diff -Nrcpad gcc-4.3.3/gcc/ada/9drpc.adb gcc-4.4.0/gcc/ada/9drpc.adb *** gcc-4.3.3/gcc/ada/9drpc.adb Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/9drpc.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.RPC is *** 81,87 **** -- or when a write procedure is executed on a full stream Partition_RPC_Receiver : RPC_Receiver; ! -- Cache the RPC_Recevier passed by Establish_RPC_Receiver type Anonymous_Task_Node; --- 79,85 ---- -- or when a write procedure is executed on a full stream Partition_RPC_Receiver : RPC_Receiver; ! -- Cache the RPC_Receiver passed by Establish_RPC_Receiver type Anonymous_Task_Node; *************** package body System.RPC is *** 155,161 **** entry Wake_Up (Request : Request_Id_Type; Length : Ada.Streams.Stream_Element_Count); ! -- To wake up the calling stub when the environnement task has -- received a reply for this request end Dispatcher; --- 153,159 ---- entry Wake_Up (Request : Request_Id_Type; Length : Ada.Streams.Stream_Element_Count); ! -- To wake up the calling stub when the environment task has -- received a reply for this request end Dispatcher; *************** package body System.RPC is *** 544,550 **** New_Result : aliased Params_Stream_Type (R_Length); begin -- Adjust the Result stream size right now to be able to load ! -- the stream in one receive call. Create a temporary resutl -- that will be substituted to Do_RPC one Streams.Allocate (New_Result); --- 542,548 ---- New_Result : aliased Params_Stream_Type (R_Length); begin -- Adjust the Result stream size right now to be able to load ! -- the stream in one receive call. Create a temporary result -- that will be substituted to Do_RPC one Streams.Allocate (New_Result); *************** package body System.RPC is *** 728,734 **** Request := Last_Request; -- << TODO >> ! -- ??? Avaibility check if Last_Request = Request_Id_Type'Last then Last_Request := Request_Id_Type'First; --- 726,732 ---- Request := Last_Request; -- << TODO >> ! -- ??? Availability check if Last_Request = Request_Id_Type'Last then Last_Request := Request_Id_Type'First; *************** package body System.RPC is *** 867,873 **** (Header'Access, Streams.Get_Stream_Size (Result'Access)); ! -- Get a protocol method to comunicate with the remote -- partition and give the message size D (D_Communication, --- 865,871 ---- (Header'Access, Streams.Get_Stream_Size (Result'Access)); ! -- Get a protocol method to communicate with the remote -- partition and give the message size D (D_Communication, *************** package body System.RPC is *** 1010,1016 **** Garbage_Collector.Allocate (Anonymous); -- We subtracted the size of the header from the size of the ! -- global message in order to provide immediatly Params size Anonymous.Element.Start (Message_Id, --- 1008,1014 ---- Garbage_Collector.Allocate (Anonymous); -- We subtracted the size of the header from the size of the ! -- global message in order to provide immediately Params size Anonymous.Element.Start (Message_Id, diff -Nrcpad gcc-4.3.3/gcc/ada/ChangeLog gcc-4.4.0/gcc/ada/ChangeLog *** gcc-4.3.3/gcc/ada/ChangeLog Sat Jan 24 10:15:46 2009 --- gcc-4.4.0/gcc/ada/ChangeLog Tue Apr 21 08:45:18 2009 *************** *** 1,29 **** ! 2009-01-24 Release Manager ! * GCC 4.3.3 released. 2009-01-11 Eric Botcazou ! * decl.c (gnat_to_gnu_entity) : Put the _Tag field ! before any discriminants in the field list. (components_to_record): Remove obsolete comment. ! 2008-12-04 Janis Johnson ! Backport from mainline: ! 2008-10-18 Jakub Jelinek ! Janis Johnson ! * Make-lang.in (check-ada-subtargets): Depend on ! check-acats-subtargets and check-gnat-subtargets. ! (check_acats_targets): New variable. ! (check-acats-subtargets, check-acats%): New targets. ! (check-acats): If -j is used and CHAPTERS is empty, run the testing ! in multiple make goals, possibly parallel, and afterwards run ! dg-extract-results.sh to merge the sum and log files. ! 2008-11-15 Bechir Zalila ! Eric Botcazou PR ada/34289 * lib.ads: (Enable_Switch_Storing): Declare. --- 1,1340 ---- ! 2009-04-21 Release Manager ! * GCC 4.4.0 released. ! ! 2009-04-09 Nick Clifton ! ! * adadecode.h: Change copyright header to refer to version ! 3 of the GNU General Public License with version 3.1 of the ! GCC Runtime Library Exception and to point readers at the ! COPYING3 and COPYING3.RUNTIME files and the FSF's license web ! page. ! * 9drpc.adb: Likewise. ! * a-assert.adb: Likewise. ! * a-astaco.adb: Likewise. ! * a-calari.adb: Likewise. ! * a-calcon.adb: Likewise. ! * a-calcon.ads: Likewise. ! * a-caldel.ads: Likewise. ! * a-calend-vms.adb: Likewise. ! * a-calend-vms.ads: Likewise. ! * a-calend.adb: Likewise. ! * a-calend.ads: Likewise. ! * a-calfor.adb: Likewise. ! * a-catizo.adb: Likewise. ! * a-cdlili.adb: Likewise. ! * a-cdlili.ads: Likewise. ! * a-cgaaso.adb: Likewise. ! * a-cgaaso.ads: Likewise. ! * a-cgarso.adb: Likewise. ! * a-cgcaso.adb: Likewise. ! * a-chacon.adb: Likewise. ! * a-chacon.ads: Likewise. ! * a-chahan.adb: Likewise. ! * a-chahan.ads: Likewise. ! * a-chlat9.ads: Likewise. ! * a-chtgke.adb: Likewise. ! * a-chtgke.ads: Likewise. ! * a-chtgop.adb: Likewise. ! * a-chtgop.ads: Likewise. ! * a-chzla1.ads: Likewise. ! * a-chzla9.ads: Likewise. ! * a-cidlli.adb: Likewise. ! * a-cidlli.ads: Likewise. ! * a-cihama.adb: Likewise. ! * a-cihama.ads: Likewise. ! * a-cihase.adb: Likewise. ! * a-cihase.ads: Likewise. ! * a-ciorma.adb: Likewise. ! * a-ciorma.ads: Likewise. ! * a-ciormu.adb: Likewise. ! * a-ciormu.ads: Likewise. ! * a-ciorse.adb: Likewise. ! * a-ciorse.ads: Likewise. ! * a-clrefi.adb: Likewise. ! * a-clrefi.ads: Likewise. ! * a-cohama.adb: Likewise. ! * a-cohama.ads: Likewise. ! * a-cohase.adb: Likewise. ! * a-cohase.ads: Likewise. ! * a-cohata.ads: Likewise. ! * a-coinve.adb: Likewise. ! * a-coinve.ads: Likewise. ! * a-colien.adb: Likewise. ! * a-colien.ads: Likewise. ! * a-colire.adb: Likewise. ! * a-colire.ads: Likewise. ! * a-comlin.adb: Likewise. ! * a-comlin.ads: Likewise. ! * a-convec.adb: Likewise. ! * a-convec.ads: Likewise. ! * a-coorma.adb: Likewise. ! * a-coorma.ads: Likewise. ! * a-coormu.adb: Likewise. ! * a-coormu.ads: Likewise. ! * a-coorse.adb: Likewise. ! * a-coorse.ads: Likewise. ! * a-coprnu.adb: Likewise. ! * a-coprnu.ads: Likewise. ! * a-crbltr.ads: Likewise. ! * a-crbtgk.adb: Likewise. ! * a-crbtgk.ads: Likewise. ! * a-crbtgo.adb: Likewise. ! * a-crbtgo.ads: Likewise. ! * a-crdlli.adb: Likewise. ! * a-crdlli.ads: Likewise. ! * a-cwila1.ads: Likewise. ! * a-cwila9.ads: Likewise. ! * a-decima.adb: Likewise. ! * a-decima.ads: Likewise. ! * a-diocst.adb: Likewise. ! * a-diocst.ads: Likewise. ! * a-direct.adb: Likewise. ! * a-direct.ads: Likewise. ! * a-direio.adb: Likewise. ! * a-direio.ads: Likewise. ! * a-dirval-mingw.adb: Likewise. ! * a-dirval-vms.adb: Likewise. ! * a-dirval.adb: Likewise. ! * a-dirval.ads: Likewise. ! * a-dynpri.adb: Likewise. ! * a-einuoc.adb: Likewise. ! * a-einuoc.ads: Likewise. ! * a-elchha.adb: Likewise. ! * a-elchha.ads: Likewise. ! * a-envvar.adb: Likewise. ! * a-excach.adb: Likewise. ! * a-except-2005.adb: Likewise. ! * a-except-2005.ads: Likewise. ! * a-except.adb: Likewise. ! * a-except.ads: Likewise. ! * a-excpol-abort.adb: Likewise. ! * a-excpol.adb: Likewise. ! * a-exctra.adb: Likewise. ! * a-exctra.ads: Likewise. ! * a-exetim-mingw.adb: Likewise. ! * a-exetim-mingw.ads: Likewise. ! * a-exexda.adb: Likewise. ! * a-exexpr-gcc.adb: Likewise. ! * a-exexpr.adb: Likewise. ! * a-exextr.adb: Likewise. ! * a-exstat.adb: Likewise. ! * a-filico.adb: Likewise. ! * a-filico.ads: Likewise. ! * a-finali.adb: Likewise. ! * a-finali.ads: Likewise. ! * a-interr.ads: Likewise. ! * a-intnam-aix.ads: Likewise. ! * a-intnam-darwin.ads: Likewise. ! * a-intnam-dummy.ads: Likewise. ! * a-intnam-freebsd.ads: Likewise. ! * a-intnam-hpux.ads: Likewise. ! * a-intnam-irix.ads: Likewise. ! * a-intnam-linux.ads: Likewise. ! * a-intnam-lynxos.ads: Likewise. ! * a-intnam-mingw.ads: Likewise. ! * a-intnam-rtems.ads: Likewise. ! * a-intnam-solaris.ads: Likewise. ! * a-intnam-tru64.ads: Likewise. ! * a-intnam-vms.ads: Likewise. ! * a-intnam-vxworks.ads: Likewise. ! * a-intsig.adb: Likewise. ! * a-intsig.ads: Likewise. ! * a-ngcefu.adb: Likewise. ! * a-ngcoar.adb: Likewise. ! * a-ngcoty.adb: Likewise. ! * a-ngcoty.ads: Likewise. ! * a-ngelfu.adb: Likewise. ! * a-ngrear.adb: Likewise. ! * a-ngrear.ads: Likewise. ! * a-nudira.adb: Likewise. ! * a-nudira.ads: Likewise. ! * a-nuflra.adb: Likewise. ! * a-nuflra.ads: Likewise. ! * a-numaux-darwin.adb: Likewise. ! * a-numaux-darwin.ads: Likewise. ! * a-numaux-libc-x86.ads: Likewise. ! * a-numaux-vxworks.ads: Likewise. ! * a-numaux-x86.adb: Likewise. ! * a-numaux-x86.ads: Likewise. ! * a-numaux.ads: Likewise. ! * a-rbtgso.adb: Likewise. ! * a-rbtgso.ads: Likewise. ! * a-reatim.ads: Likewise. ! * a-retide.adb: Likewise. ! * a-retide.ads: Likewise. ! * a-rttiev.adb: Likewise. ! * a-rttiev.ads: Likewise. ! * a-secain.adb: Likewise. ! * a-secain.ads: Likewise. ! * a-sequio.adb: Likewise. ! * a-sequio.ads: Likewise. ! * a-shcain.adb: Likewise. ! * a-shcain.ads: Likewise. ! * a-siocst.adb: Likewise. ! * a-siocst.ads: Likewise. ! * a-slcain.adb: Likewise. ! * a-slcain.ads: Likewise. ! * a-ssicst.adb: Likewise. ! * a-ssicst.ads: Likewise. ! * a-stboha.adb: Likewise. ! * a-stmaco.ads: Likewise. ! * a-storio.adb: Likewise. ! * a-strbou.adb: Likewise. ! * a-strbou.ads: Likewise. ! * a-stream.ads: Likewise. ! * a-strfix.adb: Likewise. ! * a-strhas.adb: Likewise. ! * a-strmap.adb: Likewise. ! * a-strmap.ads: Likewise. ! * a-strsea.adb: Likewise. ! * a-strsea.ads: Likewise. ! * a-strsup.adb: Likewise. ! * a-strsup.ads: Likewise. ! * a-strunb.adb: Likewise. ! * a-strunb.ads: Likewise. ! * a-ststio.adb: Likewise. ! * a-ststio.ads: Likewise. ! * a-stunau.adb: Likewise. ! * a-stunau.ads: Likewise. ! * a-stunha.adb: Likewise. ! * a-stwibo.adb: Likewise. ! * a-stwibo.ads: Likewise. ! * a-stwifi.adb: Likewise. ! * a-stwiha.adb: Likewise. ! * a-stwima.adb: Likewise. ! * a-stwima.ads: Likewise. ! * a-stwise.adb: Likewise. ! * a-stwise.ads: Likewise. ! * a-stwisu.adb: Likewise. ! * a-stwisu.ads: Likewise. ! * a-stwiun.adb: Likewise. ! * a-stwiun.ads: Likewise. ! * a-stzbou.adb: Likewise. ! * a-stzbou.ads: Likewise. ! * a-stzfix.adb: Likewise. ! * a-stzhas.adb: Likewise. ! * a-stzmap.adb: Likewise. ! * a-stzmap.ads: Likewise. ! * a-stzsea.adb: Likewise. ! * a-stzsea.ads: Likewise. ! * a-stzsup.adb: Likewise. ! * a-stzsup.ads: Likewise. ! * a-stzunb.adb: Likewise. ! * a-stzunb.ads: Likewise. ! * a-suteio.adb: Likewise. ! * a-suteio.ads: Likewise. ! * a-swbwha.adb: Likewise. ! * a-swmwco.ads: Likewise. ! * a-swunau.adb: Likewise. ! * a-swunau.ads: Likewise. ! * a-swuwha.adb: Likewise. ! * a-swuwti.adb: Likewise. ! * a-swuwti.ads: Likewise. ! * a-sytaco.adb: Likewise. ! * a-sytaco.ads: Likewise. ! * a-szbzha.adb: Likewise. ! * a-szmzco.ads: Likewise. ! * a-szunau.adb: Likewise. ! * a-szunau.ads: Likewise. ! * a-szuzha.adb: Likewise. ! * a-szuzti.adb: Likewise. ! * a-szuzti.ads: Likewise. ! * a-tags.adb: Likewise. ! * a-tags.ads: Likewise. ! * a-tasatt.ads: Likewise. ! * a-taside.adb: Likewise. ! * a-taside.ads: Likewise. ! * a-taster.adb: Likewise. ! * a-teioed.adb: Likewise. ! * a-teioed.ads: Likewise. ! * a-textio.adb: Likewise. ! * a-textio.ads: Likewise. ! * a-tiboio.adb: Likewise. ! * a-ticoau.adb: Likewise. ! * a-ticoau.ads: Likewise. ! * a-ticoio.adb: Likewise. ! * a-ticoio.ads: Likewise. ! * a-tideau.adb: Likewise. ! * a-tideau.ads: Likewise. ! * a-tideio.adb: Likewise. ! * a-tideio.ads: Likewise. ! * a-tienau.adb: Likewise. ! * a-tienau.ads: Likewise. ! * a-tienio.adb: Likewise. ! * a-tienio.ads: Likewise. ! * a-tifiio.adb: Likewise. ! * a-tifiio.ads: Likewise. ! * a-tiflau.adb: Likewise. ! * a-tiflau.ads: Likewise. ! * a-tiflio.adb: Likewise. ! * a-tiflio.ads: Likewise. ! * a-tigeau.adb: Likewise. ! * a-tigeau.ads: Likewise. ! * a-tiinau.adb: Likewise. ! * a-tiinau.ads: Likewise. ! * a-tiinio.adb: Likewise. ! * a-tiinio.ads: Likewise. ! * a-timoau.adb: Likewise. ! * a-timoau.ads: Likewise. ! * a-timoio.adb: Likewise. ! * a-timoio.ads: Likewise. ! * a-tiocst.adb: Likewise. ! * a-tiocst.ads: Likewise. ! * a-titest.adb: Likewise. ! * a-wichun.adb: Likewise. ! * a-wichun.ads: Likewise. ! * a-witeio.adb: Likewise. ! * a-witeio.ads: Likewise. ! * a-wtcoau.adb: Likewise. ! * a-wtcoau.ads: Likewise. ! * a-wtcoio.adb: Likewise. ! * a-wtcstr.adb: Likewise. ! * a-wtcstr.ads: Likewise. ! * a-wtdeau.adb: Likewise. ! * a-wtdeau.ads: Likewise. ! * a-wtdeio.adb: Likewise. ! * a-wtdeio.ads: Likewise. ! * a-wtedit.adb: Likewise. ! * a-wtedit.ads: Likewise. ! * a-wtenau.adb: Likewise. ! * a-wtenau.ads: Likewise. ! * a-wtenio.adb: Likewise. ! * a-wtenio.ads: Likewise. ! * a-wtfiio.adb: Likewise. ! * a-wtfiio.ads: Likewise. ! * a-wtflau.adb: Likewise. ! * a-wtflau.ads: Likewise. ! * a-wtflio.adb: Likewise. ! * a-wtflio.ads: Likewise. ! * a-wtgeau.adb: Likewise. ! * a-wtgeau.ads: Likewise. ! * a-wtinau.adb: Likewise. ! * a-wtinau.ads: Likewise. ! * a-wtinio.adb: Likewise. ! * a-wtmoau.adb: Likewise. ! * a-wtmoau.ads: Likewise. ! * a-wtmoio.adb: Likewise. ! * a-wtmoio.ads: Likewise. ! * a-wttest.adb: Likewise. ! * a-wwboio.adb: Likewise. ! * a-zchuni.adb: Likewise. ! * a-zchuni.ads: Likewise. ! * a-ztcoau.adb: Likewise. ! * a-ztcoau.ads: Likewise. ! * a-ztcoio.adb: Likewise. ! * a-ztcstr.adb: Likewise. ! * a-ztcstr.ads: Likewise. ! * a-ztdeau.adb: Likewise. ! * a-ztdeau.ads: Likewise. ! * a-ztdeio.adb: Likewise. ! * a-ztdeio.ads: Likewise. ! * a-ztedit.adb: Likewise. ! * a-ztedit.ads: Likewise. ! * a-ztenau.adb: Likewise. ! * a-ztenau.ads: Likewise. ! * a-ztenio.adb: Likewise. ! * a-ztenio.ads: Likewise. ! * a-ztexio.adb: Likewise. ! * a-ztexio.ads: Likewise. ! * a-ztfiio.adb: Likewise. ! * a-ztfiio.ads: Likewise. ! * a-ztflau.adb: Likewise. ! * a-ztflau.ads: Likewise. ! * a-ztflio.adb: Likewise. ! * a-ztflio.ads: Likewise. ! * a-ztgeau.adb: Likewise. ! * a-ztgeau.ads: Likewise. ! * a-ztinau.adb: Likewise. ! * a-ztinau.ads: Likewise. ! * a-ztinio.adb: Likewise. ! * a-ztmoau.adb: Likewise. ! * a-ztmoau.ads: Likewise. ! * a-ztmoio.adb: Likewise. ! * a-ztmoio.ads: Likewise. ! * a-zttest.adb: Likewise. ! * a-zzboio.adb: Likewise. ! * adadecode.c: Likewise. ! * adaint.c: Likewise. ! * adaint.h: Likewise. ! * alloc.ads: Likewise. ! * argv.c: Likewise. ! * arit64.c: Likewise. ! * atree.adb: Likewise. ! * atree.ads: Likewise. ! * aux-io.c: Likewise. ! * cal.c: Likewise. ! * casing.adb: Likewise. ! * casing.ads: Likewise. ! * cio.c: Likewise. ! * csets.adb: Likewise. ! * csets.ads: Likewise. ! * cstreams.c: Likewise. ! * ctrl_c.c: Likewise. ! * debug.adb: Likewise. ! * debug.ads: Likewise. ! * dec.ads: Likewise. ! * einfo.adb: Likewise. ! * einfo.ads: Likewise. ! * elists.adb: Likewise. ! * elists.ads: Likewise. ! * env.c: Likewise. ! * env.h: Likewise. ! * errno.c: Likewise. ! * exit.c: Likewise. ! * fe.h: Likewise. ! * final.c: Likewise. ! * fname.adb: Likewise. ! * fname.ads: Likewise. ! * g-allein.ads: Likewise. ! * g-alleve.adb: Likewise. ! * g-alleve.ads: Likewise. ! * g-altcon.adb: Likewise. ! * g-altcon.ads: Likewise. ! * g-altive.ads: Likewise. ! * g-alveop.adb: Likewise. ! * g-alveop.ads: Likewise. ! * g-alvety.ads: Likewise. ! * g-alvevi.ads: Likewise. ! * g-arrspl.adb: Likewise. ! * g-arrspl.ads: Likewise. ! * g-calend.ads: Likewise. ! * g-comlin.adb: Likewise. ! * g-debpoo.adb: Likewise. ! * g-debpoo.ads: Likewise. ! * g-eacodu-vms.adb: Likewise. ! * g-eacodu.adb: Likewise. ! * g-excact.adb: Likewise. ! * g-excact.ads: Likewise. ! * g-locfil.adb: Likewise. ! * g-os_lib.ads: Likewise. ! * g-rannum.adb: Likewise. ! * g-rannum.ads: Likewise. ! * g-regist.adb: Likewise. ! * g-regist.ads: Likewise. ! * g-signal.adb: Likewise. ! * g-signal.ads: Likewise. ! * g-soccon.ads: Likewise. ! * g-string.adb: Likewise. ! * g-string.ads: Likewise. ! * g-strspl.ads: Likewise. ! * g-timsta.adb: Likewise. ! * g-timsta.ads: Likewise. ! * g-trasym-vms-alpha.adb: Likewise. ! * g-trasym-vms-ia64.adb: Likewise. ! * g-utf_32.adb: Likewise. ! * g-utf_32.ads: Likewise. ! * g-wistsp.ads: Likewise. ! * g-zstspl.ads: Likewise. ! * gmem.c: Likewise. ! * gnatvsn.adb: Likewise. ! * gnatvsn.ads: Likewise. ! * gsocket.h: Likewise. ! * hostparm.ads: Likewise. ! * i-c.adb: Likewise. ! * i-cexten.ads: Likewise. ! * i-cobol.adb: Likewise. ! * i-cobol.ads: Likewise. ! * i-cpoint.adb: Likewise. ! * i-cpoint.ads: Likewise. ! * i-cpp.adb: Likewise. ! * i-cpp.ads: Likewise. ! * i-cstrea-vms.adb: Likewise. ! * i-cstrea.adb: Likewise. ! * i-cstrea.ads: Likewise. ! * i-cstrin.adb: Likewise. ! * i-cstrin.ads: Likewise. ! * i-forbla-darwin.adb: Likewise. ! * i-forbla-unimplemented.ads: Likewise. ! * i-forbla.adb: Likewise. ! * i-forbla.ads: Likewise. ! * i-forlap.ads: Likewise. ! * i-fortra.adb: Likewise. ! * i-pacdec.adb: Likewise. ! * i-pacdec.ads: Likewise. ! * i-vxwoio.adb: Likewise. ! * i-vxwoio.ads: Likewise. ! * indepsw-aix.adb: Likewise. ! * indepsw-gnu.adb: Likewise. ! * indepsw-mingw.adb: Likewise. ! * indepsw.adb: Likewise. ! * indepsw.ads: Likewise. ! * init.c: Likewise. ! * initialize.c: Likewise. ! * interfac.ads: Likewise. ! * krunch.adb: Likewise. ! * krunch.ads: Likewise. ! * lib-list.adb: Likewise. ! * lib-sort.adb: Likewise. ! * lib.adb: Likewise. ! * lib.ads: Likewise. ! * link.c: Likewise. ! * math_lib.adb: Likewise. ! * memtrack.adb: Likewise. ! * mingw32.h: Likewise. ! * mkdir.c: Likewise. ! * namet-sp.adb: Likewise. ! * namet-sp.ads: Likewise. ! * namet.adb: Likewise. ! * namet.ads: Likewise. ! * nlists.adb: Likewise. ! * nlists.ads: Likewise. ! * opt.adb: Likewise. ! * opt.ads: Likewise. ! * output.adb: Likewise. ! * output.ads: Likewise. ! * raise-gcc.c: Likewise. ! * raise.c: Likewise. ! * raise.h: Likewise. ! * repinfo.adb: Likewise. ! * repinfo.ads: Likewise. ! * repinfo.h: Likewise. ! * rident.ads: Likewise. ! * s-addima.adb: Likewise. ! * s-addima.ads: Likewise. ! * s-addope.adb: Likewise. ! * s-addope.ads: Likewise. ! * s-arit64.adb: Likewise. ! * s-arit64.ads: Likewise. ! * s-assert.adb: Likewise. ! * s-assert.ads: Likewise. ! * s-asthan-vms-alpha.adb: Likewise. ! * s-asthan.adb: Likewise. ! * s-asthan.ads: Likewise. ! * s-atacco.adb: Likewise. ! * s-atacco.ads: Likewise. ! * s-auxdec-empty.adb: Likewise. ! * s-auxdec-empty.ads: Likewise. ! * s-auxdec-vms_64.ads: Likewise. ! * s-auxdec.adb: Likewise. ! * s-auxdec.ads: Likewise. ! * s-bitops.adb: Likewise. ! * s-bitops.ads: Likewise. ! * s-boarop.ads: Likewise. ! * s-carsi8.adb: Likewise. ! * s-carsi8.ads: Likewise. ! * s-carun8.adb: Likewise. ! * s-carun8.ads: Likewise. ! * s-casi16.adb: Likewise. ! * s-casi16.ads: Likewise. ! * s-casi32.adb: Likewise. ! * s-casi32.ads: Likewise. ! * s-casi64.adb: Likewise. ! * s-casi64.ads: Likewise. ! * s-casuti.ads: Likewise. ! * s-caun16.adb: Likewise. ! * s-caun16.ads: Likewise. ! * s-caun32.adb: Likewise. ! * s-caun32.ads: Likewise. ! * s-caun64.adb: Likewise. ! * s-caun64.ads: Likewise. ! * s-chepoo.ads: Likewise. ! * s-crc32.adb: Likewise. ! * s-crc32.ads: Likewise. ! * s-crtl.ads: Likewise. ! * s-direio.adb: Likewise. ! * s-direio.ads: Likewise. ! * s-dsaser.ads: Likewise. ! * s-except.adb: Likewise. ! * s-except.ads: Likewise. ! * s-exctab.adb: Likewise. ! * s-exctab.ads: Likewise. ! * s-exnint.adb: Likewise. ! * s-exnint.ads: Likewise. ! * s-exnllf.adb: Likewise. ! * s-exnllf.ads: Likewise. ! * s-exnlli.adb: Likewise. ! * s-exnlli.ads: Likewise. ! * s-expint.adb: Likewise. ! * s-expint.ads: Likewise. ! * s-explli.adb: Likewise. ! * s-explli.ads: Likewise. ! * s-expllu.adb: Likewise. ! * s-expllu.ads: Likewise. ! * s-expmod.adb: Likewise. ! * s-expmod.ads: Likewise. ! * s-expuns.adb: Likewise. ! * s-expuns.ads: Likewise. ! * s-fatflt.ads: Likewise. ! * s-fatgen.adb: Likewise. ! * s-fatgen.ads: Likewise. ! * s-fatlfl.ads: Likewise. ! * s-fatllf.ads: Likewise. ! * s-fatsfl.ads: Likewise. ! * s-ficobl.ads: Likewise. ! * s-fileio.adb: Likewise. ! * s-fileio.ads: Likewise. ! * s-filofl.ads: Likewise. ! * s-finimp.adb: Likewise. ! * s-finimp.ads: Likewise. ! * s-finroo.adb: Likewise. ! * s-finroo.ads: Likewise. ! * s-fishfl.ads: Likewise. ! * s-fore.adb: Likewise. ! * s-fore.ads: Likewise. ! * s-fvadfl.ads: Likewise. ! * s-fvaffl.ads: Likewise. ! * s-fvagfl.ads: Likewise. ! * s-gearop.adb: Likewise. ! * s-gearop.ads: Likewise. ! * s-gecobl.adb: Likewise. ! * s-gecobl.ads: Likewise. ! * s-gecola.adb: Likewise. ! * s-gecola.ads: Likewise. ! * s-gerebl.adb: Likewise. ! * s-gerebl.ads: Likewise. ! * s-gerela.adb: Likewise. ! * s-gerela.ads: Likewise. ! * s-geveop.adb: Likewise. ! * s-geveop.ads: Likewise. ! * s-gloloc.adb: Likewise. ! * s-gloloc.ads: Likewise. ! * s-hibaen.ads: Likewise. ! * s-imenne.adb: Likewise. ! * s-imenne.ads: Likewise. ! * s-imgbiu.adb: Likewise. ! * s-imgbiu.ads: Likewise. ! * s-imgboo.adb: Likewise. ! * s-imgboo.ads: Likewise. ! * s-imgcha.adb: Likewise. ! * s-imgcha.ads: Likewise. ! * s-imgdec.adb: Likewise. ! * s-imgdec.ads: Likewise. ! * s-imgenu.adb: Likewise. ! * s-imgenu.ads: Likewise. ! * s-imgint.adb: Likewise. ! * s-imgint.ads: Likewise. ! * s-imgllb.adb: Likewise. ! * s-imgllb.ads: Likewise. ! * s-imglld.adb: Likewise. ! * s-imglld.ads: Likewise. ! * s-imglli.adb: Likewise. ! * s-imglli.ads: Likewise. ! * s-imgllu.adb: Likewise. ! * s-imgllu.ads: Likewise. ! * s-imgllw.adb: Likewise. ! * s-imgllw.ads: Likewise. ! * s-imgrea.adb: Likewise. ! * s-imgrea.ads: Likewise. ! * s-imguns.adb: Likewise. ! * s-imguns.ads: Likewise. ! * s-imgwch.adb: Likewise. ! * s-imgwch.ads: Likewise. ! * s-imgwiu.adb: Likewise. ! * s-imgwiu.ads: Likewise. ! * s-inmaop-dummy.adb: Likewise. ! * s-inmaop-vms.adb: Likewise. ! * s-inmaop.ads: Likewise. ! * s-interr-hwint.adb: Likewise. ! * s-interr-sigaction.adb: Likewise. ! * s-interr-vms.adb: Likewise. ! * s-interr.adb: Likewise. ! * s-interr.ads: Likewise. ! * s-intman-dummy.adb: Likewise. ! * s-intman-mingw.adb: Likewise. ! * s-intman-posix.adb: Likewise. ! * s-intman-solaris.adb: Likewise. ! * s-intman-vms.adb: Likewise. ! * s-intman-vms.ads: Likewise. ! * s-intman-vxworks.adb: Likewise. ! * s-intman-vxworks.ads: Likewise. ! * s-intman.ads: Likewise. ! * s-io.adb: Likewise. ! * s-io.ads: Likewise. ! * s-linux-alpha.ads: Likewise. ! * s-linux-hppa.ads: Likewise. ! * s-linux.ads: Likewise. ! * s-maccod.ads: Likewise. ! * s-mantis.adb: Likewise. ! * s-mantis.ads: Likewise. ! * s-mastop-irix.adb: Likewise. ! * s-mastop.adb: Likewise. ! * s-mastop.ads: Likewise. ! * s-memcop.ads: Likewise. ! * s-memory-mingw.adb: Likewise. ! * s-memory.adb: Likewise. ! * s-memory.ads: Likewise. ! * s-os_lib.ads: Likewise. ! * s-oscons-tmplt.c: Likewise. ! * s-osinte-aix.adb: Likewise. ! * s-osinte-darwin.adb: Likewise. ! * s-osinte-freebsd.adb: Likewise. ! * s-osinte-irix.adb: Likewise. ! * s-osinte-lynxos-3.adb: Likewise. ! * s-osinte-rtems.ads: Likewise. ! * s-osinte-tru64.adb: Likewise. ! * s-osinte-vxworks-kernel.adb: Likewise. ! * s-osinte-vxworks.adb: Likewise. ! * s-osprim-mingw.adb: Likewise. ! * s-osprim-posix.adb: Likewise. ! * s-osprim-solaris.adb: Likewise. ! * s-osprim-unix.adb: Likewise. ! * s-osprim-vms.adb: Likewise. ! * s-osprim-vms.ads: Likewise. ! * s-osprim-vxworks.adb: Likewise. ! * s-osprim.ads: Likewise. ! * s-pack03.adb: Likewise. ! * s-pack03.ads: Likewise. ! * s-pack05.adb: Likewise. ! * s-pack05.ads: Likewise. ! * s-pack06.adb: Likewise. ! * s-pack06.ads: Likewise. ! * s-pack07.adb: Likewise. ! * s-pack07.ads: Likewise. ! * s-pack09.adb: Likewise. ! * s-pack09.ads: Likewise. ! * s-pack10.adb: Likewise. ! * s-pack10.ads: Likewise. ! * s-pack11.adb: Likewise. ! * s-pack11.ads: Likewise. ! * s-pack12.adb: Likewise. ! * s-pack12.ads: Likewise. ! * s-pack13.adb: Likewise. ! * s-pack13.ads: Likewise. ! * s-pack14.adb: Likewise. ! * s-pack14.ads: Likewise. ! * s-pack15.adb: Likewise. ! * s-pack15.ads: Likewise. ! * s-pack17.adb: Likewise. ! * s-pack17.ads: Likewise. ! * s-pack18.adb: Likewise. ! * s-pack18.ads: Likewise. ! * s-pack19.adb: Likewise. ! * s-pack19.ads: Likewise. ! * s-pack20.adb: Likewise. ! * s-pack20.ads: Likewise. ! * s-pack21.adb: Likewise. ! * s-pack21.ads: Likewise. ! * s-pack22.adb: Likewise. ! * s-pack22.ads: Likewise. ! * s-pack23.adb: Likewise. ! * s-pack23.ads: Likewise. ! * s-pack24.adb: Likewise. ! * s-pack24.ads: Likewise. ! * s-pack25.adb: Likewise. ! * s-pack25.ads: Likewise. ! * s-pack26.adb: Likewise. ! * s-pack26.ads: Likewise. ! * s-pack27.adb: Likewise. ! * s-pack27.ads: Likewise. ! * s-pack28.adb: Likewise. ! * s-pack28.ads: Likewise. ! * s-pack29.adb: Likewise. ! * s-pack29.ads: Likewise. ! * s-pack30.adb: Likewise. ! * s-pack30.ads: Likewise. ! * s-pack31.adb: Likewise. ! * s-pack31.ads: Likewise. ! * s-pack33.adb: Likewise. ! * s-pack33.ads: Likewise. ! * s-pack34.adb: Likewise. ! * s-pack34.ads: Likewise. ! * s-pack35.adb: Likewise. ! * s-pack35.ads: Likewise. ! * s-pack36.adb: Likewise. ! * s-pack36.ads: Likewise. ! * s-pack37.adb: Likewise. ! * s-pack37.ads: Likewise. ! * s-pack38.adb: Likewise. ! * s-pack38.ads: Likewise. ! * s-pack39.adb: Likewise. ! * s-pack39.ads: Likewise. ! * s-pack40.adb: Likewise. ! * s-pack40.ads: Likewise. ! * s-pack41.adb: Likewise. ! * s-pack41.ads: Likewise. ! * s-pack42.adb: Likewise. ! * s-pack42.ads: Likewise. ! * s-pack43.adb: Likewise. ! * s-pack43.ads: Likewise. ! * s-pack44.adb: Likewise. ! * s-pack44.ads: Likewise. ! * s-pack45.adb: Likewise. ! * s-pack45.ads: Likewise. ! * s-pack46.adb: Likewise. ! * s-pack46.ads: Likewise. ! * s-pack47.adb: Likewise. ! * s-pack47.ads: Likewise. ! * s-pack48.adb: Likewise. ! * s-pack48.ads: Likewise. ! * s-pack49.adb: Likewise. ! * s-pack49.ads: Likewise. ! * s-pack50.adb: Likewise. ! * s-pack50.ads: Likewise. ! * s-pack51.adb: Likewise. ! * s-pack51.ads: Likewise. ! * s-pack52.adb: Likewise. ! * s-pack52.ads: Likewise. ! * s-pack53.adb: Likewise. ! * s-pack53.ads: Likewise. ! * s-pack54.adb: Likewise. ! * s-pack54.ads: Likewise. ! * s-pack55.adb: Likewise. ! * s-pack55.ads: Likewise. ! * s-pack56.adb: Likewise. ! * s-pack56.ads: Likewise. ! * s-pack57.adb: Likewise. ! * s-pack57.ads: Likewise. ! * s-pack58.adb: Likewise. ! * s-pack58.ads: Likewise. ! * s-pack59.adb: Likewise. ! * s-pack59.ads: Likewise. ! * s-pack60.adb: Likewise. ! * s-pack60.ads: Likewise. ! * s-pack61.adb: Likewise. ! * s-pack61.ads: Likewise. ! * s-pack62.adb: Likewise. ! * s-pack62.ads: Likewise. ! * s-pack63.adb: Likewise. ! * s-pack63.ads: Likewise. ! * s-parame-ae653.ads: Likewise. ! * s-parame-hpux.ads: Likewise. ! * s-parame-rtems.adb: Likewise. ! * s-parame-vms-alpha.ads: Likewise. ! * s-parame-vms-ia64.ads: Likewise. ! * s-parame-vms-restrict.ads: Likewise. ! * s-parame-vxworks.adb: Likewise. ! * s-parame-vxworks.ads: Likewise. ! * s-parame.adb: Likewise. ! * s-parame.ads: Likewise. ! * s-parint.adb: Likewise. ! * s-parint.ads: Likewise. ! * s-pooglo.adb: Likewise. ! * s-pooglo.ads: Likewise. ! * s-pooloc.adb: Likewise. ! * s-pooloc.ads: Likewise. ! * s-poosiz.adb: Likewise. ! * s-poosiz.ads: Likewise. ! * s-powtab.ads: Likewise. ! * s-proinf-irix-athread.adb: Likewise. ! * s-proinf-irix-athread.ads: Likewise. ! * s-proinf.adb: Likewise. ! * s-proinf.ads: Likewise. ! * s-purexc.ads: Likewise. ! * s-rannum.adb: Likewise. ! * s-rannum.ads: Likewise. ! * s-restri.adb: Likewise. ! * s-restri.ads: Likewise. ! * s-rident.ads: Likewise. ! * s-rpc.adb: Likewise. ! * s-rpc.ads: Likewise. ! * s-scaval.adb: Likewise. ! * s-scaval.ads: Likewise. ! * s-secsta.adb: Likewise. ! * s-secsta.ads: Likewise. ! * s-sequio.adb: Likewise. ! * s-sequio.ads: Likewise. ! * s-shasto.adb: Likewise. ! * s-shasto.ads: Likewise. ! * s-soflin.adb: Likewise. ! * s-soflin.ads: Likewise. ! * s-solita.adb: Likewise. ! * s-solita.ads: Likewise. ! * s-sopco3.adb: Likewise. ! * s-sopco3.ads: Likewise. ! * s-sopco4.adb: Likewise. ! * s-sopco4.ads: Likewise. ! * s-sopco5.adb: Likewise. ! * s-sopco5.ads: Likewise. ! * s-stache.adb: Likewise. ! * s-stache.ads: Likewise. ! * s-stalib.adb: Likewise. ! * s-stalib.ads: Likewise. ! * s-stausa.adb: Likewise. ! * s-stausa.ads: Likewise. ! * s-stchop-limit.ads: Likewise. ! * s-stchop-rtems.adb: Likewise. ! * s-stchop-vxworks.adb: Likewise. ! * s-stchop.adb: Likewise. ! * s-stchop.ads: Likewise. ! * s-stoele.adb: Likewise. ! * s-stoele.ads: Likewise. ! * s-stopoo.adb: Likewise. ! * s-stopoo.ads: Likewise. ! * s-stratt.adb: Likewise. ! * s-stratt.ads: Likewise. ! * s-strcom.adb: Likewise. ! * s-strcom.ads: Likewise. ! * s-string.adb: Likewise. ! * s-string.ads: Likewise. ! * s-strops.adb: Likewise. ! * s-strops.ads: Likewise. ! * s-strxdr.adb: Likewise. ! * s-ststop.adb: Likewise. ! * s-ststop.ads: Likewise. ! * s-taasde.adb: Likewise. ! * s-taasde.ads: Likewise. ! * s-tadeca.adb: Likewise. ! * s-tadeca.ads: Likewise. ! * s-tadert.adb: Likewise. ! * s-tadert.ads: Likewise. ! * s-taenca.adb: Likewise. ! * s-taenca.ads: Likewise. ! * s-taprob.ads: Likewise. ! * s-taprop-dummy.adb: Likewise. ! * s-taprop-hpux-dce.adb: Likewise. ! * s-taprop-irix.adb: Likewise. ! * s-taprop-linux.adb: Likewise. ! * s-taprop-lynxos.adb: Likewise. ! * s-taprop-mingw.adb: Likewise. ! * s-taprop-posix.adb: Likewise. ! * s-taprop-solaris.adb: Likewise. ! * s-taprop-tru64.adb: Likewise. ! * s-taprop-vms.adb: Likewise. ! * s-taprop-vxworks.adb: Likewise. ! * s-taprop.ads: Likewise. ! * s-tarest.adb: Likewise. ! * s-tarest.ads: Likewise. ! * s-tasdeb.adb: Likewise. ! * s-tasdeb.ads: Likewise. ! * s-tasinf-irix.ads: Likewise. ! * s-tasinf-linux.adb: Likewise. ! * s-tasinf-linux.ads: Likewise. ! * s-tasinf-mingw.adb: Likewise. ! * s-tasinf-mingw.ads: Likewise. ! * s-tasinf-solaris.adb: Likewise. ! * s-tasinf-solaris.ads: Likewise. ! * s-tasinf-tru64.ads: Likewise. ! * s-tasinf.adb: Likewise. ! * s-tasinf.ads: Likewise. ! * s-tasini.adb: Likewise. ! * s-tasini.ads: Likewise. ! * s-taskin.adb: Likewise. ! * s-taskin.ads: Likewise. ! * s-taspri-dummy.ads: Likewise. ! * s-taspri-hpux-dce.ads: Likewise. ! * s-taspri-mingw.ads: Likewise. ! * s-taspri-solaris.ads: Likewise. ! * s-taspri-tru64.ads: Likewise. ! * s-taspri-vms.ads: Likewise. ! * s-taspri-vxworks.ads: Likewise. ! * s-tasque.adb: Likewise. ! * s-tasque.ads: Likewise. ! * s-tasren.adb: Likewise. ! * s-tasren.ads: Likewise. ! * s-tasres.ads: Likewise. ! * s-tassta.adb: Likewise. ! * s-tassta.ads: Likewise. ! * s-tasuti.adb: Likewise. ! * s-tasuti.ads: Likewise. ! * s-tfsetr-default.adb: Likewise. ! * s-tfsetr-vxworks.adb: Likewise. ! * s-tpinop.adb: Likewise. ! * s-tpinop.ads: Likewise. ! * s-tpoben.adb: Likewise. ! * s-tpoben.ads: Likewise. ! * s-tpobop.adb: Likewise. ! * s-tpobop.ads: Likewise. ! * s-tpopde-vms.adb: Likewise. ! * s-tpopde-vms.ads: Likewise. ! * s-tpopsp-lynxos.adb: Likewise. ! * s-tpopsp-posix-foreign.adb: Likewise. ! * s-tpopsp-posix.adb: Likewise. ! * s-tpopsp-solaris.adb: Likewise. ! * s-tpopsp-vxworks.adb: Likewise. ! * s-tporft.adb: Likewise. ! * s-tposen.adb: Likewise. ! * s-tposen.ads: Likewise. ! * s-traceb.adb: Likewise. ! * s-traceb.ads: Likewise. ! * s-traces-default.adb: Likewise. ! * s-traces.adb: Likewise. ! * s-traces.ads: Likewise. ! * s-traent-vms.adb: Likewise. ! * s-traent-vms.ads: Likewise. ! * s-traent.adb: Likewise. ! * s-traent.ads: Likewise. ! * s-trafor-default.adb: Likewise. ! * s-trafor-default.ads: Likewise. ! * s-tratas-default.adb: Likewise. ! * s-tratas.adb: Likewise. ! * s-tratas.ads: Likewise. ! * s-unstyp.ads: Likewise. ! * s-utf_32.adb: Likewise. ! * s-utf_32.ads: Likewise. ! * s-vaflop-vms-alpha.adb: Likewise. ! * s-vaflop.adb: Likewise. ! * s-vaflop.ads: Likewise. ! * s-valboo.adb: Likewise. ! * s-valboo.ads: Likewise. ! * s-valcha.adb: Likewise. ! * s-valcha.ads: Likewise. ! * s-valdec.adb: Likewise. ! * s-valdec.ads: Likewise. ! * s-valenu.adb: Likewise. ! * s-valenu.ads: Likewise. ! * s-valint.adb: Likewise. ! * s-valint.ads: Likewise. ! * s-vallld.adb: Likewise. ! * s-vallld.ads: Likewise. ! * s-vallli.adb: Likewise. ! * s-vallli.ads: Likewise. ! * s-valllu.adb: Likewise. ! * s-valllu.ads: Likewise. ! * s-valrea.adb: Likewise. ! * s-valrea.ads: Likewise. ! * s-valuns.adb: Likewise. ! * s-valuns.ads: Likewise. ! * s-valuti.adb: Likewise. ! * s-valuti.ads: Likewise. ! * s-valwch.adb: Likewise. ! * s-valwch.ads: Likewise. ! * s-veboop.adb: Likewise. ! * s-veboop.ads: Likewise. ! * s-vector.ads: Likewise. ! * s-vercon.adb: Likewise. ! * s-vercon.ads: Likewise. ! * s-vmexta.adb: Likewise. ! * s-vmexta.ads: Likewise. ! * s-vxwext-kernel.ads: Likewise. ! * s-vxwext-rtp.adb: Likewise. ! * s-vxwext-rtp.ads: Likewise. ! * s-vxwext.ads: Likewise. ! * s-vxwork-arm.ads: Likewise. ! * s-vxwork-m68k.ads: Likewise. ! * s-vxwork-mips.ads: Likewise. ! * s-vxwork-ppc.ads: Likewise. ! * s-vxwork-sparcv9.ads: Likewise. ! * s-vxwork-x86.ads: Likewise. ! * s-wchcnv.adb: Likewise. ! * s-wchcnv.ads: Likewise. ! * s-wchcon.adb: Likewise. ! * s-wchcon.ads: Likewise. ! * s-wchjis.adb: Likewise. ! * s-wchjis.ads: Likewise. ! * s-wchstw.adb: Likewise. ! * s-wchstw.ads: Likewise. ! * s-wchwts.adb: Likewise. ! * s-wchwts.ads: Likewise. ! * s-widboo.adb: Likewise. ! * s-widboo.ads: Likewise. ! * s-widcha.adb: Likewise. ! * s-widcha.ads: Likewise. ! * s-widenu.adb: Likewise. ! * s-widenu.ads: Likewise. ! * s-widlli.adb: Likewise. ! * s-widlli.ads: Likewise. ! * s-widllu.adb: Likewise. ! * s-widllu.ads: Likewise. ! * s-widwch.adb: Likewise. ! * s-widwch.ads: Likewise. ! * s-win32.ads: Likewise. ! * s-winext.ads: Likewise. ! * s-wwdcha.adb: Likewise. ! * s-wwdcha.ads: Likewise. ! * s-wwdenu.adb: Likewise. ! * s-wwdenu.ads: Likewise. ! * s-wwdwch.adb: Likewise. ! * s-wwdwch.ads: Likewise. ! * scans.adb: Likewise. ! * scans.ads: Likewise. ! * seh_init.c: Likewise. ! * sfn_scan.adb: Likewise. ! * sinfo.adb: Likewise. ! * sinfo.ads: Likewise. ! * sinput.adb: Likewise. ! * sinput.ads: Likewise. ! * snames.adb: Likewise. ! * snames.ads: Likewise. ! * socket.c: Likewise. ! * stand.adb: Likewise. ! * stand.ads: Likewise. ! * stringt.adb: Likewise. ! * stringt.ads: Likewise. ! * sysdep.c: Likewise. ! * system-aix.ads: Likewise. ! * system-darwin-ppc.ads: Likewise. ! * system-darwin-x86.ads: Likewise. ! * system-darwin-x86_64.ads: Likewise. ! * system-freebsd-x86.ads: Likewise. ! * system-hpux-ia64.ads: Likewise. ! * system-hpux.ads: Likewise. ! * system-irix-n32.ads: Likewise. ! * system-irix-n64.ads: Likewise. ! * system-irix-o32.ads: Likewise. ! * system-linux-alpha.ads: Likewise. ! * system-linux-hppa.ads: Likewise. ! * system-linux-ia64.ads: Likewise. ! * system-linux-mips.ads: Likewise. ! * system-linux-mipsel.ads: Likewise. ! * system-linux-ppc.ads: Likewise. ! * system-linux-ppc64.ads: Likewise. ! * system-linux-s390.ads: Likewise. ! * system-linux-s390x.ads: Likewise. ! * system-linux-sh4.ads: Likewise. ! * system-linux-sparc.ads: Likewise. ! * system-linux-sparcv9.ads: Likewise. ! * system-linux-x86.ads: Likewise. ! * system-linux-x86_64.ads: Likewise. ! * system-lynxos-ppc.ads: Likewise. ! * system-lynxos-x86.ads: Likewise. ! * system-mingw-x86_64.ads: Likewise. ! * system-mingw.ads: Likewise. ! * system-rtems.ads: Likewise. ! * system-solaris-sparc.ads: Likewise. ! * system-solaris-sparcv9.ads: Likewise. ! * system-solaris-x86.ads: Likewise. ! * system-solaris-x86_64.ads: Likewise. ! * system-tru64.ads: Likewise. ! * system-vms-ia64.ads: Likewise. ! * system-vms-zcx.ads: Likewise. ! * system-vms.ads: Likewise. ! * system-vms_64.ads: Likewise. ! * system-vxworks-arm.ads: Likewise. ! * system-vxworks-m68k.ads: Likewise. ! * system-vxworks-mips.ads: Likewise. ! * system-vxworks-ppc.ads: Likewise. ! * system-vxworks-sparcv9.ads: Likewise. ! * system-vxworks-x86.ads: Likewise. ! * system.ads: Likewise. ! * table.adb: Likewise. ! * table.ads: Likewise. ! * targext.c: Likewise. ! * targparm.ads: Likewise. ! * tree_in.adb: Likewise. ! * tree_in.ads: Likewise. ! * tree_io.adb: Likewise. ! * tree_io.ads: Likewise. ! * types.adb: Likewise. ! * types.ads: Likewise. ! * uintp.adb: Likewise. ! * uintp.ads: Likewise. ! * uname.adb: Likewise. ! * uname.ads: Likewise. ! * urealp.adb: Likewise. ! * urealp.ads: Likewise. ! * vx_stack_info.c: Likewise. ! * widechar.adb: Likewise. ! * widechar.ads: Likewise. ! * exp_attr.adb: Change copyright header to refer to version ! 3 of the GNU General Public License and to point readers at the ! COPYING3 file and the FSF's license web page. ! * sem.adb: Likewise. ! * sem_attr.ads: Likewise. ! * freeze.adb: Likewise. ! * freeze.ads: Likewise. ! * errout.ads: Likewise. ! * erroutc.adb: Likewise. ! * exp_ch11.ads: Likewise. ! ! 2009-04-09 Jakub Jelinek ! ! * config-lang.in: Change copyright header to refer to version ! 3 of the GNU General Public License and to point readers at the ! COPYING3 file and the FSF's license web page. ! * gcc-interface/trans.c: Likewise. ! * gnathtml.pl: Likewise. ! * gcc-interface/ada.h: Likewise. Remove runtime exception. ! * gcc-interface/gigi.h: Likewise. ! * gcc-interface/misc.c: Likewise. ! * gcc-interface/targtyps.c: Likewise. ! ! 2009-03-31 Eric Botcazou ! ! * system-linux-alpha.ads (Functions_Return_By_DSP): Remove. ! * system-linux-mips.ads (Functions_Return_By_DSP): Likewise. ! * system-linux-mipsel.ads (Functions_Return_By_DSP): Likewise. ! * system-linux-s390.ads (Functions_Return_By_DSP): Likewise. ! * system-linux-s390x.ads (Functions_Return_By_DSP): Likewise. ! * system-linux-sparc.ads (Functions_Return_By_DSP): Likewise. ! * system-linux-sparcv9.ads (Functions_Return_By_DSP): Likewise. ! ! 2009-03-31 Eric Botcazou ! ! Backport from mainline: ! 2009-03-30 Paolo Bonzini ! * gcc-interface/decl.c (maybe_pad_type): Use TREE_OVERFLOW instead ! of TREE_CONSTANT_OVERFLOW. ! ! 2009-03-11 Olivier Hainque ! ! * gcc-interface/trans.c (gnat_to_gnu) : In range ! checks processing, remove unintended TREE_TYPE walk on index type. ! ! 2009-03-01 Eric Botcazou ! ! PR ada/39264 ! * gcc-interface/decl.c (gnat_to_gnu_entity) : Do no ! call make_packable_type on fat pointer types. ! : Likewise. ! : Call make_packable_type on all record types ! except for fat pointer types. ! (make_packable_type): Likewise. ! (gnat_to_gnu_field): Likewise. ! ! 2009-02-28 Eric Botcazou ! ! * gcc-interface/Makefile.in (cygwin/mingw): Revert accidental ! EH_MECHANISM change made on 2007-12-06. ! ! 2009-02-26 Andreas Schwab ! ! PR ada/39172 ! * Makefile.in (srcdir): Set to @top_srcdir@ instead of @srcdir@. ! * gcc-interface/Makefile.in: Change all uses of $(srcdir), ! $(fsrcdir) and $(fsrcpfx) to add ada subdir. ! (AWK): Substitute. ! (target_cpu_default): Substitute. ! ! 2009-02-25 Laurent GUERBY ! ! PR ada/39221 ! * a-teioed.adb (Expand): Fix Result overflow. ! ! 2009-02-25 Laurent GUERBY ! ! * gcc-interface/Makefile.in: Fix multilib handling for ! sparc64-linux. ! ! 2009-02-23 Rainer Orth ! ! * s-oscons-tmplt.c [__osf__ && !_SS_MAXSIZE]: Undef AF_UNIX6. ! ! 2009-02-18 H.J. Lu ! ! * gcc-interface/misc.c (gnat_post_options): Turn off warn_psabi. ! ! 2009-02-16 Eric Botcazou ! ! * gcc-interface/deftarg.c: Remove. ! ! 2009-02-10 Olivier Hainque ! Eric Botcazou ! ! * gcc-interface/decl.c (enum alias_set_op): New enumeration. ! (copy_alias_set): Rename into... ! (relate_alias_sets): ...this. Add third parameter OP. Retrieve the ! underlying array of unconstrained arrays for the new type as well. ! If the old and new alias sets don't conflict, make one a subset of ! the other as per the OP parameter. ! (gnat_to_gnu_entity): Adjust calls to copy_alias_set. ! : Do not copy the alias set for derived types. ! For all types, make the alias set of derived types a superset of ! that of their parent type. ! (make_aligning_type): Adjust calls to copy_alias_set. ! (make_packable_type): Likewise. ! * gcc-interface/trans.c (gnat_to_gnu): ! Check for alias set conflict instead of strict equality to issue the ! warning. ! ! 2009-02-09 Eric Botcazou ! ! * gcc-interface/decl.c (gnat_to_gnu_entity) : ! Set TYPE_NONALIASED_COMPONENT on the array type only if appropriate. ! (copy_alias_set): Assert that arrays have the same aliasing settings. ! (substitute_in_type) : Copy TYPE_NONALIASED_COMPONENT. ! ! 2009-02-08 Eric Botcazou ! ! * gcc-interface/decl.c (gnat_to_gnu_entity) : ! Set TYPE_NONALIASED_COMPONENT on the array type. ! ! 2009-01-31 Laurent GUERBY ! ! * gcc-interface/Makefile.in: Fix mipsel linux handling. ! ! 2009-01-16 Jakub Jelinek ! ! * gcc-interface/Makefile.in: Fix multilib handling for ! powerpc64-linux. ! ! 2009-01-12 Eric Botcazou ! ! * gcc-interface/decl.c (gnat_to_gnu_entity) : Really strip ! only useless conversions around renamed objects. 2009-01-11 Eric Botcazou ! * gcc-interface/decl.c (gnat_to_gnu_entity) : Put ! the _Tag field before any discriminants in the field list. (components_to_record): Remove obsolete comment. ! 2008-12-09 Jakub Jelinek ! PR ada/38450 ! * gcc-interface/utils.c (finish_record_type): Use SET_TYPE_MODE. ! * gcc-interface/decl.c (gnat_to_gnu_entity, make_aligning_type): ! Likewise. ! 2008-12-05 Sebastian Pop ! PR bootstrap/38262 ! * gcc-interface/Make-lang.in (gnat1): Add BACKENDLIBS, remove GMPLIBS. ! ! 2008-11-29 Eric Botcazou ! ! PR ada/30827 ! * g-comver.adb (Ver_Len_Max): Fix inconsistency. ! ! 2008-11-27 Eric Botcazou ! ! * gcc-interface/decl.c: Fix various nits. ! ! 2008-11-20 Eric Botcazou ! ! * gcc-interface/utils.c (init_gigi_decls): Fix type mismatch. ! ! 2008-11-16 Eric Botcazou ! ! PR ada/38127 ! * gcc-interface/decl.c (make_type_from_size) : Do not ! special-case boolean types. Propagate the name. ! * gcc-interface/targtyps.c: Tweak comment. ! ! 2008-11-15 Geert Bosch ! ! * gcc-interface/trans.c (emit_check): Put back a final save_expr ! to prevent exponential expansion during gimplification. ! ! 2008-11-15 Eric Botcazou ! ! * gcc-interface/lang-specs.h: Expand -coverage and reorder switches. ! ! 2008-11-15 Eric Botcazou ! ! * gcc-interface/decl.c (gnat_to_gnu_entity) : Force constants ! initialized to a static constant to be statically allocated even if ! they are of a padding type, provided the original type also has ! constant size. ! ! 2008-11-15 Laurent Guerby ! ! PR ada/37993 ! * gcc-interface/Makefile.in: Add multilib handling for x86_64 ! on darwin. ! * system-darwin-x86_64.ads: New file. ! ! 2008-11-13 Olivier Hainque ! ! * gcc-interface/decl.c (gnat_to_gnu_entity) : ! Turn Ada Pure on subprograms back into GCC CONST when eh constructs ! are explicit to the middle-end. Tidy. ! ! 2008-11-09 Eric Botcazou ! ! * gcc-interface/ada-tree.def (PLUS_NOMOD_EXPR): New tree code. ! (MINUS_NOMOD_EXPR): Likewise. ! * gcc-interface/utils2.c (build_binary_op) : Make ! unreachable. ! : New case. ! : Likewise. ! * gcc-interface/trans.c (Loop_Statement_to_gnu): Build increment-and- ! assignment statement instead of using an increment operator. ! ! 2008-11-07 Rainer Orth ! ! * system-irix-n64.ads: New file. ! * gcc-interface/Makefile.in (mips-sgi-irix6*): Support O32 and N64 ! multilibs. ! ! 2008-11-07 Rainer Orth ! ! PR ada/37681 ! * system-solaris-x86_64.ads: New file. ! * gcc-interface/Makefile.in (*86-solaris2*): Support x86_64 multilib. ! ! 2008-11-07 Bechir Zalila ! Eric Botcazou PR ada/34289 * lib.ads: (Enable_Switch_Storing): Declare. *************** *** 31,49 **** * switch-c.adb (Scan_Front_End_Switches): Add support for -gnatea. * make.adb: (Compile_Sources.Compile): Add -gnatea as first option. (Display): Never display -gnatea ! * lang-specs.h: If -gnatea is present, pass -gnatez. 2008-10-06 Eric Botcazou ! * utils.c (can_fold_for_view_convert_p): New predicate. (unchecked_convert): Use it to disable problematic folding with VIEW_CONVERT_EXPR in the general case. Always disable it for the special VIEW_CONVERT_EXPR built for integral types and cope with its addressability issues by preserving the first conversion. ! 2008-08-27 Release Manager ! * GCC 4.3.2 released. 2008-06-24 Eric Botcazou --- 1342,4028 ---- * switch-c.adb (Scan_Front_End_Switches): Add support for -gnatea. * make.adb: (Compile_Sources.Compile): Add -gnatea as first option. (Display): Never display -gnatea ! * gcc-interface/lang-specs.h: If -gnatea is present, pass -gnatez. ! ! 2008-11-07 Thomas Quinot ! ! * gcc-interface/trans.c (Attribute_to_gnu, case Attr_Length): Check ! for empty range in original base type, not converted result type. ! ! 2008-11-07 Geert Bosch ! ! * gcc-interface/trans.c (build_binary_op_trapv): Convert arguments ! and result for call to __gnat_mulv64. ! ! 2008-11-07 Eric Botcazou ! ! * gcc-interface/trans.c: Fix formatting nits. ! ! 2008-11-07 Geert Bosch ! ! * gcc-interface/trans.c (build_binary_op_trapv): Avoid emitting ! overflow check for constant result. ! ! 2008-11-07 Geert Bosch ! ! * gcc-interface/trans.c (build_binary_op_trapv): Use more efficient ! overflow check for addition/subtraction if neither operand is constant. ! ! 2008-11-06 Eric Botcazou ! ! * gcc-interface/Makefile.in (SPARC/Solaris): Use a common set of ! files for the target-dependent part of the runtime. ! (SPARC/Linux): Likewise. ! ! 2008-11-06 Eric Botcazou ! ! * gcc-interface/decl.c (gnat_to_gnu_entity) : If not ! optimizing, create a PARM_DECL pointing to the VAR_DECL for debugging ! purposes. ! ! 2008-11-06 Eric Botcazou ! ! * gcc-interface/misc.c (gnat_printable_name): Always return a copy ! in GC memory. ! ! 2008-11-06 Eric Botcazou ! ! PR ada/19419 ! * gcc-interface/trans.c (gnat_to_gnu) : ! Generate a call to memmove for an assignment between overlapping ! array slices. ! ! 2008-11-02 Andreas Krebbel ! ! PR target/37977 ! * gcc-interface/Makefile.in: Add multilib handling for ! s390-linux and s390x-linux. ! ! 2008-10-24 Jakub Jelinek ! ! * gcc-interface/Make-lang.in (check-ada-subtargets): Depend on ! check-acats-subtargets and check-gnat-subtargets. ! (check_acats_targets): New variable. ! (check-acats-subtargets, check-acats%): New targets. ! (check-acats): If -j is used and CHAPTERS is empty, run the testing ! in multiple make goals, possibly parallel, and afterwards run ! dg-extract-results.sh to merge the sum and log files. ! ! 2008-10-17 Geert Bosch ! ! * gcc-interface/trans.c (gnat_to_gnu) : Simplify expansion ! to use only a single check instead of three, and avoid unnecessary ! COMPOUND_EXPR. ! (emit_check): Avoid useless COMPOUND_EXPRs and SAVE_EXPRs, sometimes ! creating more opportunities for optimizations. ! ! 2008-10-13 Jakub Jelinek ! ! PR middle-end/37601 ! * gcc-interface/utils.c (gnat_types_compatible_p): Handle ! NULL TYPE_DOMAIN. ! ! 2008-10-07 Eric Botcazou ! ! * gcc-interface/decl.c (gnat_to_gnu_entity) : Move code ! dealing with volatileness to after code dealing with renaming. 2008-10-06 Eric Botcazou ! * gcc-interface/decl.c (gnat_to_gnu_entity) : Minor tweaks. ! * gcc-interface/trans.c (Pragma_to_gnu): Likewise. ! ! 2008-10-06 Eric Botcazou ! ! * gcc-interface/utils.c (can_fold_for_view_convert_p): New predicate. (unchecked_convert): Use it to disable problematic folding with VIEW_CONVERT_EXPR in the general case. Always disable it for the special VIEW_CONVERT_EXPR built for integral types and cope with its addressability issues by preserving the first conversion. ! 2008-10-01 Andreas Schwab ! * system-linux-ppc64.ads: New file. ! * gcc-interface/Makefile.in: Add multilib handling for ! powerpc-linux. ! ! 2008-09-26 Eric Botcazou ! ! * decl.c (gnat_to_gnu_entity) : Cap the alignment promotion ! to that of ptr_mode instead of word_mode. ! ! 2008-09-26 Eric Botcazou ! ! PR ada/5911 ! * gcc-interface/Makefile.in (SPARC/Solaris): Add multilib support. ! ! 2008-09-25 Samuel Tardieu ! ! PR ada/37641 ! * adaint.c (__gnat_set_non_writable): Use FILE_WRITE_EA ! instead of deprecated FILE_WRITE_PROPERTIES. ! ! 2008-09-22 Olivier Hainque ! ! * gcc-interface/decl.c (gnat_to_gnu_entity): Even when they ! are never assigned, volatile entities are not constant for code ! generation purposes. ! ! 2008-09-21 Laurent Guerby ! ! PR ada/5911 ! * gcc-interface/Makefile.in: Add multilib handling for x86_64 ! and sparc. ! * system-linux-sparcv9.ads: New file. ! ! 2008-09-20 Eric Botcazou ! ! * exp_dbug.ads: Document new convention for the XVZ variable. ! * gcc-interface/decl.c (gnat_to_gnu_entity) : Generate ! debug info if necessary for the type padding the component type. ! : Likewise. ! (maybe_pad_type): Emit the XVZ variable in units. ! * gcc-interface/trans.c (Loop_Statement_to_gnu): Fix formatting nits. ! (Subprogram_Body_to_gnu): Set the source line of the subprogram's node ! on statements generated to initialize the parameter attributes cache. ! Set the source line of the end label of the body on the special return ! statement built for a procedure with copy-in copy-out parameters. ! ! 2008-09-20 Eric Botcazou ! ! PR ada/37585 ! * gcc-interface/utils.c (create_subprog_decl): Disable inlining for ! inlined external functions if they contain a nested function not ! declared inline. ! ! 2008-09-18 Jan Hubicka ! ! * gcc-interface/utils.c (create_subprog_decl): Use DECL_DECLARED_INLINE_P. ! (end_subprog_body): Do not set DECL_INLINE. ! ! 2008-09-17 Pascal Rigaux ! ! PR ada/21327 ! * gnat_ugn.texi: Use proper format in direntry. ! ! 2008-09-15 Eric Botcazou ! ! * gcc-interface/trans.c (gigi): Declare the name of the compilation ! unit as the first global name. ! ! 2008-09-14 Jan Hubicka ! ! * gcc-interface/Make-lang.in (gnat1): Add CFLAGS. ! ! 2008-09-14 Ralf Wildenhues ! ! * a-crbtgk.adb, a-direct.ads, a-tasatt.adb, ali.ads, ! bindgen.adb, checks.adb, einfo.ads, exp_aggr.adb, exp_ch11.adb, ! exp_ch3.adb, exp_ch4.adb, exp_ch6.adb, exp_ch7.adb, exp_ch9.adb, ! exp_dbug.ads, exp_disp.adb, exp_dist.adb, exp_pakd.adb, ! exp_util.adb, g-alveop.ads, g-comlin.adb, g-comlin.ads, ! g-diopit.adb, g-socket.ads, gcc-interface/decl.c, ! gcc-interface/gigi.h, gcc-interface/trans.c, ! lib-load.adb, lib-xref.ads, make.adb, mlib-prj.adb, nlists.ads, ! opt.ads, par-ch10.adb, par-ch5.adb, par.adb, s-os_lib.ads, ! s-oscons-tmplt.c, s-parint.ads, s-regpat.ads, s-shasto.ads, ! s-stausa.ads, s-taprop-vms.adb, sem.adb, sem_ch10.adb, ! sem_ch11.adb, sem_ch12.adb, sem_ch13.adb, sem_ch3.adb, ! sem_ch3.ads, sem_ch4.adb, sem_ch6.adb, sem_ch7.adb, sem_ch8.adb, ! sem_elim.adb, sem_prag.adb, sem_util.adb, sem_util.ads, ! sem_warn.adb, sinfo.ads, styleg.adb, vms_data.ads: Fix typos in ! comments. ! * gnathtml.pl: Fix typos. ! ! 2008-09-10 Joel Sherrill ! ! * gcc-interface/Makefile.in: Switch RTEMS to s-interr-hwint.adb. ! * s-osinte-rtems.ads: Add shared hardware interrupt adapter ! layer. RTEMS binds to OS provided adapter routines so there are ! no modifications to s-osinte-rtems.adb. ! ! 2008-09-09 Arnaud Charlet ! Joel Sherrill ! ! * gcc-interface/Makefile.in: Switch VxWorks to s-interr-hwint.adb. ! ! * s-interr-vxworks.adb: Renamed to s-interr-hwint.adb ! ! * s-interr-hwint.adb: New file. ! ! * s-osinte-vxworks.ads, s-osinte-vxworks.adb: Add new functions ! needed by s-interr-hwint.adb. ! ! * s-osinte-vxworks-kernel.adb: New file. ! ! 2008-09-05 Joel Sherrill ! ! * s-stchop-rtems.adb: Add file missed in early commit. Already ! referenced in gcc-interface/Makefile.in. ! ! 2008-08-30 Thomas Quinot ! ! * gcc-interface/Make-lang.in: Allow s-oscons.{o,ali} to ! be built even without a separate libada directory. ! ! 2008-08-22 Arnaud Charlet ! ! * lib-xref.ads: Fix typo in subprogram reference definition. ! ! 2008-08-22 Robert Dewar ! ! * s-sopco3.adb, s-sopco4.adb, s-sopco5.adb, s-strops.adb: Minor code fix ! to avoid warning. ! ! * g-trasym.adb: Ditto ! ! * s-utf_32.adb (Get_Category): Fix obvious typo ! ! * s-wwdcha.adb: Minor code reorganization ! Remove dead code ! ! 2008-08-22 Robert Dewar ! ! * checks.adb (Determine_Range): Deal with values that might be invalid ! ! * opt.adb, opt.ads (Assume_No_Invalid_Values[_Config]): New ! configuration switches. ! ! * par-prag.adb: Dummy entry for pragma Assume_No_Invalid_Values ! ! * sem_prag.adb: Implement pragma Assume_No_Default_Values ! ! * snames.adb, snames.ads, snames.h: ! Add entries for pragma Assume_No_Invalid_Values ! ! * switch-c.adb: Add processing for -gnatB switch ! ! * usage.adb: Add entry for flag -gnatB (no bad invalid values) ! ! 2008-08-22 Javier Miranda ! ! * exp_ch3.adb (Build_Init_Statements): Transfer to the body of the ! init procedure all the expanded code associated with the spec of ! task types and protected types. ! ! 2008-08-22 Gary Dismukes ! ! * exp_aggr.adb (Static_Array_Aggregate): Call Analyze_And_Resolve on the ! component expression copies rather than directly setting Etype and ! Is_Static_Expression. ! ! 2008-08-22 Gary Dismukes ! ! * sem_util.adb (Has_Preelaborable_Initialization): Revise checking of ! private types to allow for types derived from a private type with ! preelaborable initialization, but return False for a private extension ! (unless it has the pragma). ! ! 2008-08-22 Robert Dewar ! ! * opt.ads: Minor code reorganization (put entries in alpha order) ! ! 2008-08-22 Pascal Obry ! ! * initialize.c, adaint.c: Use Lock_Task and Unlock_Task for non-blocking ! spawn. ! ! 2008-08-22 Geert Bosch ! ! * gcc-interface/trans.c: Define FP_ARITH_MAY_WIDEN ! (convert_with_check): Only use longest_float_type if FP_ARITH_MAY_WIDEN is 0 ! ! 2008-08-22 Doug Rupp ! ! * bindgen.adb [VMS] (Gen_Adainit_Ada, Gen_Adainit_C): Import and call ! __gnat_set_features. ! ! * init.c ! (__gnat_set_features): New function. ! (__gnat_features_set): New tracking variable. ! (__gl_no_malloc_64): New feature global variable ! ! 2008-08-22 Ed Schonberg ! ! * sem_ch8.adb (Use_One_Type): Do not emit warning message about redundant ! use_type_clause in an instance. ! ! 2008-08-22 Bob Duff ! ! * exp_ch6.ads: Remove pragma Precondition, since it breaks some builds. ! ! 2008-08-22 Robert Dewar ! ! * exp_ch6.adb: Minor reformatting ! ! * exp_ch7.adb: Minor reformatting ! ! * exp_ch7.ads: Put routines in proper alpha order ! ! * exp_dist.adb: Minor reformatting ! ! 2008-08-22 Vincent Celier ! ! * prj.ads: Minor comment update ! ! 2008-08-22 Robert Dewar ! ! * sem_ch5.adb (One_Bound): Fix latent bug involving secondary stack ! ! 2008-08-22 Ed Schonberg ! ! * exp_tss.adb: ! (Base_Init_Proc): For a protected subtype, use the base type of the ! corresponding record to locate the propoer initialization procedure. ! ! 2008-08-22 Robert Dewar ! ! * checks.adb: ! (In_Subrange_Of): New calling sequence ! (Determine_Range): Prepare for new processing using base type ! ! * exp_ch4.adb: ! (Compile_Time_Compare): Use new calling sequence ! ! * exp_ch5.adb: ! (Compile_Time_Compare): Use new calling sequence ! ! * sem_eval.adb: ! (Compile_Time_Compare): New calling sequence allows dealing with ! invalid values. ! (In_Subrange_Of): Ditto ! ! * sem_eval.ads: ! (Compile_Time_Compare): New calling sequence allows dealing with ! invalid values. ! (In_Subrange_Of): Ditto ! ! 2008-08-22 Pascal Obry ! ! * adaint.c: Fix possible race condition on win32_wait(). ! ! 2008-08-22 Bob Duff ! ! * exp_ch5.adb, exp_ch7.adb, exp_ch7.ads, exp_util.adb, freeze.adb, ! exp_ch4.adb, exp_ch6.ads, exp_ch6.adb, sem_ch6.adb, exp_aggr.adb, ! exp_intr.adb, exp_ch3.adb: Rename: ! Exp_Ch7.Controlled_Type => Needs_Finalization ! Exp_Ch7.CW_Or_Controlled_Type => CW_Or_Has_Controlled_Part ! Exp_Ch5.Expand_N_Extended_Return_Statement.Controlled_Type => ! Has_Controlled_Parts ! (Has_Some_Controlled_Component): Fix bug in array case. ! ! 2008-08-22 Robert Dewar ! ! * sem_ch8.adb: Minor reformatting ! ! 2008-08-22 Kevin Pouget ! ! * s-shasto.ads, s-shasto.adb: Move Shared_Var_ROpen, Shared_Var_WOpen and ! Shared_Var_Close procedure specifications from package spec to package body. ! ! * rtsfind.ads: Remove RE_Shared_Var_Close, RE_Shared_Var_ROpen, ! RE_Shared_Var_WOpen entries. ! ! * exp_dist.adb: Update RE_Any_Content_Ptr to RE_Any_Container_Ptr in ! Build_To_Any_Call, Build_TypeCode_Call and Build_From_Any_Call procedures. ! ! 2008-08-22 Eric Botcazou ! ! * init.c: adjust EH support code on Alpha/Tru64 as well. ! ! * raise-gcc.c: Add back a couple of comments. ! ! 2008-08-22 Ed Schonberg ! ! * exp_ch5.adb (Expand_Simple_Function_Return): If secondary stack is ! involved and the return type is class-wide, use the type of the expression ! for the generated access type. Suppress useless discriminant checks on the ! allocator. ! ! 2008-08-22 Bob Duff ! ! * exp_ch7.adb: Minor comment fix ! ! * exp_ch6.ads: Minor comment fix ! ! 2008-08-22 Thomas Quinot ! ! * sem_ch8.adb: Minor reformatting ! Minor code reorganization (introduce subprogram to factor duplicated ! code). ! ! 2008-08-22 Sergey Rybin ! ! * gnat_ugn.texi: Change the description of gnatcheck default rule ! settings. ! ! 2008-08-22 Eric Botcazou ! ! * init.c (__gnat_adjust_context_for_raise): Delete for AIX, HP-UX, ! Solaris, FreeBSD, VxWorks and PowerPC/Linux. For x86{-64}/Linux, ! do not adjust the PC anymore. ! (__gnat_error_handler): Do not call __gnat_adjust_context_for_raise ! on AIX, HP-UX, Solaris, FreeBSD and VxWorks. ! ! * raise-gcc.c (get_call_site_action_for): Use _Unwind_GetIPInfo ! instead of _Unwind_GetIP. ! ! 2008-08-22 Gary Dismukes ! ! * exp_aggr.adb (Static_Array_Aggregate): When a static array aggregate ! with a range is transformed into a positional aggregate, any copied ! component literals should be marked Is_Static_Expression. ! ! * sem_eval.adb (Compile_Time_Known_Value): Don't treat null literals as ! not being known at at compile time when Configurable_Run_Time_Mode is ! true. ! ! 2008-08-22 Robert Dewar ! ! * exp_attr.adb: ! (Expand_N_Attribute_Reference): No validity checking on OUT parameter of ! Read or Input attribute. ! ! 2008-08-22 Ed Schonberg ! ! * sem_ch8.adb (Use_One_Type): when checking which of two use_type ! clauses in related units is redundant, if one of the units is a package ! instantiation, use its instance_spec to determine which unit is the ! ancestor of the other. ! ! 2008-08-22 Javier Miranda ! ! * exp_attr.adb (Expand_N_Attribute_Reference): In case of access ! attributes add missing support to handle designated types that come ! from the limited view. ! ! * exp_disp.adb (Expand_Interface_Conversion): Remove wrong assertion. ! ! 2008-08-22 Sergey Rybin ! ! * vms_data.ads: Add entry for new gnatcheck -mNNN option ! ! * gnat_ugn.texi: Add description for gnatcheck option '-m' ! ! 2008-08-22 Sergey Rybin ! ! * gnat_ugn.texi: Update the gnatcheck subsection for metric rules ! acoording to the latest changes in the metric rule interface ! ! 2008-08-22 Vincent Celier ! ! * make.adb (Check.File_Not_A_Source_Of): New Boolean function ! (Check): Check if the file names registered in the ALI file for the ! spec, the body and each of the subunits are the ones expected. ! ! 2008-08-22 Robert Dewar ! ! * g-catiio.adb: Code cleanup. ! ! 2008-08-20 Vincent Celier ! ! * make.adb (Gnatmake): Remove extra space in version line ! ! * ali.adb: ! (Scan_ALI): Use Name_Find, not Name_Enter to get the name of a subunit, ! as the name may already have been entered in the table by the Project ! Manager. ! ! 2008-08-20 Jose Ruiz ! ! * errno.c (__get_errno, __set_errno for MaRTE): Transform then into ! weak symbols so we use the version provided by MaRTE when available. ! ! 2008-08-20 Emmanuel Briot ! ! * g-catiio.ads, g-catiio.adb: ! (Value): Avoid an unnecessary system call to Clock in most cases. ! This call is only needed when only the time is provided in the string, ! and ignored in all other cases. This is more efficient. ! ! 2008-08-20 Eric Botcazou ! ! * raise-gcc.c: Fix formatting nits. ! ! 2008-08-20 Robert Dewar ! ! * sem_ch13.adb: ! (Adjust_Record_For_Reverse_Bit_Order): Do not access First_Bit for ! non-existing component clause. ! ! * exp_ch5.adb: Minor reformatting ! ! * g-comlin.adb: Minor reformatting ! ! * make.adb: Minor reformatting ! ! * prj-proc.adb: Minor reformatting ! ! * stylesw.ads: Minor reformatting ! ! 2008-08-20 Vincent Celier ! ! * make.adb (Gnatmake_Switch_Found): New Boolean global variable ! (Switch_May_Be_Passed_To_The_Compiler): New Boolean global variable ! (Add_Switches): New Boolean parameter Unknown_Switches_To_The_Compiler ! defaulted to True. Fail when Unknown_Switches_To_The_Compiler is False ! and a switch is not recognized by gnatmake. ! (Gnatmake): Implement new scheme for gnatmake switches and global ! compilation switches. ! (Switches_Of): Try successively Switches (), ! Switches ("Ada"), Switches (others) and Default_Switches ("Ada"). ! ! 2008-08-20 Ed Schonberg ! ! * styleg-c.ads, styleg-c.adb (Missing_Overriding): new procedure to ! implement style check that overriding operations are explicitly marked ! at such. ! ! * style.ads (Missing_Overriding): new procedure that provides interface ! to previous one. ! ! * stylesw.ads, stylesw.adb: New style switch -gnatyO, to enable check ! that the declaration or body of overriding operations carries an ! explicit overriding indicator. ! ! * sem_ch8.adb ! (Analyze_Subprogram_Renaming): if operation is overriding, check whether ! explicit indicator should be present. ! ! * sem_ch6.adb (Verify_Overriding_Indicator, ! Check_Overriding_Indicator): If operation is overriding, check whether ! declaration and/or body of subprogram should be present ! ! 2008-08-20 Vincent Celier ! ! * prj-nmsc.adb (Check_Naming_Schemes): Accept source file names for ! gprbuild when casing is MixedCase, whatever the casing of the letters ! in the file name. ! ! 2008-08-20 Gary Dismukes ! ! * exp_ch3.adb (Build_Array_Init_Proc): Clarify comment related to ! creating dummy init proc. ! (Requires_Init_Proc): Return False in the case No_Default_Initialization ! is in force and the type does not have associated default ! initialization. Move test of Is_Public (with tests of restrictions ! No_Initialize_Scalars and No_Default_Initialization) to end, past tests ! for default initialization. ! ! 2008-08-20 Jerome Lambourg ! ! * g-comlin.adb (For_Each_Simple_Switch): Take care of switches not part ! of any alias or prefix but having attached parameters (as \"-O2\"). ! ! 2008-08-20 Robert Dewar ! ! * s-fileio.adb: Minor reformatting ! ! 2008-08-20 Thomas Quinot ! ! * exp_strm.adb (Build_Elementary_Input_Call, ! Build_Elementary_Write_Call): Fix incorrect condition in circuitry that ! selects the stream attribute routines for long float types. ! ! 2008-08-20 Vincent Celier ! ! * prj-proc.adb (Process_Declarative_Items): Add Location for Array_Data ! ! * prj.ads (Array_Data): Add a component Location ! ! 2008-08-20 Ed Schonberg ! ! * sem_prag.adb: ! (Analyze_Pragma, case Obsolescent): Add entity information on the pragma ! argument for ASIS and navigation use. ! ! 2008-08-20 Ed Schonberg ! ! * einfo.ads: Add comment. ! ! 2008-08-20 Bob Duff ! ! * sem_eval.ads: Minor comment fix. ! ! 2008-08-20 Bob Duff ! ! * exp_ch4.adb (Expand_N_And_Then, Expand_N_Or_Else): Improve constant ! folding. We were folding things like "False and then ...", but not ! "X and then ..." where X is a constant whose value is known at compile ! time. ! ! 2008-08-20 Hristian Kirtchev ! ! * exp_ch5.adb (Controlled_Type): New routine. ! (Expand_N_Extended_Return_Statement): When generating a move of the ! final list in extended return statements, check the type of the ! function and in the case of double expanded return statements, the type ! of the returned object. ! (Expand_Simple_Function_Return): Perform an interface conversion when ! the type of the returned object is an interface and the context is an ! extended return statement. ! ! 2008-08-20 Ed Schonberg ! ! * sem_util.adb (Set_Debug_Info_Needed): If the entity is a private type ! and the full view is visible, set flag on full view as well. ! ! 2008-08-20 Thomas Quinot ! ! * g-comlin.adb: Minor reformatting ! Minor code reorganization. ! ! * freeze.adb: Minor reformatting ! ! 2008-08-20 Vincent Celier ! ! * prj-nmsc.adb (Check_File): An excluded Ada source file may be a ! source of another project. ! ! 2008-08-20 Pascal Obry ! ! * s-os_lib.ads: Minor reformatting. ! ! 2008-08-20 Arnaud Charlet ! ! * gnatvsn.ads: Minor reformatting. ! ! 2008-08-20 Arnaud Charlet ! ! * a-crbtgk.adb, repinfo.adb, g-traceb.ads, repinfo.ads, ! system-linux-s390x.ads, s-fatflt.ads, s-parame-ae653.ads, g-spipat.adb, ! g-spipat.ads, g-tasloc.adb, g-debpoo.adb, g-except.ads, g-debpoo.ads, ! mdll-utl.adb, g-string.adb, g-soliop-solaris.ads, par-sync.adb, ! exp_ch6.ads, a-cihama.ads, g-curexc.ads, system-linux-sh4.ads, ! g-utf_32.adb, g-hesorg.adb, s-proinf-irix-athread.ads, s-parint.adb, ! s-parint.ads, exp_ch7.ads, system-linux-alpha.ads, g-dirope.adb, ! sinfo-cn.adb, par-labl.adb, a-ciorse.adb, g-calend.adb, ! s-parame-vms-alpha.ads, nlists.h, exp_imgv.adb, exp_fixd.ads, ! g-calend.ads, gnatcmd.ads, g-table.adb, s-memory-mingw.adb, ! g-alveop.ads, g-memdum.ads, g-altive.ads, initialize.c, g-regpat.adb, ! g-busorg.ads, g-regpat.ads, g-encstr.ads, g-regexp.adb, g-regexp.ads, ! live.ads, g-dyntab.adb, prj-nmsc.ads, par-ch12.adb, 9drpc.adb, ! g-alvevi.ads, s-memory.adb, math_lib.adb, s-parame.ads, s-memory.ads, ! s-regexp.adb, a-exexda.adb, i-cstrea-vms.adb, a-exexpr.adb, ! g-soliop-mingw.ads, s-imgrea.adb, namet.adb, system-vms.ads, ! s-inmaop-dummy.adb, s-finroo.ads, a-ngcefu.adb, s-hibaen.ads, ! g-soliop.ads, s-auxdec.adb, g-locfil.ads, gnatxref.adb, memroot.adb, ! osint-b.ads, memroot.ads, s-parame-hpux.ads, errutil.adb, ! system-linux-s390.ads, par-util.adb, osint-c.ads, exp_pakd.ads, ! i-pacdec.ads, par-endh.adb, mlib-tgt.ads, prj-strt.ads, ! s-osprim-vms.adb, s-proinf.ads, output.ads, g-moreex.ads, ! a-finali.ads, s-fatlfl.ads, namet.h, mdll.ads, g-dynhta.ads, ! s-imgenu.ads, par-tchk.adb, g-excact.ads, memtrack.adb, s-fatgen.adb, ! a-exexpr-gcc.adb, g-arrspl.adb, par-ch4.adb, g-cgideb.adb, freeze.ads, ! g-altcon.adb, s-fatllf.ads, gnatfind.adb, s-osinte-lynxos-3.adb, ! a-exextr.adb, g-htable.ads, a-calfor.adb, s-imgcha.adb, argv.c, ! a-chahan.ads, g-hesora.adb, system-vms_64.ads, par-ch5.adb, g-md5.adb, ! lib-xref.ads, g-md5.ads, g-casuti.ads, s-fatsfl.ads, exp_dbug.ads, ! s-htable.ads, a-ngcoar.adb, s-arit64.ads, a-ngelfu.adb, a-filico.ads, ! par-ch6.adb, s-inmaop.ads, s-parame-vxworks.ads, s-casuti.ads, ! a-numaux-darwin.adb, a-cohama.ads, system-linux-sparc.ads, g-os_lib.adb, ! system-vms-ia64.ads, s-parame-vms-restrict.ads, a-clrefi.ads, ! s-parame-vms-ia64.ads, a-strfix.adb, a-coorse.adb, a-comlin.ads, ! a-chtgke.adb, s-imgint.adb, g-expect.ads, exp_ch4.ads, s-finimp.adb, ! mingw32.h, g-heasor.adb, g-alleve.adb, a-ngrear.adb, s-mastop-irix.adb, ! s-poosiz.adb, link.c: Fix copyright notice. ! ! 2008-08-20 Arnaud Charlet ! ! * g-comlin.ads: Update comments. ! ! 2008-08-20 Ed Schonberg ! ! * sem_ch8.adb (Analyze_Subprogram_Renaming): Inherit Is_Imported flag. ! ! 2008-08-20 Gary Dismukes ! ! * exp_ch11.adb: ! (Expand_Exception_Handlers): Call Make_Exception_Handler instead of ! Make_Implicit_Exception_Handler when rewriting an exception handler with ! a choice parameter, and pass the handler's Sloc instead of that of the ! handled sequence of statements. Make_Implicit_Exception_Handler sets the ! Sloc to No_Location (unless debugging generated code), which we don't ! want for the case of a user handler. ! ! 2008-08-20 Robert Dewar ! ! * freeze.adb (Freeze_Record_Type): Improve msg for non-contiguous field ! ! * sem_ch13.adb: ! (Adjust_Record_For_Reverse_Bit_Order): Messages about layout are ! now labeled as info msgs, not warnings. ! ! * tbuild.ads: Clarify documentation of Make_Implicit_Exception_Handler ! ! * usage.adb: Minor change to avoid overlong line for -gnatwz/Z ! ! * a-textio.adb: Remove redundant test. ! ! * a-witeio.adb: Minor code reorganization ! Remove redundant test found working on another issue ! ! * a-ztexio.adb: Minor code reorganization ! Remove redundant test found working on another issue ! ! 2008-08-20 Thomas Quinot ! ! * s-fileio.adb (Open) Use C helper function to determine whether a ! given errno value corresponds to a "file not found" error. ! ! * sysdep.c (__gnat_is_file_not_found_error): New C helper function. ! ! 2008-08-20 Jose Ruiz ! ! * errno.c (__get_errno for MaRTE): Use the MaRTE function pthread_errno ! to get access to the per-task errno variable. ! (__set_errno for MaRTE): Do not redefine this function here since it is ! already defined in MaRTE. ! ! 2008-08-20 Tristan Gingold ! ! * gnat_ugn.texi: Gcov is not supported on static library on AIX. ! ! 2008-08-20 Robert Dewar ! ! * freeze.adb: Minor reformatting ! ! * g-comlin.adb: Minor reformatting ! ! * g-socket.adb: Minor reformatting ! ! * g-socthi-mingw.adb: Minor reformatting ! ! * g-stheme.adb: Minor reformatting ! ! 2008-08-20 Ed Schonberg ! ! * sem_aggr.adb, sem_type.adb, exp_ch9.ads, einfo.ads, ! exp_ch6.adb, exp_aggr.adb (Valid_Ancestor): Resolve ! confusion between partial and full views of an ancestor of the context ! type when the parent is a private extension declared in a parent unit, ! and full views are available for the context type. ! ! 2008-08-18 Samuel Tardieu ! Robert Dewar ! ! PR ada/30827 ! * bindgen.adb (Gen_Output_File_Ada): Zero-terminate the ! version string. ! Move comment in the right place. ! * g-comver.adb (Version): Look for a zero-termination in ! addition to a closing parenthesis. ! ! 2008-08-18 Samuel Tardieu ! ! * exp_ch13.adb, exp_disp.adb, sem_cat.adb, sem_ch10.adb, ! * sem_ch12.adb, sem_ch6.adb, sem_ch7.adb, sem_ch8.adb, ! * sem_prag.adb, sem_util.adb, sem_warn.adb: Use ! Is_Package_Or_Generic_Package instead of hand-crafted tests. ! ! 2008-08-18 Samuel Tardieu ! ! PR ada/15808 ! * sem_ch6.adb (Check_Private_Overriding): Check for generic packages ! as well. ! ! 2008-08-17 Aaron W. LaFramboise ! ! * adaint.c (_gnat_set_close_on_exec) [_WIN32]: Implement. ! ! 2008-08-16 Eric Botcazou ! ! * gcc-interface/trans.c (call_to_gnu): Use the Sloc of the call ! for back-copy statements in lieu of that of the actual. ! ! 2008-08-16 Eric Botcazou ! ! PR ada/20548 ! * gcc-interface/decl.c (gnat_to_gnu_entity): Use DECL_SIZE_UNIT in the ! setjmp test consistently. Adjust for new behavior of flag_stack_check. ! * gcc-interface/utils2.c (build_call_alloc_dealloc): Remove redundant ! test of flag_stack_check. Adjust for new behavior of flag_stack_check. ! ! 2008-08-13 Samuel Tardieu ! ! PR ada/36777 ! * sem_util.ads, sem_util.adb (Is_Protected_Self_Reference): New. ! * sem_attr.adb (Check_Type): The current instance of a protected ! object is not a type name. ! (Analyze_Access_Attribute): Accept instances of protected objects. ! (Analyze_Attribute, Attribute_Address clause): Ditto. ! * exp_attr.adb (Expand_N_Attribute_Reference): Rewrite ! the prefix as being the current instance if needed. ! ! 2008-08-12 Danny Smith ! ! * gcc-interface/Makefile.in (EXTRA_GNATRTL_NONTASKING_OBJS) [WINDOWS]: ! Remove duplicate s-win32.o. Add s-winext.o. ! ! 2008-08-12 Danny Smith ! ! * g-stsifd-sockets.adb (Create): Replace Constants.SOCK_STREAM ! with SOSC.SOCK__STREAM. ! * g-socthi-mingw.adb (C_Select) Replace Constants.MSG_OOB with ! SOSC.MSG_OOB. ! ! 2008-08-11 Joel Sherrill ! ! * s-oscons-tmplt.c: RTEMS defines AF_INET6 but does support it. ! * gsocket.h, socket.c: Update to support RTEMS. ! * gcc-interface/Make-lang.in: Include CFLAGS_FOR_TARGET when cross. ! ! 2008-08-10 Samuel Tardieu ! Robert Dewar ! ! * exp_ch4.adb (Expand_N_Op_Expon): Force evaluation of ! left argument even when right argument is 0. ! (Expand_N_Op_Mod): Ditto when right argument is 1. ! (Expand_N_Op_Multiply): Ditto when any argument is 0. ! (Expand_N_Op_Rem): Ditto when right argument is 1. ! ! 2008-08-09 Manuel Lopez-Ibanez ! ! * gcc-interface/misc.c (gnat_handle_option): Replace set_Wunused ! by warn_unused. ! ! 2008-08-08 Ed Schonberg ! ! * freeze.adb (Generate_Prim_Op_References): New procedure, abstracted ! from Freeze_Entity. Used to generate cross-reference information for ! types declared in generic packages. ! ! 2008-08-08 Thomas Quinot ! ! * gcc-interface/Makefile.in: Reintroduce g-soccon.ads as a ! compatibility shim. ! ! 2008-08-08 Thomas Quinot ! ! * gsocket.h: ! On Windows, include and redefine only selected errno values ! from their definitions. ! ! * s-osinte-freebsd.ads: Minor reformatting ! ! * s-osinte-hpux.ads, s-osinte-irix.ads: Minor reformatting ! ! * g-soccon.ads: New file. ! ! * g-stheme.adb, g-socthi-vms.adb, g-socthi-vxworks.adb, ! g-socthi-mingw.adb, g-sttsne-vxworks.adb, g-socthi.adb, ! g-stsifd-sockets.adb, g-socket.adb, g-socket.ads, ! g-sothco.adb, g-sothco.ads: Add back GNAT.Sockets.Constants as a child ! unit, to allow building software that depends on this internal unit ! with both older and newer compilers. ! ! 2008-08-08 Robert Dewar ! ! * s-strxdr.adb: Minor reformatting ! ! 2008-08-08 Bob Duff ! ! * gnat_ugn.texi: The "Run-Time Checks" section said "arithmetic overflow ! checking for integer operations (including division by zero)", which ! is wrong -- divide by zero is not part of overflow checking. ! Also added misc clarification about what check-suppression means. ! ! * gnat_rm.texi: Clarify the meaning of pragma Suppress. ! ! 2008-08-08 Jerome Lambourg ! ! * g-comlin.adb (Add_Switch): Handle addition of switches at the ! begining of the command line. ! (Append, Add): Renaming of Append to Add as this now allows addition ! at the begining of the list. ! ! * g-comlin.ads (Add_Switch): Handle addition of switches at the ! begining of the command line. ! ! 2008-08-08 Thomas Quinot ! ! * g-sercom.ads: ! (Name): Document application scope (only legacy PC serial ports on ! Linux and Windows). ! ! 2008-08-08 Thomas Quinot ! ! * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Revert ! previous change, not needed after all. ! ! 2008-08-08 Ed Schonberg ! ! * exp_ch4.adb (Expand_Allocator_Expression): add check if null ! exclusion indicator is present ! ! 2008-08-08 Robert Dewar ! ! * g-comlin.adb: Minor code reorganization ! Minor reformatting ! ! * g-comlin.ads: Minor reformatting ! ! * s-fileio.adb: Minor reformatting ! ! * sem_attr.adb: Minor code reorganization (use Nkind_In) ! Minor reformatting ! ! 2008-08-06 Samuel Tardieu ! ! * gcc-interface/Make-lang.in: Use GCC_FOR_TARGET when dealing ! with s-oscons-tmplt.i. ! ! 2008-08-06 Samuel Tardieu ! ! * gcc-interface/Make-lang.in (OSCONS_CPPFLAGS): Remove. ! ! 2008-08-06 Ed Schonberg ! ! * sem_ch3.adb (Analyze_Component_Declaration): Protect against misuse ! of incomplete type. ! ! * sem_ch8.adb (Analyze_Object_Renaming): Diagnose properly a renaming ! of a formal parameter of an incomplete type. Improve error message for ! other improper uses of incomplete types. ! ! 2008-08-06 Robert Dewar ! ! * gnat_ugn.texi: Clarify -gnato documentation ! ! 2008-08-06 Thomas Quinot ! ! * gcc-interface/Makefile.in, ! g-socthi-vxworks.adb, g-socthi-mingw.adb, g-sttsne-vxworks.adb, ! g-socthi.adb, g-socket.adb, g-socket.ads, g-sothco.ads, ! g-soccon-linux-x86.ads, g-soccon-vxworks.ads, g-soccon-mingw.ads, ! g-soccon-hpux-ia64.ads, g-soccon-irix.ads, g-soccon-linux-64.ads, ! g-soccon-aix.ads, g-soccon-solaris.ads, g-soccon-lynxos.ads, ! g-soccon-vms.ads, g-soccon.ads, g-soccon-freebsd.ads, ! g-soccon-linux-ppc.ads, g-soccon-tru64.ads, g-soccon-hpux.ads, ! g-soccon-solaris-64.ads, gen-oscons.c, g-soccon-darwin.ads, ! g-soccon-mingw-64.ads, g-soccon-linux-mips.ads, g-soccon-rtems.ads: ! Remove GNAT.Sockets.Constants. This internal package is replaced by ! System.OS_Constants. ! ! 2008-08-06 Thomas Quinot ! ! * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: ! Remove obsolete targets referencing gen-soccon ! When generating s-oscons.ads, use a file name that includes the ! THREAD_KIND, to ensure that the (potentially different) version from a ! previous build with a different threads flavour does not get reused. ! ! 2008-08-06 Thomas Quinot ! ! * sem_res.adb: Minor reformatting ! ! * s-fileio.adb (Open): When file open operation fails, raise Name_Error ! only when the operating system reports a non-existing file or directory ! (ENOENT), otherwise raise Name_Error. ! ! * exp_ch11.adb: Minor reformatting ! ! 2008-08-06 Ed Schonberg ! ! * sem_ch3.adb (Access_Subprogram_Declaration): If the return type is ! incomplete, add the access_to_subprogram type to the list of private ! dependents only if the incomplete type will be completed in the current ! scope. ! (Build_Discriminant_Constraints): If the type of the discriminant is ! access_to_variable, reject a constraint that is access_to_constant. ! ! 2008-08-06 Thomas Quinot ! ! * g-socket-dummy.adb, g-socket-dummy.ads, g-sothco-dummy.adb, ! g-sothco-dummy.ads, g-socthi-dummy.adb, g-socthi-dummy.ads, ! g-sttsne-dummy.ads: New files. ! ! * gcc-interface/Makefile.in, Makefile.rtl: Use placeholder sources ! with pragma Unimplemented_Unit for sockets packages on Nucleus. ! ! 2008-08-06 Pascal Obry ! ! * adaint.c: Another fix for ACL support on Windows. ! ! 2008-08-06 Javier Miranda ! ! * exp_disp (Expand_Interface_Actuals): Adds missing support for ! expansion of calls to subprograms using selected components. ! ! 2008-08-06 Ed Schonberg ! ! * sem_res.adb (Resolve_Call): Use base type to determine whether a ! dereference is needed because a subtype of an access_to_subprogram is ! simply an access-subtype ! ! 2008-08-06 Jerome Lambourg ! ! * g-comlin.adb (Set_Command_Line): Now that aliases can contain ! parameters, always specify the expected separator. ! ! 2008-08-06 Thomas Quinot ! ! * xnmake.adb: Use new XUtil package for platform independent text ! output. ! ! 2008-08-06 Vincent Celier ! ! * gnat_ugn.texi: Document compiler switch -gnateG ! ! 2008-08-06 Quentin Ochem ! ! * s-stausa.adb (Fill_Stack): Fixed pragma assert and top pattern mark ! in the case of an empty pattern size. ! (Compute_Result): Do not do any computation in the case of an empty ! pattern size. ! (Report_Result): Fixed computation of the overflow guard. ! ! 2008-08-06 Ed Schonberg ! ! * g-awk.adb (Finalize): Do not use directly objects of the type in the ! finalization routine to prevent elaboration order anomalies in new ! finalization scheme. ! ! 2008-08-06 Ed Schonberg ! ! * sem_ch3.adb (Find_Type_Name): protect against duplicate incomplete ! declaration for the same type. ! ! 2008-08-06 Thomas Quinot ! ! * sem.adb: Minor rewording (comment) ! ! 2008-08-06 Jerome Lambourg ! ! * g-comlin.adb (Define_Switch, Get_Switches): New. ! (Can_Have_Parameter, Require_Parameter, Actual_Switch): New, used when ! ungrouping switches. ! (For_Each_Simple_Switch): Allow more control over parameters handling. ! This generic method now allows ungrouping of switches with parameters ! and switches with more than one letter after the prefix. ! (Set_Command_Line): Take care of switches that are prefixed with a ! switch handling parameters without delimiter (-gnatya and -gnaty3 for ! example). ! (Add_Switch, Remove_Switch): Handle parameters possibly present inside ! a group, as in gnaty3aM80 (3 and 80 are parameters). Report status of ! the operation. ! (Start, Alias_Switches, Group_Switches): Take care of parameters ! possibly present inside a group. ! ! * g-comlin.ads (Define_Switch): New method used to define a list of ! expected switches, that are necessary for correctly ungrouping switches ! with more that one character after the prefix. ! (Get_Switches): Method that builds a getopt string from the list of ! switches as set previously by Define_Switch. ! (Add_Switch, Remove_Switch): New versions of the methods, reporting the ! status of the operation. Also allow the removal of switches with ! parameters only. ! (Command_Line_Configuration_Record): Maintain a list of expected ! switches. ! ! 2008-08-06 Doug Rupp ! ! * gcc-interface/decl.c (gnat_to_gnu_param): Force 32bit descriptor if ! TARGET_MALLOC64 clear. ! ! * gcc-interface/utils2.c (build_call_alloc_dealloc): Force 32bit malloc ! if TARGET_MALLOC64 clear. ! ! * gcc-interface/gigi.h (TARGET_ABI_OPEN_VMS): Move here from utils2.c ! (TARGET_MALLC64): New macro. Default to clear. ! ! 2008-08-06 Doug Rupp ! ! * gcc-interface/utils2.c (snames.h) Include ! (TARGET_ABI_OPEN_VMS): Initialize. ! (build_call_alloc_dealloc); [TARGET_ABI_OPEN_VMS] Allocate on 32bit heap ! for Convention C. ! ! 2008-08-06 Ed Schonberg ! ! * sem_ch3.adb (Process_Discriminants): diagnose redundant or improper ! null exclusion in a discriminant declaration ! ! * sem_ch8.adb (Analyze_Object_Renaming): diagnose null exclusion ! indicators when type is not an access type. ! ! * sem_ch12.adb (Formal_Object_Declaration): diagnose null exclusion ! indicators when type is not an access type. ! ! 2008-08-06 Javier Miranda ! ! * exp_disp (Expand_Interface_Conversion): Freeze the entity associated ! with the target interface before expanding the code of the interface ! conversion. ! ! 2008-08-05 Ed Schonberg ! ! * freeze.adb: ! (Freeze_Entity): A deferred constant does not violate the restriction ! No_Default_Initialization, ! ! * sem_ch3.adb (Process_Subtype): An allocator is a valid construct that ! can carry a null exclusion indicator, and on which an error may be ! posted if the indicator is redundant. ! ! * sem_ch8.adb (Analyze_Object_Renaming): Verify that a null exclusion ! does not apply to a subtype mark that already excludes null. ! ! * sem_ch12.adb (Formal_Object_Declaration): Verify that a null ! exclusion does not apply to a subtype mark that already excludes null. ! ! 2008-08-05 Thomas Quinot ! ! * Makefile.rtl: Compile s-oscons.ads as part of the runtime library. ! ! 2008-08-05 Doug Rupp ! ! * vms_data.ads: Translation for /POINTER_SIZE qualifier. ! ! 2008-08-05 Thomas Quinot ! ! * gsocket.h: Make this file includable in a Nucleus environment, which ! does not support sockets. ! ! * socket.c: Remove Nucleus-specific hack. ! ! 2008-08-05 Pascal Obry ! ! * adaint.c: Remove support for readable attribute on vxworks and nucleus ! ! 2008-08-05 Ed Schonberg ! ! * sem_attr.adb: ! (Analyze_Attribute, case 'Result): handle properly the case where some ! operand of the expression in a post-condition generates a transient ! block. ! ! * sem_ch5.adb (Analyze_Assignment_Statement): Apply conversion to ! right-hand side when it is an anonymous access_to_subprogram, to force ! static accessibility check when needed. ! ! 2008-08-05 Sergey Rybin ! ! * gnat_ugn.texi: Changing the description of the gnatcheck metrics ! rule according to the change in the rule option. ! Add documentation for -gnatw.b/-gnatw.B ! ! 2008-08-05 Robert Dewar ! ! * ug_words: Add entries for -gnatw.b/-gnatw.B ! ! * vms_data.ads: Add entries for -gnatw.b/-gnatw.B ! ! 2008-08-05 Vincent Celier ! ! * a-wtdeio.adb (Put (Current_Output)): Use Fore in the call to Put ! (File). ! ! * a-ztdeio.adb: Ditto. ! ! 2008-08-05 Pascal Obry ! ! * adaint.c, adaint.h, s-os_lib.adb, s-os_lib.ads: Add support for the ! readable attribute. ! ! 2008-08-05 Vincent Celier ! ! * s-wchwts.adb: ! (Wide_String_To_String): Returns a String with the same 'First as its ! parameter S. ! (Wide_Wide_String_To_String): Ditto ! ! * s-wchwts.ads: ! (Wide_String_To_String): Document that the lowest index of the returned ! String is equal to S'First. ! ! 2008-08-05 Thomas Quinot ! ! * xoscons.adb, xutil.ads, xutil.adb, s-oscons-tmplt.c: New files. ! ! * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Generate ! s-oscons.ads ! ! 2008-08-05 Robert Dewar ! ! * opt.ads (Warn_On_Biased_Representation): New flag ! ! * sem_ch13.adb: ! (Analyze_Attribute_Definition_Clause): Issue warning when biased ! representation is required. ! (Minimum_Size): Don't allow biasing if enum rep clause case ! ! * sem_warn.adb: ! (Set_Dot_Warning_Switch): Add handling of -gnatw.b/B switches ! (Set_Warning_Switch): Include -gnatw.b in -gnatwa, -gnatw.B in gnatws ! ! * usage.adb: Add lines for -gnatw.b/B switches ! ! 2008-08-05 Pascal Obry ! ! * a-coinve.adb: Reorder the code to avoid uninitialized warning. ! ! * adaint.c: In UNIX cases do not call __gnat_stat but stat directly. ! ! 2008-08-05 Thomas Quinot ! ! * socket.c: Minor reformatting. ! ! 2008-08-05 Robert Dewar ! ! * sem_ch3.adb: Minor reformatting ! ! * prj-nmsc.adb: Minor reformatting ! ! 2008-08-05 Ed Schonberg ! ! * sem_ch12.adb (Validate_Array_Type_Instance): Only apply complex ! visibility check on the component type if the simple test fails. ! ! 2008-08-05 Jose Ruiz ! ! * init.c (__gnat_install_handler for linux): If we are building the ! Xenomai run time then we need to do two additional things: avoid ! memory swapping and transform the Linux environment task into a native ! Xenomai task. ! ! * gcc-interface/Makefile.in (LIBGNAT_TARGET_PAIRS for xenomai run ! time): Use interface to Xenomai native skin and avoid linux-specific ! way of setting CPU affinity. ! (EH_MECHANISM for the xenomai run time): Use sjlj exception mechanism. ! ! 2008-08-05 Bob Duff ! ! * checks.ads: Minor comment fix ! ! 2008-08-05 Thomas Quinot ! ! * g-sercom.adb, g-sercom.ads, g-sercom-mingw.adb, ! g-sercom-linux.adb (Data_Bits): Change literals B7 and B8 to CS7 and ! CS8. ! ! 2008-08-05 Robert Dewar ! ! * mlib.adb: Minor code reorganization ! Minor reformatting ! ! * make.adb: Minor reformatting ! ! * prj-attr.ads: Minor reformatting ! ! * s-os_lib.adb: Minor reformatting ! ! * s-fileio.adb: Minor code reorganization ! Minor reformatting ! ! * prj.ads: Minor reformatting ! ! 2008-08-05 Bob Duff ! ! * sem_ch3.adb (Analyze_Object_Declaration): Avoid type Any_Access in ! unresolved initial value of "null", because it causes implicitly ! generated "=" operators to be ambiguous, and because this type should ! not be passed to gigi. ! ! 2008-08-05 Vincent Celier ! ! * mlib.adb: Update comments. ! ! * make.adb (Switches_Of): Check for Switches (others), before checking ! for Default_Switches ("Ada"). ! (Gnatmake): Use Builder'Switches (others) in preference to ! Builder'Default_Switches ("Ada") if there are several mains. ! ! * prj-attr-pm.adb: ! (Add_Attribute): Add component Others_Allowed in Attribute_Record ! aggregate. ! ! * prj-attr.adb: ! Add markers to indicates that attributes Switches allow others as index ! (Others_Allowed_For): New Boolean function, returning True for ! attributes with the mark. ! (Initialize): Recognize optional letter 'O' as the marker for ! associative array attributes where others is allowed as the index. ! ! * prj-attr.ads: ! (Others_Allowed_For): New Boolean function ! (Attribute_Record): New Boolean component Others_Allowed ! ! * prj-dect.adb: ! (Parse_Attribute_Declaration): For associative array attribute where ! others is allowed as the index, allow others as an index. ! ! * prj-nmsc.adb: ! (Process_Binder): Skip associative array attributes with index others ! (Process_Compiler): Ditto ! ! * prj-util.adb: ! (Value_Of (Index, In_Array)): Make no attempt to put in lower case when ! index is All_Other_Names. ! ! * prj.ads: ! (All_Other_Names): New constant ! ! * prj-proc.adb: ! (Process_Declarative_Items): Skip associative array attribute when index ! is reserved word "others". ! ! 2008-08-05 Vasiliy Fofanov ! ! * gen-oscons.c: Adapt for VMS where termios.h is not available. ! ! 2008-08-05 Thomas Quinot ! ! * a-rttiev.adb: Minor reformatting (comments) ! ! * gen-soccon.c: Rename to gen-oscons.c ! ! * gen-oscons.c: New file. Now generate System.OS_Constants instead of ! GNAT.Sockets.Constants. ! Add new constants for GNAT.Serial_Communications and System.File_IO. ! ! 2008-08-05 Javier Miranda ! ! * sem_util.adb (Collect_Interfaces_Info): Minor reformating. ! * exp_ch3.adb (Build_Offset_To_Top_Functions): Code cleanup: the ! implementation of this routine has been simplified. ! ! 2008-08-05 Pascal Obry ! ! * adaint.c, adaint.h, s-os_lib.adb, s-os_lib.ads: Fix the ! Set_Read_Only Win32 implementation. ! ! 2008-08-05 Thomas Quinot ! ! * exp_strm.adb: Minor reformatting (comments) ! ! * sem_ch12.adb: Minor reformatting. ! ! 2008-08-05 Robert Dewar ! ! * sem_ch3.adb: Minor reformatting ! ! * checks.adb: Minor reformatting ! ! 2008-08-05 Thomas Quinot ! ! * tbuild.ads (New_External_Name): Update spec to reflect relaxed ! restriction on Prefix. ! ! 2008-08-05 Jerome Lambourg ! ! * g-comlin.adb (Sort_Sections, Group_Switches): New/Modified internal ! methods needed to handle switch sections when building a command line. ! (Define_Section, Add_Switch, Remove_Switch, Is_New_Section, ! Current_Section): New public methods or methods modified to handle ! building command lines with sections. ! (Set_Command_Line): Take into account sections when analysing a switch ! string. ! (Start): Sort the switches by sections before iterating the command line ! elements. ! ! * g-comlin.ads (Define_Section, Add_Switch, Remove_Switch, ! Is_New_Section, Current_Section): New methods or methods modified to ! handle building command lines with sections. ! ! 2008-08-05 Ed Schonberg ! ! * exp_strm.adb (Build_Record_Or_Elementary_Input_Function): For access ! discriminants, indicate that the corresponding object declaration has ! no initialization, to prevent spurious warnings when the access type is ! null-excluding. ! ! 2008-08-05 Ed Schonberg ! ! * sem_res.adb (Resolve_Call): If this is a call to the predefined ! Abort_Task, warn if the call appears within a protected operation. ! ! 2008-08-04 Robert Dewar ! ! * exp_ch4.adb (Expand_N_In): Suppress range warnings in instances ! ! 2008-08-04 Ed Schonberg ! ! * sem_ch3.adb: ! (Replace_Anonymous_Access_To_Protected_Subprogram): Handle properly an ! anonymous access to protected subprogram that is the return type of the ! specification of a subprogram body. ! ! * sem_ch6.adb: ! (Analyze_Subprogram_Body): if the return type is an anonymous access to ! subprogram, freeze it now to prevent access anomalies in the back-end. ! ! * exp_ch9.adb: Minor code cleanup. ! Make sure that new declarations are inserted into the tree before ! analysis (from code reading). ! ! 2008-08-04 Robert Dewar ! ! * exp_ch5.adb: ! (Expand_Simple_Function_Return): Check No_Secondary_Stack restriction ! at point of return. ! ! 2008-08-04 Thomas Quinot ! ! * sem_type.adb, sem_ch4.adb, sprint.adb, exp_ch3.adb: Minor reformatting ! ! 2008-08-04 Vasiliy Fofanov ! ! * g-soccon-mingw.ads: Fix value for MSG_WAITALL ! ! 2008-08-04 Javier Miranda ! ! * sem_prag.adb (Process_Convention): Add missing support for ! N_Private_Extension_Declaration nodes. ! ! 2008-08-04 Robert Dewar ! ! * exp_ch4.adb: Minor reformatting ! ! 2008-08-04 Pascal Obry ! ! * adaint.h: Add missing prototype. ! ! * adaint.c: Refine support for Windows file attributes. ! ! 2008-08-04 Robert Dewar ! ! * sem_res.adb: ! (Valid_Conversion): Catch case of designated types having different ! sizes, even though they statically match. ! ! 2008-08-04 Javier Miranda ! ! * sem_eval.adb (Subtypes_Statically_Match): Remove superfluous patch ! added in previous patch to handle access to subprograms. ! ! 2008-08-04 Robert Dewar ! ! * freeze.adb: ! (Freeze_Entity): Only check No_Default_Initialization restriction for ! constructs that come from source ! ! 2008-08-04 Thomas Quinot ! ! * exp_ch6.adb: Minor comment fix. ! ! * sem_ch4.adb: Minor reformatting. ! ! 2008-08-04 Robert Dewar ! ! * sem_res.adb: (Large_Storage_Type): Improve previous change. ! ! 2008-08-04 Pascal Obry ! ! * adaint.c, s-os_lib.adb, s-os_lib.ads: Use Windows ACL to deal with ! file attributes. ! ! 2008-08-04 Javier Miranda ! ! * sem_ch3.adb (Access_Subprogram_Declaration): Adding missing support ! for N_Formal_Object_Declaration nodes. Adding kludge required by ! First_Formal to provide its functionality with access to functions. ! (Replace_Anonymous_Access_To_Protected_Subprogram): Add missing support ! for anonymous access types returned by functions. ! ! * sem_ch5.adb (Analyze_Assignment): Code cleanup to avoid duplicate ! conversion of null-excluding access types (required only once to force ! the generation of the required runtime check). ! ! * sem_type.adb (Covers): minor reformating ! ! * checks.adb (Null_Exclusion_Static_Checks): Avoid reporting errors ! with internally generated nodes. Avoid generating the error inside init ! procs. ! ! * sem_res.adb (Resolve_Membership_Test): Minor reformating. ! (Resolve_Null): Generate the null-excluding check in case of assignment ! to a null-excluding object. ! (Valid_Conversion): Add missing support for anonymous access to ! subprograms. ! ! * sem_ch6.adb (Check_Return_Subtype_Indication): Add missing support for ! anonymous access types whose designated type is an itype. This case ! occurs with anonymous access to protected subprograms types. ! (Analyze_Return_Type): Add missing support for anonymous access to ! protected subprogram. ! ! * sem_eval.adb (Subtypes_Statically_Match): In case of access to ! subprograms addition of missing check on matching convention. Required ! to properly handle access to protected subprogram types. ! ! * exp_ch3 (Build_Assignment): Code cleanup removing duplicated check on ! null excluding access types. ! ! 2008-08-04 Ed Schonberg ! ! * sem_ch12.adb: Add comments ! ! * sem_ch4.adb (Analyze_Allocator): If the designated type is a non-null ! access type and the allocator is not initialized, warn rather than ! reporting an error. ! ! 2008-08-04 Robert Dewar ! ! * exp_ch4.adb: Minor reformatting ! ! * exp_dist.adb: Minor reformatting ! ! * g-comlin.adb: Minor reformatting ! ! 2008-08-04 Gary Dismukes ! ! * exp_aggr.adb (Build_Record_Aggr_Code): Perform a conversion of the ! target to the type of the aggregate in the case where the target object ! is class-wide. ! ! * exp_ch5.adb (Expand_Simple_Function_Return): When the function's ! result type is class-wide and inherently limited, and the expression ! has a specific type, create a return object of the specific type, for ! more efficient handling of returns of build-in-place aggregates (avoids ! conversions of the class-wide return object to the specific type on ! component assignments). ! ! * sem_ch6.adb (Check_Return_Subtype_Indication): Suppress the error ! about a type mismatch for a class-wide function with a return object ! having a specific type when the object declaration doesn't come from ! source. Such an object can result from the expansion of a simple return. ! ! 2008-08-04 Vasiliy Fofanov ! ! * g-soccon-mingw-64.ads, system-mingw-x86_64.ads: New files. ! ! * gcc-interface/Makefile.in: Use 64bit-specific system files when ! compiling for 64bit windows. ! ! 2008-08-04 Jerome Lambourg ! ! * g-comlin.adb (Group_Switches): Preserve the switch order when ! grouping and allow switch grouping of switches with more than one ! character extension (e.g. gnatw.x). ! (Args_From_Expanded): Remove this now obsolete method. ! ! 2008-08-04 Ed Schonberg ! ! * exp_ch4.adb (Get_Allocator_Final_List): Freeze anonymous type for ! chain at once, to ensure that type is properly decorated for back-end, ! when allocator appears within a loop. ! ! 2008-08-04 Kevin Pouget ! ! * snames.h, snames.adb, snames.ads: ! Add Attr_To_Any, Attr_From_Any and Attr_TypeCode defines. ! ! * exp_dist.ads, exp_dist.adb: Add Build_From_Any_Call, ! Build_To_Any_Call and Build_TypeCode_Call procedures. ! ! * exp_attr.adb, sem_attr.adb: Add corresponding cases. ! ! * rtsfind.ads: Add corresponding names. ! ! * tbuild.adb: Update prefix restrictions to allow '_' character. ! ! 2008-08-04 Doug Rupp ! ! * gigi.h (fill_vms_descriptor): Add third parameter gnat_actual ! * trans.c (call_to_gnu): Call fill_vms_descriptor with new parameter. ! * utils2.c (fill_vms_descriptor): Add third parameter for error sloc and ! use it. Calculate pointer range overflow using 64bit types. ! ! 2008-08-04 Ed Schonberg ! ! * sem_ch3.adb (Access_Definition): A formal object declaration is a ! legal context for an anonymous access to subprogram. ! ! * sem_ch4.adb (Analyze_One_Call): If the call can be interpreted as an ! indirect call, report success to the caller to include possible ! interpretation. ! ! * sem_ch6.adb (Check_Return_Type_Indication): Apply proper conformance ! check when the type ! of the extended return is an anonymous access_to_subprogram type. ! ! * sem_res.adb: ! (Resolve_Call): Insert a dereference if the type of the subprogram is an ! access_to_subprogram and the context requires its return type, and a ! dereference has not been introduced previously. ! ! 2008-08-04 Arnaud Charlet ! ! * usage.adb (Usage): Minor rewording of -gnatwz switch, to improve ! gnatcheck support in GPS. ! ! 2008-08-04 Vincent Celier ! ! * mlib.adb (Create_Sym_Links): Create relative symbolic links when ! requested ! ! 2008-08-04 Vincent Celier ! ! * gprep.adb (Process_One_File): Call Prep.Preprocess with a Boolean ! variable, but don't check the resulting value as it has no impact on ! the processing. ! ! * opt.ads: ! (Generate_Processed_File): New Boolean flag, set to True in the compiler ! when switch -gnateG is used. ! ! * prep.adb: ! (Preprocess): new Boolean out parameter Source_Modified. Set it to True ! when the source is modified by the preprocessor and there is no ! preprocessing errors. ! ! * prep.ads (Preprocess): new Boolean out parameter Source_Modified ! ! * sinput-l.adb: ! (Load_File): Output the result of preprocessing if the source text was ! modified. ! ! * switch-c.adb (Scan_Front_End_Switches): Recognize switch -gnateG ! ! * switch-m.adb (Normalize_Compiler_Switches): Normalize switch -gnateG ! ! * ug_words: Add VMS equivalent for -gnateG ! ! * vms_data.ads: ! Add VMS option /GENERATE_PROCESSED_SOURCE, equivalent to switch -gnateG ! ! 2008-08-04 Doug Rupp ! ! * gcc-interface/utils2.c: ! (fill_vms_descriptor): Raise CE if attempt made to pass 64bit pointer ! in 32bit descriptor. ! ! 2008-08-04 Robert Dewar ! ! * par-ch10.adb: Minor reformatting ! ! * i-cobol.adb: Minor reformatting. ! ! 2008-08-04 Ed Schonberg ! ! * sem_ch3.adb (Access_Definition): Create an itype reference for an ! anonymous access return type of a regular function that is not a ! compilation unit. ! ! 2008-08-04 Vincent Celier ! ! * prj-attr.adb: New Builder attribute Global_Compilation_Switches ! ! * snames.adb: New standard name Global_Compilation_Switches ! ! * snames.ads: New standard name Global_Compilation_Switches ! ! * make.adb: Correct spelling error in comment ! ! 2008-08-04 Arnaud Charlet ! ! * sem_prag.adb (Check_Form_Of_Interface_Name): Fix handling for CLI ! target. ! ! 2008-08-04 Thomas Quinot ! ! * sem_ch10.adb: Minor comment fix. ! ! 2008-08-04 Robert Dewar ! ! * restrict.adb: Improved messages for restriction warnings ! ! * restrict.ads: Improved messages for restriction messages ! ! * s-rident.ads (Profile_Name): Add No_Profile ! ! 2008-08-04 Robert Dewar ! ! * system-darwin-x86.ads: Correct bad definition of Max_Nonbinary_Modulus ! ! 2008-08-04 Robert Dewar ! ! * freeze.adb (Freeze_Entity): Check for size clause for boolean warning ! ! 2008-08-04 Vincent Celier ! ! * prj-proc.adb: ! (Copy_Package_Declarations): When inheriting package Naming from a ! project being extended, do not inherit source exception names. ! ! 2008-08-04 Ed Schonberg ! ! * sem_prag.adb (Check_Precondition_Postcondition): When scanning the ! list of declaration to find previous subprogram, do not go to the ! original node of a generic unit. ! ! 2008-08-02 Eric Botcazou ! ! * gcc-interface/utils2.c (build_binary_op) : ! New case. Convert BOOLEAN_TYPE operation to the default integer type. ! ! 2008-08-01 Eric Botcazou ! ! * gcc-interface/ada-tree.h (DECL_PARM_ALT): Now DECL_PARM_ALT_TYPE. ! * gcc-interface/decl.c (gnat_to_gnu_param): Fix formatting, simplify ! and adjust for above renaming. ! * gcc-interface/utils.c (convert_vms_descriptor): Likewise. Add new ! gnu_expr_alt_type parameter. Convert the expression to it instead ! of changing its type in place. ! (build_function_stub): Adjust call to above function. ! ! 2008-08-01 Eric Botcazou ! ! * gcc-interface/decl.c (gnat_to_gnu_entity) : Remove dead ! code. Do not get full definition of deferred constants with address ! clause for a use. Do not ignore deferred constant definitions with ! address clause. Ignore constant definitions already marked with the ! error node. ! : Remove obsolete comment. For a deferred constant with ! address clause, get the initializer from the full view. ! * gcc-interface/trans.c (gnat_to_gnu) : ! Rework and remove obsolete comment. ! : For a deferred constant with address clause, ! mark the full view with the error node. ! * gcc-interface/utils.c (convert_to_fat_pointer): Rework and fix ! formatting nits. ! ! 2008-08-01 Hristian Kirtchev ! ! * rtsfind.ads: Add block IO versions of stream routines for Strings. ! ! * bindgen.adb, gnat_rm.texi, gnat_ugn.texi, opt.ads, ! sem_prag.adb, snames.adb, snames.ads, snames.h, ! par-prag.adb: Undo previous stream related changes. ! ! * s-rident.ads: Add new restriction No_Stream_Optimizations. ! ! * s-ststop.ads, s-ststop.adb: Comment reformatting. ! Define enumeration type to designate different IO mechanisms. ! Enchance generic package Stream_Ops_Internal to include an ! implementation of Input and Output. ! ! * exp_attr.adb (Find_Stream_Subprogram): If restriction ! No_Stream_Optimization is active, choose the default byte IO ! implementations of stream attributes for Strings. ! Otherwise use the corresponding block IO version. ! ! 2008-08-01 Olivier Hainque ! ! * gcc-interface/decl.c (gnat_to_gnu_entity) : Do not ! turn Ada Pure into GCC const, now implicitely implying nothrow as well. ! ! 2008-08-01 Robert Dewar ! ! * par-ch3.adb (P_Defining_Identifier): Avoid repeated attempt to ! convert plain identifier into defining identifier. ! ! 2008-08-01 Robert Dewar ! ! * sem_prag.adb (Check_Form_Of_Interface_Name): Refine and improve ! warnings ! ! * lib-xref.adb: Add error defense. ! ! 2008-08-01 Bob Duff ! ! * ioexcept.ads, sequenio.ads, directio.ads: Correct comment. ! ! 2008-08-01 Gary Dismukes ! ! * exp_ch6.adb (Expand_Call): Adjustment to previous fix for passing ! correct accessibility levels. In the "when others" case, retrieve the ! access level of the Etype of Prev rather than Prev_Orig, because the ! original exression has not always been analyzed. ! ! 2008-08-01 Robert Dewar ! ! * prj-nmsc.adb: Minor reformatting ! ! * sem_ch4.adb: Minor reformatting ! Minor code reorganization ! ! * prj.ads: Minor reformatting ! ! * s-os_lib.adb: Minor reformatting ! ! * par-prag.adb (Prag, case Wide_Character_Encoding): Deal with upper ! half encodings ! ! * scans.ads: Minor reformatting. ! ! * sem_prag.adb (Analyze_Pragma): Put entries in alpha order ! (Analyze_Pragma): Make sure all GNAT pragmas call GNAT_Pragma ! ! * sem_res.adb: ! (Resolve_Call): Check violation of No_Specific_Termination_Handlers ! ! * sem_ch12.adb: Minor comment reformatting ! ! * par-ch3.adb (P_Type_Declaration): Properly handle missing type ! keyword ! ! 2008-08-01 Robert Dewar ! ! * sem_ch6.adb (Process_PPCs): Don't copy spec PPC to body if not ! generating code ! ! 2008-08-01 Ed Schonberg ! ! * checks.adb (Apply_Float_Conversion_Check): If the expression to be ! converted is a real literal and the target type has static bounds, ! perform the conversion exactly to prevent floating-point anomalies on ! some targets. ! ! 2008-08-01 Vincent Celier ! ! * prj-attr.adb: New attribute Compiler'Name_Syntax () ! ! * prj-nmsc.adb (Process_Compiler): Recognize attribute Name_Syntax ! ! * prj.adb (Object_Exist_For): Use Object_Generated, not ! Objects_Generated that is removed and was never modified anyway. ! ! * prj.ads: ! (Path_Syntax_Kind): New enumeration type ! (Language_Config): New component Path_Syntax, defaulted to Host. ! Components PIC_Option and Objects_Generated removed, as they are not ! used. ! ! * snames.adb: New standard name Path_Syntax ! ! * snames.ads: New standard name Path_Syntax ! ! 2008-08-01 Vincent Celier ! ! * mlib-utl.adb: ! (Adalib_Path): New variable to store the path of the adalib directory ! when procedure Specify_Adalib_Dir is called. ! (Lib_Directory): If Adalib_Path is not null, return its value ! (Specify_Adalib_Dir): New procedure ! ! * mlib-utl.ads (Specify_Adalib_Dir): New procedure ! ! 2008-08-01 Ed Schonberg ! ! * sem_prag.adb: ! (Check_Precondition_Postcondition): If not generating code, analyze the ! expression in a postcondition that appears in a subprogram body, so that ! it is properly decorated for ASIS use. ! ! 2008-08-01 Gary Dismukes ! ! * exp_ch6.adb (Expand_Call): Remove ugly special-case code that resets ! Orig_Prev to Prev in the case where the actual is N_Function_Call or ! N_Identifier. This was interfering with other cases that are rewritten ! as N_Identifier, such as allocators, resulting in passing of the wrong ! accessibility level, and based on testing this code is apparently no ! longer needed at all. ! ! 2008-08-01 Ed Schonberg ! ! * sem_ch4.adb (Analyze_One_Call): Handle complex overloading of a ! procedure call whose prefix ! is a parameterless function call that returns an access_to_procedure. ! ! 2008-08-01 Jose Ruiz ! ! * adaint.c (__gnat_tmp_name): Refine the generation of temporary names ! for RTX. Adding a suffix that is incremented at each iteration. ! ! 2008-08-01 Robert Dewar ! ! * sem_ch6.adb (Analyze_Subprogram_Body): Remove special casing of ! Raise_Exception ! ! 2008-08-01 Jerome Lambourg ! ! * s-os_lib.adb (Normalize_Pathname): Take care of double-quotes in ! paths, which are authorized by Windows but can lead to errors when used ! elsewhere. ! ! 2008-08-01 Ed Schonberg ! ! * sem_ch12.ads (Need_Subprogram_Instance_Body): new function, to create ! a pending instantiation for the body of a subprogram that is to be ! inlined. ! ! * sem_ch12.adb: ! (Analyze_Subprogram_Instantiation): use Need_Subprogram_Instance_Body. ! ! * sem_prag.adb (Make_Inline): If the pragma applies to an instance, ! create a pending instance for its body, so that calls to the subprogram ! can be inlined by the back-end. ! ! 2008-08-01 Jose Ruiz ! ! * gnat_ugn.texi: Document the RTX run times (rts-rtx-rtss and ! rts-rtx-w32). ! ! 2008-08-01 Robert Dewar ! ! * scng.adb (Error_Illegal_Wide_Character): Bump scan pointer ! ! 2008-08-01 Doug Rupp ! ! * gnat_rm.texi: Document new mechanism Short_Descriptor. ! ! * types.ads (Mechanism_Type): Modify range for new Short_Descriptor ! mechanism values. ! ! * sem_prag.adb (Set_Mechanism_Value): Enhance for Short_Descriptor ! mechanism and Short_Descriptor mechanism values. ! ! * snames.adb (preset_names): Add short_descriptor entry. ! ! * snames.ads: Add Name_Short_Descriptor. ! ! * types.h: Add new By_Short_Descriptor mechanism values. ! ! * sem_mech.adb (Set_Mechanism_Value): Enhance for Short_Descriptor ! mechanism and Short_Descriptor mechanism values. ! ! * sem_mech.ads (Mechanism_Type): Add new By_Short_Descriptor mechanism ! values. ! (Descriptor_Codes): Modify range for new mechanism values. ! ! * treepr.adb (Print_Entity_Enfo): Handle new By_Short_Descriptor ! mechanism values. ! ! * gcc-interface/decl.c (gnat_to_gnu_entity): Handle By_Short_Descriptor. ! (gnat_to_gnu_param): Handle By_Short_Descriptor. ! ! * gcc-interface/gigi.h (build_vms_descriptor64): Remove prototype. ! (build_vms_descriptor32): New prototype. ! (fill_vms_descriptor): Remove unneeded gnat_actual parameter. ! ! * gcc-interface/trans.c (call_to_gnu): Removed unneeded gnat_actual ! argument in call fill_vms_descriptor. ! ! * gcc-interface/utils.c (build_vms_descriptor32): Renamed from ! build_vms_descriptor and enhanced to hande Short_Descriptor mechanism. ! (build_vms_descriptor): Renamed from build_vms_descriptor64. ! (convert_vms_descriptor32): New function. ! (convert_vms_descriptor64): New function. ! (convert_vms_descriptor): Rewrite to handle both 32bit and 64bit ! descriptors. ! ! * gcc-interface/utils2.c (fill_vms_descriptor): Revert previous changes, ! no longer needed. ! ! 2008-08-01 Jose Ruiz ! ! * adaint.c (__gnat_tmp_name): RTSS applications do not support tempnam ! nor tmpnam, so we always use c:\WINDOWS\Temp\gnat-XXXXXX as temporary ! name. ! ! 2008-08-01 Jose Ruiz ! ! * cstreams.c (__gnat_full_name): RTSS applications cannot ask for the ! current directory so only fully qualified names are allowed. ! ! 2008-08-01 Robert Dewar ! ! * gnat_ugn.texi: ! Minor editing, remove uncomfortable use of semicolon ! ! * s-ststop.adb: Add some ??? comments ! ! * sem_ch10.adb: Minor reformatting ! ! * snames.ads: ! Minor comment fixes, some pragmas were not properly ! categorized in the comments, documentation change only ! ! * xref_lib.adb: Minor reformatting ! ! * sinput.adb: Minor reformatting ! ! * gnatchop.adb: Minor reformatting ! ! * sem_util.ads: Minor reformatting. ! ! * opt.ads: Minor documentation fix ! ! * scng.adb: Minor reformatting ! ! * prj-part.adb: Update comments ! ! 2008-08-01 Ed Schonberg ! ! * exp_disp.adb (Expand_Interface_Conversion): If the target type is a ! tagged synchronized type, use corresponding record type. ! ! 2008-08-01 Doug Rupp ! ! * mlib-tgt-specific-vms-alpha.adb (Build_Dynamic_Library): Output a ! dummy transfer address for debugging. ! ! * mlib-tgt-specific-vms-ia64.adb (Build_Dynamic_Library): Likewise. ! ! * vms_data.ads: vms_data.ads: New qualfier /MACHINE_CODE_LISTING ! ! 2008-07-31 Eric Botcazou ! ! * gcc-interface/decl.c (gnat_to_gnu_entity): Fix formatting. ! * gcc-interface/utils.c (create_field_decl): Avoid superfluous work. ! ! 2008-07-31 Pascal Obry ! ! * prj-nmsc.adb: Keep Object and Exec directory casing. ! ! 2008-07-31 Jose Ruiz ! ! * system-rtx-rtss.ads ! Change the default stack size. It is important to set the commit part. ! ! * s-taprop-rtx.adb ! (Initialize): Get the clock resolution. ! (RT_Resolution): Return the clock resolution that is indicated by the ! system. ! ! * s-parame-vxworks.adb ! Document that this body is used for RTX in RTSS (kernel) mode. ! ! * gcc-interface/Makefile.in ! (LIBGNAT_TARGET_PAIRS for the rtx_rtss run time): Use the ! s-parame-vxworks.adb body in order to have reasonable stack sizes in ! RTX RTSS kernel mode. Virtual memory is not used in that case, so we ! cannot ask for too big values. ! ! 2008-07-31 Robert Dewar ! ! * exp_aggr.adb: Minor reformatting ! ! * makeutl.adb: Minor reformatting ! ! * prj-env.adb: Minor reformatting ! ! 2008-07-31 Hristian Kirtchev ! ! * exp_disp.adb (Prim_Op_Kind): Retrieve the full view when a private ! tagged type is completed by a concurrent type. ! ! 2008-07-31 Gary Dismukes ! ! * sem_aggr.adb: ! (Resolve_Record_Aggregate): Bypass error that a type without ! components must have a "null record" aggregate when compiling for Ada ! 2005, since it's legal to give an aggregate of form (others => <>) ! for such a type. ! ! 2008-07-31 Javier Miranda ! ! * sem_ch4.adb (Valid_First_Argument_Of): Complete its functionality to ! handle synchronized types. Required to handle well the object.operation ! notation applied to synchronized types. ! ! 2008-07-31 Quentin Ochem ! ! * s-stausa.adb (Fill_Stack): Stack_Used_When_Filling is now stored ! anymore - just used internally. ! Added handling of very small tasks - when the theoretical size is ! already full at the point of the call. ! (Report_Result): Fixed result computation, Stack_Used_When_Filling does ! not need to be added to the result. ! ! 2008-07-31 Hristian Kirtchev ! ! * sem_ch6.adb (Disambiguate_Spec): Continue the disambiguation if the ! corresponding spec is a primitive wrapper. Update comment. ! ! 2008-07-31 Hristian Kirtchev ! ! * bindgen.adb Comment reformatting. Update the list of run-time globals. ! (Gen_Adainit_Ada): Add the declaration, import and value set for ! configuration flag Canonical_Streams. ! (Gen_Adainit_C): Add the declaration and initial value of external ! symbol __gl_canonical_streams. ! ! * init.c: Update the list of global values computed by the binder. ! ! * opt.ads: Add flag Canonical_Streams. ! ! * par-prag.adb (Prag): Include Pragma_Canonical_Streams to the list of ! semantically handled pragmas. ! ! * sem_prag.adb: Add an entry into enumeration type Sig_Flags. ! (Analyze_Pragma): Add case for pragma Canonical_Streams. ! ! * snames.adb: Add character value for name Canonical_Streams. ! ! * snames.ads: ! Add Name_Canonical_Streams to the list of configuration pragmas. ! Add Pragma_Canonical_Streams to enumeration type Pragma_Id. ! ! * snames.h: Add a definition for Pragma_Canonical_Streams. ! ! * s-ststop.adb: ! Add a flag and import to seize the value of external symbol ! __gl_canonical_streams. Update comment and initial value of constant ! Use_Block_IO. ! ! * gnat_rm.texi: Add section of pragma Canonical_Streams. ! ! * gnat_ugn.texi: ! Add pragma Canonical_Streams to the list of configuration pragmas. ! ! 2008-07-31 Ed Schonberg ! ! * sem_ch10.adb (Build_Unit_Name): If the unit name in a with_clause ! has the form A.B.C and B is a unit renaming, analyze its compilation ! unit and add a with_clause on A.b to the context. ! ! 2008-07-31 Vincent Celier ! ! * makeutl.adb (Executable_Prefix_Path): If Locate_Exec_On_Path fails, ! return the empty string, instead of raising Constraint_Error. ! ! 2008-07-31 Gary Dismukes ! ! * checks.ads (Apply_Accessibility_Check): Add parameter Insert_Node. ! ! * checks.adb (Apply_Accessibility_Check): Insert the check on ! Insert_Node. ! ! * exp_attr.adb: ! (Expand_N_Attribute_Refernce, Attribute_Access): Pass attribute node ! to new parameter Insert_Node on call to Apply_Accessibility_Check. ! Necessary to distinguish the insertion node because the dereferenced ! formal may come from a rename, but the check must be inserted in ! front of the attribute. ! ! * exp_ch4.adb: ! (Expand_N_Allocator): Pass actual for new Insert_Node parameter on ! call to Apply_Accessibility_Check. ! (Expand_N_Type_Conversion): Pass actual for new Insert_Node parameter ! on call to Apply_Accessibility_Check. ! Minor reformatting ! ! 2008-07-31 Javier Miranda ! ! * sem_type.adb (Has_Compatible_Type): Complete support for synchronized ! types when the candidate type is a synchronized type. ! ! * sem_res.adb (Resolve_Actuals): Reorganize code handling synchronized ! types, and complete management of synchronized types adding missing ! code to handle formal that is a synchronized type. ! ! * sem_ch4.adb (Try_Primitive_Operation): Avoid testing attributes that ! are not available and cause the compiler to blowup. Found compiling ! test with switch -gnatc ! ! * sem_ch6.adb (Check_Synchronized_Overriding): Remove local subprogram ! Has_Correct_Formal_Mode plus code cleanup. ! ! 2008-07-31 Bob Duff ! ! * sinput.adb (Skip_Line_Terminators): Fix handling of LF/CR -- it was ! recognized as two end-of-lines, but it should be just one. ! ! 2008-07-31 Thomas Quinot ! ! * exp_ch9.adb: Minor reformatting ! ! * tbuild.ads: Fix several occurrences of incorrectly referring to ! Name_Find as Find_Name. ! ! 2008-07-31 Ed Schonberg ! ! * exp_aggr.adb (Aggr_Size_OK): If the aggregate has a single component ! and the context is an object declaration with non-static bounds, treat ! the aggregate as non-static. ! ! 2008-07-31 Vincent Celier ! ! * prj-part.adb, prj-part.ads, prj.adb, prj.ads, prj-env.adb: ! Move back spec of Parse_Single_Project to body, as it is not called ! outside of package Prj.Part. ! (Project_Data): Remove components Linker_Name, Linker_Path and ! Minimum_Linker_Options as they are no longer set. ! Remove function There_Are_Ada_Sources from package Prj and move code ! in the only place it was used, in Prj.Env.Set_Ada_Paths. ! ! 2008-07-31 Arnaud Charlet ! ! * mlib-utl.ads: Fix typo. ! ! 2008-07-31 Robert Dewar ! ! * sem_ch12.adb: Minor reformatting ! ! 2008-07-31 Sergey Rybin ! ! * gnat_ugn.texi: Change the description of the ! Overly_Nested_Control_Structures: now the rule always requires a ! positive parameter for '+R' option ! ! 2008-07-31 Thomas Quinot ! ! * g-pehage.adb: Minor reformatting ! ! 2008-07-31 Pascal Obry ! ! * s-finimp.ads: Minor reformatting. ! ! 2008-07-31 Vincent Celier ! ! * s-regexp.ads: Minor comment fix ! ! 2008-07-31 Arnaud Charlet ! ! * s-direio.adb (Reset): Replace pragma Unmodified by Warnings (Off), ! so that we can compile this file successfully with -gnatc. ! ! 2008-07-31 Hristian Kirtchev ! ! * exp_attr.adb (Find_Stream_Subprogram): Check the base type instead ! of the type when looking for stream subprograms for type String, ! Wide_String and Wide_Wide_String. ! ! * s-ststop.adb: Change the initialization expression of constant ! Use_Block_IO. ! ! 2008-07-31 Geert Bosch ! ! * arit64.c: ! New file implementing __gnat_mulv64 signed integer multiplication with ! overflow checking ! ! * fe.h (Backend_Overflow_Checks_On_Target): Define for use by Gigi ! ! * gcc-interface/gigi.h: ! (standard_types): Add ADT_mulv64_decl ! (mulv64_decl): Define subprogram declaration for __gnat_mulv64 ! ! * gcc-interface/utils.c: ! (init_gigi_decls): Add initialization of mulv64_decl ! ! * gcc-interface/trans.c: ! (build_unary_op_trapv): New function ! (build_binary_op_trapv): New function ! (gnat_to_gnu): Use the above functions instead of ! build_{unary,binary}_op ! ! * gcc-interface/Makefile.in ! (LIBGNAT_SRCS): Add arit64.c ! (LIBGNAT_OBJS): Add arit64.o ! ! 2008-07-31 Vincent Celier ! ! * prj-nmsc.adb (Check_Library_Attributes): Check if Linker'Switches or ! Linker'Default_Switches are declared. Warn if they are declared. ! ! 2008-07-31 Ed Schonberg ! ! * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): Use ! Insert_Actions to place the pointer declaration in the code, rather ! than Insert_Before_And_Analyze, so that insertions of temporaries are ! kept in the proper order when transient scopes are present. ! ! ! 2008-07-31 Robert Dewar ! ! * einfo.adb (Spec_PPC): Now defined for generic subprograms ! ! * einfo.ads (Spec_PPC): Now defined for generic subprograms ! ! * sem_prag.adb (Check_Precondition_Postcondition): Handle generic ! subprogram case ! ! 2008-07-31 Vincent Celier ! ! * s-os_lib.adb: Minor comment fix ! ! 2008-07-31 Ed Schonberg ! ! * sem_ch6.adb (Analyze_Generic_Subprogram_Body): After analysis, ! transfer pre/postconditions from generic copy to original tree, so that ! they will appear in each instance. ! (Process_PPCs): Do not transform postconditions into a procedure in a ! generic context, to prevent double expansion of check pragmas. ! ! * sem_attr.adb: In an instance, the prefix of the 'result attribute ! can be the renaming of the ! current instance, so check validity of the name accordingly. ! ! 2008-07-31 Robert Dewar ! ! * mlib-utl.ads: Minor reformatting ! ! 2008-07-31 Ed Schonberg ! ! sem_attr.adb: 'Result can have an ambiguous prefix, and is resolved ! from context. This attribute must be usable in Ada95 mode. ! The attribute can appear in the body of a function marked ! Inline_Always, but in this case the postocondition is not enforced. ! ! sem_prag.adb (Check_Precondition_Postcondition): within the expansion ! of an inlined call pre- and postconditions are legal ! ! 2008-07-31 Vincent Celier ! ! * prj.adb, prj.ads, clean.adb, prj-nmsc.adb: Remove declarations that ! were for gprmake only ! ! 2008-07-31 Robert Dewar ! ! * gnat_ugn.texi: Update -gnatN documentation. ! ! * gnat_rm.texi: Add note about pre/postcondition ! pragmas not checked in conjunction with front-end inlining. ! ! 2008-07-31 Robert Dewar ! ! * g-pehage.adb, g-pehage.ads: Minor reformatting ! ! 2008-07-31 Arnaud Charlet ! ! * mlib-utl.ads, prj-makr.ads: Add comments. ! ! 2008-07-30 Aaron W. LaFramboise ! ! * gcc-interface/Makefile.in (EXTRA_GNATRTL_NONTASKING_OBJS) ! [WINDOWS]: Add s-winext.o. ! ! 2008-07-30 Eric Botcazou ! ! PR ada/36554 ! * back_end.adb (Call_Back_End): Pass Standard_Boolean to gigi. ! * gcc-interface/gigi.h (gigi): Take new standard_boolean parameter. ! * gcc-interface/decl.c (gnat_to_gnu_entity) : ! Set precision to 1 for subtype of BOOLEAN_TYPE. ! (set_rm_size): Set TYPE_RM_SIZE_NUM for BOOLEAN_TYPE. ! (make_type_from_size): Deal with BOOLEAN_TYPE. ! * gcc-interface/misc.c (gnat_print_type): Likewise. ! * gcc-interface/trans.c (gigi): Take new standard_boolean parameter. ! Set boolean_type_node as its translation in the table, as well ! as boolean_false_node for False and boolean_true_node for True. ! * gcc-interface/utils.c (gnat_init_decl_processing): Create custom ! 8-bit boolean_type_node and set its TYPE_RM_SIZE_NUM. ! (create_param_decl): Deal with BOOLEAN_TYPE. ! (build_vms_descriptor): Likewise. ! (build_vms_descriptor64): Likewise. ! (convert): Deal with BOOLEAN_TYPE like with ENUMERAL_TYPE. ! ! 2008-07-30 Robert Dewar ! ! * exp_ch9.adb: Minor reformatting ! ! * exp_util.ads (Find_Prim_Op): Document that Program_Error is raised ! if no primitive operation is found. ! ! * exp_util.adb: (Find_Prim_Op): Add comments for previous change ! ! * sem_ch8.adb: Minor reformatting ! ! 2008-07-30 Laurent Pautet ! ! * g-pehage.adb: ! Remove a limitation on the length of the words handled by the minimal ! perfect hash function generator. ! ! * g-pehage.ads: ! Detail the use of subprograms Insert, Initialize, Compute and Finalize. ! Fix some typos. ! ! 2008-07-30 Robert Dewar ! ! * gnatlink.adb: Minor reformatting ! ! 2008-07-30 Thomas Quinot ! ! * rtsfind.adb (Check_RPC): Check version consistency even when not ! generating RCI stubs. Provide more detailed error message in case of ! mismatch. ! ! 2008-07-30 Ed Schonberg ! ! * sem_ch8.adb (Analyze_Subprogram_Renaming): When renaming an attribute ! as a actual in an instance, check for a missing attribute to prevent ! program_error on an illegal program. ! ! * exp_util.adb (Find_Prim_Op): Rather than Assert (False), raise program ! error if primitive is not found, so that exception can be handled ! elsewhere on illegal programs. ! ! 2008-07-30 Robert Dewar ! ! * uintp.adb (UI_GCD): Fix potential overflow ! ! 2008-07-30 Hristian Kirtchev ! ! * einfo.adb: Flag245 is now used. ! (Is_Primitive_Wrapper, Set_Is_Primitive_Wrapper): Relax the assertion ! check to include functions. ! (Is_Private_Primitive, Set_Is_Private_Primitive): New subprograms. ! (Wrapped_Entity, Set_Wrapped_Entity): Relax the assertion check to ! include functions. ! (Write_Entity_Flags): Move flag Is_Primitive, add Is_Private_Primitive ! to the list of displayed flags. ! ! * einfo.ads: Update comment on the usage of Is_Primitive_Wrapper and ! Wrapped_Entity. These two flags are now present in functions. ! New flag Is_Private_Primitive. ! (Is_Private_Primitive, Set_Is_Private_Primitive): New subprograms. ! ! * exp_ch9.adb: ! (Build_Wrapper_Bodies): New subprogram. ! (Build_Wrapper_Body): The spec and body have been moved to in ! Build_Wrapper_ Bodies. Code cleanup. ! (Build_Wrapper_Spec): Moved to the spec of Exp_Ch9. Code cleanup. ! Wrappers are now generated for primitives declared between the private ! and full view of a concurrent type that implements an interface. ! (Build_Wrapper_Specs): New subprogram. ! (Expand_N_Protected_Body): Code reformatting. Replace the wrapper body ! creation mechanism with a call to Build_Wrapper_Bodies. ! (Expand_N_Protected_Type_Declaration): Code reformatting. Replace the ! wrapper spec creation mechanism with a call to Build_Wrapper_Specs. ! (Expand_N_Task_Body): Replace the wrapper body creation ! mechanism with a call to Build_Wrapper_Bodies. ! (Expand_N_Task_Type_Declaration): Replace the wrapper spec ! creation mechanism with a call to Build_Wrapper_Specs. ! (Is_Private_Primitive_Subprogram): New subprogram. ! (Overriding_Possible): Code cleanup. ! (Replicate_Entry_Formals): Renamed to Replicate_Formals, code cleanup. ! ! * exp_ch9.ads (Build_Wrapper_Spec): Moved from the body of Exp_Ch9. ! ! * sem_ch3.adb: Add with and use clause for Exp_Ch9. ! (Process_Full_View): Build wrapper specs for all primitives ! that belong to a private view completed by a concurrent type ! implementing an interface. ! ! * sem_ch6.adb (Analyze_Subprogram_Body): When the current subprogram ! is a primitive of a ! concurrent type with a private view that implements an interface, try to ! find the proper spec. ! (Analyze_Subprogram_Declaration): Mark a subprogram as a private ! primitive if the type of its first parameter is a non-generic tagged ! private type. ! (Analyze_Subprogram_Specification): Code reformatting. ! (Disambiguate_Spec): New routine. ! (Find_Corresponding_Spec): Add a flag to controll the output of errors. ! (Is_Private_Concurrent_Primitive): New routine. ! ! * sem_ch6.ads: ! (Find_Corresponding_Spec): Add a formal to control the output of errors. ! ! 2008-07-30 Doug Rupp ! ! * gigi.h (build_vms_descriptor64): New function prototype. ! (fill_vms_descriptor): Modified function prototype. ! ! * utils.c (build_vms_descriptor64): New function. ! ! * utils2.c (fill_vms_descriptor): Fix handling on 32bit systems. ! ! * trans.c (call_to_gnu): Call fill_vms_descriptor with new third ! argument. ! ! * decl.c (gnat_to_gnu_tree): For By_Descriptor mech, build both a ! 64bit and 32bit descriptor and save the 64bit version as an alternate ! TREE_TYPE in the parameter. ! (make_type_from_size) : Use the appropriate mode for the ! thin pointer. ! ! * ada-tree.h (DECL_PARM_ALT, SET_DECL_PARM_ALT): New macros. ! ! 2008-07-30 Robert Dewar ! ! * make.adb: Minor reformatting ! ! * mlib-utl.adb: Minor reformatting ! ! * osint.ads: Minor reformatting ! ! 2008-07-30 Jose Ruiz ! ! * adaint.c ! (__gnat_file_exists): Do not use __gnat_stat for RTX. ! (__main for RTX in RTSS mode): Create this dummy procedure symbol to ! avoid the use of this symbol from libgcc.a in RTX kernel mode. ! ! * cio.c ! (put_int, put_int_stderr, put_char, put_char_stderr): For RTX we call ! the function RtPrintf for console output. ! ! * argv.c Do not use the environ variable for RTX. ! ! * gnatlink.adb (gnatlink): The part that handles the --RTS option has ! been moved before the call to Osint.Add_Default_Search_Dirs in order ! to take into account the flags in system.ads (RTX_RTSS_Kernel_Module) ! from the appropriate run time. ! ! * targparm.ads ! (RTX_RTSS_Kernel_Module_On_Target): Add this flag that is set to True if ! target is a RTSS module for RTX. ! ! * targparm.adb (Targparm_Tags, RTX_Str, Targparm_Str): Add tag RTX for ! RTX_RTSS_Kernel_Module ! (Get_Target_Parameters): Add processing of RTX_RTSS_Kernel_Module flag. ! ! * gcc-interface/Makefile.in (LIBGNAT_TARGET_PAIRS for RTX): Use gcc ! exception handling mechanism for Windows and RTX in Win32 mode, but ! not for RTX in kernel mode (RTSS). ! (LIBGNAT_SRCS): Remove ada.h ! ! 2008-07-30 Paolo Bonzini ! ! * gcc-interface/Make-lang.in (ALL_ADAFLAGS): Remove X_ADAFLAGS and ! T_ADAFLAGS, replace ALL_ADA_CFLAGS with ADA_CFLAGS. ! (ALL_ADA_CFLAGS): Remove, replace throughout with ADA_CFLAGS. ! * gcc-interface/Makefile.in (XCFLAGS, X_CFLAGS, X_CPPFLAGS, T_CPPFLAGS, ! X_ADA_CFLAGS, T_ADA_CFLAGS, X_ADAFLAGS, T_ADAFLAGS, ADA_CFLAGS, ! ALL_ADA_CFLAGS): Remove. ! (ALL_ADAFLAGS, MOST_ADAFLAGS): Remove X_ADAFLAGS and T_ADAFLAGS, ! replace ALL_ADA_CFLAGS with ADA_CFLAGS. ! (GCC_CFLAGS): Remove X_CFLAGS. ! (LOOSE_CFLAGS): Remove X_CFLAGS and XCFLAGS. ! (ALL_CPPFLAGS): Remove X_CPPFLAGS and T_CPPFLAGS. ! (ADA_CFLAGS): Substitute. ! ! 2008-07-30 Laurent Guerby ! ! PR ada/5911 ! * gcc-interface/Makefile.in (MULTISUBDIR, RTSDIR): New variables. ! Pass MULTISUBDIR to recursive make. Use $(RTSDIR) instead of rts. ! Replace stamp-gnatlib* by stamp-gnatlib*-rts. ! * gcc-interface/Make-lang.in: Replace stamp-gnatlib2 ! by stamp-gnatlib2-rts. ! ! 2008-07-30 Ralf Wildenhues ! ! PR documentation/15479 ! * gnat-style.texi: Remove AdaCore copyright statement and GPL ! statement for GNAT. Add @copying stanza, use it. Update to ! GFDL 1.2. Do not list GFDL as Invariant Section, do not list ! title as Front-Cover Text. ! * gnat_rm.texi: Likewise. ! * gnat_ugn.texi: Likewise. ! ! 2008-07-29 Jan Hubicka ! ! * trans.c (process_inlined_subprograms): Remove tree_really_inline ! check. ! ! 2008-07-29 Arnaud Charlet ! ! * gcc-interface: New directory. ! ! * ada-tree.def, cuintp.c, gigi.h, Makefile.in, targtyps.c, ada.h, ! utils.c, ada-tree.h, decl.c, lang.opt, Make-lang.in, trans.c, ! config-lang.in, deftarg.c, lang-specs.h, misc.c, utils2.c: Moved ! to gcc-interface subdirectory. ! ! 2008-07-29 Aaron W. LaFramboise ! ! * Makefile.in (EXTRA_GNATRTL_NONTASKING_OBJS): Remove extra s-win32.o. ! ! 2008-07-28 Jan Hubicka ! ! * misc.c (gnat_post_options): Do not set flag_no_inline. ! ! 2008-07-28 Richard Guenther ! ! Merge from gimple-tuples-branch. ! ! 2008-07-22 Olivier Hainque ! ! * gigi.h (end_subprog_body): New ELAB_P argument, saying if ! this is called for an elab proc to be discarded if empty. ! * utils.c (end_subprog_body): Honor ELAB_P. ! (build_function_stub): Adjust call to end_subprog_body. ! * trans.c (Subprogram_Body_to_gnu): Likewise. ! (gigi): Reorganize processing of elab procs to prevent ! gimplifying twice, using the new end_subprog_body argument. ! ! 2008-07-19 Richard Guenther ! ! * Make-lang.in (trans.o): Add tree-iterator.h dependency. ! (utils.o): Likewise. ! * trans.c: Include tree-iterator.h. ! (gnat_gimplify_expr): Adjust prototype. Fix typo. ! (gnat_gimplify_stmt): Use SET_EXPR_LOCATION. ! (set_expr_location_from_node): Likewise. ! (gigi): Tuplify. ! * ada-tree.h (union lang_tree_node): Use TREE_CHAIN instead ! of GENERIC_NEXT. ! * utils.c: Include tree-iterator.h. ! * gigi.h (gnat_gimplify_expr): Adjust prototype. ! ! 2008-07-18 Aldy Hernandez ! ! * trans.c: Include gimple.h instead of tree-gimple.h. ! * utils.c: Same. ! ! 2008-07-14 Aldy Hernandez ! ! * trans.c (gnat_gimplify_expr): Use gimplify_assign. ! ! 2008-07-25 Jan Hubicka ! ! * utils.c (end_subprog_body): Remove inline trees check. ! * misc.c (gnat_post_options): Do not set flag_inline_trees. ! ! 2008-07-25 Rainer Orth ! ! * raise-gcc.c: Move tsystem.h before tm.h. ! ! 2008-07-20 Arnaud Charlet ! ! * gnathtml.pl: New file. ! ! 2008-07-19 Olivier Hainque ! ! * targtyps.c (get_target_default_allocator_alignment): Use ! MALLOC_ABI_ALIGNMENT. ! ! 2008-07-17 Olivier Hainque ! ! * adaint.c (__MINGW32__ section): Include ctype.h and define ! a fallback ISALPHA if IN_RTS. ! (__gnat_is_absolute_path): Use ISALPHA instead of isalpha. ! ! 2008-07-17 Olivier Hainque ! ! * utils.c (create_var_decl_1): Relax expectations on the PUBLIC_FLAG ! argument, to apply to references in addition to definitions. Prevent ! setting TREE_STATIC on externals. ! (gnat_pushdecl): Always clear DECL_CONTEXT on public externals. ! ! 2008-07-14 Ralf Wildenhues ! ! PR documentation/15479 ! * gnat_ugn.texi (@ovar): New macro, from autoconf.texi. ! Replace backets around optional parameters with @ovar ! where possible, use @r{[}, @r{]} otherwise. ! Replace some @r, @i, and @emph with @var where appropriate. ! ! 2008-07-02 Eric Botcazou ! ! * decl.c (make_type_from_size) : Fix typo and tidy up. ! ! 2008-06-27 Kaveh R. Ghazi ! ! * ada-tree.h (SET_TYPE_LANG_SPECIFIC, SET_DECL_LANG_SPECIFIC): Fix ! -Wc++-compat warnings. ! * adaint.c (__gnat_locate_regular_file, __gnat_locate_exec, ! __gnat_locate_exec_on_path): Likewise. ! * decl.c (annotate_value): Likewise. ! * misc.c (gnat_handle_option): Likewise. ! * trans.c (gnat_to_gnu, extract_encoding, decode_name, ! post_error_ne_tree): Likewise. ! ! 2008-06-27 Eric Botcazou ! ! * utils.c (convert) : When converting it to a packable ! version of its type, attempt to first convert its elements. ! ! 2008-06-26 Chris Proctor ! ! * Makefile.in: Fix *86 kfreebsd target specific pairs. ! ! 2008-06-25 Samuel Tardieu ! ! * Makefile.in: Use mlib-tgt-specific-linux.adb for sh4 as well. 2008-06-24 Eric Botcazou *************** *** 54,83 **** : If the alignment of the offset is unknown, use that of the base. 2008-06-09 Eric Botcazou * decl.c (components_to_record): Adjust the packedness for the qualified union as well. ! 2008-06-06 Aurelien Jarno ! * s-osinte-linux-alpha.ads (SC_NPROCESSORS_ONLN): New constant ! for sysconf call. ! (bit_field): New packed boolean type used by cpu_set_t. ! (cpu_set_t): New type corresponding to the C type with ! the same name. Note that on the Ada side we use a bit ! field array for the affinity mask. There is not need ! for the C macro for setting individual bit. ! (pthread_setaffinity_np): New imported routine. ! ! 2008-06-06 Release Manager ! * GCC 4.3.1 released. 2008-05-24 Eric Botcazou ! * trans.c (Sloc_to_locus): Do not overwrite known GCC locations when ! translating GNAT standard locations. 2008-05-17 Eric Botcazou --- 4033,5552 ---- : If the alignment of the offset is unknown, use that of the base. + 2008-06-20 John David Anglin + + PR ada/36573 + * s-osinte-hpux-dce.ads (SA_ONSTACK): Define. + + 2008-06-15 Ralf Wildenhues + + * gnat_rm.texi (Implementation Defined Characteristics) + (Standard Library Routines): Use @smallexample for indented + text. Drop Indentation outside examples. + * gnat_ugn.texi: Likewise. + + 2008-06-13 Olivier Hainque + + * decl.c (FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN): Define to 0 + if undefined. + (gnat_to_gnu_entity) : Request stack + realignment with force_align_arg_pointer attribute on foreign + convention subprograms if FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN. + + 2008-06-13 Olivier Hainque + + * utils.c (rest_of_record_type_compilation): When computing + encodings for the components of a variable size type, early + strip conversions on the current position expression to make + sure it's shape is visible. Use remove_conversions for this + purpose. + + 2008-06-12 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : In the case of a + constrained subtype of a discriminated type, discard the fields that + are beyond its limits according to its size. + + 2008-06-10 Olivier Hainque + + * utils.c (create_subprog_decl): If this is for the 'main' entry + point according to the asm name, redirect main_identifier_node. + 2008-06-09 Eric Botcazou * decl.c (components_to_record): Adjust the packedness for the qualified union as well. ! 2008-06-09 Arnaud Charlet ! * Make-lang.in: Use -gnatwns instead of -gnatws to make sytyle ! checks non fatal. ! 2008-06-07 Samuel Tardieu ! ! * sem_res.adb (Large_Storage_Type): A type is large if it ! requires as many bits as Positive to store its values and its ! bounds are known at compile time. ! * sem_ch13.adb (Minimum_Size): Note that this function returns ! 0 if the size is not known at compile time. ! ! 2008-06-06 Nicolas Setton ! Olivier Hainque ! ! * ada-tree.h (DECL_PARALLEL_TYPE): New language specific ! attribute, parallel descriptive type attached to another ! type for debug info generation purposes. ! * utils.c (add_parallel_type): New function, register ! parallel type to be attached to a type. ! (get_parallel_type): New function, fetch a registered ! parallel type, if any. ! (rest_of_record_type_compilation): Register the parallel ! type we make for variable size records. ! * gigi.h (add_parallel_type, get_parallel_type): Declare. ! * decl.c (gnat_to_gnu_entity, maybe_pad_type): Register the ! parallel debug types we make. ! * trans.c (extract_encoding, decode_name): New functions. ! (gigi): If the DWARF attribute extensions are available, setup ! to use them. ! * lang.opt: Register language specific processing request ! for -gdwarf+. ! * misc.c (gnat_dwarf_extensions): New global variable. How much ! do we want of our DWARF extensions. 0 by default. ! (gnat_handle_option) : Increment gnat_dwarf_extensions. ! (gnat_post_options): Map gnat_dwarf_extensions to the ! commonuse_gnu_debug_info_extensions for later processing. ! ! 2008-06-04 Samuel Tardieu ! ! * einfo.ads, einfo.adb: Remove unused flag Function_Returns_With_DSP. ! ! 2008-06-03 Ralf Wildenhues ! ! * Makefile.in (common_tools): Fix typos in $(exeext) extension. ! * gnat_ugn.texi (Style Checking) ! (Adding the Results of Compiler Checks to gnatcheck Output) ! (Example of Binder Output File): Fix typos. ! * ali.ads, einfo.ads, exp_ch4.adb, exp_ch6.adb, ! exp_dbug.ads, exp_dist.adb, exp_smem.adb, g-socket.ads, ! s-osinte-rtems.ads, s-shasto.ads, s-stausa.adb, ! s-stausa.ads, sem_cat.adb, sem_ch12.adb, sem_ch3.adb, ! sem_ch4.adb, sem_ch6.adb, sem_ch8.adb, sem_util.ads, ! sinfo.ads, utils.c: Fix typos in comments. ! * sem_ch6.adb, vms_data.ads: Fix typos in strings. ! ! 2008-05-29 Thomas Quinot ! ! * sem_eval.adb: Minor reformatting ! ! 2008-05-29 Ed Schonberg ! ! * sem_ch6.adb (Analyze_Subprogram_Specification): if the return type ! is abstract, do not apply abstractness check on subprogram if this is ! a renaming declaration. ! ! 2008-05-29 Arnaud Charlet ! ! PR ada/864 ! * osint.ads, osint.adb (Program_Name): New parameter "Prog" to ! allow recognition of program suffix in addition to prefix. ! ! * gnatchop.adb (Locate_Executable): Add support for prefix. ! ! * make.adb, gnatcmd.adb, gnatlink.adb, prj-makr.adb, ! mlib-utl.adb: Adjust calls to Program_Name. ! ! 2008-05-29 Robert Dewar ! ! * sem_ch3.adb: Minor reformatting ! * sem_prag.adb: Minor reformatting ! * sem_res.adb: Minor reformatting ! * sinput-p.ads: Minor reformatting ! ! 2008-05-29 Javier Miranda ! ! * sem_util.adb: ! (Abstract_Interface_List): Add missing support for full type-declaration ! associated with synchronized types. ! ! 2008-05-29 Robert Dewar ! ! * sem_eval.adb (Is_Same_Value): Take care of several more cases ! ! 2008-05-28 Ed Schonberg ! ! * sem_ch5.adb (Analyze_Assignment): If the name is of a local anonymous ! access type, wrap the expression in a conversion to force an ! accessibility check. ! ! * sem_aggr.adb (Aggegate_Constraint_Checks): Apply conversion to force ! accessibility checks even when expansion is disabled in order to ! generate messages in the presence of previous errors or in ! semantics-only mode. ! ! 2008-05-28 Eric Botcazou ! ! * system-lynxos-ppc.ads (Always_Compatible_Rep): Set to False. ! * system-lynxos-x86.ads (Always_Compatible_Rep): Set to False. ! ! 2008-05-28 Vincent Celier ! ! PR ada/34446 ! * gnat_ugn.texi: Document restriction introduced on 2007-04-20 in ! preprocessing expressions ! ! 2008-05-28 Vincent Celier ! ! * sinput-p.adb (Source_File_Is_Subunit): Allow special character used ! for preprocessing ! ! * sinput-p.ads: Minor comment update and reformatting ! ! 2008-05-28 Ed Schonberg ! ! * sem_res.adb (Valid_Conversion): An anonymous access_to_subprogram ! type has a deeper level than any master only when it is the type of an ! access parameter. ! ! 2008-05-28 Javier Miranda ! ! * sem_ch3.adb (Derive_Progenitor_Subprograms): Add documentation. ! ! 2008-05-28 Javier Miranda ! ! * sem_util.ads (Find_Overridden_Synchronized_Primitive): Removed. ! * sem_util.adb (Find_Overridden_Synchronized_Primitive): Removed. ! * sem_ch6.adb (Check_Synchronized_Overriding): Remove one formal. ! Add code that was previously located in ! Find_Overridden_Synchronized_Primitive because it is only used here. ! ! 2008-05-28 Sergey Rybin ! ! * sem_prag.adb (Process_Extended_Import_Export_Subprogram_Pragma): Set ! Entity field for formal_parameter_NAME in MECHANISM_ASSOCIATION. ! ! 2008-05-28 Robert Dewar ! ! * restrict.ads: ! Add missing restrictions, and properly label all GNAT defined ones ! ! * rtsfind.ads: ! Add entry for Ada_Real_Time.Timing_Events.Timing_Event ! Add entry for Ada.Task_Termination.Set_Specific_Handler ! Add entry for Ada.Task_Termination.Specific_Handler ! ! * s-rident.ads: ! Add missing restrictions and properly mark all gnat defined ones ! ! * sem_ch3.adb: ! (Analyze_Object_Declaration): Check No_Local_Timing_Events restriction ! ! * sem_res.adb: ! (Resolve_Call): Check violation of No_Specific_Termination_Handlers ! ! * gnat_rm.texi: Add missing restrictions, and properly label all ! GNAT defined ones ! ! 2008-05-28 Robert Dewar ! ! * restrict.adb: ! (Check_Restriction): violation of restriction No_Finalization is ! treated as a serious error to stop expansion ! ! 2008-05-28 Robert Dewar ! ! * exp_util.adb: Minor reformatting ! * exp_util.ads: Minor reformatting. ! ! 2008-05-28 Arnaud Charlet ! ! * Make-lang.in: Remove gprmake. ! ! * gprmake.adb, makegpr.ads, makegpr.adb: Removed. ! ! 2008-05-28 Ed Schonberg ! ! * sem_ch3.adb (Diagnose_Interface): Cleanup error messages involving ! improper progenitor names, and avoid cascaded errors. ! ! 2008-05-28 Robert Dewar ! ! * gnat_rm.texi: Add note on Old giving warning when applied to constant ! ! * sem_attr.adb (Analyze_Attribute, case Old): Give warning if prefix is ! a constant ! ! 2008-05-28 Robert Dewar ! ! * exp_fixd.adb (Build_Multiply): Correct one-off error in computing ! size ! ! 2008-05-28 Robert Dewar ! ! * exp_ch5.adb: ! (Expand_Simple_Function_Return): Copy unaligned result into temporary ! ! 2008-05-28 Javier Miranda ! ! * sem_ch3.adb (Derive_Progenitor_Primitives): Add missing support ! for user-defined predefined primitives. ! ! * sem_util.adb (Matches_Prefixed_View_Profile): Ditto. ! (Find_Overridden_Synchronized_Primitive): Ditto. ! ! * sem_ch6.adb (Check_Synchronized_Overriding): Ditto. ! ! 2008-05-27 Arnaud Charlet ! ! * a-ststio.adb, s-direio.adb: ! Further code clean up of previous change. ! Update comments. ! ! 2008-05-27 Vincent Celier ! ! * prj-nmsc.adb: Minor reformatting ! ! 2008-05-27 Bob Duff ! ! * sem_ch3.adb (Build_Incomplete_Type_Declaration): In the case of an ! untagged private type with a tagged full type, where the full type has ! a self reference, create the corresponding class-wide type early, in ! case the self reference is "access T'Class". ! ! 2008-05-27 Ed Schonberg ! ! * exp_aggr.adb (Build_Array_Aggr_Code): If component type includes ! tasks and context is an object declaration. create master entity before ! expansion. ! ! 2008-05-27 Robert Dewar ! ! * mlib-prj.adb: Minor reformatting ! ! * prj-part.adb: Minor reformatting ! ! * prj.ads: Minor reformatting ! ! * exp_ch3.adb: Minor reformatting. ! ! * sem_ch3.ads: Minor reformatting ! ! * sem_eval.adb: Minor reformatting ! ! 2008-05-27 Vincent Celier ! ! * gnatcmd.adb: ! -gnat stack spawns gnatstack, not -gnatstack ! ! 2008-05-27 Ed Schonberg ! ! * exp_aggr.adb (Expand_Array_Aggregate): If the aggregate contains ! tasks, create an activation chain now, before the expansion into ! assignments and build-in-place calls that require the presence of an ! activation chain. ! (Backend_Processing_Possible): If the component type is inherently ! limited, the aggregate must be expanded into individual built-in-place ! assignments. ! ! * sem_ch6.adb (Build_Extra_Formals): Use underlying type of result to ! determine whether an allocation extra parameter must be built, to ! handle case of a private type whose full type is a discriminated type ! with defaults. ! ! 2008-05-27 Bob Duff ! ! * gnat_rm.texi: ! Document the new behavior regarding trampolines. ! ! 2008-05-27 Arnaud Charlet ! ! * a-direio.adb, a-sequio.adb: Replace address clause by ! unrestricted_access, simpler and compatible with .NET. ! ! 2008-05-27 Vincent Celier ! ! * prj-part.adb: ! (Project_Path_Name_Of.Try_Path): Do not use Locate_Regular_File to find ! a project file, so that symbolic links are not resolved. ! ! 2008-05-27 Arnaud Charlet ! ! * a-ztexio.adb, a-textio.adb, a-witeio.adb, s-direio.adb: ! Replace heavy address clause by 'Unrestricted_Access, cleaner and more ! portable across GNAT targets, since this kind of address clause is not ! supported by VM back-ends (.NET/JGNAT). ! ! 2008-05-27 Arnaud Charlet ! ! * bindgen.adb: Update comments. ! ! * s-tasinf-mingw.adb: Add "with" of System.OS_Interface ! ! 2008-05-27 Vincent Celier ! ! * gnatcmd.adb, prj-proc.adb, make.adb, mlib-prj.adb, prj.adb, ! prj.ads, makegpr.adb, makeutl.adb, clean.adb, prj-nmsc.adb, ! mlib-tgt.adb, prj-env.adb, prj-env.ads: ! (Path_Information): New record type ! Use component of type Path_Information when there are two paths, one in ! canonical format and one in display format. ! Update the project manager to these new components. ! ! 2008-05-27 Robert Dewar ! ! * makeutl.adb: Minor reformatting ! * prj-nmsc.adb: Minor reformatting ! * s-stausa.adb: Minor reformatting ! * s-stausa.ads: Minor reformatting ! * sem_ch6.adb: Minor reformatting ! ! 2008-05-27 Thomas Quinot ! ! * sem_res.adb: Minor comment fixes ! ! 2008-05-27 Thomas Quinot ! ! * makeutl.adb: Minor code reorganization ! ! * exp_aggr.adb: Add ??? comment ! Fix typo ! ! * exp_ch6.adb: Minor reformatting ! ! 2008-05-27 Quentin Ochem ! ! * s-stausa.adb (Initialize): Updated result initialization, and ! initialization of environment stack. ! (Fill_Stack): Improved computation of the pattern zone, taking into ! account already filled at the calling point. ! (Get_Usage_Range): Now uses Min_Measure and Max_Measure instead of ! Measure and Overflow_Guard. ! (Report_Result): Fixed computation of the result using new fields of ! Stack_Analyzer. ! ! * s-stausa.ads (Initialize_Analyzer): Replaced Size / Overflow_Guard ! params by more explicit Stack_Size / Max_Pattern_Size params. ! (Stack_Analyzer): Added distinct Stack_Size & Pattern_Size fields. ! Added Stack_Used_When_Filling field. ! (Task_Result): Replaced Measure / Overflow_Guard by more explicit ! Min_Measure and Max_Measure fields. ! ! * s-tassta.adb (Task_Wrapper): Updated call to Initialize_Analyzer. ! ! 2008-05-27 Vincent Celier ! ! * prj-nmsc.adb: ! (Check_File): Make sure that a unit that replaces the same unit in a ! project being extended is properly processed. ! ! 2008-05-27 Ed Schonberg ! ! * sem_ch3.adb: ! (Get_Discr_Value): Remove obsolete code that failed to find the value ! of a discriminant for an inherited task component appearing in a type ! extension. ! ! 2008-05-27 Thomas Quinot ! ! (System.File_IO.{Close, Delete, Reset}): ! Change File parameter from "in out AFCB_Ptr" to "access AFCB_Ptr". ! ! (Ada.*_IO.{Close, Delete, Reset, Set_Mode}): ! Pass File parameter by reference. ! ! 2008-05-27 Vincent Celier ! ! * prj-nmsc.adb: ! (Process_Sources_In_Multi_Language_Mode): Check that there are not two ! sources of the same project that have the same object file name. ! (Find_Explicit_Sources): Always remove a source exception that was not ! found. ! ! 2008-05-27 Thomas Quinot ! ! * sem_ch3.adb: Minor reformatting ! ! 2008-05-27 Ed Schonberg ! ! * sem_ch6.adb: ! (Is_Interface_Conformant): Handle properly a primitive operation that ! overrides an interface function with a controlling access result. ! (Type_Conformance): If Skip_Controlling_Formals is true, when matching ! inherited and overriding operations, omit as well the conformance check ! on result types, to prevent spurious errors. ! ! 2008-05-27 Vincent Celier ! ! * makeutl.ads, makeutl.adb: ! (Set_Location): New procedure ! (Get_Location): New function ! (Update_Main): New procedure ! ! 2008-05-27 Vincent Celier ! ! * prj-nmsc.adb: ! (Check_Library): Allow standard project to be extended as a static ! library project. ! (Get_Mains): Do not inherit attribute Main in an extending library ! project. ! ! 2008-05-27 Eric Botcazou ! ! * system-darwin-ppc.ads (Always_Compatible_Rep): Set to False. ! * system-darwin-x86.ads (Always_Compatible_Rep): Likewise. ! * system-freebsd-x86.ads (Always_Compatible_Rep): Likewise. ! * system-linux-ppc.ads (Always_Compatible_Rep): Likewise. ! * system-linux-x86_64.ads (Always_Compatible_Rep): Likewise. ! * system-linux-x86.ads (Always_Compatible_Rep): Likewise. ! * system-mingw.ads (Always_Compatible_Rep): Likewise. ! * system-solaris-sparc.ads (Always_Compatible_Rep): Likewise. ! * system-solaris-sparcv9.ads (Always_Compatible_Rep): Likewise. ! * system-solaris-x86.ads (Always_Compatible_Rep): Likewise. ! ! 2008-05-27 Ed Schonberg ! ! * sem_attr.adb: add guard to previous patch. ! ! 2008-05-27 Ed Schonberg ! ! * exp_disp.adb (Build_Dispatch_Tables): For a private type completed by ! a synchronized tagged type, do not attempt to build dispatch table for ! full view. The table is built for the corresponding record type, which ! has its own declaration. ! ! 2008-05-27 Gary Dismukes ! ! * sem_ch3.adb (Fixup_Bad_Constraint): Set the Etype on the bad subtype ! to the known type entity E, rather than setting it to Any_Type. Fixes ! possible blowup in function Base_Init_Proc, as called from Freeze_Entity ! for objects whose type had an illegal constraint. ! ! 2008-05-27 Vincent Celier ! ! * gnat_ugn.texi: ! Add succinct documentation for attribute Excluded_Source_List_File ! ! 2008-05-27 Vincent Celier ! ! * prj-attr.adb: Add new project level attribute Map_File_Option ! ! * prj-nmsc.adb (Process_Linker): Process new attribute Map_File_Option ! ! * prj.ads: Minor reformatting and comment update ! (Project_Configuration): New component Map_File_Option ! ! * snames.adb: New standard name Map_File_Option ! ! * snames.ads: New standard name Map_File_Option ! ! 2008-05-27 Vincent Celier ! ! * xsnames.adb: Remove unused variable Oname ! ! 2008-05-27 Doug Rupp ! ! * exp_ch6.adb: ! (Expand_N_Function_Call): Fix comments. Minor reformatting. ! ! * exp_vfpt.ads: ! (Expand_Vax_Foreign_Return): Fix comments. ! ! 2008-05-27 Thomas Quinot ! ! * exp_dist.adb: Minor reformating ! ! 2008-05-26 Gary Dismukes ! ! * exp_ch3.adb (Expand_N_Object_Declaration): Remove checks for ! No_Default_Initialization, which is now delayed until the freeze point ! of the object. Add a comment about deferral of the check. ! ! * freeze.adb (Freeze_Entity): The check for No_Default_Initialization ! on objects is moved here. ! ! 2008-05-26 Eric Botcazou ! ! * s-casi16.adb (Uhalf): Rewrite it as integer with small alignment. ! (Compare_Array_S16): Adjust for above change. ! * s-casi32.adb (Uword): Likewise. ! (Compare_Array_S32): Likewise. ! * s-casi64.adb (Uword): Likewise. ! (Compare_Array_S64): Likewise. ! * s-caun16.adb (Uhalf): Likewise. ! (Compare_Array_U16): Likewise. ! * s-caun32.adb (Uword): Likewise. ! (Compare_Array_U32): Likewise. ! * s-caun64.adb (Uword): Likewise. ! (Compare_Array_U64): Likewise. ! ! 2008-05-26 Robert Dewar ! ! * exp_ch6.adb: Add ??? comment for previous change ! ! * exp_vfpt.adb: Minor reformatting ! ! * exp_vfpt.ads: Add ??? comment for last change ! ! * sem_attr.adb: Add some ??? comments for previous change ! ! * s-vaflop.ads: Add comments for previous change ! ! 2008-05-26 Doug Rupp ! ! * s-vaflop-vms-alpha.adb: ! Remove System.IO use clause, to prevent spurious ambiguities when ! package is access through rtsfind. ! ! 2008-05-26 Sergey Rybin ! ! * tree_io.ads (ASIS_Version_Number): Update because of the changes ! made in front-end ! ! 2008-05-26 Ed Schonberg ! ! * sem_attr.adb: ! (Resolve_Attribute, case 'address): S (A .. B)' address can be safely ! converted to S (A)'address only if A .. B is known to be a non-null ! range. ! ! 2008-05-26 Doug Rupp ! ! * s-vaflop.adb: ! (Return_D, Return_F, Return_G): New functions. ! ! * s-vaflop.ads: ! (Return_D, Return_F, Return_G): New functions. ! ! * exp_vfpt.adb: ! (Expand_Vax_Foreign_Return): New procedure ! ! * exp_vfpt.ads: ! (Expand_Vax_Foreign_Return): New procedure ! ! * rtsfind.ads: ! (RE_Return_D, RE_Return_F, RE_Return_G): New RE_Ids ! (RE_Return_D, RE_Return_F, RE_Return_G): New RE_Unit_Table elements ! ! * exp_ch6.adb: ! Import Exp_Vfpt ! (Expand_N_Function_Call): Call Expand_Vax_Foreign_Return. ! ! * s-vaflop-vms-alpha.adb: ! (Return_D, Return_F, Return_G): New functions. ! ! 2008-05-26 Gary Dismukes ! ! * exp_ch3.adb (Build_Array_Init_Proc): Only set Init_Proc to a dummy ! init proc entity when there is actual default initialization associated ! with the component type, to avoid spurious errors on objects of scalar ! array types that are marked Is_Public when No_Default_Initialization ! applies. ! ! 2008-05-26 Thomas Quinot ! ! * rtsfind.ads, rtsfind.adb: ! (RE_Get_RACW): New runtime library entity provided by PolyORB s-parint. ! (Check_RPC): Support per-PCS-kind API versioning. ! ! exp_dist.ads, exp_dist.adb: ! (Build_Stub_Tag, Get_Stub_Elements): New utility subprograms. ! (PolyORB_Support.Add_RACW_From_Any): Offload common code to new runtime ! library function Get_RACW. ! (PolyORB_Support.Add_RACW_To_Any): Offload common code to new runtime ! library function Get_Reference. ! (PolyORB_Support.Add_RACW_Read_Attribute): Use Get_RACW instead of going ! through an intermediate Any. ! (PolyORB_Support.Add_RACW_Write_Attribute): Use Get_Reference instead of ! going through an intermediate Any. ! ! * sem_dist.adb: Minor reformatting. ! ! 2008-05-26 Javier Miranda ! ! * einfo.ads (Abstract_Interface_Alias): Renamed as Interface_Alias. ! (Set_Abstract_Interface_Alias): Renamed as Set_Interface_Alias. ! (Is_Internal): Adding documentation on internal entities that have ! attribute Interface_Alias (old attribute Abstract_Interface_Alias) ! ! * einfo.adb (Abstract_Interface_Alias): Renamed as Interface_Alias. ! (Set_Abstract_Interface_Alias): Renamed as Set_Interface_Alias. ! Added assertion to force entities with this attribute to have ! attribute Is_Internal set to True. ! (Next_Tag_Component): Simplify assertion using attribute Is_Tag. ! ! * sem_ch3.adb (Derive_Interface_Subprograms): This subprogram has been ! renamed as Derive_Progenitor_Subprograms. In addition, its code is ! a new implementation. ! (Add_Interface_Tag_Components): Remove special management of ! synchronized interfaces. ! (Analyze_Interface_Declaration): Minor reformating ! (Build_Derived_Record_Type): Minor reformating ! (Check_Abstract_Overriding): Avoid reporting error in case of abstract ! predefined primitive inherited from interface type because the body of ! internally generated predefined primitives of tagged types are generated ! later by Freeze_Type ! (Derive_Subprogram): Avoid generating an internal name if the parent ! subprogram overrides an interface primitive. ! (Derive_Subprograms): New implementation that keeps separate the ! management of tagged types not implementing interfaces, from tagged ! types that implement interfaces. ! (Is_Progenitor): New implementation. ! (Process_Full_View): Add documentation ! (Record_Type_Declaration): Replace call to Derive_Interface_Subprograms ! by call to Derive_Progenitor_Subprograms. ! ! * sem_ch6.ads (Is_Interface_Conformant): New subprogram. ! (Check_Subtype_Conformant, Subtype_Conformant): Adding new argument ! Skip_Controlling_Formals. ! ! * sem_ch6.adb (Is_Interface_Conformant): New subprogram. ! (Check_Conventions): New implementation. Remove local subprogram ! Skip_Check. Remove formal Search_From of routine Check_Convention. ! (Check_Subtype_Conformant, Subtype_Conformant): Adding new argument ! Skip_Controlling_Formals. ! (New_Overloaded_Entity): Enable addition of predefined dispatching ! operations. ! ! * sem_disp.ads ! (Find_Primitive_Covering_Interface): New subprogram. ! ! * sem_disp.adb (Check_Dispatching_Operation): Disable registering ! the task body procedure as a primitive of the corresponding tagged ! type. ! (Check_Operation_From_Private_Type): Avoid adding twice an entity ! to the list of primitives. ! (Find_Primitive_Covering_Interface): New subprogram. ! (Override_Dispatching_Operation): Add documentation. ! ! * sem_type.adb (Covers): Minor reformatings ! ! * sem_util.ads (Collect_Abstract_Interfaces): Renamed as ! Collect_Interfaces. ! Rename formal. ! (Has_Abstract_Interfaces): Renamed as Has_Interfaces. ! (Implements_Interface): New subprogram. ! (Is_Parent): Removed. ! (Primitive_Names_Match): New subprogram. ! (Remove_Homonym): Moved here from Derive_Interface_Subprograms. ! (Ultimate_Alias): New subprogram. ! ! * sem_util.adb (Collect_Abstract_Interfaces): Renamed as ! Collect_Interfaces. ! Remove special management for synchronized types. Rename formal. Remove ! internal subprograms Interface_Present_In_Parent and Add_Interface. ! (Has_Abstract_Interfaces): Renamed as Has_Interfaces. Replace assertion ! on non-record types by code to return false in such case. ! (Implements_Interface): New subprogram. ! (Is_Parent): Removed. No special management is now required for ! synchronized types covering interfaces. ! (Primitive_Names_Match): New subprogram. ! (Remove_Homonym): Moved here from Derive_Interface_Subprograms. ! (Ultimate_Alias): New subprogram. ! ! * exp_ch3.adb (Add_Internal_Interface_Entities): New subprogram. ! Add internal entities associated with secondary dispatch tables to ! the list of tagged type primitives that are not interfaces. ! (Freeze_Record_Type): Add new call to Add_Internal_Interface_Entities ! (Make_Predefined_Primitive_Specs): Code reorganization to improve ! the management of predefined equality operator. In addition, if ! the type has an equality function corresponding with a primitive ! defined in an interface type, the inherited equality is abstract ! as well, and no body can be created for it. ! ! * exp_disp.ads (Is_Predefined_Dispatching_Operation): Moved from ! exp_util to exp_disp. ! (Is_Predefined_Interface_Primitive): New subprogram. Returns True if ! an entity corresponds with one of the predefined primitives required ! to implement interfaces. ! Update copyright notice. ! ! * exp_disp.adb (Set_All_DT_Position): Add assertion. Exclude from the ! final check on abstract subprograms all the primitives associated with ! interface primitives because they must be visible in the public and ! private part. ! (Write_DT): Use Find_Dispatching_Type to locate the name of the ! interface type. This allows the use of this routine, for debugging ! purposes, when the tagged type is not fully decorated. ! (Is_Predefined_Dispatching_Operation): Moved from exp_util to exp_disp. ! Factorize code calling new subprogram Is_Predefined_Interface_Primitive. ! (Is_Predefined_Interface_Primitive): New subprogram. Returns True if an ! entity corresponds with one of the predefined primitives required to ! implement interfaces. ! ! * exp_util.adb (Find_Interface_ADT): New implementation ! (Find_Interface): Removed. ! ! * sprint.adb (Sprint_Node_Actual): Generate missing output for the ! list of interfaces associated with nodes ! N_Formal_Derived_Type_Definition and N_Private_Extension_Declaration. ! ! 2008-05-26 Thomas Quinot ! ! * exp_ch5.adb (Make_Tag_Ctrl_Assignment): Add missing guard on ! condition for assignment to temporary. ! ! 2008-05-26 Ed Schonberg ! ! * exp_ch4.adb (Expand_Concatenate_Other): Add explicit constraint ! checks on the upper bound if the index type is a modular type, to ! prevent wrap-around computations when size is close to upper bound of ! type. ! ! 2008-05-26 Robert Dewar ! ! * sem_ch3.adb: Minor reformatting ! ! 2008-05-26 Ed Schonberg ! ! * sem_ch12.adb (Remove_Parent): Use specification of instance ! to retrieve generic parent, ! to handle properly the case where the instance is a child unit. ! Add guard to handle properly wrapper packages. ! Minor reformatting ! ! 2008-05-26 Thomas Quinot ! ! * sinfo.ads: Minor reformatting ! ! 2008-05-26 Hristian Kirtchev ! ! * exp_ch4.adb (Expand_N_Type_Conversion): Minor code reformatting. ! Generate a tag check when the result subtype of a function, defined by ! an access definition, designates a specific tagged type. ! (Make_Tag_Check): New routine. ! ! 2008-05-26 Arnaud Charlet ! ! * ceinfo.adb, csinfo.adb: Remove warnings. Update headers. ! ! 2008-05-26 Eric Botcazou ! ! * gigi.h (gigi): Remove bogus ATTRIBUTE_UNUSED marker. ! (builtin_decl_for): Likewise. ! * trans.c (gigi): Likewise. ! * utils.c (def_builtin_1): Fix formatting. ! ! 2008-05-26 Hristian Kirtchev ! ! * exp_ch3.adb (Build_Init_Statements): Alphabetize local variables. ! Create the statements which map a string name to protected or task ! entry indix. ! ! * exp_ch9.adb: Add with and use clause for Stringt. ! Minor code reformatting. ! (Build_Entry_Names): New routine. ! (Make_Initialize_Protection, Make_Task_Create_Call): Generate a value ! for flag Build_Entry_Names which controls the allocation of the data ! structure for the string names of entries. ! ! * exp_ch9.ads (Build_Entry_Names): New subprogram. ! ! * exp_util.adb (Entry_Names_OK): New function. ! ! * exp_util.ads (Entry_Names_OK): New function. ! ! * rtsfind.ads: Add RO_PE_Set_Entry_Name and RO_TS_Set_Entry_Name to ! enumerations RE_Id and RE_Unit_Table. ! ! * s-taskin.adb Add with and use clause for Ada.Unchecked_Deallocation. ! (Free_Entry_Names_Array): New routine. ! ! * s-taskin.ads: Comment reformatting. ! Add types String_Access, Entry_Names_Array, Entry_Names_Array_Access. ! Add component Entry_Names to record Ada_Task_Control_Block. ! (Free_Entry_Names_Array): New routine. ! ! * s-tassta.adb (Create_Task): If flag Build_Entry_Names is set, ! dynamically allocate an array ! of string pointers. This structure holds string entry names. ! (Free_Entry_Names): New routine. ! (Free_Task, Vulnerable_Free_Task): Deallocate the entry names array. ! (Set_Entry_Names): New routine. ! ! * s-tassta.ads: ! (Create_Task): Add formal Build_Entry_Names. The flag is used to ! control the allocation of the data structure which stores entry names. ! (Set_Entry_Name): New routine. ! ! * s-tpoben.adb: ! Add with and use clause for Ada.Unchecked_Conversion. ! (Finalize): Deallocate the entry names array. ! (Free_Entry_Names): New routine. ! (Initialize_Protection_Entries): When flag Build_Entry_Names is set, ! create an array of string pointers to hold the entry names. ! (Set_Entry_Name): New routine. ! ! * s-tpoben.ads: ! Add field Entry_Names to record Protection_Entries. ! (Initialize_Protection_Entries): Add formal Build_Entry_Names. ! (Set_Entry_Name): New routine. ! ! 2008-05-26 Vincent Celier ! ! * prj-nmsc.adb: ! (Process_Project_Level_Simple_Attributes): process attribute Library_GCC ! ! * prj.ads: ! (Project_Configuration): New component Shared_Lib_Driver ! ! 2008-05-26 Ed Schonberg ! ! * inline.adb: ! (Cleanup_Scopes): For a protected operation, transfer finalization list ! to protected body subprogram, to force cleanup actions when needed. ! ! 2008-05-26 Robert Dewar ! ! * sem_cat.adb: Minor reformatting ! ! * gnatname.adb: Minor reformatting ! ! * osint.ads: Minor reformatting ! ! * s-carun8.ads: Minor reformatting ! ! * g-heasor.ads: Minor comment fix (unit is now pure) ! ! 2008-05-26 Robert Dewar ! ! * exp_ch2.adb: ! (Expand_Current_Value): Properly type generated integer literal ! ! 2008-05-26 Sergey Rybin ! ! * gnat_ugn.texi: Add description for the new gnatcheck rule - ! Separate_Numeric_Error_Handlers. ! ! 2008-05-26 Pascal Obry ! ! * sem_aggr.adb: Minor reformatting. ! ! 2008-05-26 Jose Ruiz ! ! * s-osinte-aix.adb: ! (To_Target_Priority): Setting the time slice value to 0 or greater sets ! the scheduling policy to FIFO within priorities or round-robin ! respectively. ! Hence, the priority must be set in this case to the one selected by the ! user. ! ! 2008-05-26 Ed Schonberg ! ! * sem_ch12.adb: ! (Remove_Parent): If the enclosing scope is an instance whose generic ! parent is declared within some parent scope of the just completed ! instance, make full views of the entities in that parent visible, when ! applicable. ! ! 2008-05-26 Kai Tietz ! ! * mingw32.h (STD_MINGW): Set to true for target w64. ! ! 2008-05-25 Eric Botcazou ! ! * trans.c (Attribute_to_gnu) : Set TREE_NO_TRAMPOLINE ! instead of TREE_STATIC on the ADDR_EXPR. 2008-05-24 Eric Botcazou ! * trans.c (gnat_to_gnu): Do not set source location info on NOP_EXPRs. ! (Sloc_to_locus): Do not overwrite known GCC locations when translating ! GNAT standard locations. ! ! 2008-05-23 Eric Botcazou ! ! * gigi.h (mark_visited): Declare. ! * decl.c (gnat_to_gnu_entity): Use mark_visited instead of marking ! only the topmost node of expressions. ! (elaborate_expression_1): Look deeper for read-only variables. ! * trans.c (add_decl_expr): Use mark_visited instead of marking by hand. ! (mark_visited): Move logic to mark_visited_r. Invoke walk_tree. ! (mark_visited_r): New function. ! ! 2008-05-23 Vincent Celier ! ! * snames.adb: New standard name Excluded_Source_List_File. ! ! * snames.ads: New standard name Excluded_Source_List_File. ! ! * prj-attr.adb: New project level attribute Excluded_Source_List_File. ! ! * prj-nmsc.adb: (Find_Excluded_Sources): New parameter Project. ! Get excluded sources from ! file indicated by attribute Excluded_Source_List_File, when present and ! neither Excluded_Source_Files nor Locally_Removed_Files are declared. ! ! 2008-05-23 Robert Dewar ! ! * exp_dist.adb: Minor reformatting ! ! 2008-05-23 Ed Schonberg ! ! * sem_attr.adb (Resolve_Attribute, case 'address): If the prefix is a ! slice, convert it to an indexed component, which is equivalent, more ! efficient, and usable even if the slice itself is not addressable. ! ! 2008-05-23 Olivier Hainque ! ! * gnat_ugn.texi (Calling Conventions): Document that the Intrinsic ! convention also allows access to named compiler built-in subprograms ! such as the GCC __builtin family. ! ! 2008-05-23 Vincent Celier ! ! * prj-nmsc.adb (Check_Naming_Schemes): Check a file for spec, body and ! sep. If there are several possibilities, choose the one with the ! longer prefix. ! ! 2008-05-23 Vincent Celier ! ! * gnatlink.adb (Process_Args): Do not disable scanning of ALI file for ! back end switches when executable specified with --GCC= is same as ! default, even if there are additional options. ! ! * gnat_ugn.texi: ! Document when the back end switches from the ALI file are taken into ! account when gnatlink is invoked with --GCC= ! ! 2008-05-23 Thomas Quinot ! ! * s-os_lib.adb: ! (copy_File): Do not open destination file if source file is unreadable. ! ! 2008-05-23 Eric Botcazou ! ! * utils.c (handle_type_generic_attribute): Adjust to accept ! fixed arguments before an elipsis. ! ! 2008-05-21 Thomas Quinot ! ! * g-sothco.ads, g-sothco.adb: New files. ! ! 2008-05-20 Thomas Quinot ! ! * Makefile.rtl (GNAT.Sockets.Thin_Common): New unit. ! ! * g-sttsne-vxworks.adb: Add missing dependency on Sockets.Constants. ! Add missing "with" of Ada.Unchecked_Conversion ! ! * g-soccon-linux-ppc.ads, g-soccon-linux-64.ads, g-soccon-lynxos.ads, ! g-soccon-linux-x86.ads, g-soccon-hpux-ia64.ads, ! g-soccon-solaris-64.ads, g-soccon-tru64.ads, g-soccon-aix.ads, ! g-soccon-irix.ads, g-soccon-hpux.ads, g-soccon-solaris.ads, ! g-soccon-vms.ads, g-soccon-mingw.ads, g-soccon-vxworks.ads, ! g-socthi-vxworks.adb, g-soccon-freebsd.ads, g-soccon.ads: ! Move common code out of GNAT.Sockets.Thin implementations and into ! Thin_Common. ! New constant SIZEOF_fd_set ! New flag Has_Sockaddr_Len ! New constants SIZEOF_sockaddr_in, SIZEOF_sockaddr_in6 ! ! * g-stsifd-sockets.adb ! (Create): Remove call to Set_Length; use Set_Family to set the family ! and (on appropriate platforms) length fields in struct sockaddr. ! ! * g-socthi.adb, g-socthi.ads, g-socthi-vms.ads, g-socthi-vms.adb, ! g-socthi-mingw.adb, g-socthi-mingw.ads, g-socthi-vxworks.adb, ! g-soccon-darwin.ads, g-soccon-darwin.ads: New constant SIZEOF_fd_set ! Move common code out of GNAT.Sockets.Thin implementations and into ! Thin_Common. ! ! * g-socket.ads, g-socket.adb: ! Move common code out of GNAT.Sockets.Thin implementations and into ! Thin_Common. ! (Connect_Socket, Accept_Socket): Provide new versions of these two ! routines that operate with a user specified timeout. ! (Bind_Socket, Connect_Socket, Send_Socket): Remove calls to Set_Length, ! this is now handled automatically by Set_Family on platforms that ! require it. ! ! * gen-soccon.c: ! Move common code out of GNAT.Sockets.Thin implementations and into ! Thin_Common. ! (SIZEOF_sockaddr_in6): On platforms where IPv6 is not supported, define ! this constant to 0 (not -1) because we use it to initialize an ! unsigned_char value. ! Align values for numeric constants only. ! Handle the case of systems that do not support AF_INET6. ! New constant SIZEOF_fd_set ! New flag Has_Sockaddr_Len ! New constants SIZEOF_sockaddr_in, SIZEOF_sockaddr_in6 ! ! * gsocket.h: New flag Has_Sockaddr_Len ! New constants SIZEOF_sockaddr_in, SIZEOF_sockaddr_in6 ! ! 2008-05-20 Santiago Uruena ! ! * i-cobol.ads: Interfaces.COBOL should be preelaborate. ! ! 2008-05-20 Arnaud Charlet ! ! * s-linux-hppa.ads (atomic_lock_t): Put back proper alignment now that ! the underlying issue with malloc/free has been fixed. Remove associated ! comments. ! Minor reformatting. ! Related to PR ada/24533 ! ! 2008-05-20 Robert Dewar ! ! * ali.adb: Correct casing of ASCII.NUL ! ! * styleg-c.adb (Check_Identifier): Handle case of names in ASCII ! properly. ! ! 2008-05-20 Robert Dewar ! Gary Dismukes ! ! * checks.adb (Apply_Arithmetic_Overflow_Check): Avoid intermediate ! overflow if result converted to wider integer type. ! (Apply_Type_Conversion_Checks): Don't emit checks on conversions to ! discriminated types when discriminant checks are suppressed. ! ! 2008-05-20 Vincent Celier ! ! * cstand.adb (Print_Standard): Issue the correct Size clause for type ! Wide_Wide_Character. ! ! 2008-05-20 Tristan Gingold ! ! * decl.c: Do not emit a variable for a object that has an address ! representation clause whose value is known at compile time. ! When a variable has an address clause whose value is known at compile ! time, refer to this variable by using directly the address instead of ! dereferencing a pointer. ! ! 2008-05-20 Robert Dewar ! ! PR ada/30740 ! * einfo.ads, einfo.adb (Non_Binary_Modulus): Applies to all types and ! subtypes, always False for non-modular types. ! Shared_Var_Assign_Proc (node22) and Shared_Var_Read_Proc (node 15) ! entry nodes have been replaced by Shared_Var_Procs_Instance (node22) ! for Shared_Storage package. ! (Is_RACW_Stub_Type): New entity flag. ! ! * exp_ch4.adb ! (Expand_N_Op_Expon): Avoid incorrect optimization of a*(2**b) in the ! case where we have a modular type with a non-binary modules. ! Comments reformattings. ! ! * sem_intr.adb: Simplify code not that Non_Binary_Modulus applies to ! all types. ! ! 2008-05-20 Javier Miranda ! ! * exp_aggr.adb ! (Build_Record_Aggr_Code): Fix wrong tests checking progenitors. Previous ! tests did not covered the case in which the type of the aggregate has ! no progenitors but some its parents has progenitors. ! ! 2008-05-20 Gary Dismukes ! Hristian Kirtchev ! ! * exp_ch3.adb ! (Expand_N_Object_Declaration): Correct the condition which triggers the ! generation of a call to Displace when initializing a class-wide object. ! (Build_Dcheck_Functions): Build discriminant-checking for null variants ! when Frontend_Layout_On_Target is true to ensure that they're available ! for calling when a record variant size function is built in Layout. ! ! 2008-05-20 Ed Schonberg ! ! * exp_ch5.adb (Expand_Assign_Record): Within an initialization ! procedure for a derived type retrieve the discriminant values from the ! parent using the corresponding discriminant. ! (Expand_N_Assignment_Statement): Skip generation of implicit ! if-statement associated with controlled types if we are ! compiling with restriction No_Finalization. ! ! 2008-05-20 Vincent Celier ! ! * prj.adb (Hash (Project_Id)): New function ! (Project_Empty): Add new component Interfaces_Defined ! ! * prj.ads (Source_Data): New component Object_Linked ! (Language_Config): New components Object_Generated and Objects_Linked ! (Hash (Project_Id)): New function ! (Source_Data): New Boolean components In_Interfaces and ! Declared_In_Interfaces. ! (Project_Data): New Boolean component Interfaces_Defined ! ! * prj-attr.adb: ! New project level attribute Object_Generated and Objects_Linked ! Add new project level attribute Interfaces ! ! * prj-dect.adb: Use functions Present and No throughout ! (Parse_Variable_Declaration): If a string type is specified as a simple ! name and is not found in the current project, look for it also in the ! ancestors of the project. ! ! * prj-makr.adb: ! Replace procedure Make with procedures Initialize, Process and Finalize ! to implement H414-023: process different directories with different ! patterns. ! Use functions Present and No throughout ! ! * prj-makr.ads: ! Replace procedure Make with procedures Initialize, Process and Finalize ! ! * prj-nmsc.adb ! (Add_Source): Set component Object_Exists and Object_Linked accordnig to ! the language configuration. ! (Process_Project_Level_Array_Attributes): Process new attributes ! Object_Generated and Object_Linked. ! (Report_No_Sources): New Boolean parameter Continuation, defaulted to ! False, to indicate that the erreor/warning is a continuation. ! (Check): Call Report_No_Sources with Contnuation = True after the first ! call. ! (Error_Msg): Process successively contnuation character and warning ! character. ! (Find_Explicit_Sources): Check that all declared sources have been found ! (Check_File): Indicate in hash table Source_Names when a declared source ! is found. ! (Check_File): Set Other_Part when found ! (Find_Explicit_Sources): In multi language mode, check if all exceptions ! to the naming scheme have been found. For Ada, report an error if an ! exception has not been found. Otherwise, disregard the exception. ! (Check_Interfaces): New procedure ! (Add_Source): When Other_Part is defined, set mutual pointers in spec ! and body. ! (Check): In multi-language mode, call Check_Interfaces ! (Process_Sources_In_Multi_Language_Mode): Set In_Interfaces to False ! for an excluded source. ! (Remove_Source): A source replacing a source in the interfaces is also ! in the interfaces. ! ! * prj-pars.adb: Use function Present ! ! * prj-part.adb: Use functions Present and No throughout ! (Parse_Single_Project): Set the parent project for child projects ! (Create_Virtual_Extending_Project): Register project with no qualifier ! (Parse_Single_Project): Allow an abstract project to be extend several ! times. Do not allow an abstract project to extend a non abstract ! project. ! ! * prj-pp.adb: Use functions Present and No throughout ! (Print): Take into account the full associative array attribute ! declarations. ! ! * prj-proc.adb: Use functions Present and No throughout ! (Expression): Call itself with the same From_Project_Node for the ! default value of an external reference. ! ! * prj-strt.adb: Use functions Present and No throughout ! (Parse_Variable_Reference): If a variable is specified as a simple name ! and is not found in the current project, look for it also in the ! ancestors of the project. ! ! * prj-tree.ads, prj-tree.adb (Present): New function ! (No): New function ! Use functions Present and No throughout ! (Parent_Project_Of): New function ! (Set_Parent_Project_Of): New procedure ! ! * snames.ads, snames.adb: ! Add new standard names Object_Generated and Objects_Linked ! ! 2008-05-20 Hristian Kirtchev ! ! * exp_ch6.adb (Expand_Call): Add guard to ensure that both the parent ! and the derived type are of the same kind. ! (Expand_Call): Generate type conversions for actuals of ! record or array types when the parent and the derived types differ in ! size and/or packed status. ! ! 2008-05-20 Javier Miranda ! Ed Schonberg ! ! * exp_disp.adb (Make_DT, Make_Secondary_DT, Make_Tags): Avoid ! generating dispatch tables of locally defined tagged types statically. ! Remove implicit if-statement that is no longer required. ! (Expand_Dispatching_Call): If this is a call to an instance of the ! generic dispatching constructor, the type of the first argument may be ! a subtype of Tag, so always use the base type to recognize this case. ! ! 2008-05-20 Thomas Quinot ! ! * exp_dist.adb ! (GARLIC_Support.Add_RACW_Read_Attribute): When a zero value is received, ! and the RACW is null-excluding, raise CONSTRAINT_ERROR instead of ! assigning NULL into the result, to avoid a spurious warning. ! (Add_RACW_Features, case Same_Scope): Add assertion that designated type ! is not frozen. ! (Add_Stub_Type): Set entity flag Is_RACW_Stub_Type on generated stub ! type. ! (Build_From_Any_Function, Build_To_Any_Function, ! Build_TypeCode_Function): For a type that has user-specified stream ! attributes, use an opaque sequence of octets as the representation. ! ! 2008-05-20 Kevin Pouget ! ! * exp_smem.ads, exp_smem.adb: Construction of access and assign ! routines has been replaced by an instantiation of ! System.Shared_Storage.Shared_Var_Procs generic package, while expanding ! shared variable declaration. ! Calls to access and assign routines have been replaced by calls to ! Read/Write routines of System.Shared_Storage.Shared_Var_Procs ! instantiated package. ! ! * rtsfind.ads: RE_Shared_Var_Procs entry has been added in RE_Unit_Table ! It identifies the new generic package added in s-shasto. ! ! * s-shasto.adb, s-shasto.ads: A new generic package has been added, it ! is instantiated for each shared passive variable. It provides ! supporting procedures called upon each read or write access by the ! expanded code. ! ! * sem_attr.adb: ! For this runtime unit (always compiled in GNAT mode), we allow ! stream attributes references for limited types for the case where ! shared passive objects are implemented using stream attributes, ! which is the default in GNAT's persistent storage implementation. ! ! 2008-05-20 Ed Schonberg ! ! * freeze.adb ! (Freeze_Enumeration_Type): For a subtype that inherits a foreign ! convention from its base type, do not set the type to that of integer, ! because it may inherit a size clause. ! Warn on a size clause with a size different ! from that of Integer, if the type has convention C. ! ! 2008-05-20 Vincent Celier ! ! * gnatname.adb ! (Scan_Args): Rewrite to take into account new switch --and to separate ! arguments into sections. ! (Gnatname): Call Prj.Makr.Initialize, then Prj.Makr.Process for each ! section, then Finalize. ! ! 2008-05-20 Tristan Gingold ! ! * init.c: Enable stack probing on ppc-linux. ! ! * tracebak.c: Add symbolic traceback for ppc-linux. ! ! * system-linux-ppc.ads: Enable stack probing on ppc-linux. ! ! 2008-05-20 Arnaud Charlet ! ! * Makefile.in ! (common-tools): New rule, to avoid parallel build failure on gnat tools. ! Reenable parallel builds on this Makefile. ! ! * Make-lang.in: Update dependencies. ! ! 2008-05-20 Robert Dewar ! ! * opt.ads (Treat_Restrictions_As_Warnings): New switch ! ! * sem_prag.adb, par-prag.adb, restrict.ads: Implement flag ! Treat_Restrictions_As_Warnings. ! ! * switch-c.adb: Recognize new switch -gnatr ! ! * usage.adb: Add line for -gnatr ! ! 2008-05-20 Hristian Kirtchev ! ! * par-ch3.adb ! (P_Access_Definition): Change the error message when parsing "access ! all" in Ada 95 mode. The message no longer forces the user to recompile ! in 05 mode only to discover that anonymous access types are not allowed ! to have "all". ! ! 2008-05-20 Hristian Kirtchev ! ! * par-ch9.adb ! (P_Protected): Update the error message on missing "-gnat05" switch when ! using interfaces in conjunction with protected types. Remove the ! incorrect error message associated with the presence of "private" after ! a "with". ! ! 2008-05-20 Ed Schonberg ! ! * sem_aggr.adb: Update comments. ! Improve previous change for PR ada/17985 ! ! 2008-05-20 Thomas Quinot ! ! * sem_cat.adb ! (Set_Categorization_From_Scope): Do not set In_Remote_Types unless in ! the visible part of the spec of a remote types unit. ! (Validate_Remote_Access_Object_Type_Declaration): ! New local subprogram Is_Valid_Remote_Object_Type, replaces ! Is_Recursively_Limited_Private. ! (Validate_RACW_Primitives): Enforce E.2.2(14) rules: the types of all ! non-controlling formals (and the return type, even though this is not ! explicit in the standard) must support external streaming. ! (Validate_RCI_Subprogram_Declaration): Enforce E.2.3(14) rules: same ! as above for of RAS types and RCI subprograms. (The return type is not ! checked yet). ! Update comments related to RACWs designating limited interfaces per ! ARG ruling on AI05-060. ! ! * sem_util.ads, sem_util.adb ! (Is_Remote_Access_To_Class_Wide_Type): Only rely on Is_Remote_Types and ! Is_Remote_Call_Interface to identify RACW types in a stable and ! consistent way. We used to rely in this predicate on the privateness of ! the designated type and its ancestors, but depending on the currently ! visible private parts, this caused false negatives. We now uniformly ! rely on checks made at the point where the RACW type is declared. ! (Inspect_Deferred_Constant_Completion): Moved from Sem_Ch7. ! ! 2008-05-20 Javier Miranda ! Ed Schonberg ! Hristian Kirtchev ! ! * sem_ch3.adb ! (Analyze_Object_Declaration): Fix over-conservative condition ! restricting use of predefined assignment with tagged types that have ! convention CPP. ! (Analyze_Object_Declaration): Relax the check regarding deferred ! constants declared in scopes other than packages since they can be ! completed with pragma Import. ! Add missing escaping of all-caps word 'CPP' in error messages. ! (Build_Discriminated_Subtype): Do not inherit representation clauses ! from parent type if subtype already carries them, because they are ! inherited earlier during derivation and already include those that may ! come from a partial view. ! ! * sem_ch9.adb, sem_ch5.adb, sem_ch6.adb (Analyze_Subprogram_Body): ! Check the declarations of a subprogram body for proper deferred ! constant completion. ! ! * sem_ch7.ads, sem_ch7.adb ! (Inspect_Deferred_Constant_Completion): Moved to sem_util. ! ! 2008-05-20 Ed Schonberg ! Thomas Quinot ! ! * sem_ch4.adb ! (Try_Indexed_Call): Handle properly a construct of the form F(S) where ! F is a parameterless function that returns an array, and S is a subtype ! mark. ! (Analyze_Call): Insert dereference when the prefix is a parameterless ! function that returns an access to subprogram and the call has ! parameters. ! Reject a non-overloaded call whose name resolves to denote ! a primitive operation of the stub type generated to support a remote ! access-to-class-wide type. ! ! 2008-05-20 Ed Schonberg ! ! * sem_ch8.adb ! (Note_Redundant_Use): Diagnose a redundant use within a subprogram body ! when there is a use clause for the same entity in the context. ! (Analyze_Subprogram_Renaming): A renaming_as_body is legal if it is ! created for a stream attribute of an abstract type or interface type. ! ! 2008-05-20 Thomas Quinot ! ! * sem_dist.ads, sem_dist.adb (Is_RACW_Stub_Type_Operation): New ! subprogram. ! ! * sem_type.adb ! (Add_One_Interp): Ignore any interpretation that is a primitive ! operation of an RACW stub type (these primitives are only executed ! through dispatching, never through static calls). ! (Collect_Interps): When only one interpretation has been found, set N's ! Entity and Etype to that interpretation, otherwise Entity and Etype may ! still refer to an interpretation that was ignored by Add_One_Interp, ! in which case would end up with being marked as not overloaded but with ! an Entity attribute not pointing to its (unique) correct interpretation. ! ! 2008-05-20 Ed Schonberg ! ! * sem_eval.adb ! (Eval_Slice): Warn when a slice whose discrete range is a subtype name ! denotes the whole array of its prefix. ! ! 2008-05-20 Robert Dewar ! ! * sem_res.adb (Resolve_Op_Not): Warn on double negation ! ! 2008-05-20 Ed Schonberg ! ! * sprint.adb ! (Print_Itype): Do not modify the sloc of the component type of a ! (packed) array itype, because it is an unrelated type whose source ! location is independent of the point of creation of the itype itself. ! ! 2008-05-20 Thomas Quinot ! ! * uintp.adb, urealp.adb: Replace calls to Increment_Last + Set with ! Append. ! ! 2008-05-20 Robert Dewar ! Vincent Celier ! ! * vms_data.ads: Add entry for -gnatr ! Put GNAT SYNC section in proper alpha order ! Add VMS qualifier /DISPLAY_PROGRESS equivalent to gnatmake switch -d ! ! * gnat_ugn.texi: Add documentation for new gnatname switch --and ! Update the style checks section ! Add documentation of -gnatr ! Add to the "Adding the Results of Compiler Checks to gnatcheck Output" ! subsection the explanation how compiler checks should be disabled for ! gnatcheck. ! Update the list of Ada 95 reserved words used by in the project language ! Add documentation for project qualifiers. ! Document that abstract projects may be extended by different projects in ! the same project tree. ! Add documentation for gnatmake switch -d ! ! * ug_words: Add -gnatyy VMS equivalence string. ! Add entry for -gnatr ! ! 2008-05-20 Bob Duff ! ! * a-rttiev.adb ! (Set_Handler): Remove code from both of these that implements ! RM-D.15(15/2), because it causes a race condition and potential ! deadlock. ! (Process_Queued_Events): Add comment explaining "exception when others ! => null". Add clarifying ".all", even though implicit .all is legal ! here. ! ! 2008-05-20 Arnaud Charlet ! ! * s-winext.ads: Replace representation clause by pragma Pack. Gives ! equivalent representation, but has the advantage of allowing ! compilation of this file under 64 bits platforms. ! ! * s-os_lib.adb (Normalize_Pathname): Mark Cur_Dir constant. ! ! * s-osinte-irix.ads: (Alternate_Stack_Size): Add dummy declaration. ! ! * adaint.c: ! Don't define dummy implementation of convert_addresses on ppc-linux. ! ! 2008-05-20 Ed Schonberg ! ! * exp_ch7.adb ! (Expand_Ctrl_Function_Call): Do not attach result to finalization list ! if expression is aggregate component. ! ! 2008-05-20 Robert Dewar ! ! * g-byorma.adb, gnatlink.adb, prepcomp.adb, sinfo.ads, ! sem_ch12.adb: Update comments. Minor reformatting. ! ! * exp_ch2.adb: Typo ! ! * s-unstyp.ads: Fixed some typos in comments. ! ! 2008-05-20 Arnaud Charlet ! ! * s-taspri-vxworks.ads (Task_Address, Task_Address_Size): New ! type/constant. ! ! * g-socthi-vxworks.ads: Update to latest socket changes. ! ! * a-caldel-vms.adb: Resync with a-caldel spec. ! ! * exp_ch9.ads, sem_ch8.ads, inline.adb: Minor reformatting. ! Update comments. 2008-05-17 Eric Botcazou *************** *** 90,95 **** --- 5559,5573 ---- of records and unions. (gnat_to_gnu) : Fix formatting. + 2008-05-14 Samuel Tardieu + Robert Dewar + + * sem_attr.adb (Analyze_Attribute, Attribute_Old case): Add + restrictions to the prefix of 'Old. + * sem_util.ads, sem_util.adb (In_Parameter_Specification): New. + * gnat_rm.texi ('Old): Note that 'Old cannot be applied to local + variables. + 2008-05-13 Eric Botcazou PR ada/24880 *************** *** 98,122 **** expression to an integral type with lower precision, use NOP_EXPR directly in a couple of special cases. ! 2008-04-09 Eric Botcazou * decl.c (is_variable_size): Do not unconditionally return false on non-strict alignment platforms. 2008-04-01 John David Anglin PR ada/33857 * env.c: Always include crt_externs.h if __APPLE__ is defined. (__gnat_setenv): Use setenv instead of putenv if __APPLE__ is defined. 2008-03-31 Eric Botcazou * decl.c (gnat_to_gnu_entity) : Do not force a non-null size if it has overflowed. ! 2008-03-05 Release Manager ! * GCC 4.3.0 released. 2008-02-17 Ralf Wildenhues --- 5576,8599 ---- expression to an integral type with lower precision, use NOP_EXPR directly in a couple of special cases. ! 2008-05-12 Samuel Tardieu ! Ed Schonberg ! ! * sem_ch3.adb (Build_Derived_Record_Type): Accept statically matching ! constraint expressions. ! ! 2008-05-12 Tomas Bily ! ! * utils2.c (known_alignment, contains_save_expr_p) ! (gnat_mark_addressable): Use CASE_CONVERT. ! * decl.c (annotate_value): Likewise. ! * trans.c (maybe_stabilize_reference): Likewise. ! * utils2.c (build_binary_op): Use CONVERT_EXPR_P. ! * utils.c (rest_of_record_type_compilation): Likewise. ! * trans.c (protect_multiple_eval, Attribute_to_gnu) ! (protect_multiple_eval): Likewise. ! ! 2008-05-08 Andreas Schwab ! ! * utils.c (handle_pure_attribute, init_gigi_decls): Rename ! DECL_IS_PURE to DECL_PURE_P. ! ! 2008-05-05 Eric Botcazou ! ! * decl.c (maybe_pad_type): Add ??? comment. ! ! 2008-05-03 Eric Botcazou ! ! * decl.c (components_to_record): Zero the alignment of the qualified ! union built for the variant part upon creating it. ! ! 2008-05-03 Eric Botcazou ! ! * decl.c (maybe_pad_type): Try to get a form of the type with integral ! mode even if the alignment is not a factor of the original size. But ! make sure to create the inner field with the original size. Reorder. ! * trans.c (addressable_p) : Treat the field of a padding ! record as always addressable. ! * utils.c (convert): Deal specially with conversions between original ! and packable versions of a record type. ! * utils2.c (build_binary_op) : Be more restrictive when ! recognizing an assignment between padded objects. ! ! 2008-05-01 Eric Botcazou ! ! * decl.c (make_packable_type): Resize the last component to its RM size ! only if it is of an aggregate type. ! * trans.c (call_to_gnu): Fix nit in comment. ! (gnat_to_gnu): Likewise. ! ! 2008-04-30 Samuel Tardieu ! ! * Makefile.in: Adapt sh4-linux target. ! ! 2008-04-29 Ed Schonberg ! ! PR ada/35792 ! * sem_ch3.adb (Find_Type_Name): Refuse completion of an incomplete ! tagged type by an untagged protected or task type. ! ! 2008-04-28 Eric Botcazou ! Tristan Gingold ! ! PR ada/36007 ! * decl.c (gnat_to_gnu_entity) : Do not promote alignment ! of aliased objects with an unconstrained nominal subtype. ! Cap the promotion to the effective alignment of the word mode. ! ! 2008-04-28 Ralf Wildenhues ! ! * Make-lang.in (ada.tags, check-acats, ada/treeprs.ads) ! (ada/einfo.h, ada/sinfo.h, ada/nmake.adb, ada/nmake.ads): ! Use '&&' instead of ';'. ! ! 2008-04-24 Olivier Hainque ! ! * trans.c (Attribute_to_gnu) : Length computation ! doesn't require signed arithmetic anymore. ! ! 2008-04-23 Paolo Bonzini ! ! * trans.c (Attribute_to_gnu): Don't set TREE_INVARIANT. ! (call_to_gnu): Don't set TREE_INVARIANT. ! * utils2.c (gnat_build_constructor): Don't set TREE_INVARIANT. ! ! 2008-04-22 Joel Sherrill ! ! * s-osinte-rtems.adb: Add sigalstack function. ! * s-osinte-rtems.ads: Add SO_ONSTACK and sigalstack ! function. Add Alternate_Stack and Alternate_Stack_Size. ! Add missing process_shared field to pthread_condattr_t ! and change ss_low_priority to int from timespec. ! ! 2008-04-22 Samuel Tardieu ! ! * i-forbla.adb: Link against -llapack and -lblas by default ! instead of the private -lgnalasup. ! ! 2008-04-21 Olivier Hainque ! ! Access to most C builtins from Ada ! * utils.c: #include "langhooks.h" and define GCC_DIAG_STYLE. ! (handle_pure_attribute, handle_novops_attribute, ! handle_nonnull_attribute, handle_sentinel_attribute, ! handle_noreturn_attribute, handle_malloc_attribute, ! handle_type_generic_attribute): New attribute handlers, from C fe. ! (gnat_internal_attribute_table): Map the new handlers. ! (gnat_init_decl_processing): Move call to gnat_install_builtins to ... ! (init_gigi_decls): ... here. ! (handle_const_attribute, handle_nothrow_attribute, builtin_decl_for): ! Move to a section dedicated to builtins processing. ! (build_void_list_node, builtin_type_for_size): New functions. ! (def_fn_type, get_nonnull_operand): Likewise. ! (install_builtin_elementary_type, install_builtin_function_types, ! install_builtin_attributes): Likewise. ! (fake_attribute_handler): Fake handler for attributes we don't ! support in Ada. ! (def_builtin_1): New function, worker for DEF_BUILTIN. ! (install_builtin_functions): New function. ! (gnat_install_builtins): Move to the builtins processing section. ! Now calling the newly introduced installers. ! ! 2008-04-20 Eric Botcazou ! ! * decl.c (gnat_to_gnu_entity) : Also promote the alignment of ! constant objects, but not exceptions. ! * trans.c (add_decl_expr): Use gnat_types_compatible_p for type ! compatibility test. ! * utils.c (create_var_decl_1): Likewise. ! * utils2.c (build_binary_op) : Also use the padded view of ! the type when copying to padded object and the source is a constructor. ! ! 2008-04-18 Eric Botcazou ! ! * decl.c (gnat_to_gnu_entity) : When trying to promote the ! alignment, reset it to zero if it would end up not being greater ! than that of the type. ! ! 2008-04-18 Eric Botcazou ! ! * decl.c (maybe_pad_type): Only generate the XVS parallel type if ! the padded type has a variable size. ! ! 2008-04-18 Eric Botcazou ! ! * decl.c (gnat_to_gnu_entity) : Use the return by ! target pointer mechanism as soon as the size is not constant. ! ! 2008-04-18 Eric Botcazou ! ! * gigi.h (create_var_decl_1): Declare. ! (create_var_decl): Turn into a macro invoking create_var_decl_1. ! (create_true_var_decl): Likewise. ! * utils.c (create_var_decl_1): Make global and reorder parameters. ! (create_var_decl): Delete. ! (create_true_var_decl): Likewise. ! ! 2008-04-17 Eric Botcazou ! ! * decl.c (gnat_to_gnu_entity) : Promote the alignment of ! objects by default. ! * fe.h (Debug_Flag_Dot_A): Delete. ! * debug.adb (-gnatd.a): Update documentation. ! ! 2008-04-17 Samuel Tardieu ! ! * g-socket.ads, g-socket.adb (Get_Address): Make Stream a ! "not null" parameter. ! ! 2008-04-17 Samuel Tardieu ! ! * g-socket.adb: Add a message "IPv6 not supported" to the ! Socket_Error exception. ! ! 2008-04-16 Samuel Tardieu ! ! PR ada/29015 ! * sem_ch12.adb (Instantiate_Type): Check whether the full view of ! the type is known instead of the underlying type. ! ! 2008-04-15 Ed Schonberg ! ! PR ada/22387 ! * exp_ch5.adb (Expand_Assign_Record): Within an initialization ! procedure for a derived type retrieve the discriminant values from ! the parent using the corresponding discriminant. ! ! 2008-04-15 Samuel Tardieu ! Gary Dismukes ! ! PR ada/28733 ! * sem_ch8.adb (Analyze_Use_Package): Do not allow "use" of something ! which is not an entity (and hence not a package). ! (End_Use_Package): Ditto. ! ! 2008-04-15 Ed Schonberg ! ! PR ada/16086 ! * sem_ch12.adb (Analyze_Formal_Subprogram): The default can be any ! protected operation that matches the signature, not only an entry, a ! regular subprogram or a literal. ! ! 2008-04-15 Eric Botcazou ! ! * ada-tree.h (DECL_BY_COMPONENT_PTR_P): Use DECL_LANG_FLAG_3. ! * decl.c (gnat_to_gnu_entity) : Call maybe_pad_type only ! if a size or alignment is specified. Do not take into account ! alignment promotions for the computation of the object's size. ! : Call maybe_pad_type only if a size or alignment is specified. ! (maybe_pad_type): Really reuse the RM_Size of the original type if ! requested. ! * trans.c (Attribute_to_gnu): Fix a couple of nits. ! * utils2.c (build_binary_op) : Merge related conditional ! statements. Use the padded view of the type when copying between ! padded objects of the same underlying type. ! ! 2008-04-14 Ralf Wildenhues ! ! * vms_data.ads: Fix typo in constant. ! * gen-soccon.c: Fix typo in error string. ! * gnat_rm.texi (Pragma Optimize_Alignment, Pragma Postcondition): ! Fix typos. ! * a-calcon.ads, a-calend-vms.adb, a-calend.adb, a-crdlli.ads, ! bcheck.adb, checks.adb, einfo.ads, errout.adb, erroutc.adb, ! erroutc.ads, exp_attr.adb, exp_ch11.adb, exp_ch2.adb, ! exp_ch5.adb, exp_ch9.adb, exp_ch9.ads, exp_pakd.adb, ! exp_util.adb, fmap.adb, g-soccon-linux-mips.ads, ! g-soccon-rtems.ads, g-timsta.adb, g-timsta.ads, lib-writ.ads, ! mlib-tgt-specific-linux.adb, mlib-tgt-specific-tru64.adb, ! s-interr-vxworks.adb, s-interr.adb, s-osinte-lynxos.ads, ! s-rident.ads, s-taprop-solaris.adb, s-tassta.adb, s-win32.ads, ! sem_aggr.adb, sem_attr.ads, sem_ch10.adb, sem_ch13.ads, ! sem_ch3.adb, sem_ch6.adb, sem_ch7.adb, sem_ch8.adb, sem_ch9.adb, ! sem_prag.ads, sem_res.adb, sem_util.adb, sem_util.ads, ! sinfo.ads: Fix typos in comments. ! ! 2008-04-14 Robert Dewar ! ! * sem_prag.adb (Analyze_Pragma, Linker_Section case): Extend error ! to every non-object and change error message. ! ! 2008-04-14 Robert Dewar ! ! * sem_util.ads, sem_util.adb (In_Subprogram): Remove. ! * sem_attr.adb (Anayze_Attribute): Check for Current_Subprogram ! directly. ! ! 2008-04-14 Samuel Tardieu ! ! PR ada/18680 ! * sem_prag.adb (Analyze_Pragma, Linker_Section case): Refuse to ! apply pragma Linker_Section on type. ! ! 2008-04-14 Samuel Tardieu ! ! PR ada/16098 ! * sem_prag.adb (Error_Pragma_Ref): New. ! (Process_Convention): Specialized message for non-local ! subprogram renaming. Detect the problem in homonyms as well. ! ! 2008-04-14 Samuel Tardieu ! ! PR ada/15915 ! * sem_util.ads, sem_util.adb (Denotes_Variable): New function. ! * sem_ch12.adb (Instantiate_Object): Use it. ! * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Ensure that ! storage pool denotes a variable as per RM 13.11(15). ! ! 2008-04-14 Samuel Tardieu ! ! * sem_util.ads, sem_util.adb (In_Subprogram): New function. ! * sem_attr.adb (Analyze_Attribute, Attribute_Old case): Use it. ! ! 2008-04-14 Rolf Ebert ! ! PR ada/20822 ! * xgnatugn.adb (Put_Line): New procedure, ensuring Unix ! line endings even on non-Unix platforms. ! ! 2008-04-14 Samuel Tardieu ! ! PR ada/35050 ! * xref_lib.adb (Parse_Identifier_Info): Correctly parse and ignore the ! renaming information. ! ! 2008-04-13 Samuel Tardieu ! ! PR ada/17985 ! * sem_aggr.adb (Valid_Ancestor_Type): A type is not an ancestor of ! itself. ! ! 2008-04-13 Ralf Wildenhues ! ! * sfn_scan.adb, sfn_scan.ads, sinfo.ads, ! sinput-d.ads, sinput-l.adb, sinput-l.ads, sinput.ads, ! snames.ads, sprint.adb, stand.ads, stringt.ads, ! styleg.adb, styleg.ads, stylesw.adb, stylesw.ads, ! switch.ads, sysdep.c, table.adb, table.ads, ! targparm.ads, tb-gcc.c, tbuild.ads, tracebak.c, ! trans.c, tree_io.adb, treepr.adb, types.adb, types.ads, ! uintp.adb, uintp.ads, utils.c, utils2.c, validsw.ads, ! vms_conv.adb, vms_conv.ads, vms_data.ads, widechar.adb, ! widechar.ads, xeinfo.adb, xgnatugn.adb, xr_tabls.adb, ! xr_tabls.ads, xref_lib.adb, xref_lib.ads, xsinfo.adb: ! Fix comment typos. ! ! * sem_ch10.adb, sem_ch10.ads, ! sem_ch12.adb, sem_ch12.ads, sem_ch13.adb, sem_ch13.ads, ! sem_ch3.adb, sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, ! sem_ch6.ads, sem_ch8.adb, sem_ch8.ads, sem_ch9.adb, ! sem_elab.adb, sem_elab.ads, sem_elim.ads, sem_eval.adb, ! sem_eval.ads, sem_intr.adb, sem_mech.adb, sem_mech.ads, ! sem_prag.adb, sem_prag.ads, sem_res.adb, sem_res.ads, ! sem_type.adb, sem_util.adb, sem_util.ads, sem_warn.adb, ! sem_warn.ads: Fix comment typos. ! ! * s-secsta.adb, s-sequio.ads, s-shasto.ads, ! s-soflin.ads, s-stalib.ads, s-stausa.adb, ! s-stausa.ads, s-strxdr.adb, s-taenca.adb, s-taenca.ads, ! s-taprob.adb, s-taprop-hpux-dce.adb, s-taprop-irix.adb, ! s-taprop-linux.adb, s-taprop-mingw.adb, s-taprop-posix.adb, ! s-taprop-solaris.adb, s-taprop-tru64.adb, s-taprop-vms.adb, ! s-taprop-vxworks.adb, s-taprop.ads, s-tarest.adb, ! s-tarest.ads, s-tasini.adb, s-tasini.ads, s-taskin.ads, ! s-tasque.ads, s-tassta.adb, s-tassta.ads, s-tasuti.ads, ! s-tpoben.adb, s-tpoben.ads, s-tpobop.adb, ! s-tpopsp-posix.adb, s-tpopsp-rtems.adb, s-tposen.adb, ! s-tposen.ads, s-traceb-hpux.adb, s-traces.ads, ! s-trafor-default.ads, s-unstyp.ads, s-utf_32.ads, ! s-vaflop.adb, s-vaflop.ads, s-valrea.adb, s-valuti.adb, ! s-wchstw.ads, s-wchwts.adb, s-wchwts.ads, scans.ads, ! scn.adb, scng.adb, seh_init.c, sem.ads, sem_aggr.adb, ! sem_attr.adb, sem_attr.ads, sem_case.adb, sem_case.ads, ! sem_cat.adb, sem_cat.ads: Fix comment typos. ! ! 2008-04-12 Joel Sherrill ! ! PR ada/35825 ! * g-soccon-rtems.ads: Add IP_PKTINFO as unsupported. ! ! 2008-04-12 Arnaud Charlet ! ! * s-linux-hppa.ads: Fix syntax errors. ! ! 2008-04-10 Ralf Wildenhues ! ! * gnat_ugn.texi: Fix typos. ! * raise-gcc.c, repinfo.adb, repinfo.ads, restrict.adb, ! restrict.ads, rtsfind.adb, rtsfind.ads, s-arit64.ads, ! s-asthan-vms-alpha.adb, s-auxdec.ads, s-casuti.ads, ! s-fatflt.ads, s-fatgen.adb, s-fatlfl.ads, ! s-fatllf.ads, s-fatsfl.ads, s-filofl.ads, ! s-finimp.adb, s-finroo.ads, s-fishfl.ads, ! s-fvadfl.ads, s-fvaffl.ads, s-fvagfl.ads, ! s-hibaen.ads, s-htable.ads, s-imgcha.adb, ! s-imgenu.ads, s-imgint.adb, s-imgrea.adb, ! s-inmaop-dummy.adb, s-inmaop.ads, s-interr-vms.adb, ! s-interr-vxworks.adb, s-interr.adb, s-interr.ads, ! s-intman-vxworks.ads, s-intman.ads, s-mastop-irix.adb, ! s-os_lib.adb, s-os_lib.ads, s-osinte-aix.ads, ! s-osinte-darwin.ads, s-osinte-freebsd.ads, ! s-osinte-hpux.ads, s-osinte-lynxos-3.adb, ! s-osinte-lynxos-3.ads, s-osinte-lynxos.ads, ! s-osinte-rtems.ads, s-osinte-solaris-posix.ads, ! s-osprim-mingw.adb, s-osprim-vms.adb, s-parame-ae653.ads, ! s-parame-hpux.ads, s-parame-vms-alpha.ads, ! s-parame-vms-ia64.ads, s-parame-vms-restrict.ads, ! s-parame-vxworks.ads, s-parame.ads, s-parint.adb, ! s-parint.ads, s-poosiz.adb, s-proinf-irix-athread.ads, ! s-proinf.ads, s-regexp.adb, s-regpat.adb, s-regpat.ads, ! s-rident.ads: Fix comment typos. ! ! 2008-04-09 Samuel Tardieu ! ! PR ada/28305 ! * sem_ch6.adb (Build_Body_To_Inline): Do not save and restore ! environment if generic instance is a top-level one. ! ! 2008-04-09 Doug Rupp ! ! * decl.c (validate_size): Set minimum size for fat pointers same as ! access types. Code clean ups. ! ! * gmem.c (xstrdup32): New macro for 32bit dup on VMS, noop otherwise ! (__gnat_gmem_a2l_initialize): Dup exename into 32 bit memory on VMS ! ! * s-auxdec-vms_64.ads, s-auxdec.ads (Short_Address_Size): New constant ! ! * s-crtl.ads (malloc32) New function, alias for malloc ! (realloc32) New function, alias for realloc ! ! * socket.c (__gnat_new_socket_set): Malloc fd_set in 32 bits on VMS ! ! * utils2.c (build_call_alloc_dealloc): Return call to short malloc if ! allocator size is 32 and default pointer size is 64. ! (find_common_type): Document assumption on t1/t2 vs lhs/rhs. Force use of ! lhs type if smaller, whatever the modes. ! ! * gigi.h (malloc32_decl): New macro definition ! ! * utils.c (init_gigi_decls): New malloc32_decl ! Various code clean ups. ! ! * s-asthan-vms-alpha.adb (Process_AST.To_Address): Unchecked convert to ! Task_Address vice System.Address. ! ! * s-taspri-vms.ads: Import System.Aux_DEC ! (Task_Address): New subtype of System.Aux_DEC.Short_Address ! (Task_Address_Size): New constant size of System.Aux_DEC.Short_Address ! ! * s-asthan-vms-alpha.adb (Process_AST.To_Address): Unchecked convert to ! Task_Address vice System.Address. ! ! * s-inmaop-vms.adb: Import System.Task_Primitives ! (To_Address): Unchecked convert to Task_Address vice System.Address ! ! * s-taprop-vms.adb (Timed_Delay): Always set the timer even if delay ! expires now. ! (To_Task_ID) Unchecked convert from Task_Adddress vice System.Address ! (To_Address) Unchecked convert to Task_Address vice System.Address ! ! * s-tpopde-vms.adb: Remove unnecessary warning pragmas ! ! * g-socthi-vms.ads: Add 32bit size clauses on socket access types. ! ! 2008-04-08 Eric Botcazou ! ! * gigi.h (standard_datatypes): Add ADT_fdesc_type and ADT_null_fdesc. ! (fdesc_type_node): Define. ! (null_fdesc_node): Likewise. ! * decl.c (gnat_to_gnu_entity) : If the target ! uses descriptors for vtables and the type comes from a dispatch table, ! return the descriptor type. ! * trans.c (Attribute_to_gnu) : If the target ! uses descriptors for vtables and the type comes from a dispatch table, ! build a descriptor in the static case and copy the existing one in the ! non-static case. ! (gnat_to_gnu) : If the target uses descriptors for vtables and ! the type is a pointer-to-subprogram coming from a dispatch table, ! return the null descriptor. ! : If the target uses descriptors for ! vtables, the source type is the descriptor type and the target type ! is a pointer type, first build the pointer. ! * utils.c (init_gigi_decls): If the target uses descriptors for vtables ! build the descriptor type and the null descriptor. ! ! 2008-04-08 Eric Botcazou ! ! * decl.c (prepend_attributes): Fix typo. ! * trans.c (Pragma_to_gnu): Likewise. ! * utils.c (gnat_genericize): Likewise. ! ! 2008-04-08 Eric Botcazou ! Richard Kenner ! ! * ada-tree.h (TYPE_PACKED_ARRAY_TYPE_P): Only set it when bit-packed. ! * decl.c (gnat_to_gnu_entity): Adjust for above change. ! : Try to get a better form of the component for ! packing, even if it has an integral mode. ! : Likewise. ! * trans.c (gnat_to_gnu): Do not require BLKmode for the special ! exception suppressing the final conversion between record types. ! ! 2008-04-08 Eric Botcazou ! ! * decl.c (gnat_to_gnu_entity) : If -gnatd.a and not optimizing ! alignment for space, promote the alignment of non-scalar variables with ! no size and alignment. ! * gigi.h (gnat_types_compatible_p): Declare. ! * misc.c (LANG_HOOKS_TYPES_COMPATIBLE_P): Set to above predicate. ! * trans.c (gnat_to_gnu): Revert revision 129339 change. Minor cleanup. ! * utils.c (gnat_types_compatible_p) : New predicate. ! (convert): Use it throughout to test for cases where a mere view ! conversion is sufficient. ! * utils2.c (build_binary_op): Minor tweaks. ! (build_unary_op): Likewise. ! ! 2008-04-08 Eric Botcazou ! ! * decl.c (adjust_packed): Expand comment. ! ! 2008-04-08 Arnaud Charlet ! ! * s-tasuti.ads: Use Task_Address instead of System.Address. ! ! * makeutl.adb (Path_Or_File_Name): New function ! ! * nlists.ads, itypes.ads: Update comments. ! ! * s-crtl.ads (malloc32, realloc32): New functions. ! ! * s-auxdec.ads (Short_Address_Size): New constant. ! ! * a-taside.adb, s-tasdeb.adb: Use Task_Address. ! ! * s-ststop.ads, s-ststop.adb: New file. ! ! * exp_tss.ads, s-taprop-lynxos.adb: Update comments. ! Minor reformatting. ! ! 2008-04-08 Pascal Obry ! ! * g-sercom.ads, g-sercom.adb (Data_Rate): Add B115200. ! (Stop_Bits_Number): New type. ! (Parity_Check): Likewise. ! (Set): Add parameter to set the number of stop bits and ! the parity. Parameter timeout is now a duration instead ! of a plain integer. ! ! * g-sercom-linux.adb: ! Implement the stop bits and parity support for GNU/Linux. ! Fix handling of timeout, it must be given in tenth of seconds. ! ! * g-sercom-mingw.adb: ! Implement the stop bits and parity support for Windows. ! Use new s-win32.ads unit instead of declaring Win32 services ! directly into this body. ! Update handling of timeout as now a duration. ! ! * s-win32.ads, s-winext.ads: New files. ! ! 2008-04-08 Eric Botcazou ! Arnaud Charlet ! ! * s-osinte-linux-alpha.ads, s-osinte-linux-hppa.ads: Removed. ! ! s-taspri-posix-noaltstack.ads, s-linux.ads, s-linux-alpha.ads, ! s-linux-hppa.ads: New files. Disable alternate stack on ia64-hpux. ! ! * s-osinte-lynxos-3.ads, ! (Alternate_Stack): Remove when not needed. Simplify declaration ! otherwise. ! (Alternate_Stack_Size): New constant. ! ! s-osinte-mingw.ads, s-taprop-mingw.adb: Code clean up: avoid use of ! 'Unrestricted_Access. ! ! * s-osinte-hpux.ads, s-osinte-solaris-posix.ads, s-osinte-aix.ads, ! s-osinte-lynxos.ads, s-osinte-freebsd.ads s-osinte-darwin.ads, ! s-osinte-tru64.ads, s-osinte-irix.ads, s-osinte-linux.ads, ! s-osinte-solaris.ads, s-osinte-vms.ads ! (SA_ONSTACK): New constant. ! (stack_t): New record type. ! (sigaltstack): New imported function. ! (Alternate_Stack): New imported variable. ! (Alternate_Stack_Size): New constant. ! ! * system-linux-x86_64.ads: (Stack_Check_Probes): Set to True. ! ! * s-taspri-lynxos.ads, s-taspri-solaris.ads, s-taspri-tru64.ads, ! s-taspri-hpux-dce.ads, s-taspri-dummy.ads, s-taspri-posix.ads, ! s-taspri-vms.ads (Task_Address): New subtype of System.Address ! (Task_Address_Size): New constant size of System.Address ! (Alternate_Stack_Size): New constant. ! ! * s-taprop-posix.adb, s-taprop-linux.adb (Get_Stack_Attributes): Delete. ! (Enter_Task): Do not notify stack to System.Stack_Checking.Operations. ! Establish the alternate stack if the platform makes use of n alternate ! signal stack for stack overflows. ! (Create_Task): Take into account the alternate stack in the stack size. ! (Initialize): Save the address of the alternate stack into the ATCB for ! the environment task. ! (Create_Task): Fix assertions for NPTL library (vs old LinuxThreads). ! ! * s-parame.adb (Minimum_Stack_Size): Increase value to 16K ! ! * system-linux-x86.ads: (Stack_Check_Probes): Set to True. ! ! * s-intman-posix.adb: ! (Initialize): Set SA_ONSTACK for SIGSEGV if the platform makes use of an ! alternate signal stack for stack overflows. ! ! * init.c (__gnat_adjust_context_for_raise, Linux version): On i386 and ! x86-64, adjust the saved value of the stack pointer if the signal was ! raised by a stack checking probe. ! (HP-UX section): Use global __gnat_alternate_stack as signal handler ! stack and only for SIGSEGV. ! (Linux section): Likewise on x86 and x86-64. ! [VxWorks section] ! (__gnat_map_signal): Now static. ! (__gnat_error_handler): Not static any more. ! (__gnat_adjust_context_for_raise): New function. Signal context ! adjustment for PPC && !VTHREADS && !RTP, as required by the zcx ! propagation circuitry. ! (__gnat_error_handler): Second argument of a sigaction handler is a ! pointer, not an int, and is unused. ! Adjust signal context before mapping to exception. ! Install signal handlers for LynxOS case. ! ! * s-taskin.ads (Common_ATCB): New field Task_Alternate_Stack. ! (Task_Id): Set size to Task_Address_Size ! (To_Task_id): Unchecked convert from Task_Address vice System.Address ! (To_Address): Unchecked convert to Task_Address vice System.Address ! ! * s-tassta.adb (Task_Wrapper): Define the alternate stack and save its ! address into the ATCB if the platform makes use of an alternate signal ! stack for stack overflows. ! (Free_Task): Add call to Finalize_Attributes_Link. ! Add argument Relative_Deadline to pass the value specified for ! the task. This is not yet used for any target. ! ! * s-tassta.ads (Create_Task): Add argument Relative_Deadline to pass ! the value specified for the task. ! ! 2008-04-08 Arnaud Charlet ! ! (s-osinte-vxworks6.ads): Removed, merged with s-osinte-vxworks.ads/.adb ! (s-vxwext.ads, s-vxwext-kernel.ads, s-vxwext-rtp.ads, ! s-vxwext-rtp.adb): New files. ! ! * s-taprop-vxworks.adb, s-osinte-vxworks.ads, s-osinte-vxworks.adb: ! Minor updates to accomodate changes above. ! ! 2008-04-08 Pascal Obry ! ! * a-exetim-mingw.adb, s-gloloc-mingw.adb, s-taprop-mingw.adb, ! s-tasinf-mingw.ad{s,b}, s-taspri-mingw.ads: ! Use new s-win32.ads unit instead of declaration ! from s-osinte-mingw.ads. ! ! * s-osinte-mingw.ads: ! Move all non tasking based interface to s-win32.ads. ! ! * s-osprim-mingw.adb: ! Remove duplicated declarations and use s-win32.ads ! unit instead. ! ! 2008-04-08 Vincent Celier ! Arnaud Charlet ! ! * mlib-tgt-aix.adb, mlib-tgt-darwin.adb, mlib-tgt-hpux.adb, ! mlib-tgt-irix.adb, mlib-tgt-linux.adb, mlib-tgt-lynxos.adb, ! mlib-tgt-solaris.adb, mlib-tgt-tru64.adb, mlib-tgt-vms.adb, ! mlib-tgt-vms.ads, mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, ! mlib-tgt-vxworks.adb, mlib-tgt-mingw.adb: Renamed into... ! ! * mlib-tgt-specific-aix.adb, mlib-tgt-specific-darwin.adb, ! mlib-tgt-specific-hpux.adb, mlib-tgt-specific-irix.adb, ! mlib-tgt-specific-linux.adb, mlib-tgt-specific-lynxos.adb, ! mlib-tgt-specific-solaris.adb, mlib-tgt-specific-tru64.adb, ! mlib-tgt-vms_common.adb, mlib-tgt-vms_common.ads, ! mlib-tgt-specific-vms-alpha.adb, mlib-tgt-specific-vms-ia64.adb, ! mlib-tgt-specific-vxworks.adb, mlib-tgt-specific-xi.adb, ! mlib-tgt-specific-mingw.adb: New names. ! ! * Makefile.in: ! On VxWorks platforms use s-stchop-limit.ads for s-stchop.ads ! Get rid of gnatbl. ! (EXTRA_GNATRTL_NONTASKING_OBJS): Add s-win32.o ! Files mlib-tgt-*.adb have been renamed mlib-tgt-specific-*.adb ! Minor updates for VMS ! ! * gnatbl.c: Removed. ! ! 2008-04-08 Thomas Quinot ! ! * g-expect-vms.adb, a-textio.adb, a-witeio.adb, exp_dbug.adb, ! g-expect.adb, g-locfil.adb, gnatchop.adb, gnatdll.adb, gnatlbr.adb, ! gnatmem.adb, g-regist.adb, i-vxwork.ads, mlib-utl.adb, i-vxwork-x86.ads, ! a-ztexio.adb, g-enblsp-vms-alpha.adb, g-enblsp-vms-ia64.adb, ! s-os_lib.adb, s-regpat.adb, s-regpat.ads: Fix incorrect casing of ! ASCII.NUL throughout. ! ! 2008-04-08 Arnaud Charlet ! Matthew Heaney ! ! * a-cgcaso.adb, a-convec.adb: (Swap, Sift): Avoid use of complex ! renaming. ! ! * a-cgaaso.ads, a-secain.ads, a-slcain.ads, a-shcain.ads, ! a-crdlli.ads, a-coormu.ads, a-ciormu.ads: modified header to conform ! to convention for non-RM specs. ! Add descriptive header, and documented each operation ! document each operation ! ! 2008-04-08 Robert Dewar ! Bob Duff ! Gary Dismukes ! Ed Schonberg ! ! * alloc.ads: Add entries for Obsolescent_Warnings table ! ! * einfo.ads, einfo.adb: Minor reformatting. ! (Is_Discriminal): New subprogram. ! (Is_Prival): New subprogram. ! (Is_Protected_Component): New subprogram. ! (Is_Protected_Private): Removed. ! (Object_Ref, Set_Object_Ref): Removed. ! (Prival, Set_Prival): Change assertion. ! (Privals_Chain, Set_Privals_Chain): Removed. ! (Prival_Link, Set_Prival_Link): New subprogram. ! (Protected_Operation, Set_Protected_Operation): Removed. ! (Protection_Object, Set_Protection_Object): New subprogram. ! (Write_Field17_Name): Remove case for Object_Ref. ! (Write_Field20_Name): Add case for Prival_Link. ! (Write_Field22_Name): Remove case for Protected_Operation, ! Privals_Chain. ! Add case for Protection_Object. ! (Can_Use_Internal_Rep): Make this into a [base type only] attribute, ! so clients ! (Overlays_Constant): New flag ! (Is_Constant_Object): New predicate ! (Is_Standard_Character_Type): New predicate ! (Optimize_Alignment_Space): New flag ! (Optimize_Alignment_Time): New flag ! (Has_Postconditions): New flag ! (Obsolescent_Warrning): Field removed ! (Spec_PPC_List): New field ! (Relative_Deadline_Variable, Set_Relative_Deadline_Variable): Add ! subprograms to get and set the relative deadline associated to a task. ! ! * exp_attr.adb (May_Be_External_Call): Account for the case where the ! Access attribute is part of a named parameter association. ! (Expand_Access_To_Protected_Op): Test for the attribute occurring ! within an init proc and use that directly as the scope rather than ! traversing up to the protected operation's enclosing scope. Only apply ! assertion on Is_Open_Scopes in the case the scope traversal is done. ! For the init proc case use the address of the first formal (_init) as ! the protected object reference. ! Implement Invalid_Value attribute ! (Expand_N_Attribute_Reference): Case Attribute_Unrestricted_Access. ! contents of the dispatch table there is no need to duplicate the ! itypes associated with record types (i.e. the implicit full view ! of private types). ! Implement Enum_Val attribute ! (Expand_N_Attribute_Reference, case Old): Properly handle appearence ! within _Postconditions procedure ! (Expand_N_Attribute_Reference, case Result): Implement new attribute ! ! * exp_ch5.adb (Expand_N_Simple_Return_Statement): Handle case in which ! a return statement calls a function that is not available in ! configurable runtime. ! (Analyze_If_Statement): don't optimize simple True/False cases in -O0 ! (Expand_Non_Function_Return): Generate call to _Postconditions proc ! (Expand_Simple_Function_Return): Ditto ! ! * frontend.adb: Add call to Sem_Aux.Initialize ! ! * sem_aux.ads, sem_aux.adb: New file. ! ! * par-prag.adb: Add entries for pragmas Precondition/Postcondition ! Add new Pragma_Relative_Deadline. ! Add support for pragmas Check and Check_Policy ! ! * sem_attr.ads, sem_attr.adb (Check_Not_CPP_Type): New subprogram. ! (Check_Stream_Attribute): Add missing check (not allowed in CPP types) ! (Analyze_Attribute): In case of attributes 'Alignment and 'size add ! missing check because they are not allowed in CPP tagged types. ! Add Sure parameter to Note_Possible_Modification calls ! Add implementation of Invalid_Value attribute ! Implement new attribute Has_Tagged_Values ! Implement Enum_Val attribute ! (Analyze_Attribute, case Range): Set Name_Req True for prefix of ! generated attributes. ! (Analyze_Attribute, case Result): If prefix of the attribute is ! overloaded, it always resolves to the enclosing function. ! (Analyze_Attribute, case Result): Properly deal with analysis when ! Postconditions are not active. ! (Resolve_Attribute, case Result): Properly deal with appearence during ! preanalysis in spec. ! Add processing for attribute Result ! ! * sem_ch6.ads, sem_ch6.adb (Check_Overriding_Indicator): Code cleanup ! for operators. ! (Analyze_Subprogram_Body): Install private_with_clauses when the body ! acts as a spec. ! (Check_Inline_Pragma): recognize an inline pragma that appears within ! the subprogram body to which it applies. ! (Analyze_Function_Return): Check that type of the expression of a return ! statement in a function with a class-wide result is not declared at a ! deeper level than the function. ! (Process_PPCs): Deal with enabling/disabling, using PPC_Enabled flag ! (Verify_Overriding_Indicator): Handle properly subprogram bodies for ! user- defined operators. ! (Install_Formals): Moved to spec to allow use from Sem_Prag for ! analysis of precondition/postcondition pragmas. ! (Analyze_Subprogram_Body.Last_Real_Spec_Entity): New name for ! Last_Formal, along with lots of comments on what this is about ! (Analyze_Subprogram_Body): Fix case where we move entities from the ! spec to the body when there are no body entities (now possible with ! precondition and postcondition pragmas). ! (Process_PPCs): New procedure ! (Analyze_Subprogram_Body): Add call to Process_PPCs ! ! * sem_ch8.adb (Use_One_Type): refine warning on a redundant use_type ! clause. ! (Pop_Scope): Restore Check_Policy_List on scope exit ! (Push_Scope): Save Check_Policy_List on scope entry ! Change name In_Default_Expression => In_Spec_Expression ! Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression ! Change name Pre_Analyze_And_Resolve => Preanalyze_And_Resolve ! (Analyze_Object_Renaming): Allow 'Reference as object ! (Analyze_Pragma, case Restriction_Warnings): Call GNAT_Pragma ! (Process_Restrictions_Or_Restriction_Warnings): Check for bad spelling ! of restriction identifier. ! Add Sure parameter to Note_Possible_Modication calls ! ! * sem_prag.ads, sem_prag.adb (Analyze_Pragma, case Stream_Convert): ! Don't check for primitive operations when calling Rep_Item_Too_Late. ! (Process_Import_Or_Interface): Do not place flag on formal ! subprograms. ! (Analyze_Pragma, case Export): If the entity is a deferred constant, ! propagate information to full view, which is the one elaborated by the ! back-end. ! (Make_Inline): the pragma is effective if it applies to an internally ! generated subprogram declaration for a body that carries the pragma. ! (Analyze_Pragma, case Optimize_Alignment): Set new flag ! Optimize_Alignment_Local. ! (Analyze_PPC_In_Decl_Part): New procedure ! (Get_Pragma_Arg): Moved to outer level ! (Check_Precondition_Postcondition): Change to allow new visibility ! rules for package spec ! (Analyze_Pragma, case Check_Policy): Change placement rules to be ! same as pragma Suppress/Unsuppress. ! Change name In_Default_Expression => In_Spec_Expression ! Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression ! Change name Pre_Analyze_And_Resolve => Preanalyze_And_Resolve ! (Check_Precondition_Postcondition): Do proper visibility preanalysis ! for the case of these pragmas appearing in the spec. ! (Check_Enabled): New function ! (Initialize): New procedure ! (Tree_Read): New procedure ! (Tree_Write): New procedure ! (Check_Precondition_Postcondition): New procedure ! Implement pragmas Check and Check_Policy ! Merge Assert processing with Check ! ! * sem_warn.adb (Warn_On_Known_Condition): Handle pragma Check ! New warning flag -gnatw.e ! ! * sinfo.ads, sinfo.adb (Has_Relative_Deadline_Pragma): New function ! returning whether a task (or main procedure) has a pragma ! Relative_Deadline. ! (Set_Has_Relative_Deadline_Pragma): Procedure to indicate that a task ! (or main procedure) has a pragma Relative_Deadline. ! Add Next_Pragma field to N_Pragma node ! (PPC_Enabled): New flag ! (Next_Pragma): Now used for Pre/Postcondition processing ! ! * snames.h, snames.ads, snames.adb: New standard name ! Inherit_Source_Path ! Add entry for 'Invalid_Value attribute ! Add entry for new attribute Has_Tagged_Values ! Add entry for Enum_Val attribute ! Add new standard names Aggregate, Configuration and Library. ! Add _Postconditions ! Add _Result ! Add Pragma_Precondition ! Add Pragma_Postcondition ! Add Attribute_Result ! New standard name Archive_Builder_Append_Option ! (Preset_Names): Add _relative_deadline and relative_deadline definitions ! There was also a missing non_preemptive_within_priorities. ! (Get_Pragma_Id, Is_Pragma_Name): Add support for pragma ! Relative_Deadline. ! Add support for pragmas Check and Check_Policy ! ! * tree_gen.adb: Call Sem_Aux.Tree_Write ! ! * tree_in.adb: Call Sem_Aux.Tree_Read ! ! * exp_ch11.adb (Expand_N_Raise_Statement): New Build_Location calling ! sequence ! ! * exp_intr.adb (Expand_Source_Info): New Build_Location calling ! sequence ! ! * exp_prag.adb (Expand_Pragma_Relative_Deadline): New procedure. ! (Expand_N_Pragma): Call the appropriate procedure for expanding pragma ! Relative_Deadline. ! (Expand_Pragma_Check): New procedure ! ! * sinput.ads, sinput.adb (Build_Location_String): Now appends to name ! buffer. ! ! * sinfo.adb (PPC_Enabled): New flag ! ! 2008-04-08 Robert Dewar ! Gary Dismukes ! Javier Miranda ! Ed Schonberg ! ! * fe.h: Remove global Optimize_Alignment flag, no longer used ! ! * layout.adb: Test Optimize_Alignment flags rather than global switch ! ! * lib.ads, lib.adb: New OA_Setting field in library record ! ! * lib-load.adb: New OA_Setting field in library record ! ! * lib-writ.ads, lib-writ.adb (Collect_Withs, Write_With_Lines): Place ! units mentioned in limited_with_ clauses in the ali file, with an ! 'Y' marker. ! New Ox fields in U line ! ! * opt.adb: New flag Optimize_Alignment_Local ! (Check_Policy_List[_Config]): New flags ! ! * opt.ads (Invalid_Value_Used): New flag ! New switch Optimize_Alignment_Local ! (Warn_On_Parameter_Order): New flag ! (Check_Policy_List[_Config]): New flags ! ! * ali.ads, ali.adb: Add indicator 'Y' to mark mark the presence of ! limited_with clauses. ! New data structures for Optimize_Alignment ! ! * bcheck.adb (Check_Consistent_Restriction_No_Default_Initialization): ! New procedure ! (Check_Consistent_Optimize_Alignment): Rework for new structure ! (Check_Consistent_Restrictions): Fix incorrect error message ! ! sem_ch10.adb (Decorate_Tagged_Type): Set the Parent field of a newly ! created class-wide type (to the Parent field of the specific type). ! (Install_Siblings): Handle properly private_with_clauses on subprogram ! bodies and on generic units. ! (Analyze_With_Clause, Install_Limited_Withed_Unit): Guard against an ! illegal limited_with_clause that names a non-existent package. ! (Check_Body_Required): Determine whether a unit named a limited_with ! clause needs a body. ! (Analyze_Context): A limited_with_clause is illegal on a unit_renaming. ! Capture Optimize_Alignment settings to set new OA_Setting field in ! library record. ! (Build_Limited_Views): Include task and protected type declarations. ! ! * sem_ch3.ads, sem_ch3.adb (Analyze_Object_Declaration): Handle the ! case of a possible constant redeclaration where the current object is ! an entry index constant. ! (Analyze_Object_Declaration): Generate an error in case of CPP ! class-wide object initialization. ! (Analyze_Object_Declaration): Add extra information on warnings for ! declaration of unconstrained objects. ! (Access_Type_Declaration): Set Associated_Final_Chain to Empty, to avoid ! conflicts with the setting of Stored_Constraint in the case where the ! access type entity has already been created as an E_Incomplete_Type due ! to a limited with clause. ! Use new Is_Standard_Character_Type predicate ! (Analyze_Object_Declaration): Apply access_constant check only after ! expression has been resolved, given that it may be overloaded with ! several access types. ! (Constant_Redeclaration): Additional legality checks for deferred ! constant declarations tha involve anonymous access types and/or null ! exclusion indicators. ! (Analyze_Type_Declaration): Set Optimize_Alignment flags ! (Analyze_Subtype_Declaration): Ditto ! (Analyze_Object_Declaration): Ditto ! (Analyze_Object_Declaration): Don't count tasks in generics ! Change name In_Default_Expression => In_Spec_Expression ! Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression ! Change name Pre_Analyze_And_Resolve => Preanalyze_And_Resolve ! (Process_Discriminants): Additional check for illegal use of default ! expressions in access discriminant specifications in a type that is not ! explicitly limited. ! (Check_Abstract_Overriding): If an inherited function dispaches on an ! access result, it must be overridden, even if the type is a null ! extension. ! (Derive_Subprogram): The formals of the derived subprogram have the ! names and defaults of the parent subprogram, even if the type is ! obtained from the actual subprogram. ! (Derive_Subprogram): In the presence of interfaces, a formal of an ! inherited operation has the derived type not only if it descends from ! the type of the formal of the parent operation, but also if it ! implements it. This is relevant for the renamings created for the ! primitive operations of the actual for a formal derived type. ! (Is_Progenitor): New predicate, to determine whether the type of a ! formal in the parent operation must be replaced by the derived type. ! ! * sem_util.ads, sem_util.adb (Has_Overriding_Initialize): Make ! predicate recursive to handle components that have a user-defined ! Initialize procedure. Handle controlled derived types whose ancestor ! has a user-defined Initialize procedured. ! (Note_Possible_Modification): Add Sure parameter, generate warning if ! sure modification of constant ! Use new Is_Standard_Character_Type predicate ! (Find_Parameter_Type): when determining whether a protected operation ! implements an interface operation, retrieve the type of the formal from ! the entity when the formal is an access parameter or an ! anonymous-access-to-subprogram. ! Move Copy_Parameter_List to sem_util, for use when building stubbed ! subprogram bodies. ! (Has_Access_Values): Tagged types now return False ! (Within_HSS_Or_If): New procedure ! (Set_Optimize_Alignment_Flags): New procedure ! Change name In_Default_Expression => In_Spec_Expression ! Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression ! Change name Pre_Analyze_And_Resolve => Preanalyze_And_Resolve ! ! 2008-04-08 Tristan Gingold ! ! * s-fileio.adb: Name_Error shouldn't be raised for a tempory file. ! ! 2008-04-08 Tristan Gingold ! ! PR ada/10768 ! ! * cuintp.c: Fix 16 bits issue for AVR. ! On AVR, integer is 16 bits, so it can't be used to do math with ! Base (=32768). ! So use long_integer instead. ! ! 2008-04-08 Hristian Kirtchev ! ! * a-calend-vms.ads, a-calend-vms.adb: Add with and use clause for ! System.OS_Primitives. ! Change type of various constants, parameters and local variables from ! Time to representation type OS_Time. ! (To_Ada_Time, To_Unix_Time): Correct sign of origin shift. ! Remove the declaration of constant Mili_F from several routines. New ! body for internal package Conversions_Operations. ! (Time_Of): Add default parameters for several formals. ! ! * a-caldel.adb: Minor reformatting ! ! * a-calend.ads, a-calend.adb: New body for internal package ! Conversions_Operations. ! (Time_Of): Add default parameters for several formals. ! ! * Makefile.rtl: Add a-ststop ! Add Ada.Calendar.Conversions to the list of runtime files. ! Add g-timsta ! ! * a-calcon.adb, a-calcon.ads: New files. ! ! 2008-04-08 Jose Ruiz ! Tristan Gingold ! ! * s-interr-dummy.adb, s-interr-vms.adb, s-interr-sigaction.adb ! (Install_Restricted_Handlers): New procedure ! which is a simplified version of Install_Handlers that does not store ! previously installed. ! ! * s-interr-vxworks.adb: Fix ACATS cxc3001 ! On VxWorks interrupts can't be detached. ! (Install_Restricted_Handlers): New procedure. ! ! * s-interr.ads, s-interr.adb (Install_Restricted_Handlers): New ! procedure. ! ! 2008-04-08 Olivier Hainque ! ! * s-intman-vxworks.ads, s-intman-vxworks.adb ! (Map_And_Raise_Exception): Remove. Was an import of only part of the ! required services already implemented elsewhere. ! (Notify_Exception): Delete body, import __gnat_error_handler instead. ! (Initialize): Add SA_SIGINFO to the sa_flags, to get the sigcontext ! argument passed to the handler, which we need for ZCX propagation ! purposes. ! ! 2008-04-08 Hristian Kirtchev ! ! * adaint.h, adaint.c (__gnat_current_time_string): New routine. ! ! * g-timsta.adb, g-timsta.ads: New files. ! ! 2008-04-08 Robert Dewar ! ! * a-except-2005.ads, a-except-2005.adb, a-except.ads, a-except.adb ! (Raise_Exception): In accordance with AI-446, raise CE for Null_Id ! (Raise_Exception_Always): Fix documentation accordingly ! ! 2008-04-08 Robert Dewar ! ! * a-strbou.ads, a-strbou.adb (From_String): New procedure (for use by ! Stream_Convert) ! ! * sem_ch13.ads (Rep_Item_Too_Late): Document that Stream_Convert sets ! FOnly ! ! 2008-04-08 Javier Miranda ! Robert Dewar ! Ed Schonberg ! ! * a-tags.adb (Register_Interface_Offset): New subprogram. ! (Set_Dynamic_Offset_To_Top): New subprogram (see previous comment). ! (To_Predef_Prims_Table_Ptr): Removed. ! (Acc_Size): Removed. ! (To_Acc_Size): Removed. ! (Parent_Size): Modified to the call the subprogram returning the size of ! the parent by means of the new TSD component Size_Func. ! ! * a-tags.ads (Offset_To_Top_Ptr): New access type declaration. ! (DT_Offset_To_Top_Offset): New constant value that is used to generate ! code referencing the Offset_To_Top component of the dispatch table's ! prologue. ! (Prim_Ptr): New declaration of access to procedure. Used to avoid the ! use of 'address to initialize dispatch table slots. ! (Size_Func): New component of the TSD. Used by the run-time to call the ! size primitive of the tagged type. ! ! * checks.adb (Apply_Access_Check): Avoid check when accessing the ! Offset_To_Top component of a dispatch table. ! (Null_Exclusion_Static_Checks): If the non-null access type appears in a ! deferred constant declaration. do not add a null expression, to prevent ! spurious errors when full declaration is analyzed. ! (Apply_Discriminant_Check): If both discriminant constraints share a ! node which is not static but has no side effects, do not generate a ! check for that discriminant. ! (Generate_Index_Checks): Set Name_Req to true in call to duplicate ! subexpr, since the prefix of an attribute is a name. ! ! * checks.ads: Fix nit in comment. ! ! * exp_ch3.ads, exp_ch3.adb (Freeze_Record_Type): Do not add the spec ! and body of predefined primitives in case of CPP tagged type ! derivations. ! (Freeze_Type): Deal properly with no storage pool case ! (Make_Predefined_Primitive_Specs): Generate specification of abstract ! primitive Deep_Adjust if a nonlimited interface is derived from a ! limited interface. ! (Build_Dcheck_Functions): Create discriminant-checking functions only ! for variants that have some component(s). ! (Build_Slice_Assignment): In expanded code for slice assignment, handle ! properly the case where the slice bounds extend to the last value of the ! underlying representation. ! (Get_Simple_Init_Val): New calling sequence, accomodate Invalid_Value ! (Is_Variable_Size_Record): An array component has a static size if ! index bounds are enumeration literals. ! ! * exp_disp.adb (Make_DT): Use the first subtype to determine whether ! an external tag has been specified for the type. ! (Building_Static_DT): Add missing support for private types. ! (Make_DT): Add declaration of Parent_Typ to ensure consistent access ! to the entity associated with the parent of Typ. This is done to ! avoid wrong access when the parent is a private type. ! (Expand_Interface_Conversion): Improve error message when the ! configurable runtime has no support for dynamic interface conversion. ! (Expand_Interface_Thunk): Add missing support to interface types in ! configurable runtime. ! (Expand_Dispatching_Call): remove obsolete code. ! (Make_DT): Replace occurrences of RE_Address by RE_Prim_Ptr, and ! ensure that all subtypes and aggregates associated with dispatch ! tables have the attribute Is_Dispatch_Table_Entity set to true. ! (Register_Primitive): Rename one variable to improve code reading. ! Replace occurrences of RE_Addres by RE_Prim_Ptr. Register copy o ! of the pointer to the 'size primitive in the TSD. ! ! * rtsfind.ads (RE_DT_Offset_To_Top_Offset): New entity. ! (RE_Offset_To_Top_Ptr): New entity. ! (RE_Register_Interface_Offset): New entity. ! (RE_Set_Dynamic_Offset_To_Top): New entity. ! (RE_Set_Offset_To_Top): Removed entity. ! (RE_Prim_Ptr): New entity ! (RE_Size_Func): New entity ! (RE_Size_Ptr): New entity ! (RTU_Id): Add Ada_Dispatching and Ada_Dispatching_EDF. ! (Ada_Dispatching_Child): Define this new subrange. ! (RE_Id): Add new required run-time calls (RE_Set_Deadline, RE_Clock, ! RE_Time_Span, and RE_Time_Span_Zero). ! (RE_Unit_Table): Add new required run-time calls ! ! * rtsfind.adb (Get_Unit_Name): Add processing for Ada.Dispatching ! children. ! ! * exp_atag.ads, exp_atag.adb (Build_Offset_To_Top): New subprogram. ! (Build_Set_Static_Offset_To_Top): New subprogram. Generates code that ! initializes the Offset_To_Top component of a dispatch table. ! (Build_Predef_Prims): Removed. ! (Build_Get_Predefined_Prim_Op_Address): Replace call to Predef_Prims by ! its actual code. ! (Build_Set_Size_Function): New subprogram. ! ! * exp_ch13.adb: Do not generate storage variable for storage_size zero ! (Expand): Handle setting/restoring flag Inside_Freezing_Actions ! ! 2008-04-08 Robert Dewar ! ! * a-ztdeau.adb, a-tideau.adb, a-wtdeau.adb (Puts_Dec): Fix error in ! computing Fore when Exp > 0 ! ! 2008-04-08 Robert Dewar ! ! * back_end.adb: Remove Big_String_Ptr declarations (now in Types) ! ! * errout.adb: Remove Big_String_Ptr declarations (now in Types) ! Change name Is_Style_Msg to Is_Style_Or_Info_Msg ! ! * fmap.adb: Remove Big_String declarations (now in Types) ! (No_Mapping_File): New Boolean global variable ! (Initialize): When mapping file cannot be read, set No_Mapping_File to ! False. ! (Update_Mapping_File): Do nothing if No_Mapping_File is True. If the ! tables were empty before adding entries, open the mapping file ! with Truncate = True, instead of delete/re-create. ! ! * fname-sf.adb: Remove Big_String declarations (now in Types) ! ! * s-strcom.adb, g-dyntab.ads, g-table.ads, s-carsi8.adb, ! s-stalib.ads, s-carun8.adb: Add zero size Storage_Size clauses for ! big pointer types ! ! * table.ads: Add for Table_Ptr'Storage_Size use 0 ! ! * types.ads: Add Big_String declarations ! Add Size_Clause of zero for big pointer types ! ! 2008-04-08 Vincent Celier ! ! * clean.adb (Parse_Cmd_Line): Recognize switch --subdirs= ! (Usage): Add line for switch --subdirs= ! Add new switch -eL, to follow symbolic links when processing project ! files. ! ! * gnatcmd.adb: Process switches -eL and --subdirs= ! (Non_VMS_Usage): Output "gnaampcmd" instead of "gnat", and call ! Program_Name to get proper tool names when AAMP_On_Target is set. ! (Gnatcmd): Call Add_Default_Search_Dirs and Get_Target_Parameters to get ! AAMP_On_Target set properly for use of GNAAMP tools (this is needed by ! Osint.Program_Name). ! ! * gnatname.adb: (Scan_Args): Recognize switches -eL and --subdirs= ! (Usage): Add lines for switches -eL and --subdirs= ! ! * makeusg.adb: Add line for switch --subdirs= ! ! * prj.ads: ! (Source_Data): New Boolean component Compiled, defaulted to True ! (Empty_File_Name: New global variable in private part, initialized in ! procedure Initialize. ! (Subdirs_Option): New constant string ! (Subdirs): New String_Ptr global variable ! (Language_Config): New component Include_Compatible_Languages ! (Project_Qualifier): New type for project qualifiers ! (Project_Data): New component Qualifier ! (Project_Configuration): New component Archive_Builder_Append_Option ! ! * prj-nmsc.adb (Get_Unit_Exceptions): When a unit is already in ! another imported project indicate the name of this imported project. ! (Check_File): When a unit is in two project files, indicate the project ! names and the paths of the source files for each project. ! (Add_Source): Set Compiled to False if compiler driver is empty. Only ! set object, dependency and switches file names if Compiled is True. ! (Process_Compiler): Allow the empty string for value of attribute Driver ! (Get_Directories): When Subdirs is not null and Object_Dir is not ! specified, locate and create if necessary the actual object dir. ! (Locate_Directory): When Subdirs is not empty and Create is not the ! empty string, locate and create if necessary the actual directory ! as a subdirectory of directory Name. ! (Check_Library_Attributes.Check_Library): Allow a project where the only ! "sources" are header files of file based languages to be imported by ! library projects, in multi-language mode (gprbuild). ! (Check_Library_Attributes.Check_Library): In multi-language mode ! (gprbuild), allow a library project to import a project with no ! sources, even when this is not declared explicitly. ! (Check_If_Externally_Built): A virtual project extending an externally ! built project is also externally built. ! (Check_Library_Attributes): For a virtual project extending a library ! project, inherit the library directory. ! (Process_Project_Level_Array_Attributes): Process new attribute ! Inherit_Source_Path. ! For projects with specified qualifiers "standard", "library" or ! "abstract", check that the project conforms to the qualifier. ! (Process_Project_Level_Simple_Attributes): Process new attribute ! Archive_Builder_Append_Option. ! ! * switch-m.adb: (Scan_Make_Switches): Process switch --subdirs= ! (Normalize_Compiler_Switches): Only keep compiler switches that are ! passed to gnat1 by the gcc driver and that are stored in the ALI file ! by gnat1. ! Do not take into account switc -save-temps ! ! * makegpr.adb (Compile_Link_With_Gnatmake): Transmit switch -eL if ! gprmake is called with -eL. ! (Scan_Arg): Recognize switch -eL ! (Usage): Add line for switch -eL ! ! * prj.adb (Initialize): Initialize Empty_File_Name ! (Project_Empty): New component Qualifier ! ! * prj-attr.ads, prj-attr.adb: New project level attribute ! Inherit_Source_Path. ! New project level attribute Archive_Builder_Append_Option ! ! * prj-dect.adb: Replace System.Strings by GNAT.Strings. ! ! * prj-ext.adb (Initialize_Project_Path): In Multi_Language mode, add ! /lib/gnat in the project path, after /share/gpr, for ! upward compatibility. ! ! * prj-part.adb (Project_Path_Name_Of.Try_Path): In high verbosity, put ! each Trying ..." on different lines. ! (Parse_Single_Project): Recognize project qualifiers. Fail in qualifier ! is "configuration" when not in configuration. Fail when in configuration ! when a specified qualifier is other than "configuration". ! ! * prj-proc.adb (Process_Declarative_Items): Link new elements of copied ! full associative array together. ! (Recursive_Process): Put the project qualifier in the project data ! ! * prj-tree.ads, prj-tree.adb: (Project_Qualifier_Of): New function ! (Set_Project_Qualifier_Of): New procedure ! ! 2008-04-08 Robert Dewar ! ! * errout.ads: Update comments for new handling of info: messages ! ! * erroutc.adb (Matches): New procedure ! (Warning_Specifically_Suppressed): Modified to handle multiple * chars ! (Is_Style_Or_Info_Msg): New name for Is_Style_Msg, now set for ! info messages as well as style messages. ! ! * erroutc.ads: Remove unneeded fields from Specific_Warning_Entry ! ! * sem_elab.adb (Supply_Bodies): Create actual bodies for stubbed ! subprograms. ! (Check_A_Call): Special "info: " warnings now have ? in the text ! (Elab_Warning): Use info message in static case ! ! 2008-04-08 Ed Schonberg ! ! * exp_aggr.adb (Static_Array_Aggregate): Use Max_Aggr_Size to determine ! whether an array aggregate with static bounds and scalar components ! should be expanded into a static constant. ! ! 2008-04-08 Gary Dismukes ! Ed Schonberg ! Robert Dewar ! ! * sem_cat.adb (Validate_RCI_Subprogram_Declaration): Add tests of ! Has_Stream_Attribute_ Definition when checking for available stream ! attributes on parameters of a limited type in Ada 2005. Necessary for ! proper recognition of visible stream attribute clauses. ! (Has_Stream_Attribute_Definition): If the type is derived from a ! private type, then use the derived type's underlying type for checking ! whether it has stream attributes. ! (Validate_Object_Declaration): The check for a user-defined Initialize ! procedure applies also to types with controlled components or a ! controlled ancestor. ! Reject an object declaration in a preelaborated unit if the type is a ! controlled type with an overriding Initialize procedure. ! (Validate_Remote_Access_To_Class_Wide_Type): Return without further ! checking when the parent of a dereference is a selected component and ! the name has not been analyzed. ! ! * sem_ch4.adb (Analyze_Selected_Component): Add checking for selected ! prefixes that are invalid explicit dereferences of remote ! access-to-class-wide values, first checking whether the selected ! component is a prefixed form of call to a tagged operation. ! (Analyze_Call): Remove code that issues an error for limited function ! calls in illegal contexts, as we now support all of the contexts that ! were forbidden here. ! Allow a function call that returns a task.and appears as the ! prefix of a selected component. ! (Analyze_Reference): Give error message if we try to make a 'Reference ! for an object that is atomic/aliased without its type having the ! corresponding attribute. ! (Analyze_Call): Remove condition checking for attributes to allow ! calls to functions with inherently limited results as prefixes of ! attributes. Remove related comment about Class attributes. ! (Analyze_Selected_Component): If the prefix is a remote type, check ! whether this is a prefixed call before reporting an error. ! (Complete_Object_Operation): If the controlling formal is an access to ! variable reject an actual that is a constant or an access to one. ! (Try_Object_Operation): If prefix is a tagged protected object,retrieve ! primitive operations from base type. ! ! * exp_ch4.adb (Expand_N_Indexed_Component): Test for prefix that is a ! build-in-place ! function call and call Make_Build_In_Place_Call_In_Anonymous_Context. ! (Expand_N_Selected_Component): Test for prefix that is a build-in-place ! function call and call Make_Build_In_Place_Call_In_Anonymous_Context. ! (Expand_N_Slice): Test for prefix that is a build-in-place function call ! and call Make_Build_In_Place_Call_In_Anonymous_Context. ! (Analyze_Call): Remove code that issues an error for limited function ! calls in illegal contexts, as we now support all of the contexts that ! were forbidden here. ! New calling sequence for Get_Simple_Init_Val ! (Expand_Boolean_Operator): Add call to Silly_Boolean_Array_Xor_Test ! (Expand_N_Op_Not): Add call to Silly_Boolan_Array_Not_Test ! ! 2008-04-08 Hristian Kirtchev ! Ed Schonberg ! Robert Dewar ! ! * exp_ch2.adb: Minor reformatting. ! (Expand_Entry_Index_Parameter): Set the type of the identifier. ! (Expand_Entry_Reference): Add call to Expand_Protected_Component. ! (Expand_Protected_Component): New routine. ! (Expand_Protected_Private): Removed. ! Add Sure parameter to Note_Possible_Modification calls ! ! * sem_ch12.ads, sem_ch12.adb (Analyze_Subprogram_Instantiation): The ! generated subprogram declaration must inherit the overriding indicator ! from the instantiation node. ! (Validate_Access_Type_Instance): If the designated type of the actual is ! a limited view, use the available view in all cases, not only if the ! type is an incomplete type. ! (Instantiate_Object): Actual is illegal if the formal is null-excluding ! and the actual subtype does not exclude null. ! (Process_Default): Handle properly abstract formal subprograms. ! (Check_Formal_Package_Instance): Handle properly defaulted formal ! subprograms in a partially parameterized formal package. ! Add Sure parameter to Note_Possible_Modification calls ! (Validate_Derived_Type_Instance): if the formal is non-limited, the ! actual cannot be limited. ! (Collect_Previous_Instances): Generate instance bodies for subprograms ! as well. ! ! * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case Small): Don't ! try to set RM_Size. ! Add Sure parameter to Note_Possible_Modification calls ! (Analyze_At_Clause): Preserve Comes_From_Source on Rewrite call ! (Analyze_Attribute_Definition_Clause, case Attribute_Address): Check for ! constant overlaid by variable and issue warning. ! Use new Is_Standard_Character_Type predicate ! (Analyze_Record_Representation_Clause): Check that the specified ! Last_Bit is not less than First_Bit - 1. ! (Analyze_Attribute_Definition_Clause, case Address): Check for ! self-referential address clause ! ! * sem_ch5.ads, sem_ch5.adb (Diagnose_Non_Variable_Lhs): Rewrite the ! detection mechanism when the lhs is a prival. ! (Analyze_Assignment): Call Check_Unprotected_Access to detect ! assignment of a pointer to protected data, to an object declared ! outside of the protected object. ! (Analyze_Loop_Statement): Check for unreachable code after loop ! Add Sure parameter to Note_Possible_Modication calls ! Protect analysis from previous syntax error such as a scope mismatch ! or a missing begin. ! (Analyze_Assignment_Statement): The assignment is illegal if the ! left-hand is an interface. ! ! * sem_res.ads, sem_res.adb (Resolve_Arithmetic_Op): For mod/rem check ! violation of restriction No_Implicit_Conditionals ! Add Sure parameter to Note_Possible_Modication calls ! Use new Is_Standard_Character_Type predicate ! (Make_Call_Into_Operator): Preserve Comes_From_Source when rewriting ! call as operator. Fixes problems (e.g. validity checking) which ! come from the result looking as though it does not come from source). ! (Resolve_Call): Check case of name in named parameter if style checks ! are enabled. ! (Resolve_Call): Exclude calls to Current_Task as entry formal defaults ! from the checking that such calls should not occur from an entry body. ! (Resolve_Call): If the return type of an Inline_Always function ! requires the secondary stack, create a transient scope for the call ! if the body of the function is not available for inlining. ! (Resolve_Actuals): Apply Ada2005 checks to view conversions of arrays ! that are actuals for in-out formals. ! (Try_Object_Operation): If prefix is a tagged protected object,retrieve ! primitive operations from base type. ! (Analyze_Selected_Component): If the context is a call to a protected ! operation the parent may be an indexed component prior to expansion. ! (Resolve_Actuals): If an actual is of a protected subtype, use its ! base type to determine whether a conversion to the corresponding record ! is needed. ! (Resolve_Short_Circuit): Handle pragma Check ! ! * sem_eval.adb: Minor code reorganization (usea Is_Constant_Object) ! Use new Is_Standard_Character_Type predicate ! (Eval_Relational_Op): Catch more cases of string comparison ! ! 2008-04-08 Robert Dewar ! Gary Dismukes ! ! * s-rident.ads: Add No_Default_Initialization restriction ! ! * exp_tss.adb: ! (Has_Non_Null_Base_Init_Proc): Handle No_Default_Initialization case ! (Set_TSS): Handle No_Default_Initialization case ! ! * exp_ch6.adb (Expand_N_Subprogram_Body): Handle restriction ! No_Default_Initialization ! (Expand_N_Subprogram_Body): Remove redundant initialization of out ! parameters when Normalize_Scalars is active. ! (Add_Final_List_Actual_To_Build_In_Place_Call): Add formal Sel_Comp ! Fix casing error in formal parameter name in call ! (Register_Predefined_DT_Entry): Replace occurrences of RE_Address by ! (Expand_Call, Propagate_Tag): Call Kill_Current_Values when processing a ! dispatching call on VM targets. ! ! 2008-04-08 Gary Dismukes ! Thomas Quinot ! ! * exp_ch7.adb (Find_Final_List): Change the test for generating a ! selected component from an access type's Associated_Final_Chain to ! check for the presence of that field, rather than assuming it exists ! for all named access types. ! (Make_Clean): New formal Chained_Cleanup_Action allowing to specify a ! procedure to call at the end of the generated cleanup procedure. ! (Expand_Cleanup_Actions): When a new cleanup procedure is generated, and ! and an At_End_Proc already exists in the handled sequence of statements ! for which cleanup actions are being expanded, the original cleanup ! action must be preserved. ! ! 2008-04-08 Hristian Kirtchev ! Ed Schonberg ! Robert Dewar ! Gary Dismukes ! ! * exp_ch9.ads, exp_ch9.adb (Build_Protected_Entry, ! Build_Unprotected_Subprogram_Body): Generate debug info for ! declarations related to the handling of private data in task and ! protected types. ! (Debug_Private_Data_Declarations): New subprogram. ! (Install_Private_Data_Declarations): Remove all debug info flagging. ! This is now done by Debug_Private_Data_Declarations at the correct ! stage of expansion. ! (Build_Simple_Entry_Call): If the task name is a function call, expand ! the prefix into an object declaration, and make the surrounding block a ! task master. ! (Build_Master_Entity): An internal block is a master if it wraps a call. ! Code reformatting, update comments. Code clean up. ! (Make_Task_Create_Call): Use 'Unrestricted_Access instead of 'Address. ! (Replicate_Entry_Formals): If the formal is an access parameter or ! anonymous access to subprogram, copy the original tree to create new ! entities for the formals of the subprogram. ! (Expand_N_Task_Type_Declaration): Create a Relative_Deadline variable ! for tasks to store the value passed using pragma Relative_Deadline. ! (Make_Task_Create_Call): Add the Relative_Deadline argument to the ! run-time call to create a task. ! (Build_Wrapper_Spec): If the controlling argument of the interface ! operation is an access parameter with a non-null indicator, use the ! non-null indicator on the wrapper. ! ! * sem_ch9.adb (Analyze_Protected_Type): Only retrieve the full view when ! present, which it may not be in the case where the type entity is an ! incomplete view brought in by a limited with. ! (Analyze_Task_Type): Only retrieve the full view when present, which it ! may not be in the case where the type entity is an incomplete view brought ! in by a limited with. ! (Analyze_Protected_Definition): Set Is_Frozen on all itypes generated for ! private components of a protected type, to prevent the generation of freeze ! nodes for which there is no proper scope of elaboration. ! ! * exp_util.ads, exp_util.adb ! (Remove_Side_Effects): If the expression is a function call that returns a ! task, expand into a declaration to invoke the build_in_place machinery. ! (Find_Protection_Object): New routine. ! (Remove_Side_Effects): Also make a copy of the value ! for attributes whose result is of an elementary type. ! (Silly_Boolean_Array_Not_Test): New procedure ! (Silly_Boolean_Array_Xor_Test): New procedure ! (Is_Volatile_Reference): New function ! (Remove_Side_Effects): Use Is_Volatile_Reference ! (Possible_Bit_Aligned_Component): Handle slice case properly ! ! * exp_pakd.adb (Expand_Packed_Not): Move silly true/true or false/false ! case test to Exp_Util ! (Expand_Packed_Xor): Move silly true/true case test to Exp_Util ! ! 2008-04-08 Thomas Quinot ! ! * exp_dist.ads, exp_dist.adb: Fix casing error in formal parameter name ! in call ! (Add_RACW_Features): When processing an RACW in another unit than the ! main unit, set Body_Decls to No_List to indicate that the bodies of ! the type's TSS must not be generated. ! (GARLIC_Support.Add_RACW_Read_Attribute, ! GARLIC_Support.Add_RACW_Write_Attribute): Do not generate bodies if ! Body_Decls is No_List. ! (PolyORB_Support.Add_RACW_Read_Attribute, ! PolyORB_Support.Add_RACW_Write_Attribute, ! PolyORB_Support.Add_RACW_From_Any, ! PolyORB_Support.Add_RACW_To_Any, ! PolyORB_Support.Add_RACW_TypeCode): Same. ! (Transmit_As_Unconstrained): New function. ! (Build_Ordered_Parameters_List): Use the above to order parameters. ! (GARLIC_Support.Build_General_Calling_Stubs): ! Use the above to determine which parameters to unmarshall using 'Input ! at the point where their temporary is declared (as opposed to later on ! with a 'Read call). ! (PolyORB_Support.Build_General_Calling_Stubs): ! Use the above to determine which parameters to unmarshall using From_Any ! at the point where their temporary is declared (as opposed to later on ! with an assignment). ! ! 2008-04-08 Ed Schonberg ! ! * exp_strm.adb (Build_Record_Or_Elementary_Input_Function): If this is ! an Input function for an access type, do not perform default ! initialization on the local variable that receives the value, to ! prevent spurious warnings when the type is null-excluding. ! ! 2008-04-08 Robert Dewar ! Ed Schonberg ! ! * freeze.adb (Freeze_Entity): Improve warnings on access types in pure ! units. ! (Size_Known): Generic formal scalar types have known at compile ! time size, so remove check. ! Fix casing error in formal parameter name in call ! (Freeze_Subprogram): If the subprogram is a user-defined operator, ! recheck its overriding indication. ! ! 2008-04-08 Vincent Celier ! ! * gnat1drv.adb: Send all messages indicating an error to standard error ! ! 2008-04-08 Robert Dewar ! ! * gnatbind.adb (Restriction_Could_Be_Set): New procedure ! (List_Applicable_Restrictions): Do not list existing restrictions ! ! 2008-04-08 Thomas Quinot ! ! * g-socket.ads, g-socket.adb: Improve documentation of GNAT.Sockets: ! add a pointer to generic sockets literature ! do not mention that the given example is "typical" usage. ! Remove obsolete comment about multicast not being supported on Windows. ! (Connect_Socket): Make Server mode IN rather than IN OUT ! since this formal is never modified. ! ! 2008-04-08 Robert Dewar ! ! * sprint.adb (Write_Itype): Handle Itypes whose Parent field points to ! the declaration for some different entity. ! (Sprint_Node_Actual, case N_Derived_Type_Definition): When an interface ! list is precent (following the parent subtype indication), display ! appropriate "and" keyword. ! ! * itypes.adb: Remove unnecessary calls to Init_Size_Align and Init_Esize ! Remove unnecessary calls to Init_Size_Align and Init_Esize. ! Add notes on use of Parent field of an Itype ! ! 2008-04-08 Ed Schonberg ! Robert Dewar ! Gary Dismukes ! ! * lib-xref.adb (Is_On_LHS): Remove dead code ! (Output_Overriden_Op): If the overridden operation is itself inherited, ! list the ancestor operation, which is the one whose body or absstract ! specification is actually being overridden. For source navigation ! purposes. ! ! * sem_ch7.adb (Is_Primitive_Of): use base type to determine whether ! operation is primitive for the type. ! (Declare_Inherited_Private_Subprograms): If the new operation overrides ! an inherited private subprogram, set properly the Overridden_Operation ! attribute, for better cross-reference information. ! (Analyze_Package_Specification): Do late analysis of spec PPCs ! (Install_Private_Declaration, Uninstall_Declarations): Save/restore ! properly the full view and underlying full views of a private type in a ! child unit, whose full view is derived from a private type in a parent ! unit, and whose own full view becomes visible in the child body. ! ! * sem_disp.adb (Check_Dispatching_Operation): When a body declares a ! primitive operation after the type has been frozen, add an explicit ! reference to the type and the operation, because other primitive ! references have been emitted already. ! (Expand_Call, Propagate_Tag): Call Kill_Current_Values when processing a ! dispatching call on VM targets. ! ! 2008-04-08 Vincent Celier ! Thomas Quinot ! ! * make.adb: (Gnatmake_Called): Remove, no longer necessary ! (Compile_Surces): Call Delete_Temp_Config_Files only if Gnatmake_Called ! is True and Debug_Flag_N is False. Debug_Flag_N means "keep temp files". ! (Insert_Project_Sources): Take into account index in multi-unit source ! files. ! After building a library project, delete all temporary files. ! (Initialize): Reset current output after parsing project file. ! (Collect_Arguments_And_Compile): Never insert in the queue the sources ! of library projects that are externally built. ! Put file name in error and inform messages if -df is used ! (Display): If invoked with -d7, do not display path names, but only ! file names. ! ! * makeutl.ads (Path_Or_File_Name): New function ! (Path_Or_File_Name): New function ! ! 2008-04-08 Arnaud Charlet ! ! * Make-lang.in: Disable warnings during first stage of bootstrap ! Get rid of gnatbl. ! Update dependencies. ! ! 2008-04-08 Vincent Celier ! ! * mlib-prj.adb (Build_Library): Compare with ALI file name in canonical ! case to decide if ALI object file is included in library. ! (Build_Library): Never attempt to build a library if the project is ! externally built. ! ! 2008-04-08 Thomas Quinot ! ! * nlists.adb (Is_Non_Empty_List): Remove redundant test. First ! (No_List) is defined to return Empty. ! ! 2008-04-08 Jose Ruiz ! ! * osint.ads, osint.adb (Get_Libraries_From_Registry): Improve ! documentation. ! Update comments. ! (Read_Default_Search_Dirs): Do not consider spaces as path separators ! because spaces may be part of legal paths. ! ! 2008-04-08 Robert Dewar ! ! * par-ch11.adb (P_Exception_Handler): Check indentation level for ! handler ! ! 2008-04-08 Ed Schonberg ! ! * par-ch3.adb (P_Type_Declaration) Reject the keyword "synchronized" ! in a type declaration, if this is not an interface declaration or ! private type extension. ! ! 2008-04-08 Vincent Celier ! ! * prj-util.adb (Executable_Of): New String parameter Language. When ! Ada_Main is False and Language is not empty, attempt to remove the body ! suffix or the spec suffix of the language to get the base of the ! executable file name. ! (Put): New Boolean parameter Lower_Case, defauilted to False. When ! Lower_Case is True, put the value in lower case in the name list. ! (Executable_Of): If there is no executable suffix in the configuration, ! then do not modify Executable_Extension_On_Target. ! ! * prj-util.ads (Executable_Of): New String parameter Language, ! defaulted to the empty string. ! (Put): New Boolean parameter Lower_Case, defauilted to False ! ! 2008-04-08 Robert Dewar ! ! * scng.adb (Scan_Identifier): Handle case of identifier starting with ! wide character using UTF-8 encoding. ! ! 2008-04-08 Javier Miranda ! ! * sem.adb (Analyze): Consider case in which we analyze an empty node ! that was generated by a call to a runtime function that is not ! available under the configurable runtime. ! ! * sem.ads (Inside_Freezing_Actions): New flag. ! (Save_Check_Policy_List): New field in scope stack entry ! ! 2008-04-08 Ed Schonberg ! Robert Dewar ! ! * sem_aggr.adb (Analyze_N_Extension_Aggregate): Add legality checks for ! the ancestor part of an extension aggregate for a limited type. ! (Resolve_Array_Aggregate): Issue warning for sliding of aggregate with ! enumeration index bounds. ! (Resolve_Array_Aggregate): Add circuit for diagnosing missing choices ! when array is too short. ! (Check_Expr_OK_In_Limited_Aggregate): Move function ! Check_Non_Limited_Type from Resolve_Record_Aggregate to top level (and ! change name). ! (Resolve_Array_Aggregate.Resolve_Aggr_Expr): ! Check_Expr_OK_In_Limited_Aggregates called to check for illegal limited ! component associations. ! (Check_Non_Limited_Type): Moved to outer level and renamed. ! (Resolve_Record_Aggregate): In an extension aggregate, an association ! with a box initialization can only designate a component of the ! extension, not a component inherited from the given ancestor ! ! * sem_case.adb: Use new Is_Standard_Character_Type predicate ! ! 2008-04-08 Robert Dewar ! ! * s-imgdec.adb (Set_Decimal_Digits): Fix error when input is zero with ! negative scale ! (Set_Decimal_Digits): Properly handle Aft=0 (equivalent to Aft=1) ! Properly handle case where Aft > Scale and input number is less than ! one. ! ! 2008-04-08 Hristian Kirtchev ! ! * s-stoele.ads, s-soflin.ads: Move the location of ! Dummy_Communication_Block from System.Storage_Elements to ! System.Soft_Links. ! ! * s-tpobop.ads: Add comment on usage of Dummy_Communication_Block to ! emulate Communication_Block in certain scenarios. ! ! 2008-04-08 Hristian Kirtchev ! ! * s-strxdr.adb, s-stratt.ads, s-stratt.adb (Block_IO_OK): New ! subprogram. ! Add new subtype S_WWC, unchecked conversion routines From_WWC and ! To_WWC. ! (I_WWC, O_WWC): New routines for input and output of ! Wide_Wide_Character. ! ! 2008-04-08 Robert Dewar ! ! * stringt.adb (Write_String_Table_Entry): Handle wide characters ! properly ! ! 2008-04-08 Robert Dewar ! ! * styleg.adb (Check_Comment): Allow special char after -- in ! non-end-of-line case ! ! 2008-04-08 Robert Dewar ! ! * stylesw.adb: Implement -gnaty + - y options ! (Set_GNAT_Style_Check_Options): Includ I in style check string ! ! * stylesw.ads: Add comments for new style switch options ! ! 2008-04-08 Sergey Rybin ! ! * tree_io.ads: Increase ASIS_Version_Number because of adding Sem_Aux ! to the set of the GNAT components needed by ASIS. ! ! 2008-04-08 Bob Duff ! ! * types.h: Change CE_Null_Exception_Id to the correct value (8, was 9). ! ! 2008-04-08 Tristan Gingold ! ! * vxaddr2line.adb: Use Unsigned_32 instead of Integer for address type. ! Improve error message generation. ! ! 2008-04-08 Vincent Celier ! ! * a-direct.adb (Start_Search): Check for Name_Error before checking for ! Use_Error, as specified in the RM. Check if directory is open and raise ! Use_Error if it is not. ! ! 2008-04-08 Vincent Celier ! Robert Dewar ! ! * vms_conv.adb (Output_Version): Print "GNAAMP" instead of "GNAT when ! AAMP_On_Target is set. ! ! * vms_data.ads: Add NOxxx to style check switch list ! Add entry COMPONENTS for -gnatVe ! Add VMS qualifiers for -eL (/FOLLOW_LINKS_FOR_FILES) and --subdirs= ! (/SUBDIRS=). ! (GCC_Switches): Add /ALL_BACK_END_WARNINGS. ! Add qualifiers for gnatmetric coupling options ! Add note that -gnata enables all checks ! Add entries [NO]PARAMETER_ORDER for -gnatw.p[P] ! Fix inconsistency for VMS qualifier for the gnatpp '-rnb' option ! New warning flag -gnatw.e ! ! * usage.adb: Add entries for -gnaty+ -gnaty- -gnatyy ! Add entry for -gnatyN (forgotten before) ! Line for new warning switch -gnatw.p ! New warning flag -gnatw.e ! ! * gnat_ugn.texi: Add documentation fpr project file switch -aP ! Document -gnaty - + y ! Replace occurences of "package specification" with "package spec" ! Define preprocessing symbols in documentation of gnatprep ! Clarify reason for distinguishing overflow checking ! Add documentation for project-aware tool switches -eL and --subdirs= ! Complete list of configuration pragmas ! Specify that, even when gnatmake switch -x is used, mains on the command ! line need to be sources of project files. ! Editing of gnatcheck/gnatmetric doc. ! Add documentation for -gnatw.p/-gnatw.P ! Add missing documentation for -fno-inline-functions. ! Add documentation for -gnatw.e ! ! * gnat_rm.texi: Add documentation for No_Default_Initialization ! Replace occurences of "package specification" with "package spec" ! Document use of * in Warnings Off string ! Update documentation of alignment/component clauses. ! Add documentation for Invalid_Value ! Document new consistency rule for Optimize_Alignment ! Add documentation for Precondition and Postcondition pragmas ! Add documentation for Check and Check_Policy pragmas ! Document new Enum_Val attribute ! Remove requirement for static string in pragma Assert ! Add documentation on GNAT.Time_Stamp ! ! * ug_words: add entry for -gnatVe ! Add entries for -gnat.p[P] /WARNINGS=[NO]PARAMETER_ORDER ! Add entry for -gnatw.e ! ! * debug.adb: Add missing documentation for d.a flag ! Document new -gnatd.a switch. ! Add documentation for new gnatmake debug switch -df ! ! 2008-04-08 Thomas Quinot ! ! * gen-soccon.c: Bump year in copyright notices. ! ! * g-soccon-vxworks.ads: Add new constant IP_PKTINFO ! ! 2008-04-08 Eric Botcazou ! ! * ctrl_c.c: Improve handling of ctrl-c on LynxOS and Windows. ! Minor reformatting. ! ! 2008-04-08 Robert Dewar ! Bob Duff ! ! * impunit.adb: Add Interfaces.Java.JNI, System.Strings.Stream_Ops, ! Ada.Calendar.Conversions, Ada.Dispatching.EDF, GNAT.Time_Stamp ! ! * s-intman-mingw.adb: Minor comment fix -- spell 'explicitly' correctly ! ! * g-trasym.adb: Minor comment fix -- spell 'explicitly' correctly ! ! * g-trasym.ads: Minor comment improvements ! ! * s-stalib.adb: Minor comment fix -- spell 'explicitly' correctly ! ! * a-sequio.ads, a-direio.ads: improve message for tagged type ! ! * a-strunb.ads: Minor reformatting ! ! * a-tifiio.adb: Minor reformatting ! ! * atree.adb (Fix_Parents): Use clearer names for formals ! Cleanup and simplify code ! Use named notation in calls ! ! * exp_fixd.adb (Do_Multiply_Fixed_Universal): Use named notation in ! confusing calls ! ! * uintp.adb: Used named notation for some confusing calls ! ! * bindusg.adb: Minor change in one line of output ! ! * cstand.adb: Minor reformatting of src representation of Standard ! ! * a-assert.ads: Add comment. ! ! * g-decstr.adb: Fix bad indentation ! ! * expander.ads, expander.adb: Code clean up. ! ! * sem_dist.ads: Minor comment improvement ! ! * sem_type.adb, g-dirope.ads, g-exctra.ads, s-valwch.adb, ! s-wchstw.adb, targparm.ads, widechar.adb: Minor reformatting ! ! * i-cstrin.adb: Fix casing error in formal parameter name in call ! ! 2008-04-08 Ed Schonberg ! ! * binde.adb (Gather_All_Links, Gather_Dependencies): units that are ! mentioned in limited_with_clauses to do create semantic dependencies ! even though they appear in the ali file. ! ! 2008-04-08 Emmanuel Briot ! ! * g-comlin.ads, g-comlin.adb (Expansion): Remove unreachable return ! statement. ! (Get_Configuration): New subprogram. ! ! * prj-pp.ads, prj-pp.adb (Pretty_Print): new parameters Id and Id_Tree ! These optional parameters help preserve the casing of the project's name ! when pretty-printing. ! ! 2008-04-08 Jerome Lambourg ! Arnaud Charlet ! ! * bindgen.adb (Gen_Adainit_Ada): If the main program is a CIL function, ! then use __gnat_set_exit_status to report the returned status code. ! ! * comperr.adb (Compiler_Abort): Convert most bug boxes into clean error ! messages on .NET, since some constructs of the language are not ! properly supported. ! ! * gnatlink.adb (Gnatlink): In case the command line is too long for the ! .NET linker, gnatlink now concatenate all .il files and pass this to ! ilasm. ! ! 2008-04-07 Aurelien Jarno ! Xavier Grave ! ! * Makefile.in: Add make ifeq define for mips/mipsel support. ! * g-soccon-linux-mips.ads, system-linux-mipsel.ads, ! system-linux-mips.ads: New files. ! ! 2008-04-07 Aurelien Jarno ! ! * sysdep.c: add __GLIBC__ to the #ifdef preprocessor macros to ! detect systems using GNU libc. ! * gsocket.h: ditto. ! * socket.c: ditto. ! * adaint.c: ditto. ! * link.c: ditto. ! ! 2008-04-07 Aurelien Jarno ! ! * s-osinte-linux-kfreebsd.ads (SC_NPROCESSORS_ONLN): New ! constant constant for sysconf call. ! (bit_field): New packed boolean type used by cpu_set_t. ! (cpu_set_t): New type corresponding to the C type with ! the same name. Note that on the Ada side we use a bit ! field array for the affinity mask. There is not need ! for the C macro for setting individual bit. ! (pthread_setaffinity_np): New imported routine. ! * Makefile.in: Use s-tasinf-linux.ads and s-tasinf-linux.adb ! on GNU/kFreeBSD. ! ! 2008-04-07 Eric Botcazou ! ! * utils2.c (build_binary_op): Fold ARRAY_REF and ARRAY_RANGE_REF too. ! ! 2008-04-07 Eric Botcazou ! ! * gigi.h (create_subprog_type): Remove returns_with_dsp parameter. ! * decl.c (gnat_to_gnu_entity): Adjust for above new prototype. ! * utils.c (create_subprog_type): Remove returns_with_dsp parameter. ! * trans.c (gnat_to_gnu) : Remove code dealing with ! Return by Depressed Stack Pointer. ! ! 2008-04-06 Eric Botcazou * decl.c (is_variable_size): Do not unconditionally return false on non-strict alignment platforms. + 2008-04-06 Eric Botcazou + + * decl.c (rest_of_type_decl_compilation_no_defer): New local function + used to process all the variants of the specified type. + (gnat_to_gnu_entity): Invoke rest_of_type_decl_compilation for enumeral + types too. Call rest_of_type_decl_compilation_no_defer if undeferring. + (rest_of_type_decl_compilation): Likewise. + * utils.c (gnat_pushdecl): Propagate the name to all variants of type. + + 2008-04-03 Paolo Bonzini + + * gigi.h (insert_block): Kill. + * utils.c (insert_block): Kill. + + 2008-04-02 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : For a constant object whose + type has self-referential size, get the size from the initializing + expression directly if it is also a constant whose nominal type + has self-referential size. + 2008-04-01 John David Anglin + PR ada/33688 + * g-soccon-darwin.ads: Define new constant IP_PKTINFO. + PR ada/33857 * env.c: Always include crt_externs.h if __APPLE__ is defined. (__gnat_setenv): Use setenv instead of putenv if __APPLE__ is defined. + 2008-04-01 Andreas Jaeger + + * g-soccon-linux-ppc.ads: Add new constants SO_REUSEPORT and + IP_PKTINFO. + + 2008-03-31 Ralf Wildenhues + + * g-table.adb, g-tasloc.adb, g-traceb.ads, + g-trasym.adb, g-utf_32.adb, gen-soccon.c, gigi.h, gmem.c, + gnatbind.adb, gnatchop.adb, gnatcmd.adb, + gnatcmd.ads, gnatdll.adb, gnatfind.adb, + gnatlink.adb, gnatmem.adb, gprep.adb, + i-cstrea-vms.adb, i-cstrin.adb, i-pacdec.ads, + i-vxwork.ads, impunit.adb, init.c, initialize.c, inline.adb, + layout.adb, lib-writ.adb, lib-writ.ads, lib-xref.adb, + lib-xref.ads, lib.adb, link.c, live.ads, + make.adb, makegpr.adb, makeutl.adb, math_lib.adb, + mdll-utl.adb, mdll.ads, memroot.adb, memroot.ads, + misc.c, mlib-prj.adb, mlib-tgt-hpux.adb, + mlib-tgt-linux.adb, mlib-tgt-tru64.adb, mlib-tgt.ads, + namet.adb, namet.h, nlists.adb, nlists.ads, + nlists.h, opt.ads, osint-b.ads, osint-c.adb, + osint-c.ads, osint.adb, osint.ads, output.ads, + par-ch10.adb, par-ch12.adb, par-ch2.adb, par-ch3.adb, + par-ch4.adb, par-ch5.adb, par-ch6.adb, par-ch9.adb, + par-endh.adb, par-labl.adb, par-prag.adb, + par-sync.adb, par-tchk.adb, par-util.adb, + par.adb, prep.adb, prep.ads, prepcomp.adb, prj-attr.ads, + prj-dect.adb, prj-env.adb, prj-ext.adb, prj-nmsc.adb, + prj-nmsc.ads, prj-pp.adb, prj-proc.adb, + prj-strt.ads, prj-tree.ads, prj.adb, prj.ads: Fix comment typos. + 2008-03-31 Eric Botcazou * decl.c (gnat_to_gnu_entity) : Do not force a non-null size if it has overflowed. ! 2008-03-31 Olivier Hainque ! Eric Botcazou ! * utils2.c (find_common_type): Document assumption on t1/t2 vs ! lhs/rhs. Force use of lhs type if smaller, whatever the modes. ! ! 2008-03-30 Ralf Wildenhues ! ! * a-textio.ads, a-witeio.ads, a-ztexio.ads, ali.ads, ! einfo.ads, erroutc.adb, erroutc.ads, exp_attr.adb, ! exp_imgv.adb, exp_intr.adb, exp_pakd.adb, ! exp_pakd.ads, exp_prag.adb, exp_smem.adb, ! exp_tss.ads, exp_util.adb, exp_util.ads, ! exp_vfpt.adb, freeze.adb, freeze.ads, ! frontend.adb, g-alleve.adb, g-altcon.adb, ! g-altive.ads, g-alveop.ads, g-alvevi.ads, ! g-arrspl.adb, g-busorg.ads, g-calend.adb, ! g-calend.ads, g-casuti.ads, g-cgideb.adb, ! g-comlin.adb, g-comlin.ads, g-curexc.ads, ! g-debpoo.adb, g-debpoo.ads, g-decstr.adb, ! g-dirope.adb, g-dirope.ads, g-dynhta.ads, ! g-dyntab.adb, g-encstr.ads, g-excact.ads, ! g-except.ads, g-expect.ads, g-heasor.adb, ! g-hesora.adb, g-hesorg.adb, g-htable.ads, ! g-locfil.ads, g-md5.adb, g-md5.ads, ! g-memdum.ads, g-moreex.ads, g-os_lib.adb, ! g-pehage.adb, g-pehage.ads, g-regexp.adb, ! g-regexp.ads, g-regpat.adb, g-regpat.ads, ! g-soccon-aix.ads, g-soccon-darwin.ads, ! g-soccon-freebsd.ads, g-soccon-hpux-ia64.ads, ! g-soccon-hpux.ads, g-soccon-irix.ads, ! g-soccon-linux-64.ads, g-soccon-linux-ppc.ads, ! g-soccon-linux-x86.ads, g-soccon-lynxos.ads, ! g-soccon-mingw.ads, g-soccon-solaris-64.ads, ! g-soccon-solaris.ads, g-soccon-tru64.ads, ! g-soccon-vms.ads, g-soccon-vxworks.ads, ! g-soccon.ads, g-socket.adb, g-socket.ads, ! g-socthi-mingw.adb, g-socthi-vms.adb, ! g-socthi-vxworks.adb, g-soliop-mingw.ads, ! g-soliop-solaris.ads, g-soliop.ads, g-spipat.adb, ! g-spipat.ads, g-string.adb, g-stsifd-sockets.adb: Fix comment ! typos. ! ! 2008-03-27 Eric Botcazou ! ! * decl.c (gnat_to_gnu_entity) : Also set the public flag ! if the procedure is imported. ! ! 2008-03-26 Arnaud Charlet ! ! * adaint.c: Fix warnings. ! ! 2008-03-26 Arnaud Charlet ! ! * g-dirope.ads, g-dirope.adb: (Dir_Type_Value): Moved to spec. ! ! 2008-03-26 Arnaud Charlet ! ! * a-witeio.adb: Fix problem with Current_Output (introduce Self). ! Fix problem of status check for null file ! ! 2008-03-26 Arnaud Charlet ! ! * s-proinf-irix-athread.ads, s-vxwork-mips.ads, ! s-traces.ads, s-vxwork-arm.ads, s-vxwork-ppc.ads, s-vxwork-sparcv9.ads, ! s-tasinf-mingw.ads, s-tasinf-linux.ads, s-tasdeb.ads, mlib-tgt.ads, ! i-cstrin.ads, uintp.adb, g-catiio.adb, s-vmexta.ads, ! s-trafor-default.ads, s-vxwork-m68k.ads: Minor reformatting. Update ! comments. ! ! 2008-03-26 Thomas Quinot ! ! PR ada/33688 ! * g-socket.ads, g-socket.adb (Options, Set_Socket_Option, ! Get_Socket_Option): Add support for Receive_Packet_Info. ! ! * g-soccon.ads, g-soccon-tru64.ads, g-soccon-aix.ads, ! g-soccon-irix.ads, g-soccon-hpux.ads, g-soccon-solaris.ads, ! g-soccon-vms.ads, g-soccon-mingw.ads, g-soccon-freebsd.ads, ! g-soccon-hpux-ia64.ads, g-soccon-solaris-64.ads, g-soccon-darwin.ads, ! g-soccon-lynxos.ads, g-soccon-linux-64.ads, g-soccon-linux-x86.ads: Add ! new constants SO_REUSEPORT and IP_PKTINFO ! ! 2008-03-26 Robert Dewar ! ! * a-taster.adb, s-shasto.adb, s-soflin.adb, s-taasde.adb, s-taenca.adb, ! a-sytaco.adb, a-sytaco.ads, a-tasatt.adb, a-taside.adb, ! a-intnam-lynxos.ads, a-retide.adb, a-intnam-tru64.ads, a-intnam-aix.ads, ! a-intnam-irix.ads, a-intnam-hpux.ads, a-intnam-linux.ads, ! a-intnam-solaris.ads, a-caldel-vms.adb, a-intnam-vms.ads, ! a-excpol-abort.adb, a-intnam-mingw.ads, s-interr.adb, s-interr.ads, ! s-intman.ads, s-gloloc.adb, s-osinte-lynxos-3.ads, ! s-interr-sigaction.adb, s-osinte-hpux.ads, s-osinte-solaris-posix.ads, ! a-intnam-freebsd.ads, s-osinte-freebsd.ads, s-osinte-lynxos.ads, ! s-taspri-lynxos.ads, s-osinte-tru64.ads, s-osinte-tru64.ads, ! s-taspri-tru64.ads, s-osinte-aix.ads, s-osinte-irix.ads, ! s-osinte-hpux-dce.ads, s-taprop-hpux-dce.adb, s-taspri-hpux-dce.ads, ! s-osinte-linux.ads, s-osinte-dummy.ads, s-taprop-dummy.adb, ! s-taspri-dummy.ads, s-interr-dummy.adb, s-osinte-solaris.ads, ! s-osinte-mingw.ads, s-taprop-solaris.adb, s-taspri-solaris.ads, ! s-inmaop-vms.adb, s-interr-vms.adb, s-intman-vms.ads, s-osinte-vms.ads, ! s-osinte-vms.ads, s-taprop-vms.adb, s-taspri-vms.ads, ! s-taspri-mingw.ads, s-interr-vxworks.adb, s-inmaop-posix.adb, ! s-intman-vxworks.ads, s-osinte-vxworks.ads, s-osprim-vxworks.adb, ! s-taspri-vxworks.ads, s-taspri-posix.ads, a-caldel.adb, a-calend.adb, ! a-elchha.adb, a-dynpri.adb, a-except.adb, a-except.ads, a-interr.ads, ! a-textio.adb, a-tigeau.ads, atree.adb, s-taprob.adb, s-taprop.ads, ! s-tarest.adb, s-tarest.ads, s-tasini.adb, s-taskin.adb, s-taskin.ads, ! s-tasque.adb, s-tasren.adb, s-tasren.ads, s-tassta.adb, s-tassta.ads, ! s-tasuti.adb, s-tataat.adb, s-tataat.ads, s-tpoben.adb, s-tpoben.ads, ! s-tpobop.adb, s-tpobop.ads, s-tposen.adb, s-tposen.ads, s-valrea.adb, ! s-valuti.adb, a-intnam-darwin.ads, s-osinte-darwin.ads, s-solita.adb, ! a-ztinau.ads, s-osinte-linux-hppa.ads, a-except-2005.adb, ! a-except-2005.ads, a-rttiev.adb, s-osinte-vxworks6.ads, s-regexp.adb, ! s-tasloc.adb: Minor reformatting. ! Update comments. ! Remove "used for" sections from comments. ! ! 2008-03-26 Robert Dewar ! ! * s-tpopsp-posix.adb, s-tpopsp-solaris.adb, s-tpopsp-posix-foreign.adb, ! s-tpopsp-lynxos.adb, s-tpopde-vms.ads, s-tpopde-vms.adb, ! s-tpopsp-vxworks.adb, s-casi16.adb, s-caun16.adb, s-inmaop.ads, ! s-tadeca.adb, s-tadeca.ads, s-tadert.adb, s-tadert.ads, s-tpinop.adb, ! s-tpinop.ads, s-tporft.adb, a-rbtgso.adb, a-crbtgo.ads, a-crbtgo.adb, ! a-crbtgk.ads, a-crbtgk.adb, a-ciorse.adb, a-cihama.ads, a-cihama.adb, ! a-cidlli.ads, a-cidlli.adb, a-chtgop.ads, a-chtgop.adb, a-cgcaso.ads, ! a-cgcaso.adb, a-cgaaso.adb, a-ciormu.adb, a-cihase.adb, a-swuwha.ads, ! a-rbtgso.ads, a-cgaaso.ads, a-cgaaso.ads, a-ciorma.adb, a-chtgke.ads, ! a-chtgke.adb, a-llfzti.ads, a-ztenau.adb, a-ztenau.ads, a-stzhas.ads, ! a-szbzha.ads, a-szbzha.adb, a-crdlli.ads, a-crdlli.ads, a-crdlli.adb, ! i-forbla-darwin.adb, i-forbla.ads, s-regexp.adb, a-nllrar.ads, ! a-nlrear.ads, a-nucoar.ads, a-nurear.ads, i-forlap.ads, s-gearop.adb, ! s-gearop.ads, s-gecobl.adb, s-gecobl.ads, s-gecola.adb, s-gecola.ads, ! s-gerebl.adb, s-gerela.ads, a-swuwha.adb, i-forbla-unimplemented.ads, ! double spaced if it fits on one line and otherwise single spaced. ! ! 2008-03-26 Arnaud Charlet ! ! * s-taprop-irix.adb, s-taprop-tru64.adb, s-taprop-lynxos.adb, ! s-taprop-linux.adb, s-taprop-mingw.adb, s-taprop-vxworks.adb, ! s-taprop-posix.adb (Create_Task): Do not attempt to set task priority ! or task info if the thread could not be created. ! ! 2008-03-26 Arnaud Charlet ! ! * gnatvsn.ads (Library_Version): Bump to 4.4. ! (Current_Year): Bump to 2008. ! ! 2008-03-26 Robert Dewar ! ! * ali.ads, ali.adb (Optimize_Alignment_Setting): New field in ALI record ! ! * bcheck.adb (Check_Consistent_Optimize_Alignment): New procedure ! ! * debug.adb: Add debug flags d.r and d.v ! Add debug flag .T (Optimize_Alignment (Time)) ! Add debug flag .S (Optimize_Alignment (Space)) ! ! * freeze.adb (Freeze_Record_Type): Set OK_To_Reorder_Components ! depending on setting of relevant debug flags. ! Replace use of Warnings_Off by Has_Warnings_Off ! (Freeze_Entity): In circuit for warning on suspicious convention ! actuals, do not give warning if subprogram has same entity as formal ! type, or if subprogram does not come from source. ! (Freeze_Entity): Don't reset Is_Packed for fully rep speced record ! if Optimize_Alignment set to Space. ! ! * frontend.adb: Add call to Sem_Warn.Initialize ! Add call to Sem_Warn.Output_Unused_Warnings_Off_Warnings ! Reset Optimize_Alignment mode from debug switches .S and .T ! ! * layout.adb (Layout_Composite_Object): Rewritten for ! Optimize_Aligment pragma. ! ! * lib-writ.ads, lib-writ.adb: New Ox parameter for Optimize_Alignment ! mode. ! ! * opt.ads, opt.adb: (Optimize_Alignment): New global switch ! ! * par-prag.adb (N_Pragma): Chars field removed, use Chars ! (Pragma_Identifier (.. instead, adjustments throughout to accomodate ! this change. Add entry for pragma Optimize_Alignment ! ! * sem_prag.adb (N_Pragma): Chars field removed, use Chars ! (Pragma_Identifier (.. ! instead, adjustments throughout to accomodate this change. ! (Process_Compile_Time_Warning_Or_Error): Use !! for generated msg ! (Favor_Top_Level): Use new function Is_Access_Subprogram_Type ! Add implementation of pragma Optimize_Alignment ! ! 2008-03-26 Vincent Celier ! ! * a-szuzti.adb, a-swuwti.adb, a-suteio.adb (functions Get_Line): ! Improve memory usage to avoid use of stack. ! ! 2008-03-26 Robert Dewar ! ! * a-teioed.ads: Correct value of Default_Fill ! ! * a-teioed.adb (Image): Use Fill_Character instead of '*' to fill ! ! 2008-03-26 Robert Dewar ! ! * a-ztexio.adb, a-ztexio.ads, a-witeio.ads, a-witeio.adb: Fix problem ! with Current_Output (introduce Self). ! ! 2008-03-26 Robert Dewar ! ! * checks.adb (Ensure_Valid): Capture valid status if possible ! (eliminate checks) ! ! 2008-03-26 Robert Dewar ! ! * stand.ads: Deal with reordering of package standard declarations ! ! * cstand.adb: Put package Standard declarations in proper order ! ! 2008-03-26 Robert Dewar ! ! * einfo.ads, einfo.adb (N_Pragma): Chars field removed, use Chars ! (Pragma_Identifier (.. instead. ! (OK_To_Reorder_Components): New flag ! (Has_Entries): Code cleanup. ! (Warnings_Off_Used): New flag ! (Warnings_Off_Used_Unmodified): New flag ! (Warnings_Off_Used_Unreferenced): New flag ! (Has_Warnings_Off): New function ! (Has_Unmodified): New function ! (Has_Unreferenced): New function ! (Is_Trivial_Subprogram): New flag ! (Is_Static_Dispatch_Table_Entity): New attribute. ! Change name Access_Subprogram_Type_Kind to Access_Subprogram_Kind ! (more consistent with other similar names) ! (Access_Subprogram_Type): New classification function ! ! 2008-03-26 Robert Dewar ! ! * errout.ads: Document new !! insertion sequence ! ! * errout.adb (N_Pragma): Chars field removed, use Chars ! (Pragma_Identifier (.. instead. ! Replace use of Warnings_Off by Has_Warnings_Off ! (Error_Msg_Internal): Don't delete warning ending in !! ! ! 2008-03-26 Robert Dewar ! ! * par.adb (Check_No_Right_Paren): Removed no longer used ! ! * par-ch10.adb (N_Pragma): Chars field removed, use Chars ! (Pragma_Identifier (.. instead. ! ! * par-ch10.adb (P_Subunit): Improvement in error recovery and message ! ! * par-tchk.adb, par-ch5.adb, par-ch6.adb, par-ch3.adb, ! par-ch4.adb: Minor improvements in error recovery and messages. ! ! * erroutc.adb (Test_Style_Warning_Serious_Msg): Treat style msgs as ! non-serious ! ! * par-ch9.adb: Minor improvements in error recovery and messages ! (P_Protected): Better error recovery for "protected type x;" ! ! * par-util.adb: Minor improvements in error recovery and messages ! (Check_No_Right_Paren): Removed no longer used ! ! 2008-03-26 Ed Schonberg ! ! * exp_aggr.adb (Replace_Type): When checking for self-reference, verify ! that the prefix of an attribute is the type of the aggregate being ! expanded. ! ! 2008-03-26 Javier Miranda ! Robert Dewar ! ! * exp_attr.adb (N_Pragma): Chars field removed. ! (Expand_N_Attribute_Reference): If the designated type associated with ! attribute 'Unrestricted_Access is a subprogram entity then replace it ! by an E_Subprogram_Type itype. ! Implement attribute Old ! ! * sem_attr.ads (Attribute_Class_Array): Move to snames.ads ! ! * sem_attr.adb (Build_Access_Subprogram_Itype): Add documentation. ! Replace call to ! New_Internal_Entity by call to Create_Itype to centralize calls ! building itypes, ad propagate the convention of the designated ! subprogram. In addition, disable the machinery cleaning constant ! indications from all entities in current scope when 'Unrestricted_Access ! corresponds with a node initializing a dispatch table slot. ! (Analyze_Attribute): Parameterless attributes returning a string or a ! type will not be called with improper arguments, so we can remove junk ! code that was dealing with this case. ! Implement attribute Old ! ! * snames.ads, snames.h, snames.adb: Add entries for attribute Old ! Add entry for pragma Optimize_Alignment ! New standard names Sync and Synchronize ! ! 2008-03-26 Robert Dewar ! Arnaud Charlet ! ! * exp_ch11.adb (Expand_At_End_Handler): Set From_At_End flag on raise ! stmt. ! (No_Exception_Propagation_Active): New function. ! (Expand_Exception_Handlers): Use No_Exception_Propagation_Active. ! Update comments, and review all uses of No_Exception_Propagation, which ! are now correct and in sync with what gigi expects. ! ! * restrict.ads, restrict.adb (No_Exception_Propagation_Active): New ! function. ! (Expand_Exception_Handlers): Use No_Exception_Propagation_Active. ! Update comments, and review all uses of No_Exception_Propagation, which ! are now correct and in sync with what gigi expects. ! ! 2008-03-26 Ed Schonberg ! ! * sem_ch3.adb (Access_Definition): If the access type is the return ! result of a protected function, create an itype reference for it ! because usage will be in an inner scope from the point of declaration. ! (Build_Derived_Record_Type): Inherit Reverse_Bit_Order and ! OK_To_Reorder_Components. ! (Make_Index): If an overloaded range includes a universal integer ! interpretation, resolve to Standard.Integer. ! (Analyze_Subtype_Indication): Copy Convention to subtype ! (Check_Abstract_Interfaces): Complete semantic checks on the legality of ! limited an synchronized progenitors in type declaration and private ! extension declarations. ! ! * exp_ch13.adb (Expand_N_Freeze_Entity): If the scope of the entity is a ! protected subprogram body, determine proper scope from subprogram ! declaration. ! ! 2008-03-26 Robert Dewar ! ! * exp_ch4.adb (Expand_N_Op_Concat): Remove special tests for ! No_Run_Time_Mode ! ! 2008-03-26 Gary Dismukes ! ! * exp_ch5.adb (Expand_N_Extended_Return_Statement): Suppress generation ! of a heap allocator for a limited unconstrained function return when ! resstriction No_Allocators is active. ! (Analyze_Allocator): The restriction No_Allocators is now only checked ! on allocators that have Comes_From_Source set, as per RM-H.4(7). ! ! * sem_ch4.adb (Expand_N_Extended_Return_Statement): Suppress generation ! of a heap allocator for a limited unconstrained function return when ! resstriction No_Allocators is active. ! (Analyze_Allocator): The restriction No_Allocators is now only checked ! on allocators that have Comes_From_Source set, as per RM-H.4(7). ! (Has_Fixed_Op): If the name in a function call is Standard."*" and the ! operands are fixed-point types, the universal_fixed predefined operation ! is used, regardless of whether the operand type (s) have a primitive ! operation of the same name. ! ! 2008-03-26 Javier Miranda ! ! * exp_disp.adb (Make_DT, Make_Secondary_DT): Set attribute ! Is_Static_Dispatch_Table ! (Build_Dispatch_Tables): Replace calls to Exchange_Entities() by calls ! to Exchange_Declarations to exchange the private and full-view. Bug ! found working in this issue. ! (Expand_Dispatching_Call): Propagate the convention of the subprogram ! to the subprogram pointer type. ! (Make_Secondary_DT): Replace generation of Prim'Address by ! Address (Prim'Unrestricted_Access) ! (Make_DT): Replace generation of Prim'Address by ! Address (Prim'Unrestricted_Access) ! (Make_Disp_*_Bodies): When compiling for a restricted profile, use ! simple call form for single entry. ! (Make_DT): Handle new contents of Access_Disp_Table (access to dispatch ! tables of predefined primitives). ! (Make_Secondary_DT): Add support to handle access to dispatch tables of ! predefined primitives. ! (Make_Tags): Add entities to Access_Dispatch_Table associated with ! access to dispatch tables containing predefined primitives. ! ! * exp_ch6.adb (N_Pragma): Chars field removed, use Chars ! (Pragma_Identifier (.. instead, adjustments throughout to accomodate ! this change. ! (Register_Predefined_DT_Entry): Updated to handle the new contents ! of attribute Access_Disp_Table (pointers to dispatch tables containing ! predefined primitives). ! ! * exp_util.ads, exp_util.adb (Corresponding_Runtime_Package): New ! subprogram. ! (Find_Interface_ADT): Updated to skip the new contents of attribute ! Access_Dispatch_Table (pointers to dispatch tables containing predefined ! primitives). ! ! * sem_util.adb (Has_Abstract_Interfaces): Add missing support for ! concurrent types. ! (Set_Convention): Use new function Is_Access_Subprogram_Type ! (Collect_Interfaces_Info): Updated to skip the new contents of attribute ! Access_Dispatch_Table (pointers to dispatch tables containing predefined ! primitives). ! ! * exp_atag.ads, exp_atag.adb (Build_Inherit_Predefined_Prims): Improve ! expanded code avoiding calls to Build_Predef_Prims. ! (Build_Set_Predefined_Prim_Op_Address): Improve expanded code avoiding ! call to Build_Get_Predefined_Prim_Op_Address. ! ! 2008-03-26 Javier Miranda ! ! * exp_ch7.adb (Make_Clean): Code cleanup using the new centralized ! subprogram Corresponding_Runtime_Package to know the runtime package ! that will provide support to a given protected type. ! ! * exp_ch9.adb (Add_Private_Declarations, ! Build_Protected_Subprogram_Call, ! Build_Protected_Entry, Build_Simple_Entry_Call, ! Expand_N_Protected_Body, Expand_N_Protected_Type_Declaration, ! Expand_N_Timed_Entry_Call, Make_Initialize_Protection): Code ! cleanup using the new centralized subprogram Corresponding_Runtime ! Package to know the runtime package that provides support to ! a given protected type. ! ! 2008-03-26 Ed Schonberg ! ! * exp_pakd.adb (Expand_Bit_Packed_Element_Set): If the component ! assignment is within the initialization procedure for a packed array, ! and Initialize_Scalars is enabled, compile right-hand side with checks ! off, because the value is purposely out of range. ! ! 2008-03-26 Vincent Celier ! ! * gnatcmd.adb: Add processing for GNAT SYNC ! ! * vms_conv.ads: (Command_Type): Add command Sync ! ! * vms_conv.adb (Initialize): Add Command_List data for new command Sync ! ! * vms_data.ads: Add entries for -gnatw.w ! Add qualifier for gnatstub --header-file option ! Add switches for GNAT SYNC ! ! * prj-attr.ads, prj-attr.adb: Add new package Synchronize for GNAT SYNC ! (Add_Package_Name): New procedure ! (Package_Name_List): New function ! (Initialize): Add known package names to the list ! (Register_New_Package): Add the new package name to the list ! ! 2008-03-26 Robert Dewar ! ! * g-pehage.adb, g-regist.adb, g-spipat.ads, g-spipat.adb, ! s-asthan.adb, s-parint.adb, s-rpc.adb, s-stchop.adb: Replace ! Raise_Exception by "raise with" construct. ! ! 2008-03-26 Pascal Obry ! ! * Makefile.in: Add proper GNAT.Serial_Communications implementation on ! supported platforms. ! ! * Makefile.rtl: Add g-sercom.o. ! ! * impunit.adb: Add g-sercom.adb. ! ! * s-crtl.ads (open): New routine. ! (close): Likewise. ! (write): Likewise. ! ! * s-osinte-mingw.ads (BYTE): New type. ! (CHAR): Likewise. ! (OVERLAPPED): Likewise. ! (GENERIC_READ): New constant. ! (GENERIC_WRITE): Likewise. ! (OPEN_EXISTING): Likewise. ! (PSECURITY_ATTRIBUTES): Removed this type, use anonymous access ! type instead. ! (CreateFile): New routine. ! (WriteFile): Likewise. ! (ReadFile): Likewise. ! (CloseHandle): Move next to the other file oriented routines. ! ! * g-sercom.ads: New unit. ! ! * g-sercom.adb: Default implementation, calls to this unit will raise ! a program error exception. ! ! * g-sercom-mingw.adb, g-sercom-linux.adb: Windows and ! GNU/Linux implementations. ! ! 2008-03-26 Robert Dewar ! ! * itypes.adb (Create_Itype): Use new name Access_Subprogram_Kind ! ! * sem_ch13.adb (Validate_Unchecked_Conversion): Give warning for ! unchecked conversion for different conventions only for subprogram ! pointers or on VMS. ! ! 2008-03-26 Vincent Celier ! ! * osint-c.adb (Set_Library_Info_Name): Use canonical case file names ! to check if the specified object file is correct. ! ! 2008-03-26 Thomas Quinot ! ! * sem_cat.adb (Validate_RACW_Primitives): Do not rely on ! Comes_From_Source to exclude primitives from being checked. We want to ! exclude predefined primitives only, so use the appropriate specific ! predicate. Also, flag a formal parameter of an anonymous ! access-to-subprogram type as illegal for a primitive operation of a ! remote access to class-wide type. ! ! 2008-03-26 Vincent Celier ! ! * prj-dect.adb (Parse_Package_Declaration): When a package name is not ! known, check if it may be a missspelling of a known package name. In ! not verbose, not mode, issue warnings only if the package name is a ! possible misspelling. ! In verbose mode, always issue a warning for a not known package name, ! plus a warning if the name is a misspelling of a known package name. ! ! * prj-part.adb (Post_Parse_Context_Clause): Modify so that only non ! limited withs or limited withs are parse during one call. ! (Parse_Single_Project): Post parse context clause in two passes: non ! limited withs before current project and limited withs after current ! project. ! ! * prj-proc.adb (Imported_Or_Extended_Project_From): Returns an extended ! project with the name With_Name, even if it is only extended indirectly. ! (Recursive_Process): Process projects in order: first single withs, then ! current project, then limited withs. ! ! * prj-tree.adb (Imported_Or_Extended_Project_Of): Returns an extended ! project with the name With_Name, even if it is only extended indirectly. ! ! 2008-03-26 Robert Dewar ! ! * scn.adb (Initialize_Scanner): Format messages belong on standard error ! ! 2008-03-26 Ed Schonberg ! ! * sem_ch10.adb (Analyze_Compilation_Unit): if a unit in the context is ! a generic subprogram that is imported, do not attempt to compile ! non-existent body. ! ! * sem_ch12.adb (Instantiate_Subprogram_Body): if the generic is ! imported, do not generate a raise_program_error for the non-existent ! body. ! (Pre_Analyze_Actuals): If an error is detected during pre-analysis, ! perform minimal name resolution on the generic to avoid spurious ! warnings. ! (Find_Actual_Type): the designated type of the actual in a child unit ! may be declared in a parent unit without being an actual. ! ! 2008-03-26 Robert Dewar ! ! * sem_ch11.adb: Fix No_Exception_Restriction violation for SJLJ ! * sinfo.ads, sinfo.adb (From_At_End): New flag ! ! 2008-03-26 Ed Schonberg ! ! * sem_ch6.adb (Analyze_Subprogram_Body): Remove spurious check on ! operations that have an interface parameter. ! (Analyze_Subprogram_Body): Set Is_Trivial_Subprogram flag ! Don't treat No_Return call as raise. ! ! * sem_disp.adb (Check_Dispatching_Operations): apply check for ! non-primitive interface primitives to access parameters, not to all ! parameters of an access type. ! ! 2008-03-26 Ed Schonberg ! ! * sem_ch7.adb (Install_Parent_Private_Declarations): If the private ! declarations of a parent unit are made visible when compiling a child ! instance, the parent is not a hidden open scope, even though it may ! contain other pending instance. ! ! * sem_ch8.adb (Restore_Scope_Stack): If an entry on the stack is a ! hidden open scope for some child instance, it does affect the ! visibility status of other stach entries. ! (Analyze_Object_Renaming): Check that a class-wide object cannot be ! renamed as an object of a specific type. ! ! 2008-03-26 Robert Dewar ! ! * sem_res.adb (Check_Infinite_Recursion): Diagnose definite infinite ! recursion and raise SE directly. ! (Resolve_Actuals): Reset Never_Set_In_Source if warnings off is ! set for formal type for IN mode parameter. ! ! 2008-03-26 Robert Dewar ! ! * sem_warn.ads, sem_warn.adb (Warnings_Off_Pragmas): New table ! (Initialize): New procedure ! (Output_Warnings_Off_Warnings): New procedure ! (Check_References): Suppress certain msgs if Is_Trivial_Subprogram ! (Output_Non_Modifed_In_Out_Warnings): Ditto ! (Warn_On_Unreferenced_Entity): Ditto ! ! 2008-03-26 Vincent Celier ! ! * a-direct.adb (Start_Search): Raise Use_Error if the directory is not ! readable. ! ! 2008-03-26 Matthew Heaney ! ! * a-ciorse.ads, a-cidlli.ads, a-cdlili.ads, a-cihase.ads, a-cohase.ads, ! a-ciorma.ads, a-coorma.ads, a-ciormu.ads, a-coormu.ads, a-coorse.ads: ! Marked with clauses as private, and controlled operations as overriding ! ! 2008-03-26 Robert Dewar ! ! * g-byorma.adb (Read_BOM): Reorder tests so that UTF_32 is recognized ! ! 2008-03-26 Robert Dewar ! ! * back_end.adb, back_end.ads: Minor reformatting ! ! * bindgen.adb: Minor clarification of comments ! ! * fname.ads: Minor comment fixes ! ! * g-altive.ads, g-catiio.ads, g-trasym.ads, prj.ads, ! prj-nmsc.adb, sem_aggr.adb: Minor reformatting ! ! * xeinfo.adb, xnmake.adb, xsinfo.adb, xtreeprs.adb, ! xsnames.adb: Remove warnings off pragma no longer needed ! ! * a-catizo.ads, a-calari.ads, a-calfor.adb, ! a-calfor.ads: Fix header. ! ! 2008-03-26 Tristan Gingold ! ! * init.c: Do not adjust pc for HPARITH on alpha/vms. ! ! 2008-03-26 Robert Dewar ! ! * lib-xref.adb: (OK_To_Set_Reference): New function ! (Generate_Reference): Don't set referenced from occurrence in Warnings, ! Unmodified, or Unreferenced pragma ! ! 2008-03-26 Robert Dewar ! ! * alloc.ads: Add entries for Warnings_Off_Pragmas table ! ! 2008-03-26 GNAT Script ! ! * Make-lang.in: Makefile automatically updated ! ! 2008-03-26 Robert Dewar ! ! * tbuild.ads, tbuild.adb, trans.c, sprint.adb, exp_prag.adb, decl.c, ! par-ch2.adb, sem_elab.adb, sem_util.ads (N_Pragma): Chars field ! removed, use Chars (Pragma_Identifier (.. instead, adjustments ! throughout to accomodate this change. ! ! * s-pooglo.ads, s-pooloc.ads: Minor comment updates ! ! * exp_dbug.adb: Use Sem_Util.Set_Debug_Info_Needed (not ! Einfo.Set_Needs_Debug_Info) ! ! 2008-03-26 Robert Dewar ! ! * gnat_ugn.texi: Add documentation for -gnatw.w/-gnatw.W ! Add description for the new gnatstub option '--header-file' ! clarification of -gnatwz/-gnatwZ ! Add a "Irix-Specific Considerations" section to document the need to ! set LD_LIBRARY_PATH when using the default shared runtime library. ! Added documentation for both gcov and gprof. ! ! * gnat_rm.texi: Document that pragma Compile_Time_Warning generates ! messages that are not suppressed when clients are compiled. ! Add documentation of s-pooglo s-pooloc ! Document the new GNAT.Serial_Communications API. ! Add documentation for 'Old attribute ! Add description of pragma Optimize_Alignment ! ! * ug_words: Add entries for -gnatw.w -gnatw.W ! ! * usage.adb: Add line for -gnatw.w (warn on warnings off) ! ! 2008-03-25 Eric Botcazou ! ! Revert ! 2008-03-05 Eric Botcazou ! PR ada/35186 ! * decl.c (maybe_pad_type): Avoid padding an integral type when ! bumping its alignment is sufficient. ! ! 2008-03-25 Arnaud Charlet ! ! * exp_ch6.adb, exp_disp.adb: Update copyright notice. ! Fix wrong formatting (lines too long) ! ! 2008-03-24 Ralf Wildenhues ! ! * 9drpc.adb, a-caldel-vms.adb, a-caldel.adb, ! a-calend-vms.adb, a-calend.adb, a-calend.ads, ! a-calfor.adb, a-chahan.ads, a-chtgke.adb, ! a-cihama.ads, a-ciorse.adb, a-clrefi.ads, ! a-cohama.ads, a-comlin.ads, a-coorse.adb, ! a-crbtgk.adb, a-direct.adb, a-except-2005.adb, ! a-except-2005.ads, a-except.adb, a-except.ads, ! a-exexda.adb, a-exexpr-gcc.adb, a-exexpr.adb, ! a-exextr.adb, a-filico.ads, a-finali.ads, ! a-intnam-aix.ads, a-intnam-solaris.ads, a-ngcefu.adb, ! a-ngelfu.adb, a-numaux-darwin.adb, a-numeri.ads, ! a-sequio.ads, a-strbou.ads, a-strfix.adb, ! checks.adb, exp_ch3.adb, exp_ch4.adb, ! exp_ch4.ads, exp_ch5.adb, exp_ch6.adb, ! exp_ch6.ads, exp_ch7.adb, exp_ch7.ads, ! exp_ch9.adb, exp_ch9.ads, exp_dbug.adb, ! exp_dbug.ads, exp_disp.adb, exp_dist.adb, ! exp_dist.ads, exp_fixd.adb, exp_fixd.ads: Fix comment typos. ! ! 2008-03-24 Robert Dewar ! ! * s-tpopsp-posix.adb, s-tpopsp-solaris.adb, s-tpopsp-posix-foreign.adb, ! s-tpopsp-lynxos.adb, s-tpopde-vms.ads, s-tpopde-vms.adb, ! s-tpopsp-vxworks.adb, s-casi16.adb, s-caun16.adb, s-inmaop.ads, ! s-tadeca.adb, s-tadeca.ads, s-tadert.adb, s-tadert.ads, s-tpinop.adb, ! s-tpinop.ads, s-tporft.adb, a-rbtgso.adb, a-crbtgo.ads, a-crbtgo.adb, ! a-crbtgk.ads, a-crbtgk.adb, a-ciorse.adb, a-cihama.ads, a-cihama.adb, ! a-cidlli.ads, a-cidlli.adb, a-chtgop.ads, a-chtgop.adb, a-cgcaso.ads, ! a-cgcaso.adb, a-cgaaso.adb, a-ciormu.adb, a-cihase.adb, a-swuwha.ads, ! a-rbtgso.ads, a-cgaaso.ads, a-cgaaso.ads, a-ciorma.adb, a-chtgke.ads, ! a-chtgke.adb, a-llfzti.ads, a-ztenau.adb, a-ztenau.ads, a-stzhas.ads, ! a-szbzha.ads, a-szbzha.adb, a-crdlli.ads, a-crdlli.ads, a-crdlli.adb, ! i-forbla-darwin.adb, i-forbla.ads, s-regexp.adb, a-nllrar.ads, ! a-nlrear.ads, a-nucoar.ads, a-nurear.ads, i-forlap.ads, s-gearop.adb, ! s-gearop.ads, s-gecobl.adb, s-gecobl.ads, s-gecola.adb, s-gecola.ads, ! s-gerebl.adb, s-gerela.ads, a-swuwha.adb, i-forbla-unimplemented.ads, ! double spaced if it fits on one line and otherwise single spaced. ! ! 2008-03-24 Ralf Wildenhues ! ! PR documentation/15479 ! * Make-lang.in (doc/gnat_ugn.texi) Renamed from ... ! (doc/gnat_ugn_unw.texi): ... this, and adjusted. ! (doc/gnat_ugn.info): Renamed from ... ! (doc/gnat_ugn_unw.info): ... this. ! (doc/gnat_ugn.dvi): Renamed from ... ! (doc/gnat_ugn_unw.dvi): ... this. ! (doc/gnat_ugn.pdf): Renamed from ... ! (doc/gnat_ugn_unw.pdf): ... this. ! (ADA_INFOFILES, ADA_PDFFILES, ada.install-info, ada.dvi): ! Adjusted. ! * gnat_ugn.texi (FILE): Hard-code gnat_ugn; set filename ! unconditionally to gnat_ugn.info. Fix cross references to the ! GNAT Reference Manual. Convert links to the GCC, GDB, Emacs, ! and GNU make manuals to be proper texinfo links. ! * gnat_rm.texi: Fix cross references to the GNAT User's Guide. ! ! 2008-03-21 Olivier Hainque ! ! * trans.c (Attribute_to_gnu) <'length>: Compute as (hb < lb) ! ? 0 : hb - lb + 1 instead of max (hb - lb + 1, 0). ! ! 2008-03-21 Eric Botcazou ! ! * trans.c (addressable_p): Add notes on addressability issues. ! ! 2008-03-21 Olivier Hainque ! Ed Schonberg ! ! * trans.c (addressable_p): Accept COND_EXPR when both arms ! are addressable. ! (gnat_gimplify_expr): Let the gimplifier handle &COND_EXPR. ! (call_to_gnu): Do not use name reference in the error message ! for a misaligned by_reference_parameter. The actual may be a ! general expression. ! ! 2008-03-18 Paolo Bonzini ! ! * misc.c (LANG_HOOKS_REDUCE_BIT_FIELD_OPERATIONS): Delete. ! ! 2008-03-15 Ralf Wildenhues ! ! * gnat_rm.texi (Implementation Defined Characteristics) ! (Wide_Text_IO, Wide_Wide_Text_IO): Add @var annotations where ! appropriate. ! * gnat_ugn.texi (Wide Character Encodings, Switches for gnatbind) ! (Switches for gnatchop, Installing a library): Likewise. ! ! 2008-03-10 Eric Botcazou ! ! * trans.c (emit_range_check): Do not emit the check if the base type ! of the expression is the type against which its range must be checked. ! ! 2008-03-08 Eric Botcazou ! ! * decl.c (maybe_pad_type): Use value_factor_p. ! ! 2008-03-08 Eric Botcazou ! ! * lang.opt (nostdlib): Move around. ! * misc.c (gnat_handle_option): Fix formatting. ! (gnat_dwarf_name): Move around. ! * trans.c (Case_Statement_to_gnu): Fix formatting. ! (gnat_to_gnu): Likewise. ! * utils.c (aggregate_type_contains_array_p): Likewise. ! (create_subprog_decl): Likewise. ! ! 2008-03-08 Eric Botcazou ! ! * decl.c (gnat_to_gnu_entity) : Do not ! bother propagating the TYPE_USER_ALIGN flag when creating a JM type. ! ! 2008-03-08 Eric Botcazou ! ! * decl.c (gnat_to_gnu_entity) : Do not force ! BIGGEST_ALIGNMENT when capping the alignment of records with ! strict alignment and size clause. ! ! 2008-03-08 Eric Botcazou ! ! * lang-specs.h: Pass -gnatwa if -Wall is passed. ! * misc.c (gnat_handle_option) : Expand into -Wunused ! and -Wuninitialized. ! (gnat_post_options): Clear warn_unused_parameter. ! ! 2008-03-08 Eric Botcazou ! ! * utils.c (finish_record_type): Clear DECL_BIT_FIELD on sufficiently ! aligned bit-fields, bumping the alignment of the record type if deemed ! profitable. ! (value_factor_p): Return false instead of 0. ! ! 2008-03-08 Eric Botcazou ! ! * decl.c (gnat_to_gnu_entity) : Add support ! for scalar types with small alignment. ! ! 2008-03-08 Eric Botcazou ! ! * trans.c (Loop_Statement_to_gnu): Set the SLOC of the loop label ! from that of the front-end's end label. ! (gnat_gimplify_stmt) : Set the SLOC of the backward goto ! from that of the loop label. ! ! 2008-03-07 Eric Botcazou ! ! * decl.c (gnat_to_gnu_entity) : Add ! comment for the packed array type case. ! * utils.c (build_template): Use a loop to strip padding or ! containing records for justified modular types. ! ! 2008-03-07 Eric Botcazou ! ! * decl.c (gnat_to_gnu_entity): Issue a warning on suspiciously ! large alignments specified for types. ! (validate_alignment): Minor cleanup. ! ! 2008-03-07 Eric Botcazou ! ! * decl.c (MAX_FIXED_MODE_SIZE): Define if not already defined. ! (gnat_to_gnu_entity) : Try to get a smaller form of ! the component for packing, if possible, as well as if a component ! size clause is specified. ! : For an array type used to implement a packed ! array, get the component type from the original array type. ! Try to get a smaller form of the component for packing, if possible, ! as well as if a component size clause is specified. ! (round_up_to_align): New function. ! (make_packable_type): Add in_record parameter. ! For a padding record, preserve the size. If not in_record and the ! size is too large for an integral mode, attempt to shrink the size ! by lowering the alignment. ! Ditch the padding bits of the last component. ! Compute sizes and mode manually, and propagate the RM size. ! Return a BLKmode record type if its size has shrunk. ! (maybe_pad_type): Use MAX_FIXED_MODE_SIZE instead of BIGGEST_ALIGNMENT. ! Use Original_Array_Type to retrieve the type in case of an error. ! Adjust call to make_packable_type. ! (gnat_to_gnu_field): Likewise. ! (concat_id_with_name): Minor tweak. ! * trans.c (larger_record_type_p): New predicate. ! (call_to_gnu): Compute the nominal type of the object only if the ! parameter is by-reference. Do the conversion actual type -> nominal ! type if the nominal type is a larger record. ! (gnat_to_gnu): Do not require integral modes on the source type to ! avoid the conversion for types with identical names. ! (addressable_p): Add gnu_type parameter. If it is specified, do not ! return true if the expression is not addressable in gnu_type. ! Adjust recursive calls. ! * utils.c (finish_record_type): Remove dead code. ! ! 2008-03-05 Eric Botcazou ! ! PR ada/35186 ! * decl.c (maybe_pad_type): Avoid padding an integral type when ! bumping its alignment is sufficient. ! ! 2008-03-02 Ralf Wildenhues ! ! * gnatfind.adb, gnatxref.adb: Fix argument parsing typos. ! * s-auxdec-empty.adb, s-auxdec.adb: Fix typos in copyright ! statement. ! * a-ngcoar.adb, a-ngrear.adb, g-awk.adb, g-debpoo.adb, ! gprep.adb, make.adb, makegpr.adb, par-ch6.adb, prj-nmsc.adb, ! sem_attr.adb, sem_ch4.adb, sem_ch8.adb: Fix typos in ada source ! code output strings. ! * sem_type.adb, system-vms-ia64.ads, system-vms.ads, ! system-vms_64.ads: Fix typos in ada source code comments. ! * sinfo-cn.adb: Remove incomplete sentence. ! ! PR documentation/15479 ! * gnat_rm.texi, gnat_ugn.texi: Avoid standalone `non' word. ! ! 2008-02-27 Samuel Tardieu ! ! PR ada/22255 ! * s-fileio.adb (Reset): Do not raise Use_Error if mode isn't changed. ! ! 2008-02-27 Samuel Tardieu ! ! PR ada/34799 ! * sem_ch13.adb (Analyze_Record_Representation_Clause): Check ! that underlying type is present. ! ! 2008-02-26 Tom Tromey ! ! * misc.c (internal_error_function): Remove test of ! USE_MAPPED_LOCATION. ! * trans.c (gigi): Remove test of USE_MAPPED_LOCATION. ! (Sloc_to_locus): Remove old location code. ! ! 2008-02-25 Ralf Wildenhues ! ! * gnat_rm.texi, gnat_ugn.texi: Fix spacing after `e.g.' and ! `i.e.' by adding comma or `@:' as appropriate. ! * gnat_rm.texi (Pragma Wide_Character_Encoding): Instead of ! plain characters `C', use `@samp{C}'. ! * gnat_ugn.texi (File Naming Rules, About gnatkr) ! (Krunching Method): Likewise. ! ! * gnat_ugn.texi (Conventions): List environment variables and ! metasyntactic variables. ! (Compiling Programs): Fix notation of metasyntactic variables. ! Add @file where appropriate. Use @file for file extensions, ! @samp for strings. ! * gnat_rm.texi, gnat_ugn.texi: Where appropriate, use @samp ! instead of @file, @env instead of @code. ! ! 2008-02-24 Ralf Wildenhues ! ! PR documentation/15479 ! * gnat_rm.texi, gnat_ugn.texi: Where appropriate, replace `..' ! and `...' with `@dots{}' or `@enddots{}'. ! ! PR documentation/15479 ! * gnat_rm.texi, gnat_ugn.texi: Where appropriate, add @command, ! use @command instead of @code, @option instead of @samp or @code, ! @code instead of @var, @samp instead of @file. ! ! PR documentation/15479 ! * gnat_ugn.texi (Using gnatmake in a Makefile): Do not ignore errors ! in Makefile rules, by using `&&' rather than `;'. 2008-02-17 Ralf Wildenhues *************** *** 132,138 **** sample. * gnat_rm.texi, gnat_ugn.texi: Fix typos. Bump copyright years. ! 2008-02-11 Joel Sherrill PR ada/35143 * env.c: Add __rtems__ to if defined. --- 8609,8615 ---- sample. * gnat_rm.texi, gnat_ugn.texi: Fix typos. Bump copyright years. ! 2008-02-11 Joel Sherrill PR ada/35143 * env.c: Add __rtems__ to if defined. *************** *** 179,185 **** 2008-01-13 Eric Botcazou ! * trans.c (call_to_gnu):Invoke the addressable_p predicate only when necessary. Merge some conditional statements. Update comments. Rename unchecked_convert_p local variable to suppress_type_conversion. Do not suppress conversions in the In case. --- 8656,8662 ---- 2008-01-13 Eric Botcazou ! * trans.c (call_to_gnu): Invoke the addressable_p predicate only when necessary. Merge some conditional statements. Update comments. Rename unchecked_convert_p local variable to suppress_type_conversion. Do not suppress conversions in the In case. *************** *** 208,214 **** for the C macro for setting individual bit. (pthread_setaffinity_np): New imported routine. ! 2008-01-03 Tero Koskinen PR ada/34647 * adaint.c (__gnat_open_new_temp, __gnat_tmp_name): Use mkstemp() --- 8685,8691 ---- for the C macro for setting individual bit. (pthread_setaffinity_np): New imported routine. ! 2008-01-03 Tero Koskinen PR ada/34647 * adaint.c (__gnat_open_new_temp, __gnat_tmp_name): Use mkstemp() *************** *** 243,249 **** 2007-12-19 Robert Dewar ! * g-expect-vms.adb, g-expect.adb, s-poosiz.adb: Add pragma Warnings (Off) for unassigned IN OUT arguments * sem_warn.adb (Output_Reference): Suppress messages for internal names --- 8720,8726 ---- 2007-12-19 Robert Dewar ! * g-expect-vms.adb, g-expect.adb, s-poosiz.adb: Add pragma Warnings (Off) for unassigned IN OUT arguments * sem_warn.adb (Output_Reference): Suppress messages for internal names *************** *** 312,318 **** * errout.adb (First_Node): Use Traverse_Proc instead of Traverse_Func, because the former already takes care of discarding the result. (Remove_Warning_Messages): Use appropriate subtype for Status and ! Discard 2007-12-19 Ed Schonberg --- 8789,8795 ---- * errout.adb (First_Node): Use Traverse_Proc instead of Traverse_Func, because the former already takes care of discarding the result. (Remove_Warning_Messages): Use appropriate subtype for Status and ! Discard 2007-12-19 Ed Schonberg *************** *** 472,478 **** * adaint.c (__gnat_pthread_setaffinity_np): New routine. A dummy version is provided for older GNU/Linux distribution not supporting thread affinity sets. ! * s-osinte-linux.ads (SC_NPROCESSORS_ONLN): New constant for sysconf call. (bit_field): New packed boolean type used by cpu_set_t. --- 8949,8955 ---- * adaint.c (__gnat_pthread_setaffinity_np): New routine. A dummy version is provided for older GNU/Linux distribution not supporting thread affinity sets. ! * s-osinte-linux.ads (SC_NPROCESSORS_ONLN): New constant for sysconf call. (bit_field): New packed boolean type used by cpu_set_t. *************** *** 481,503 **** field array for the affinity mask. There is not need for the C macro for setting individual bit. (pthread_setaffinity_np): New imported routine. ! * s-taprop-linux.adb (Enter_Task): Check that the CPU affinity mask is no null. (Create_Task): Set the processor affinity mask if information is present. ! * s-tasinf-linux.ads, s-tasinf-linux.adb: New files. ! 2007-12-13 Robert Dewar ! * s-osinte-lynxos-3.ads, s-osinte-hpux.ads, s-osinte-solaris-posix.ads, ! s-osinte-freebsd.ads, s-osinte-lynxos.ads, s-osinte-tru64.ads, ! s-osinte-mingw.ads, s-osinte-aix.ads, s-osinte-hpux-dce.ads, s-osinte-irix.ads, s-osinte-solaris.ads, s-intman-vms.adb, s-osinte-vms.ads, s-osinte-vxworks6.ads, s-osinte-vxworks.ads, ! s-auxdec.ads, s-auxdec-vms_64.ads, s-osinte-darwin.ads, ! s-taprop-vms.adb, s-interr-sigaction.adb, s-osinte-linux-hppa.ads, i-vxwork-x86.ads, s-tpopde-vms.ads: Add missing pragma Convention C for subprogram pointers. --- 8958,8980 ---- field array for the affinity mask. There is not need for the C macro for setting individual bit. (pthread_setaffinity_np): New imported routine. ! * s-taprop-linux.adb (Enter_Task): Check that the CPU affinity mask is no null. (Create_Task): Set the processor affinity mask if information is present. ! * s-tasinf-linux.ads, s-tasinf-linux.adb: New files. ! 2007-12-13 Robert Dewar ! * s-osinte-lynxos-3.ads, s-osinte-hpux.ads, s-osinte-solaris-posix.ads, ! s-osinte-freebsd.ads, s-osinte-lynxos.ads, s-osinte-tru64.ads, ! s-osinte-mingw.ads, s-osinte-aix.ads, s-osinte-hpux-dce.ads, s-osinte-irix.ads, s-osinte-solaris.ads, s-intman-vms.adb, s-osinte-vms.ads, s-osinte-vxworks6.ads, s-osinte-vxworks.ads, ! s-auxdec.ads, s-auxdec-vms_64.ads, s-osinte-darwin.ads, ! s-taprop-vms.adb, s-interr-sigaction.adb, s-osinte-linux-hppa.ads, i-vxwork-x86.ads, s-tpopde-vms.ads: Add missing pragma Convention C for subprogram pointers. *************** *** 521,535 **** Bob Duff Tristan Gingold ! * system-linux-ia64.ads, system-freebsd-x86.ads, system-lynxos-ppc.ads, ! system-lynxos-x86.ads, system-linux-x86_64.ads, system-tru64.ads, ! system-aix.ads, system-vxworks-sparcv9.ads, system-solaris-x86.ads, ! system-irix-o32.ads, system-irix-n32.ads, system-hpux.ads, ! system-vxworks-m68k.ads, system-linux-x86.ads, system-vxworks-mips.ads, ! system-solaris-sparc.ads, system-solaris-sparcv9.ads, system-vms.ads, ! system-mingw.ads, system-vms-zcx.ads, system-vxworks-ppc.ads, system-vxworks-arm.ads, system-darwin-x86.ads, system.ads, ! system-vms_64.ads, system-darwin-ppc.ads, system-vxworks-x86.ads, system-linux-ppc.ads, system-linux-hppa.ads, system-hpux-ia64.ads, system-vms-ia64.ads (Stack_Check_Limits): New target parameter. (Always_Compatible_Rep): New flag to control trampolines globally. --- 8998,9012 ---- Bob Duff Tristan Gingold ! * system-linux-ia64.ads, system-freebsd-x86.ads, system-lynxos-ppc.ads, ! system-lynxos-x86.ads, system-linux-x86_64.ads, system-tru64.ads, ! system-aix.ads, system-vxworks-sparcv9.ads, system-solaris-x86.ads, ! system-irix-o32.ads, system-irix-n32.ads, system-hpux.ads, ! system-vxworks-m68k.ads, system-linux-x86.ads, system-vxworks-mips.ads, ! system-solaris-sparc.ads, system-solaris-sparcv9.ads, system-vms.ads, ! system-mingw.ads, system-vms-zcx.ads, system-vxworks-ppc.ads, system-vxworks-arm.ads, system-darwin-x86.ads, system.ads, ! system-vms_64.ads, system-darwin-ppc.ads, system-vxworks-x86.ads, system-linux-ppc.ads, system-linux-hppa.ads, system-hpux-ia64.ads, system-vms-ia64.ads (Stack_Check_Limits): New target parameter. (Always_Compatible_Rep): New flag to control trampolines globally. *************** *** 540,546 **** * s-taprop-vxworks.adb: Use stack limit method of stack checking. Simply indirectly call s-stchop when a task is created. ! * ali.ads: New flag added: Stack_Check_Switch_Set which is set when '-fstack-check' appears as an argument (entries A) in an ALI file. --- 9017,9023 ---- * s-taprop-vxworks.adb: Use stack limit method of stack checking. Simply indirectly call s-stchop when a task is created. ! * ali.ads: New flag added: Stack_Check_Switch_Set which is set when '-fstack-check' appears as an argument (entries A) in an ALI file. *************** *** 565,572 **** 2007-12-13 Robert Dewar ! * sem_ch5.adb, s-taskin.adb, a-ciorma.adb, a-coorma.adb, a-cohama.adb, ! a-cihama.adb, g-awk.adb, s-inmaop-posix.adb: Update handling of assigned value/unreferenced warnings --- 9042,9049 ---- 2007-12-13 Robert Dewar ! * sem_ch5.adb, s-taskin.adb, a-ciorma.adb, a-coorma.adb, a-cohama.adb, ! a-cihama.adb, g-awk.adb, s-inmaop-posix.adb: Update handling of assigned value/unreferenced warnings *************** *** 578,584 **** * lib-xref.ads: Improve documentation for k xref type ! * lib-xref.adb: Update handling of assigned value/unreferenced warnings (Generate_Reference): Warning for reference to entity for which a pragma Unreferenced has been given should be unconditional. --- 9055,9061 ---- * lib-xref.ads: Improve documentation for k xref type ! * lib-xref.adb: Update handling of assigned value/unreferenced warnings (Generate_Reference): Warning for reference to entity for which a pragma Unreferenced has been given should be unconditional. *************** *** 608,614 **** EXTRA_GNATRTL_NONTASKING_OBJS, EXTRA_GNATRTL_TASKING_OBJS, GNATLIB_SHARED for RTX run time): Use the versions required by RTX. ! * mingw32.h: Do not define GNAT_UNICODE_SUPPORT for RTX since it is not supported. * sysdep.c (winflush_function for RTX): Procedure that does nothing --- 9085,9091 ---- EXTRA_GNATRTL_NONTASKING_OBJS, EXTRA_GNATRTL_TASKING_OBJS, GNATLIB_SHARED for RTX run time): Use the versions required by RTX. ! * mingw32.h: Do not define GNAT_UNICODE_SUPPORT for RTX since it is not supported. * sysdep.c (winflush_function for RTX): Procedure that does nothing *************** *** 619,625 **** 2007-12-13 Robert Dewar ! * a-textio.adb, a-textio.ads: Extensive changes to private part for wide character encoding * a-witeio.adb, a-witeio.ads, a-ztexio.ads, a-ztexio.adb --- 9096,9102 ---- 2007-12-13 Robert Dewar ! * a-textio.adb, a-textio.ads: Extensive changes to private part for wide character encoding * a-witeio.adb, a-witeio.ads, a-ztexio.ads, a-ztexio.adb *************** *** 662,668 **** * opt.adb: New pragma Fast_Math ! * par-prag.adb: Add Implemented_By_Entry to the list of pragmas which do not require any special processing. (Favor_Top_Level): New pragma. --- 9139,9145 ---- * opt.adb: New pragma Fast_Math ! * par-prag.adb: Add Implemented_By_Entry to the list of pragmas which do not require any special processing. (Favor_Top_Level): New pragma. *************** *** 703,709 **** New pragma Fast_Math (Analyze_Pragma, case No_Return): Handle generic instance ! * snames.h, snames.ads, snames.adb: Add new predefined name for interface primitive _Disp_Requeue. New pragma Fast_Math --- 9180,9186 ---- New pragma Fast_Math (Analyze_Pragma, case No_Return): Handle generic instance ! * snames.h, snames.ads, snames.adb: Add new predefined name for interface primitive _Disp_Requeue. New pragma Fast_Math *************** *** 743,749 **** 2007-12-13 Geert Bosch ! * a-tifiio.adb: (Put_Int64): Use Put_Digit to advance Pos. This fixes a case where the second or later Scaled_Divide would omit leading zeroes, resulting in too few digits produced and a Layout_Error as result. --- 9220,9226 ---- 2007-12-13 Geert Bosch ! * a-tifiio.adb: (Put_Int64): Use Put_Digit to advance Pos. This fixes a case where the second or later Scaled_Divide would omit leading zeroes, resulting in too few digits produced and a Layout_Error as result. *************** *** 771,777 **** (Find_Interface_ADT): Modified to fulfill the new specification. Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List ! * par-ch4.adb, nlists.ads, nlists.adb: Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List * sinfo.ads, sinfo.adb: (Nkind_In): New functions --- 9248,9254 ---- (Find_Interface_ADT): Modified to fulfill the new specification. Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List ! * par-ch4.adb, nlists.ads, nlists.adb: Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List * sinfo.ads, sinfo.adb: (Nkind_In): New functions *************** *** 781,787 **** 2007-12-13 Vincent Celier ! * opt.ads: Indicate what flags are used by the Project Manager, gprbuild and gprclean. (Opt.Follow_Links_For_Dirs): New flag --- 9258,9264 ---- 2007-12-13 Vincent Celier ! * opt.ads: Indicate what flags are used by the Project Manager, gprbuild and gprclean. (Opt.Follow_Links_For_Dirs): New flag *************** *** 813,819 **** passing a pointer to a procedure. This is to eliminate trampolines (since the Callback procedure is usually nested). ! * gnatfind.adb, switch.adb, switch.ads, gnatlink.adb, gnatls.adb, gnatname.adb, gnatxref.adb, gnatchop.adb, gprep.adb, gnatbind.adb (Check_Version_And_Help): Change Check_Version_And_Help to be generic. --- 9290,9296 ---- passing a pointer to a procedure. This is to eliminate trampolines (since the Callback procedure is usually nested). ! * gnatfind.adb, switch.adb, switch.ads, gnatlink.adb, gnatls.adb, gnatname.adb, gnatxref.adb, gnatchop.adb, gprep.adb, gnatbind.adb (Check_Version_And_Help): Change Check_Version_And_Help to be generic. *************** *** 1061,1067 **** * g-speche.adb: Use generic routine in g-spchge ! * s-wchcnv.ads, s-wchcnv.adb: Minor code cleanup (make formal type consistent with spec) * namet.adb: Update comments. --- 9538,9544 ---- * g-speche.adb: Use generic routine in g-spchge ! * s-wchcnv.ads, s-wchcnv.adb: Minor code cleanup (make formal type consistent with spec) * namet.adb: Update comments. *************** *** 1192,1198 **** * prj-pars.adb: new parameter Current_Dir ! * prj-part.ads, prj-part.adb: Change Opt.Follow_Links to Opt.Follow_Links_For_Files. (Opt.Follow_Links_For_Dirs): New flag (Project_Path_Name_Of): Cache information returned by this routine as --- 9669,9675 ---- * prj-pars.adb: new parameter Current_Dir ! * prj-part.ads, prj-part.adb: Change Opt.Follow_Links to Opt.Follow_Links_For_Files. (Opt.Follow_Links_For_Dirs): New flag (Project_Path_Name_Of): Cache information returned by this routine as *************** *** 1265,1274 **** * s-imenne.adb, s-imenne.ads: New files. ! * s-imgboo.adb, s-imgboo.ads, s-imgcha.adb, s-imgcha.ads, s-imgdec.adb, ! s-imgdec.ads, s-imgenu.ads, s-imgint.adb, s-imgint.ads, s-imglld.adb, ! s-imglld.ads, s-imglli.adb, s-imglli.ads, s-imgllu.adb, s-imgllu.ads, ! s-imgrea.adb, s-imgrea.ads, s-imguns.adb, s-imguns.ads, s-imgwch.adb, s-imgwch.ads: New calling sequence for Image routines to avoid sec stack usage. --- 9742,9751 ---- * s-imenne.adb, s-imenne.ads: New files. ! * s-imgboo.adb, s-imgboo.ads, s-imgcha.adb, s-imgcha.ads, s-imgdec.adb, ! s-imgdec.ads, s-imgenu.ads, s-imgint.adb, s-imgint.ads, s-imglld.adb, ! s-imglld.ads, s-imglli.adb, s-imglli.ads, s-imgllu.adb, s-imgllu.ads, ! s-imgrea.adb, s-imgrea.ads, s-imguns.adb, s-imguns.ads, s-imgwch.adb, s-imgwch.ads: New calling sequence for Image routines to avoid sec stack usage. *************** *** 1433,1439 **** 2007-12-13 Arnaud Charlet ! * s-tassta.adb: (Create_Task): Take into account tasks created by foreign threads. Code clean up: use constants instead of hard coded values. --- 9910,9916 ---- 2007-12-13 Arnaud Charlet ! * s-tassta.adb: (Create_Task): Take into account tasks created by foreign threads. Code clean up: use constants instead of hard coded values. *************** *** 1459,1465 **** 2007-12-13 Robert Dewar ! * tbuild.ads, tbuild.adb: Fix location of flag for unrecognized pragma message 2007-12-13 Robert Dewar --- 9936,9942 ---- 2007-12-13 Robert Dewar ! * tbuild.ads, tbuild.adb: Fix location of flag for unrecognized pragma message 2007-12-13 Robert Dewar *************** *** 1502,1508 **** * sem_case.adb: Minor reformatting * s-fileio.adb: Minor reformattinng * s-vmexta.ads: Minor typo ! * vxaddr2line.adb: Take into account 'Success' value as per new GNAT warning. 2007-12-13 Vincent Celier --- 9979,9985 ---- * sem_case.adb: Minor reformatting * s-fileio.adb: Minor reformattinng * s-vmexta.ads: Minor typo ! * vxaddr2line.adb: Take into account 'Success' value as per new GNAT warning. 2007-12-13 Vincent Celier *************** *** 1591,1597 **** 2007-12-13 Geert Bosch ! * s-parame-vxworks.adb: Update comments to reflect usage of this package by Nucleus. 2007-12-13 Arnaud Charlet --- 10068,10074 ---- 2007-12-13 Geert Bosch ! * s-parame-vxworks.adb: Update comments to reflect usage of this package by Nucleus. 2007-12-13 Arnaud Charlet *************** *** 1629,1635 **** * decl.c (gnat_to_gnu_entity) : When computing the designated full view, only follow a second level Full_View link for Non_Limited_Views of from_limited_with references. ! 2007-12-07 Samuel Tardieu PR ada/15805 --- 10106,10112 ---- * decl.c (gnat_to_gnu_entity) : When computing the designated full view, only follow a second level Full_View link for Non_Limited_Views of from_limited_with references. ! 2007-12-07 Samuel Tardieu PR ada/15805 *************** *** 1675,1687 **** * exp_ch9.adb (Build_Simple_Entry_Call): Initialize OUT access type parameters of an entry call. ! 2007-12-03 Robert Dewar ! Samuel Tardieu PR ada/34287 * sem_util.adb (Safe_To_Capture_Value): Do not capture values of variables declared in a library-level package. ! 2007-12-02 Samuel Tardieu * clean.adb (Clean_Library_Directory): Use Empty_String'Access intead --- 10152,10164 ---- * exp_ch9.adb (Build_Simple_Entry_Call): Initialize OUT access type parameters of an entry call. ! 2007-12-03 Robert Dewar ! Samuel Tardieu PR ada/34287 * sem_util.adb (Safe_To_Capture_Value): Do not capture values of variables declared in a library-level package. ! 2007-12-02 Samuel Tardieu * clean.adb (Clean_Library_Directory): Use Empty_String'Access intead *************** *** 1735,1744 **** 2007-11-26 Andreas Krebbel ! PR 34081/C++ ! * trans.c (Subprogram_Body_to_gnu, Compilation_Unit_to_gnu): ! Pass 'false' for the new allocate_struct_function parameter. ! * utils.c (build_function_stub): Likewise. 2007-11-25 Richard Guenther --- 10212,10221 ---- 2007-11-26 Andreas Krebbel ! PR 34081/C++ ! * trans.c (Subprogram_Body_to_gnu, Compilation_Unit_to_gnu): ! Pass 'false' for the new allocate_struct_function parameter. ! * utils.c (build_function_stub): Likewise. 2007-11-25 Richard Guenther *************** *** 1775,1781 **** * trans.c (gnat_to_gnu) : Reformat lines to fit in 80 columns. ! 2007-11-21 Aurelien Jarno * s-osinte-kfreebsd-gnu.ads (To_Target_Priority): New function. * Makefile.in: Add EH_MECHANISM=-gcc to kfreebsd-gnu. Remove SYMLIB. --- 10252,10258 ---- * trans.c (gnat_to_gnu) : Reformat lines to fit in 80 columns. ! 2007-11-21 Aurelien Jarno * s-osinte-kfreebsd-gnu.ads (To_Target_Priority): New function. * Makefile.in: Add EH_MECHANISM=-gcc to kfreebsd-gnu. Remove SYMLIB. *************** *** 1801,1807 **** here to ... * trans.c (gnat_to_gnu) : ... here, and don't expect a super-aligned address for a fat or thin pointer. ! 2007-11-14 Eric Botcazou * trans.c (call_to_gnu): Always set the source location on the call --- 10278,10284 ---- here to ... * trans.c (gnat_to_gnu) : ... here, and don't expect a super-aligned address for a fat or thin pointer. ! 2007-11-14 Eric Botcazou * trans.c (call_to_gnu): Always set the source location on the call *************** *** 1884,1890 **** PR bootstrap/33608 * tracebak.c: #undef abort after including system.h. ! 2007-10-20 Danny Smith * Makefile.in (LIBGNAT_TARGET_PAIRS) Add s-tasinf-mingw.adb, s-tasinf-mingw.ads, a-exetim-mingw.adb, a-exetim-mingw.ads --- 10361,10367 ---- PR bootstrap/33608 * tracebak.c: #undef abort after including system.h. ! 2007-10-20 Danny Smith * Makefile.in (LIBGNAT_TARGET_PAIRS) Add s-tasinf-mingw.adb, s-tasinf-mingw.ads, a-exetim-mingw.adb, a-exetim-mingw.ads *************** *** 1903,1923 **** 2007-10-15 Robert Dewar ! * s-taprop-solaris.adb, s-taprop-vms.adb, s-taprop-mingw.adb, s-taprop-vxworks.adb, s-taprop-posix.adb, a-calend-vms.adb, ! a-calend.adb, a-nuflra.adb, a-tigeau.adb, a-wtgeau.adb, ! checks.adb, bindgen.adb, eval_fat.adb, exp_fixd.adb, fmap.adb, ! freeze.adb, g-awk.adb, g-calend.adb, g-diopit.adb, g-expect.adb, ! gnatchop.adb, gnatlink.adb, g-spipat.adb, g-thread.adb, make.adb, ! mdll.adb, mlib.adb, mlib-prj.adb, osint.adb, par-ch3.adb, prj.adb, ! prj-makr.adb, sem_prag.adb, sem_type.adb, s-fatgen.adb, s-fileio.adb, ! sinfo.ads, sinput-d.adb, s-taasde.adb, s-tasdeb.ads, s-tasren.adb, s-tassta.adb, s-tpobop.adb, s-tposen.adb, stylesw.adb, types.ads, ! uintp.adb, validsw.adb, makegpr.adb, a-rbtgso.adb, a-crbtgo.adb, ! a-coorse.adb, a-convec.adb, a-coinve.adb, a-cohama.adb, a-ciorse.adb, ! a-cihama.adb, a-cidlli.adb, a-chtgop.adb, a-cdlili.adb, a-cdlili.adb, ! a-coormu.adb, a-ciormu.adb, a-cihase.adb, a-cohase.adb, a-ciorma.adb, ! a-coorma.adb, a-ztgeau.adb, symbols-vms.adb, a-crdlli.adb, a-calari.adb, a-calfor.adb, s-os_lib.adb, s-regpat.adb, a-ngrear.adb: Minor reformatting. Add Unreferenced and Warnings (Off) pragmas for cases of --- 10380,10400 ---- 2007-10-15 Robert Dewar ! * s-taprop-solaris.adb, s-taprop-vms.adb, s-taprop-mingw.adb, s-taprop-vxworks.adb, s-taprop-posix.adb, a-calend-vms.adb, ! a-calend.adb, a-nuflra.adb, a-tigeau.adb, a-wtgeau.adb, ! checks.adb, bindgen.adb, eval_fat.adb, exp_fixd.adb, fmap.adb, ! freeze.adb, g-awk.adb, g-calend.adb, g-diopit.adb, g-expect.adb, ! gnatchop.adb, gnatlink.adb, g-spipat.adb, g-thread.adb, make.adb, ! mdll.adb, mlib.adb, mlib-prj.adb, osint.adb, par-ch3.adb, prj.adb, ! prj-makr.adb, sem_prag.adb, sem_type.adb, s-fatgen.adb, s-fileio.adb, ! sinfo.ads, sinput-d.adb, s-taasde.adb, s-tasdeb.ads, s-tasren.adb, s-tassta.adb, s-tpobop.adb, s-tposen.adb, stylesw.adb, types.ads, ! uintp.adb, validsw.adb, makegpr.adb, a-rbtgso.adb, a-crbtgo.adb, ! a-coorse.adb, a-convec.adb, a-coinve.adb, a-cohama.adb, a-ciorse.adb, ! a-cihama.adb, a-cidlli.adb, a-chtgop.adb, a-cdlili.adb, a-cdlili.adb, ! a-coormu.adb, a-ciormu.adb, a-cihase.adb, a-cohase.adb, a-ciorma.adb, ! a-coorma.adb, a-ztgeau.adb, symbols-vms.adb, a-crdlli.adb, a-calari.adb, a-calfor.adb, s-os_lib.adb, s-regpat.adb, a-ngrear.adb: Minor reformatting. Add Unreferenced and Warnings (Off) pragmas for cases of *************** *** 1925,1931 **** the resulting values are not subsequently referenced. In a few cases, we also remove redundant code found by the new warnings. ! * ug_words, vms_data.ads, usage.adb, sem_util.adb, sem_util.ads, sem_warn.adb, sem_warn.ads, sem_res.adb, sem_ch7.adb, sem_ch8.adb, sem_ch5.adb, opt.ads, lib-xref.adb, lib-xref.ads, exp_smem.adb, sem_ch11.adb, exp_ch6.adb, einfo.ads, einfo.adb: implement a new --- 10402,10408 ---- the resulting values are not subsequently referenced. In a few cases, we also remove redundant code found by the new warnings. ! * ug_words, vms_data.ads, usage.adb, sem_util.adb, sem_util.ads, sem_warn.adb, sem_warn.ads, sem_res.adb, sem_ch7.adb, sem_ch8.adb, sem_ch5.adb, opt.ads, lib-xref.adb, lib-xref.ads, exp_smem.adb, sem_ch11.adb, exp_ch6.adb, einfo.ads, einfo.adb: implement a new *************** *** 2160,2166 **** * g-soccon-vms.ads: Fix value of MSG_WAITALL. ! * gen-soccon.c: Update documentation to note that OpenVMS 8.3 or later must be used to generate g-soccon-vms.ads. --- 10637,10643 ---- * g-soccon-vms.ads: Fix value of MSG_WAITALL. ! * gen-soccon.c: Update documentation to note that OpenVMS 8.3 or later must be used to generate g-soccon-vms.ads. *************** *** 2251,2263 **** 2007-09-26 Hristian Kirtchev ! * a-calend-vms.adb, a-calend.adb: Add a section on leap seconds control along with two entities used to enable and disable leap seconds support. The array Leap_Second_Times is now constant and contains hard time values pre-generated. Remove all elaboration code used to populate the table of leap seconds. ! * bindgen.adb: Add entity Leap_Seconds_Support to the list of global run-time variables along with a comment on its usage and values. (Gen_Adainit_Ada): Add code to generate the declaration and import of --- 10728,10740 ---- 2007-09-26 Hristian Kirtchev ! * a-calend-vms.adb, a-calend.adb: Add a section on leap seconds control along with two entities used to enable and disable leap seconds support. The array Leap_Second_Times is now constant and contains hard time values pre-generated. Remove all elaboration code used to populate the table of leap seconds. ! * bindgen.adb: Add entity Leap_Seconds_Support to the list of global run-time variables along with a comment on its usage and values. (Gen_Adainit_Ada): Add code to generate the declaration and import of *************** *** 2318,2329 **** 2007-09-26 Javier Miranda Eric Botcazou ! * a-tags.adb: (Get_HT_Link/Set_HT_Link): Updated to handle the additional level of indirection added to the HT_Link component of the TSD. This is required to statically allocate the TSD. ! * a-tags.ads: Minor reordering of the declarations in the private part. Required to add a level of indirection to the contents of the TSD component HT_Link. This is required to statically allocate the TSD. --- 10795,10806 ---- 2007-09-26 Javier Miranda Eric Botcazou ! * a-tags.adb: (Get_HT_Link/Set_HT_Link): Updated to handle the additional level of indirection added to the HT_Link component of the TSD. This is required to statically allocate the TSD. ! * a-tags.ads: Minor reordering of the declarations in the private part. Required to add a level of indirection to the contents of the TSD component HT_Link. This is required to statically allocate the TSD. *************** *** 2396,2402 **** of each extra formal of a protected operation to reference the corresponding extra formal of the subprogram denoted by the operation's Protected_Body_Subprogram. ! * sinfo.ads, sinfo.adb (Is_Expanded_Build_In_Place_Call): New flag on N_Function_Call nodes. --- 10873,10879 ---- of each extra formal of a protected operation to reference the corresponding extra formal of the subprogram denoted by the operation's Protected_Body_Subprogram. ! * sinfo.ads, sinfo.adb (Is_Expanded_Build_In_Place_Call): New flag on N_Function_Call nodes. *************** *** 2660,2673 **** s-stoele.adb, s-strcom.adb, s-strops.adb, s-traceb.adb, s-traent.adb, s-wchcnv.adb, s-wchcon.adb, s-wchjis.adb, s-addope.adb, s-except.adb, s-os_lib.adb, s-string.adb, s-utf_32.adb, a-elchha.adb, ! a-chlat1.ads, a-elchha.ads, a-except.ads, g-hesora.ads, g-htable.ads, ! g-speche.ads, par-prag.adb, restrict.adb, restrict.ads, s-assert.ads, ! s-carun8.ads, s-casuti.ads, s-crc32.ads, sem_ch11.adb, sem_prag.adb, ! s-exctab.ads, s-htable.ads, s-imgenu.ads, s-mastop.ads, snames.adb, ! snames.ads, snames.h, s-purexc.ads, s-secsta.ads, s-soflin.ads, ! s-sopco3.ads, s-sopco4.ads, s-sopco5.ads, s-stache.ads, s-stalib.ads, ! s-stoele.ads, s-strcom.ads, s-strops.ads, s-traceb.ads, s-traent.ads, ! s-unstyp.ads, s-wchcnv.ads, s-wchcon.ads, s-wchjis.ads, s-addope.ads, s-except.ads, s-os_lib.ads, s-string.ads, s-utf_32.ads: Implement pragma Compiler_Unit and adds it to relevant library units. --- 11137,11150 ---- s-stoele.adb, s-strcom.adb, s-strops.adb, s-traceb.adb, s-traent.adb, s-wchcnv.adb, s-wchcon.adb, s-wchjis.adb, s-addope.adb, s-except.adb, s-os_lib.adb, s-string.adb, s-utf_32.adb, a-elchha.adb, ! a-chlat1.ads, a-elchha.ads, a-except.ads, g-hesora.ads, g-htable.ads, ! g-speche.ads, par-prag.adb, restrict.adb, restrict.ads, s-assert.ads, ! s-carun8.ads, s-casuti.ads, s-crc32.ads, sem_ch11.adb, sem_prag.adb, ! s-exctab.ads, s-htable.ads, s-imgenu.ads, s-mastop.ads, snames.adb, ! snames.ads, snames.h, s-purexc.ads, s-secsta.ads, s-soflin.ads, ! s-sopco3.ads, s-sopco4.ads, s-sopco5.ads, s-stache.ads, s-stalib.ads, ! s-stoele.ads, s-strcom.ads, s-strops.ads, s-traceb.ads, s-traent.ads, ! s-unstyp.ads, s-wchcnv.ads, s-wchcon.ads, s-wchjis.ads, s-addope.ads, s-except.ads, s-os_lib.ads, s-string.ads, s-utf_32.ads: Implement pragma Compiler_Unit and adds it to relevant library units. *************** *** 2714,2720 **** 2007-09-12 Thomas Quinot ! * g-soccon-solaris-64.ads, g-soccon-hpux-ia64.ads: Add new constant Thread_Blocking_IO, always True by default, set False on a per-runtime basis. (Need_Netdb_Buffer): New constant. --- 11191,11197 ---- 2007-09-12 Thomas Quinot ! * g-soccon-solaris-64.ads, g-soccon-hpux-ia64.ads: Add new constant Thread_Blocking_IO, always True by default, set False on a per-runtime basis. (Need_Netdb_Buffer): New constant. *************** *** 2769,2775 **** Also return inner allocator node, when present, so that we do not have to look for that node again in the caller. ! 2007-09-11 Jan Hubicka * misc.c (gnat_expand_body): Kill. (LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION): Kill. --- 11246,11252 ---- Also return inner allocator node, when present, so that we do not have to look for that node again in the caller. ! 2007-09-11 Jan Hubicka * misc.c (gnat_expand_body): Kill. (LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION): Kill. *************** *** 2965,2971 **** 2007-02-07 Andreas Krebbel * raise-gcc.c (get_region_description_for, get_call_site_action_for, ! get_action_description_for): Replace _Unwind_Word with _uleb128_t and _Unwind_SWord with _sleb128_t. 2007-09-06 Eric Botcazou --- 11442,11448 ---- 2007-02-07 Andreas Krebbel * raise-gcc.c (get_region_description_for, get_call_site_action_for, ! get_action_description_for): Replace _Unwind_Word with _uleb128_t and _Unwind_SWord with _sleb128_t. 2007-09-06 Eric Botcazou *************** *** 2992,2998 **** PR ada/4720 ! * gnatchop.adb, gnatfind.adb, gnatlink.adb, gnatls.adb, gnatname.adb, gnatxref.adb, gprep.adb, clean.adb gnatbind.adb (Check_Version_And_Help): New procedure in package Switch to process switches --version and --help. --- 11469,11475 ---- PR ada/4720 ! * gnatchop.adb, gnatfind.adb, gnatlink.adb, gnatls.adb, gnatname.adb, gnatxref.adb, gprep.adb, clean.adb gnatbind.adb (Check_Version_And_Help): New procedure in package Switch to process switches --version and --help. *************** *** 3075,3081 **** 2007-08-31 Hristian Kirtchev ! * restrict.adb, namet.adb, par-util.adb: Remove redundant type conversion. * sem_res.adb (Resolve_Qualified_Expression): Add machinery to detect --- 11552,11558 ---- 2007-08-31 Hristian Kirtchev ! * restrict.adb, namet.adb, par-util.adb: Remove redundant type conversion. * sem_res.adb (Resolve_Qualified_Expression): Add machinery to detect *************** *** 3394,3400 **** 2007-08-14 Thomas Quinot ! * g-soccon-interix.ads, a-excpol-interix.adb, a-intnam-interix.ads, s-osinte-interix.ads, system-interix.ads: Removed. 2007-08-14 Hristian Kirtchev --- 11871,11877 ---- 2007-08-14 Thomas Quinot ! * g-soccon-interix.ads, a-excpol-interix.adb, a-intnam-interix.ads, s-osinte-interix.ads, system-interix.ads: Removed. 2007-08-14 Hristian Kirtchev *************** *** 3417,3423 **** 2007-08-14 Robert Dewar Ed Schonberg ! * inline.adb, types.ads, inline.ads, frontend.adb, alloc.ads: Suppress unmodified in-out parameter warning in some cases This patch is a also fairly significant change to the way suppressible checks are handled. --- 11894,11900 ---- 2007-08-14 Robert Dewar Ed Schonberg ! * inline.adb, types.ads, inline.ads, frontend.adb, alloc.ads: Suppress unmodified in-out parameter warning in some cases This patch is a also fairly significant change to the way suppressible checks are handled. *************** *** 3438,3444 **** Ed Schonberg Thomas Quinot ! * a-stzsup.adb, nlists.adb, lib-util.adb, treepr.adb, a-stwisu.adb, a-strsup.adb: Fix warnings for range tests optimized out. --- 11915,11921 ---- Ed Schonberg Thomas Quinot ! * a-stzsup.adb, nlists.adb, lib-util.adb, treepr.adb, a-stwisu.adb, a-strsup.adb: Fix warnings for range tests optimized out. *************** *** 3513,3519 **** * comperr.adb: Fix problem with suppressing warning messages from gigi ! * erroutc.ads, erroutc.adb, errout.ads, errout.adb (Write_Eol): Remove trailing spaces before writing the line (Write_Eol_Keep_Blanks): New procedure to write a line, including possible trailing spaces. --- 11990,11996 ---- * comperr.adb: Fix problem with suppressing warning messages from gigi ! * erroutc.ads, erroutc.adb, errout.ads, errout.adb (Write_Eol): Remove trailing spaces before writing the line (Write_Eol_Keep_Blanks): New procedure to write a line, including possible trailing spaces. *************** *** 3521,3531 **** Fix problem with suppressing warning messages from back end Improve handling of deleted warnings ! * gnat1drv.adb: Fix problem with suppressing warning messages from back end Handle setting of Static_Dispatch_Tables flag. ! * prepcomp.adb: Fix problem with suppressing warning messages from back end * exp_intr.adb: Improve handling of deleted warnings --- 11998,12008 ---- Fix problem with suppressing warning messages from back end Improve handling of deleted warnings ! * gnat1drv.adb: Fix problem with suppressing warning messages from back end Handle setting of Static_Dispatch_Tables flag. ! * prepcomp.adb: Fix problem with suppressing warning messages from back end * exp_intr.adb: Improve handling of deleted warnings *************** *** 3725,3731 **** Ed Schonberg Javier Miranda ! * exp_util.ads, exp_util.adb: This patch replaces a number of occurrences of explicit tests for N_Null with calls to Known_Null. This improves tracking of null values, since Known_Null also catches null constants, and variables currently known to --- 12202,12208 ---- Ed Schonberg Javier Miranda ! * exp_util.ads, exp_util.adb: This patch replaces a number of occurrences of explicit tests for N_Null with calls to Known_Null. This improves tracking of null values, since Known_Null also catches null constants, and variables currently known to *************** *** 3776,3782 **** including gprmake, so that the same sources in the GNAT repository can be used by gprbuild. ! * prj-com.ads: Major update of the Project Manager and of the project aware tools, including gprmake, so that the same sources in the GNAT repository can be used by gprbuild. --- 12253,12259 ---- including gprmake, so that the same sources in the GNAT repository can be used by gprbuild. ! * prj-com.ads: Major update of the Project Manager and of the project aware tools, including gprmake, so that the same sources in the GNAT repository can be used by gprbuild. *************** *** 3791,3797 **** including gprmake, so that the same sources in the GNAT repository can be used by gprbuild. ! * prj-env.ads, prj-env.adb: Major update of the Project Manager and of the project aware tools, including gprmake, so that the same sources in the GNAT repository can be used by gprbuild. --- 12268,12274 ---- including gprmake, so that the same sources in the GNAT repository can be used by gprbuild. ! * prj-env.ads, prj-env.adb: Major update of the Project Manager and of the project aware tools, including gprmake, so that the same sources in the GNAT repository can be used by gprbuild. *************** *** 3807,3813 **** including gprmake, so that the same sources in the GNAT repository can be used by gprbuild. ! * prj-nmsc.ads, prj-nmsc.adb: Update Project Manager to new attribute names for ghprbuild Allow all valid declarations in configuration project files (Search_Directories): Detect subunits that are specified with an --- 12284,12290 ---- including gprmake, so that the same sources in the GNAT repository can be used by gprbuild. ! * prj-nmsc.ads, prj-nmsc.adb: Update Project Manager to new attribute names for ghprbuild Allow all valid declarations in configuration project files (Search_Directories): Detect subunits that are specified with an *************** *** 3826,3832 **** (Locate_Directory): Make sure that on Windows '/' is converted to '\', otherwise creating missing directories will fail. ! * prj-attr-pm.adb, prj-tree.ads, prj-proc.ads, prj-proc.adb, prj-part.ads, prj-part.adb: Major update of the Project Manager and of the project aware tools, including gprmake, so that the same sources in the GNAT repository --- 12303,12309 ---- (Locate_Directory): Make sure that on Windows '/' is converted to '\', otherwise creating missing directories will fail. ! * prj-attr-pm.adb, prj-tree.ads, prj-proc.ads, prj-proc.adb, prj-part.ads, prj-part.adb: Major update of the Project Manager and of the project aware tools, including gprmake, so that the same sources in the GNAT repository *************** *** 3844,3850 **** defaulted to False. When True, always check against indexes in lower case. ! * snames.ads, snames.h, snames.adb: Update Project Manager to new attribute names for gprbuild Allow all valid declarations in configuration project files --- 12321,12327 ---- defaulted to False. When True, always check against indexes in lower case. ! * snames.ads, snames.h, snames.adb: Update Project Manager to new attribute names for gprbuild Allow all valid declarations in configuration project files *************** *** 3856,3862 **** New switch -gnatI to disable representation clauses Implement new pragma Implicit_Packing ! * usage.adb: Warning for non-local exception propagation now off by default Add warning for unchecked conversion of pointers wi different conventions. --- 12333,12339 ---- New switch -gnatI to disable representation clauses Implement new pragma Implicit_Packing ! * usage.adb: Warning for non-local exception propagation now off by default Add warning for unchecked conversion of pointers wi different conventions. *************** *** 3873,3879 **** Add documentation for new -gnatyS style check Update documentation about SAL and auto-init on Windows. ! * gnat_rm.texi: Add documentation for pragma Check_Name and 'Enabled attribute Document that Eliminate on dispatching operation is ignored Document IDE attributes VCS_Repository_Root and VCS_Patch_Root. --- 12350,12356 ---- Add documentation for new -gnatyS style check Update documentation about SAL and auto-init on Windows. ! * gnat_rm.texi: Add documentation for pragma Check_Name and 'Enabled attribute Document that Eliminate on dispatching operation is ignored Document IDE attributes VCS_Repository_Root and VCS_Patch_Root. *************** *** 3973,3979 **** * misc.c (gnat_init_gcc_eh): Use __gnat_eh_personality_sj for the name of the personality function with SJLJ exceptions. ! * raise-gcc.c (PERSONALITY_FUNCTION): Use __gnat_eh_personality_sj for the name of the personality function with SJLJ exceptions. 2007-08-14 Robert Dewar --- 12450,12456 ---- * misc.c (gnat_init_gcc_eh): Use __gnat_eh_personality_sj for the name of the personality function with SJLJ exceptions. ! * raise-gcc.c (PERSONALITY_FUNCTION): Use __gnat_eh_personality_sj for the name of the personality function with SJLJ exceptions. 2007-08-14 Robert Dewar *************** *** 4068,4074 **** 2007-08-14 Ed Schonberg Gary Dismukes ! * exp_aggr.ads, exp_aggr.adb (Convert_Aggr_In_Allocator): Use Insert_Actions to place expanded aggregate code before allocator, and ahead of declaration for temporary, to prevent access before elaboration when the allocator is --- 12545,12551 ---- 2007-08-14 Ed Schonberg Gary Dismukes ! * exp_aggr.ads, exp_aggr.adb (Convert_Aggr_In_Allocator): Use Insert_Actions to place expanded aggregate code before allocator, and ahead of declaration for temporary, to prevent access before elaboration when the allocator is *************** *** 4095,4102 **** 2007-08-14 Jerome Guitton ! * s-taprop-lynxos.adb, s-taprop-tru64.adb, s-taprop-irix.adb, ! s-taprop-hpux-dce.adb, s-taprop-dummy.adb, s-taprop-solaris.adb, s-taprop-vms.adb, s-taprop-posix.adb (Continue_Task, Stop_All_Tasks): New functions; dummy implementations. --- 12572,12579 ---- 2007-08-14 Jerome Guitton ! * s-taprop-lynxos.adb, s-taprop-tru64.adb, s-taprop-irix.adb, ! s-taprop-hpux-dce.adb, s-taprop-dummy.adb, s-taprop-solaris.adb, s-taprop-vms.adb, s-taprop-posix.adb (Continue_Task, Stop_All_Tasks): New functions; dummy implementations. *************** *** 4120,4130 **** 2007-08-14 Vincent Celier ! * clean.adb, fmap.adb, sinput-p.adb, sinput-p.ads, gnatcmd.adb, gnatname.adb, makeutl.ads, makeutl.adb, makegpr.adb, mlib-tgt-vms.adb ! mlib-tgt-darwin.adb, mlib-tgt-lynxos.adb, mlib-prj.adb, mlib-tgt.adb, ! mlib-tgt.ads, mlib-tgt-irix.adb mlib-tgt-hpux.adb, mlib-tgt-linux.adb, ! mlib-tgt-solaris.adb, mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, mlib-tgt-mingw.adb, mlib-tgt-vxworks.adb, mlib-tgt-aix.adb, mlib-tgt-tru64.adb, mlib.ads, mlib.adb (Create_Sym_Links): New procedure. --- 12597,12607 ---- 2007-08-14 Vincent Celier ! * clean.adb, fmap.adb, sinput-p.adb, sinput-p.ads, gnatcmd.adb, gnatname.adb, makeutl.ads, makeutl.adb, makegpr.adb, mlib-tgt-vms.adb ! mlib-tgt-darwin.adb, mlib-tgt-lynxos.adb, mlib-prj.adb, mlib-tgt.adb, ! mlib-tgt.ads, mlib-tgt-irix.adb mlib-tgt-hpux.adb, mlib-tgt-linux.adb, ! mlib-tgt-solaris.adb, mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, mlib-tgt-mingw.adb, mlib-tgt-vxworks.adb, mlib-tgt-aix.adb, mlib-tgt-tru64.adb, mlib.ads, mlib.adb (Create_Sym_Links): New procedure. *************** *** 4146,4163 **** * system-solaris-x86.ads (ZCX_By_Default): Switch to True. (GCC_ZCX_Support): Switch to True. ! * s-intman-solaris.adb (Notify_Exception): Call Adjust_Context_For_Raise before raising, as expected for signal handlers in general. ! * s-intman-posix.adb (Notify_Exception): Remove declaration of Adjust_Context_For_Raise, moved to the spec of this unit to be visible to other implementation bodies. ! * s-intman.ads (Adjust_Context_For_Raise): Declare and import here, to be visible by multiple implementation bodies. ! * init.c [VMS section] (__gnat_handle_vms_condition): Adjust context only for conditions coming from hardware. [alpha-tru64 section] (__gnat_adjust_context_for_raise): Implement, --- 12623,12640 ---- * system-solaris-x86.ads (ZCX_By_Default): Switch to True. (GCC_ZCX_Support): Switch to True. ! * s-intman-solaris.adb (Notify_Exception): Call Adjust_Context_For_Raise before raising, as expected for signal handlers in general. ! * s-intman-posix.adb (Notify_Exception): Remove declaration of Adjust_Context_For_Raise, moved to the spec of this unit to be visible to other implementation bodies. ! * s-intman.ads (Adjust_Context_For_Raise): Declare and import here, to be visible by multiple implementation bodies. ! * init.c [VMS section] (__gnat_handle_vms_condition): Adjust context only for conditions coming from hardware. [alpha-tru64 section] (__gnat_adjust_context_for_raise): Implement, *************** *** 4237,4243 **** 2007-08-14 Javier Miranda ! * a-tags.ads, a-tags.adb (Displace): Associate a message with the raised CE exception. (To_Addr_Ptr, To_Address, To_Dispatch_Table_Ptr, --- 12714,12720 ---- 2007-08-14 Javier Miranda ! * a-tags.ads, a-tags.adb (Displace): Associate a message with the raised CE exception. (To_Addr_Ptr, To_Address, To_Dispatch_Table_Ptr, *************** *** 4274,4280 **** won't be an associated Afile). (Elab_All_Links): Fail if a referenced unit cannot be found ! * bindgen.adb: Fix comments in bindgen regarding consistency checks done in Bcheck: the checks are made across units within a partition, not across several partitions. --- 12751,12757 ---- won't be an associated Afile). (Elab_All_Links): Fail if a referenced unit cannot be found ! * bindgen.adb: Fix comments in bindgen regarding consistency checks done in Bcheck: the checks are made across units within a partition, not across several partitions. *************** *** 4368,4376 **** 2007-08-14 Bob Duff ! * a-cihama.ads, a-cidlli.ads, a-chtgop.ads, a-chtgop.adb, a-cdlili.ads, ! a-cihase.adb, a-cihase.ads, a-cohase.adb, a-cohase.ads, a-ciorma.ads, ! a-coorma.ads, a-ciormu.ads, a-coormu.ads, a-ciorse.ads, a-cohama.ads, a-cohata.ads, a-convec.adb, a-coinve.ads, a-coinve.adb, a-convec.ads, a-coorse.ads (Next): Applied pragma Inline. Make all Containers packages Remote_Types (unless they are already --- 12845,12853 ---- 2007-08-14 Bob Duff ! * a-cihama.ads, a-cidlli.ads, a-chtgop.ads, a-chtgop.adb, a-cdlili.ads, ! a-cihase.adb, a-cihase.ads, a-cohase.adb, a-cohase.ads, a-ciorma.ads, ! a-coorma.ads, a-ciormu.ads, a-coormu.ads, a-ciorse.ads, a-cohama.ads, a-cohata.ads, a-convec.adb, a-coinve.ads, a-coinve.adb, a-convec.ads, a-coorse.ads (Next): Applied pragma Inline. Make all Containers packages Remote_Types (unless they are already *************** *** 4513,4518 **** --- 12990,12996 ---- valid value. 2007-08-14 Thomas Quinot + Pablo Oliveira * exp_dist.adb (PolyORB_Support.Build_TypeCode_Function): When creating typecode parameters for a union (in a variant record), remove *************** *** 4814,4827 **** 2007-07-27 Aurelien Jarno ! * s-osinte-kfreebsd-gnu.ads ((sigset_t_ptr): Removed, replaced by anonymous access type. (pthread_sigmask): Now take an access sigset_t. ! 2007-07-05 Joel Sherrill - * s-osinte-rtems.ads: Correct prototype of pthread_sigmask. - 2007-06-21 Eric Botcazou PR tree-optimization/25737 --- 13292,13305 ---- 2007-07-27 Aurelien Jarno ! * s-osinte-kfreebsd-gnu.ads ((sigset_t_ptr): Removed, replaced by anonymous access type. (pthread_sigmask): Now take an access sigset_t. ! 2007-07-05 Joel Sherrill ! ! * s-osinte-rtems.ads: Correct prototype of pthread_sigmask. 2007-06-21 Eric Botcazou PR tree-optimization/25737 *************** *** 4842,4855 **** POINTER_PLUS_EXPR's operands. When adding an offset to a pointer, use POINTER_PLUS_EXPR. ! 2007-06-11 Rafael Avila de Espindola * trans.c (Attribute_to_gnu): Use signed_or_unsigned_type_for instead of get_signed_or_unsigned_type. * misc.c (LANG_HOOKS_SIGNED_TYPE): Remove. 2007-06-11 Bob Duff ! Thomas Quinot * g-stsifd-sockets.adb (Create): Work around strange behavior of 'bind' on windows that causes 'connect' to fail intermittently, by --- 13320,13333 ---- POINTER_PLUS_EXPR's operands. When adding an offset to a pointer, use POINTER_PLUS_EXPR. ! 2007-06-11 Rafael Ãvila de Espíndola * trans.c (Attribute_to_gnu): Use signed_or_unsigned_type_for instead of get_signed_or_unsigned_type. * misc.c (LANG_HOOKS_SIGNED_TYPE): Remove. 2007-06-11 Bob Duff ! Thomas Quinot * g-stsifd-sockets.adb (Create): Work around strange behavior of 'bind' on windows that causes 'connect' to fail intermittently, by *************** *** 4869,4876 **** 2007-06-06 Thomas Quinot Bob Duff ! * g-soccon-freebsd.ads, g-soccon-vxworks.ads:, ! g-soccon-aix.ads, g-soccon-irix.ads, g-soccon-hpux.ads, g-soccon-solaris.ads, g-soccon-vms.ads, g-soccon-tru64.ads: Add new constant Thread_Blocking_IO, always True by default, set False on a per-runtime basis. --- 13347,13354 ---- 2007-06-06 Thomas Quinot Bob Duff ! * g-soccon-freebsd.ads, g-soccon-vxworks.ads:, ! g-soccon-aix.ads, g-soccon-irix.ads, g-soccon-hpux.ads, g-soccon-solaris.ads, g-soccon-vms.ads, g-soccon-tru64.ads: Add new constant Thread_Blocking_IO, always True by default, set False on a per-runtime basis. *************** *** 4946,4952 **** 2007-06-06 Bob Duff ! * g-expect-vms.adb: (Send_Signal, Close): Raise Invalid_Process if the process id is invalid. * g-expect.ads, g-expect.adb (Send): Avoid useless copy of the string. (Send_Signal, Close): Raise Invalid_Process if the process id is --- 13424,13430 ---- 2007-06-06 Bob Duff ! * g-expect-vms.adb: (Send_Signal, Close): Raise Invalid_Process if the process id is invalid. * g-expect.ads, g-expect.adb (Send): Avoid useless copy of the string. (Send_Signal, Close): Raise Invalid_Process if the process id is *************** *** 5001,5017 **** 2007-06-06 Arnaud Charlet ! * s-taprop-vms.adb, s-taprop-hpux-dce.adb, s-taprop-vxworks.adb, ! s-osprim-posix.adb, s-taprop-posix.adb, s-osprim-vxworks.adb, ! s-taprop-solaris.adb, s-osprim-solaris.adb, s-taprop-dummy.adb, ! s-osprim-unix.adb, s-osinte-freebsd.adb, s-osinte-freebsd.ads, ! s-osinte-lynxos.adb, s-osinte-lynxos.ads, s-taprop-tru64.adb, ! s-taprop-lynxos.adb, s-taprop-irix.adb, s-osinte-tru64.adb, ! s-osinte-tru64.ads, s-taprop-linux.adb, s-parame.ads, ! s-parame-vms-alpha.ads, s-parame-vms-ia64.ads, s-parame-hpux.ads, ! s-parame-vms-restrict.ads, s-parame-ae653.ads, s-parame-vxworks.ads, s-taprop-mingw.adb, s-osinte-lynxos-3.ads, s-osinte-lynxos-3.adb, ! s-osprim-mingw.adb (Timed_Delay, Timed_Sleep): Register the base time when entering this routine to detect a backward clock setting (manual setting or DST adjustment), to avoid waiting for a longer delay than needed. --- 13479,13495 ---- 2007-06-06 Arnaud Charlet ! * s-taprop-vms.adb, s-taprop-hpux-dce.adb, s-taprop-vxworks.adb, ! s-osprim-posix.adb, s-taprop-posix.adb, s-osprim-vxworks.adb, ! s-taprop-solaris.adb, s-osprim-solaris.adb, s-taprop-dummy.adb, ! s-osprim-unix.adb, s-osinte-freebsd.adb, s-osinte-freebsd.ads, ! s-osinte-lynxos.adb, s-osinte-lynxos.ads, s-taprop-tru64.adb, ! s-taprop-lynxos.adb, s-taprop-irix.adb, s-osinte-tru64.adb, ! s-osinte-tru64.ads, s-taprop-linux.adb, s-parame.ads, ! s-parame-vms-alpha.ads, s-parame-vms-ia64.ads, s-parame-hpux.ads, ! s-parame-vms-restrict.ads, s-parame-ae653.ads, s-parame-vxworks.ads, s-taprop-mingw.adb, s-osinte-lynxos-3.ads, s-osinte-lynxos-3.adb, ! s-osprim-mingw.adb (Timed_Delay, Timed_Sleep): Register the base time when entering this routine to detect a backward clock setting (manual setting or DST adjustment), to avoid waiting for a longer delay than needed. *************** *** 5057,5070 **** 2007-06-06 Arnaud Charlet ! * system-vxworks-sparcv9.ads, system-solaris-x86.ads, ! system-irix-o32.ads, system-freebsd-x86.ads, system-lynxos-ppc.ads, ! system-lynxos-x86.ads, system-vxworks-m68k.ads, system-linux-x86.ads, ! system-vxworks-mips.ads, system-vxworks-alpha.ads, ! system-vxworks-x86.ads, system-linux-ppc.ads, system-mingw.ads, ! system-vms-zcx.ads, system-darwin-ppc.ads, system-vxworks-ppc.ads, ! system-interix.ads, system-linux-hppa.ads, system-tru64.ads, ! system-hpux.ads, system-irix-n32.ads, system-solaris-sparc.ads, system-solaris-sparcv9.ads, system-vms.ads, system.ads, system-vms_64.ads, system-hpux-ia64.ads, system-linux-x86_64.ads, system-linux-ia64.ads: Document mapping between Ada and OS priorities. --- 13535,13548 ---- 2007-06-06 Arnaud Charlet ! * system-vxworks-sparcv9.ads, system-solaris-x86.ads, ! system-irix-o32.ads, system-freebsd-x86.ads, system-lynxos-ppc.ads, ! system-lynxos-x86.ads, system-vxworks-m68k.ads, system-linux-x86.ads, ! system-vxworks-mips.ads, system-vxworks-alpha.ads, ! system-vxworks-x86.ads, system-linux-ppc.ads, system-mingw.ads, ! system-vms-zcx.ads, system-darwin-ppc.ads, system-vxworks-ppc.ads, ! system-interix.ads, system-linux-hppa.ads, system-tru64.ads, ! system-hpux.ads, system-irix-n32.ads, system-solaris-sparc.ads, system-solaris-sparcv9.ads, system-vms.ads, system.ads, system-vms_64.ads, system-hpux-ia64.ads, system-linux-x86_64.ads, system-linux-ia64.ads: Document mapping between Ada and OS priorities. *************** *** 5087,5096 **** * mlib-tgt-specific.adb, mlib-tgt-specific.ads, mlib-tgt-vms.adb, mlib-tgt-vms.ads: New files. ! * mlib-tgt.adb, mlib-tgt.ads, mlib-tgt-darwin.adb, ! mlib-tgt-vxworks.adb, mlib-tgt-mingw.adb, mlib-tgt-lynxos.adb, ! mlib-tgt-linux.adb, mlib-tgt-solaris.adb, mlib-tgt-vms-alpha.adb, ! mlib-tgt-vms-ia64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb, mlib-tgt-hpux.adb, mlib-tgt-tru64.adb: Make a common body for package MLib.Tgt, containing the default versions of the exported subprograms. For each platform, create a specific version of the body of new child --- 13565,13574 ---- * mlib-tgt-specific.adb, mlib-tgt-specific.ads, mlib-tgt-vms.adb, mlib-tgt-vms.ads: New files. ! * mlib-tgt.adb, mlib-tgt.ads, mlib-tgt-darwin.adb, ! mlib-tgt-vxworks.adb, mlib-tgt-mingw.adb, mlib-tgt-lynxos.adb, ! mlib-tgt-linux.adb, mlib-tgt-solaris.adb, mlib-tgt-vms-alpha.adb, ! mlib-tgt-vms-ia64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb, mlib-tgt-hpux.adb, mlib-tgt-tru64.adb: Make a common body for package MLib.Tgt, containing the default versions of the exported subprograms. For each platform, create a specific version of the body of new child *************** *** 5108,5114 **** * s-osinte-linux.ads (sigset_t): Bump alignment to match more closely its C counterpart. Remove references to Unchecked_Conversion, and use Ada.xxx instead. ! Replace Unchecked_Conversion by Ada.Unchecked_Conversion. 2007-06-06 Vasiliy Fofanov --- 13586,13592 ---- * s-osinte-linux.ads (sigset_t): Bump alignment to match more closely its C counterpart. Remove references to Unchecked_Conversion, and use Ada.xxx instead. ! Replace Unchecked_Conversion by Ada.Unchecked_Conversion. 2007-06-06 Vasiliy Fofanov *************** *** 5275,5297 **** (build_unc_object_type): Likewise. (declare_debug_type): New function. ! * ada-tree.def: USE_STMT: removed (not emitted anymore). ! * misc.c (gnat_expand_expr): Call to gnat_expand_stmt removed because ! no statement is expandable anymore. ! (gnat_init_gcc_eh): Do not initialize the DWARF-2 CFI machinery twice. ! (gnat_handle_option): Only allow flag_eliminate_debug_types to be set ! when the user requested it explicitely. ! (gnat_post_options): By default, set flag_eliminate_unused_debug_types ! to 0 for Ada. ! (get_alias_set): Return alias set 0 for a type if ! TYPE_UNIVERSAL_ALIASING_P is set on its main variant. ! * ada-tree.h: (TYPE_UNIVERSAL_ALIASING_P): New macro. ! (DECL_FUNCTION_STUB): New accessor macro. ! (SET_DECL_FUNCTION_STUB): New setter macro. ! * lang.opt (feliminate-unused-debug-types): Intercept this flag for Ada. * fe.h (Get_Local_Raise_Call_Entity, Get_RT_Exception_Entity): New declarations. --- 13753,13775 ---- (build_unc_object_type): Likewise. (declare_debug_type): New function. ! * ada-tree.def: USE_STMT: removed (not emitted anymore). ! * misc.c (gnat_expand_expr): Call to gnat_expand_stmt removed because ! no statement is expandable anymore. ! (gnat_init_gcc_eh): Do not initialize the DWARF-2 CFI machinery twice. ! (gnat_handle_option): Only allow flag_eliminate_debug_types to be set ! when the user requested it explicitely. ! (gnat_post_options): By default, set flag_eliminate_unused_debug_types ! to 0 for Ada. ! (get_alias_set): Return alias set 0 for a type if ! TYPE_UNIVERSAL_ALIASING_P is set on its main variant. ! * ada-tree.h: (TYPE_UNIVERSAL_ALIASING_P): New macro. ! (DECL_FUNCTION_STUB): New accessor macro. ! (SET_DECL_FUNCTION_STUB): New setter macro. ! * lang.opt (feliminate-unused-debug-types): Intercept this flag for Ada. * fe.h (Get_Local_Raise_Call_Entity, Get_RT_Exception_Entity): New declarations. *************** *** 5383,5400 **** 2007-06-06 Vincent Celier Robert Dewar ! * bcheck.adb, binde.adb, binderr.adb, binderr.ads, butil.adb, ! butil.ads, erroutc.adb, erroutc.ads, errutil.adb, errutil.ads, ! err_vars.ads, exp_tss.adb, exp_tss.ads, fmap.adb, fmap.ads, ! fname.adb, fname.ads, fname-sf.adb, fname-uf.adb, fname-uf.ads, ! lib-sort.adb, lib-util.adb, lib-util.ads, lib-xref.adb, makeutl.ads, ! makeutl.adb, nmake.adt, osint.adb, osint.ads, osint-b.adb, ! par-load.adb, prj-attr.adb, prj-dect.adb, prj-err.adb, prj-makr.adb, ! prj-part.adb, prj-pp.adb, prj-proc.adb, prj-tree.adb, prj-tree.ads, ! prj-util.adb, prj-util.ads, scans.adb, scans.ads, sem_ch2.adb, ! sinput-c.adb, styleg-c.adb, tempdir.adb, tempdir.ads, uname.adb, uname.ads, atree.h, atree.ads, atree.adb, ali-util.ads, ali-util.adb, ! ali.ads, ali.adb: Move Name_Id, File_Name_Type and Unit_Name_Type from package Types to package Namet. Make File_Name_Type and Unit_Name_Type types derived from Mame_Id. Add new type Path_Name_Type, also derived from Name_Id. --- 13861,13878 ---- 2007-06-06 Vincent Celier Robert Dewar ! * bcheck.adb, binde.adb, binderr.adb, binderr.ads, butil.adb, ! butil.ads, erroutc.adb, erroutc.ads, errutil.adb, errutil.ads, ! err_vars.ads, exp_tss.adb, exp_tss.ads, fmap.adb, fmap.ads, ! fname.adb, fname.ads, fname-sf.adb, fname-uf.adb, fname-uf.ads, ! lib-sort.adb, lib-util.adb, lib-util.ads, lib-xref.adb, makeutl.ads, ! makeutl.adb, nmake.adt, osint.adb, osint.ads, osint-b.adb, ! par-load.adb, prj-attr.adb, prj-dect.adb, prj-err.adb, prj-makr.adb, ! prj-part.adb, prj-pp.adb, prj-proc.adb, prj-tree.adb, prj-tree.ads, ! prj-util.adb, prj-util.ads, scans.adb, scans.ads, sem_ch2.adb, ! sinput-c.adb, styleg-c.adb, tempdir.adb, tempdir.ads, uname.adb, uname.ads, atree.h, atree.ads, atree.adb, ali-util.ads, ali-util.adb, ! ali.ads, ali.adb: Move Name_Id, File_Name_Type and Unit_Name_Type from package Types to package Namet. Make File_Name_Type and Unit_Name_Type types derived from Mame_Id. Add new type Path_Name_Type, also derived from Name_Id. *************** *** 5617,5623 **** some use of System.Restrictions in the partition. (Check_System_Restrictions_Used): New procedure ! * s-stalib.adb: Remove with of System.Restrictions. No longer needed since we only with this unit in the binder file if it is used elsewhere in the partition. --- 14095,14101 ---- some use of System.Restrictions in the partition. (Check_System_Restrictions_Used): New procedure ! * s-stalib.adb: Remove with of System.Restrictions. No longer needed since we only with this unit in the binder file if it is used elsewhere in the partition. *************** *** 5808,5814 **** Bob Duff Hristian Kirtchev ! * exp_aggr.ads, exp_aggr.adb: (Build_Record_Aggr_Code): Add missing initialization of secondary tags in extension aggregates. (Flatten): Other conditions being met, an aggregate is static if the --- 14286,14292 ---- Bob Duff Hristian Kirtchev ! * exp_aggr.ads, exp_aggr.adb: (Build_Record_Aggr_Code): Add missing initialization of secondary tags in extension aggregates. (Flatten): Other conditions being met, an aggregate is static if the *************** *** 6347,6353 **** objects. Remove all handling of with_type clauses. ! * par-ch10.adb: Remove all handling of with_type clauses. * lib-load.ads, lib-load.adb (Load_Main_Source): Do not get the checksum if the main source could not be parsed. --- 14825,14831 ---- objects. Remove all handling of with_type clauses. ! * par-ch10.adb: Remove all handling of with_type clauses. * lib-load.ads, lib-load.adb (Load_Main_Source): Do not get the checksum if the main source could not be parsed. *************** *** 6390,6396 **** 2007-06-06 Robert Dewar Ed Schonberg ! * g-comlin.ads, g-comlin.adb: Add new warning for renaming of function return objects * opt.adb (Tree_Write, Tree_Read): Use proper expressions for size --- 14868,14874 ---- 2007-06-06 Robert Dewar Ed Schonberg ! * g-comlin.ads, g-comlin.adb: Add new warning for renaming of function return objects * opt.adb (Tree_Write, Tree_Read): Use proper expressions for size *************** *** 6483,6489 **** 2007-06-06 Vincent Celier ! * gnatls.adb: Add 3 spaces before the default project directory when displaying the project search path. Add new command line switch '-l' to display license information. --- 14961,14967 ---- 2007-06-06 Vincent Celier ! * gnatls.adb: Add 3 spaces before the default project directory when displaying the project search path. Add new command line switch '-l' to display license information. *************** *** 6763,6769 **** (Copy_ALI_Files): Make sure that an already existing ALI file in the ALI copy dir is writable, before doing the copy. ! * mlib-utl.ads, mlib-utl.adb: (Gcc): If length of command line is too long, put the list of object files in a response file, if this is supported by the platform. (Ar): If invocation of the archive builder is allowed to be done in --- 15241,15247 ---- (Copy_ALI_Files): Make sure that an already existing ALI file in the ALI copy dir is writable, before doing the copy. ! * mlib-utl.ads, mlib-utl.adb: (Gcc): If length of command line is too long, put the list of object files in a response file, if this is supported by the platform. (Ar): If invocation of the archive builder is allowed to be done in *************** *** 7464,7470 **** 2007-06-06 Javier Miranda ! * a-cidlli.ads, a-cdlili.ads, a-cohama.ads, a-coinve.ads, a-convec.ads (Empty_Vector, Empty_Map, Empty_List): Move this object declaration after freezing point of all its associated tagged types; otherwise such types are frozen too early. --- 15942,15948 ---- 2007-06-06 Javier Miranda ! * a-cidlli.ads, a-cdlili.ads, a-cohama.ads, a-coinve.ads, a-convec.ads (Empty_Vector, Empty_Map, Empty_List): Move this object declaration after freezing point of all its associated tagged types; otherwise such types are frozen too early. *************** *** 7508,7514 **** * misc.c (enumerate_modes): Consider log2_b to always be one. ! 2007-05-14 Rafael Avila de Espindola * misc.c (LANG_HOOKS_UNSIGNED_TYPE): Remove. --- 15986,15992 ---- * misc.c (enumerate_modes): Consider log2_b to always be one. ! 2007-05-14 Rafael Ãvila de Espíndola * misc.c (LANG_HOOKS_UNSIGNED_TYPE): Remove. *************** *** 7582,7603 **** s-taprop-hpux-dce.adb, s-traceb-hpux.adb, s-taprop-linux.adb, s-taprop-dummy.adb, s-osprim-unix.adb, s-osprim-solaris.adb, s-taprop-solaris.adb, s-taprop-vms.adb, ! s-osprim-mingw.adb, s-taprop-mingw.adb, s-osprim-posix.adb, ! s-taprop-posix.adb, a-exexpr-gcc.adb, a-ststio.adb, a-ststio.ads, ! a-textio.adb, a-textio.ads, a-tideau.adb, a-tideau.ads, a-witeio.adb, ! a-witeio.ads, a-wtdeau.adb, a-wtdeau.ads, g-calend.adb, g-calend.ads, ! g-dirope.adb, g-expect.ads, gnatchop.adb, g-spipat.adb, g-spipat.ads, ! s-direio.adb, s-direio.ads, s-fatgen.adb, s-fatgen.ads, s-parint.adb, ! s-sequio.adb, s-sequio.ads, s-taprop.ads, s-valdec.adb, s-valdec.ads, ! s-valint.adb, s-valint.ads, s-vallld.adb, s-vallld.ads, s-vallli.adb, ! s-vallli.ads, s-valllu.adb, s-valllu.ads, s-valrea.adb, s-valrea.ads, ! s-valuns.adb, s-valuns.ads, s-valuti.adb, s-valuti.ads, xref_lib.adb, ! s-stchop.adb, i-vxwork-x86.ads, a-crbtgo.ads, a-crbtgo.adb, ! a-coorse.ads, a-coorse.adb, a-cohama.ads, a-cohama.adb, a-ciorse.ads, ! a-ciorse.adb, a-cihama.ads, a-cihama.adb, a-chtgop.ads, a-chtgop.ads, ! a-coormu.adb, a-ciormu.adb, a-cihase.adb, a-cihase.ads, a-cohase.adb, a-cohase.ads, a-swuwha.ads, a-ciormu.ads, a-coormu.ads, a-rbtgso.ads, ! a-stunha.ads, a-ciorma.adb, a-coorma.adb, a-ztdeau.adb, a-ztdeau.ads, a-ztexio.adb, a-ztexio.ads: Addition of null-exclusion to anonymous access types. Update documentation. --- 16060,16081 ---- s-taprop-hpux-dce.adb, s-traceb-hpux.adb, s-taprop-linux.adb, s-taprop-dummy.adb, s-osprim-unix.adb, s-osprim-solaris.adb, s-taprop-solaris.adb, s-taprop-vms.adb, ! s-osprim-mingw.adb, s-taprop-mingw.adb, s-osprim-posix.adb, ! s-taprop-posix.adb, a-exexpr-gcc.adb, a-ststio.adb, a-ststio.ads, ! a-textio.adb, a-textio.ads, a-tideau.adb, a-tideau.ads, a-witeio.adb, ! a-witeio.ads, a-wtdeau.adb, a-wtdeau.ads, g-calend.adb, g-calend.ads, ! g-dirope.adb, g-expect.ads, gnatchop.adb, g-spipat.adb, g-spipat.ads, ! s-direio.adb, s-direio.ads, s-fatgen.adb, s-fatgen.ads, s-parint.adb, ! s-sequio.adb, s-sequio.ads, s-taprop.ads, s-valdec.adb, s-valdec.ads, ! s-valint.adb, s-valint.ads, s-vallld.adb, s-vallld.ads, s-vallli.adb, ! s-vallli.ads, s-valllu.adb, s-valllu.ads, s-valrea.adb, s-valrea.ads, ! s-valuns.adb, s-valuns.ads, s-valuti.adb, s-valuti.ads, xref_lib.adb, ! s-stchop.adb, i-vxwork-x86.ads, a-crbtgo.ads, a-crbtgo.adb, ! a-coorse.ads, a-coorse.adb, a-cohama.ads, a-cohama.adb, a-ciorse.ads, ! a-ciorse.adb, a-cihama.ads, a-cihama.adb, a-chtgop.ads, a-chtgop.ads, ! a-coormu.adb, a-ciormu.adb, a-cihase.adb, a-cihase.ads, a-cohase.adb, a-cohase.ads, a-swuwha.ads, a-ciormu.ads, a-coormu.ads, a-rbtgso.ads, ! a-stunha.ads, a-ciorma.adb, a-coorma.adb, a-ztdeau.adb, a-ztdeau.ads, a-ztexio.adb, a-ztexio.ads: Addition of null-exclusion to anonymous access types. Update documentation. *************** *** 7614,7620 **** system-mingw.ads, system-vms-zcx.ads, system-vxworks-ppc.ads, system-vxworks-alpha.ads, system-vms_64.ads, system-darwin-ppc.ads, system-vxworks-x86.ads, system-linux-ppc.ads, system-linux-hppa.ads, ! system-hpux-ia64.ads, targparm.adb, targparm.ads (Functions_Return_By_DSP_On_Target): Removed * system.ads: Move Functions_Return_By_DSP to obsolete section, --- 16092,16098 ---- system-mingw.ads, system-vms-zcx.ads, system-vxworks-ppc.ads, system-vxworks-alpha.ads, system-vms_64.ads, system-darwin-ppc.ads, system-vxworks-x86.ads, system-linux-ppc.ads, system-linux-hppa.ads, ! system-hpux-ia64.ads, targparm.adb, targparm.ads (Functions_Return_By_DSP_On_Target): Removed * system.ads: Move Functions_Return_By_DSP to obsolete section, *************** *** 7771,7777 **** * a-calari.ads, a-calari.adb ("+", "-", Difference): Add calls to target independent routines in Ada.Calendar. ! * a-calfor.ads, a-calfor.adb: Code cleanup and addition of validity checks in various routines. (Day_Of_Week, Split, Time_Of): Add call to target independent routine in Ada.Calendar. --- 16249,16255 ---- * a-calari.ads, a-calari.adb ("+", "-", Difference): Add calls to target independent routines in Ada.Calendar. ! * a-calfor.ads, a-calfor.adb: Code cleanup and addition of validity checks in various routines. (Day_Of_Week, Split, Time_Of): Add call to target independent routine in Ada.Calendar. *************** *** 7781,7787 **** 2007-04-06 Olivier Hainque ! * adaint.c: (convert_addresses): Adjust prototype and dummy definition to expect an extra file_name argument. --- 16259,16265 ---- 2007-04-06 Olivier Hainque ! * adaint.c: (convert_addresses): Adjust prototype and dummy definition to expect an extra file_name argument. *************** *** 8008,8014 **** run-time check. 2007-04-06 Arnaud Charlet ! Eric Botcazou * gnatvsn.ads, comperr.adb (Get_Gnat_build_Type): Renamed Build_Type and made constant. --- 16486,16492 ---- run-time check. 2007-04-06 Arnaud Charlet ! Eric Botcazou * gnatvsn.ads, comperr.adb (Get_Gnat_build_Type): Renamed Build_Type and made constant. *************** *** 8035,8041 **** '/' should be inserted between the path and the filename. 2007-04-06 Olivier Hainque ! Eric Botcazou * decl.c (gnat_to_gnu_entity) : Associate an external VAR_DECL to a CONST_DECL we make for a public constant when we know the --- 16513,16519 ---- '/' should be inserted between the path and the filename. 2007-04-06 Olivier Hainque ! Eric Botcazou * decl.c (gnat_to_gnu_entity) : Associate an external VAR_DECL to a CONST_DECL we make for a public constant when we know the *************** *** 8473,8479 **** Remove all code for DSP option (CW_Or_Controlled_Type): new subprogram. ! 2007-04-06 Eric Botcazou Ed Schonberg Gary Dismukes --- 16951,16957 ---- Remove all code for DSP option (CW_Or_Controlled_Type): new subprogram. ! 2007-04-06 Eric Botcazou Ed Schonberg Gary Dismukes *************** *** 8509,8514 **** --- 16987,16993 ---- formals. 2007-04-06 Thomas Quinot + Pablo Oliveira * exp_dist.ads, exp_dist.adb (Build_To_Any_Call, Build_From_Any_Call): Do an Unchecked_Conversion to handle the passage from the Underlying *************** *** 8649,8654 **** --- 17128,17134 ---- (Set_Valid): Move to local package Validity 2007-04-06 Arnaud Charlet + Pablo Oliveira * g-expect.adb (Get_Command_Output): When expanding the output buffer we must ensure that there is enough place for the new data we are going *************** *** 8770,8776 **** * a-fzteio.ads, a-izteio.ads: New Ada 2005 run-time units. ! 2007-04-06 Eric Botcazou Arnaud Charlet * init.c: Reuse PA/HP-UX code for IA-64/HP-UX, except --- 17250,17256 ---- * a-fzteio.ads, a-izteio.ads: New Ada 2005 run-time units. ! 2007-04-06 Eric Botcazou Arnaud Charlet * init.c: Reuse PA/HP-UX code for IA-64/HP-UX, except *************** *** 8783,8789 **** member in struct sigaction, so as to avoid warning for incompatible pointer types. ! 2007-04-06 Serguei Rybin * lib.ads, lib.adb (Tree_Read): Release the memory occupied by the switches from previously loaded tree --- 17263,17269 ---- member in struct sigaction, so as to avoid warning for incompatible pointer types. ! 2007-04-06 Serguei Rybin * lib.ads, lib.adb (Tree_Read): Release the memory occupied by the switches from previously loaded tree *************** *** 8798,8804 **** 2007-04-06 Ed Schonberg Javier Miranda ! * lib-xref.ads, lib-xref.adb: Modify the loop that collects type references, to include interface types that the type implements. List each of these interfaces when building the entry for the type. --- 17278,17284 ---- 2007-04-06 Ed Schonberg Javier Miranda ! * lib-xref.ads, lib-xref.adb: Modify the loop that collects type references, to include interface types that the type implements. List each of these interfaces when building the entry for the type. *************** *** 9124,9138 **** (Preserve_Full_Attributes): The full entity list is not an attribute that must be preserved from full to partial view. ! * sem_dist.adb (Add_RAS_Dereference_TSS): ! Change primitive name to _Call so it cannot clash with any legal ! identifier, and be special-cased in Check_Completion. ! Mark the full view of the designated type for the RACW associated with ! a RAS as Comes_From_Source to get proper view switching when installing ! private declarations. ! Provite a placeholder nested package body along with the nested spec ! to have a place for Append_RACW_Bodies to generate the calling stubs ! and stream attributes. 2007-04-06 Ed Schonberg Robert Dewar --- 17604,17618 ---- (Preserve_Full_Attributes): The full entity list is not an attribute that must be preserved from full to partial view. ! * sem_dist.adb (Add_RAS_Dereference_TSS): ! Change primitive name to _Call so it cannot clash with any legal ! identifier, and be special-cased in Check_Completion. ! Mark the full view of the designated type for the RACW associated with ! a RAS as Comes_From_Source to get proper view switching when installing ! private declarations. ! Provite a placeholder nested package body along with the nested spec ! to have a place for Append_RACW_Bodies to generate the calling stubs ! and stream attributes. 2007-04-06 Ed Schonberg Robert Dewar *************** *** 9230,9236 **** an address always within the call instruction from a return address. 2007-04-06 Olivier Hainque ! Eric Botcazou * trans.c (call_to_gnu) : Return an expression with a COMPOUND_EXPR including the call instead of emitting --- 17710,17716 ---- an address always within the call instruction from a return address. 2007-04-06 Olivier Hainque ! Eric Botcazou * trans.c (call_to_gnu) : Return an expression with a COMPOUND_EXPR including the call instead of emitting *************** *** 9269,9275 **** BIT_AND_EXPR. Handle also VIEW_CONVERT_EXPR, as the other conversion opcodes. ! 2007-04-06 Eric Botcazou Olivier Hainque * utils.c (update_pointer_to): Make a copy of the couple of FIELD_DECLs --- 17749,17755 ---- BIT_AND_EXPR. Handle also VIEW_CONVERT_EXPR, as the other conversion opcodes. ! 2007-04-06 Eric Botcazou Olivier Hainque * utils.c (update_pointer_to): Make a copy of the couple of FIELD_DECLs *************** *** 9287,9295 **** function declaration node. (builtin_decl_for): Search the builtin_decls list. ! 2007-04-06 Eric Botcazou ! * s-stchop-vxworks.adb: (Stack_Check): Raise Storage_Error if the argument has wrapped around. 2007-04-06 Robert Dewar --- 17767,17775 ---- function declaration node. (builtin_decl_for): Search the builtin_decls list. ! 2007-04-06 Eric Botcazou ! * s-stchop-vxworks.adb: (Stack_Check): Raise Storage_Error if the argument has wrapped around. 2007-04-06 Robert Dewar *************** *** 9326,9332 **** (Print_Name,Print_Node): Make these debug printouts more robust: print "no such..." instead of crashing on bad input. ! 2007-03-30 Rafael Avila de Espindola * trans.c (Attribute_to_gnu): Use get_signed_or_unsigned_type instead of gnat_signed_or_unsigned_type. --- 17806,17812 ---- (Print_Name,Print_Node): Make these debug printouts more robust: print "no such..." instead of crashing on bad input. ! 2007-03-30 Rafael Ãvila de Espíndola * trans.c (Attribute_to_gnu): Use get_signed_or_unsigned_type instead of gnat_signed_or_unsigned_type. *************** *** 9403,9409 **** 2007-02-07 Andreas Krebbel * raise-gcc.c (get_region_description_for, get_call_site_action_for, ! get_action_description_for): Replace _Unwind_Word with _uleb128_t and _Unwind_SWord with _sleb128_t. 2007-02-06 Paolo Bonzini --- 17883,17889 ---- 2007-02-07 Andreas Krebbel * raise-gcc.c (get_region_description_for, get_call_site_action_for, ! get_action_description_for): Replace _Unwind_Word with _uleb128_t and _Unwind_SWord with _sleb128_t. 2007-02-06 Paolo Bonzini *************** *** 9557,9563 **** part of Ada.Calendar: all subprogram raise Unimplemented. (Split_W_Offset): Temp function body, raising Unimplemented ! * a-calend.ads, a-calend-vms.ads: Add imported variable Invalid_TZ_Offset used to designate targets unable to support time zones. (Unimplemented): Temporary function raised by the body of new --- 18037,18043 ---- part of Ada.Calendar: all subprogram raise Unimplemented. (Split_W_Offset): Temp function body, raising Unimplemented ! * a-calend.ads, a-calend-vms.ads: Add imported variable Invalid_TZ_Offset used to designate targets unable to support time zones. (Unimplemented): Temporary function raised by the body of new *************** *** 9595,9607 **** 2006-10-31 Arnaud Charlet Jose Ruiz ! * s-osinte-posix.adb, s-osinte-linux.ads, s-osinte-freebsd.adb, ! s-osinte-freebsd.ads, s-osinte-solaris-posix.ads, s-osinte-hpux.ads, s-osinte-darwin.adb, s-osinte-darwin.ads, s-osinte-lynxos-3.ads, s-osinte-lynxos-3.adb (To_Target_Priority): New function maps from System.Any_Priority to a POSIX priority on the target. ! * system-linux-ia64.ads: Extend range of Priority types on Linux to use the whole range made available by the system. --- 18075,18087 ---- 2006-10-31 Arnaud Charlet Jose Ruiz ! * s-osinte-posix.adb, s-osinte-linux.ads, s-osinte-freebsd.adb, ! s-osinte-freebsd.ads, s-osinte-solaris-posix.ads, s-osinte-hpux.ads, s-osinte-darwin.adb, s-osinte-darwin.ads, s-osinte-lynxos-3.ads, s-osinte-lynxos-3.adb (To_Target_Priority): New function maps from System.Any_Priority to a POSIX priority on the target. ! * system-linux-ia64.ads: Extend range of Priority types on Linux to use the whole range made available by the system. *************** *** 9622,9633 **** Priority_Specific_Dispatching pragmas when determining if Round Robin must be used for scheduling the task. ! * system-linux-x86_64.ads, system-linux-x86.ads, system-linux-ppc.ads: Extend range of Priority types on Linux to use the whole range made available by the system. ! * s-taprop-vms.adb, s-taprop-mingw.adb, s-taprop-irix.adb, ! s-taprop-tru64.adb, s-taprop-linux.adb, s-taprop-hpux-dce.adb, s-taprop-lynxos.adb (Finalize_TCB): invalidate the stack-check cache when deallocating the TCB in order to avoid potential references to deallocated data. --- 18102,18113 ---- Priority_Specific_Dispatching pragmas when determining if Round Robin must be used for scheduling the task. ! * system-linux-x86_64.ads, system-linux-x86.ads, system-linux-ppc.ads: Extend range of Priority types on Linux to use the whole range made available by the system. ! * s-taprop-vms.adb, s-taprop-mingw.adb, s-taprop-irix.adb, ! s-taprop-tru64.adb, s-taprop-linux.adb, s-taprop-hpux-dce.adb, s-taprop-lynxos.adb (Finalize_TCB): invalidate the stack-check cache when deallocating the TCB in order to avoid potential references to deallocated data. *************** *** 9646,9659 **** 2006-10-31 Robert Dewar ! * system-vms_64.ads, system-darwin-ppc.ads, system-vxworks-x86.ads, ! system-linux-hppa.ads, system-hpux-ia64.ads, ! system-lynxos-ppc.ads, system-lynxos-x86.ads, system-tru64.ads, ! system-vxworks-sparcv9.ads, system-solaris-x86.ads, ! system-irix-o32.ads, system-irix-n32.ads, system-hpux.ads, ! system-vxworks-m68k.ads, system-vxworks-mips.ads, system-interix.ads, ! system-solaris-sparc.ads, system-solaris-sparcv9.ads, system-vms.ads, ! system-mingw.ads, system-vms-zcx.ads, system-vxworks-ppc.ads, system-vxworks-alpha.ads, system.ads: Add pragma Warnings(Off, Default_Bit_Order) to kill constant condition warnings for references to this switch. --- 18126,18139 ---- 2006-10-31 Robert Dewar ! * system-vms_64.ads, system-darwin-ppc.ads, system-vxworks-x86.ads, ! system-linux-hppa.ads, system-hpux-ia64.ads, ! system-lynxos-ppc.ads, system-lynxos-x86.ads, system-tru64.ads, ! system-vxworks-sparcv9.ads, system-solaris-x86.ads, ! system-irix-o32.ads, system-irix-n32.ads, system-hpux.ads, ! system-vxworks-m68k.ads, system-vxworks-mips.ads, system-interix.ads, ! system-solaris-sparc.ads, system-solaris-sparcv9.ads, system-vms.ads, ! system-mingw.ads, system-vms-zcx.ads, system-vxworks-ppc.ads, system-vxworks-alpha.ads, system.ads: Add pragma Warnings(Off, Default_Bit_Order) to kill constant condition warnings for references to this switch. *************** *** 9671,9677 **** * mlib-fil.ads, mlib-fil.adb: (Append_To): New function ! * mlib-tgt-darwin.adb: Use Append_To, instead of Ext_To, when building the library file name (Flat_Namespace): New global variable. (No_Shared_Libgcc_Switch): Rename to No_Shared_Libgcc_Options. --- 18151,18157 ---- * mlib-fil.ads, mlib-fil.adb: (Append_To): New function ! * mlib-tgt-darwin.adb: Use Append_To, instead of Ext_To, when building the library file name (Flat_Namespace): New global variable. (No_Shared_Libgcc_Switch): Rename to No_Shared_Libgcc_Options. *************** *** 9688,9694 **** 2006-10-31 Jose Ruiz ! * s-osinte-vxworks.ads, s-osinte-vxworks.adb: (getpid): New body for this function that uses the underlying taskIdSelf function for VxWorks 5 and VxWorks 6 in kernel mode. (unsigned_int): New type, modular to allow logical bit operations. --- 18168,18174 ---- 2006-10-31 Jose Ruiz ! * s-osinte-vxworks.ads, s-osinte-vxworks.adb: (getpid): New body for this function that uses the underlying taskIdSelf function for VxWorks 5 and VxWorks 6 in kernel mode. (unsigned_int): New type, modular to allow logical bit operations. *************** *** 9921,9931 **** * lib.adb, lib.ads: (In_Predefined_Unit): New functions ! * a-finali.ads, a-ngcoty.ads, a-strbou.ads, a-stream.ads, a-strmap.ads, ! a-strunb.ads, a-stwibo.ads, a-stwima.ads, a-stwiun.ads, a-taside.ads, ! a-coorse.ads, a-convec.ads, a-coinve.ads, a-cohama.ads, a-ciorse.ads, ! a-cihama.ads, a-cihase.ads, a-cohase.ads, a-ciorma.ads, a-coorma.ads, ! a-ciormu.ads, a-coormu.ads, a-stzbou.ads, a-stzmap.ads, a-stzunb.ads, a-except-2005.ads: Add pragma Preelaborable_Warning 2006-10-31 Robert Dewar --- 18401,18411 ---- * lib.adb, lib.ads: (In_Predefined_Unit): New functions ! * a-finali.ads, a-ngcoty.ads, a-strbou.ads, a-stream.ads, a-strmap.ads, ! a-strunb.ads, a-stwibo.ads, a-stwima.ads, a-stwiun.ads, a-taside.ads, ! a-coorse.ads, a-convec.ads, a-coinve.ads, a-cohama.ads, a-ciorse.ads, ! a-cihama.ads, a-cihase.ads, a-cohase.ads, a-ciorma.ads, a-coorma.ads, ! a-ciormu.ads, a-coormu.ads, a-stzbou.ads, a-stzmap.ads, a-stzunb.ads, a-except-2005.ads: Add pragma Preelaborable_Warning 2006-10-31 Robert Dewar *************** *** 10025,10031 **** 2006-10-31 Javier Miranda ! * a-tags.ads, a-tags.adb: (Predefined_DT): New function that improves readability of the code. (Get_Predefined_Prim_Op_Address, Set_Predefined_Prim_Op_Address, Inherit_DT): Use the new function Predefined_DT to improve code --- 18505,18511 ---- 2006-10-31 Javier Miranda ! * a-tags.ads, a-tags.adb: (Predefined_DT): New function that improves readability of the code. (Get_Predefined_Prim_Op_Address, Set_Predefined_Prim_Op_Address, Inherit_DT): Use the new function Predefined_DT to improve code *************** *** 10183,10192 **** Implement insertion character ~ (insert string) (First_Node): Minor adjustments to get better placement. ! * frontend.adb: Implement new -gnatl=xxx switch to output listing to file ! * gnat1drv.adb: Implement new -gnatl=xxx switch to output listing to file * opt.ads: (Warn_On_Questionable_Missing_Paren): New switch --- 18663,18672 ---- Implement insertion character ~ (insert string) (First_Node): Minor adjustments to get better placement. ! * frontend.adb: Implement new -gnatl=xxx switch to output listing to file ! * gnat1drv.adb: Implement new -gnatl=xxx switch to output listing to file * opt.ads: (Warn_On_Questionable_Missing_Paren): New switch *************** *** 10207,10218 **** invoked with a relative path. (Executable_Name): New function taking string parameters. ! * osint-c.ads, osint-c.adb: Implement new -gnatl=xxx switch to output listing to file * sinput-d.adb: Change name Creat_Debug_File to Create_Debug_File ! * switch-c.adb: Implement new -gnatl=xxx switch to output listing to file Recognize new -gnatL switch (no longer keep in old warning about old style usage) --- 18687,18698 ---- invoked with a relative path. (Executable_Name): New function taking string parameters. ! * osint-c.ads, osint-c.adb: Implement new -gnatl=xxx switch to output listing to file * sinput-d.adb: Change name Creat_Debug_File to Create_Debug_File ! * switch-c.adb: Implement new -gnatl=xxx switch to output listing to file Recognize new -gnatL switch (no longer keep in old warning about old style usage) *************** *** 10263,10269 **** Javier Miranda Robert Dewar ! * exp_attr.adb: (Expand_Access_To_Protected_Op): If the context indicates that an access to a local operation may be transfered outside of the object, create an access to the wrapper operation that must be used in an external call. --- 18743,18749 ---- Javier Miranda Robert Dewar ! * exp_attr.adb: (Expand_Access_To_Protected_Op): If the context indicates that an access to a local operation may be transfered outside of the object, create an access to the wrapper operation that must be used in an external call. *************** *** 11109,11115 **** * rtsfind.adb: Remove s-polint from comment as it exists no more. ! * rtsfind.ads: Move entity RE_Get_Active_Partition_Id to package System.DSA_Services. Move all the entities in obsolete package System.PolyORB_Interface to System.Partition_Interface. --- 19589,19595 ---- * rtsfind.adb: Remove s-polint from comment as it exists no more. ! * rtsfind.ads: Move entity RE_Get_Active_Partition_Id to package System.DSA_Services. Move all the entities in obsolete package System.PolyORB_Interface to System.Partition_Interface. *************** *** 11561,11567 **** 2006-10-31 Robert Dewar ! * s-osinte-tru64.adb: Mark Asm statements Volatile to prevent warnings (seems a reasonable change anyway) Fixes new warnings --- 20041,20047 ---- 2006-10-31 Robert Dewar ! * s-osinte-tru64.adb: Mark Asm statements Volatile to prevent warnings (seems a reasonable change anyway) Fixes new warnings *************** *** 11649,11655 **** (No_Restrictions): New constant used to clean up code and follow preelaborate constraints. ! * s-stalib.adb: Add System.Restrictions dependence, referenced directly from the binder generated file. --- 20129,20135 ---- (No_Restrictions): New constant used to clean up code and follow preelaborate constraints. ! * s-stalib.adb: Add System.Restrictions dependence, referenced directly from the binder generated file. *************** *** 11780,11786 **** 2006-10-31 Pat Rogers ! * a-rttiev.ads, a-rttiev.adb: This is a significant redesign primarily for the sake of automatic timer task termination but also to fix a design flaw. Therefore we are now using an RTS lock, instead of a protected --- 20260,20266 ---- 2006-10-31 Pat Rogers ! * a-rttiev.ads, a-rttiev.adb: This is a significant redesign primarily for the sake of automatic timer task termination but also to fix a design flaw. Therefore we are now using an RTS lock, instead of a protected *************** *** 11813,11819 **** Clarify that inlining is not always possible Update documentation on pragma Unchecked_Union. ! * gnat_rm.texi: Add documentation for new extended version of pragma Obsolescent Add documentation for implementation defined attribute 'Stub_Type. Add note on use of Volatile in asm statements --- 20293,20299 ---- Clarify that inlining is not always possible Update documentation on pragma Unchecked_Union. ! * gnat_rm.texi: Add documentation for new extended version of pragma Obsolescent Add documentation for implementation defined attribute 'Stub_Type. Add note on use of Volatile in asm statements *************** *** 11827,11833 **** Clarify difference between No_Dispatching_Calls & No_Dispatch. Add documentation for pragma Restrictions (No_Elaboration_Code) ! * gnat-style.texi: Add comments on layout of subprogram local variables in the presence of nested subprograms. --- 20307,20313 ---- Clarify difference between No_Dispatching_Calls & No_Dispatch. Add documentation for pragma Restrictions (No_Elaboration_Code) ! * gnat-style.texi: Add comments on layout of subprogram local variables in the presence of nested subprograms. *************** *** 11844,11850 **** * usage.adb: Update documentation. ! * validsw.ads, validsw.adb: Add definition of Validity_Check_Components and implement -gnatVe/E * vms_data.ads: Add missing VMS qualifiers. --- 20324,20330 ---- * usage.adb: Update documentation. ! * validsw.ads, validsw.adb: Add definition of Validity_Check_Components and implement -gnatVe/E * vms_data.ads: Add missing VMS qualifiers. *************** *** 11885,11894 **** * s-soflin.adb: Minor reformatting ! * s-stoele.ads: Add comment about odd qualification in Storage_Offset declaration ! * s-strxdr.adb: Remove unnecessary 'in' keywords for formal parameters. * treeprs.adt: Minor reformatting --- 20365,20374 ---- * s-soflin.adb: Minor reformatting ! * s-stoele.ads: Add comment about odd qualification in Storage_Offset declaration ! * s-strxdr.adb: Remove unnecessary 'in' keywords for formal parameters. * treeprs.adt: Minor reformatting *************** *** 11916,11922 **** * lang.opt: Woverlength-strings: New option. ! * nmake.adt: Update copyright, since nmake.ads and nmake.adb have changed. * osint-b.ads, osint-b.adb (Time_From_Last_Bind): removed function . --- 20396,20402 ---- * lang.opt: Woverlength-strings: New option. ! * nmake.adt: Update copyright, since nmake.ads and nmake.adb have changed. * osint-b.ads, osint-b.adb (Time_From_Last_Bind): removed function . *************** *** 12021,12027 **** * fe.h: Remove redundant declarations. ! 2006-10-23 Rafael Avila de Espindola * utils.c (builtin_function): Rename to gnat_builtin_function. Move common code to add_builtin_function. --- 20501,20507 ---- * fe.h: Remove redundant declarations. ! 2006-10-23 Rafael Ãvila de Espíndola * utils.c (builtin_function): Rename to gnat_builtin_function. Move common code to add_builtin_function. *************** *** 12050,12056 **** of Get_Jmpbuf_Address_Soft and Get_GNAT_Exception. * utils2.c (build_call_0_expr): Do not set TREE_SIDE_EFFECTS. ! 2006-08-20 Laurent GUERBY PR ada/28716 g-socket.adb (Bind_Socket): Call Set_Address. --- 20530,20536 ---- of Get_Jmpbuf_Address_Soft and Get_GNAT_Exception. * utils2.c (build_call_0_expr): Do not set TREE_SIDE_EFFECTS. ! 2006-08-20 Laurent Guerby PR ada/28716 g-socket.adb (Bind_Socket): Call Set_Address. *************** *** 12123,12129 **** PR ada/27944 * s-taprop-hpux-dce.adb: Delete redundant 'with System.Parameters'. ! 2006-06-06 Laurent GUERBY PR ada/27769 mlib-utl.adb: Use Program_Name. --- 20603,20609 ---- PR ada/27944 * s-taprop-hpux-dce.adb: Delete redundant 'with System.Parameters'. ! 2006-06-06 Laurent Guerby PR ada/27769 mlib-utl.adb: Use Program_Name. *************** *** 12172,12178 **** * utils.c (create_var_decl): Use have_global_bss_p when deciding whether to make the decl common. ! 2006-02-20 Rafael Ávila de Espíndola * Make-lang.in (Ada): Remove. (.PHONY): Remove Ada --- 20652,20658 ---- * utils.c (create_var_decl): Use have_global_bss_p when deciding whether to make the decl common. ! 2006-02-20 Rafael Ãvila de Espíndola * Make-lang.in (Ada): Remove. (.PHONY): Remove Ada *************** *** 12200,12208 **** 2006-02-17 Jose Ruiz ! * s-taprop-irix.adb, s-taprop-hpux-dce.adb, s-taprop-linux.adb, ! s-taprop-solaris.adb, s-taprop-vms.adb, s-taprop-mingw.adb, ! s-taprop-posix.adb, s-taprop-vxworks.adb, s-taprop-lynxos.adb, s-taprop-tru64.adb (Set_False, Set_True, Suspend_Until_True): Add Abort_Defer/Undefer pairs to avoid the possibility of a task being aborted while owning a lock. --- 20680,20688 ---- 2006-02-17 Jose Ruiz ! * s-taprop-irix.adb, s-taprop-hpux-dce.adb, s-taprop-linux.adb, ! s-taprop-solaris.adb, s-taprop-vms.adb, s-taprop-mingw.adb, ! s-taprop-posix.adb, s-taprop-vxworks.adb, s-taprop-lynxos.adb, s-taprop-tru64.adb (Set_False, Set_True, Suspend_Until_True): Add Abort_Defer/Undefer pairs to avoid the possibility of a task being aborted while owning a lock. *************** *** 12312,12318 **** 2006-02-17 Matthew Heaney ! * a-convec.ads, a-convec.adb: (operator "&"): handle potential overflow for large index types (Insert): removed Contraint_Error when using large index types (Insert_Space): removed Constraint_Error for large index types --- 20792,20798 ---- 2006-02-17 Matthew Heaney ! * a-convec.ads, a-convec.adb: (operator "&"): handle potential overflow for large index types (Insert): removed Contraint_Error when using large index types (Insert_Space): removed Constraint_Error for large index types *************** *** 12331,12337 **** * s-wchcnv.adb: Document handling of [ on output (we do not change this to ["5B"] and the new comments say why not. ! * gnat_ugn.texi: Add note for -gnatVo that this now includes the cases of type conversions and qualified expressions. Add comments on handling of brackets encoding for Text_IO --- 20811,20817 ---- * s-wchcnv.adb: Document handling of [ on output (we do not change this to ["5B"] and the new comments say why not. ! * gnat_ugn.texi: Add note for -gnatVo that this now includes the cases of type conversions and qualified expressions. Add comments on handling of brackets encoding for Text_IO *************** *** 12451,12461 **** 2006-02-13 Arnaud Charlet ! * s-osinte-darwin.adb, s-osinte-darwin.ads, s-osinte-vxworks.ads, ! s-osinte-solaris.ads, s-osinte-linux.ads, s-osinte-freebsd.ads, ! s-osinte-solaris-posix.ads, s-osinte-lynxos-3.ads, s-osinte-lynxos.ads, ! s-osinte-tru64.ads, s-osinte-aix.ads, s-osinte-irix.ads, ! s-osinte-hpux-dce.ads, s-osinte-linux-hppa.ads, s-osinte-linux-alpha.ads, s-inmaop-posix.adb (sigset_t_ptr): Removed, replaced by anonymous access type. (pthread_sigmask): Now take an access sigset_t --- 20931,20941 ---- 2006-02-13 Arnaud Charlet ! * s-osinte-darwin.adb, s-osinte-darwin.ads, s-osinte-vxworks.ads, ! s-osinte-solaris.ads, s-osinte-linux.ads, s-osinte-freebsd.ads, ! s-osinte-solaris-posix.ads, s-osinte-lynxos-3.ads, s-osinte-lynxos.ads, ! s-osinte-tru64.ads, s-osinte-aix.ads, s-osinte-irix.ads, ! s-osinte-hpux-dce.ads, s-osinte-linux-hppa.ads, s-osinte-linux-alpha.ads, s-inmaop-posix.adb (sigset_t_ptr): Removed, replaced by anonymous access type. (pthread_sigmask): Now take an access sigset_t *************** *** 12466,12473 **** 2006-02-13 Pascal Obry ! * s-taprop-posix.adb, s-taprop-vxworks.adb, s-taprop-tru64.adb, ! s-taprop-lynxos.adb, s-taprop-irix.adb, s-taprop-hpux-dce.adb, s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-vms.adb (Create_Task): Remove task adjustment code. This adjustement is already done when calling this routine. --- 20946,20953 ---- 2006-02-13 Pascal Obry ! * s-taprop-posix.adb, s-taprop-vxworks.adb, s-taprop-tru64.adb, ! s-taprop-lynxos.adb, s-taprop-irix.adb, s-taprop-hpux-dce.adb, s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-vms.adb (Create_Task): Remove task adjustment code. This adjustement is already done when calling this routine. *************** *** 12556,12562 **** Eric Botcazou * ada-tree.h: (TYPE_UNCHECKED_UNION_P): Deleted. ! * gigi.h (value_factor_p): Add prototype and description, now public. * decl.c (gnat_to_gnu_field): Don't attempt BLKmode to integral type --- 21036,21042 ---- Eric Botcazou * ada-tree.h: (TYPE_UNCHECKED_UNION_P): Deleted. ! * gigi.h (value_factor_p): Add prototype and description, now public. * decl.c (gnat_to_gnu_field): Don't attempt BLKmode to integral type *************** *** 12782,12789 **** 2006-02-13 Matthew Heaney ! * a-rbtgso.adb, a-crbtgo.adb, a-crbtgk.adb, a-coorse.adb, ! a-cohama.adb, a-ciorse.adb, a-cihama.adb, a-cihase.adb, a-cohase.adb: All explicit raise statements now include an exception message. --- 21262,21269 ---- 2006-02-13 Matthew Heaney ! * a-rbtgso.adb, a-crbtgo.adb, a-crbtgk.adb, a-coorse.adb, ! a-cohama.adb, a-ciorse.adb, a-cihama.adb, a-cihase.adb, a-cohase.adb: All explicit raise statements now include an exception message. *************** *** 12840,12846 **** 2006-02-13 Robert Dewar ! * rtsfind.adb, exp_prag.adb, lib-writ.adb, par-labl.adb, sem_case.adb: Minor code reorganization (not Present should be No) 2006-02-13 Geert Bosch --- 21320,21326 ---- 2006-02-13 Robert Dewar ! * rtsfind.adb, exp_prag.adb, lib-writ.adb, par-labl.adb, sem_case.adb: Minor code reorganization (not Present should be No) 2006-02-13 Geert Bosch *************** *** 12979,12985 **** Define Tree_Version_String as a dynamic string. (Default_Stack_Size): new variable, used to handle switch -d. ! * par-prag.adb: For pragma Ada_2005, remove stuff about setting Ada_Version_Explicit only for main unit. Add pragma Ada_2005 (synonym for Ada_05) --- 21459,21465 ---- Define Tree_Version_String as a dynamic string. (Default_Stack_Size): new variable, used to handle switch -d. ! * par-prag.adb: For pragma Ada_2005, remove stuff about setting Ada_Version_Explicit only for main unit. Add pragma Ada_2005 (synonym for Ada_05) *************** *** 13991,13997 **** Multi_Unit_Index_Character after OpenVMS_On_Target gets its definitive value. (Get_Target_Parameters): Set OpenVMS_On_Target if openvms. ! * targparm.ads: Add special exception to license. * g-os_lib.ads, g-os_lib.adb (Get_Target_Debuggable_Suffix): New --- 22471,22477 ---- Multi_Unit_Index_Character after OpenVMS_On_Target gets its definitive value. (Get_Target_Parameters): Set OpenVMS_On_Target if openvms. ! * targparm.ads: Add special exception to license. * g-os_lib.ads, g-os_lib.adb (Get_Target_Debuggable_Suffix): New *************** *** 14112,14122 **** (Set_Output): new subprogram (Put): now uses the value of Current_Out to know if the output has to be send to stderr or stdout. ! * s-stausa.ads: Complete implementation. * switch-b.adb: Added handling of -u switch for dynamic stack analysis. ! * impunit.adb (Non_Imp_File_Names_05): Add Ada.Task_Termination to the list of Ada 05 files. (GNAT Library Units): Add AltiVec files. --- 22592,22602 ---- (Set_Output): new subprogram (Put): now uses the value of Current_Out to know if the output has to be send to stderr or stdout. ! * s-stausa.ads: Complete implementation. * switch-b.adb: Added handling of -u switch for dynamic stack analysis. ! * impunit.adb (Non_Imp_File_Names_05): Add Ada.Task_Termination to the list of Ada 05 files. (GNAT Library Units): Add AltiVec files. *************** *** 14288,14294 **** * namet.ads (Name_Buffer): Adjust size to reflect increase on max line length. ! * scn.adb, scng.adb: Always check line length against the absolute supported maximum, Hostparm.Max_Line_Length. --- 22768,22774 ---- * namet.ads (Name_Buffer): Adjust size to reflect increase on max line length. ! * scn.adb, scng.adb: Always check line length against the absolute supported maximum, Hostparm.Max_Line_Length. *************** *** 14400,14406 **** * par-ch12.adb (P_Formal_Derived_Type_Definition): In Ada 2005, handle use of "limited" in declaration. ! * sinfo.ads, sinfo.adb: Formal derived types can carry an explicit "limited" indication. * sem_ch3.adb: Add with and use of Targparm. --- 22880,22886 ---- * par-ch12.adb (P_Formal_Derived_Type_Definition): In Ada 2005, handle use of "limited" in declaration. ! * sinfo.ads, sinfo.adb: Formal derived types can carry an explicit "limited" indication. * sem_ch3.adb: Add with and use of Targparm. *************** *** 14625,14640 **** 2005-12-09 Robert Dewar ! * g-soccon.ads: Further comment fixes to make the status of the default file clear * s-bitops.adb: Clarify comment for Bits_Array ! 2005-12-07 Rafael Ávila de Espíndola * Make-lang.in (ada.install-normal): Remove. ! 2005-12-07 Rafael Ávila de Espíndola * Make-lang.in: Remove all dependencies on s-gtype. --- 23105,23120 ---- 2005-12-09 Robert Dewar ! * g-soccon.ads: Further comment fixes to make the status of the default file clear * s-bitops.adb: Clarify comment for Bits_Array ! 2005-12-07 Rafael Ãvila de Espíndola * Make-lang.in (ada.install-normal): Remove. ! 2005-12-07 Rafael Ãvila de Espíndola * Make-lang.in: Remove all dependencies on s-gtype. *************** *** 14656,14666 **** * utils.c (max_size): Only test for TREE_OVERFLOW on INTEGER_CST nodes. ! 2005-11-23 Laurent GUERBY * mlib-prj.adb (Build_Library): Initialize Delete. ! 2005-11-21 Joel Sherrill * socket.c: Add extern int h_errno for rtems since networking header files are not available at this point in a tool bootstrap. Newlib --- 23136,23146 ---- * utils.c (max_size): Only test for TREE_OVERFLOW on INTEGER_CST nodes. ! 2005-11-23 Laurent Guerby * mlib-prj.adb (Build_Library): Initialize Delete. ! 2005-11-21 Joel Sherrill * socket.c: Add extern int h_errno for rtems since networking header files are not available at this point in a tool bootstrap. Newlib *************** *** 14674,14680 **** the error message text, instead use pp_format_text and the new pretty printer APIs. This allows handling of %qs, %w, etc. ! 2005-11-18 Laurent GUERBY PR ada/24857 * Makefile.in: Use s-auxdec-empty for RTEMS. --- 23154,23160 ---- the error message text, instead use pp_format_text and the new pretty printer APIs. This allows handling of %qs, %w, etc. ! 2005-11-18 Laurent Guerby PR ada/24857 * Makefile.in: Use s-auxdec-empty for RTEMS. *************** *** 14687,14693 **** reference, declaration, or constant, since the gimplifier can't handle that case. ! 2005-11-17 Laurent GUERBY PR ada/24857 * s-auxdec-empty.ads, s-auxdec-empty.adb: New files. --- 23167,23173 ---- reference, declaration, or constant, since the gimplifier can't handle that case. ! 2005-11-17 Laurent Guerby PR ada/24857 * s-auxdec-empty.ads, s-auxdec-empty.adb: New files. *************** *** 14696,14706 **** * Makefile.in: Add EH_MECHANISM=-gcc to s390(x) linux. ! 2005-11-16 Joel Sherrill PR ada/24855 * raise-gcc.c: Add missing stdarg.h include. ! 2005-11-16 Richard Guenther * Make-lang.in (ada/decl.o): Add $(EXPR_H) dependency. --- 23176,23186 ---- * Makefile.in: Add EH_MECHANISM=-gcc to s390(x) linux. ! 2005-11-16 Joel Sherrill PR ada/24855 * raise-gcc.c: Add missing stdarg.h include. ! 2005-11-16 Richard Guenther * Make-lang.in (ada/decl.o): Add $(EXPR_H) dependency. *************** *** 14728,14734 **** g-soccon-solaris-64.ads, g-soccon-linux-64.ads, g-soccon-linux-x86.ads: New files. ! * g-socthi-mingw.adb: (Socket_Error_Message): Remove redundant use of GNAT.Sockets.Constants * g-socthi-vxworks.ads, g-socthi-vms.ads, g-socthi-mingw.ads --- 23208,23214 ---- g-soccon-solaris-64.ads, g-soccon-linux-64.ads, g-soccon-linux-x86.ads: New files. ! * g-socthi-mingw.adb: (Socket_Error_Message): Remove redundant use of GNAT.Sockets.Constants * g-socthi-vxworks.ads, g-socthi-vms.ads, g-socthi-mingw.ads *************** *** 14817,14826 **** * s-mastop-tru64.adb (Pop_Frame): Remove redundant parentheses in if statement. ! * s-taprop-solaris.adb: Change some <= to =, to avoid new warning ! * a-exexda.adb, prj-proc.adb: Fix obvious typo (Num_Tracebacks compared <= 0 instead of < 0) Fix obvious typo (Total_Errors_Detected <= 0 should be = 0) --- 23297,23306 ---- * s-mastop-tru64.adb (Pop_Frame): Remove redundant parentheses in if statement. ! * s-taprop-solaris.adb: Change some <= to =, to avoid new warning ! * a-exexda.adb, prj-proc.adb: Fix obvious typo (Num_Tracebacks compared <= 0 instead of < 0) Fix obvious typo (Total_Errors_Detected <= 0 should be = 0) *************** *** 14834,14840 **** 2005-11-14 Matthew Gingell ! * system-lynxos-ppc.ads, system-lynxos-x86.ads: Increase default priority on Lynx from 15 to 17, and meet the Ada requirement that Default_Priority be ((Priority'First + Priority'Last) / 2) by increasing the range of Interrupt_Priority. --- 23314,23320 ---- 2005-11-14 Matthew Gingell ! * system-lynxos-ppc.ads, system-lynxos-x86.ads: Increase default priority on Lynx from 15 to 17, and meet the Ada requirement that Default_Priority be ((Priority'First + Priority'Last) / 2) by increasing the range of Interrupt_Priority. *************** *** 15043,15054 **** 2005-11-14 Matthew Heaney ! * a-crbtgo.ads, a-crbtgo.adb, a-coorse.ads, a-coorse.adb, a-convec.ads, ! a-convec.adb, a-coinve.ads, a-coinve.adb, a-cohama.ads, a-cohama.adb, ! a-ciorse.ads, a-ciorse.adb, a-cihama.ads, a-cihama.adb, a-cidlli.ads, ! a-cidlli.adb, a-cdlili.ads, a-cdlili.adb, a-coormu.adb, a-ciormu.adb, ! a-cihase.adb, a-cihase.ads, a-cohase.adb, a-cohase.ads, a-ciorma.ads, ! a-coorma.ads, a-ciormu.ads, a-coormu.ads, a-ciorma.adb, a-coorma.adb: Compiles against the spec for ordered maps described in sections A.18.6 of the most recent (August 2005) AI-302 draft. --- 23523,23534 ---- 2005-11-14 Matthew Heaney ! * a-crbtgo.ads, a-crbtgo.adb, a-coorse.ads, a-coorse.adb, a-convec.ads, ! a-convec.adb, a-coinve.ads, a-coinve.adb, a-cohama.ads, a-cohama.adb, ! a-ciorse.ads, a-ciorse.adb, a-cihama.ads, a-cihama.adb, a-cidlli.ads, ! a-cidlli.adb, a-cdlili.ads, a-cdlili.adb, a-coormu.adb, a-ciormu.adb, ! a-cihase.adb, a-cihase.ads, a-cohase.adb, a-cohase.ads, a-ciorma.ads, ! a-coorma.ads, a-ciormu.ads, a-coormu.ads, a-ciorma.adb, a-coorma.adb: Compiles against the spec for ordered maps described in sections A.18.6 of the most recent (August 2005) AI-302 draft. *************** *** 15154,15160 **** * binde.adb: Implement new AD/ED for Elaborate_All/Elaborate desirable (Elab_Error_Msg): Use -da to include internal unit links, not -de. ! * lib-writ.ads, lib-writ.adb: Implement new AD/ED for Elaborate_All/Elaborate desirable Use new Elaborate_All_Desirable flag in N_With_Clause node --- 23634,23640 ---- * binde.adb: Implement new AD/ED for Elaborate_All/Elaborate desirable (Elab_Error_Msg): Use -da to include internal unit links, not -de. ! * lib-writ.ads, lib-writ.adb: Implement new AD/ED for Elaborate_All/Elaborate desirable Use new Elaborate_All_Desirable flag in N_With_Clause node *************** *** 15232,15238 **** * Makefile.rtl: Add new instantiations of system.fat_gen ! * s-fatflt.ads, s-fatlfl.ads, s-fatllf.ads, s-fatsfl.ads: Change name of instantiated package for better consistency with newly added system.fat_gen instantiations. --- 23712,23718 ---- * Makefile.rtl: Add new instantiations of system.fat_gen ! * s-fatflt.ads, s-fatlfl.ads, s-fatllf.ads, s-fatsfl.ads: Change name of instantiated package for better consistency with newly added system.fat_gen instantiations. *************** *** 15823,15829 **** Jose Ruiz Pascal Obry ! * gnat_ugn.texi: Document that -fstack-check is needed for strict compliance with the Ada 95 Reference Manual. Correct reference to VAX systems to meet HP guidelines --- 24303,24309 ---- Jose Ruiz Pascal Obry ! * gnat_ugn.texi: Document that -fstack-check is needed for strict compliance with the Ada 95 Reference Manual. Correct reference to VAX systems to meet HP guidelines *************** *** 16076,16082 **** build_binary_op for the "target pointer" case. Use build_return_expr instead of manually building the RETURN_EXPR tree. ! 2005-09-16 Laurent GUERBY PR ada/23788 * s-tpinop.ads: Make this unit Preelaborate. --- 24556,24562 ---- build_binary_op for the "target pointer" case. Use build_return_expr instead of manually building the RETURN_EXPR tree. ! 2005-09-16 Laurent Guerby PR ada/23788 * s-tpinop.ads: Make this unit Preelaborate. *************** *** 19301,19307 **** comment typos. * gnat_rm.texi, gnat_ugn.texi: Fix typos. ! 2005-05-16 Nathanael Nerode PR ada/20270 * Makefile.in: Make TGT_LIB behave correctly. --- 27781,27787 ---- comment typos. * gnat_rm.texi, gnat_ugn.texi: Fix typos. ! 2005-05-16 Nathanael Nerode PR ada/20270 * Makefile.in: Make TGT_LIB behave correctly. *************** *** 19310,19316 **** * misc.c: Adjust warning() callers. ! 2005-04-16 Laurent GUERBY PR ada/18847 * a-nudira.adb (Value): Check for valid string. --- 27790,27796 ---- * misc.c: Adjust warning() callers. ! 2005-04-16 Laurent Guerby PR ada/18847 * a-nudira.adb (Value): Check for valid string. *************** *** 19325,19331 **** * adaint.c, init.c, tracebak.c: Fix comment typos. * gnat-style.texi, gnat_rm.texi, gnat_ugn.texi: Fix typos. ! 2005-04-07 Laurent GUERBY John David Anglin * Makefile.in: Add make ifeq define for hppa linux tasking support. --- 27805,27811 ---- * adaint.c, init.c, tracebak.c: Fix comment typos. * gnat-style.texi, gnat_rm.texi, gnat_ugn.texi: Fix typos. ! 2005-04-07 Laurent Guerby John David Anglin * Makefile.in: Add make ifeq define for hppa linux tasking support. *************** *** 20677,20693 **** relaxed rules about placement of large packed bit array components. Add documentation of GNAT.UTF_32 ! 2005-03-12 Daniel Berlin * misc.c (gnat_post_options): Turn off structural aliasing for now. ! 2005-03-08 Laurent Guerby * system-linux-sparc.ads: Fix typo in previous commit. ! 2005-03-07 James A. Morrison ! Laurent Guerby PR ada/20035 * system-linux-sparc.ads: New. --- 29157,29173 ---- relaxed rules about placement of large packed bit array components. Add documentation of GNAT.UTF_32 ! 2005-03-12 Daniel Berlin * misc.c (gnat_post_options): Turn off structural aliasing for now. ! 2005-03-08 Laurent Guerby * system-linux-sparc.ads: Fix typo in previous commit. ! 2005-03-07 James A. Morrison ! Laurent Guerby PR ada/20035 * system-linux-sparc.ads: New. *************** *** 21245,21251 **** [VMS] (#define exit hack): Remove. 2005-02-09 Pascal Obry ! Arnaud Charlet * init.c (__gnat_initialize): Add a new parameter eh which contains the address of the exception registration. The Win32 version of this --- 29725,29731 ---- [VMS] (#define exit hack): Remove. 2005-02-09 Pascal Obry ! Arnaud Charlet * init.c (__gnat_initialize): Add a new parameter eh which contains the address of the exception registration. The Win32 version of this *************** *** 21492,21505 **** a-zttest.ads, a-zzunio.ads: New files. Part of new Ada 2005 library. ! 2005-01-27 Laurent GUERBY * Makefile.in: Fix a-intnam.ads from previous commit, add 2005 to copyright. * a-intman-rtems.ads: Renamed to... * a-intnam-rtems.ads: ! 2005-01-27 Laurent GUERBY * Makefile.in: Rename GNAT RTEMS specific files. * 5rtpopsp.adb, 4rintnam.ads, 5rosinte.adb, --- 29972,29985 ---- a-zttest.ads, a-zzunio.ads: New files. Part of new Ada 2005 library. ! 2005-01-27 Laurent Guerby * Makefile.in: Fix a-intnam.ads from previous commit, add 2005 to copyright. * a-intman-rtems.ads: Renamed to... * a-intnam-rtems.ads: ! 2005-01-27 Laurent Guerby * Makefile.in: Rename GNAT RTEMS specific files. * 5rtpopsp.adb, 4rintnam.ads, 5rosinte.adb, *************** *** 21507,21521 **** * s-tpopsp-rtems.adb, a-intman-rtems.ads, s-osinte-rtems.adb, s-osinte-rtems.ads, s-parame-rtems.adb: Replace files above. ! 2005-01-27 Joel Sherrill ! Laurent GUERBY PR ada/19488 * 5rosinte.ads: Add No_Key constant. * 5rtpopsp.adb: Initialize ATCB_Key with No_Key and fix style. * gsocket.h: Do not include with RTEMS either. ! 2005-01-26 Laurent GUERBY PR ada/19414 * i-cobol.adb (Valid_Numeric): Handle zero length case. --- 29987,30001 ---- * s-tpopsp-rtems.adb, a-intman-rtems.ads, s-osinte-rtems.adb, s-osinte-rtems.ads, s-parame-rtems.adb: Replace files above. ! 2005-01-27 Joel Sherrill ! Laurent Guerby PR ada/19488 * 5rosinte.ads: Add No_Key constant. * 5rtpopsp.adb: Initialize ATCB_Key with No_Key and fix style. * gsocket.h: Do not include with RTEMS either. ! 2005-01-26 Laurent Guerby PR ada/19414 * i-cobol.adb (Valid_Numeric): Handle zero length case. *************** *** 21902,21908 **** whether the ancestor type is private, as may be the case with nested instantiations. ! 2004-12-30 Sohail Somani PR ada/19128 * trans.c (gnat_to_gnu): Fix typo: Use correct return variable. --- 30382,30388 ---- whether the ancestor type is private, as may be the case with nested instantiations. ! 2004-12-30 Sohail Somani PR ada/19128 * trans.c (gnat_to_gnu): Fix typo: Use correct return variable. *************** *** 23067,23073 **** * mlib-tgt.ads: (Build_Dynamic_Library): New parameter Options_2 ! 2004-10-04 Laurent GUERBY PR ada/15156 * Makefile.in: Define and use RANLIB_FLAGS. --- 31547,31553 ---- * mlib-tgt.ads: (Build_Dynamic_Library): New parameter Options_2 ! 2004-10-04 Laurent Guerby PR ada/15156 * Makefile.in: Define and use RANLIB_FLAGS. *************** *** 27173,27179 **** * sem_elim.adb: Some minor code reorganization from code reading. Fix misprint in the function name (File_Name_Match). ! 2004-04-23 Laurent GUERBY * Makefile.in: Remove RANLIB_TEST, use -$(RANLIB) including after install. --- 35653,35659 ---- * sem_elim.adb: Some minor code reorganization from code reading. Fix misprint in the function name (File_Name_Match). ! 2004-04-23 Laurent Guerby * Makefile.in: Remove RANLIB_TEST, use -$(RANLIB) including after install. *************** *** 27258,27264 **** * snames.ads, snames.adb: Remove Name_Homonym_Number (Homonym_Number is no longer used as a parameter name for Eliminate pragma). ! 2004-04-22 Laurent GUERBY PR optimization/14984 PR optimization/14985 --- 35738,35744 ---- * snames.ads, snames.adb: Remove Name_Homonym_Number (Homonym_Number is no longer used as a parameter name for Eliminate pragma). ! 2004-04-22 Laurent Guerby PR optimization/14984 PR optimization/14985 *************** *** 27734,27740 **** * mdll-utl.adb (Locate): New version is idempotent. ! 2004-04-17 Laurent Guerby PR ada/14988 (partial) * impunit.adb: Fix typo. --- 36214,36220 ---- * mdll-utl.adb (Locate): New version is idempotent. ! 2004-04-17 Laurent Guerby PR ada/14988 (partial) * impunit.adb: Fix typo. *************** *** 28428,28434 **** (gnat_to_gnu_entity, case E_Array_Type): Don't set and clear it. * misc.c (LANG_HOOK_HASH_TYPE): Redefine. ! 2004-03-19 Laurent Guerby * sem_prag.adb (Suppress_Unsuppress_Echeck): use loop instead of aggregate, allows bootstrap from 3.3 on powerpc-darwin. --- 36908,36914 ---- (gnat_to_gnu_entity, case E_Array_Type): Don't set and clear it. * misc.c (LANG_HOOK_HASH_TYPE): Redefine. ! 2004-03-19 Laurent Guerby * sem_prag.adb (Suppress_Unsuppress_Echeck): use loop instead of aggregate, allows bootstrap from 3.3 on powerpc-darwin. *************** *** 30811,30817 **** * s-rident.ads: Add new restriction No_Direct_Boolean_Operators ! 2003-11-24 Arnaud Charlet PR ada/13142 * utils.c (init_gigi_decls): Change name of built-in setjmp to --- 39291,39297 ---- * s-rident.ads: Add new restriction No_Direct_Boolean_Operators ! 2003-11-24 Arnaud Charlet PR ada/13142 * utils.c (init_gigi_decls): Change name of built-in setjmp to *************** *** 32587,32593 **** * misc.c (gnat_handle_option): Don't handle filenames. ! 2003-07-04 H.J. Lu * Make-lang.in: Replace PWD with PWD_COMMAND. * Makefile.adalib: Likewise. --- 41067,41073 ---- * misc.c (gnat_handle_option): Don't handle filenames. ! 2003-07-04 H.J. Lu * Make-lang.in: Replace PWD with PWD_COMMAND. * Makefile.adalib: Likewise. *************** *** 32727,32733 **** * utils.c (finish_record_type): Remove usages of ROUND_TYPE_SIZE and ROUND_TYPE_SIZE_UNIT. ! 2003-05-22 Geert Bosch * gnat_rm.texi : Remove reference to Ada Core Technologies. --- 41207,41213 ---- * utils.c (finish_record_type): Remove usages of ROUND_TYPE_SIZE and ROUND_TYPE_SIZE_UNIT. ! 2003-05-22 Geert Bosch * gnat_rm.texi : Remove reference to Ada Core Technologies. *************** *** 32746,32752 **** end_subprog_body): Likewise. * utils2.c (build_call_raise): Likewise. ! 2003-05-01 Laurent Guerby PR ada/10546 * 5iosinte.ads: Increase pthread_cond_t size to match recent --- 41226,41232 ---- end_subprog_body): Likewise. * utils2.c (build_call_raise): Likewise. ! 2003-05-01 Laurent Guerby PR ada/10546 * 5iosinte.ads: Increase pthread_cond_t size to match recent *************** *** 32756,32762 **** * utils.c (convert): No need to clear TREE_CST_RTL. ! 2003-04-23 Geert Bosch * 1aexcept.adb, 1aexcept.ads, 1ic.ads, 1ssecsta.adb, 1ssecsta.ads, 31soccon.ads, 31soliop.ads, 3asoccon.ads, --- 41236,41242 ---- * utils.c (convert): No need to clear TREE_CST_RTL. ! 2003-04-23 Geert Bosch * 1aexcept.adb, 1aexcept.ads, 1ic.ads, 1ssecsta.adb, 1ssecsta.ads, 31soccon.ads, 31soliop.ads, 3asoccon.ads, *************** *** 33115,33121 **** * misc.c (gnat_adjust_rli): #if 0. ! 2003-03-31 Geert Bosch PR ada/10020 * link.c : Fix misspelled "const" keyword --- 41595,41601 ---- * misc.c (gnat_adjust_rli): #if 0. ! 2003-03-31 Geert Bosch PR ada/10020 * link.c : Fix misspelled "const" keyword *************** *** 33158,33164 **** * gnat_ug_unx.texi, gnat_ug_vms.texi, gnat_ug_vxw.texi, gnat_ug_wnt.texi: Regenerate. ! 2003-03-02 Laurent Guerby * Makefile.in (install-gnatlib): Match previous change there so it works. --- 41638,41644 ---- * gnat_ug_unx.texi, gnat_ug_vms.texi, gnat_ug_vxw.texi, gnat_ug_wnt.texi: Regenerate. ! 2003-03-02 Laurent Guerby * Makefile.in (install-gnatlib): Match previous change there so it works. *************** *** 33184,33190 **** * gnat_ug_unx.texi, gnat_ug_vms.texi, gnat_ug_vxw.texi, gnat_ug_wnt.texi: Regenerate. ! 2003-02-03 Christian Cornelssen * Make-lang.in (ada.install-info): Let $(DESTDIR)$(infodir) be created if necessary. --- 41664,41670 ---- * gnat_ug_unx.texi, gnat_ug_vms.texi, gnat_ug_vxw.texi, gnat_ug_wnt.texi: Regenerate. ! 2003-02-03 Christian Cornelssen * Make-lang.in (ada.install-info): Let $(DESTDIR)$(infodir) be created if necessary. *************** *** 33201,33214 **** * gnat_ug.texi: Remove -fvolatile from example. * gnat_ug_vxw.texi: Likewise. ! 2003-01-29 Laurent Guerby PR ada/8344 * final.c: rename to adafinal.c to avoid file name conflicts with gcc file. * Makefile.in: match previous change. * Make-lang.in: match previous change. ! 2003-01-29 Joel Sherrill * 5rosinte.ads: Add SIGXCPU. * 5rtpopsp.adb: New file. --- 41681,41694 ---- * gnat_ug.texi: Remove -fvolatile from example. * gnat_ug_vxw.texi: Likewise. ! 2003-01-29 Laurent Guerby PR ada/8344 * final.c: rename to adafinal.c to avoid file name conflicts with gcc file. * Makefile.in: match previous change. * Make-lang.in: match previous change. ! 2003-01-29 Joel Sherrill * 5rosinte.ads: Add SIGXCPU. * 5rtpopsp.adb: New file. *************** *** 33273,33283 **** ada/gnat_ug_wnt.dvi, ada/gnat_rm.dvi): Depend on $(srcdir)/doc/include/gcc-common.texi. ! 2002-12-15 Geert Bosch * sem_ch6.adb (Analyze_Subprogram_Body): Fix typo and formatting ! 2002-12-14 Geert Bosch PR ada/5690 * sem_ch6.adb (Analyze_Subprogram_Body): Recognize additional --- 41753,41763 ---- ada/gnat_ug_wnt.dvi, ada/gnat_rm.dvi): Depend on $(srcdir)/doc/include/gcc-common.texi. ! 2002-12-15 Geert Bosch * sem_ch6.adb (Analyze_Subprogram_Body): Fix typo and formatting ! 2002-12-14 Geert Bosch PR ada/5690 * sem_ch6.adb (Analyze_Subprogram_Body): Recognize additional *************** *** 33321,33334 **** * trans.c (gnu_pending_elaboration_lists): New GC root. (build_unit_elab): Use.. ! 2002-10-30 Geert Bosch PR ada/6558 * misc.c : Include optabs.h * Make-lang.in (misc.o): Add dependency on optabs.h ! 2002-10-29 Geert Bosch PR ada/6558 * Make-lang.in (gnatbind): Depend on CONFIG_H --- 41801,41814 ---- * trans.c (gnu_pending_elaboration_lists): New GC root. (build_unit_elab): Use.. ! 2002-10-30 Geert Bosch PR ada/6558 * misc.c : Include optabs.h * Make-lang.in (misc.o): Add dependency on optabs.h ! 2002-10-29 Geert Bosch PR ada/6558 * Make-lang.in (gnatbind): Depend on CONFIG_H *************** *** 33632,33639 **** * doc/tm.texi (REAL_VALUE_LDEXP): Remove. (REAL_VALUE_RNDZINT, REAL_VALUE_UNSIGNED_RNDZINT): Remove. ! 2002-08-25 Andre Leis ! David Billinghurst (David.Billinghurst@riotinto.com> * sysdep.c (__gnat_ttyname): include on cygwin --- 42112,42119 ---- * doc/tm.texi (REAL_VALUE_LDEXP): Remove. (REAL_VALUE_RNDZINT, REAL_VALUE_UNSIGNED_RNDZINT): Remove. ! 2002-08-25 Andre Leis ! David Billinghurst * sysdep.c (__gnat_ttyname): include on cygwin *************** *** 33961,33967 **** * Makefile.in: Pass VPATH=$(fsrcdir) when calling make in rts directory. ! 2001-03-28 Robert Dewar * checks.ads: (Remove_Checks): New procedure --- 42441,42447 ---- * Makefile.in: Pass VPATH=$(fsrcdir) when calling make in rts directory. ! 2001-03-28 Robert Dewar * checks.ads: (Remove_Checks): New procedure *************** *** 33996,34002 **** (Constant_Array_Ref): Deal with string literals (patch suggested by Zack Weinberg on the gcc list) ! 2001-03-28 Ed Schonberg * exp_util.adb: Duplicate_Subexpr_No_Checks_Orig => Duplicate_Subexpr_Move_Checks. --- 42476,42482 ---- (Constant_Array_Ref): Deal with string literals (patch suggested by Zack Weinberg on the gcc list) ! 2001-03-28 Ed Schonberg * exp_util.adb: Duplicate_Subexpr_No_Checks_Orig => Duplicate_Subexpr_Move_Checks. *************** *** 34008,34014 **** value of array exists before retrieving it (it may a private protected component in a function). ! 2002-03-28 Geert Bosch * prj-pp.adb : New file. --- 42488,42494 ---- value of array exists before retrieving it (it may a private protected component in a function). ! 2002-03-28 Geert Bosch * prj-pp.adb : New file. *************** *** 34055,34062 **** 2002-03-23 Florian Weimer * gnat_rm.texi: Sync with ACT version. - (From Ben Brosgol ) 2002-03-20 Neil Booth --- 42535,42542 ---- 2002-03-23 Florian Weimer + From Ben Brosgol * gnat_rm.texi: Sync with ACT version. 2002-03-20 Neil Booth *************** *** 34274,34280 **** function call could reallocate the table which was being indexed using its result). Fixes ada/4851. ! 2001-12-19 Robert Dewar * bindgen.adb: Minor reformatting --- 42754,42760 ---- function call could reallocate the table which was being indexed using its result). Fixes ada/4851. ! 2001-12-19 Robert Dewar * bindgen.adb: Minor reformatting *************** *** 34308,34314 **** error found (there were odd exceptions to this general rule in -gnatec/-gnatem processing) ! 2001-12-19 Olivier Hainque * raise.c (__gnat_eh_personality): Exception handling personality routine for Ada. Still in rough state, inspired from the C++ version --- 42788,42794 ---- error found (there were odd exceptions to this general rule in -gnatec/-gnatem processing) ! 2001-12-19 Olivier Hainque * raise.c (__gnat_eh_personality): Exception handling personality routine for Ada. Still in rough state, inspired from the C++ version *************** *** 34319,34325 **** * raise.c (eh_personality): Add comments. Part of work for the GCC 3 exception handling integration. ! 2001-12-19 Arnaud Charlet * Makefile.in: Remove use of 5smastop.adb which is obsolete. (HIE_SOURCES): Add s-secsta.ad{s,b}. --- 42799,42805 ---- * raise.c (eh_personality): Add comments. Part of work for the GCC 3 exception handling integration. ! 2001-12-19 Arnaud Charlet * Makefile.in: Remove use of 5smastop.adb which is obsolete. (HIE_SOURCES): Add s-secsta.ad{s,b}. *************** *** 34328,34334 **** interrupt handling files. (RAVEN_MOD): Removed, no longer needed. ! 2001-12-19 Robert Dewar * a-ngelfu.adb: Remove ??? comment for inappropriate Inline_Always Add 2001 to copyright date --- 42808,42814 ---- interrupt handling files. (RAVEN_MOD): Removed, no longer needed. ! 2001-12-19 Robert Dewar * a-ngelfu.adb: Remove ??? comment for inappropriate Inline_Always Add 2001 to copyright date *************** *** 34336,34342 **** * g-regpat.adb: Change pragma Inline_Always to Inline. There is no need to force universal inlining for these cases. ! 2001-12-19 Arnaud Charlet * s-taprob.adb: Minor clean ups so that this unit can be used in Ravenscar HI. --- 42816,42822 ---- * g-regpat.adb: Change pragma Inline_Always to Inline. There is no need to force universal inlining for these cases. ! 2001-12-19 Arnaud Charlet * s-taprob.adb: Minor clean ups so that this unit can be used in Ravenscar HI. *************** *** 34344,34359 **** * exp_ch7.adb: Allow use of secondary stack in HI mode. Disallow it when pragma Restrictions (No_Secondary_Stack) is specified. ! 2001-12-19 Vincent Celier * prj-tree.ads (Project_Node_Record): Add comments for components Pkg_Id and Case_Insensitive. ! 2001-12-19 Pascal Obry * g-socket.adb: Minor reformatting. Found while reading code. ! 2001-12-19 Robert Dewar * prj-tree.ads: Minor reformatting --- 42824,42839 ---- * exp_ch7.adb: Allow use of secondary stack in HI mode. Disallow it when pragma Restrictions (No_Secondary_Stack) is specified. ! 2001-12-19 Vincent Celier * prj-tree.ads (Project_Node_Record): Add comments for components Pkg_Id and Case_Insensitive. ! 2001-12-19 Pascal Obry * g-socket.adb: Minor reformatting. Found while reading code. ! 2001-12-19 Robert Dewar * prj-tree.ads: Minor reformatting *************** *** 34361,34367 **** * config-lang.in (diff_excludes): Remove. ! 2001-12-17 Ed Schonberg * sem_res.adb (Resolve_Selected_Component): do not generate a discriminant check if the selected component is a component of --- 42841,42847 ---- * config-lang.in (diff_excludes): Remove. ! 2001-12-17 Ed Schonberg * sem_res.adb (Resolve_Selected_Component): do not generate a discriminant check if the selected component is a component of *************** *** 34371,34377 **** type is private, the gnu_type is the base type of the full view, given that the full view itself may be a subtype. ! 2001-12-17 Robert Dewar * sem_res.adb: Minor reformatting --- 42851,42857 ---- type is private, the gnu_type is the base type of the full view, given that the full view itself may be a subtype. ! 2001-12-17 Robert Dewar * sem_res.adb: Minor reformatting *************** *** 34382,34397 **** * urealp.h: Add definition of Round_Even for call to Machine Add third parameter for Machine ! 2001-12-17 Ed Schonberg * sem_warn.adb (Check_One_Unit): Suppress warnings completely on predefined units in No_Run_Time mode. ! 2001-12-17 Richard Kenner * misc.c (insn-codes.h): Now include. ! 2001-12-17 Olivier Hainque * a-except.adb: Preparation work for future integration of the GCC 3 exception handling mechanism --- 42862,42877 ---- * urealp.h: Add definition of Round_Even for call to Machine Add third parameter for Machine ! 2001-12-17 Ed Schonberg * sem_warn.adb (Check_One_Unit): Suppress warnings completely on predefined units in No_Run_Time mode. ! 2001-12-17 Richard Kenner * misc.c (insn-codes.h): Now include. ! 2001-12-17 Olivier Hainque * a-except.adb: Preparation work for future integration of the GCC 3 exception handling mechanism *************** *** 34401,34411 **** (Propagate_Exception, Raise_Current_Excep, Raise_From_Signal_Handler): Use the new notification routines. ! 2001-12-17 Emmanuel Briot * prj-tree.ads (First_Choice_Of): Document the when others case ! 2001-12-17 Arnaud Charlet * bindgen.adb (Gen_Ada_Init_*): Set priority of environment task in HI-E mode, in order to support Ravenscar profile properly. --- 42881,42891 ---- (Propagate_Exception, Raise_Current_Excep, Raise_From_Signal_Handler): Use the new notification routines. ! 2001-12-17 Emmanuel Briot * prj-tree.ads (First_Choice_Of): Document the when others case ! 2001-12-17 Arnaud Charlet * bindgen.adb (Gen_Ada_Init_*): Set priority of environment task in HI-E mode, in order to support Ravenscar profile properly. *************** *** 34413,34419 **** * cstand.adb (Create_Standard): Duration is a 32 bit type in HI-E mode on 32 bits targets. ! 2001-12-17 Vincent Celier * fmap.adb: Initial version. --- 42893,42899 ---- * cstand.adb (Create_Standard): Duration is a 32 bit type in HI-E mode on 32 bits targets. ! 2001-12-17 Vincent Celier * fmap.adb: Initial version. *************** *** 34444,34456 **** * Makefile.in: Add dependencies for fmap.o. ! 2001-12-17 Ed Schonberg * sem_ch10.adb (Analyze_With_Clause): Retrieve proper entity when unit is a package instantiation rewritten as a package body. (Install_Withed_Unit): Undo previous change, now redundant. ! 2001-12-17 Gary Dismukes * layout.adb: (Compute_Length): Move conversion to Unsigned to callers. --- 42924,42936 ---- * Makefile.in: Add dependencies for fmap.o. ! 2001-12-17 Ed Schonberg * sem_ch10.adb (Analyze_With_Clause): Retrieve proper entity when unit is a package instantiation rewritten as a package body. (Install_Withed_Unit): Undo previous change, now redundant. ! 2001-12-17 Gary Dismuke * layout.adb: (Compute_Length): Move conversion to Unsigned to callers. *************** *** 34462,34468 **** where Max (Len, 0) wasn't getting applied due to the Unsigned conversion used by Compute_Length. ! 2001-12-17 Arnaud Charlet * rtsfind.ads: (OK_To_Use_In_No_Run_Time_Mode): Allow Ada.Exceptions and --- 42942,42948 ---- where Max (Len, 0) wasn't getting applied due to the Unsigned conversion used by Compute_Length. ! 2001-12-17 Arnaud Charlet * rtsfind.ads: (OK_To_Use_In_No_Run_Time_Mode): Allow Ada.Exceptions and *************** *** 34475,34535 **** * rident.ads (No_Secondary_Stack): New restriction. ! 2001-12-17 Joel Brobecker * gnat_rm.texi: Fix minor typos. Found while reading the section regarding "Bit_Order Clauses" that was sent to a customer. Very interesting documentation! ! 2001-12-17 Robert Dewar * sem_case.adb (Choice_Image): Avoid creating improper character literal names by using the routine Set_Character_Literal_Name. This fixes bombs in certain error message cases. ! 2001-12-17 Arnaud Charlet * a-reatim.adb: Minor reformatting. ! 2001-12-17 Ed Schonberg * sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly the case where the formal is an extension of another formal in the current unit or in a parent generic unit. ! 2001-12-17 Arnaud Charlet * s-tposen.adb: Update comments. Minor reformatting. Minor code clean up. * s-tarest.adb: Update comments. Minor code reorganization. ! 2001-12-17 Gary Dismukes * exp_attr.adb (Attribute_Tag): Suppress expansion of 'Tag when Java_VM. ! 2001-12-17 Robert Dewar * exp_attr.adb: Minor reformatting ! 2001-12-17 Ed Schonberg * sem_ch3.adb (Build_Derived_Private_Type): Refine check to handle derivations nested within a child unit: verify that the parent type is declared in an outer scope. ! 2001-12-17 Robert Dewar * sem_ch12.adb: Minor reformatting ! 2001-12-17 Ed Schonberg * sem_warn.adb (Check_One_Unit): In No_Run_Time mode, do not post warning if current unit is a predefined one, from which bodies may have been deleted. ! 2001-12-17 Robert Dewar * eval_fat.ads: Add comment that Round_Even is referenced in Ada code Fix header format. Add 2001 to copyright date. --- 42955,43015 ---- * rident.ads (No_Secondary_Stack): New restriction. ! 2001-12-17 Joel Brobecker * gnat_rm.texi: Fix minor typos. Found while reading the section regarding "Bit_Order Clauses" that was sent to a customer. Very interesting documentation! ! 2001-12-17 Robert Dewar * sem_case.adb (Choice_Image): Avoid creating improper character literal names by using the routine Set_Character_Literal_Name. This fixes bombs in certain error message cases. ! 2001-12-17 Arnaud Charlet * a-reatim.adb: Minor reformatting. ! 2001-12-17 Ed Schonberg * sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly the case where the formal is an extension of another formal in the current unit or in a parent generic unit. ! 2001-12-17 Arnaud Charlet * s-tposen.adb: Update comments. Minor reformatting. Minor code clean up. * s-tarest.adb: Update comments. Minor code reorganization. ! 2001-12-17 Gary Dismukes * exp_attr.adb (Attribute_Tag): Suppress expansion of 'Tag when Java_VM. ! 2001-12-17 Robert Dewa * exp_attr.adb: Minor reformatting ! 2001-12-17 Ed Schonberg * sem_ch3.adb (Build_Derived_Private_Type): Refine check to handle derivations nested within a child unit: verify that the parent type is declared in an outer scope. ! 2001-12-17 Robert Dewar * sem_ch12.adb: Minor reformatting ! 2001-12-17 Ed Schonberg * sem_warn.adb (Check_One_Unit): In No_Run_Time mode, do not post warning if current unit is a predefined one, from which bodies may have been deleted. ! 2001-12-17 Robert Dewar * eval_fat.ads: Add comment that Round_Even is referenced in Ada code Fix header format. Add 2001 to copyright date. *************** *** 34537,34543 **** * exp_dbug.adb (Get_Encoded_Name): Fix out of bounds reference, which caused CE during compilation if checks were enabled. ! 2001-12-17 Vincent Celier * make.adb: (Switches_Of): New function --- 43017,43023 ---- * exp_dbug.adb (Get_Encoded_Name): Fix out of bounds reference, which caused CE during compilation if checks were enabled. ! 2001-12-17 Vincent Celier * make.adb: (Switches_Of): New function *************** *** 34575,34581 **** * snames.ads: Added Exec_Dir ! 2001-12-17 Robert Dewar * make.adb: Minor reformatting --- 43055,43061 ---- * snames.ads: Added Exec_Dir ! 2001-12-17 Robert Dewar * make.adb: Minor reformatting *************** *** 34585,34613 **** * snames.ads: Alphebetize entries for project file ! 2001-12-17 Ed Schonberg * trans.c (process_freeze_entity): Do nothing if the entity is a subprogram that was already elaborated. ! 2001-12-17 Richard Kenner * decl.c (gnat_to_gnu_entity, object): Do not back-annotate Alignment and Esize if object is referenced via pointer. ! 2001-12-17 Ed Schonberg * sem_ch3.adb (Analyze_Variant_Part): check that type of discriminant is discrete before analyzing choices. ! 2001-12-17 Joel Brobecker * bindgen.adb (Gen_Output_File_Ada): Generate a new C-like string containing the name of the Ada Main Program. This string is mainly intended for the debugger. (Gen_Output_File_C): Do the equivalent change when generating a C file. ! 2001-12-17 Robert Dewar * ali.adb: Set new Dummy_Entry field in dependency entry --- 43065,43093 ---- * snames.ads: Alphebetize entries for project file ! 2001-12-17 Ed Schonberg * trans.c (process_freeze_entity): Do nothing if the entity is a subprogram that was already elaborated. ! 2001-12-17 Richard Kenner * decl.c (gnat_to_gnu_entity, object): Do not back-annotate Alignment and Esize if object is referenced via pointer. ! 2001-12-17 Ed Schonberg * sem_ch3.adb (Analyze_Variant_Part): check that type of discriminant is discrete before analyzing choices. ! 2001-12-17 Joel Brobecker * bindgen.adb (Gen_Output_File_Ada): Generate a new C-like string containing the name of the Ada Main Program. This string is mainly intended for the debugger. (Gen_Output_File_C): Do the equivalent change when generating a C file. ! 2001-12-17 Robert Dewar * ali.adb: Set new Dummy_Entry field in dependency entry *************** *** 34621,34627 **** * types.ads: (Dummy_Time_Stamp): New value for non-existant files ! 2001-12-17 Robert Dewar * ali.adb: Type reference does not reset current file. --- 43101,43107 ---- * types.ads: (Dummy_Time_Stamp): New value for non-existant files ! 2001-12-17 Robert Dewar * ali.adb: Type reference does not reset current file. *************** *** 34639,34645 **** there could be a real problem here with an uninitialized reference to Hbound, but no actual example of failure has been found. ! 2001-12-17 Laurent Pautet * g-socket.ads: Fix comment of Shutdown_Socket and Close_Socket. These functions --- 43119,43125 ---- there could be a real problem here with an uninitialized reference to Hbound, but no actual example of failure has been found. ! 2001-12-17 Laurent Pautet * g-socket.ads: Fix comment of Shutdown_Socket and Close_Socket. These functions *************** *** 34649,34655 **** When an error occurs, an exception is raised with the error message as exception message. ! 2001-12-17 Robert Dewar * frontend.adb: Move call to Check_Unused_Withs from Frontend, so that it happens before modification of Sloc values for -gnatD. --- 43129,43135 ---- When an error occurs, an exception is raised with the error message as exception message. ! 2001-12-17 Robert Dewar * frontend.adb: Move call to Check_Unused_Withs from Frontend, so that it happens before modification of Sloc values for -gnatD. *************** *** 34691,34702 **** sprint.adb, tbuild.ads, types.ads, utils.c, xeinfo.adb: Fix spelling errors. ! 2001-12-14 Vincent Celier * osint.adb(Create_Debug_File): When an object file is specified, put the .dg file in the same directory as the object file. ! 2001-12-14 Robert Dewar * osint.adb: Minor reformatting --- 43171,43182 ---- sprint.adb, tbuild.ads, types.ads, utils.c, xeinfo.adb: Fix spelling errors. ! 2001-12-14 Vincent Celier * osint.adb(Create_Debug_File): When an object file is specified, put the .dg file in the same directory as the object file. ! 2001-12-14 Robert Dewar * osint.adb: Minor reformatting *************** *** 34725,34752 **** Add 2001 to copyright date Add entry for Latin-5 (Cyrillic ISO-8859-5) ! 2001-12-14 Matt Gingell * adaint.c: mktemp is a macro on Lynx and can not be used as an expression. ! 2001-12-14 Richard Kenner * misc.c (gnat_expand_constant): Do not strip UNCHECKED_CONVERT_EXPR if operand is CONSTRUCTOR. ! 2001-12-14 Ed Schonberg * trans.c (tree_transform, case N_Assignment_Statement): Set lineno before emiting check on right-hand side, so that exception information is correct. ! 2001-12-14 Richard Kenner * utils.c (create_var_decl): Throw away initializing expression if just annotating types and non-constant. ! 2001-12-14 Vincent Celier * prj-nmsc.adb: (Ada_Check): Migrate drom Ada_Default_... to Default_Ada_... --- 43205,43232 ---- Add 2001 to copyright date Add entry for Latin-5 (Cyrillic ISO-8859-5) ! 2001-12-14 Matt Gingell * adaint.c: mktemp is a macro on Lynx and can not be used as an expression. ! 2001-12-14 Richard Kenner * misc.c (gnat_expand_constant): Do not strip UNCHECKED_CONVERT_EXPR if operand is CONSTRUCTOR. ! 2001-12-14 Ed Schonberg * trans.c (tree_transform, case N_Assignment_Statement): Set lineno before emiting check on right-hand side, so that exception information is correct. ! 2001-12-14 Richard Kenner * utils.c (create_var_decl): Throw away initializing expression if just annotating types and non-constant. ! 2001-12-14 Vincent Celier * prj-nmsc.adb: (Ada_Check): Migrate drom Ada_Default_... to Default_Ada_... *************** *** 34763,34769 **** * ChangeLog: Remove piece of diff output. ! 2001-12-14 Geert Bosch * config-lang.in: Update copyright notice --- 43243,43249 ---- * ChangeLog: Remove piece of diff output. ! 2001-12-14 Geert Bosch * config-lang.in: Update copyright notice *************** *** 34775,34781 **** * sem_ch3.adb: Minor reformatting. ! 2001-12-12 Geert Bosch * freeze.ads: Update copyright date. --- 43255,43261 ---- * sem_ch3.adb: Minor reformatting. ! 2001-12-12 Geert Bosch * freeze.ads: Update copyright date. *************** *** 34783,34798 **** * gnat-style.texi: Fix typo. ! 2001-12-12 Geert Bosch * einfo.h: Regenerate. ! 2001-12-12 Ed Schonberg * sem_ch12.adb (Save_Entity_Descendant): Use syntactic field names on known node types, rather than untyped fields. Further cleanups. ! 2001-12-12 Robert Dewar * sem_ch12.adb: (Save_Entity_Descendant): Minor comment update. --- 43263,43278 ---- * gnat-style.texi: Fix typo. ! 2001-12-12 Geert Bosch * einfo.h: Regenerate. ! 2001-12-12 Ed Schonberg * sem_ch12.adb (Save_Entity_Descendant): Use syntactic field names on known node types, rather than untyped fields. Further cleanups. ! 2001-12-12 Robert Dewar * sem_ch12.adb: (Save_Entity_Descendant): Minor comment update. *************** *** 34804,34810 **** * sem_ch12.adb (Associated_Node): Minor documentation cleanup. ! 2001-12-12 Robert Dewar * s-stalib.adb: Add more comments on with statements being needed --- 43284,43290 ---- * sem_ch12.adb (Associated_Node): Minor documentation cleanup. ! 2001-12-12 Robert Dewar * s-stalib.adb: Add more comments on with statements being needed *************** *** 34817,34829 **** * s-fatgen.ads: Minor comment improvement ! 2001-12-12 Ed Schonberg * sem_ch4.adb (Analyze_Selected_Component): If the prefix is of a formal derived type, look for an inherited component from the full view of the parent, if any. ! 2001-12-12 Robert Dewar * checks.ads (Apply_Alignment_Check): New procedure. --- 43297,43309 ---- * s-fatgen.ads: Minor comment improvement ! 2001-12-12 Ed Schonberg * sem_ch4.adb (Analyze_Selected_Component): If the prefix is of a formal derived type, look for an inherited component from the full view of the parent, if any. ! 2001-12-12 Robert Dewar * checks.ads (Apply_Alignment_Check): New procedure. *************** *** 34838,34881 **** * mlib-fil.ads: Minor reformatting ! 2001-12-12 Ed Schonberg * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Extend previous fix to any component reference if enclosing record has non-standard representation. ! 2001-12-12 Vincent Celier * g-dirope.ads (Find, Wildcard_Iterator): Moved to child package Iteration ! 2001-12-12 Ed Schonberg * freeze.ads: Make Freeze_Fixed_Point_Type visible, for use in sem_attr. ! 2001-12-12 Robert Dewar * impunit.adb: Add entry for GNAT.Directory_Operations.Iteration ! 2001-12-12 Emmanuel Briot * g-regexp.adb: Remove all debug code, since it isn't required anymore, and it adds dependencies to system.io. ! 2001-12-12 Pascal Obry * g-dirope.adb (Expand_Path.Var): Correctly detect end of variable name. ! 2001-12-11 Ed Schonberg * sem_ch10.adb (Install_Withed_Unit): If the unit is a generic instance that is the parent of other generics, the instance body replaces the instance node. Retrieve the instance of the spec, which is the one that is visible in clients and within the body. ! 2001-12-11 Vincent Celier * gnatmain.adb: Initial version. --- 43318,43361 ---- * mlib-fil.ads: Minor reformatting ! 2001-12-12 Ed Schonberg * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Extend previous fix to any component reference if enclosing record has non-standard representation. ! 2001-12-12 Vincent Celier * g-dirope.ads (Find, Wildcard_Iterator): Moved to child package Iteration ! 2001-12-12 Ed Schonberg * freeze.ads: Make Freeze_Fixed_Point_Type visible, for use in sem_attr. ! 2001-12-12 Robert Dewar * impunit.adb: Add entry for GNAT.Directory_Operations.Iteration ! 2001-12-12 Emmanuel Briot * g-regexp.adb: Remove all debug code, since it isn't required anymore, and it adds dependencies to system.io. ! 2001-12-12 Pascal Obry * g-dirope.adb (Expand_Path.Var): Correctly detect end of variable name. ! 2001-12-11 Ed Schonberg * sem_ch10.adb (Install_Withed_Unit): If the unit is a generic instance that is the parent of other generics, the instance body replaces the instance node. Retrieve the instance of the spec, which is the one that is visible in clients and within the body. ! 2001-12-11 Vincent Celier * gnatmain.adb: Initial version. *************** *** 34887,34918 **** * snames.ads: Added Gnatstub. ! 2001-12-11 Vincent Celier * prj-attr.adb (Initialization_Data): Change name from Initialisation_Data. ! 2001-12-11 Emmanuel Briot * g-regpat.adb (Parse_Literal): Properly handle simple operators ?, + and * applied to backslashed expressions like \r. ! 2001-12-11 Vasiliy Fofanov * g-os_lib.ads: String_List type added, Argument_List type is now subtype of String_List. ! 2001-12-11 Robert Dewar * g-os_lib.ads: Change copyright to FSF Add comments for String_List type ! 2001-12-11 Vincent Celier * g-dirope.adb (Expand_Path): Fix bug. (wrong length when adding a string to the buffer). ! 2001-12-11 Ed Schonberg * freeze.adb: Make Freeze_Fixed_Point_Type visible, for use in sem_attr. --- 43367,43398 ---- * snames.ads: Added Gnatstub. ! 2001-12-11 Vincent Celier * prj-attr.adb (Initialization_Data): Change name from Initialisation_Data. ! 2001-12-11 Emmanuel Briot * g-regpat.adb (Parse_Literal): Properly handle simple operators ?, + and * applied to backslashed expressions like \r. ! 2001-12-11 Vasiliy Fofanov * g-os_lib.ads: String_List type added, Argument_List type is now subtype of String_List. ! 2001-12-11 Robert Dewar * g-os_lib.ads: Change copyright to FSF Add comments for String_List type ! 2001-12-11 Vincent Celier * g-dirope.adb (Expand_Path): Fix bug. (wrong length when adding a string to the buffer). ! 2001-12-11 Ed Schonberg * freeze.adb: Make Freeze_Fixed_Point_Type visible, for use in sem_attr. *************** *** 34922,34947 **** to avoid anomalies where the bound of the type appears to raise constraint error. ! 2001-12-11 Robert Dewar * lib-xref.adb (Output_Refs): Make sure pointers are always properly handled. ! 2001-12-11 Ed Schonberg * sem_ch12.adb (Analyze_Subprogram_Instantiation): Check for a renamed unit before checking for recursive instantiations. ! 2001-12-11 Emmanuel Briot * prj.ads: Add comments for some of the fields. ! 2001-12-11 Robert Dewar * lib-xref.adb (Output_Refs): Don't output type references outside the main unit if they are not otherwise referenced. ! 2001-12-11 Ed Schonberg * sem_attr.adb (Analyze_attribute, case Address and Size): Simplify code and diagnose additional illegal uses --- 43402,43427 ---- to avoid anomalies where the bound of the type appears to raise constraint error. ! 2001-12-11 Robert Dewar * lib-xref.adb (Output_Refs): Make sure pointers are always properly handled. ! 2001-12-11 Ed Schonber * sem_ch12.adb (Analyze_Subprogram_Instantiation): Check for a renamed unit before checking for recursive instantiations. ! 2001-12-11 Emmanuel Briot * prj.ads: Add comments for some of the fields. ! 2001-12-11 Robert Dewar * lib-xref.adb (Output_Refs): Don't output type references outside the main unit if they are not otherwise referenced. ! 2001-12-11 Ed Schonberg * sem_attr.adb (Analyze_attribute, case Address and Size): Simplify code and diagnose additional illegal uses *************** *** 34949,34955 **** * sem_util.adb (Is_Object_Reference): An indexed component is an object only if the prefix is. ! 2001-12-11 Vincent Celier * g-diopit.adb: Initial version. --- 43429,43435 ---- * sem_util.adb (Is_Object_Reference): An indexed component is an object only if the prefix is. ! 2001-12-11 Vincent Celier * g-diopit.adb: Initial version. *************** *** 34961,34975 **** * Makefile.in: Added g-diopit.o to GNATRTL_NONTASKING_OBJS ! 2001-12-11 Robert Dewar * sem_attr.adb: Minor reformatting ! 2001-12-11 Ed Schonberg * sem_ch3.adb: Clarify some ???. ! 2001-12-11 Robert Dewar * exp_util.adb (Must_Be_Aligned): Removed, replaced by Exp_Pakd.Known_Aligned_Enough --- 43441,43455 ---- * Makefile.in: Added g-diopit.o to GNATRTL_NONTASKING_OBJS ! 2001-12-11 Robert Dewar * sem_attr.adb: Minor reformatting ! 2001-12-11 Ed Schonberg * sem_ch3.adb: Clarify some ???. ! 2001-12-11 Robert Dewar * exp_util.adb (Must_Be_Aligned): Removed, replaced by Exp_Pakd.Known_Aligned_Enough *************** *** 34977,34983 **** * sem_ch13.adb (Check_Address_Alignment): Removed, extended version is moved to Exp_Ch13. ! 2001-12-11 Robert Dewar * einfo.ads: Minor reformatting --- 43457,43463 ---- * sem_ch13.adb (Check_Address_Alignment): Removed, extended version is moved to Exp_Ch13. ! 2001-12-11 Robert Dewar * einfo.ads: Minor reformatting *************** *** 35007,35013 **** * exp_pakd.adb: Minor reformatting. Note that prevous RH should say: (Known_Aligned_Enough): Replaces Must_Be_Aligned. ! 2001-12-11 Vincent Celier * gnatcmd.adb: Changed /COMPILE_ONLY to /ACTIONS=COMPILE --- 43487,43493 ---- * exp_pakd.adb: Minor reformatting. Note that prevous RH should say: (Known_Aligned_Enough): Replaces Must_Be_Aligned. ! 2001-12-11 Vincent Celier * gnatcmd.adb: Changed /COMPILE_ONLY to /ACTIONS=COMPILE *************** *** 35026,35044 **** is enabled, do not kill the code for the condition, to preserve warning. ! 2001-12-11 Robert Dewar * checks.adb (Insert_Valid_Check): Apply validity check to expression of conversion, not to result of conversion. ! 2001-12-11 Ed Schonberg * sem_ch3.adb (Build_Derived_Record_Type): set Controlled flag before freezing parent. If the declarations are mutually recursive, an access to the current record type may be frozen before the derivation is complete. ! 2001-12-05 Vincent Celier * gnatcmd.adb: (MAKE): Add new translations: -b /BIND_ONLY, -c /COMPILE_ONLY, -l /LINK_ONLY --- 43506,43524 ---- is enabled, do not kill the code for the condition, to preserve warning. ! 2001-12-11 Robert Dewar * checks.adb (Insert_Valid_Check): Apply validity check to expression of conversion, not to result of conversion. ! 2001-12-11 Ed Schonberg * sem_ch3.adb (Build_Derived_Record_Type): set Controlled flag before freezing parent. If the declarations are mutually recursive, an access to the current record type may be frozen before the derivation is complete. ! 2001-12-05 Vincent Celier * gnatcmd.adb: (MAKE): Add new translations: -b /BIND_ONLY, -c /COMPILE_ONLY, -l /LINK_ONLY *************** *** 35059,35065 **** (Scan_Make_Arg): Reset the bind and link step flags when -u or -gnatc has been specified. ! 2001-12-05 Ed Schonberg * sem_eval.adb (Eval_Concatenation): If left operand is a null string, get bounds from right operand. --- 43539,43545 ---- (Scan_Make_Arg): Reset the bind and link step flags when -u or -gnatc has been specified. ! 2001-12-05 Ed Schonberg * sem_eval.adb (Eval_Concatenation): If left operand is a null string, get bounds from right operand. *************** *** 35072,35096 **** * exp_util.adb: Undo earlier change, fixes ACVC regressions C48009B and C48009J ! 2001-12-05 Vincent Celier * prj-nmsc.adb Minor reformatting * prj-nmsc.adb (Language_Independent_Check): Reset Library flag if set and libraries are not supported. ! 2001-12-05 Ed Schonberg * sem_ch3.adb (Build_Derived_Private_Type): set Public status of private view explicitly, so the back-end can treat as a global when appropriate. ! 2001-12-05 Ed Schonberg * sem_ch12.adb (Instantiate_Package_Body): if instance is a compilation unit, always replace instance node with new body, for ASIS use. ! 2001-12-05 Vincent Celier * prj-nmsc.adb (Language_Independent_Check): Issue a warning if libraries are not supported and both attributes Library_Name and --- 43552,43576 ---- * exp_util.adb: Undo earlier change, fixes ACVC regressions C48009B and C48009J ! 2001-12-05 Vincent Celier * prj-nmsc.adb Minor reformatting * prj-nmsc.adb (Language_Independent_Check): Reset Library flag if set and libraries are not supported. ! 2001-12-05 Ed Schonberg * sem_ch3.adb (Build_Derived_Private_Type): set Public status of private view explicitly, so the back-end can treat as a global when appropriate. ! 2001-12-05 Ed Schonberg * sem_ch12.adb (Instantiate_Package_Body): if instance is a compilation unit, always replace instance node with new body, for ASIS use. ! 2001-12-05 Vincent Celier * prj-nmsc.adb (Language_Independent_Check): Issue a warning if libraries are not supported and both attributes Library_Name and *************** *** 35104,35121 **** * prj-proc.adb: Put the change indicated above that was forgotten. ! 2001-12-05 Robert Dewar * Makefile.in: Add dependencies for System.IO for GNAT.Regexp ! 2001-12-05 Ed Schonberg * sem_ch3.adb (Build_Derived_Concurrent_Type): If derivation imposes a constraint, introduce explicit subtype declaration and derive from it. * sem_ch3.adb: Minor reformatting ! 2001-12-05 Robert Dewar * checks.adb (Determine_Range): Increase cache size for checks. Minor reformatting --- 43584,43601 ---- * prj-proc.adb: Put the change indicated above that was forgotten. ! 2001-12-05 Robert Dewar * Makefile.in: Add dependencies for System.IO for GNAT.Regexp ! 2001-12-05 Ed Schonberg * sem_ch3.adb (Build_Derived_Concurrent_Type): If derivation imposes a constraint, introduce explicit subtype declaration and derive from it. * sem_ch3.adb: Minor reformatting ! 2001-12-05 Robert Dewar * checks.adb (Determine_Range): Increase cache size for checks. Minor reformatting *************** *** 35131,35155 **** * g-regexp.adb: Use System.IO instead of Ada.Text_IO. ! 2001-12-05 Ed Schonberg * sem_ch3.adb (Analyze_Object_Declaration): If expression is an aggregate with static wrong size, attach generated Raise node to declaration. ! 2001-12-05 Robert Dewar * sem_attr.adb (Analyze_Attribute): Defend against bad Val attribute. Fixes compilation abandoned bomb in B24009B. ! 2001-12-05 Ed Schonberg * sem_ch12.adb: Document use of Associated_Node on Selected_Components. (Save_Global_Operand_Descendants): Change to Save_Entity_Descendants, to clarify use of untyped descendant fields. ! 2001-12-05 Robert Dewar * prj-dect.ads: Add ??? comment Add 2001 to copyright notice (was not done in after all) --- 43611,43635 ---- * g-regexp.adb: Use System.IO instead of Ada.Text_IO. ! 2001-12-05 Ed Schonberg * sem_ch3.adb (Analyze_Object_Declaration): If expression is an aggregate with static wrong size, attach generated Raise node to declaration. ! 2001-12-05 Robert Dewar * sem_attr.adb (Analyze_Attribute): Defend against bad Val attribute. Fixes compilation abandoned bomb in B24009B. ! 2001-12-05 Ed Schonberg * sem_ch12.adb: Document use of Associated_Node on Selected_Components. (Save_Global_Operand_Descendants): Change to Save_Entity_Descendants, to clarify use of untyped descendant fields. ! 2001-12-05 Robert Dewar * prj-dect.ads: Add ??? comment Add 2001 to copyright notice (was not done in after all) *************** *** 35160,35170 **** * snames.ads: Minor reformatting ! 2001-12-05 Geert Bosch * snames.adb: Autoupdate ! 2001-12-05 Vincent Celier * prj-dect.adb (Parse): Rename parameter Modifying to Extends. --- 43640,43650 ---- * snames.ads: Minor reformatting ! 2001-12-05 Geert Bosch * snames.adb: Autoupdate ! 2001-12-05 Vincent Celier * prj-dect.adb (Parse): Rename parameter Modifying to Extends. *************** *** 35185,35191 **** * snames.ads: Change modifying to extends. ! 2001-12-05 Robert Dewar * sem_warn.adb: Remove stuff for conditionals, we are not going to do this after all. --- 43665,43671 ---- * snames.ads: Change modifying to extends. ! 2001-12-05 Robert Dewar * sem_warn.adb: Remove stuff for conditionals, we are not going to do this after all. *************** *** 35193,35203 **** * sem_warn.ads: Remove stuff for conditionals, we are not going to do this after all. Add 2001 to copyright notice ! 2001-12-04 Geert Bosch * einfo.h, sinfo.h, treeprs.ads: Regenerate. ! 2001-12-04 Robert Dewar * errout.adb (Error_Msg): Ignore attempt to put error msg at junk location if we already have errors. Stops some cases of cascaded --- 43673,43683 ---- * sem_warn.ads: Remove stuff for conditionals, we are not going to do this after all. Add 2001 to copyright notice ! 2001-12-04 Geert Bosch * einfo.h, sinfo.h, treeprs.ads: Regenerate. ! 2001-12-04 Robert Dewar * errout.adb (Error_Msg): Ignore attempt to put error msg at junk location if we already have errors. Stops some cases of cascaded *************** *** 35205,35211 **** * errout.adb: Improve comment. ! 2001-12-04 Robert Dewar * sem_ch12.adb: (Analyze_Formal_Type_Definition): Defend against Error. --- 43685,43691 ---- * errout.adb: Improve comment. ! 2001-12-04 Robert Dewar * sem_ch12.adb: (Analyze_Formal_Type_Definition): Defend against Error. *************** *** 35214,35220 **** * par-ch12.adb (F_Formal_Type_Declaration): In case of error, remove following semicolon if present. Removes cascaded error. ! 2001-12-04 Douglas B. Rupp * bindgen.adb: (Gen_Exception_Table_Ada): Write "begin" and then return if Num --- 43694,43700 ---- * par-ch12.adb (F_Formal_Type_Declaration): In case of error, remove following semicolon if present. Removes cascaded error. ! 2001-12-04 Douglas B. Rupp * bindgen.adb: (Gen_Exception_Table_Ada): Write "begin" and then return if Num *************** *** 35222,35232 **** (Gen_Exception_Table_C): Return if Num exceptions equals 0. Fixes PIWG E tests (which have to be run with -gnatL). ! 2001-12-04 Robert Dewar * einfo.ads: Minor reformatting ! 2001-12-04 Ed Schonberg * einfo.ads: Block_Node points to the identifier of the block, not to the block node itself, to preserve the link when the block is --- 43702,43712 ---- (Gen_Exception_Table_C): Return if Num exceptions equals 0. Fixes PIWG E tests (which have to be run with -gnatL). ! 2001-12-04 Robert Dewar * einfo.ads: Minor reformatting ! 2001-12-04 Ed Schonberg * einfo.ads: Block_Node points to the identifier of the block, not to the block node itself, to preserve the link when the block is *************** *** 35238,35244 **** * sem_ch5.adb (Analyze_Block_Statement): set Block_Node to point to identifier of block node, rather than to node itself. ! 2001-12-04 Gary Dismukes * layout.adb: (Get_Max_Size): Fix "start of processing" comment to say Get_Max_Size. --- 43718,43724 ---- * sem_ch5.adb (Analyze_Block_Statement): set Block_Node to point to identifier of block node, rather than to node itself. ! 2001-12-04 Gary Dismukes * layout.adb: (Get_Max_Size): Fix "start of processing" comment to say Get_Max_Size. *************** *** 35247,35275 **** fail name resolution. Also set Analyzed. Remove with and use of Sem_Res. ! 2001-12-04 Arnaud Charlet * Makefile.in: (HIE_SOURCES): add s-fat*. ! 2001-12-04 Robert Dewar * sem_attr.adb: (Compile_Time_Known_Attribute): New procedure. (Eval_Attribute, case Size): Use Compile_Time_Known_Attribute to ensure proper range check. ! 2001-12-04 Ed Schonberg * sem_ch7.adb (New_Private_Type): Set Is_Tagged_Type flag before processing discriminants to diagnose illegal default values. ! 2001-12-04 Ed Schonberg * sem_attr.adb (Resolve_Attribute): Handle properly an non-classwide access discriminant within a type extension that constrains its parent discriminants. ! 2001-12-04 Ed Schonberg * sem_ch3.adb (Find_Type_Of_Subtype_Indic): If subtype indication is malformed, use instance of Any_Id to allow analysis to proceed. --- 43727,43755 ---- fail name resolution. Also set Analyzed. Remove with and use of Sem_Res. ! 2001-12-04 Arnaud Charlet * Makefile.in: (HIE_SOURCES): add s-fat*. ! 2001-12-04 Robert Dewar * sem_attr.adb: (Compile_Time_Known_Attribute): New procedure. (Eval_Attribute, case Size): Use Compile_Time_Known_Attribute to ensure proper range check. ! 2001-12-04 Ed Schonberg * sem_ch7.adb (New_Private_Type): Set Is_Tagged_Type flag before processing discriminants to diagnose illegal default values. ! 2001-12-04 Ed Schonberg * sem_attr.adb (Resolve_Attribute): Handle properly an non-classwide access discriminant within a type extension that constrains its parent discriminants. ! 2001-12-04 Ed Schonberg * sem_ch3.adb (Find_Type_Of_Subtype_Indic): If subtype indication is malformed, use instance of Any_Id to allow analysis to proceed. *************** *** 35279,35294 **** (P_Formal_Derived_Type_Definition): Better recovery when TAGGED is misplaced. ! 2001-12-04 Ed Schonberg * sem_warn.adb (Output_Unreferenced_Messages): Extend previous fix to constants. ! 2001-12-04 Robert Dewar * errout.adb: Minor reformatting ! 2001-12-04 Robert Dewar * exp_util.adb: Minor reformatting from last change --- 43759,43774 ---- (P_Formal_Derived_Type_Definition): Better recovery when TAGGED is misplaced. ! 2001-12-04 Ed Schonberg * sem_warn.adb (Output_Unreferenced_Messages): Extend previous fix to constants. ! 2001-12-04 Robert Dewar * errout.adb: Minor reformatting ! 2001-12-04 Robert Dewar * exp_util.adb: Minor reformatting from last change *************** *** 35296,35320 **** which is a rewriting of an expression, traverse the original expression to remove warnings that may have been posted on it. ! 2001-12-04 Ed Schonberg * exp_util.adb (Must_Be_Aligned): Return false for a component of a record that has other packed components. ! 2001-12-04 Douglass B. Rupp * adaint.c: Minor cleanups. ! 2001-12-04 Douglass B. Rupp * adaint.c: Do not use utime.h on vxworks. ! 2001-12-04 Arnaud Charlet * Makefile.adalib: Clarify step 3 (use of gnat.adc) as it causes more confusion than it solves. ! 2001-12-04 Geert bosch * einfo.h, nmake.adb, nmake.ads, sinfo.h treeprs.ads: Regenerate. --- 43776,43800 ---- which is a rewriting of an expression, traverse the original expression to remove warnings that may have been posted on it. ! 2001-12-04 Ed Schonberg * exp_util.adb (Must_Be_Aligned): Return false for a component of a record that has other packed components. ! 2001-12-04 Douglass B. Rupp * adaint.c: Minor cleanups. ! 2001-12-04 Douglass B. Rupp * adaint.c: Do not use utime.h on vxworks. ! 2001-12-04 Arnaud Charlet * Makefile.adalib: Clarify step 3 (use of gnat.adc) as it causes more confusion than it solves. ! 2001-12-04 Geert bosch * einfo.h, nmake.adb, nmake.ads, sinfo.h treeprs.ads: Regenerate. *************** *** 35323,35329 **** * Makefile.in (update-sources): New target. For use by gcc_release script. ! 2001-12-04 Ed Schonberg * sem_prag.adb (Analyze_Pragma, case Validity_Checks): do not treat as a configuration pragma, it is now legal wherever a pragma can appear. --- 43803,43809 ---- * Makefile.in (update-sources): New target. For use by gcc_release script. ! 2001-12-04 Ed Schonberg * sem_prag.adb (Analyze_Pragma, case Validity_Checks): do not treat as a configuration pragma, it is now legal wherever a pragma can appear. *************** *** 35334,35340 **** @cross_overrides@, @build_overrides@ stanzas. INTERNAL_CFLAGS is now @CROSS@ -DIN_GCC; update comment. ! 2001-12-04 Robert Dewar * einfo.adb (Has_Pragma_Pure_Function): New flag. Fix problem that stopped ceinfo from working --- 43814,43820 ---- @cross_overrides@, @build_overrides@ stanzas. INTERNAL_CFLAGS is now @CROSS@ -DIN_GCC; update comment. ! 2001-12-04 Robert Dewar * einfo.adb (Has_Pragma_Pure_Function): New flag. Fix problem that stopped ceinfo from working *************** *** 35343,35349 **** * sem_prag.adb (Pure_Function): Set new flag Has_Pragma_Pure_Function. ! 2001-12-04 Douglas B. Rupp * gnatchop.adb: (File_Time_Stamp): New procedure. --- 43823,43829 ---- * sem_prag.adb (Pure_Function): Set new flag Has_Pragma_Pure_Function. ! 2001-12-04 Douglas B. Rupp * gnatchop.adb: (File_Time_Stamp): New procedure. *************** *** 35361,35378 **** * adaint.h: Fix typo ! 2001-12-03 Robert Dewar * sinfo.ads: Minor reformatting. N_Freeze_Entity node does not have Associated_Node. ! 2001-12-03 Robert Dewar * prj-proc.adb: Minor reformatting * make.adb: Minor reformatting ! 2001-12-03 Geert Bosch * make.adb: Minor reformatting. --- 43841,43858 ---- * adaint.h: Fix typo ! 2001-12-03 Robert Dewar * sinfo.ads: Minor reformatting. N_Freeze_Entity node does not have Associated_Node. ! 2001-12-03 Robert Dewar * prj-proc.adb: Minor reformatting * make.adb: Minor reformatting ! 2001-12-03 Geert Bosch * make.adb: Minor reformatting. *************** *** 35380,35386 **** * sem_ch12.adb: Minor reformatting ! 2001-12-03 Ed Schonberg * sem_ch12.adb (Inline_Instance_Body): Use Save_Scope_Stack and push Standard on the stack before analyzing the instance body, --- 43860,43866 ---- * sem_ch12.adb: Minor reformatting ! 2001-12-03 Ed Schonberg * sem_ch12.adb (Inline_Instance_Body): Use Save_Scope_Stack and push Standard on the stack before analyzing the instance body, *************** *** 35388,35399 **** * sem_ch12.adb (Inline_Instance_Body): Remove redundant code. ! 2001-12-03 Ed Schonberg * sem_ch12.adb (Instantiate_Package_Body): Protect against double instantiation of a body that contains an inlined body. ! 2001-12-03 Ed Schonberg * sem_ch12.adb: (Analyze_generic_subprogram_Declaration): Set outer_generic_scope, --- 43868,43879 ---- * sem_ch12.adb (Inline_Instance_Body): Remove redundant code. ! 2001-12-03 Ed Schonberg * sem_ch12.adb (Instantiate_Package_Body): Protect against double instantiation of a body that contains an inlined body. ! 2001-12-03 Ed Schonberg * sem_ch12.adb: (Analyze_generic_subprogram_Declaration): Set outer_generic_scope, *************** *** 35423,35439 **** * Make-lang.in (ada.generated-manpages): New dummy target. ! 2001-11-29 Ed Schonberg * g-os_lib.adb (Add_To_Command): use explicit loop to move string into Command, an array conversion is illegal here. Uncovered by ACATS B460005. ! 2001-11-28 Geert Bosch * init.c: Minor whitespace changes. ! 2001-11-28 Doug Rupp * init.c: (__gnat_install_handler,VMS): Increase size of alternate signal stack. --- 43903,43919 ---- * Make-lang.in (ada.generated-manpages): New dummy target. ! 2001-11-29 Ed Schonberg * g-os_lib.adb (Add_To_Command): use explicit loop to move string into Command, an array conversion is illegal here. Uncovered by ACATS B460005. ! 2001-11-28 Geert Bosch * init.c: Minor whitespace changes. ! 2001-11-28 Doug Rupp * init.c: (__gnat_install_handler,VMS): Increase size of alternate signal stack. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35522,35549 **** * misc.c: Include langhooks-def.h. * Makefile.in: Update. ! 2001-10-30 Robert Dewar * style.adb: (Check_Identifier): Rewrite circuit to be compatible with use of letters in the upper half of ASCII. (Check_Identifier): Minor reformatting ! 2001-10-30 Geert Bosch * (Associated_Node, Set_Associated_Node): Do not check for Freeze_Entity. ! 2001-10-30 Robert Dewar * a-reatim.ads: Minor reformatting ! 2001-10-30 Robert Dewar * gnatdll.adb: Minor reformatting throughout. Many ??? added for undocumented declarations. ! 2001-10-30 Pascal Obry * gnatdll.adb (Parse_Command_Line): handle -g option to be passed to the binder and linker. --- 44002,44029 ---- * misc.c: Include langhooks-def.h. * Makefile.in: Update. ! 2001-10-30 Robert Dewar * style.adb: (Check_Identifier): Rewrite circuit to be compatible with use of letters in the upper half of ASCII. (Check_Identifier): Minor reformatting ! 2001-10-30 Geert Bosch * (Associated_Node, Set_Associated_Node): Do not check for Freeze_Entity. ! 2001-10-30 Robert Dewar * a-reatim.ads: Minor reformatting ! 2001-10-30 Robert Dewar * gnatdll.adb: Minor reformatting throughout. Many ??? added for undocumented declarations. ! 2001-10-30 Pascal Obry * gnatdll.adb (Parse_Command_Line): handle -g option to be passed to the binder and linker. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35553,35563 **** * mdll.adb: Fix layout. Update copyright notice. ! 2001-10-30 Robert Dewar * usage.adb: Minor fix to output for -gnaty. ! 2001-10-30 Ed Schonberg * a-reatim.ads: Makes Seconds_Count into a 64-bit integer, to accommodate all its possible values. --- 44033,44043 ---- * mdll.adb: Fix layout. Update copyright notice. ! 2001-10-30 Robert Dewar * usage.adb: Minor fix to output for -gnaty. ! 2001-10-30 Ed Schonberg * a-reatim.ads: Makes Seconds_Count into a 64-bit integer, to accommodate all its possible values. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35565,35582 **** * a-reatim.adb (Split): Special-case handling of Time_Span_First and of small absolute values of T. ! 2001-10-30 Richard Kenner * misc.c (gnat_expand_expr, case NULL_EXPR): Remove call to set_mem_attributes since not needed and wrong if RESULT if a REG; fixes ACATS failures. ! 2001-10-30 Geert Bosch * 86numaux.adb, a-tigeau.ads, a-wtgeau.ads, fname-sf.ads, g-traceb.ads, s-tasdeb.ads, sem_maps.ads: Add 2001 to copyright notice. ! 2001-10-30 Robert Dewar * bindusg.adb: Undocument -f switch. --- 44045,44062 ---- * a-reatim.adb (Split): Special-case handling of Time_Span_First and of small absolute values of T. ! 2001-10-30 Richard Kenner * misc.c (gnat_expand_expr, case NULL_EXPR): Remove call to set_mem_attributes since not needed and wrong if RESULT if a REG; fixes ACATS failures. ! 2001-10-30 Geert Bosch * 86numaux.adb, a-tigeau.ads, a-wtgeau.ads, fname-sf.ads, g-traceb.ads, s-tasdeb.ads, sem_maps.ads: Add 2001 to copyright notice. ! 2001-10-30 Robert Dewar * bindusg.adb: Undocument -f switch. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35589,35610 **** * gnatbind.adb: Minor update of warning msg. ! 2001-10-30 Vincent Celier * gnatcmd.adb (MAKE, BIND, LINK, LIST, FIND, XREF): Add translations for project file switches (-P (/PROJECT_FILE=), -X (/EXTERNAL_REFERENCE=) and -vPx (/PROJECT_FILE_VERBOSITY=DEFAULT or MEDIUM or HIGH) ! 2001-10-30 Geert Bosch * decl.c: Minor whitespace fixes. ! 2001-10-30 Richard Kenner * utils2.c (build_allocator): Test for SIZE overflow in array case too ! 2001-10-30 Geert Bosch * ali-util.adb (Initialize_Checksum): Use out-mode instead of in out. Found due to GCC 3.0 warning of using uninitialized value. --- 44069,44090 ---- * gnatbind.adb: Minor update of warning msg. ! 2001-10-30 Vincent Celier * gnatcmd.adb (MAKE, BIND, LINK, LIST, FIND, XREF): Add translations for project file switches (-P (/PROJECT_FILE=), -X (/EXTERNAL_REFERENCE=) and -vPx (/PROJECT_FILE_VERBOSITY=DEFAULT or MEDIUM or HIGH) ! 2001-10-30 Geert Bosch * decl.c: Minor whitespace fixes. ! 2001-10-30 Richard Kenner * utils2.c (build_allocator): Test for SIZE overflow in array case too ! 2001-10-30 Geert Bosch * ali-util.adb (Initialize_Checksum): Use out-mode instead of in out. Found due to GCC 3.0 warning of using uninitialized value. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35615,35621 **** (Layout_Array_Type): Use variant record for tracking value/expression. Makes logic clearer and prevents warnings for uninitialized variables. ! 2001-10-30 Robert Dewar * lib.adb: Minor reformatting --- 44095,44101 ---- (Layout_Array_Type): Use variant record for tracking value/expression. Makes logic clearer and prevents warnings for uninitialized variables. ! 2001-10-30 Robert Dewar * lib.adb: Minor reformatting *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35628,35634 **** const. (_gnat_error_handler): Make MSG const. ! 2001-10-29 Richard Kenner * sysdep.c: Fix localtime_r problem on LynxOS. Also remove #elif to avoid warnings. --- 44108,44114 ---- const. (_gnat_error_handler): Make MSG const. ! 2001-10-29 Richard Kenner * sysdep.c: Fix localtime_r problem on LynxOS. Also remove #elif to avoid warnings. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35651,35657 **** sem_util.ads, sinfo.ads, sinput.ads, table.adb, table.ads, types.ads, urealp.adb: Fix spelling errors. ! 2001-10-27 Laurent Guerby * trans.c (gigi): Fix non determinism leading to bootstrap comparison failures for debugging information. --- 44131,44137 ---- sem_util.ads, sinfo.ads, sinput.ads, table.adb, table.ads, types.ads, urealp.adb: Fix spelling errors. ! 2001-10-27 Laurent Guerby * trans.c (gigi): Fix non determinism leading to bootstrap comparison failures for debugging information. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35660,35683 **** * gnat_rm.texi: Use @./@: where appropriate. ! 2001-10-26 Robert Dewar * sinfo.adb: Define Associated_Node to overlap Entity field. Cleanup. ! 2001-10-26 Richard Kenner * gmem.c (__gnat_gmem_read_next): Properly check for EOF ! 2001-10-26 Richard Kenner * decl.c (validate_size): Modify message for bad size to avoid implication that compiler is modifying the size. ! 2001-10-26 Robert Dewar * prj-util.adb: Minor reformatting. Fix bad header format. ! 2001-10-26 Robert Dewar * sinfo.ads: Define Associated_Node to overlap Entity field. Cleanup. --- 44140,44163 ---- * gnat_rm.texi: Use @./@: where appropriate. ! 2001-10-26 Robert Dewar * sinfo.adb: Define Associated_Node to overlap Entity field. Cleanup. ! 2001-10-26 Richard Kenner * gmem.c (__gnat_gmem_read_next): Properly check for EOF ! 2001-10-26 Richard Kenner * decl.c (validate_size): Modify message for bad size to avoid implication that compiler is modifying the size. ! 2001-10-26 Robert Dewar * prj-util.adb: Minor reformatting. Fix bad header format. ! 2001-10-26 Robert Dewar * sinfo.ads: Define Associated_Node to overlap Entity field. Cleanup. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35687,35693 **** Associated_Node to Get_Associated_Node. Put use of Unchecked_Access much more narrowly in places where needed. These are cleanups. ! 2001-10-26 Joel Brobecker * 5zosinte.ads (null_pthread): new constant. --- 44167,44173 ---- Associated_Node to Get_Associated_Node. Put use of Unchecked_Access much more narrowly in places where needed. These are cleanups. ! 2001-10-26 Joel Brobecker * 5zosinte.ads (null_pthread): new constant. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35702,35708 **** (Resume_All_Tasks): Lock the tasks list before using it. (Suspend_All_Tasks): ditto. ! 2001-10-26 Richard Kenner * decl.c (gnat_to_gnu_entity, case E_General_Access_Type): Make constant variant of designated type for Is_Access_Constant. --- 44182,44188 ---- (Resume_All_Tasks): Lock the tasks list before using it. (Suspend_All_Tasks): ditto. ! 2001-10-26 Richard Kenner * decl.c (gnat_to_gnu_entity, case E_General_Access_Type): Make constant variant of designated type for Is_Access_Constant. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35717,35794 **** * utils2.c (build_unary_op, case INDIRECT_REF): No longer set TREE_STATIC. ! 2001-10-26 Robert Dewar * prj-util.adb: Minor reformatting ! 2001-10-26 Robert Dewar * prj-util.adb: Minor reformatting ! 2001-10-26 Robert Dewar * prj-attr.adb: Minor reformatting throughout ! 2001-10-26 Robert Dewar * prj-attr.ads: Minor reformatting Add ??? comment (this whole spec has almost no comments) ! 2001-10-26 Vincent Celier * g-os_lib.adb (Normalize_Pathname): Preserve the double slash ("//") that precede the drive letter on Interix. ! 2001-10-26 Geert Bosch * gnat_rm.texi: Add GNAT Reference Manual. ! 2001-10-25 Robert Dewar * sem_ch8.adb (Analyze_Package_Renaming): Skip analysis if Name is Error. Similar change for other renaming cases. ! 2001-10-25 Robert Dewar * s-atacco.ads: Add pragma Inline_Always for functions. Fix header format. Add copyright 2001 ! 2001-10-25 Ed Schonberg * par-ch3.adb (P_Subtype_Mark_Resync): for an anonymous array return Error rather than Empty so that analysis can proceed. ! 2001-10-25 Ed Schonberg * sem_util.adb (Enter_Name): better handling of cascaded error messages when a unit appears in its own context. ! 2001-10-25 Ed Schonberg * sem_util.adb (Defining_Entity): in case of error, attach created entity to specification, so that semantic analysis can proceed. ! 2001-10-25 Robert Dewar * sem_util.adb (Defining_Entity): Deal with Error. (Process_End_Label): Deal with bad end label for. ! 2001-10-25 Ed Schonberg * sem_elab.adb (Check_A_Call): refine message when call is in an instance but callee is not declared in the generic unit. ! 2001-10-25 Ed Schonberg * sem_elab.adb (Check_A_Call): check for renaming before finding the enclosing unit, which may already be different from the calling unit. ! 2001-10-25 Geert Bosch * 4gintnam.ads: fix header format. ! 2001-10-25 Ed Schonberg * sem_res.adb (Resolve_Call): if the call is actually an indexing operation on the result of a parameterless call, perform elaboration --- 44197,44274 ---- * utils2.c (build_unary_op, case INDIRECT_REF): No longer set TREE_STATIC. ! 2001-10-26 Robert Dewar * prj-util.adb: Minor reformatting ! 2001-10-26 Robert Dewar * prj-util.adb: Minor reformatting ! 2001-10-26 Robert Dewar * prj-attr.adb: Minor reformatting throughout ! 2001-10-26 Robert Dewar * prj-attr.ads: Minor reformatting Add ??? comment (this whole spec has almost no comments) ! 2001-10-26 Vincent Celier * g-os_lib.adb (Normalize_Pathname): Preserve the double slash ("//") that precede the drive letter on Interix. ! 2001-10-26 Geert Bosch * gnat_rm.texi: Add GNAT Reference Manual. ! 2001-10-25 Robert Dewar * sem_ch8.adb (Analyze_Package_Renaming): Skip analysis if Name is Error. Similar change for other renaming cases. ! 2001-10-25 Robert Dewar * s-atacco.ads: Add pragma Inline_Always for functions. Fix header format. Add copyright 2001 ! 2001-10-25 Ed Schonberg * par-ch3.adb (P_Subtype_Mark_Resync): for an anonymous array return Error rather than Empty so that analysis can proceed. ! 2001-10-25 Ed Schonberg * sem_util.adb (Enter_Name): better handling of cascaded error messages when a unit appears in its own context. ! 2001-10-25 Ed Schonberg * sem_util.adb (Defining_Entity): in case of error, attach created entity to specification, so that semantic analysis can proceed. ! 2001-10-25 Robert Dewar * sem_util.adb (Defining_Entity): Deal with Error. (Process_End_Label): Deal with bad end label for. ! 2001-10-25 Ed Schonberg * sem_elab.adb (Check_A_Call): refine message when call is in an instance but callee is not declared in the generic unit. ! 2001-10-25 Ed Schonberg * sem_elab.adb (Check_A_Call): check for renaming before finding the enclosing unit, which may already be different from the calling unit. ! 2001-10-25 Geert Bosch * 4gintnam.ads: fix header format. ! 2001-10-25 Ed Schonberg * sem_res.adb (Resolve_Call): if the call is actually an indexing operation on the result of a parameterless call, perform elaboration *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35798,35804 **** inlined within the generic tree, the defining identifier is not a compilation_unit. ! 2001-10-25 Ed Schonberg * sem_res.adb (Resolve): special-case resolution of Null in an instance or an inlined body to avoid view conflicts. --- 44278,44284 ---- inlined within the generic tree, the defining identifier is not a compilation_unit. ! 2001-10-25 Ed Schonberg * sem_res.adb (Resolve): special-case resolution of Null in an instance or an inlined body to avoid view conflicts. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35806,35812 **** * sem_ch12.adb (Copy_Generic_Node): for allocators, check for view compatibility by retrieving the access type of the generic copy. ! 2001-10-25 Robert Dewar * sem_ch3.adb: (Analyze_Number_Declaration): Handle error expression. --- 44286,44292 ---- * sem_ch12.adb (Copy_Generic_Node): for allocators, check for view compatibility by retrieving the access type of the generic copy. ! 2001-10-25 Robert Dewar * sem_ch3.adb: (Analyze_Number_Declaration): Handle error expression. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35815,35826 **** * sem_util.adb (Get_Index_Bounds): Check for Error. ! 2001-10-25 Robert Dewar * restrict.adb (Set_No_Run_Time_Mode): Set Discard_Names as default in no run time mode. ! 2001-10-25 Pascal Obry * gnatmem.adb (Read_Next): fix Curs2 value to properly handle quiet mode case for ALLOC case. --- 44295,44306 ---- * sem_util.adb (Get_Index_Bounds): Check for Error. ! 2001-10-25 Robert Dewar * restrict.adb (Set_No_Run_Time_Mode): Set Discard_Names as default in no run time mode. ! 2001-10-25 Pascal Obry * gnatmem.adb (Read_Next): fix Curs2 value to properly handle quiet mode case for ALLOC case. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35828,35834 **** * gnatmem.adb (Read_Next): correctly fix parsing in Quiet mode on all platforms. Improvement of last change. ! 2001-10-25 Robert Dewar * exp_ch4.adb (Expand_N_Allocator): Minor reformatting. --- 44308,44314 ---- * gnatmem.adb (Read_Next): correctly fix parsing in Quiet mode on all platforms. Improvement of last change. ! 2001-10-25 Robert Dewar * exp_ch4.adb (Expand_N_Allocator): Minor reformatting. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35836,35842 **** * osint.adb (Is_Relative): Remove duplicate. ! 2001-10-25 Pascal Obry * osint.adb (Read_Default_Search_Dirs): correctly detect relative pathnames in UNIX and DOS style with drive letter. --- 44316,44322 ---- * osint.adb (Is_Relative): Remove duplicate. ! 2001-10-25 Pascal Obry * osint.adb (Read_Default_Search_Dirs): correctly detect relative pathnames in UNIX and DOS style with drive letter. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35847,35860 **** * osint.adb (Is_Relative): implementation using GNAT.OS_Lib.Is_Absolute_Path. Better fix. ! 2001-10-25 Pascal Obry * g-dirope.adb (Basename): correctly compute offset between the original Path and the translated one. * g-dirope.adb: (Base_Name): add some comments. ! 2001-10-25 Robert Dewar * exp_imgv.adb (Expand_Image_Attribute): Defend against bad use in HIE mode, avoids compilation abandoned message --- 44327,44340 ---- * osint.adb (Is_Relative): implementation using GNAT.OS_Lib.Is_Absolute_Path. Better fix. ! 2001-10-25 Pascal Obry * g-dirope.adb (Basename): correctly compute offset between the original Path and the translated one. * g-dirope.adb: (Base_Name): add some comments. ! 2001-10-25 Robert Dewar * exp_imgv.adb (Expand_Image_Attribute): Defend against bad use in HIE mode, avoids compilation abandoned message *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35863,35873 **** * exp_imgv.adb: Correct typo in previous change (not my day!) ! 2001-10-25 Robert Dewar * s-tpinop.ads: Add 2001 to copyright notice. Fix header format. ! 2001-10-25 Pascal Obry * g-awk.ads: Move all pragma inlines next to the routine declarations. This is more uniform with other GNAT spec. --- 44343,44353 ---- * exp_imgv.adb: Correct typo in previous change (not my day!) ! 2001-10-25 Robert Dewar * s-tpinop.ads: Add 2001 to copyright notice. Fix header format. ! 2001-10-25 Pascal Obry * g-awk.ads: Move all pragma inlines next to the routine declarations. This is more uniform with other GNAT spec. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35902,35930 **** * validsw.adb: Properly save -gnatVn status. ! 2001-10-11 Robert Dewar * usage.adb: Add lines for V switch. * gnatcmd.adb (COMPILE): Revise translations for -gnatV (/VALIDITY_CHECKING). ! 2001-10-11 Ed Schonberg * sem_type.adb (Add_One_Interp): an operator for a type declared in an extension of System is known to be visible. ! 2001-10-11 Ed Schonberg * sem_eval.adb (Compare_Fixup): get the bounds of a String_Literal properly. Fixes regression on ACATS C34005G. ! 2001-10-11 Robert Dewar * sem_ch5.adb (Analyze_Iteration_Scheme): Suppress warning on null loop in generic instance, since this is likely not very useful. ! 2001-10-11 Robert Dewar * restrict.adb (Disallow in No_Run_Time_Mode): Properly specialize the error message for high integrity mode. --- 44382,44410 ---- * validsw.adb: Properly save -gnatVn status. ! 2001-10-11 Robert Dewar * usage.adb: Add lines for V switch. * gnatcmd.adb (COMPILE): Revise translations for -gnatV (/VALIDITY_CHECKING). ! 2001-10-11 Ed Schonberg * sem_type.adb (Add_One_Interp): an operator for a type declared in an extension of System is known to be visible. ! 2001-10-11 Ed Schonberg * sem_eval.adb (Compare_Fixup): get the bounds of a String_Literal properly. Fixes regression on ACATS C34005G. ! 2001-10-11 Robert Dewar * sem_ch5.adb (Analyze_Iteration_Scheme): Suppress warning on null loop in generic instance, since this is likely not very useful. ! 2001-10-11 Robert Dewar * restrict.adb (Disallow in No_Run_Time_Mode): Properly specialize the error message for high integrity mode. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 35949,35976 **** * rtsfind.adb (RTE): Make sure we do not try to load unit after giving message for entity not available in high integrity mode. ! 2001-10-11 Pascal Obry * impunit.adb: Add GNAT.CRC32. ! 2001-10-11 Ed Schonberg * exp_fixd.adb (Expand_Multiply_Fixed_By_Fixed_Giving_Fixed): handle properly the case where one universal operand in a non-static exponentiation of a real literal. ! 2001-10-11 Ed Schonberg * exp_ch7.adb (Find_Final_List): for a type appearing in a with_type clause, return the gobal finalization list, for lack of anthing else. ! 2001-10-11 Ed Schonberg * exp_ch7.adb (Make_Transient_Block): if statement is within exception handler, always use new transient scope to place Clean procedure. ! 2001-10-11 Pascal Obry * Makefile.in: (GNAT_ADA_OBJS): add g-crc32.o, a-tags.o, a-stream.o --- 44429,44456 ---- * rtsfind.adb (RTE): Make sure we do not try to load unit after giving message for entity not available in high integrity mode. ! 2001-10-11 Pascal Obry * impunit.adb: Add GNAT.CRC32. ! 2001-10-11 Ed Schonberg * exp_fixd.adb (Expand_Multiply_Fixed_By_Fixed_Giving_Fixed): handle properly the case where one universal operand in a non-static exponentiation of a real literal. ! 2001-10-11 Ed Schonberg * exp_ch7.adb (Find_Final_List): for a type appearing in a with_type clause, return the gobal finalization list, for lack of anthing else. ! 2001-10-11 Ed Schonberg * exp_ch7.adb (Make_Transient_Block): if statement is within exception handler, always use new transient scope to place Clean procedure. ! 2001-10-11 Pascal Obry * Makefile.in: (GNAT_ADA_OBJS): add g-crc32.o, a-tags.o, a-stream.o *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 36135,36141 **** * gnat-style.texi: New file describing coding guidelines for Ada. ! 2001-10-10 Ed Schonberg * einfo.adb (Write_Entity_Flags): Elaboration_Entity_Required is Flag174. --- 44615,44621 ---- * gnat-style.texi: New file describing coding guidelines for Ada. ! 2001-10-10 Ed Schonberg * einfo.adb (Write_Entity_Flags): Elaboration_Entity_Required is Flag174. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 36148,36154 **** * snames.h: Update to reflect snames.ads changes. ! 2001-10-10 Vincent Celier * make.adb: (Add_Switches): reflect the changes for the switches attributes --- 44628,44634 ---- * snames.h: Update to reflect snames.ads changes. ! 2001-10-10 Vincent Celier * make.adb: (Add_Switches): reflect the changes for the switches attributes *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 36234,36246 **** * prj.ads: Add ??? for uncommented declarations ! 2001-10-10 Ed Schonberg * sem_prag.adb: (Analyze_Pragma, case External): If entity is a constant, do not indicate possible modification, so that gigi can treat it as a bona fide constant. ! 2001-10-10 Robert Dewar * sem_prag.adb: Add processing for pragma External. --- 44714,44726 ---- * prj.ads: Add ??? for uncommented declarations ! 2001-10-10 Ed Schonberg * sem_prag.adb: (Analyze_Pragma, case External): If entity is a constant, do not indicate possible modification, so that gigi can treat it as a bona fide constant. ! 2001-10-10 Robert Dewar * sem_prag.adb: Add processing for pragma External. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 36250,36256 **** * snames.adb: Updated to match snames.ads. ! 2001-10-10 Ed Schonberg * exp_ch4.adb (Expand_N_Allocator): Generate meaningful names for a dynamic task if the allocator appears in an indexed assignment --- 44730,44736 ---- * snames.adb: Updated to match snames.ads. ! 2001-10-10 Ed Schonberg * exp_ch4.adb (Expand_N_Allocator): Generate meaningful names for a dynamic task if the allocator appears in an indexed assignment *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 36260,36266 **** For a dynamic task in an assignment statement, use target of assignment to generate meaningful name. ! 2001-10-10 Ed Schonberg * einfo.adb (Write_Field19_Name): Body_Entity is also defined for a generic package. --- 44740,44746 ---- For a dynamic task in an assignment statement, use target of assignment to generate meaningful name. ! 2001-10-10 Ed Schonberg * einfo.adb (Write_Field19_Name): Body_Entity is also defined for a generic package. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 36283,36300 **** (typically the discriminal in an init_proc) denote the same value. Two useful optimization uncovered by bugfixes above. ! 2001-10-10 Robert Dewar * xeinfo.adb: Change int to char in translation of enumeration types. This fixes a problem in the C representation of component alignment. Add 2001 to copyright notice ! 2001-10-10 Richard Kenner * decl.c: (validate_size): Do check size of object of integral type if it is a packed array type. ! 2001-10-10 Richard Kenner * decl.c: (gnat_to_gnu_entity, case object): Also materialize VAR_DECL for constant if not Is_Public but -O0. --- 44763,44780 ---- (typically the discriminal in an init_proc) denote the same value. Two useful optimization uncovered by bugfixes above. ! 2001-10-10 Robert Dewar * xeinfo.adb: Change int to char in translation of enumeration types. This fixes a problem in the C representation of component alignment. Add 2001 to copyright notice ! 2001-10-10 Richard Kenner * decl.c: (validate_size): Do check size of object of integral type if it is a packed array type. ! 2001-10-10 Richard Kenner * decl.c: (gnat_to_gnu_entity, case object): Also materialize VAR_DECL for constant if not Is_Public but -O0. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 36350,36356 **** * comperr.adb (Abort_In_Progress): New. (Compiler_Abort): Use it to prevent recursion. ! 2001-10-08 Robert Dewar * atree.adb: Set Error_Posted in Error node, helps error recovery. --- 44830,44836 ---- * comperr.adb (Abort_In_Progress): New. (Compiler_Abort): Use it to prevent recursion. ! 2001-10-08 Robert Dewar * atree.adb: Set Error_Posted in Error node, helps error recovery. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 36369,36385 **** * sinfo.ads (N_Error): Now has Etype field (which will be set to Any_Type to help error recovery). ! 2001-10-08 Richard Kenner (kenner@gnat.com) * misc.c (gnat_expand_expr, case UNCHECKED_CONVERT_EXPR): Consistently set MEM attributes from expression; fixes bootstrap failure on x86. ! 2001-10-08 Geert Bosch (bosch@gnat.com) * 5oosinte.adb: Add 2001 to copyright notice. ! 2001-10-08 Geert Bosch (bosch@gnat.com) * ceinfo.adb: Add utility for consistency checking of einfo.ad[bs]. --- 44849,44865 ---- * sinfo.ads (N_Error): Now has Etype field (which will be set to Any_Type to help error recovery). ! 2001-10-08 Richard Kenner * misc.c (gnat_expand_expr, case UNCHECKED_CONVERT_EXPR): Consistently set MEM attributes from expression; fixes bootstrap failure on x86. ! 2001-10-08 Geert Bosch * 5oosinte.adb: Add 2001 to copyright notice. ! 2001-10-08 Geert Bosch * ceinfo.adb: Add utility for consistency checking of einfo.ad[bs]. *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 36389,36395 **** * 5oosinte.adb: Fix spelling error of "separate" as "seperate". ! 2001-10-05 Geert Bosch (bosch@gnat.com) * adaint.h: Small formatting fix. --- 44869,44875 ---- * 5oosinte.adb: Fix spelling error of "separate" as "seperate". ! 2001-10-05 Geert Bosch * adaint.h: Small formatting fix. diff -Nrcpad gcc-4.3.3/gcc/ada/Make-lang.in gcc-4.4.0/gcc/ada/Make-lang.in *** gcc-4.3.3/gcc/ada/Make-lang.in Thu Dec 4 23:00:19 2008 --- gcc-4.4.0/gcc/ada/Make-lang.in Thu Jan 1 00:00:00 1970 *************** *** 1,4312 **** - # Top level -*- makefile -*- fragment for GNU Ada (GNAT). - # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, - # 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. - - #This file is part of GCC. - - #GCC is free software; you can redistribute it and/or modify - #it under the terms of the GNU General Public License as published by - #the Free Software Foundation; either version 3, or (at your option) - #any later version. - - #GCC is distributed in the hope that it will be useful, - #but WITHOUT ANY WARRANTY; without even the implied warranty of - #MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - #GNU General Public License for more details. - - #You should have received a copy of the GNU General Public License - #along with GCC; see the file COPYING3. If not see - #. - - # This file provides the language dependent support in the main Makefile. - # Each language makefile fragment must provide the following targets: - # - # foo.all.cross, foo.start.encap, foo.rest.encap, - # foo.install-common, foo.install-man, foo.install-info, foo.install-pdf, - # foo.info, foo.dvi, foo.pdf, foo.html, foo.uninstall, - # foo.mostlyclean, foo.clean, foo.distclean, - # foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4 - # - # where `foo' is the name of the language. - # - # It should also provide rules for: - # - # - making any compiler driver (eg: g++) - # - the compiler proper (eg: cc1plus) - # - define the names for selecting the language in LANGUAGES. - # tool definitions - CP = cp -p - ECHO = echo - MV = mv - MKDIR = mkdir -p - RM = rm -f - RMDIR = rm -rf - - - # Extra flags to pass to recursive makes. - BOOT_ADAFLAGS= $(ADAFLAGS) - ADAFLAGS= -gnatpg -gnata - ALL_ADAFLAGS = $(CFLAGS) $(ALL_ADA_CFLAGS) $(X_ADAFLAGS) $(T_ADAFLAGS) \ - $(ADAFLAGS) - FORCE_DEBUG_ADAFLAGS = -g - ADA_CFLAGS = - ALL_ADA_CFLAGS = $(X_ADA_CFLAGS) $(T_ADA_CFLAGS) $(ADA_CFLAGS) - ADA_INCLUDES = -nostdinc -I- -I. -Iada -I$(srcdir)/ada - ADA_INCLUDE_DIR = $(libsubdir)/adainclude - ADA_RTL_OBJ_DIR = $(libsubdir)/adalib - ADA_FLAGS_TO_PASS = \ - "ADA_FOR_BUILD=$(ADA_FOR_BUILD)" \ - "ADA_INCLUDE_DIR=$(ADA_INCLUDE_DIR)" \ - "ADA_RTL_OBJ_DIR=$(ADA_RTL_OBJ_DIR)" \ - "ADAFLAGS=$(ADAFLAGS)" \ - "ADA_FOR_TARGET=$(ADA_FOR_TARGET)" \ - "INSTALL=$(INSTALL)" \ - "INSTALL_DATA=$(INSTALL_DATA)" \ - "INSTALL_PROGRAM=$(INSTALL_PROGRAM)" - - # Say how to compile Ada programs. - .SUFFIXES: .ada .adb .ads - - # FIXME: need to add $(ALL_ADA_CFLAGS) to .c.o suffix rule - # Use loose warnings for this front end, but add some special flags - ada-warn = $(ALL_ADA_CFLAGS) $(WERROR) - # unresolved warnings in a couple of files - ada/tracebak.o-warn = -Wno-error - ada/b_gnat1.o-warn = -Wno-error - ada/b_gnatb.o-warn = -Wno-error - - .adb.o: - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) - .ads.o: - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) - - # Define the names for selecting Ada in LANGUAGES. - ada: gnat1$(exeext) gnatbind$(exeext) - - # Tell GNU Make to ignore these, if they exist. - .PHONY: ada - - # There are too many Ada sources to check against here. Let's - # always force the recursive make. - ADA_TOOLS_FLAGS_TO_PASS=\ - "CC=../../xgcc -B../../" \ - "CFLAGS=$(CFLAGS)" \ - "exeext=$(exeext)" \ - "ADAFLAGS=$(ADAFLAGS)" \ - "ADA_INCLUDES=-I../rts" \ - "GNATMAKE=../../gnatmake" \ - "GNATLINK=../../gnatlink" \ - "GNATBIND=../../gnatbind" - - GCC_LINK=$(CC) -static-libgcc $(LDFLAGS) - - # Lists of files for various purposes. - - # Languages-specific object files for Ada. - # Object files for gnat1 from C sources. - GNAT1_C_OBJS = ada/b_gnat1.o ada/adadecode.o ada/adaint.o ada/cstreams.o \ - ada/cio.o ada/targtyps.o ada/decl.o ada/misc.o ada/utils.o ada/utils2.o \ - ada/trans.o ada/cuintp.o ada/argv.o ada/raise.o ada/init.o ada/tracebak.o \ - ada/initialize.o ada/env.o - - # Object files from Ada sources that are used by gnat1 - - GNAT_ADA_OBJS = ada/ada.o ada/a-charac.o ada/a-chlat1.o ada/a-except.o \ - ada/a-elchha.o ada/a-ioexce.o \ - ada/s-memory.o ada/s-carun8.o ada/s-casuti.o ada/s-strcom.o ada/s-purexc.o \ - ada/s-htable.o ada/s-traceb.o ada/s-mastop.o ada/ali.o \ - ada/alloc.o ada/atree.o ada/butil.o ada/casing.o ada/checks.o ada/comperr.o \ - ada/csets.o ada/cstand.o ada/debug.o ada/debug_a.o ada/einfo.o ada/elists.o \ - ada/errout.o ada/erroutc.o ada/err_vars.o ada/eval_fat.o ada/exp_attr.o \ - ada/exp_ch11.o ada/exp_ch12.o ada/exp_ch13.o ada/exp_ch2.o ada/exp_ch3.o \ - ada/exp_ch4.o ada/exp_ch5.o ada/exp_ch6.o ada/exp_ch7.o ada/exp_ch8.o \ - ada/exp_ch9.o ada/exp_code.o ada/exp_dbug.o ada/exp_disp.o ada/exp_atag.o \ - ada/exp_dist.o ada/exp_fixd.o ada/exp_aggr.o ada/exp_imgv.o ada/exp_intr.o \ - ada/exp_pakd.o ada/exp_prag.o ada/exp_sel.o ada/exp_smem.o ada/exp_strm.o \ - ada/exp_tss.o ada/exp_util.o ada/exp_vfpt.o ada/expander.o ada/fname.o \ - ada/fname-uf.o ada/fmap.o ada/freeze.o ada/frontend.o ada/gnat.o \ - ada/g-byorma.o \ - ada/g-hesora.o ada/g-htable.o ada/s-os_lib.o \ - ada/g-speche.o ada/g-spchge.o ada/g-u3spch.o ada/s-string.o \ - ada/s-utf_32.o ada/s-crc32.o ada/get_targ.o \ - ada/gnatvsn.o ada/hlo.o ada/hostparm.o ada/impunit.o ada/interfac.o \ - ada/itypes.o ada/inline.o ada/krunch.o ada/lib.o ada/layout.o \ - ada/lib-load.o ada/lib-util.o ada/lib-xref.o ada/lib-writ.o ada/live.o \ - ada/namet.o ada/namet-sp.o \ - ada/nlists.o ada/nmake.o ada/opt.o ada/osint.o ada/osint-c.o \ - ada/output.o \ - ada/par.o ada/prep.o ada/prepcomp.o ada/repinfo.o ada/restrict.o \ - ada/rident.o ada/rtsfind.o \ - ada/s-addope.o ada/s-assert.o ada/s-parame.o ada/s-stache.o \ - ada/s-stalib.o ada/s-imgenu.o ada/s-imenne.o ada/s-stoele.o ada/s-soflin.o \ - ada/s-except.o ada/s-exctab.o \ - ada/s-secsta.o ada/s-strops.o ada/s-sopco3.o ada/s-sopco4.o ada/s-sopco5.o \ - ada/s-traent.o ada/s-wchcnv.o ada/s-wchcon.o ada/s-wchjis.o \ - ada/s-unstyp.o ada/scans.o ada/scng.o ada/scn.o ada/sdefault.o ada/sem.o \ - ada/sem_aggr.o ada/sem_attr.o ada/sem_cat.o ada/sem_ch10.o ada/sem_ch11.o \ - ada/sem_ch12.o ada/sem_ch13.o ada/sem_ch2.o ada/sem_ch3.o ada/sem_ch4.o \ - ada/sem_ch5.o ada/sem_ch6.o ada/sem_ch7.o ada/sem_ch8.o ada/sem_ch9.o \ - ada/sem_case.o ada/sem_disp.o ada/sem_dist.o ada/sem_elab.o ada/sem_elim.o \ - ada/sem_eval.o ada/sem_intr.o ada/sem_maps.o ada/sem_mech.o ada/sem_prag.o \ - ada/sem_res.o ada/sem_smem.o ada/sem_type.o ada/sem_util.o ada/sem_vfpt.o \ - ada/sem_warn.o ada/sinfo-cn.o ada/sinfo.o ada/sinput.o ada/sinput-d.o \ - ada/sinput-l.o ada/snames.o ada/sprint.o ada/stand.o ada/stringt.o \ - ada/style.o ada/styleg.o ada/styleg-c.o ada/switch.o ada/switch-c.o \ - ada/stylesw.o ada/validsw.o ada/system.o ada/table.o ada/targparm.o \ - ada/tbuild.o ada/tree_gen.o ada/tree_io.o ada/treepr.o ada/treeprs.o \ - ada/ttypef.o ada/ttypes.o ada/types.o ada/uintp.o ada/uname.o ada/urealp.o \ - ada/usage.o ada/widechar.o ada/s-crtl.o ada/seh_init.o ada/targext.o \ - ada/s-restri.o - - # Object files for gnat executables - GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o - - GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) $(EXTRA_GNAT1_OBJS) - - GNATBIND_OBJS = \ - ada/adaint.o \ - ada/argv.o \ - ada/exit.o \ - ada/cio.o \ - ada/cstreams.o \ - ada/env.o \ - ada/final.o \ - ada/init.o \ - ada/initialize.o \ - ada/seh_init.o \ - ada/link.o \ - ada/targext.o \ - ada/raise.o \ - ada/tracebak.o \ - ada/ada.o \ - ada/a-clrefi.o \ - ada/a-comlin.o \ - ada/a-elchha.o \ - ada/a-except.o \ - ada/ali-util.o \ - ada/ali.o \ - ada/alloc.o \ - ada/atree.o \ - ada/bcheck.o \ - ada/binde.o \ - ada/binderr.o \ - ada/bindgen.o \ - ada/bindusg.o \ - ada/butil.o \ - ada/casing.o \ - ada/csets.o \ - ada/debug.o \ - ada/einfo.o \ - ada/elists.o \ - ada/err_vars.o \ - ada/errout.o \ - ada/erroutc.o \ - ada/fmap.o \ - ada/fname.o \ - ada/g-hesora.o \ - ada/g-htable.o \ - ada/s-os_lib.o \ - ada/s-string.o \ - ada/gnat.o \ - ada/gnatbind.o \ - ada/gnatvsn.o \ - ada/hostparm.o \ - ada/interfac.o \ - ada/lib.o \ - ada/namet.o \ - ada/nlists.o \ - ada/opt.o \ - ada/osint-b.o \ - ada/osint.o \ - ada/output.o \ - ada/rident.o \ - ada/s-addope.o \ - ada/s-assert.o \ - ada/s-carun8.o \ - ada/s-casuti.o \ - ada/s-crc32.o \ - ada/s-crtl.o \ - ada/s-except.o \ - ada/s-exctab.o \ - ada/s-htable.o \ - ada/s-imenne.o \ - ada/s-imgenu.o \ - ada/s-mastop.o \ - ada/s-memory.o \ - ada/s-parame.o \ - ada/s-restri.o \ - ada/s-secsta.o \ - ada/s-soflin.o \ - ada/s-sopco3.o \ - ada/s-sopco4.o \ - ada/s-sopco5.o \ - ada/s-stache.o \ - ada/s-stalib.o \ - ada/s-stoele.o \ - ada/s-strops.o \ - ada/s-traceb.o \ - ada/s-traent.o \ - ada/s-unstyp.o \ - ada/s-utf_32.o \ - ada/s-wchcnv.o \ - ada/s-wchcon.o \ - ada/s-wchjis.o \ - ada/scng.o \ - ada/scans.o \ - ada/sdefault.o \ - ada/sinfo.o \ - ada/sinput.o \ - ada/sinput-c.o \ - ada/snames.o \ - ada/stand.o \ - ada/stringt.o \ - ada/switch-b.o \ - ada/switch.o \ - ada/style.o \ - ada/styleg.o \ - ada/stylesw.o \ - ada/system.o \ - ada/table.o \ - ada/targparm.o \ - ada/tree_io.o \ - ada/types.o \ - ada/uintp.o \ - ada/uname.o \ - ada/urealp.o \ - ada/widechar.o \ - $(EXTRA_GNATBIND_OBJS) - - # List of extra object files linked in with various programs. - EXTRA_GNAT1_OBJS = prefix.o - EXTRA_GNATBIND_OBJS = prefix.o version.o - - # Language-independent object files. - ADA_BACKEND = $(BACKEND) attribs.o - - # List of target dependent sources, overridden below as necessary - TARGET_ADA_SRCS = - - # Needs to be built with CC=gcc - # Since the RTL should be built with the latest compiler, remove the - # stamp target in the parent directory whenever gnat1 is rebuilt - gnat1$(exeext): $(TARGET_ADA_SRCS) $(GNAT1_OBJS) $(ADA_BACKEND) $(LIBDEPS) - $(GCC_LINK) -o $@ $(GNAT1_OBJS) $(ADA_BACKEND) $(ALL_CFLAGS) $(LIBS) $(SYSLIBS) $(GMPLIBS) - $(RM) stamp-gnatlib2 stamp-tools - - gnatbind$(exeext): ada/b_gnatb.o $(CONFIG_H) $(GNATBIND_OBJS) - $(GCC_LINK) -o $@ ada/b_gnatb.o $(GNATBIND_OBJS) $(ALL_CFLAGS) $(LIBS) $(SYSLIBS) - - # use cross-gcc - gnat-cross: force - make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp" \ - $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) HOST_CFLAGS= HOST_CC=cc - - gen-soccon: force - $(MAKE) -C ada $(FLAGS_TO_PASS) \ - GNATLIBFLAGS="$(GNATLIBFLAGS)" \ - GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ - TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \ - THREAD_KIND="$(THREAD_KIND)" \ - TRACE="$(TRACE)" \ - LIBGNAT_OBJS=gen-soccon \ - gnatlib - - - # Build hooks: - - ada.all.cross: - -if [ -f gnatbind$(exeext) ] ; \ - then \ - $(MV) gnatbind$(exeext) gnatbind-cross$(exeext); \ - fi - -if [ -f gnatbl$(exeext) ] ; \ - then \ - $(MV) gnatbl$(exeext) gnatbl-cross$(exeext); \ - fi - -if [ -f gnatchop$(exeext) ] ; \ - then \ - $(MV) gnatchop$(exeext) gnatchop-cross$(exeext); \ - fi - -if [ -f gnat$(exeext) ] ; \ - then \ - $(MV) gnat$(exeext) gnat-cross$(exeext); \ - fi - -if [ -f gnatkr$(exeext) ] ; \ - then \ - $(MV) gnatkr$(exeext) gnatkr-cross$(exeext); \ - fi - -if [ -f gnatlink$(exeext) ] ; \ - then \ - $(MV) gnatlink$(exeext) gnatlink-cross$(exeext); \ - fi - -if [ -f gnatls$(exeext) ] ; \ - then \ - $(MV) gnatls$(exeext) gnatls-cross$(exeext); \ - fi - -if [ -f gnatmake$(exeext) ] ; \ - then \ - $(MV) gnatmake$(exeext) gnatmake-cross$(exeext); \ - fi - -if [ -f gnatname$(exeext) ] ; \ - then \ - $(MV) gnatname$(exeext) gnatname-cross$(exeext); \ - fi - -if [ -f gnatprep$(exeext) ] ; \ - then \ - $(MV) gnatprep$(exeext) gnatprep-cross$(exeext); \ - fi - -if [ -f gnatxref$(exeext) ] ; \ - then \ - $(MV) gnatxref$(exeext) gnatxref-cross$(exeext); \ - fi - -if [ -f gnatfind$(exeext) ] ; \ - then \ - $(MV) gnatfind$(exeext) gnatfind-cross$(exeext); \ - fi - -if [ -f gnatclean$(exeext) ] ; \ - then \ - $(MV) gnatclean$(exeext) gnatclean-cross$(exeext); \ - fi - -if [ -f gnatsym$(exeext) ] ; \ - then \ - $(MV) gnatsym$(exeext) gnatsym-cross$(exeext); \ - fi - -if [ -f gprmake$(exeext) ] ; \ - then \ - $(MV) gprmake$(exeext) gprmake-cross$(exeext); \ - fi - - ada.start.encap: - ada.rest.encap: - ada.man: - ada.srcextra: - ada.srcman: - - ada.tags: force - cd $(srcdir)/ada; etags -o TAGS.sub *.c *.h *.ads *.adb; \ - etags --include TAGS.sub --include ../TAGS.sub - - - # Generate documentation. - - ada/doctools/xgnatugn$(build_exeext): ada/xgnatugn.adb - -$(MKDIR) ada/doctools - $(CP) $^ ada/doctools - cd ada/doctools && $(GNATMAKE) -q xgnatugn - - # Note that gnat_ugn_unw.texi does not depend on xgnatugn - # being built so we can distribute a pregenerated gnat_ugn_unw.info - - doc/gnat_ugn_unw.texi: $(srcdir)/ada/gnat_ugn.texi $(srcdir)/ada/ug_words \ - $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi - $(MAKE) ada/doctools/xgnatugn$(build_exeext) - ada/doctools/xgnatugn unw $(srcdir)/ada/gnat_ugn.texi \ - $(srcdir)/ada/ug_words doc/gnat_ugn_unw.texi - - doc/gnat_ugn_unw.info: doc/gnat_ugn_unw.texi \ - $(gcc_docdir)/include/fdl.texi $(gcc_docdir)/include/gcc-common.texi \ - gcc-vers.texi - if [ x$(BUILD_INFO) = xinfo ]; then \ - rm -f $(@)*; \ - $(MAKEINFO) $(MAKEINFOFLAGS) -I$(gcc_docdir)/include \ - -I$(srcdir)/ada -o $@ $<; \ - else true; fi - - doc/gnat_rm.info: ada/gnat_rm.texi $(gcc_docdir)/include/fdl.texi \ - $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi - if [ x$(BUILD_INFO) = xinfo ]; then \ - rm -f $(@)*; \ - $(MAKEINFO) $(MAKEINFOFLAGS) -I$(gcc_docdir)/include \ - -I$(srcdir)/ada -o $@ $<; \ - else true; fi - - doc/gnat-style.info: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi \ - $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi - if [ x$(BUILD_INFO) = xinfo ]; then \ - rm -f $(@)*; \ - $(MAKEINFO) $(MAKEINFOFLAGS) -I$(gcc_docdir)/include \ - -I$(srcdir)/ada -o $@ $<; \ - else true; fi - - ADA_INFOFILES = doc/gnat_ugn_unw.info doc/gnat_ugn_unw.texi \ - doc/gnat_rm.info doc/gnat-style.info - - ada.info: $(ADA_INFOFILES) - - ada.srcinfo: $(ADA_INFOFILES) - -$(CP) $^ $(srcdir)/doc - - ada.install-info: $(DESTDIR)$(infodir)/gnat_ugn_unw.info \ - $(DESTDIR)$(infodir)/gnat_rm.info \ - $(DESTDIR)$(infodir)/gnat-style.info - - ada.dvi: doc/gnat_ugn_unw.dvi \ - doc/gnat_rm.dvi doc/gnat-style.dvi - - ADA_PDFFILES = doc/gnat_ugn_unw.pdf \ - doc/gnat_rm.pdf doc/gnat-style.pdf - - ada.pdf: $(ADA_PDFFILES) - - ada.install-pdf: $(ADA_PDFFILES) - @$(NORMAL_INSTALL) - test -z "$(pdfdir)/gcc" || $(mkinstalldirs) "$(DESTDIR)$(pdfdir)/gcc" - @list='$(ADA_PDFFILES)'; for p in $$list; do \ - if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ - f=$(pdf__strip_dir) \ - echo " $(INSTALL_DATA) '$$d$$p' '$(DESTDIR)$(pdfdir)/gcc/$$f'"; \ - $(INSTALL_DATA) "$$d$$p" "$(DESTDIR)$(pdfdir)/gcc/$$f"; \ - done - - ada.html: - - doc/gnat_ugn_unw.dvi: doc/gnat_ugn_unw.texi $(gcc_docdir)/include/fdl.texi \ - $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi - $(TEXI2DVI) -c -I $(abs_docdir)/include -o $@ $< - - doc/gnat_rm.dvi: ada/gnat_rm.texi $(gcc_docdir)/include/fdl.texi \ - $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi - $(TEXI2DVI) -c -I $(abs_docdir)/include -o $@ $< - - doc/gnat-style.dvi: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi - $(TEXI2DVI) -c -I $(abs_docdir)/include -o $@ $< - - doc/gnat_ugn_unw.pdf: doc/gnat_ugn_unw.texi $(gcc_docdir)/include/fdl.texi \ - $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi - $(TEXI2PDF) -c -I $(abs_docdir)/include -o $@ $< - - doc/gnat_rm.pdf: ada/gnat_rm.texi $(gcc_docdir)/include/fdl.texi \ - $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi - $(TEXI2PDF) -c -I $(abs_docdir)/include -o $@ $< - - doc/gnat-style.pdf: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi - $(TEXI2PDF) -c -I $(abs_docdir)/include -o $@ $< - - - # Install hooks: - # gnat1 is installed elsewhere as part of $(COMPILERS). - - # Install the binder program as $(target_noncanonical)-gnatbind - # and also as either gnatbind (if native) or $(tooldir)/bin/gnatbind - # likewise for gnatf, gnatchop, and gnatlink, gnatkr, gnatmake, gnat, - # gnatprep, gnatbl, gnatls, gnatxref, gnatfind, gnatname, gnatclean, - # gnatsym, gprmake - ada.install-common: - $(MKDIR) $(DESTDIR)$(bindir) - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatbind-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbind$(exeext); \ - $(INSTALL_PROGRAM) gnatbind-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbind$(exeext); \ - if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ - rm -f $(DESTDIR)$(tooldir)/bin/gnatbind$(exeext); \ - $(INSTALL_PROGRAM) gnatbind-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatbind$(exeext); \ - fi; \ - else \ - $(RM) $(DESTDIR)$(bindir)/gnatbind$(exeext); \ - $(INSTALL_PROGRAM) gnatbind$(exeext) $(DESTDIR)$(bindir)/gnatbind$(exeext); \ - fi ; \ - fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatbl-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbl$(exeext); \ - $(INSTALL_PROGRAM) gnatbl-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbl$(exeext); \ - if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ - rm -f $(DESTDIR)$(tooldir)/bin/gnatbl$(exeext); \ - $(INSTALL_PROGRAM) gnatbl-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatbl$(exeext); \ - fi; \ - else \ - $(RM) $(DESTDIR)$(bindir)/gnatbl$(exeext); \ - $(INSTALL_PROGRAM) gnatbl$(exeext) $(DESTDIR)$(bindir)/gnatbl$(exeext); \ - fi ; \ - fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatchop-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatchop$(exeext); \ - $(INSTALL_PROGRAM) gnatchop-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatchop$(exeext); \ - if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ - rm -f $(DESTDIR)$(tooldir)/bin/gnatchop$(exeext); \ - $(INSTALL_PROGRAM) gnatchop-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatchop$(exeext); \ - fi ; \ - else \ - $(RM) $(DESTDIR)$(bindir)/gnatchop$(exeext); \ - $(INSTALL_PROGRAM) gnatchop$(exeext) $(DESTDIR)$(bindir)/gnatchop$(exeext); \ - fi ; \ - fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnat-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnat$(exeext); \ - $(INSTALL_PROGRAM) gnat-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnat$(exeext); \ - if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ - rm -f $(DESTDIR)$(tooldir)/bin/gnat$(exeext); \ - $(INSTALL_PROGRAM) gnat-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnat$(exeext); \ - fi; \ - else \ - $(RM) $(DESTDIR)$(bindir)/gnat$(exeext); \ - $(INSTALL_PROGRAM) gnat$(exeext) $(DESTDIR)$(bindir)/gnat$(exeext); \ - fi ; \ - fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatkr-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatkr$(exeext); \ - $(INSTALL_PROGRAM) gnatkr-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatkr$(exeext); \ - if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ - rm -f $(DESTDIR)$(tooldir)/bin/gnatkr$(exeext); \ - $(INSTALL_PROGRAM) gnatkr-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatkr$(exeext); \ - fi; \ - else \ - $(RM) $(DESTDIR)$(bindir)/gnatkr$(exeext); \ - $(INSTALL_PROGRAM) gnatkr$(exeext) $(DESTDIR)$(bindir)/gnatkr$(exeext); \ - fi ; \ - fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatlink-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatlink$(exeext); \ - $(INSTALL_PROGRAM) gnatlink-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatlink$(exeext); \ - if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ - rm -f $(DESTDIR)$(tooldir)/bin/gnatlink$(exeext); \ - $(INSTALL_PROGRAM) gnatlink-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatlink$(exeext); \ - fi; \ - else \ - $(RM) $(DESTDIR)$(bindir)/gnatlink$(exeext); \ - $(INSTALL_PROGRAM) gnatlink$(exeext) $(DESTDIR)$(bindir)/gnatlink$(exeext); \ - fi ; \ - fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatls-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatls$(exeext); \ - $(INSTALL_PROGRAM) gnatls-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatls$(exeext); \ - if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ - rm -f $(DESTDIR)$(tooldir)/bin/gnatls$(exeext); \ - $(INSTALL_PROGRAM) gnatls-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatls$(exeext); \ - fi; \ - else \ - $(RM) $(DESTDIR)$(bindir)/gnatls$(exeext); \ - $(INSTALL_PROGRAM) gnatls$(exeext) $(DESTDIR)$(bindir)/gnatls$(exeext); \ - fi ; \ - fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatmake-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatmake$(exeext); \ - $(INSTALL_PROGRAM) gnatmake-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatmake$(exeext); \ - if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ - rm -f $(DESTDIR)$(tooldir)/bin/gnatmake$(exeext); \ - $(INSTALL_PROGRAM) gnatmake-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatmake$(exeext); \ - fi; \ - else \ - $(RM) $(DESTDIR)$(bindir)/gnatmake$(exeext); \ - $(INSTALL_PROGRAM) gnatmake$(exeext) $(DESTDIR)$(bindir)/gnatmake$(exeext); \ - fi ; \ - fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatname-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatname$(exeext); \ - $(INSTALL_PROGRAM) gnatname-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatname$(exeext); \ - else \ - $(RM) $(DESTDIR)$(bindir)/gnatname$(exeext); \ - $(INSTALL_PROGRAM) gnatname$(exeext) $(DESTDIR)$(bindir)/gnatname$(exeext); \ - fi ; \ - fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatprep-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatprep$(exeext); \ - $(INSTALL_PROGRAM) gnatprep-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatprep$(exeext); \ - if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ - rm -f $(DESTDIR)$(tooldir)/bin/gnatprep$(exeext); \ - $(INSTALL_PROGRAM) gnatprep-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatprep$(exeext); \ - fi; \ - else \ - $(RM) $(DESTDIR)$(bindir)/gnatprep$(exeext); \ - $(INSTALL_PROGRAM) gnatprep$(exeext) $(DESTDIR)$(bindir)/gnatprep$(exeext); \ - fi ; \ - fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatxref-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatxref$(exeext); \ - $(INSTALL_PROGRAM) gnatxref-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatxref$(exeext); \ - else \ - $(RM) $(DESTDIR)$(bindir)/gnatxref$(exeext); \ - $(INSTALL_PROGRAM) gnatxref$(exeext) $(DESTDIR)$(bindir)/gnatxref$(exeext); \ - fi ; \ - fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatfind-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatfind$(exeext); \ - $(INSTALL_PROGRAM) gnatfind-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatfind$(exeext); \ - else \ - $(RM) $(DESTDIR)$(bindir)/gnatfind$(exeext); \ - $(INSTALL_PROGRAM) gnatfind$(exeext) $(DESTDIR)$(bindir)/gnatfind$(exeext); \ - fi ; \ - fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatclean-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatclean$(exeext); \ - $(INSTALL_PROGRAM) gnatclean-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatclean$(exeext); \ - else \ - $(RM) $(DESTDIR)$(bindir)/gnatclean$(exeext); \ - $(INSTALL_PROGRAM) gnatclean$(exeext) $(DESTDIR)$(bindir)/gnatclean$(exeext); \ - fi ; \ - fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gprmake-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gprmake$(exeext); \ - $(INSTALL_PROGRAM) gprmake-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gprmake$(exeext); \ - else \ - $(RM) $(bindir)/gprmake$(exeext); \ - $(INSTALL_PROGRAM) gprmake$(exeext) $(DESTDIR)$(bindir)/gprmake$(exeext); \ - fi ; \ - fi - # - # Gnatsym is only built on some platforms, including VMS - # - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatsym$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/gnatsym$(exeext); \ - $(INSTALL_PROGRAM) gnatsym$(exeext) $(DESTDIR)$(bindir)/gnatsym$(exeext); \ - fi ; \ - fi - # - # Gnatlbr is only used on VMS. - # - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gnatlbr$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/gnatlbr$(exeext); \ - $(INSTALL_PROGRAM) gnatlbr$(exeext) $(DESTDIR)$(bindir)/gnatlbr$(exeext); \ - fi ; \ - fi - # - # Gnatdll is only used on Windows. - # - -if [ -f gnat1$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/gnatdll$(exeext); \ - $(INSTALL_PROGRAM) gnatdll$(exeext) $(DESTDIR)$(bindir)/gnatdll$(exeext); \ - fi - # - # vxaddr2line is only used for cross ports (it calls the underlying cross - # addr2line). - # - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f vxaddr2line$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/vxaddr2line$(exeext); \ - $(INSTALL_PROGRAM) vxaddr2line$(exeext) $(DESTDIR)$(bindir)/vxaddr2line$(exeext); \ - fi ; \ - fi - - # - # Finally, install the library - # - -if [ -f gnat1$(exeext) ] ; \ - then \ - $(MAKE) $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib; \ - fi - - install-gnatlib: - $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib$(LIBGNAT_TARGET) - - install-gnatlib-obj: - $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib-obj - - ada.install-man: - - ada.uninstall: - -$(RM) $(DESTDIR)$(bindir)/gnatbind$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatbl$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatchop$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnat$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatfind$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatdll$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatkr$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatlbr$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatlink$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatls$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatmake$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatname$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatprep$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatxref$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatclean$(exeext) - -$(RM) $(DESTDIR)$(bindir)/gnatsym$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbind$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbl$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatchop$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnat$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatfind$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatdll$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatkr$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatlbr$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatlink$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatls$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatmake$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatname$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatprep$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatxref$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatclean$(exeext) - -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatsym$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatbind$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatbl$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatchop$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnat$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatfind$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatdll$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatkr$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatlbr$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatlink$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatls$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatmake$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatname$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatprep$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatxref$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatclean$(exeext) - -$(RM) $(DESTDIR)$(tooldir)/bin/gnatsym$(exeext) - # Gnatlbr and Gnatchop are only used on VMS - -$(RM) $(DESTDIR)$(bindir)/gnatlbr$(exeext) $(DESTDIR)$(bindir)/gnatchop$(exeext) - - # Clean hooks: - # A lot of the ancillary files are deleted by the main makefile. - # We just have to delete files specific to us. - - ada.mostlyclean: - -$(RM) ada/*$(objext) ada/*.ali ada/b_*.c - -$(RM) ada/*$(coverageexts) - -$(RM) ada/sdefault.adb ada/stamp-sdefault - -$(RMDIR) ada/tools - ada.clean: - ada.distclean: - -$(RM) ada/Makefile - -$(RM) gnatbl$(exeext) - -$(RM) gnatchop$(exeext) - -$(RM) gnat$(exeext) - -$(RM) gnatdll$(exeext) - -$(RM) gnatkr$(exeext) - -$(RM) gnatlink$(exeext) - -$(RM) gnatls$(exeext) - -$(RM) gnatmake$(exeext) - -$(RM) gnatname$(exeext) - -$(RM) gnatprep$(exeext) - -$(RM) gnatfind$(exeext) - -$(RM) gnatxref$(exeext) - -$(RM) gnatclean$(exeext) - -$(RM) gnatsym$(exeext) - -$(RM) gprmake$(exeext) - # Gnatlbr is only used on VMS - -$(RM) gnatlbr$(exeext) - -$(RM) ada/rts/* - -$(RMDIR) ada/rts - -$(RM) ada/tools/* - -$(RMDIR) ada/tools - ada.maintainer-clean: - -$(RM) ada/sinfo.h - -$(RM) ada/einfo.h - -$(RM) ada/nmake.adb - -$(RM) ada/nmake.ads - -$(RM) ada/treeprs.ads - - # Stage hooks: - # The main makefile has already created stage?/ada - - ada.stage1: stage1-start - -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage1/ada - -$(MV) ada/stamp-* stage1/ada - ada.stage2: stage2-start - -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage2/ada - -$(MV) ada/stamp-* stage2/ada - ada.stage3: stage3-start - -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage3/ada - -$(MV) ada/stamp-* stage3/ada - ada.stage4: stage4-start - -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage4/ada - -$(MV) ada/stamp-* stage4/ada - ada.stageprofile: stageprofile-start - -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stageprofile/ada - -$(MV) ada/stamp-* stageprofile/ada - ada.stagefeedback: stagefeedback-start - -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stagefeedback/ada - -$(MV) ada/stamp-* stagefeedback/ada - - lang_checks += check-gnat - - check-ada: check-acats check-gnat - check-ada-subtargets: check-acats-subtargets check-gnat-subtargets - - ACATSDIR = $(TESTSUITEDIR)/ada/acats - - check_acats_targets = $(patsubst %,check-acats%, 0 1 2) - - check-acats: - @test -d $(ACATSDIR) || mkdir -p $(ACATSDIR); \ - if [ -z "$(CHAPTERS)" ] && [ "$(filter -j, $(MFLAGS))" = "-j" ]; \ - then \ - $(MAKE) $(check_acats_targets); \ - for idx in 0 1 2; do \ - mv -f $(ACATSDIR)$$idx/acats.sum $(ACATSDIR)$$idx/acats.sum.sep; \ - mv -f $(ACATSDIR)$$idx/acats.log $(ACATSDIR)$$idx/acats.log.sep; \ - done; \ - $(SHELL) $(srcdir)/../contrib/dg-extract-results.sh \ - $(ACATSDIR)0/acats.sum.sep $(ACATSDIR)1/acats.sum.sep \ - $(ACATSDIR)2/acats.sum.sep > $(ACATSDIR)/acats.sum; \ - $(SHELL) $(srcdir)/../contrib/dg-extract-results.sh -L \ - $(ACATSDIR)0/acats.log.sep $(ACATSDIR)1/acats.log.sep \ - $(ACATSDIR)2/acats.log.sep > $(ACATSDIR)/acats.log; \ - exit 0; \ - fi; \ - testdir=`cd ${srcdir}/${ACATSDIR}; ${PWD_COMMAND}`; \ - export testdir; cd $(ACATSDIR); $(SHELL) $${testdir}/run_acats $(CHAPTERS) - - check-acats-subtargets: - @echo $(check_acats_targets) - - # Parallelized check-acats - $(check_acats_targets): check-acats%: - test -d $(ACATSDIR)$* || mkdir -p $(ACATSDIR)$*; \ - testdir=`cd ${srcdir}/${ACATSDIR} && ${PWD_COMMAND}`; \ - case "$*" in \ - 0) chapters="`cd $$testdir/tests; echo [a-b]* c[0-4]*`";; \ - 1) chapters="`cd $$testdir/tests; echo c[5-9ab]*`";; \ - 2) chapters="`cd $$testdir/tests; echo c[c-z]* [d-z]*`";; \ - esac; \ - export testdir; cd $(ACATSDIR)$* && $(SHELL) $${testdir}/run_acats $$chapters - - .PHONY: check-acats $(check_acats_targets) - - - # Bootstrapping targets for just GNAT - use the same stage directories - gnatboot: force - -$(RM) gnatboot3 - $(MAKE) gnat1$(exeext) gnatbind$(exeext) CC="$(CC)" \ - CFLAGS="$(CFLAGS)" - $(MAKE) gnatboot2 BOOT_CFLAGS="$(BOOT_CFLAGS)" \ - BOOT_ADAFLAGS="$(BOOT_ADAFLAGS)" \ - LDFLAGS="$(BOOT_LDFLAGS)" - - gnatboot2: force - $(MAKE) gnatstage1 - $(MAKE) gnat1$(exeext) gnatbind$(exeext) CC="gcc -B../stage1/"\ - CFLAGS="$(BOOT_CFLAGS)" \ - ADAFLAGS="$(BOOT_ADAFLAGS)"\ - LDFLAGS="$(BOOT_LDFLAGS)" \ - GNATBIND="../stage1/gnatbind" - $(MAKE) gnatboot3 BOOT_CFLAGS="$(BOOT_CFLAGS)" \ - BOOT_ADAFLAGS="$(BOOT_ADAFLAGS)" \ - LDFLAGS="$(BOOT_LDFLAGS)" - - gnatboot3: - $(MAKE) gnatstage2 - $(MAKE) gnat1$(exeext) gnatbind$(exeext) CC="gcc -B../stage2/"\ - CFLAGS="$(BOOT_CFLAGS)" \ - ADAFLAGS="$(BOOT_ADAFLAGS)"\ - LDFLAGS="$(BOOT_LDFLAGS)" \ - GNATBIND="../stage2/gnatbind" - - gnatstage1: force - -$(MKDIR) stage1 - -$(MKDIR) stage1/ada - -$(MV) gnat1$(exeext) gnatbind$(exeext) stage1 - -$(MV) ada/*$(objext) ada/*.ali stage1/ada - -$(MV) ada/stamp-* stage1/ada - - gnatstage2: force - -$(MKDIR) stage2 - -$(MKDIR) stage2/ada - -$(MV) gnat1$(exeext) gnatbind$(exeext) stage2 - -$(MV) ada/*$(objext) ada/*.ali stage2/ada - -$(MV) ada/stamp-* stage2/ada - - # Compiling object files from source files. - - # Note that dependencies on obstack.h are not written - # because that file is not part of GCC. - # Dependencies on gvarargs.h are not written - # because all that file does, when not compiling with GCC, - # is include the system varargs.h. - - # Ada language specific files. - - ada_extra_files : ada/treeprs.ads ada/einfo.h ada/sinfo.h ada/nmake.adb \ - ada/nmake.ads - - ada/b_gnat1.c : $(GNAT1_ADA_OBJS) - $(GNATBIND) -C $(ADA_INCLUDES) -o ada/b_gnat1.c -n ada/gnat1drv.ali - ada/b_gnat1.o : ada/b_gnat1.c - - ada/b_gnatb.c : $(GNATBIND_OBJS) ada/gnatbind.o ada/interfac.o - $(GNATBIND) -C $(ADA_INCLUDES) -o ada/b_gnatb.c ada/gnatbind.ali - ada/b_gnatb.o : ada/b_gnatb.c - - # We delete the files before copying, below, in case they are read-only. - ada/treeprs.ads : ada/treeprs.adt ada/sinfo.ads ada/xtreeprs.adb - -$(MKDIR) ada/bldtools/treeprs - $(RM) $(addprefix ada/bldtools/treeprs/,$(notdir $^)) - $(CP) $^ ada/bldtools/treeprs - (cd ada/bldtools/treeprs; $(GNATMAKE) -q xtreeprs ; ./xtreeprs ../../treeprs.ads ) - - ada/einfo.h : ada/einfo.ads ada/einfo.adb ada/xeinfo.adb - -$(MKDIR) ada/bldtools/einfo - $(RM) $(addprefix ada/bldtools/einfo/,$(notdir $^)) - $(CP) $^ ada/bldtools/einfo - (cd ada/bldtools/einfo; $(GNATMAKE) -q xeinfo ; ./xeinfo ../../einfo.h ) - - ada/sinfo.h : ada/sinfo.ads ada/xsinfo.adb - -$(MKDIR) ada/bldtools/sinfo - $(RM) $(addprefix ada/bldtools/sinfo/,$(notdir $^)) - $(CP) $^ ada/bldtools/sinfo - (cd ada/bldtools/sinfo; $(GNATMAKE) -q xsinfo ; ./xsinfo ../../sinfo.h ) - - ada/nmake.adb : ada/sinfo.ads ada/nmake.adt ada/xnmake.adb - -$(MKDIR) ada/bldtools/nmake_b - $(RM) $(addprefix ada/bldtools/nmake_b/,$(notdir $^)) - $(CP) $^ ada/bldtools/nmake_b - (cd ada/bldtools/nmake_b; $(GNATMAKE) -q xnmake ; ./xnmake -b ../../nmake.adb ) - - ada/nmake.ads : ada/sinfo.ads ada/nmake.adt ada/xnmake.adb ada/nmake.adb - -$(MKDIR) ada/bldtools/nmake_s - $(RM) $(addprefix ada/bldtools/nmake_s/,$(notdir $^)) - $(CP) $^ ada/bldtools/nmake_s - (cd ada/bldtools/nmake_s; $(GNATMAKE) -q xnmake ; ./xnmake -s ../../nmake.ads ) - - update-sources : ada/treeprs.ads ada/einfo.h ada/sinfo.h ada/nmake.adb \ - ada/nmake.ads - $(RM) $(addprefix $(srcdir)/ada/,$(notdir $^)) - $(CP) $^ $(srcdir)/ada - - ada/sdefault.adb: ada/stamp-sdefault ; @true - ada/stamp-sdefault : $(srcdir)/version.c Makefile - $(ECHO) "pragma Style_Checks (Off);" >tmp-sdefault.adb - $(ECHO) "with Osint; use Osint;" >>tmp-sdefault.adb - $(ECHO) "package body Sdefault is" >>tmp-sdefault.adb - $(ECHO) " S0 : constant String := \"$(prefix)/\";" >>tmp-sdefault.adb - $(ECHO) " S1 : constant String := \"$(ADA_INCLUDE_DIR)/\";" >>tmp-sdefault.adb - $(ECHO) " S2 : constant String := \"$(ADA_RTL_OBJ_DIR)/\";" >>tmp-sdefault.adb - $(ECHO) " S3 : constant String := \"$(target)/\";" >>tmp-sdefault.adb - $(ECHO) " S4 : constant String := \"$(libsubdir)/\";" >>tmp-sdefault.adb - $(ECHO) " function Include_Dir_Default_Name return String_Ptr is" >>tmp-sdefault.adb - $(ECHO) " begin" >>tmp-sdefault.adb - $(ECHO) " return Relocate_Path (S0, S1);" >>tmp-sdefault.adb - $(ECHO) " end Include_Dir_Default_Name;" >>tmp-sdefault.adb - $(ECHO) " function Object_Dir_Default_Name return String_Ptr is" >>tmp-sdefault.adb - $(ECHO) " begin" >>tmp-sdefault.adb - $(ECHO) " return Relocate_Path (S0, S2);" >>tmp-sdefault.adb - $(ECHO) " end Object_Dir_Default_Name;" >>tmp-sdefault.adb - $(ECHO) " function Target_Name return String_Ptr is" >>tmp-sdefault.adb - $(ECHO) " begin" >>tmp-sdefault.adb - $(ECHO) " return new String'(S3);" >>tmp-sdefault.adb - $(ECHO) " end Target_Name;" >>tmp-sdefault.adb - $(ECHO) " function Search_Dir_Prefix return String_Ptr is" >>tmp-sdefault.adb - $(ECHO) " begin" >>tmp-sdefault.adb - $(ECHO) " return Relocate_Path (S0, S4);" >>tmp-sdefault.adb - $(ECHO) " end Search_Dir_Prefix;" >>tmp-sdefault.adb - $(ECHO) "end Sdefault;" >> tmp-sdefault.adb - $(srcdir)/../move-if-change tmp-sdefault.adb ada/sdefault.adb - touch ada/stamp-sdefault - - ada/sdefault.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads ada/namet.ads \ - ada/opt.ads ada/osint.ads ada/output.ads ada/sdefault.ads ada/sdefault.adb \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/system.ads ada/table.adb ada/table.ads ada/tree_io.ads \ - ada/types.ads ada/unchdeal.ads ada/unchconv.ads - - ADA_TREE_H = ada/ada-tree.h ada/ada-tree.def - - # force debugging information on s-tasdeb.o so that it is always - # possible to set conditional breakpoints on tasks. - - ada/s-tasdeb.o : ada/s-tasdeb.adb ada/s-tasdeb.ads - $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ - $< $(OUTPUT_OPTION) - - # force debugging information on s-vaflop.o so that it is always - # possible to call the VAX float debug print routines. - # force at least -O so that the inline assembly works. - - ada/s-vaflop.o : ada/s-vaflop.adb ada/s-vaflop.ads - $(CC) -c -O $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ - $(OUTPUT_OPTION) $< - - # force debugging information on a-except.o so that it is always - # possible to set conditional breakpoints on exceptions. - # use -O1 otherwise gdb isn't able to get a full backtrace on mips targets. - - ada/a-except.o : ada/a-except.adb ada/a-except.ads - $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \ - $(ADA_INCLUDES) $< $(OUTPUT_OPTION) - - # compile s-except.o without optimization and with debug info to let the - # debugger set breakpoints and inspect subprogram parameters on exception - # related events. - - ada/s-except.o : ada/s-except.adb ada/s-except.ads - $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ - $(ADA_INCLUDES) $< $(OUTPUT_OPTION) - - # force debugging information on s-assert.o so that it is always - # possible to set breakpoint on assert failures. - - ada/s-assert.o : ada/s-assert.adb ada/s-assert.ads ada/a-except.ads - $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 \ - $(ADA_INCLUDES) $< $(OUTPUT_OPTION) - - # dependencies for windows specific tool (mdll) - - ada/mdll.o : ada/mdll.adb ada/mdll.ads ada/mdll-fil.ads ada/mdll-utl.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) - - ada/mdll-fil.o : ada/mdll-fil.adb ada/mdll.ads ada/mdll-fil.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) - - ada/mdll-utl.o : ada/mdll-utl.adb ada/mdll.ads ada/mdll-utl.ads ada/sdefault.ads ada/types.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) - - # force debugging information and no optimization on s-memory.o so that it - # is always possible to set breakpoint on __gnat_malloc and __gnat_free - # this is important for gnatmem using GDB. memtrack.o is built from - # memtrack.adb, and used by the post-mortem analysis with gnatmem. - - ada/s-memory.o : ada/s-memory.adb ada/s-memory.ads - $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ - $(ADA_INCLUDES) $< $(OUTPUT_OPTION) - - ada/memtrack.o : ada/memtrack.adb ada/s-memory.ads - $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ - $(ADA_INCLUDES) $< $(OUTPUT_OPTION) - - ada/adadecode.o : ada/adadecode.c $(CONFIG_H) $(SYSTEM_H) ada/adadecode.h - ada/adaint.o : ada/adaint.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h - ada/argv.o : ada/argv.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h - ada/cstreams.o : ada/cstreams.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h - ada/exit.o : ada/exit.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h - ada/final.o : ada/final.c $(CONFIG_H) $(SYSTEM_H) ada/raise.h - ada/link.o : ada/link.c - - - ada/targext.o : ada/targext.c $(SYSTEM_H) coretypes.h $(TM_H) - $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ - $< $(OUTPUT_OPTION) - - ada/cio.o : ada/cio.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h - $(CC) -c $(ALL_CFLAGS) $(ALL_ADA_CFLAGS) \ - $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) - - ada/init.o : ada/init.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h ada/raise.h - $(CC) -c $(ALL_CFLAGS) $(ALL_ADA_CFLAGS) \ - $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) - - ada/initialize.o : ada/initialize.c - $(CC) -c $(ALL_CFLAGS) $(ALL_ADA_CFLAGS) \ - $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) - - ada/raise.o : ada/raise.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h ada/raise.h - $(CC) -c $(ALL_CFLAGS) $(ALL_ADA_CFLAGS) \ - $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) - - # Need to keep the frame pointer in this file to pop the stack properly on - # some targets. - ada/tracebak.o : ada/tracebak.c $(CONFIG_H) $(SYSTEM_H) - $(CC) -c $(ALL_CFLAGS) $(ALL_ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ - -fno-omit-frame-pointer $< $(OUTPUT_OPTION) - - ada/cuintp.o : ada/cuintp.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(TREE_H) ada/ada.h ada/types.h ada/uintp.h ada/atree.h ada/stringt.h \ - ada/elists.h ada/nlists.h ada/fe.h ada/gigi.h - - ada/decl.o : ada/decl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ - $(FLAGS_H) toplev.h convert.h $(TARGET_H) ada/ada.h ada/types.h ada/atree.h \ - ada/nlists.h ada/elists.h ada/uintp.h ada/sinfo.h ada/einfo.h ada/snames.h \ - ada/namet.h ada/stringt.h ada/repinfo.h ada/fe.h $(ADA_TREE_H) ada/gigi.h \ - $(EXPR_H) gt-ada-decl.h - - ada/misc.o : ada/misc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ - $(RTL_H) $(EXPR_H) insn-codes.h insn-flags.h insn-config.h recog.h \ - $(FLAGS_H) $(DIAGNOSTIC_H) output.h except.h $(TM_P_H) langhooks.h debug.h \ - $(LANGHOOKS_DEF_H) libfuncs.h $(OPTABS_H) ada/ada.h ada/types.h \ - ada/atree.h ada/nlists.h ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h \ - ada/stringt.h ada/uintp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h \ - ada/adadecode.h opts.h options.h $(TARGET_H) $(REAL_H) - - ada/targtyps.o : ada/targtyps.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(TREE_H) ada/ada.h ada/types.h ada/atree.h ada/nlists.h ada/elists.h \ - ada/uintp.h ada/sinfo.h ada/einfo.h ada/namet.h ada/snames.h ada/stringt.h \ - ada/urealp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h - - ada/trans.o : ada/trans.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(TREE_H) $(RTL_H) $(EXPR_H) $(FLAGS_H) $(FUNCTION_H) ada/ada.h except.h \ - ada/types.h ada/atree.h ada/nlists.h ada/elists.h ada/uintp.h ada/sinfo.h \ - ada/einfo.h ada/namet.h ada/snames.h ada/stringt.h ada/urealp.h ada/fe.h \ - $(ADA_TREE_H) ada/gigi.h gt-ada-trans.h - - ada/utils.o : ada/utils.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(TREE_H) $(FLAGS_H) $(EXPR_H) convert.h defaults.h ada/ada.h ada/types.h \ - ada/atree.h ada/nlists.h ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h \ - ada/stringt.h ada/uintp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h gt-ada-utils.h \ - gtype-ada.h $(TARGET_H) - - ada/utils2.o : ada/utils2.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(TREE_H) $(FLAGS_H) ada/ada.h ada/types.h ada/atree.h ada/nlists.h \ - ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h ada/snames.h \ - ada/stringt.h ada/uintp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h - - # - # DO NOT PUT SPECIAL RULES BELOW, THIS SECTION IS UPDATED AUTOMATICALLY - # - # GNAT DEPENDENCIES - # regular dependencies - ada/a-charac.o : ada/ada.ads ada/a-charac.ads ada/system.ads - - ada/a-chlat1.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \ - ada/system.ads - - ada/a-clrefi.o : ada/ada.ads ada/a-comlin.ads ada/a-clrefi.ads \ - ada/a-clrefi.adb ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads - - ada/a-comlin.o : ada/ada.ads ada/a-comlin.ads ada/a-comlin.adb \ - ada/a-unccon.ads ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \ - ada/s-stoele.adb - - ada/a-elchha.o : ada/ada.ads ada/a-except.ads ada/a-elchha.ads \ - ada/a-elchha.adb ada/a-unccon.ads ada/system.ads ada/s-parame.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-traent.ads - - ada/a-except.o : ada/ada.ads ada/a-except.ads ada/a-except.adb \ - ada/a-exexda.adb ada/a-exextr.adb ada/a-elchha.ads ada/a-excpol.adb \ - ada/a-exstat.adb ada/a-unccon.ads ada/system.ads ada/s-exctab.ads \ - ada/s-except.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-traent.ads - - ada/a-ioexce.o : ada/ada.ads ada/a-except.ads ada/a-ioexce.ads \ - ada/a-unccon.ads ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads - - ada/ada.o : ada/ada.ads ada/system.ads - - ada/ali-util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/ali.ads ada/ali-util.ads ada/ali-util.adb \ - ada/alloc.ads ada/binderr.ads ada/casing.ads ada/csets.ads \ - ada/debug.ads ada/err_vars.ads ada/gnat.ads ada/g-htable.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ - ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ - ada/scans.ads ada/scng.ads ada/scng.adb ada/sinput.ads ada/sinput.adb \ - ada/sinput-c.ads ada/snames.ads ada/stringt.ads ada/stringt.adb \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ - ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-utf_32.adb ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/widechar.ads - - ada/ali.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/ali.ads ada/ali.adb ada/alloc.ads ada/butil.ads ada/casing.ads \ - ada/debug.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ - ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ - ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ - ada/s-htable.adb ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/widechar.ads - - ada/alloc.o : ada/alloc.ads ada/system.ads - - ada/atree.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/interfac.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/back_end.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/back_end.ads ada/back_end.adb ada/casing.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/fname.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/osint.ads ada/osint-c.ads \ - ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/switch.ads ada/switch-c.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/bcheck.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/ali.ads ada/ali-util.ads ada/ali-util.adb \ - ada/alloc.ads ada/bcheck.ads ada/bcheck.adb ada/binderr.ads \ - ada/butil.ads ada/casing.ads ada/csets.ads ada/debug.ads \ - ada/err_vars.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ - ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ - ada/scans.ads ada/scng.ads ada/scng.adb ada/sinput.ads ada/sinput-c.ads \ - ada/snames.ads ada/stringt.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads - - ada/binde.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/ali.ads ada/alloc.ads ada/binde.ads ada/binde.adb \ - ada/binderr.ads ada/butil.ads ada/casing.ads ada/debug.ads \ - ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ - ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads ada/system.ads \ - ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/widechar.ads - - ada/binderr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/binderr.ads ada/binderr.adb \ - ada/butil.ads ada/debug.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \ - ada/output.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - - ada/bindgen.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/ali.ads ada/alloc.ads ada/binde.ads \ - ada/bindgen.ads ada/bindgen.adb ada/casing.ads ada/debug.ads \ - ada/fname.ads ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \ - ada/osint.ads ada/osint-b.ads ada/output.ads ada/rident.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads - - ada/bindusg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/bindusg.ads ada/bindusg.adb \ - ada/debug.ads ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads \ - ada/output.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - - ada/butil.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/butil.ads ada/butil.adb \ - ada/debug.ads ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ - ada/rident.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads - - ada/casing.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/casing.adb \ - ada/csets.ads ada/csets.adb ada/debug.ads ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/output.ads ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads - - ada/checks.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ - ada/sem.ads ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch6.ads \ - ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads - - ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/comperr.ads ada/comperr.adb ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/fname.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/osint.ads ada/output.ads \ - ada/output.adb ada/sdefault.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/treepr.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/csets.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/csets.ads \ - ada/csets.adb ada/debug.ads ada/hostparm.ads ada/opt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/types.ads ada/unchdeal.ads - - ada/cstand.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/cstand.ads \ - ada/cstand.adb ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ - ada/layout.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads \ - ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads - - ada/debug.o : ada/debug.ads ada/debug.adb ada/system.ads - - ada/debug_a.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/debug_a.ads ada/debug_a.adb \ - ada/einfo.ads ada/elists.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads - - ada/einfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/snames.adb \ - ada/stand.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - - ada/elists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/elists.ads \ - ada/elists.adb ada/hostparm.ads ada/opt.ads ada/output.ads \ - ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads - - ada/err_vars.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/err_vars.ads \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ - ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads - - ada/errout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/errout.adb \ - ada/erroutc.ads ada/fname.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/scans.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/erroutc.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ - ada/err_vars.ads ada/erroutc.ads ada/erroutc.adb ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/output.ads ada/output.adb ada/rident.ads \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads - - ada/eval_fat.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/eval_fat.adb ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads \ - ada/output.ads ada/rident.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/ttypef.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/urealp.adb - - ada/exp_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_aggr.adb ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads \ - ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/expander.ads ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads ada/widechar.ads - - ada/exp_atag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ - ada/exp_atag.adb ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dist.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ - ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads \ - ada/lib-load.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/sem.ads \ - ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads - - ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ - ada/exp_attr.ads ada/exp_attr.adb ada/exp_ch2.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_imgv.ads ada/exp_pakd.ads \ - ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/exp_vfpt.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/validsw.ads ada/widechar.ads - - ada/exp_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/casing.adb ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_ch11.adb \ - ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_ch8.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/exp_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/exp_ch12.ads ada/exp_ch12.adb ada/exp_tss.ads \ - ada/exp_util.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - - ada/exp_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/exp_ch13.ads ada/exp_ch13.adb ada/exp_ch3.ads \ - ada/exp_ch6.ads ada/exp_imgv.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - - ada/exp_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_aggr.ads ada/exp_ch2.ads ada/exp_ch2.adb \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_smem.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/exp_vfpt.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/itypes.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch8.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/validsw.ads - - ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch3.ads ada/exp_ch3.adb ada/exp_ch4.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads ada/exp_dist.ads \ - ada/exp_pakd.ads ada/exp_smem.ads ada/exp_strm.ads ada/exp_tss.ads \ - ada/exp_tss.adb ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ - ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads - - ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch4.adb ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads ada/exp_dist.ads \ - ada/exp_fixd.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/exp_vfpt.ads ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads \ - ada/lib-load.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ - ada/sem.ads ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_dist.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/urealp.adb ada/validsw.ads - - ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch5.ads ada/exp_ch5.adb ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_dbug.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads - - ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch6.adb ada/exp_ch7.ads \ - ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_disp.ads ada/exp_dist.ads \ - ada/exp_intr.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ - ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_ch12.ads \ - ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \ - ada/sem_mech.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads - - ada/exp_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_ch7.adb ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_disp.ads \ - ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_ch3.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads - - ada/exp_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_aggr.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch8.ads \ - ada/exp_ch8.adb ada/exp_dbug.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ - ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/sem.ads ada/sem_ch8.ads ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads - - ada/exp_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_ch11.ads \ - ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads \ - ada/exp_ch9.adb ada/exp_dbug.ads ada/exp_sel.ads ada/exp_smem.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_ch11.ads ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads - - ada/exp_code.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/eval_fat.ads ada/exp_code.ads ada/exp_code.adb \ - ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/widechar.ads - - ada/exp_dbug.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/exp_dbug.ads ada/exp_dbug.adb ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/urealp.adb ada/widechar.ads - - ada/exp_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_disp.ads \ - ada/exp_disp.adb ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads \ - ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/validsw.ads ada/widechar.ads - - ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/exp_atag.ads ada/exp_dist.ads ada/exp_dist.adb \ - ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads \ - ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/exp_fixd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_fixd.ads ada/exp_fixd.adb ada/exp_tss.ads \ - ada/exp_util.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb - - ada/exp_imgv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_dist.ads ada/exp_imgv.ads ada/exp_imgv.adb \ - ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/fname-uf.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ - ada/sem.ads ada/sem_ch7.ads ada/sem_dist.ads ada/sem_res.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - - ada/exp_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads \ - ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_code.ads \ - ada/exp_fixd.ads ada/exp_intr.ads ada/exp_intr.adb ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads ada/widechar.ads - - ada/exp_pakd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads \ - ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_dbug.ads ada/exp_pakd.ads ada/exp_pakd.adb ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/itypes.ads ada/layout.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads - - ada/exp_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/casing.adb ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_ch11.ads ada/exp_prag.ads ada/exp_prag.adb \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/snames.adb \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/exp_sel.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/exp_sel.ads ada/exp_sel.adb ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/exp_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/exp_smem.ads ada/exp_smem.adb ada/exp_tss.ads ada/exp_util.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/sem.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/exp_strm.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/exp_strm.ads ada/exp_strm.adb ada/exp_tss.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/exp_tss.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads \ - ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/rtsfind.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/widechar.ads - - ada/exp_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/fname.ads ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads - - ada/exp_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/exp_vfpt.ads ada/exp_vfpt.adb ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/rtsfind.ads \ - ada/sem_res.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tbuild.ads ada/tree_io.ads ada/ttypef.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/urealp.adb - - ada/expander.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/debug_a.ads ada/debug_a.adb \ - ada/einfo.ads ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_aggr.ads ada/exp_attr.ads ada/exp_ch11.ads \ - ada/exp_ch12.ads ada/exp_ch13.ads ada/exp_ch2.ads ada/exp_ch3.ads \ - ada/exp_ch4.ads ada/exp_ch5.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_ch8.ads ada/exp_ch9.ads ada/exp_prag.ads ada/expander.ads \ - ada/expander.adb ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads \ - ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch8.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads - - ada/fmap.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fmap.ads ada/fmap.adb \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ - ada/opt.ads ada/osint.ads ada/output.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads - - ada/fname-uf.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ - ada/fmap.ads ada/fname.ads ada/fname-uf.ads ada/fname-uf.adb \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/krunch.ads \ - ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads - - ada/fname.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fname.ads \ - ada/fname.adb ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ - ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads - - ada/freeze.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_aggr.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ - ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/expander.ads ada/fname.ads ada/freeze.ads ada/freeze.adb \ - ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/itypes.ads ada/layout.ads \ - ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch4.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_intr.ads \ - ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_res.adb \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads - - ada/frontend.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/cstand.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_dbug.ads \ - ada/fmap.ads ada/fname.ads ada/fname-uf.ads ada/frontend.ads \ - ada/frontend.adb ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb \ - ada/live.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/osint.ads ada/output.ads ada/par.ads \ - ada/prepcomp.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_ch8.ads ada/sem_elab.ads ada/sem_prag.ads ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/sinput-l.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/g-byorma.o : ada/gnat.ads ada/g-byorma.ads ada/g-byorma.adb \ - ada/system.ads - - ada/g-hesora.o : ada/gnat.ads ada/g-hesora.ads ada/g-hesora.adb \ - ada/system.ads - - ada/g-htable.o : ada/gnat.ads ada/g-htable.ads ada/g-htable.adb \ - ada/system.ads ada/s-htable.ads - - ada/g-spchge.o : ada/gnat.ads ada/g-spchge.ads ada/g-spchge.adb \ - ada/system.ads - - ada/g-speche.o : ada/gnat.ads ada/g-speche.ads ada/g-speche.adb \ - ada/g-spchge.ads ada/g-spchge.adb ada/system.ads - - ada/g-u3spch.o : ada/gnat.ads ada/g-spchge.ads ada/g-spchge.adb \ - ada/g-u3spch.ads ada/g-u3spch.adb ada/system.ads ada/s-wchcnv.ads \ - ada/s-wchcon.ads - - ada/get_targ.o : ada/ada.ads ada/a-unccon.ads ada/get_targ.ads \ - ada/get_targ.adb ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \ - ada/s-unstyp.ads ada/types.ads ada/unchdeal.ads - - ada/gnat.o : ada/gnat.ads ada/system.ads - - ada/gnat1drv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/back_end.ads ada/casing.ads ada/comperr.ads ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fmap.ads \ - ada/fname.ads ada/fname-uf.ads ada/frontend.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/gnat1drv.ads \ - ada/gnat1drv.adb ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/osint.ads ada/output.ads \ - ada/prepcomp.ads ada/repinfo.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/sem.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch8.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_type.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/sinput-l.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tree_gen.ads \ - ada/tree_io.ads ada/treepr.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/usage.ads ada/widechar.ads - - ada/gnatbind.o : ada/ada.ads ada/a-comlin.ads ada/a-clrefi.ads \ - ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads ada/ali.ads \ - ada/ali-util.ads ada/alloc.ads ada/bcheck.ads ada/binde.ads \ - ada/binderr.ads ada/bindgen.ads ada/bindusg.ads ada/butil.ads \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/fmap.ads ada/fname.ads \ - ada/gnat.ads ada/g-htable.ads ada/gnatbind.ads ada/gnatbind.adb \ - ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \ - ada/osint.ads ada/osint-b.ads ada/output.ads ada/rident.ads \ - ada/snames.ads ada/switch.ads ada/switch.adb ada/switch-b.ads \ - ada/system.ads ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads - - ada/gnatvsn.o : ada/ada.ads ada/a-unccon.ads ada/gnatvsn.ads \ - ada/gnatvsn.adb ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \ - ada/s-stoele.adb - - ada/hlo.o : ada/ada.ads ada/a-unccon.ads ada/hlo.ads ada/hlo.adb \ - ada/hostparm.ads ada/output.ads ada/system.ads ada/s-exctab.ads \ - ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-unstyp.ads ada/types.ads ada/unchdeal.ads - - ada/hostparm.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \ - ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-unstyp.ads \ - ada/types.ads ada/unchdeal.ads - - ada/impunit.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/impunit.ads ada/impunit.adb \ - ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/inline.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_ch7.ads ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads \ - ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/inline.adb \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/rtsfind.ads ada/sem.ads ada/sem_ch10.ads ada/sem_ch12.ads \ - ada/sem_ch8.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads - - ada/instpar.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/instpar.ads ada/instpar.adb \ - ada/interfac.ads ada/namet.ads ada/opt.ads ada/output.ads \ - ada/sdefault.ads ada/sinput.ads ada/sinput.adb ada/sinput-l.ads \ - ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/widechar.ads - - ada/interfac.o : ada/interfac.ads ada/system.ads - - ada/itypes.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/itypes.ads \ - ada/itypes.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads ada/sem.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads - - ada/krunch.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \ - ada/krunch.ads ada/krunch.adb ada/system.ads ada/s-exctab.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-unstyp.ads \ - ada/types.ads ada/unchdeal.ads - - ada/layout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_ch3.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/layout.ads \ - ada/layout.adb ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/repinfo.ads ada/repinfo.adb ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_ch13.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/lib-load.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib-load.ads \ - ada/lib-load.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/osint.ads ada/osint-c.ads \ - ada/output.ads ada/par.ads ada/restrict.ads ada/rident.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/sinput-l.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/lib-util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/lib.ads ada/lib-util.ads ada/lib-util.adb ada/namet.ads ada/opt.ads \ - ada/osint.ads ada/osint-c.ads ada/output.ads ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - - ada/lib-writ.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/ali.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/lib-util.ads ada/lib-util.adb ada/lib-writ.ads ada/lib-writ.adb \ - ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/osint.ads ada/osint-c.ads \ - ada/output.ads ada/par.ads ada/restrict.ads ada/rident.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ - ada/system.ads ada/s-casuti.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \ - ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/lib-xref.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/gnat.ads ada/g-hesorg.ads ada/g-hesorg.adb \ - ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/lib-util.ads \ - ada/lib-util.adb ada/lib-xref.ads ada/lib-xref.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/osint.ads \ - ada/osint-c.ads ada/output.ads ada/restrict.ads ada/rident.ads \ - ada/sem.ads ada/sem_prag.ads ada/sem_util.ads ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/lib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/fname.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-hesorg.adb ada/g-htable.ads ada/hostparm.ads \ - ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads - - ada/live.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/live.ads ada/live.adb ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/namet-sp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ - ada/g-u3spch.ads ada/hostparm.ads ada/namet.ads ada/namet-sp.ads \ - ada/namet-sp.adb ada/opt.ads ada/output.ads ada/system.ads \ - ada/s-carun8.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcnv.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb \ - ada/unchconv.ads ada/unchdeal.ads - - ada/namet.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \ - ada/system.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/types.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/widechar.ads - - ada/nlists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - - ada/nmake.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/opt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/debug.ads ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads ada/opt.adb \ - ada/system.ads ada/s-exctab.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/tree_io.ads ada/types.ads \ - ada/unchdeal.ads - - ada/osint-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/osint.ads ada/osint-b.ads ada/osint-b.adb \ - ada/output.ads ada/rident.ads ada/system.ads ada/s-exctab.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - - ada/osint-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads \ - ada/osint-c.ads ada/osint-c.adb ada/output.ads ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/widechar.ads - - ada/osint.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fmap.ads ada/gnat.ads \ - ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \ - ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads ada/osint.adb \ - ada/output.ads ada/rident.ads ada/sdefault.ads ada/system.ads \ - ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/widechar.ads - - ada/output.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/hostparm.ads ada/output.ads ada/output.adb ada/system.ads \ - ada/s-exctab.ads ada/s-os_lib.ads ada/s-stalib.ads ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-unstyp.ads ada/types.ads ada/unchdeal.ads - - ada/par.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ - ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/g-speche.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb \ - ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/osint.ads \ - ada/output.ads ada/par.ads ada/par.adb ada/par-ch10.adb \ - ada/par-ch11.adb ada/par-ch12.adb ada/par-ch13.adb ada/par-ch2.adb \ - ada/par-ch3.adb ada/par-ch4.adb ada/par-ch5.adb ada/par-ch6.adb \ - ada/par-ch7.adb ada/par-ch8.adb ada/par-ch9.adb ada/par-endh.adb \ - ada/par-labl.adb ada/par-load.adb ada/par-prag.adb ada/par-sync.adb \ - ada/par-tchk.adb ada/par-util.adb ada/restrict.ads ada/rident.ads \ - ada/scans.ads ada/scans.adb ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ - ada/sinput.adb ada/sinput-l.ads ada/snames.ads ada/snames.adb \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ - ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads - - ada/prep.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \ - ada/debug.ads ada/err_vars.ads ada/gnat.ads ada/g-dyntab.ads \ - ada/g-dyntab.adb ada/g-hesorg.ads ada/g-hesorg.adb ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/prep.ads \ - ada/prep.adb ada/scans.ads ada/sinput.ads ada/snames.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-carun8.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - - ada/prepcomp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \ - ada/debug.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/gnat.ads ada/g-dyntab.ads ada/g-dyntab.adb ada/g-hesorg.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib-writ.ads \ - ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/prep.ads \ - ada/prepcomp.ads ada/prepcomp.adb ada/scans.ads ada/scn.ads \ - ada/scng.ads ada/scng.adb ada/sinput.ads ada/sinput.adb \ - ada/sinput-l.ads ada/snames.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-crc32.adb \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/repinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/opt.ads ada/output.ads ada/output.adb ada/repinfo.ads \ - ada/repinfo.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/restrict.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ - ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/rident.o : ada/rident.ads ada/system.ads ada/s-rident.ads - - ada/rtsfind.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_dist.ads ada/fname.ads ada/fname-uf.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/rtsfind.adb ada/sem.ads ada/sem_ch7.ads ada/sem_dist.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads - - ada/s-addope.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-addope.ads ada/s-addope.adb - - ada/s-assert.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/system.ads ada/s-assert.ads ada/s-assert.adb ada/s-exctab.ads \ - ada/s-exctab.adb ada/s-except.ads ada/s-htable.ads ada/s-parame.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-traent.ads - - ada/s-carun8.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-addope.ads ada/s-addope.adb ada/s-carun8.ads ada/s-carun8.adb \ - ada/s-stoele.ads ada/s-stoele.adb - - ada/s-casuti.o : ada/system.ads ada/s-casuti.ads ada/s-casuti.adb - - ada/s-crc32.o : ada/interfac.ads ada/system.ads ada/s-crc32.ads \ - ada/s-crc32.adb - - ada/s-crtl.o : ada/system.ads ada/s-crtl.ads ada/s-parame.ads - - ada/s-except.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-except.ads ada/s-except.adb ada/s-stalib.ads - - ada/s-exctab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-htable.adb ada/s-parame.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-traent.ads - - ada/s-htable.o : ada/ada.ads ada/a-uncdea.ads ada/system.ads \ - ada/s-htable.ads ada/s-htable.adb - - ada/s-imenne.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-imenne.ads ada/s-imenne.adb ada/s-stoele.ads ada/s-stoele.adb - - ada/s-imgenu.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-imgenu.ads ada/s-imgenu.adb ada/s-secsta.ads ada/s-stoele.ads \ - ada/s-stoele.adb - - ada/s-mastop.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-mastop.ads ada/s-mastop.adb ada/s-stoele.ads ada/s-stoele.adb - - ada/s-memory.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/system.ads ada/s-crtl.ads ada/s-memory.ads ada/s-memory.adb \ - ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads - - ada/s-os_lib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/system.ads ada/s-casuti.ads ada/s-crtl.ads \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-os_lib.ads \ - ada/s-os_lib.adb ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads - - ada/s-parame.o : ada/system.ads ada/s-parame.ads ada/s-parame.adb - - ada/s-purexc.o : ada/system.ads ada/s-purexc.ads - - ada/s-restri.o : ada/system.ads ada/s-restri.ads ada/s-restri.adb \ - ada/s-rident.ads - - ada/s-secsta.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/system.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-secsta.adb ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads - - ada/s-soflin.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/system.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-soflin.adb ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-traent.ads - - ada/s-sopco3.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco3.adb ada/s-sopco4.ads ada/s-sopco5.ads - - ada/s-sopco4.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco4.adb ada/s-sopco5.ads - - ada/s-sopco5.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-sopco5.adb - - ada/s-stache.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-stache.ads ada/s-stache.adb ada/s-stoele.ads ada/s-stoele.adb - - ada/s-stalib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/system.ads ada/s-memory.ads ada/s-parame.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stalib.adb ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-traent.ads - - ada/s-stoele.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-stoele.ads ada/s-stoele.adb - - ada/s-strcom.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-strcom.ads ada/s-strcom.adb - - ada/s-string.o : ada/ada.ads ada/a-uncdea.ads ada/system.ads \ - ada/s-string.ads ada/s-string.adb - - ada/s-strops.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-strops.adb - - ada/s-traceb.o : ada/system.ads ada/s-traceb.ads ada/s-traceb.adb - - ada/s-traent.o : ada/system.ads ada/s-traent.ads ada/s-traent.adb - - ada/s-unstyp.o : ada/system.ads ada/s-unstyp.ads - - ada/s-utf_32.o : ada/system.ads ada/s-utf_32.ads ada/s-utf_32.adb - - ada/s-wchcnv.o : ada/interfac.ads ada/system.ads ada/s-wchcnv.ads \ - ada/s-wchcnv.adb ada/s-wchcon.ads ada/s-wchjis.ads - - ada/s-wchcon.o : ada/system.ads ada/s-wchcon.ads ada/s-wchcon.adb - - ada/s-wchjis.o : ada/system.ads ada/s-wchjis.ads ada/s-wchjis.adb - - ada/scans.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \ - ada/scans.ads ada/scans.adb ada/snames.ads ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/scn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/elists.ads ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/gnat.ads ada/g-byorma.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/scans.ads ada/scn.ads ada/scn.adb \ - ada/scng.ads ada/scng.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-utf_32.adb ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb \ - ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/urealp.adb ada/widechar.ads - - ada/scng.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \ - ada/debug.ads ada/err_vars.ads ada/hostparm.ads ada/interfac.ads \ - ada/namet.ads ada/opt.ads ada/output.ads ada/scans.ads ada/scng.ads \ - ada/scng.adb ada/sinput.ads ada/snames.ads ada/stringt.ads \ - ada/styleg.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/sem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/debug.ads \ - ada/debug_a.ads ada/debug_a.adb ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_tss.ads ada/expander.ads ada/fname.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hlo.ads ada/hostparm.ads \ - ada/inline.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/sem.ads ada/sem.adb \ - ada/sem_attr.ads ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads \ - ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch2.adb ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_prag.ads ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads - - ada/sem_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/fname.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ - ada/sem_aggr.adb ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch13.ads \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads ada/widechar.ads - - ada/sem_attr.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \ - ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads ada/alloc.ads \ - ada/atree.ads ada/atree.adb ada/casing.ads ada/checks.ads \ - ada/checks.adb ada/csets.ads ada/debug.ads ada/debug_a.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads \ - ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads \ - ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sdefault.ads \ - ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_attr.adb \ - ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/snames.adb ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ - ada/s-carun8.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypef.ads ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/urealp.adb ada/validsw.ads ada/widechar.ads - - ada/sem_case.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-hesorg.adb ada/g-htable.ads ada/hostparm.ads \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/sem.ads ada/sem_case.ads \ - ada/sem_case.adb ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/sem_cat.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_tss.ads ada/fname.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/sem.ads \ - ada/sem_cat.ads ada/sem_cat.adb ada/sem_eval.ads ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/sem_ch10.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/impunit.ads \ - ada/inline.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_ch10.ads \ - ada/sem_ch10.adb ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_prag.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/sem_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_code.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/sem.ads ada/sem_ch11.ads ada/sem_ch11.adb ada/sem_ch5.ads \ - ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads \ - ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - - ada/sem_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_dist.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/expander.ads ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/rtsfind.adb ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch10.ads \ - ada/sem_ch12.ads ada/sem_ch12.adb ada/sem_ch13.ads ada/sem_ch3.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ - ada/sinput.ads ada/sinput-l.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-htable.adb \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads - - ada/sem_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/fname.ads ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-hesorg.adb ada/g-htable.ads ada/hostparm.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ - ada/sem.ads ada/sem_ch13.ads ada/sem_ch13.adb ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb - - ada/sem_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/sem_ch2.ads ada/sem_ch2.adb ada/sem_ch8.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/system.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/sem_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch3.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dist.ads ada/exp_pakd.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_case.ads ada/sem_case.adb ada/sem_cat.ads ada/sem_cat.adb \ - ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch3.adb ada/sem_ch6.ads \ - ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_mech.ads \ - ada/sem_res.ads ada/sem_smem.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/urealp.adb ada/validsw.ads ada/widechar.ads - - ada/sem_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/expander.ads ada/fname.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch4.adb ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_intr.ads \ - ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ - ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_code.ads ada/exp_disp.ads ada/exp_pakd.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_case.ads ada/sem_case.adb ada/sem_cat.ads \ - ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch5.adb \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elab.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads \ - ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads ada/widechar.ads - - ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch12.ads \ - ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \ - ada/sem_ch6.adb ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_prag.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ - ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads - - ada/sem_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_dbug.ads ada/exp_disp.ads \ - ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_cat.ads \ - ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch6.ads \ - ada/sem_ch7.ads ada/sem_ch7.adb ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/expander.ads ada/fname.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/impunit.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \ - ada/sem_cat.ads ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_ch8.adb ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_intr.ads \ - ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ - ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads ada/exp_pakd.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch8.ads \ - ada/sem_ch9.ads ada/sem_ch9.adb ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elab.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads - - ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_disp.ads \ - ada/exp_disp.adb ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_disp.adb \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads ada/widechar.ads - - ada/sem_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_dist.ads \ - ada/exp_tss.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_dist.ads \ - ada/sem_dist.adb ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-carun8.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ - ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/sem_elab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_elab.ads ada/sem_elab.adb ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads - - ada/sem_elim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/output.ads ada/sem_elim.ads \ - ada/sem_elim.adb ada/sem_prag.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch4.ads ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/widechar.ads - - ada/sem_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/rident.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_intr.adb \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - - ada/sem_maps.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ - ada/sem_maps.ads ada/sem_maps.adb ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/sem_mech.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads \ - ada/sem.ads ada/sem_mech.ads ada/sem_mech.adb ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/sem_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_intr.ads ada/sem_mech.ads ada/sem_prag.ads \ - ada/sem_prag.adb ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sem_vfpt.ads ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/snames.adb ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ - ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads ada/widechar.ads - - ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ - ada/debug.ads ada/debug_a.ads ada/debug_a.adb ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads \ - ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/urealp.adb ada/validsw.ads ada/widechar.ads - - ada/sem_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/output.ads ada/sem_smem.ads \ - ada/sem_smem.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/sem_type.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_ch12.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_type.adb ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads - - ada/sem_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/casing.adb ada/checks.ads ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads - - ada/sem_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/cstand.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ - ada/rident.ads ada/sem_vfpt.ads ada/sem_vfpt.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/ttypef.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/sem_warn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_code.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_ch6.ads ada/sem_ch8.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ - ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/sinfo-cn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads \ - ada/sinfo-cn.ads ada/sinfo-cn.adb ada/sinput.ads ada/snames.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/sinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/sinput-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ - ada/sinput.ads ada/sinput-c.ads ada/sinput-c.adb ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - - ada/sinput-d.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads \ - ada/osint-c.ads ada/output.ads ada/sinput.ads ada/sinput-d.ads \ - ada/sinput-d.adb ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - - ada/sinput-l.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ - ada/g-dyntab.ads ada/g-dyntab.adb ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/osint.ads ada/output.ads ada/prep.ads \ - ada/prepcomp.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput-l.ads \ - ada/sinput-l.adb ada/snames.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/sinput.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ - ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ - ada/opt.ads ada/output.ads ada/sinput.ads ada/sinput.adb ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads - - ada/snames.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \ - ada/snames.ads ada/snames.adb ada/system.ads ada/s-exctab.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/widechar.ads - - ada/sprint.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/fname.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ - ada/output.adb ada/rtsfind.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/sinput-d.ads ada/snames.ads \ - ada/sprint.ads ada/sprint.adb ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/urealp.adb ada/widechar.ads - - ada/stand.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/output.ads ada/stand.ads ada/stand.adb \ - ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads - - ada/stringt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/output.ads ada/stringt.ads \ - ada/stringt.adb ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/types.adb ada/unchconv.ads \ - ada/unchdeal.ads - - ada/style.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ - ada/scans.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/styleg-c.ads ada/styleg-c.adb ada/stylesw.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/styleg-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/casing.ads \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/err_vars.ads \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads ada/sinfo.ads \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/styleg.ads \ - ada/styleg-c.ads ada/styleg-c.adb ada/stylesw.ads ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads - - ada/styleg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \ - ada/debug.ads ada/err_vars.ads ada/hostparm.ads ada/namet.ads \ - ada/opt.ads ada/output.ads ada/scans.ads ada/sinput.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-exctab.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - - ada/stylesw.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/debug.ads ada/hostparm.ads ada/opt.ads ada/stylesw.ads \ - ada/stylesw.adb ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/types.ads ada/unchdeal.ads - - ada/switch-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \ - ada/switch.ads ada/switch-b.ads ada/switch-b.adb ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads - - ada/switch-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/lib.ads ada/namet.ads ada/opt.ads ada/osint.ads \ - ada/output.ads ada/prepcomp.ads ada/sem_warn.ads ada/stylesw.ads \ - ada/switch.ads ada/switch-c.ads ada/switch-c.adb ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/validsw.ads - - ada/switch.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \ - ada/switch.ads ada/switch.adb ada/system.ads ada/s-exctab.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads - - ada/system.o : ada/system.ads - - ada/table.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/debug.ads \ - ada/hostparm.ads ada/opt.ads ada/output.ads ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-stalib.ads \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - - ada/targparm.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/csets.ads ada/debug.ads \ - ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ - ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads ada/system.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/targparm.adb \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/widechar.ads - - ada/tbuild.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/fname.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/tree_gen.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/casing.ads \ - ada/debug.ads ada/einfo.ads ada/elists.ads ada/fname.ads \ - ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ - ada/osint.ads ada/osint-c.ads ada/output.ads ada/repinfo.ads \ - ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_gen.ads ada/tree_gen.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads - - ada/tree_io.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/debug.ads ada/hostparm.ads ada/output.ads \ - ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/tree_io.ads ada/tree_io.adb \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads - - ada/treepr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/fname.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/output.adb \ - ada/sem_mech.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/treepr.ads \ - ada/treepr.adb ada/treeprs.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads - - ada/treeprs.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/output.ads ada/sinfo.ads ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/treeprs.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - - ada/ttypef.o : ada/system.ads ada/ttypef.ads - - ada/ttypes.o : ada/ada.ads ada/a-unccon.ads ada/get_targ.ads \ - ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \ - ada/ttypes.ads ada/types.ads ada/unchdeal.ads - - ada/types.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/system.ads \ - ada/s-carun8.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ - ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \ - ada/types.ads ada/types.adb ada/unchdeal.ads - - ada/uintp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/opt.ads ada/output.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads - - ada/uname.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/uname.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - - ada/urealp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/opt.ads ada/output.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb - - ada/usage.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ - ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/usage.ads ada/usage.adb - - ada/validsw.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/debug.ads ada/hostparm.ads ada/opt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/types.ads ada/unchdeal.ads ada/validsw.ads \ - ada/validsw.adb - - ada/widechar.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/debug.ads ada/hostparm.ads ada/interfac.ads \ - ada/opt.ads ada/system.ads ada/s-exctab.ads ada/s-parame.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcnv.ads ada/s-wchcnv.adb ada/s-wchcon.ads ada/s-wchjis.ads \ - ada/types.ads ada/unchdeal.ads ada/widechar.ads ada/widechar.adb - - # end of regular dependencies --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/Makefile.in gcc-4.4.0/gcc/ada/Makefile.in *** gcc-4.3.3/gcc/ada/Makefile.in Wed Feb 13 19:04:53 2008 --- gcc-4.4.0/gcc/ada/Makefile.in Fri Feb 27 09:54:25 2009 *************** *** 1,2243 **** ! # Makefile for GNU Ada Compiler (GNAT). ! # Copyright (C) 1994-2008 Free Software Foundation, Inc. ! ! #This file is part of GCC. ! ! #GCC is free software; you can redistribute it and/or modify ! #it under the terms of the GNU General Public License as published by ! #the Free Software Foundation; either version 3, or (at your option) ! #any later version. ! ! #GCC is distributed in the hope that it will be useful, ! #but WITHOUT ANY WARRANTY; without even the implied warranty of ! #MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! #GNU General Public License for more details. ! ! #You should have received a copy of the GNU General Public License ! #along with GCC; see the file COPYING3. If not see ! #. ! ! # The makefile built from this file lives in the language subdirectory. ! # Its purpose is to provide support for: ! # ! # 1) recursion where necessary, and only then (building .o's), and ! # 2) building and debugging cc1 from the language subdirectory, and ! # 3) nothing else. ! # ! # The parent makefile handles all other chores, with help from the ! # language makefile fragment, of course. ! # ! # The targets for external use are: ! # all, TAGS, ???mostlyclean, ???clean. ! ! # This makefile will only work with Gnu make. ! # The rules are written assuming a minimum subset of tools are available: ! # ! # Required: ! # MAKE: Only Gnu make will work. ! # MV: Must accept (at least) one, maybe wildcard, source argument, ! # a file or directory destination, and support creation/ ! # modification date preservation. Gnu mv -f works. ! # RM: Must accept an arbitrary number of space separated file ! # arguments, or one wildcard argument. Gnu rm works. ! # RMDIR: Must delete a directory and all its contents. Gnu rm -rf works. ! # ECHO: Must support command line redirection. Any Unix-like ! # shell will typically provide this, otherwise a custom version ! # is trivial to write. ! # AR: Gnu ar works. ! # MKDIR: Gnu mkdir works. ! # CHMOD: Gnu chmod works. ! # true: Does nothing and returns a normal successful return code. ! # pwd: Prints the current directory on stdout. ! # cd: Change directory. ! # ! # Optional: ! # BISON: Gnu bison works. ! # FLEX: Gnu flex works. ! # Other miscellaneous tools for obscure targets. ! ! # Tell GNU make 3.79 not to run this directory in parallel. ! # Not all of the required dependencies are present. ! .NOTPARALLEL: ! ! # Suppress smart makes who think they know how to automake Yacc files ! .y.c: ! ! # Variables that exist for you to override. ! # See below for how to change them for certain systems. ! ! # Various ways of specifying flags for compilations: ! # CFLAGS is for the user to override to, e.g., do a bootstrap with -O2. ! # BOOT_CFLAGS is the value of CFLAGS to pass ! # to the stage2 and stage3 compilations ! # XCFLAGS is used for most compilations but not when using the GCC just built. ! XCFLAGS = ! CFLAGS = -g ! BOOT_CFLAGS = -O $(CFLAGS) ! # These exists to be overridden by the x-* and t-* files, respectively. ! X_CFLAGS = ! T_CFLAGS = ! ! X_CPPFLAGS = ! T_CPPFLAGS = ! ! X_ADA_CFLAGS = ! T_ADA_CFLAGS = ! ! X_ADAFLAGS = ! T_ADAFLAGS = ! ! CC = cc ! BISON = bison ! BISONFLAGS = ! ECHO = echo ! LEX = flex ! LEXFLAGS = ! CHMOD = chmod ! LN = ln ! LN_S = ln -s ! CP = cp -p ! MV = mv -f ! RM = rm -f ! RMDIR = rm -rf ! MKDIR = mkdir -p ! AR = ar ! AR_FLAGS = rc ! LS = ls ! RANLIB = @RANLIB@ ! RANLIB_FLAGS = @ranlib_flags@ ! ! SHELL = @SHELL@ ! PWD_COMMAND = $${PWDCMD-pwd} ! # How to copy preserving the date ! INSTALL_DATA_DATE = cp -p ! MAKEINFO = makeinfo ! TEXI2DVI = texi2dvi ! TEXI2PDF = texi2pdf ! GNATBIND_FLAGS = -static -x ! ADA_CFLAGS = ! ADAFLAGS = -W -Wall -gnatpg -gnata ! SOME_ADAFLAGS =-gnata ! FORCE_DEBUG_ADAFLAGS = -g ! GNATLIBFLAGS = -gnatpg -nostdinc ! GNATLIBCFLAGS = -g -O2 ! GNATLIBCFLAGS_FOR_C = $(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS) -fexceptions \ ! -DIN_RTS ! ALL_ADA_CFLAGS = $(X_ADA_CFLAGS) $(T_ADA_CFLAGS) $(ADA_CFLAGS) ! ALL_ADAFLAGS = $(CFLAGS) $(ALL_ADA_CFLAGS) $(X_ADAFLAGS) $(T_ADAFLAGS) \ ! $(ADAFLAGS) ! MOST_ADAFLAGS = $(CFLAGS) $(ALL_ADA_CFLAGS) $(X_ADAFLAGS) $(T_ADAFLAGS) \ ! $(SOME_ADAFLAGS) ! THREAD_KIND = native ! THREADSLIB = ! GMEM_LIB = ! MISCLIB = ! SYMDEPS = $(LIBINTL_DEP) ! OUTPUT_OPTION = @OUTPUT_OPTION@ ! ! objext = .o ! exeext = ! arext = .a ! soext = .so ! shext = ! hyphen = - ! ! # Define this as & to perform parallel make on a Sequent. ! # Note that this has some bugs, and it seems currently necessary ! # to compile all the gen* files first by hand to avoid erroneous results. ! P = ! ! # This is used instead of ALL_CFLAGS when compiling with GCC_FOR_TARGET. ! # It omits XCFLAGS, and specifies -B./. ! # It also specifies -B$(tooldir)/ to find as and ld for a cross compiler. ! GCC_CFLAGS = $(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(CFLAGS) ! ! # Tools to use when building a cross-compiler. ! # These are used because `configure' appends `cross-make' ! # to the makefile when making a cross-compiler. ! ! # We don't use cross-make. Instead we use the tools from the build tree, ! # if they are available. ! # program_transform_name and objdir are set by configure.in. ! program_transform_name = ! objdir = . ! ! target_alias=@target_alias@ ! target=@target@ ! xmake_file = @xmake_file@ ! tmake_file = @tmake_file@ ! host_canonical=@host@ ! #version=`sed -e 's/.*\"\([^ \"]*\)[ \"].*/\1/' < $(srcdir)/version.c` ! #mainversion=`sed -e 's/.*\"\([0-9]*\.[0-9]*\).*/\1/' < $(srcdir)/version.c` ! ! # Directory where sources are, from where we are. ! srcdir = @srcdir@ ! VPATH = $(srcdir) ! ! fsrcdir := $(shell cd $(srcdir);${PWD_COMMAND}) ! fsrcpfx := $(shell cd $(srcdir);${PWD_COMMAND})/ ! fcurdir := $(shell ${PWD_COMMAND}) ! fcurpfx := $(shell ${PWD_COMMAND})/ ! ! # Top build directory, relative to here. ! top_builddir = ../.. ! ! # Internationalization library. ! LIBINTL = @LIBINTL@ ! LIBINTL_DEP = @LIBINTL_DEP@ ! ! # Any system libraries needed just for GNAT. ! SYSLIBS = @GNAT_LIBEXC@ ! ! # List of extra object files linked in with various programs. ! EXTRA_GNATTOOLS_OBJS = ../../prefix.o ../../version.o ! ! # List of target dependent sources, overridden below as necessary ! TARGET_ADA_SRCS = ! ! # Type of tools build we are doing; default is not compiling tools. ! TOOLSCASE = ! ! # End of variables for you to override. ! ! all: all.indirect ! ! # This tells GNU Make version 3 not to put all variables in the environment. ! .NOEXPORT: ! ! # tmake_file and xmake_file expand to lists with entries of the form ! # $(srcdir)/config/... but here $(srcdir) is the ada subdirectory so we ! # need to adjust the paths. There can't be spaces in the subst arguments ! # or we get spurious spaces in the actual list of files to include. ! ! # target overrides ! ifneq ($(tmake_file),) ! include $(subst /config,/../config,$(tmake_file)) ! endif ! ! # host overrides ! ifneq ($(xmake_file),) ! include $(subst /config,/../config,$(xmake_file)) ! endif ! ! # Now figure out from those variables how to compile and link. ! ! all.indirect: Makefile ../gnat1$(exeext) ! ! # IN_GCC distinguishes between code compiled into GCC itself and other ! # programs built during a bootstrap. ! # autoconf inserts -DCROSS_DIRECTORY_STRUCTURE if we are building a cross ! # compiler which does not use the native libraries and headers. ! INTERNAL_CFLAGS = @CROSS@ -DIN_GCC ! ! # This is the variable actually used when we compile. ! LOOSE_CFLAGS = `echo $(CFLAGS) $(WARN2_CFLAGS)|sed -e 's/-pedantic//g' -e 's/-Wtraditional//g'` ! ALL_CFLAGS = $(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(LOOSE_CFLAGS) \ ! $(XCFLAGS) ! ! # Likewise. ! ALL_CPPFLAGS = $(CPPFLAGS) $(X_CPPFLAGS) $(T_CPPFLAGS) ! ! # This is where we get libiberty.a from. ! LIBIBERTY = ../../libiberty/libiberty.a ! ! # How to link with both our special library facilities ! # and the system's installed libraries. ! LIBS = $(LIBINTL) $(LIBIBERTY) $(SYSLIBS) ! LIBDEPS = $(LIBINTL_DEP) $(LIBIBERTY) ! # Default is no TGT_LIB; one might be passed down or something ! TGT_LIB = ! TOOLS_LIBS = $(EXTRA_GNATTOOLS_OBJS) targext.o link.o $(LIBGNAT) ../../../libiberty/libiberty.a $(SYSLIBS) $(TGT_LIB) ! ! # Specify the directories to be searched for header files. ! # Both . and srcdir are used, in that order, ! # so that tm.h and config.h will be found in the compilation ! # subdirectory rather than in the source directory. ! INCLUDES = -I- -I. -I.. -I$(srcdir) -I$(srcdir)/.. -I$(srcdir)/../config \ ! -I$(srcdir)/../../include ! ! ADA_INCLUDES = -I- -I. -I$(srcdir) ! ! INCLUDES_FOR_SUBDIR = -I. -I.. -I../.. -I$(fsrcdir) -I$(fsrcdir)/../config \ ! -I$(fsrcdir)/../../include -I$(fsrcdir)/.. ! ADA_INCLUDES_FOR_SUBDIR = -I. -I$(fsrcdir) ! ! # Avoid a lot of time thinking about remaking Makefile.in and *.def. ! .SUFFIXES: .in .def ! ! # Say how to compile Ada programs. ! .SUFFIXES: .ada .adb .ads .asm ! ! # Always use -I$(srcdir)/config when compiling. ! .asm.o: ! $(CC) -c -x assembler $< $(OUTPUT_OPTION) ! ! .c.o: ! $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $< \ ! $(OUTPUT_OPTION) ! ! .adb.o: ! $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) ! ! .ads.o: ! $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) ! ! # how to regenerate this file ! Makefile: ../config.status $(srcdir)/Makefile.in $(srcdir)/../version.c ! cd ..; \ ! LANGUAGES="$(CONFIG_LANGUAGES)" \ ! CONFIG_HEADERS= \ ! CONFIG_FILES=ada/Makefile $(SHELL) config.status ! ! # This tells GNU make version 3 not to export all the variables ! # defined in this file into the environment. ! .NOEXPORT: ! ! # Lists of files for various purposes. ! ! GNATLINK_OBJS = gnatlink.o \ ! a-except.o ali.o alloc.o butil.o casing.o csets.o debug.o fmap.o fname.o \ ! gnatvsn.o hostparm.o indepsw.o interfac.o i-c.o i-cstrin.o namet.o opt.o \ ! osint.o output.o rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \ ! sdefault.o snames.o stylesw.o switch.o system.o table.o targparm.o tree_io.o \ ! types.o validsw.o widechar.o ! ! GNATMAKE_OBJS = a-except.o ali.o ali-util.o s-casuti.o \ ! alloc.o atree.o binderr.o butil.o casing.o csets.o debug.o elists.o einfo.o\ ! erroutc.o errutil.o err_vars.o fmap.o fname.o fname-uf.o fname-sf.o \ ! gnatmake.o gnatvsn.o hostparm.o interfac.o i-c.o i-cstrin.o krunch.o lib.o \ ! make.o makeusg.o makeutl.o mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o \ ! mlib-tgt-specific.o mlib-utl.o namet.o nlists.o opt.o osint.o osint-m.o output.o \ ! prj.o prj-attr.o prj-attr-pm.o prj-com.o prj-dect.o prj-env.o prj-err.o prj-ext.o prj-nmsc.o \ ! prj-pars.o prj-part.o prj-proc.o prj-strt.o prj-tree.o prj-util.o \ ! rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \ ! scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o \ ! sinfo.o sinput.o sinput-c.o sinput-p.o \ ! snames.o stand.o stringt.o styleg.o stylesw.o system.o validsw.o switch.o switch-m.o \ ! table.o targparm.o tempdir.o tree_io.o types.o \ ! uintp.o uname.o urealp.o usage.o widechar.o \ ! $(EXTRA_GNATMAKE_OBJS) ! ! # Convert the target variable into a space separated list of architecture, ! # manufacturer, and operating system and assign each of those to its own ! # variable. ! ! host:=$(subst -, ,$(host_canonical)) ! targ:=$(subst -, ,$(target)) ! arch:=$(word 1,$(targ)) ! ifeq ($(words $(targ)),2) ! manu:= ! osys:=$(word 2,$(targ)) ! else ! manu:=$(word 2,$(targ)) ! osys:=$(word 3,$(targ)) ! endif ! ! # LIBGNAT_TARGET_PAIRS is a list of pairs of filenames. ! # The members of each pair must be separated by a '<' and no whitespace. ! # Each pair must be separated by some amount of whitespace from the following ! # pair. ! ! # Non-tasking case: ! ! LIBGNAT_TARGET_PAIRS = \ ! a-intnam.ads SYMVEC_$$$$.opt && \ ! objdump --syms $(LIBGNAT_OBJS) $(GNATRTL_NONTASKING_OBJS) | \ ! $(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \ ! echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \ ! ../../xgcc -g -B../../ -shared -shared-libgcc \ ! -o libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) libgnat.a \ ! sys\$$library:trace.exe \ ! --for-linker=/noinform \ ! --for-linker=SYMVEC_$$$$.opt \ ! --for-linker=gsmatch=equal,$(GSMATCH_VERSION) ! cd rts && echo "case_sensitive=yes" > SYMVEC_$$$$.opt && \ ! objdump --syms $(GNATRTL_TASKING_OBJS) | \ ! $(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \ ! echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \ ! ../../xgcc -g -B../../ -shared -shared-libgcc \ ! -o libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \ ! libgnarl.a libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \ ! sys\$$library:trace.exe \ ! --for-linker=/noinform \ ! --for-linker=SYMVEC_$$$$.opt \ ! --for-linker=gsmatch=equal,$(GSMATCH_VERSION) ! ! gnatlib-shared: ! $(MAKE) $(FLAGS_TO_PASS) \ ! GNATLIBFLAGS="$(GNATLIBFLAGS)" \ ! GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ ! THREAD_KIND="$(THREAD_KIND)" \ ! TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \ ! $(GNATLIB_SHARED) ! ! gnatlib-sjlj: ! $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="" ../stamp-gnatlib1 ! sed -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := False;/' rts/system.ads > rts/s.ads ! $(MV) rts/s.ads rts/system.ads ! $(MAKE) $(FLAGS_TO_PASS) \ ! EH_MECHANISM="" \ ! GNATLIBFLAGS="$(GNATLIBFLAGS)" \ ! GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ ! THREAD_KIND="$(THREAD_KIND)" \ ! TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib ! ! gnatlib-zcx: ! $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="-gcc" ../stamp-gnatlib1 ! sed -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := True;/' rts/system.ads > rts/s.ads ! $(MV) rts/s.ads rts/system.ads ! $(MAKE) $(FLAGS_TO_PASS) \ ! EH_MECHANISM="-gcc" \ ! GNATLIBFLAGS="$(GNATLIBFLAGS)" \ ! GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ ! THREAD_KIND="$(THREAD_KIND)" \ ! TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib ! ! # .s files for cross-building ! gnat-cross: force ! make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp" ! ! # Compiling object files from source files. ! ! # Note that dependencies on obstack.h are not written ! # because that file is not part of GCC. ! # Dependencies on gvarargs.h are not written ! # because all that file does, when not compiling with GCC, ! # is include the system varargs.h. ! ! b_gnatl.c : $(GNATLINK_OBJS) ! $(GNATBIND) -C $(ADA_INCLUDES) -o b_gnatl.c gnatlink.ali ! b_gnatl.o : b_gnatl.c ! ! b_gnatm.c : $(GNATMAKE_OBJS) ! $(GNATBIND) -C $(ADA_INCLUDES) -o b_gnatm.c gnatmake.ali ! b_gnatm.o : b_gnatm.c ! ! ADA_INCLUDE_DIR = $(libsubdir)/adainclude ! ADA_RTL_OBJ_DIR = $(libsubdir)/adalib ! ! # force no sibling call optimization on s-traceb.o so the number of stack ! # frames to be skipped when computing a call chain is not modified by ! # optimization. However we can do that only when building the runtime ! # (not the compiler) because the -fno-optimize-sibling-calls option exists ! # only in GCC 3 and above. ! ! ifneq (,$(findstring xgcc,$(CC))) ! NO_SIBLING_ADAFLAGS=-fno-optimize-sibling-calls ! else ! NO_SIBLING_ADAFLAGS= ! endif ! ! s-traceb.o : s-traceb.adb ! $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) \ ! $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) \ ! $< $(OUTPUT_OPTION) ! ! # force debugging information on s-tasdeb.o so that it is always ! # possible to set conditional breakpoints on tasks. ! ! s-tasdeb.o : s-tasdeb.adb s-tasdeb.ads ! $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ ! $< $(OUTPUT_OPTION) ! ! # force no function reordering on a-except.o because of the exclusion bounds ! # mechanism (see the source file for more detailed information). However we ! # can do that only when building the runtime (not the compiler) because the ! # -fno-toplevel-reorder option exists only in GCC 4.2 and above. ! ! ifneq (,$(findstring xgcc,$(CC))) ! NO_REORDER_ADAFLAGS=-fno-toplevel-reorder ! else ! NO_REORDER_ADAFLAGS= ! endif ! ! # force debugging information on a-except.o so that it is always ! # possible to set conditional breakpoints on exceptions. ! # use -O1 otherwise gdb isn't able to get a full backtrace on mips targets. ! ! a-except.o : a-except.adb a-except.ads ! $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \ ! $(NO_REORDER_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) ! ! # compile s-except.o without optimization and with debug info to let the ! # debugger set breakpoints and inspect subprogram parameters on exception ! # related events. ! ! s-except.o : s-except.adb s-except.ads ! $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ ! $< $(OUTPUT_OPTION) ! ! # force debugging information on s-assert.o so that it is always ! # possible to set breakpoint on assert failures. ! ! s-assert.o : s-assert.adb s-assert.ads a-except.ads ! $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 $(ADA_INCLUDES) \ ! $< $(OUTPUT_OPTION) ! ! adadecode.o : adadecode.c adadecode.h ! aux-io.o : aux-io.c ! argv.o : argv.c ! cal.o : cal.c ! deftarg.o : deftarg.c ! errno.o : errno.c ! exit.o : adaint.h exit.c ! expect.o : expect.c ! final.o : final.c ! gmem.o : gmem.c ! link.o : link.c ! mkdir.o : mkdir.c ! socket.o : socket.c gsocket.h ! sysdep.o : sysdep.c ! raise-gcc.o : raise-gcc.c raise.h ! raise.o : raise.c raise.h ! vx_stack_info.o : vx_stack_info.c ! ! gen-soccon: gen-soccon.c gsocket.h ! $(CC) $(ALL_CFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ ! -UIN_GCC -DTARGET=\"$(target_alias)\" \ ! $< $(OUTPUT_OPTION) ! ! cio.o : cio.c ! $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ ! $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) ! ! init.o : init.c adaint.h raise.h ! $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ ! $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) ! ! initialize.o : initialize.c raise.h ! $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ ! $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) ! ! targext.o : targext.c ! $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ ! $(ALL_CPPFLAGS) $(INCLUDES_FOR_SUBDIR) \ ! $< $(OUTPUT_OPTION) ! ! # No optimization to compile this file as optimizations (-O1 or above) breaks ! # the SEH handling on Windows. The reasons are not clear. ! seh_init.o : seh_init.c raise.h ! $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) -O0 \ ! $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) ! ! # Need to keep the frame pointer in this file to pop the stack properly on ! # some targets. ! tracebak.o : tracebak.c tb-alvms.c tb-alvxw.c tb-gcc.c ! $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ ! -fno-omit-frame-pointer $< $(OUTPUT_OPTION) ! ! # In GNU Make, ignore whether `stage*' exists. ! .PHONY: stage1 stage2 stage3 stage4 clean realclean TAGS bootstrap ! .PHONY: risky-stage1 risky-stage2 risky-stage3 risky-stage4 ! ! force: ! ! # Gnatlbr, Vms_help, and Gnat.hlp are only used on VMS ! ! ../../gnatlbr$(exeext): ../../prefix.o ! $(GNATMAKE) -c $(ADA_INCLUDES) gnatlbr --GCC="$(CC) $(ALL_ADAFLAGS)" ! $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatlbr ! $(GNATLINK) -v gnatlbr -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) ! ! ../../vms_help$(exeext): ! $(GNATMAKE) -c $(ADA_INCLUDES) vms_help --GCC="$(CC) $(ALL_ADAFLAGS)" ! $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) vms_help ! $(GNATLINK) -v vms_help -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) ! ! ../../gnat.hlp: ../../vms_help$(exeext) ! ../../vms_help$(exeext) $(fsrcdir)/gnat.help_in \ ! $(fsrcdir)/vms_data.ads ../../gnat.hlp --- 1,5 ---- ! # All makefile fragments assume that $(srcdir) points to the gcc ! # directory, not the language subdir ! srcdir = @top_srcdir@ ! -include ./gcc-interface/Makefile ! -include ../gcc-interface/Makefile diff -Nrcpad gcc-4.3.3/gcc/ada/Makefile.rtl gcc-4.4.0/gcc/ada/Makefile.rtl *** gcc-4.3.3/gcc/ada/Makefile.rtl Thu Dec 13 10:44:45 2007 --- gcc-4.4.0/gcc/ada/Makefile.rtl Fri Feb 20 15:20:38 2009 *************** *** 1,5 **** # Makefile.rtl for GNU Ada Compiler (GNAT). ! # Copyright (C) 2003-2007, Free Software Foundation, Inc. #This file is part of GCC. --- 1,5 ---- # Makefile.rtl for GNU Ada Compiler (GNAT). ! # Copyright (C) 2003-2008, Free Software Foundation, Inc. #This file is part of GCC. *************** GNATRTL_TASKING_OBJS= \ *** 46,51 **** --- 46,52 ---- s-inmaop$(objext) \ s-interr$(objext) \ s-intman$(objext) \ + s-oscons$(objext) \ s-osinte$(objext) \ s-proinf$(objext) \ s-solita$(objext) \ *************** GNATRTL_NONTASKING_OBJS= \ *** 79,84 **** --- 80,86 ---- a-calari$(objext) \ a-caldel$(objext) \ a-calend$(objext) \ + a-calcon$(objext) \ a-calfor$(objext) \ a-catizo$(objext) \ a-cdlili$(objext) \ *************** GNATRTL_NONTASKING_OBJS= \ *** 360,371 **** g-rannum$(objext) \ g-regexp$(objext) \ g-regpat$(objext) \ g-sestin$(objext) \ g-sha1$(objext) \ - g-soccon$(objext) \ - g-socket$(objext) \ - g-socthi$(objext) \ - g-soliop$(objext) \ g-souinf$(objext) \ g-speche$(objext) \ g-spchge$(objext) \ --- 362,370 ---- g-rannum$(objext) \ g-regexp$(objext) \ g-regpat$(objext) \ + g-sercom$(objext) \ g-sestin$(objext) \ g-sha1$(objext) \ g-souinf$(objext) \ g-speche$(objext) \ g-spchge$(objext) \ *************** GNATRTL_NONTASKING_OBJS= \ *** 376,384 **** g-sptavs$(objext) \ g-string$(objext) \ g-strspl$(objext) \ - g-sttsne$(objext) \ g-table$(objext) \ g-tasloc$(objext) \ g-traceb$(objext) \ g-utf_32$(objext) \ g-u3spch$(objext) \ --- 375,383 ---- g-sptavs$(objext) \ g-string$(objext) \ g-strspl$(objext) \ g-table$(objext) \ g-tasloc$(objext) \ + g-timsta$(objext) \ g-traceb$(objext) \ g-utf_32$(objext) \ g-u3spch$(objext) \ *************** GNATRTL_NONTASKING_OBJS= \ *** 557,562 **** --- 556,562 ---- s-stopoo$(objext) \ s-stratt$(objext) \ s-strops$(objext) \ + s-ststop$(objext) \ s-soflin$(objext) \ s-memory$(objext) \ s-memcop$(objext) \ *************** GNATRTL_NONTASKING_OBJS= \ *** 603,606 **** --- 603,607 ---- text_io$(objext) \ unchconv$(objext) \ unchdeal$(objext) \ + $(GNATRTL_SOCKETS_OBJS) \ $(EXTRA_GNATRTL_NONTASKING_OBJS) diff -Nrcpad gcc-4.3.3/gcc/ada/a-assert.adb gcc-4.4.0/gcc/ada/a-assert.adb *** gcc-4.3.3/gcc/ada/a-assert.adb Tue Aug 14 08:48:27 2007 --- gcc-4.4.0/gcc/ada/a-assert.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-assert.ads gcc-4.4.0/gcc/ada/a-assert.ads *** gcc-4.3.3/gcc/ada/a-assert.ads Tue Aug 14 08:48:27 2007 --- gcc-4.4.0/gcc/ada/a-assert.ads Tue Apr 8 06:57:39 2008 *************** package Ada.Assertions is *** 25,30 **** --- 25,33 ---- pragma Pure (Assertions); Assertion_Error : exception renames System.Assertions.Assert_Failure; + -- This is the renaming that is allowed by 11.4.2(24). Note that the + -- Exception_Name will refer to the one in System.Assertions (see + -- AARM-11.4.1(12.b)). procedure Assert (Check : Boolean); diff -Nrcpad gcc-4.3.3/gcc/ada/a-astaco.adb gcc-4.4.0/gcc/ada/a-astaco.adb *** gcc-4.3.3/gcc/ada/a-astaco.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-astaco.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-calari.adb gcc-4.4.0/gcc/ada/a-calari.adb *** gcc-4.3.3/gcc/ada/a-calari.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-calari.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-calari.ads gcc-4.4.0/gcc/ada/a-calari.ads *** gcc-4.3.3/gcc/ada/a-calari.ads Fri Apr 6 09:15:21 2007 --- gcc-4.4.0/gcc/ada/a-calari.ads Fri Feb 20 15:20:38 2009 *************** *** 6,37 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. The copyright notice above, and the license provisions that follow -- ! -- apply solely to the contents of the part following the private keyword. -- ! -- -- ! -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- ! -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- ! -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- ! -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 6,17 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. In accordance with the copyright of that document, you can freely -- ! -- copy and modify this specification, provided that if you redistribute a -- ! -- modified version, any changes that you have made are clearly indicated. -- -- -- ------------------------------------------------------------------------------ *************** package Ada.Calendar.Arithmetic is *** 50,59 **** .. +(366 * (1 + Year_Number'Last - Year_Number'First)); - -- Negative leap seconds occur whenever the astronomical time is faster - -- than the atomic time or as a result of Difference when Left < Right. - subtype Leap_Seconds_Count is Integer range -2047 .. 2047; procedure Difference (Left : Time; --- 30,39 ---- .. +(366 * (1 + Year_Number'Last - Year_Number'First)); subtype Leap_Seconds_Count is Integer range -2047 .. 2047; + -- Count of leap seconds. Negative leap seconds occur whenever the + -- astronomical time is faster than the atomic time or as a result of + -- Difference when Left < Right. procedure Difference (Left : Time; diff -Nrcpad gcc-4.3.3/gcc/ada/a-calcon.adb gcc-4.4.0/gcc/ada/a-calcon.adb *** gcc-4.3.3/gcc/ada/a-calcon.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/a-calcon.adb Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,148 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- A D A . C A L E N D A R . C O N V E R S I O N S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2008-2009 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + with Interfaces.C; use Interfaces.C; + + package body Ada.Calendar.Conversions is + + ----------------- + -- To_Ada_Time -- + ----------------- + + function To_Ada_Time (Unix_Time : long) return Time is + Val : constant Long_Integer := Long_Integer (Unix_Time); + begin + return Conversion_Operations.To_Ada_Time (Val); + end To_Ada_Time; + + ----------------- + -- To_Ada_Time -- + ----------------- + + function To_Ada_Time + (tm_year : int; + tm_mon : int; + tm_day : int; + tm_hour : int; + tm_min : int; + tm_sec : int; + tm_isdst : int) return Time + is + Year : constant Integer := Integer (tm_year); + Month : constant Integer := Integer (tm_mon); + Day : constant Integer := Integer (tm_day); + Hour : constant Integer := Integer (tm_hour); + Minute : constant Integer := Integer (tm_min); + Second : constant Integer := Integer (tm_sec); + DST : constant Integer := Integer (tm_isdst); + begin + return + Conversion_Operations.To_Ada_Time + (Year, Month, Day, Hour, Minute, Second, DST); + end To_Ada_Time; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration + (tv_sec : long; + tv_nsec : long) return Duration + is + Secs : constant Long_Integer := Long_Integer (tv_sec); + Nano_Secs : constant Long_Integer := Long_Integer (tv_nsec); + begin + return Conversion_Operations.To_Duration (Secs, Nano_Secs); + end To_Duration; + + ------------------------ + -- To_Struct_Timespec -- + ------------------------ + + procedure To_Struct_Timespec + (D : Duration; + tv_sec : out long; + tv_nsec : out long) + is + Secs : Long_Integer; + Nano_Secs : Long_Integer; + + begin + Conversion_Operations.To_Struct_Timespec (D, Secs, Nano_Secs); + + tv_sec := long (Secs); + tv_nsec := long (Nano_Secs); + end To_Struct_Timespec; + + ------------------ + -- To_Struct_Tm -- + ------------------ + + procedure To_Struct_Tm + (T : Time; + tm_year : out int; + tm_mon : out int; + tm_day : out int; + tm_hour : out int; + tm_min : out int; + tm_sec : out int) + is + Year : Integer; + Month : Integer; + Day : Integer; + Hour : Integer; + Minute : Integer; + Second : Integer; + + begin + Conversion_Operations.To_Struct_Tm + (T, Year, Month, Day, Hour, Minute, Second); + + tm_year := int (Year); + tm_mon := int (Month); + tm_day := int (Day); + tm_hour := int (Hour); + tm_min := int (Minute); + tm_sec := int (Second); + end To_Struct_Tm; + + ------------------ + -- To_Unix_Time -- + ------------------ + + function To_Unix_Time (Ada_Time : Time) return long is + Val : constant Long_Integer := + Conversion_Operations.To_Unix_Time (Ada_Time); + begin + return long (Val); + end To_Unix_Time; + + end Ada.Calendar.Conversions; diff -Nrcpad gcc-4.3.3/gcc/ada/a-calcon.ads gcc-4.4.0/gcc/ada/a-calcon.ads *** gcc-4.3.3/gcc/ada/a-calcon.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/a-calcon.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,114 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- A D A . C A L E N D A R . C O N V E R S I O N S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2008-2009 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides various routines for conversion between Ada and Unix + -- time models - Time, Duration, struct tm and struct timespec. + + with Interfaces.C; + + package Ada.Calendar.Conversions is + + function To_Ada_Time (Unix_Time : Interfaces.C.long) return Time; + -- Convert a time value represented as number of seconds since the Unix + -- Epoch to a time value relative to an Ada implementation-defined Epoch. + -- The units of the result are 100 nanoseconds on VMS and nanoseconds on + -- all other targets. Raises Time_Error if the result cannot fit into a + -- Time value. + + function To_Ada_Time + (tm_year : Interfaces.C.int; + tm_mon : Interfaces.C.int; + tm_day : Interfaces.C.int; + tm_hour : Interfaces.C.int; + tm_min : Interfaces.C.int; + tm_sec : Interfaces.C.int; + tm_isdst : Interfaces.C.int) return Time; + -- Convert a time value expressed in Unix-like fields of struct tm into + -- a Time value relative to the Ada Epoch. The ranges of the formals are + -- as follows: + + -- tm_year -- years since 1900 + -- tm_mon -- months since January [0 .. 11] + -- tm_day -- day of the month [1 .. 31] + -- tm_hour -- hours since midnight [0 .. 24] + -- tm_min -- minutes after the hour [0 .. 59] + -- tm_sec -- seconds after the minute [0 .. 60] + -- tm_isdst -- Daylight Savings Time flag [-1 .. 1] + + -- The returned value is in UTC and may or may not contain leap seconds + -- depending on whether binder flag "-y" was used. Raises Time_Error if + -- the input values are out of the defined ranges or if tm_sec equals 60 + -- and the instance in time is not a leap second occurrence. + + function To_Duration + (tv_sec : Interfaces.C.long; + tv_nsec : Interfaces.C.long) return Duration; + -- Convert an elapsed time value expressed in Unix-like fields of struct + -- timespec into a Duration value. The expected ranges are: + + -- tv_sec - seconds + -- tv_nsec - nanoseconds + + procedure To_Struct_Timespec + (D : Duration; + tv_sec : out Interfaces.C.long; + tv_nsec : out Interfaces.C.long); + -- Convert a Duration value into the constituents of struct timespec. + -- Formal tv_sec denotes seconds and tv_nsecs denotes nanoseconds. + + procedure To_Struct_Tm + (T : Time; + tm_year : out Interfaces.C.int; + tm_mon : out Interfaces.C.int; + tm_day : out Interfaces.C.int; + tm_hour : out Interfaces.C.int; + tm_min : out Interfaces.C.int; + tm_sec : out Interfaces.C.int); + -- Convert a Time value set in the Ada Epoch into the constituents of + -- struct tm. The ranges of the out formals are as follows: + + -- tm_year -- years since 1900 + -- tm_mon -- months since January [0 .. 11] + -- tm_day -- day of the month [1 .. 31] + -- tm_hour -- hours since midnight [0 .. 24] + -- tm_min -- minutes after the hour [0 .. 59] + -- tm_sec -- seconds after the minute [0 .. 60] + -- tm_isdst -- Daylight Savings Time flag [-1 .. 1] + + -- The input date is considered to be in UTC + + function To_Unix_Time (Ada_Time : Time) return Interfaces.C.long; + -- Convert a time value represented as number of time units since the Ada + -- implementation-defined Epoch to a value relative to the Unix Epoch. The + -- units of the result are seconds. Raises Time_Error if the result cannot + -- fit into a Time value. + + end Ada.Calendar.Conversions; diff -Nrcpad gcc-4.3.3/gcc/ada/a-caldel-vms.adb gcc-4.4.0/gcc/ada/a-caldel-vms.adb *** gcc-4.3.3/gcc/ada/a-caldel-vms.adb Mon Sep 5 08:07:00 2005 --- gcc-4.4.0/gcc/ada/a-caldel-vms.adb Tue May 20 12:59:41 2008 *************** *** 7,13 **** -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2005, AdaCore -- -- -- -- GNARL 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- -- --- 7,13 ---- -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNARL 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- -- *************** *** 35,44 **** -- This is the Alpha/VMS version with System.OS_Primitives; - -- Used for Max_Sensible_Delay - with System.Soft_Links; - -- Used for Timed_Delay package body Ada.Calendar.Delays is --- 35,41 ---- *************** package body Ada.Calendar.Delays is *** 47,52 **** --- 44,56 ---- use type TSL.Timed_Delay_Call; + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Timed_Delay_NT (Time : Duration; Mode : Integer); + -- Timed delay procedure used when no tasking is active + --------------- -- Delay_For -- --------------- *************** package body Ada.Calendar.Delays is *** 79,86 **** -- Timed_Delay_NT -- -------------------- - procedure Timed_Delay_NT (Time : Duration; Mode : Integer); - procedure Timed_Delay_NT (Time : Duration; Mode : Integer) is begin OSP.Timed_Delay (Time, Mode); --- 83,88 ---- *************** package body Ada.Calendar.Delays is *** 88,96 **** begin -- Set up the Timed_Delay soft link to the non tasking version if it has ! -- not been already set. ! -- If tasking is present, Timed_Delay has already set this soft link, or ! -- this will be overriden during the elaboration of -- System.Tasking.Initialization if TSL.Timed_Delay = null then --- 90,97 ---- begin -- Set up the Timed_Delay soft link to the non tasking version if it has ! -- not been already set. If tasking is present, Timed_Delay has already set ! -- this soft link, or this will be overridden during the elaboration of -- System.Tasking.Initialization if TSL.Timed_Delay = null then diff -Nrcpad gcc-4.3.3/gcc/ada/a-caldel.adb gcc-4.4.0/gcc/ada/a-caldel.adb *** gcc-4.3.3/gcc/ada/a-caldel.adb Fri Apr 6 09:15:21 2007 --- gcc-4.4.0/gcc/ada/a-caldel.adb Tue Apr 8 06:46:17 2008 *************** *** 7,13 **** -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2006, AdaCore -- -- -- -- GNARL 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- -- --- 7,13 ---- -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNARL 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- -- *************** *** 33,49 **** ------------------------------------------------------------------------------ with System.OS_Primitives; - -- Used for Delay_Modes - -- Max_Sensible_Delay - with System.Soft_Links; - -- Used for Timed_Delay - with System.Traces; - -- Used for Send_Trace_Info - with System.Parameters; - -- used for Runtime_Traces package body Ada.Calendar.Delays is --- 33,41 ---- *************** package body Ada.Calendar.Delays is *** 54,60 **** use System.Traces; ! -- Earlier, System.Time_Opeations was used to implement the following -- operations. The idea was to avoid sucking in the tasking packages. This -- did not work. Logically, we can't have it both ways. There is no way to -- implement time delays that will have correct task semantics without --- 46,52 ---- use System.Traces; ! -- Earlier, System.Time_Operations was used to implement the following -- operations. The idea was to avoid sucking in the tasking packages. This -- did not work. Logically, we can't have it both ways. There is no way to -- implement time delays that will have correct task semantics without *************** package body Ada.Calendar.Delays is *** 124,138 **** -- target independent operation in Ada.Calendar is used to perform -- this conversion. ! return Delays_Operations.To_Duration (T); end To_Duration; begin -- Set up the Timed_Delay soft link to the non tasking version if it has ! -- not been already set. ! ! -- If tasking is present, Timed_Delay has already set this soft link, or ! -- this will be overriden during the elaboration of -- System.Tasking.Initialization if SSL.Timed_Delay = null then --- 116,128 ---- -- target independent operation in Ada.Calendar is used to perform -- this conversion. ! return Delay_Operations.To_Duration (T); end To_Duration; begin -- Set up the Timed_Delay soft link to the non tasking version if it has ! -- not been already set. If tasking is present, Timed_Delay has already set ! -- this soft link, or this will be overridden during the elaboration of -- System.Tasking.Initialization if SSL.Timed_Delay = null then diff -Nrcpad gcc-4.3.3/gcc/ada/a-caldel.ads gcc-4.4.0/gcc/ada/a-caldel.ads *** gcc-4.3.3/gcc/ada/a-caldel.ads Mon Sep 5 08:07:00 2005 --- gcc-4.4.0/gcc/ada/a-caldel.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-calend-vms.adb gcc-4.4.0/gcc/ada/a-calend-vms.adb *** gcc-4.3.3/gcc/ada/a-calend-vms.adb Thu Dec 13 10:44:32 2007 --- gcc-4.4.0/gcc/ada/a-calend-vms.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 33,42 **** -- This is the Alpha/VMS version - with System.Aux_DEC; use System.Aux_DEC; - with Ada.Unchecked_Conversion; package body Ada.Calendar is -------------------------- --- 31,41 ---- -- This is the Alpha/VMS version with Ada.Unchecked_Conversion; + with System.Aux_DEC; use System.Aux_DEC; + with System.OS_Primitives; use System.OS_Primitives; + package body Ada.Calendar is -------------------------- *************** package body Ada.Calendar is *** 48,54 **** -- Because time is measured in different units and from different origins -- on various targets, a system independent model is incorporated into ! -- Ada.Calendar. The idea behing the design is to encapsulate all target -- dependent machinery in a single package, thus providing a uniform -- interface to all existing and any potential children. --- 47,53 ---- -- Because time is measured in different units and from different origins -- on various targets, a system independent model is incorporated into ! -- Ada.Calendar. The idea behind the design is to encapsulate all target -- dependent machinery in a single package, thus providing a uniform -- interface to all existing and any potential children. *************** package body Ada.Calendar is *** 77,97 **** -- Local Subprograms -- ----------------------- ! procedure Check_Within_Time_Bounds (T : Time); -- Ensure that a time representation value falls withing the bounds of Ada -- time. Leap seconds support is taken into account. procedure Cumulative_Leap_Seconds ! (Start_Date : Time; ! End_Date : Time; Elapsed_Leaps : out Natural; ! Next_Leap_Sec : out Time); ! -- Elapsed_Leaps is the sum of the leap seconds that have occured on or -- after Start_Date and before (strictly before) End_Date. Next_Leap_Sec ! -- represents the next leap second occurence on or after End_Date. If -- there are no leaps seconds after End_Date, End_Of_Time is returned. -- End_Of_Time can be used as End_Date to count all the leap seconds that ! -- have occured on or after Start_Date. -- -- Note: Any sub seconds of Start_Date and End_Date are discarded before -- the calculations are done. For instance: if 113 seconds is a leap --- 76,96 ---- -- Local Subprograms -- ----------------------- ! procedure Check_Within_Time_Bounds (T : OS_Time); -- Ensure that a time representation value falls withing the bounds of Ada -- time. Leap seconds support is taken into account. procedure Cumulative_Leap_Seconds ! (Start_Date : OS_Time; ! End_Date : OS_Time; Elapsed_Leaps : out Natural; ! Next_Leap_Sec : out OS_Time); ! -- Elapsed_Leaps is the sum of the leap seconds that have occurred on or -- after Start_Date and before (strictly before) End_Date. Next_Leap_Sec ! -- represents the next leap second occurrence on or after End_Date. If -- there are no leaps seconds after End_Date, End_Of_Time is returned. -- End_Of_Time can be used as End_Date to count all the leap seconds that ! -- have occurred on or after Start_Date. -- -- Note: Any sub seconds of Start_Date and End_Date are discarded before -- the calculations are done. For instance: if 113 seconds is a leap *************** package body Ada.Calendar is *** 135,160 **** -- The range of Ada time expressed as milis since the VMS Epoch ! Ada_Low : constant Time := (10 * 366 + 32 * 365 + 45) * Milis_In_Day; ! Ada_High : constant Time := (131 * 366 + 410 * 365 + 45) * Milis_In_Day; -- Even though the upper bound of time is 2399-12-31 23:59:59.9999999 -- UTC, it must be increased to include all leap seconds. ! Ada_High_And_Leaps : constant Time := ! Ada_High + Time (Leap_Seconds_Count) * Mili; -- Two constants used in the calculations of elapsed leap seconds. -- End_Of_Time is later than Ada_High in time zone -28. Start_Of_Time -- is earlier than Ada_Low in time zone +28. ! End_Of_Time : constant Time := Ada_High + Time (3) * Milis_In_Day; ! Start_Of_Time : constant Time := Ada_Low - Time (3) * Milis_In_Day; -- The following table contains the hard time values of all existing leap -- seconds. The values are produced by the utility program xleaps.adb. ! Leap_Second_Times : constant array (1 .. Leap_Seconds_Count) of Time := (35855136000000000, 36014112010000000, 36329472020000000, --- 134,159 ---- -- The range of Ada time expressed as milis since the VMS Epoch ! Ada_Low : constant OS_Time := (10 * 366 + 32 * 365 + 45) * Milis_In_Day; ! Ada_High : constant OS_Time := (131 * 366 + 410 * 365 + 45) * Milis_In_Day; -- Even though the upper bound of time is 2399-12-31 23:59:59.9999999 -- UTC, it must be increased to include all leap seconds. ! Ada_High_And_Leaps : constant OS_Time := ! Ada_High + OS_Time (Leap_Seconds_Count) * Mili; -- Two constants used in the calculations of elapsed leap seconds. -- End_Of_Time is later than Ada_High in time zone -28. Start_Of_Time -- is earlier than Ada_Low in time zone +28. ! End_Of_Time : constant OS_Time := Ada_High + OS_Time (3) * Milis_In_Day; ! Start_Of_Time : constant OS_Time := Ada_Low - OS_Time (3) * Milis_In_Day; -- The following table contains the hard time values of all existing leap -- seconds. The values are produced by the utility program xleaps.adb. ! Leap_Second_Times : constant array (1 .. Leap_Seconds_Count) of OS_Time := (35855136000000000, 36014112010000000, 36329472020000000, *************** package body Ada.Calendar is *** 219,231 **** -- The bound of type Duration expressed as time ! Dur_High : constant Time := To_Relative_Time (Duration'Last); ! Dur_Low : constant Time := To_Relative_Time (Duration'First); ! Res_M : Time; begin ! Res_M := Left - Right; -- Due to the extended range of Ada time, "-" is capable of producing -- results which may exceed the range of Duration. In order to prevent --- 218,232 ---- -- The bound of type Duration expressed as time ! Dur_High : constant OS_Time := ! OS_Time (To_Relative_Time (Duration'Last)); ! Dur_Low : constant OS_Time := ! OS_Time (To_Relative_Time (Duration'First)); ! Res_M : OS_Time; begin ! Res_M := OS_Time (Left) - OS_Time (Right); -- Due to the extended range of Ada time, "-" is capable of producing -- results which may exceed the range of Duration. In order to prevent *************** package body Ada.Calendar is *** 240,246 **** -- Normal case, result fits else ! return To_Duration (Res_M); end if; exception --- 241,247 ---- -- Normal case, result fits else ! return To_Duration (Time (Res_M)); end if; exception *************** package body Ada.Calendar is *** 254,260 **** function "<" (Left, Right : Time) return Boolean is begin ! return Long_Integer (Left) < Long_Integer (Right); end "<"; ---------- --- 255,261 ---- function "<" (Left, Right : Time) return Boolean is begin ! return OS_Time (Left) < OS_Time (Right); end "<"; ---------- *************** package body Ada.Calendar is *** 263,269 **** function "<=" (Left, Right : Time) return Boolean is begin ! return Long_Integer (Left) <= Long_Integer (Right); end "<="; --------- --- 264,270 ---- function "<=" (Left, Right : Time) return Boolean is begin ! return OS_Time (Left) <= OS_Time (Right); end "<="; --------- *************** package body Ada.Calendar is *** 272,278 **** function ">" (Left, Right : Time) return Boolean is begin ! return Long_Integer (Left) > Long_Integer (Right); end ">"; ---------- --- 273,279 ---- function ">" (Left, Right : Time) return Boolean is begin ! return OS_Time (Left) > OS_Time (Right); end ">"; ---------- *************** package body Ada.Calendar is *** 281,294 **** function ">=" (Left, Right : Time) return Boolean is begin ! return Long_Integer (Left) >= Long_Integer (Right); end ">="; ------------------------------ -- Check_Within_Time_Bounds -- ------------------------------ ! procedure Check_Within_Time_Bounds (T : Time) is begin if Leap_Support then if T < Ada_Low or else T > Ada_High_And_Leaps then --- 282,295 ---- function ">=" (Left, Right : Time) return Boolean is begin ! return OS_Time (Left) >= OS_Time (Right); end ">="; ------------------------------ -- Check_Within_Time_Bounds -- ------------------------------ ! procedure Check_Within_Time_Bounds (T : OS_Time) is begin if Leap_Support then if T < Ada_Low or else T > Ada_High_And_Leaps then *************** package body Ada.Calendar is *** 307,314 **** function Clock return Time is Elapsed_Leaps : Natural; ! Next_Leap_M : Time; ! Res_M : constant Time := Time (OSP.OS_Clock); begin -- Note that on other targets a soft-link is used to get a different --- 308,315 ---- function Clock return Time is Elapsed_Leaps : Natural; ! Next_Leap_M : OS_Time; ! Res_M : constant OS_Time := OS_Clock; begin -- Note that on other targets a soft-link is used to get a different *************** package body Ada.Calendar is *** 335,341 **** Elapsed_Leaps := 0; end if; ! return Res_M + Time (Elapsed_Leaps) * Mili; end Clock; ----------------------------- --- 336,342 ---- Elapsed_Leaps := 0; end if; ! return Time (Res_M + OS_Time (Elapsed_Leaps) * Mili); end Clock; ----------------------------- *************** package body Ada.Calendar is *** 343,364 **** ----------------------------- procedure Cumulative_Leap_Seconds ! (Start_Date : Time; ! End_Date : Time; Elapsed_Leaps : out Natural; ! Next_Leap_Sec : out Time) is End_Index : Positive; ! End_T : Time := End_Date; Start_Index : Positive; ! Start_T : Time := Start_Date; begin pragma Assert (Leap_Support and then End_Date >= Start_Date); Next_Leap_Sec := End_Of_Time; ! -- Make sure that the end date does not excede the upper bound -- of Ada time. if End_Date > Ada_High then --- 344,365 ---- ----------------------------- procedure Cumulative_Leap_Seconds ! (Start_Date : OS_Time; ! End_Date : OS_Time; Elapsed_Leaps : out Natural; ! Next_Leap_Sec : out OS_Time) is End_Index : Positive; ! End_T : OS_Time := End_Date; Start_Index : Positive; ! Start_T : OS_Time := Start_Date; begin pragma Assert (Leap_Support and then End_Date >= Start_Date); Next_Leap_Sec := End_Of_Time; ! -- Make sure that the end date does not exceed the upper bound -- of Ada time. if End_Date > Ada_High then *************** package body Ada.Calendar is *** 387,393 **** end if; -- Perform the calculations only if the start date is within the leap ! -- second occurences table. if Start_T <= Leap_Second_Times (Leap_Seconds_Count) then --- 388,394 ---- end if; -- Perform the calculations only if the start date is within the leap ! -- second occurrences table. if Start_T <= Leap_Second_Times (Leap_Seconds_Count) then *************** package body Ada.Calendar is *** 449,460 **** function Is_Leap (Year : Year_Number) return Boolean is begin ! -- Leap centenial years if Year mod 400 = 0 then return True; ! -- Non-leap centenial years elsif Year mod 100 = 0 then return False; --- 450,461 ---- function Is_Leap (Year : Year_Number) return Boolean is begin ! -- Leap centennial years if Year mod 400 = 0 then return True; ! -- Non-leap centennial years elsif Year mod 100 = 0 then return False; *************** package body Ada.Calendar is *** 641,648 **** function Add (Date : Time; Days : Long_Integer) return Time is pragma Unsuppress (Overflow_Check); begin ! return Date + Time (Days) * Milis_In_Day; exception when Constraint_Error => raise Time_Error; --- 642,650 ---- function Add (Date : Time; Days : Long_Integer) return Time is pragma Unsuppress (Overflow_Check); + Date_M : constant OS_Time := OS_Time (Date); begin ! return Time (Date_M + OS_Time (Days) * Milis_In_Day); exception when Constraint_Error => raise Time_Error; *************** package body Ada.Calendar is *** 659,673 **** Seconds : out Duration; Leap_Seconds : out Integer) is ! Mili_F : constant Duration := 10_000_000.0; ! ! Diff_M : Time; ! Diff_S : Time; ! Earlier : Time; Elapsed_Leaps : Natural; ! Later : Time; Negate : Boolean := False; ! Next_Leap : Time; Sub_Seconds : Duration; begin --- 661,673 ---- Seconds : out Duration; Leap_Seconds : out Integer) is ! Diff_M : OS_Time; ! Diff_S : OS_Time; ! Earlier : OS_Time; Elapsed_Leaps : Natural; ! Later : OS_Time; Negate : Boolean := False; ! Next_Leap : OS_Time; Sub_Seconds : Duration; begin *************** package body Ada.Calendar is *** 675,685 **** -- being raised by the arithmetic operators in Ada.Calendar. if Left >= Right then ! Later := Left; ! Earlier := Right; else ! Later := Right; ! Earlier := Left; Negate := True; end if; --- 675,685 ---- -- being raised by the arithmetic operators in Ada.Calendar. if Left >= Right then ! Later := OS_Time (Left); ! Earlier := OS_Time (Right); else ! Later := OS_Time (Right); ! Earlier := OS_Time (Left); Negate := True; end if; *************** package body Ada.Calendar is *** 699,705 **** Elapsed_Leaps := 0; end if; ! Diff_M := Later - Earlier - Time (Elapsed_Leaps) * Mili; -- Sub second processing --- 699,705 ---- Elapsed_Leaps := 0; end if; ! Diff_M := Later - Earlier - OS_Time (Elapsed_Leaps) * Mili; -- Sub second processing *************** package body Ada.Calendar is *** 730,737 **** function Subtract (Date : Time; Days : Long_Integer) return Time is pragma Unsuppress (Overflow_Check); begin ! return Date - Time (Days) * Milis_In_Day; exception when Constraint_Error => raise Time_Error; --- 730,738 ---- function Subtract (Date : Time; Days : Long_Integer) return Time is pragma Unsuppress (Overflow_Check); + Date_M : constant OS_Time := OS_Time (Date); begin ! return Time (Date_M - OS_Time (Days) * Milis_In_Day); exception when Constraint_Error => raise Time_Error; *************** package body Ada.Calendar is *** 739,744 **** --- 740,948 ---- end Arithmetic_Operations; --------------------------- + -- Conversion_Operations -- + --------------------------- + + package body Conversion_Operations is + + Epoch_Offset : constant OS_Time := 35067168000000000; + -- The difference between 1970-1-1 UTC and 1858-11-17 UTC expressed in + -- 100 nanoseconds. + + ----------------- + -- To_Ada_Time -- + ----------------- + + function To_Ada_Time (Unix_Time : Long_Integer) return Time is + pragma Unsuppress (Overflow_Check); + Unix_Rep : constant OS_Time := OS_Time (Unix_Time) * Mili; + begin + return Time (Unix_Rep + Epoch_Offset); + exception + when Constraint_Error => + raise Time_Error; + end To_Ada_Time; + + ----------------- + -- To_Ada_Time -- + ----------------- + + function To_Ada_Time + (tm_year : Integer; + tm_mon : Integer; + tm_day : Integer; + tm_hour : Integer; + tm_min : Integer; + tm_sec : Integer; + tm_isdst : Integer) return Time + is + pragma Unsuppress (Overflow_Check); + + Year_Shift : constant Integer := 1900; + Month_Shift : constant Integer := 1; + + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Second : Integer; + Leap : Boolean; + Result : OS_Time; + + begin + -- Input processing + + Year := Year_Number (Year_Shift + tm_year); + Month := Month_Number (Month_Shift + tm_mon); + Day := Day_Number (tm_day); + + -- Step 1: Validity checks of input values + + if not Year'Valid + or else not Month'Valid + or else not Day'Valid + or else tm_hour not in 0 .. 24 + or else tm_min not in 0 .. 59 + or else tm_sec not in 0 .. 60 + or else tm_isdst not in -1 .. 1 + then + raise Time_Error; + end if; + + -- Step 2: Potential leap second + + if tm_sec = 60 then + Leap := True; + Second := 59; + else + Leap := False; + Second := tm_sec; + end if; + + -- Step 3: Calculate the time value + + Result := + OS_Time + (Formatting_Operations.Time_Of + (Year => Year, + Month => Month, + Day => Day, + Day_Secs => 0.0, -- Time is given in h:m:s + Hour => tm_hour, + Minute => tm_min, + Second => Second, + Sub_Sec => 0.0, -- No precise sub second given + Leap_Sec => Leap, + Use_Day_Secs => False, -- Time is given in h:m:s + Is_Ada_05 => True, -- Force usage of explicit time zone + Time_Zone => 0)); -- Place the value in UTC + -- Step 4: Daylight Savings Time + + if tm_isdst = 1 then + Result := Result + OS_Time (3_600) * Mili; + end if; + + return Time (Result); + exception + when Constraint_Error => + raise Time_Error; + end To_Ada_Time; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration + (tv_sec : Long_Integer; + tv_nsec : Long_Integer) return Duration + is + pragma Unsuppress (Overflow_Check); + begin + return Duration (tv_sec) + Duration (tv_nsec) / Mili_F; + end To_Duration; + + ------------------------ + -- To_Struct_Timespec -- + ------------------------ + + procedure To_Struct_Timespec + (D : Duration; + tv_sec : out Long_Integer; + tv_nsec : out Long_Integer) + is + pragma Unsuppress (Overflow_Check); + Secs : Duration; + Nano_Secs : Duration; + + begin + -- Seconds extraction, avoid potential rounding errors + + Secs := D - 0.5; + tv_sec := Long_Integer (Secs); + + -- 100 Nanoseconds extraction + + Nano_Secs := D - Duration (tv_sec); + tv_nsec := Long_Integer (Nano_Secs * Mili); + end To_Struct_Timespec; + + ------------------ + -- To_Struct_Tm -- + ------------------ + + procedure To_Struct_Tm + (T : Time; + tm_year : out Integer; + tm_mon : out Integer; + tm_day : out Integer; + tm_hour : out Integer; + tm_min : out Integer; + tm_sec : out Integer) + is + pragma Unsuppress (Overflow_Check); + Year : Year_Number; + Month : Month_Number; + Second : Integer; + Day_Secs : Day_Duration; + Sub_Sec : Duration; + Leap_Sec : Boolean; + + begin + -- Step 1: Split the input time + + Formatting_Operations.Split + (T, Year, Month, tm_day, Day_Secs, + tm_hour, tm_min, Second, Sub_Sec, Leap_Sec, True, 0); + + -- Step 2: Correct the year and month + + tm_year := Year - 1900; + tm_mon := Month - 1; + + -- Step 3: Handle leap second occurrences + + if Leap_Sec then + tm_sec := 60; + else + tm_sec := Second; + end if; + end To_Struct_Tm; + + ------------------ + -- To_Unix_Time -- + ------------------ + + function To_Unix_Time (Ada_Time : Time) return Long_Integer is + pragma Unsuppress (Overflow_Check); + Ada_OS_Time : constant OS_Time := OS_Time (Ada_Time); + begin + return Long_Integer ((Ada_OS_Time - Epoch_Offset) / Mili); + exception + when Constraint_Error => + raise Time_Error; + end To_Unix_Time; + end Conversion_Operations; + + --------------------------- -- Formatting_Operations -- --------------------------- *************** package body Ada.Calendar is *** 812,831 **** Ada_Min_Year : constant := 1901; Ada_Max_Year : constant := 2399; - Mili_F : constant Duration := 10_000_000.0; ! Date_M : Time; Elapsed_Leaps : Natural; ! Next_Leap_M : Time; begin ! Date_M := Date; -- Step 1: Leap seconds processing if Leap_Support then Cumulative_Leap_Seconds ! (Start_Of_Time, Date, Elapsed_Leaps, Next_Leap_M); Leap_Sec := Date_M >= Next_Leap_M; --- 1016,1034 ---- Ada_Min_Year : constant := 1901; Ada_Max_Year : constant := 2399; ! Date_M : OS_Time; Elapsed_Leaps : Natural; ! Next_Leap_M : OS_Time; begin ! Date_M := OS_Time (Date); -- Step 1: Leap seconds processing if Leap_Support then Cumulative_Leap_Seconds ! (Start_Of_Time, Date_M, Elapsed_Leaps, Next_Leap_M); Leap_Sec := Date_M >= Next_Leap_M; *************** package body Ada.Calendar is *** 840,851 **** Leap_Sec := False; end if; ! Date_M := Date_M - Time (Elapsed_Leaps) * Mili; -- Step 2: Time zone processing if Time_Zone /= 0 then ! Date_M := Date_M + Time (Time_Zone) * 60 * Mili; end if; -- After the leap seconds and time zone have been accounted for, --- 1043,1054 ---- Leap_Sec := False; end if; ! Date_M := Date_M - OS_Time (Elapsed_Leaps) * Mili; -- Step 2: Time zone processing if Time_Zone /= 0 then ! Date_M := Date_M + OS_Time (Time_Zone) * 60 * Mili; end if; -- After the leap seconds and time zone have been accounted for, *************** package body Ada.Calendar is *** 867,873 **** -- Step 4: VMS system call ! Numtim (Status, Timbuf, Date_M); if Status mod 2 /= 1 or else Timbuf (1) not in Ada_Min_Year .. Ada_Max_Year --- 1070,1076 ---- -- Step 4: VMS system call ! Numtim (Status, Timbuf, Time (Date_M)); if Status mod 2 /= 1 or else Timbuf (1) not in Ada_Min_Year .. Ada_Max_Year *************** package body Ada.Calendar is *** 903,912 **** Minute : Integer; Second : Integer; Sub_Sec : Duration; ! Leap_Sec : Boolean; ! Use_Day_Secs : Boolean; ! Is_Ada_05 : Boolean; ! Time_Zone : Long_Integer) return Time is procedure Cvt_Vectim (Status : out Unsigned_Longword; --- 1106,1115 ---- Minute : Integer; Second : Integer; Sub_Sec : Duration; ! Leap_Sec : Boolean := False; ! Use_Day_Secs : Boolean := False; ! Is_Ada_05 : Boolean := False; ! Time_Zone : Long_Integer := 0) return Time is procedure Cvt_Vectim (Status : out Unsigned_Longword; *************** package body Ada.Calendar is *** 923,930 **** Status : Unsigned_Longword; Timbuf : Unsigned_Word_Array (1 .. 7); - Mili_F : constant := 10_000_000.0; - Y : Year_Number := Year; Mo : Month_Number := Month; D : Day_Number := Day; --- 1126,1131 ---- *************** package body Ada.Calendar is *** 935,943 **** Elapsed_Leaps : Natural; Int_Day_Secs : Integer; ! Next_Leap_M : Time; ! Res_M : Time; ! Rounded_Res_M : Time; begin -- No validity checks are performed on the input values since it is --- 1136,1145 ---- Elapsed_Leaps : Natural; Int_Day_Secs : Integer; ! Next_Leap_M : OS_Time; ! Res : Time; ! Res_M : OS_Time; ! Rounded_Res_M : OS_Time; begin -- No validity checks are performed on the input values since it is *************** package body Ada.Calendar is *** 1015,1021 **** Timbuf (6) := Unsigned_Word (Se); Timbuf (7) := 0; ! Cvt_Vectim (Status, Timbuf, Res_M); if Status mod 2 /= 1 then raise Time_Error; --- 1217,1223 ---- Timbuf (6) := Unsigned_Word (Se); Timbuf (7) := 0; ! Cvt_Vectim (Status, Timbuf, Res); if Status mod 2 /= 1 then raise Time_Error; *************** package body Ada.Calendar is *** 1023,1029 **** -- Step 3: Sub second adjustment ! Res_M := Res_M + Time (Su * Mili_F); -- Step 4: Bounds check --- 1225,1231 ---- -- Step 3: Sub second adjustment ! Res_M := OS_Time (Res) + OS_Time (Su * Mili_F); -- Step 4: Bounds check *************** package body Ada.Calendar is *** 1032,1038 **** -- Step 5: Time zone processing if Time_Zone /= 0 then ! Res_M := Res_M - Time (Time_Zone) * 60 * Mili; end if; -- Step 6: Leap seconds processing --- 1234,1240 ---- -- Step 5: Time zone processing if Time_Zone /= 0 then ! Res_M := Res_M - OS_Time (Time_Zone) * 60 * Mili; end if; -- Step 6: Leap seconds processing *************** package body Ada.Calendar is *** 1041,1047 **** Cumulative_Leap_Seconds (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M); ! Res_M := Res_M + Time (Elapsed_Leaps) * Mili; -- An Ada 2005 caller requesting an explicit leap second or an -- Ada 95 caller accounting for an invisible leap second. --- 1243,1249 ---- Cumulative_Leap_Seconds (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M); ! Res_M := Res_M + OS_Time (Elapsed_Leaps) * Mili; -- An Ada 2005 caller requesting an explicit leap second or an -- Ada 95 caller accounting for an invisible leap second. *************** package body Ada.Calendar is *** 1049,1055 **** if Leap_Sec or else Res_M >= Next_Leap_M then ! Res_M := Res_M + Time (1) * Mili; end if; -- Leap second validity check --- 1251,1257 ---- if Leap_Sec or else Res_M >= Next_Leap_M then ! Res_M := Res_M + OS_Time (1) * Mili; end if; -- Leap second validity check *************** package body Ada.Calendar is *** 1064,1070 **** end if; end if; ! return Res_M; end Time_Of; end Formatting_Operations; --- 1266,1272 ---- end if; end if; ! return Time (Res_M); end Time_Of; end Formatting_Operations; diff -Nrcpad gcc-4.3.3/gcc/ada/a-calend-vms.ads gcc-4.4.0/gcc/ada/a-calend-vms.ads *** gcc-4.3.3/gcc/ada/a-calend-vms.ads Wed Sep 12 13:11:54 2007 --- gcc-4.4.0/gcc/ada/a-calend-vms.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 107,112 **** --- 105,111 ---- -- readability, this unit will be called "mili". Mili : constant := 10_000_000; + Mili_F : constant := 10_000_000.0; Milis_In_Day : constant := 864_000_000_000; Secs_In_Day : constant := 86_400; *************** private *** 139,145 **** --- 138,149 ---- -- NOTE: Delays does not need a target independent interface because -- VMS already has a target specific file for that package. + --------------------------- + -- Arithmetic_Operations -- + --------------------------- + package Arithmetic_Operations is + function Add (Date : Time; Days : Long_Integer) return Time; -- Add a certain number of days to a time value *************** private *** 156,164 **** --- 160,218 ---- function Subtract (Date : Time; Days : Long_Integer) return Time; -- Subtract a certain number of days from a time value + end Arithmetic_Operations; + --------------------------- + -- Conversion_Operations -- + --------------------------- + + package Conversion_Operations is + function To_Ada_Time (Unix_Time : Long_Integer) return Time; + -- Unix to Ada Epoch conversion + + function To_Ada_Time + (tm_year : Integer; + tm_mon : Integer; + tm_day : Integer; + tm_hour : Integer; + tm_min : Integer; + tm_sec : Integer; + tm_isdst : Integer) return Time; + -- Struct tm to Ada Epoch conversion + + function To_Duration + (tv_sec : Long_Integer; + tv_nsec : Long_Integer) return Duration; + -- Struct timespec to Duration conversion + + procedure To_Struct_Timespec + (D : Duration; + tv_sec : out Long_Integer; + tv_nsec : out Long_Integer); + -- Duration to struct timespec conversion + + procedure To_Struct_Tm + (T : Time; + tm_year : out Integer; + tm_mon : out Integer; + tm_day : out Integer; + tm_hour : out Integer; + tm_min : out Integer; + tm_sec : out Integer); + -- Time to struct tm conversion + + function To_Unix_Time (Ada_Time : Time) return Long_Integer; + -- Ada to Unix Epoch conversion + + end Conversion_Operations; + + --------------------------- + -- Formatting_Operations -- + --------------------------- + package Formatting_Operations is + function Day_Of_Week (Date : Time) return Integer; -- Determine which day of week Date falls on. The returned values are -- within the range of 0 .. 6 (Monday .. Sunday). *************** private *** 189,209 **** Minute : Integer; Second : Integer; Sub_Sec : Duration; ! Leap_Sec : Boolean; ! Use_Day_Secs : Boolean; ! Is_Ada_05 : Boolean; ! Time_Zone : Long_Integer) return Time; -- Given all the components of a date, return the corresponding time -- value. Set Use_Day_Secs to use the value in Day_Secs, otherwise the -- day duration will be calculated from Hour, Minute, Second and Sub_ -- Sec. Set Is_Ada_05 to use the local time zone (the value in formal -- Time_Zone is ignored) when building a time value and to verify the -- validity of a requested leap second. end Formatting_Operations; package Time_Zones_Operations is function UTC_Time_Offset (Date : Time) return Long_Integer; -- Return the offset in seconds from UTC end Time_Zones_Operations; end Ada.Calendar; --- 243,270 ---- Minute : Integer; Second : Integer; Sub_Sec : Duration; ! Leap_Sec : Boolean := False; ! Use_Day_Secs : Boolean := False; ! Is_Ada_05 : Boolean := False; ! Time_Zone : Long_Integer := 0) return Time; -- Given all the components of a date, return the corresponding time -- value. Set Use_Day_Secs to use the value in Day_Secs, otherwise the -- day duration will be calculated from Hour, Minute, Second and Sub_ -- Sec. Set Is_Ada_05 to use the local time zone (the value in formal -- Time_Zone is ignored) when building a time value and to verify the -- validity of a requested leap second. + end Formatting_Operations; + --------------------------- + -- Time_Zones_Operations -- + --------------------------- + package Time_Zones_Operations is + function UTC_Time_Offset (Date : Time) return Long_Integer; -- Return the offset in seconds from UTC + end Time_Zones_Operations; end Ada.Calendar; diff -Nrcpad gcc-4.3.3/gcc/ada/a-calend.adb gcc-4.4.0/gcc/ada/a-calend.adb *** gcc-4.3.3/gcc/ada/a-calend.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-calend.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 34,40 **** with Ada.Unchecked_Conversion; with System.OS_Primitives; - -- used for Clock package body Ada.Calendar is --- 32,37 ---- *************** package body Ada.Calendar is *** 85,96 **** End_Date : Time_Rep; Elapsed_Leaps : out Natural; Next_Leap : out Time_Rep); ! -- Elapsed_Leaps is the sum of the leap seconds that have occured on or -- after Start_Date and before (strictly before) End_Date. Next_Leap_Sec ! -- represents the next leap second occurence on or after End_Date. If -- there are no leaps seconds after End_Date, End_Of_Time is returned. -- End_Of_Time can be used as End_Date to count all the leap seconds that ! -- have occured on or after Start_Date. -- -- Note: Any sub seconds of Start_Date and End_Date are discarded before -- the calculations are done. For instance: if 113 seconds is a leap --- 82,93 ---- End_Date : Time_Rep; Elapsed_Leaps : out Natural; Next_Leap : out Time_Rep); ! -- Elapsed_Leaps is the sum of the leap seconds that have occurred on or -- after Start_Date and before (strictly before) End_Date. Next_Leap_Sec ! -- represents the next leap second occurrence on or after End_Date. If -- there are no leaps seconds after End_Date, End_Of_Time is returned. -- End_Of_Time can be used as End_Date to count all the leap seconds that ! -- have occurred on or after Start_Date. -- -- Note: Any sub seconds of Start_Date and End_Date are discarded before -- the calculations are done. For instance: if 113 seconds is a leap *************** package body Ada.Calendar is *** 154,160 **** -- Lower and upper bound of Ada time. The zero (0) value of type Time is -- positioned at year 2150. Note that the lower and upper bound account ! -- for the non-leap centenial years. Ada_Low : constant Time_Rep := -(61 * 366 + 188 * 365) * Nanos_In_Day; Ada_High : constant Time_Rep := (60 * 366 + 190 * 365) * Nanos_In_Day; --- 151,157 ---- -- Lower and upper bound of Ada time. The zero (0) value of type Time is -- positioned at year 2150. Note that the lower and upper bound account ! -- for the non-leap centennial years. Ada_Low : constant Time_Rep := -(61 * 366 + 188 * 365) * Nanos_In_Day; Ada_High : constant Time_Rep := (60 * 366 + 190 * 365) * Nanos_In_Day; *************** package body Ada.Calendar is *** 391,397 **** Next_Leap := End_Of_Time; ! -- Make sure that the end date does not excede the upper bound -- of Ada time. if End_Date > Ada_High then --- 388,394 ---- Next_Leap := End_Of_Time; ! -- Make sure that the end date does not exceed the upper bound -- of Ada time. if End_Date > Ada_High then *************** package body Ada.Calendar is *** 420,426 **** end if; -- Perform the calculations only if the start date is within the leap ! -- second occurences table. if Start_T <= Leap_Second_Times (Leap_Seconds_Count) then --- 417,423 ---- end if; -- Perform the calculations only if the start date is within the leap ! -- second occurrences table. if Start_T <= Leap_Second_Times (Leap_Seconds_Count) then *************** package body Ada.Calendar is *** 483,494 **** function Is_Leap (Year : Year_Number) return Boolean is begin ! -- Leap centenial years if Year mod 400 = 0 then return True; ! -- Non-leap centenial years elsif Year mod 100 = 0 then return False; --- 480,491 ---- function Is_Leap (Year : Year_Number) return Boolean is begin ! -- Leap centennial years if Year mod 400 = 0 then return True; ! -- Non-leap centennial years elsif Year mod 100 = 0 then return False; *************** package body Ada.Calendar is *** 724,730 **** -- Difference processing. This operation should be able to calculate -- the difference between opposite values which are close to the end ! -- and start of Ada time. To accomodate the large range, we convert -- to seconds. This action may potentially round the two values and -- either add or drop a second. We compensate for this issue in the -- previous step. --- 721,727 ---- -- Difference processing. This operation should be able to calculate -- the difference between opposite values which are close to the end ! -- and start of Ada time. To accommodate the large range, we convert -- to seconds. This action may potentially round the two values and -- either add or drop a second. We compensate for this issue in the -- previous step. *************** package body Ada.Calendar is *** 759,771 **** when Constraint_Error => raise Time_Error; end Subtract; end Arithmetic_Operations; ---------------------- -- Delay_Operations -- ---------------------- ! package body Delays_Operations is ----------------- -- To_Duration -- --- 756,971 ---- when Constraint_Error => raise Time_Error; end Subtract; + end Arithmetic_Operations; + --------------------------- + -- Conversion_Operations -- + --------------------------- + + package body Conversion_Operations is + + Epoch_Offset : constant Time_Rep := + (136 * 365 + 44 * 366) * Nanos_In_Day; + -- The difference between 2150-1-1 UTC and 1970-1-1 UTC expressed in + -- nanoseconds. Note that year 2100 is non-leap. + + ----------------- + -- To_Ada_Time -- + ----------------- + + function To_Ada_Time (Unix_Time : Long_Integer) return Time is + pragma Unsuppress (Overflow_Check); + Unix_Rep : constant Time_Rep := Time_Rep (Unix_Time) * Nano; + begin + return Time (Unix_Rep - Epoch_Offset); + exception + when Constraint_Error => + raise Time_Error; + end To_Ada_Time; + + ----------------- + -- To_Ada_Time -- + ----------------- + + function To_Ada_Time + (tm_year : Integer; + tm_mon : Integer; + tm_day : Integer; + tm_hour : Integer; + tm_min : Integer; + tm_sec : Integer; + tm_isdst : Integer) return Time + is + pragma Unsuppress (Overflow_Check); + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Second : Integer; + Leap : Boolean; + Result : Time_Rep; + + begin + -- Input processing + + Year := Year_Number (1900 + tm_year); + Month := Month_Number (1 + tm_mon); + Day := Day_Number (tm_day); + + -- Step 1: Validity checks of input values + + if not Year'Valid + or else not Month'Valid + or else not Day'Valid + or else tm_hour not in 0 .. 24 + or else tm_min not in 0 .. 59 + or else tm_sec not in 0 .. 60 + or else tm_isdst not in -1 .. 1 + then + raise Time_Error; + end if; + + -- Step 2: Potential leap second + + if tm_sec = 60 then + Leap := True; + Second := 59; + else + Leap := False; + Second := tm_sec; + end if; + + -- Step 3: Calculate the time value + + Result := + Time_Rep + (Formatting_Operations.Time_Of + (Year => Year, + Month => Month, + Day => Day, + Day_Secs => 0.0, -- Time is given in h:m:s + Hour => tm_hour, + Minute => tm_min, + Second => Second, + Sub_Sec => 0.0, -- No precise sub second given + Leap_Sec => Leap, + Use_Day_Secs => False, -- Time is given in h:m:s + Is_Ada_05 => True, -- Force usage of explicit time zone + Time_Zone => 0)); -- Place the value in UTC + + -- Step 4: Daylight Savings Time + + if tm_isdst = 1 then + Result := Result + Time_Rep (3_600) * Nano; + end if; + + return Time (Result); + + exception + when Constraint_Error => + raise Time_Error; + end To_Ada_Time; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration + (tv_sec : Long_Integer; + tv_nsec : Long_Integer) return Duration + is + pragma Unsuppress (Overflow_Check); + begin + return Duration (tv_sec) + Duration (tv_nsec) / Nano_F; + end To_Duration; + + ------------------------ + -- To_Struct_Timespec -- + ------------------------ + + procedure To_Struct_Timespec + (D : Duration; + tv_sec : out Long_Integer; + tv_nsec : out Long_Integer) + is + pragma Unsuppress (Overflow_Check); + Secs : Duration; + Nano_Secs : Duration; + + begin + -- Seconds extraction, avoid potential rounding errors + + Secs := D - 0.5; + tv_sec := Long_Integer (Secs); + + -- Nanoseconds extraction + + Nano_Secs := D - Duration (tv_sec); + tv_nsec := Long_Integer (Nano_Secs * Nano); + end To_Struct_Timespec; + + ------------------ + -- To_Struct_Tm -- + ------------------ + + procedure To_Struct_Tm + (T : Time; + tm_year : out Integer; + tm_mon : out Integer; + tm_day : out Integer; + tm_hour : out Integer; + tm_min : out Integer; + tm_sec : out Integer) + is + pragma Unsuppress (Overflow_Check); + Year : Year_Number; + Month : Month_Number; + Second : Integer; + Day_Secs : Day_Duration; + Sub_Sec : Duration; + Leap_Sec : Boolean; + + begin + -- Step 1: Split the input time + + Formatting_Operations.Split + (T, Year, Month, tm_day, Day_Secs, + tm_hour, tm_min, Second, Sub_Sec, Leap_Sec, True, 0); + + -- Step 2: Correct the year and month + + tm_year := Year - 1900; + tm_mon := Month - 1; + + -- Step 3: Handle leap second occurrences + + if Leap_Sec then + tm_sec := 60; + else + tm_sec := Second; + end if; + end To_Struct_Tm; + + ------------------ + -- To_Unix_Time -- + ------------------ + + function To_Unix_Time (Ada_Time : Time) return Long_Integer is + pragma Unsuppress (Overflow_Check); + Ada_Rep : constant Time_Rep := Time_Rep (Ada_Time); + begin + return Long_Integer ((Ada_Rep + Epoch_Offset) / Nano); + exception + when Constraint_Error => + raise Time_Error; + end To_Unix_Time; + end Conversion_Operations; + ---------------------- -- Delay_Operations -- ---------------------- ! package body Delay_Operations is ----------------- -- To_Duration -- *************** package body Ada.Calendar is *** 780,792 **** Res_N := Time_Rep (Date); -- If the target supports leap seconds, remove any leap seconds ! -- elapsed upto the input date. if Leap_Support then Cumulative_Leap_Seconds (Start_Of_Time, Res_N, Elapsed_Leaps, Next_Leap_N); ! -- The input time value may fall on a leap second occurence if Res_N >= Next_Leap_N then Elapsed_Leaps := Elapsed_Leaps + 1; --- 980,992 ---- Res_N := Time_Rep (Date); -- If the target supports leap seconds, remove any leap seconds ! -- elapsed up to the input date. if Leap_Support then Cumulative_Leap_Seconds (Start_Of_Time, Res_N, Elapsed_Leaps, Next_Leap_N); ! -- The input time value may fall on a leap second occurrence if Res_N >= Next_Leap_N then Elapsed_Leaps := Elapsed_Leaps + 1; *************** package body Ada.Calendar is *** 805,811 **** return Time (Res_N) - Time (Unix_Min); end To_Duration; ! end Delays_Operations; --------------------------- -- Formatting_Operations -- --- 1005,1012 ---- return Time (Res_N) - Time (Unix_Min); end To_Duration; ! ! end Delay_Operations; --------------------------- -- Formatting_Operations -- *************** package body Ada.Calendar is *** 899,905 **** is -- The following constants represent the number of nanoseconds -- elapsed since the start of Ada time to and including the non ! -- leap centenial years. Year_2101 : constant Time_Rep := Ada_Low + Time_Rep (49 * 366 + 151 * 365) * Nanos_In_Day; --- 1100,1106 ---- is -- The following constants represent the number of nanoseconds -- elapsed since the start of Ada time to and including the non ! -- leap centennial years. Year_2101 : constant Time_Rep := Ada_Low + Time_Rep (49 * 366 + 151 * 365) * Nanos_In_Day; *************** package body Ada.Calendar is *** 963,973 **** end; end if; ! -- Step 3: Non-leap centenial year adjustment in local time zone -- In order for all divisions to work properly and to avoid more ! -- complicated arithmetic, we add fake Febriary 29s to dates which ! -- occur after a non-leap centenial year. if Date_N >= Year_2301 then Date_N := Date_N + Time_Rep (3) * Nanos_In_Day; --- 1164,1174 ---- end; end if; ! -- Step 3: Non-leap centennial year adjustment in local time zone -- In order for all divisions to work properly and to avoid more ! -- complicated arithmetic, we add fake February 29s to dates which ! -- occur after a non-leap centennial year. if Date_N >= Year_2301 then Date_N := Date_N + Time_Rep (3) * Nanos_In_Day; *************** package body Ada.Calendar is *** 1072,1081 **** Minute : Integer; Second : Integer; Sub_Sec : Duration; ! Leap_Sec : Boolean; ! Use_Day_Secs : Boolean; ! Is_Ada_05 : Boolean; ! Time_Zone : Long_Integer) return Time is Count : Integer; Elapsed_Leaps : Natural; --- 1273,1282 ---- Minute : Integer; Second : Integer; Sub_Sec : Duration; ! Leap_Sec : Boolean := False; ! Use_Day_Secs : Boolean := False; ! Is_Ada_05 : Boolean := False; ! Time_Zone : Long_Integer := 0) return Time is Count : Integer; Elapsed_Leaps : Natural; *************** package body Ada.Calendar is *** 1096,1109 **** Res_N := Ada_Low; ! -- Step 2: Year processing and centenial year adjustment. Determine -- the number of four year segments since the start of Ada time and -- the input date. Count := (Year - Year_Number'First) / 4; Res_N := Res_N + Time_Rep (Count) * Secs_In_Four_Years * Nano; ! -- Note that non-leap centenial years are automatically considered -- leap in the operation above. An adjustment of several days is -- required to compensate for this. --- 1297,1310 ---- Res_N := Ada_Low; ! -- Step 2: Year processing and centennial year adjustment. Determine -- the number of four year segments since the start of Ada time and -- the input date. Count := (Year - Year_Number'First) / 4; Res_N := Res_N + Time_Rep (Count) * Secs_In_Four_Years * Nano; ! -- Note that non-leap centennial years are automatically considered -- leap in the operation above. An adjustment of several days is -- required to compensate for this. *************** package body Ada.Calendar is *** 1218,1223 **** --- 1419,1425 ---- return Time (Res_N); end Time_Of; + end Formatting_Operations; --------------------------- *************** package body Ada.Calendar is *** 1236,1242 **** Time_Rep (Leap_Seconds_Count) * Nano; -- The following constants denote February 28 during non-leap ! -- centenial years, the units are nanoseconds. T_2100_2_28 : constant Time_Rep := Ada_Low + (Time_Rep (49 * 366 + 150 * 365 + 59) * Secs_In_Day + --- 1438,1444 ---- Time_Rep (Leap_Seconds_Count) * Nano; -- The following constants denote February 28 during non-leap ! -- centennial years, the units are nanoseconds. T_2100_2_28 : constant Time_Rep := Ada_Low + (Time_Rep (49 * 366 + 150 * 365 + 59) * Secs_In_Day + *************** package body Ada.Calendar is *** 1307,1314 **** begin Date_N := Time_Rep (Date); ! -- Dates which are 56 years appart fall on the same day, day light ! -- saving and so on. Non-leap centenial years violate this rule by -- one day and as a consequence, special adjustment is needed. if Date_N > T_2100_2_28 then --- 1509,1516 ---- begin Date_N := Time_Rep (Date); ! -- Dates which are 56 years apart fall on the same day, day light ! -- saving and so on. Non-leap centennial years violate this rule by -- one day and as a consequence, special adjustment is needed. if Date_N > T_2100_2_28 then *************** package body Ada.Calendar is *** 1353,1358 **** --- 1555,1561 ---- return Offset; end UTC_Time_Offset; + end Time_Zones_Operations; -- Start of elaboration code for Ada.Calendar diff -Nrcpad gcc-4.3.3/gcc/ada/a-calend.ads gcc-4.4.0/gcc/ada/a-calend.ads *** gcc-4.3.3/gcc/ada/a-calend.ads Wed Sep 12 13:11:54 2007 --- gcc-4.4.0/gcc/ada/a-calend.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 139,145 **** -- Time is represented as a signed 64 bit integer count of nanoseconds -- since the start of Ada time (1901-01-01 00:00:00.0 UTC). Time values ! -- produced by Time_Of are internaly normalized to UTC regardless of their -- local time zone. This representation ensures correct handling of leap -- seconds as well as performing arithmetic. In Ada 95, Split and Time_Of -- will treat a time value as being in the local time zone, in Ada 2005, --- 137,143 ---- -- Time is represented as a signed 64 bit integer count of nanoseconds -- since the start of Ada time (1901-01-01 00:00:00.0 UTC). Time values ! -- produced by Time_Of are internally normalized to UTC regardless of their -- local time zone. This representation ensures correct handling of leap -- seconds as well as performing arithmetic. In Ada 95, Split and Time_Of -- will treat a time value as being in the local time zone, in Ada 2005, *************** private *** 155,161 **** -- Due to Earth's slowdown, the astronomical time is not as precise as the -- International Atomic Time. To compensate for this inaccuracy, a single -- leap second is added after the last day of June or December. The count ! -- of seconds during those occurences becomes: -- ... 58, 59, leap second 60, 0, 1, 2 ... --- 153,159 ---- -- Due to Earth's slowdown, the astronomical time is not as precise as the -- International Atomic Time. To compensate for this inaccuracy, a single -- leap second is added after the last day of June or December. The count ! -- of seconds during those occurrences becomes: -- ... 58, 59, leap second 60, 0, 1, 2 ... *************** private *** 183,198 **** -- aggregate generated by xleaps -- The algorithms that build the actual leap second values and discover ! -- how many leap seconds have occured between two dates do not need any -- modification. ------------------------------ ! -- Non-leap centenial years -- ------------------------------ ! -- Over the range of Ada time, centenial years 2100, 2200 and 2300 are -- non-leap. As a consequence, seven non-leap years occur over the period ! -- of year - 4 to year + 4. Internaly, routines Split and Time_Of add or -- subtract a "fake" February 29 to facilitate the arithmetic involved. -- The underlying type of Time has been chosen to be a 64 bit signed --- 181,196 ---- -- aggregate generated by xleaps -- The algorithms that build the actual leap second values and discover ! -- how many leap seconds have occurred between two dates do not need any -- modification. ------------------------------ ! -- Non-leap centennial years -- ------------------------------ ! -- Over the range of Ada time, centennial years 2100, 2200 and 2300 are -- non-leap. As a consequence, seven non-leap years occur over the period ! -- of year - 4 to year + 4. Internally, routines Split and Time_Of add or -- subtract a "fake" February 29 to facilitate the arithmetic involved. -- The underlying type of Time has been chosen to be a 64 bit signed *************** private *** 212,220 **** -- Determine whether a given year is leap -- The following packages provide a target independent interface to the ! -- children of Calendar - Arithmetic, Delays, Formatting and Time_Zones. package Arithmetic_Operations is function Add (Date : Time; Days : Long_Integer) return Time; -- Add a certain number of days to a time value --- 210,224 ---- -- Determine whether a given year is leap -- The following packages provide a target independent interface to the ! -- children of Calendar - Arithmetic, Conversions, Delays, Formatting and ! -- Time_Zones. ! ! --------------------------- ! -- Arithmetic_Operations -- ! --------------------------- package Arithmetic_Operations is + function Add (Date : Time; Days : Long_Integer) return Time; -- Add a certain number of days to a time value *************** private *** 231,245 **** function Subtract (Date : Time; Days : Long_Integer) return Time; -- Subtract a certain number of days from a time value end Arithmetic_Operations; ! package Delays_Operations is function To_Duration (Date : Time) return Duration; -- Given a time value in nanoseconds since 1901, convert it into a -- duration value giving the number of nanoseconds since the Unix Epoch. ! end Delays_Operations; package Formatting_Operations is function Day_Of_Week (Date : Time) return Integer; -- Determine which day of week Date falls on. The returned values are -- within the range of 0 .. 6 (Monday .. Sunday). --- 235,306 ---- function Subtract (Date : Time; Days : Long_Integer) return Time; -- Subtract a certain number of days from a time value + end Arithmetic_Operations; ! --------------------------- ! -- Conversion_Operations -- ! --------------------------- ! ! package Conversion_Operations is ! ! function To_Ada_Time (Unix_Time : Long_Integer) return Time; ! -- Unix to Ada Epoch conversion ! ! function To_Ada_Time ! (tm_year : Integer; ! tm_mon : Integer; ! tm_day : Integer; ! tm_hour : Integer; ! tm_min : Integer; ! tm_sec : Integer; ! tm_isdst : Integer) return Time; ! -- Struct tm to Ada Epoch conversion ! ! function To_Duration ! (tv_sec : Long_Integer; ! tv_nsec : Long_Integer) return Duration; ! -- Struct timespec to Duration conversion ! ! procedure To_Struct_Timespec ! (D : Duration; ! tv_sec : out Long_Integer; ! tv_nsec : out Long_Integer); ! -- Duration to struct timespec conversion ! ! procedure To_Struct_Tm ! (T : Time; ! tm_year : out Integer; ! tm_mon : out Integer; ! tm_day : out Integer; ! tm_hour : out Integer; ! tm_min : out Integer; ! tm_sec : out Integer); ! -- Time to struct tm conversion ! ! function To_Unix_Time (Ada_Time : Time) return Long_Integer; ! -- Ada to Unix Epoch conversion ! ! end Conversion_Operations; ! ! ---------------------- ! -- Delay_Operations -- ! ---------------------- ! ! package Delay_Operations is ! function To_Duration (Date : Time) return Duration; -- Given a time value in nanoseconds since 1901, convert it into a -- duration value giving the number of nanoseconds since the Unix Epoch. ! ! end Delay_Operations; ! ! --------------------------- ! -- Formatting_Operations -- ! --------------------------- package Formatting_Operations is + function Day_Of_Week (Date : Time) return Integer; -- Determine which day of week Date falls on. The returned values are -- within the range of 0 .. 6 (Monday .. Sunday). *************** private *** 270,290 **** Minute : Integer; Second : Integer; Sub_Sec : Duration; ! Leap_Sec : Boolean; ! Use_Day_Secs : Boolean; ! Is_Ada_05 : Boolean; ! Time_Zone : Long_Integer) return Time; -- Given all the components of a date, return the corresponding time -- value. Set Use_Day_Secs to use the value in Day_Secs, otherwise the -- day duration will be calculated from Hour, Minute, Second and Sub_ -- Sec. Set Is_Ada_05 to use the local time zone (the value in formal -- Time_Zone is ignored) when building a time value and to verify the -- validity of a requested leap second. end Formatting_Operations; package Time_Zones_Operations is function UTC_Time_Offset (Date : Time) return Long_Integer; -- Return the offset in seconds from UTC end Time_Zones_Operations; end Ada.Calendar; --- 331,358 ---- Minute : Integer; Second : Integer; Sub_Sec : Duration; ! Leap_Sec : Boolean := False; ! Use_Day_Secs : Boolean := False; ! Is_Ada_05 : Boolean := False; ! Time_Zone : Long_Integer := 0) return Time; -- Given all the components of a date, return the corresponding time -- value. Set Use_Day_Secs to use the value in Day_Secs, otherwise the -- day duration will be calculated from Hour, Minute, Second and Sub_ -- Sec. Set Is_Ada_05 to use the local time zone (the value in formal -- Time_Zone is ignored) when building a time value and to verify the -- validity of a requested leap second. + end Formatting_Operations; + --------------------------- + -- Time_Zones_Operations -- + --------------------------- + package Time_Zones_Operations is + function UTC_Time_Offset (Date : Time) return Long_Integer; -- Return the offset in seconds from UTC + end Time_Zones_Operations; end Ada.Calendar; diff -Nrcpad gcc-4.3.3/gcc/ada/a-calfor.adb gcc-4.4.0/gcc/ada/a-calfor.adb *** gcc-4.3.3/gcc/ada/a-calfor.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-calfor.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 34,41 **** with Ada.Calendar; use Ada.Calendar; with Ada.Calendar.Time_Zones; use Ada.Calendar.Time_Zones; - pragma Warnings (Off); -- temp till we fix out param warnings ??? - package body Ada.Calendar.Formatting is -------------------------- --- 32,37 ---- *************** package body Ada.Calendar.Formatting is *** 47,53 **** procedure Check_Char (S : String; C : Character; Index : Integer); -- Subsidiary to the two versions of Value. Determine whether the ! -- input strint S has character C at position Index. Raise -- Constraint_Error if there is a mismatch. procedure Check_Digit (S : String; Index : Integer); --- 43,49 ---- procedure Check_Char (S : String; C : Character; Index : Integer); -- Subsidiary to the two versions of Value. Determine whether the ! -- input string S has character C at position Index. Raise -- Constraint_Error if there is a mismatch. procedure Check_Digit (S : String; Index : Integer); diff -Nrcpad gcc-4.3.3/gcc/ada/a-calfor.ads gcc-4.4.0/gcc/ada/a-calfor.ads *** gcc-4.3.3/gcc/ada/a-calfor.ads Fri Apr 6 09:15:21 2007 --- gcc-4.4.0/gcc/ada/a-calfor.ads Fri Feb 20 15:20:38 2009 *************** *** 6,37 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. The copyright notice above, and the license provisions that follow -- ! -- apply solely to the contents of the part following the private keyword. -- ! -- -- ! -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- ! -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- ! -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- ! -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 6,17 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. In accordance with the copyright of that document, you can freely -- ! -- copy and modify this specification, provided that if you redistribute a -- ! -- modified version, any changes that you have made are clearly indicated. -- -- -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-catizo.adb gcc-4.4.0/gcc/ada/a-catizo.adb *** gcc-4.3.3/gcc/ada/a-catizo.adb Fri Apr 6 09:15:21 2007 --- gcc-4.4.0/gcc/ada/a-catizo.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-catizo.ads gcc-4.4.0/gcc/ada/a-catizo.ads *** gcc-4.3.3/gcc/ada/a-catizo.ads Fri Apr 6 09:15:21 2007 --- gcc-4.4.0/gcc/ada/a-catizo.ads Fri Feb 20 15:20:38 2009 *************** *** 6,37 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. The copyright notice above, and the license provisions that follow -- ! -- apply solely to the contents of the part following the private keyword. -- ! -- -- ! -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- ! -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- ! -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- ! -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 6,17 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. In accordance with the copyright of that document, you can freely -- ! -- copy and modify this specification, provided that if you redistribute a -- ! -- modified version, any changes that you have made are clearly indicated. -- -- -- ------------------------------------------------------------------------------ *************** package Ada.Calendar.Time_Zones is *** 47,55 **** Unknown_Zone_Error : exception; function UTC_Time_Offset (Date : Time := Clock) return Time_Offset; ! -- Returns, as a number of minutes, the difference between the ! -- implementation-defined time zone of Calendar, and UTC time, at the time ! -- Date. If the time zone of the Calendar implementation is unknown, then ! -- Unknown_Zone_Error is raised. end Ada.Calendar.Time_Zones; --- 27,34 ---- Unknown_Zone_Error : exception; function UTC_Time_Offset (Date : Time := Clock) return Time_Offset; ! -- Returns (in minutes), the difference between the implementation-defined ! -- time zone of Calendar, and UTC time, at the time Date. If the time zone ! -- of the Calendar implementation is unknown, raises Unknown_Zone_Error. end Ada.Calendar.Time_Zones; diff -Nrcpad gcc-4.3.3/gcc/ada/a-cdlili.adb gcc-4.4.0/gcc/ada/a-cdlili.adb *** gcc-4.3.3/gcc/ada/a-cdlili.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-cdlili.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-cdlili.ads gcc-4.4.0/gcc/ada/a-cdlili.ads *** gcc-4.3.3/gcc/ada/a-cdlili.ads Tue Aug 14 08:45:48 2007 --- gcc-4.4.0/gcc/ada/a-cdlili.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,40 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! with Ada.Finalization; ! with Ada.Streams; generic type Element_Type is private; --- 14,38 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! private with Ada.Finalization; ! private with Ada.Streams; generic type Element_Type is private; *************** private *** 230,237 **** --- 228,237 ---- Lock : Natural := 0; end record; + overriding procedure Adjust (Container : in out List); + overriding procedure Finalize (Container : in out List) renames Clear; use Ada.Streams; diff -Nrcpad gcc-4.3.3/gcc/ada/a-cgaaso.adb gcc-4.4.0/gcc/ada/a-cgaaso.adb *** gcc-4.3.3/gcc/ada/a-cgaaso.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-cgaaso.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- G E N E R I C _ A N O N Y M O U S _ A R R A Y _ S O R T -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.GENERIC_ANONYMOUS_ARRAY_SORT -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-cgaaso.ads gcc-4.4.0/gcc/ada/a-cgaaso.ads *** gcc-4.3.3/gcc/ada/a-cgaaso.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-cgaaso.ads Thu Apr 9 23:23:07 2009 *************** *** 2,39 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- G E N E R I C _ A N O N Y M O U S _ A R R A Y _ S O R T -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- ! -- -- ! -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. The copyright notice above, and the license provisions that follow -- ! -- apply solely to the contents of the part following the private keyword. -- -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ generic type Index_Type is (<>); with function Less (Left, Right : Index_Type) return Boolean is <>; --- 2,36 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.GENERIC_ANONYMOUS_ARRAY_SORT -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ + -- Allows an anonymous array (or array-like container) to be sorted. Generic + -- formal Less returns the result of comparing the elements designated by the + -- indices, and generic formal Swap exchanges the designated elements. + generic type Index_Type is (<>); with function Less (Left, Right : Index_Type) return Boolean is <>; *************** generic *** 41,45 **** procedure Ada.Containers.Generic_Anonymous_Array_Sort (First, Last : Index_Type'Base); - pragma Pure (Ada.Containers.Generic_Anonymous_Array_Sort); --- 38,41 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/a-cgarso.adb gcc-4.4.0/gcc/ada/a-cgarso.adb *** gcc-4.3.3/gcc/ada/a-cgarso.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-cgarso.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-cgcaso.adb gcc-4.4.0/gcc/ada/a-cgcaso.adb *** gcc-4.3.3/gcc/ada/a-cgcaso.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-cgcaso.adb Thu Apr 9 23:23:07 2009 *************** *** 2,33 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- G E N E R I C _ C O N S T R A I N E D _ A R R A Y _ S O R T -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- ! -- This unit has originally being developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -- This algorithm was adapted from GNAT.Heap_Sort_G (see g-hesorg.ad[sb]) --- 2,30 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.GENERIC_CONSTRAINED_ARRAY_SORT -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- ! -- -- ! -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -- This algorithm was adapted from GNAT.Heap_Sort_G (see g-hesorg.ad[sb]) *************** is *** 92,105 **** while C /= S loop declare ! Father : constant T := C / 2; ! Father_Elem : Element_Type renames A (To_Index (Father)); ! begin ! if Father_Elem < Temp then -- Lt (Father, 0) ! A (To_Index (C)) := Father_Elem; -- Move (Father, C) C := Father; - else exit; end if; --- 89,99 ---- while C /= S loop declare ! Father : constant T := C / 2; begin ! if A (To_Index (Father)) < Temp then -- Lt (Father, 0) ! A (To_Index (C)) := A (To_Index (Father)); -- Move (Father, C) C := Father; else exit; end if; *************** begin *** 118,129 **** end loop; while Max > 1 loop ! declare ! Max_Elem : Element_Type renames A (To_Index (Max)); ! begin ! Temp := Max_Elem; -- Move (Max, 0); ! Max_Elem := A (A'First); -- Move (1, Max); ! end; Max := Max - 1; Sift (1); --- 112,119 ---- end loop; while Max > 1 loop ! Temp := A (To_Index (Max)); -- Move (Max, 0); ! A (To_Index (Max)) := A (A'First); -- Move (1, Max); Max := Max - 1; Sift (1); diff -Nrcpad gcc-4.3.3/gcc/ada/a-cgcaso.ads gcc-4.4.0/gcc/ada/a-cgcaso.ads *** gcc-4.3.3/gcc/ada/a-cgcaso.ads Fri Apr 6 09:43:23 2007 --- gcc-4.4.0/gcc/ada/a-cgcaso.ads Mon Mar 24 10:57:32 2008 *************** *** 2,9 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- G E N E R I C _ C O N S T R A I N E D _ A R R A Y _ S O R T -- -- -- -- S p e c -- -- -- --- 2,8 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.GENERIC_CONSTRAINED_ARRAY_SORT -- -- -- -- S p e c -- -- -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-chacon.adb gcc-4.4.0/gcc/ada/a-chacon.adb *** gcc-4.3.3/gcc/ada/a-chacon.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-chacon.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-chacon.ads gcc-4.4.0/gcc/ada/a-chacon.ads *** gcc-4.3.3/gcc/ada/a-chacon.ads Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-chacon.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-chahan.adb gcc-4.4.0/gcc/ada/a-chahan.adb *** gcc-4.3.3/gcc/ada/a-chahan.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-chahan.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-chahan.ads gcc-4.4.0/gcc/ada/a-chahan.ads *** gcc-4.3.3/gcc/ada/a-chahan.ads Wed Jun 6 10:17:28 2007 --- gcc-4.4.0/gcc/ada/a-chahan.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Ada.Characters.Handling is *** 94,100 **** -- Ada 2005 AI 395: these functions are moved to Ada.Characters.Conversions -- and are considered obsolete in Ada.Characters.Handling. However we do -- not complain about this obsolescence, since in practice it is necessary ! -- to use these routines when creating code that is intended ro run in -- either Ada 95 or Ada 2005 mode. function Is_Character (Item : Wide_Character) return Boolean; --- 92,98 ---- -- Ada 2005 AI 395: these functions are moved to Ada.Characters.Conversions -- and are considered obsolete in Ada.Characters.Handling. However we do -- not complain about this obsolescence, since in practice it is necessary ! -- to use these routines when creating code that is intended to run in -- either Ada 95 or Ada 2005 mode. function Is_Character (Item : Wide_Character) return Boolean; *************** package Ada.Characters.Handling is *** 107,113 **** -- Ada 2005 AI 395: these functions are moved to Ada.Characters.Conversions -- and are considered obsolete in Ada.Characters.Handling. However we do -- not complain about this obsolescence, since in practice it is necessary ! -- to use these routines when creating code that is intended ro run in -- either Ada 95 or Ada 2005 mode. function To_Character --- 105,111 ---- -- Ada 2005 AI 395: these functions are moved to Ada.Characters.Conversions -- and are considered obsolete in Ada.Characters.Handling. However we do -- not complain about this obsolescence, since in practice it is necessary ! -- to use these routines when creating code that is intended to run in -- either Ada 95 or Ada 2005 mode. function To_Character diff -Nrcpad gcc-4.3.3/gcc/ada/a-chlat9.ads gcc-4.4.0/gcc/ada/a-chlat9.ads *** gcc-4.3.3/gcc/ada/a-chlat9.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-chlat9.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-chtgke.adb gcc-4.4.0/gcc/ada/a-chtgke.adb *** gcc-4.3.3/gcc/ada/a-chtgke.adb Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/a-chtgke.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- H A S H _ T A B L E S . G E N E R I C _ K E Y S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ *************** package body Ada.Containers.Hash_Tables. *** 247,253 **** end loop; -- We have determined that Key is not already in the hash table, so ! -- the change is tenatively allowed. We now perform the standard -- checks to determine whether the hash table is locked (because you -- cannot change an element while it's in use by Query_Element or -- Update_Element), or if the container is busy (because moving a --- 244,250 ---- end loop; -- We have determined that Key is not already in the hash table, so ! -- the change is tentatively allowed. We now perform the standard -- checks to determine whether the hash table is locked (because you -- cannot change an element while it's in use by Query_Element or -- Update_Element), or if the container is busy (because moving a diff -Nrcpad gcc-4.3.3/gcc/ada/a-chtgke.ads gcc-4.4.0/gcc/ada/a-chtgke.ads *** gcc-4.3.3/gcc/ada/a-chtgke.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-chtgke.ads Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- H A S H _ T A B L E S . G E N E R I C _ K E Y S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-chtgop.adb gcc-4.4.0/gcc/ada/a-chtgop.adb *** gcc-4.3.3/gcc/ada/a-chtgop.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-chtgop.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- H A S H _ T A B L E S . G E N E R I C _ O P E R A T I O N S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ *************** with System; use type System.Address; *** 38,46 **** package body Ada.Containers.Hash_Tables.Generic_Operations is type Buckets_Allocation is access all Buckets_Type; ! -- Used for allocation and deallocation (see New_Buckets and ! -- Free_Buckets). This is necessary because Buckets_Access has an empty ! -- storage pool. ------------ -- Adjust -- --- 35,42 ---- package body Ada.Containers.Hash_Tables.Generic_Operations is type Buckets_Allocation is access all Buckets_Type; ! -- Used for allocation and deallocation (see New_Buckets and Free_Buckets). ! -- This is necessary because Buckets_Access has an empty storage pool. ------------ -- Adjust -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-chtgop.ads gcc-4.4.0/gcc/ada/a-chtgop.ads *** gcc-4.3.3/gcc/ada/a-chtgop.ads Tue Aug 14 08:45:48 2007 --- gcc-4.4.0/gcc/ada/a-chtgop.ads Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- H A S H _ T A B L E S . G E N E R I C _ O P E R A T I O N S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ *************** package Ada.Containers.Hash_Tables.Gener *** 165,175 **** function New_Buckets (Length : Hash_Type) return Buckets_Access; pragma Inline (New_Buckets); ! -- Allocate a new Buckets_Type array with bounds 0..Length-1. procedure Free_Buckets (Buckets : in out Buckets_Access); pragma Inline (Free_Buckets); ! -- Unchecked_Deallocate Buckets. -- Note: New_Buckets and Free_Buckets are needed because Buckets_Access has -- an empty pool. --- 162,172 ---- function New_Buckets (Length : Hash_Type) return Buckets_Access; pragma Inline (New_Buckets); ! -- Allocate a new Buckets_Type array with bounds 0..Length-1 procedure Free_Buckets (Buckets : in out Buckets_Access); pragma Inline (Free_Buckets); ! -- Unchecked_Deallocate Buckets -- Note: New_Buckets and Free_Buckets are needed because Buckets_Access has -- an empty pool. diff -Nrcpad gcc-4.3.3/gcc/ada/a-chzla1.ads gcc-4.4.0/gcc/ada/a-chzla1.ads *** gcc-4.3.3/gcc/ada/a-chzla1.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-chzla1.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-chzla9.ads gcc-4.4.0/gcc/ada/a-chzla9.ads *** gcc-4.3.3/gcc/ada/a-chzla9.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-chzla9.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-cidlli.adb gcc-4.4.0/gcc/ada/a-cidlli.adb *** gcc-4.3.3/gcc/ada/a-cidlli.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-cidlli.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- I N D E F I N I T E _ D O U B L Y _ L I N K E D _ L I S T S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-cidlli.ads gcc-4.4.0/gcc/ada/a-cidlli.ads *** gcc-4.3.3/gcc/ada/a-cidlli.ads Tue Aug 14 08:45:48 2007 --- gcc-4.4.0/gcc/ada/a-cidlli.ads Thu Apr 9 23:23:07 2009 *************** *** 2,13 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- I N D E F I N I T E _ D O U B L Y _ L I N K E D _ L I S T S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 2,12 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,41 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! with Ada.Finalization; ! with Ada.Streams; generic type Element_Type (<>) is private; --- 14,38 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! private with Ada.Finalization; ! private with Ada.Streams; generic type Element_Type (<>) is private; *************** private *** 223,230 **** --- 220,229 ---- Lock : Natural := 0; end record; + overriding procedure Adjust (Container : in out List); + overriding procedure Finalize (Container : in out List) renames Clear; use Ada.Streams; diff -Nrcpad gcc-4.3.3/gcc/ada/a-cihama.adb gcc-4.4.0/gcc/ada/a-cihama.adb *** gcc-4.3.3/gcc/ada/a-cihama.adb Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/a-cihama.adb Thu Apr 9 23:23:07 2009 *************** *** 2,33 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- I N D E F I N I T E _ H A S H E D _ M A P S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- ! -- This unit has originally being developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with Ada.Containers.Hash_Tables.Generic_Operations; --- 2,30 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- ! -- -- ! -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with Ada.Containers.Hash_Tables.Generic_Operations; diff -Nrcpad gcc-4.3.3/gcc/ada/a-cihama.ads gcc-4.4.0/gcc/ada/a-cihama.ads *** gcc-4.3.3/gcc/ada/a-cihama.ads Thu Dec 13 10:42:54 2007 --- gcc-4.4.0/gcc/ada/a-cihama.ads Thu Apr 9 23:23:07 2009 *************** *** 2,13 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- I N D E F I N I T E _ H A S H E D _ M A P S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 2,12 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ *************** package Ada.Containers.Indefinite_Hashed *** 82,88 **** procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type); -- Adjusts the current capacity, by allocating a new buckets array. If the -- requested capacity is less than the current capacity, then the capacity ! -- is contracted (to a value not less than the curent length). If the -- requested capacity is greater than the current capacity, then the -- capacity is expanded (to a value not less than what is requested). In -- either case, the nodes are rehashed from the old buckets array onto the --- 79,85 ---- procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type); -- Adjusts the current capacity, by allocating a new buckets array. If the -- requested capacity is less than the current capacity, then the capacity ! -- is contracted (to a value not less than the current length). If the -- requested capacity is greater than the current capacity, then the -- capacity is expanded (to a value not less than what is requested). In -- either case, the nodes are rehashed from the old buckets array onto the *************** package Ada.Containers.Indefinite_Hashed *** 192,198 **** procedure Delete (Container : in out Map; Key : Key_Type); -- Searches for Key in the map (which involves calling both Hash and -- Equivalent_Keys). If the search fails, then the operation raises ! -- Constraint_Eror. Otherwise it removes the node from the map and then -- deallocates it. (This is the deletion analog of non-conditional -- Insert. It is intended for use when you want to assert that the item is -- already in the map.) --- 189,195 ---- procedure Delete (Container : in out Map; Key : Key_Type); -- Searches for Key in the map (which involves calling both Hash and -- Equivalent_Keys). If the search fails, then the operation raises ! -- Constraint_Error. Otherwise it removes the node from the map and then -- deallocates it. (This is the deletion analog of non-conditional -- Insert. It is intended for use when you want to assert that the item is -- already in the map.) diff -Nrcpad gcc-4.3.3/gcc/ada/a-cihase.adb gcc-4.4.0/gcc/ada/a-cihase.adb *** gcc-4.3.3/gcc/ada/a-cihase.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-cihase.adb Thu Apr 9 23:23:07 2009 *************** *** 2,33 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- I N D E F I N I T E _ H A S H E D _ S E T S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- ! -- This unit has originally being developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; --- 2,30 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.INDEFINITE_HASHED_SETS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- ! -- -- ! -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; diff -Nrcpad gcc-4.3.3/gcc/ada/a-cihase.ads gcc-4.4.0/gcc/ada/a-cihase.ads *** gcc-4.3.3/gcc/ada/a-cihase.ads Thu Dec 13 10:42:54 2007 --- gcc-4.4.0/gcc/ada/a-cihase.ads Thu Apr 9 23:23:07 2009 *************** *** 2,13 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- I N D E F I N I T E _ H A S H E D _ S E T S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 2,12 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.INDEFINITE_HASHED_SETS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,42 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! with Ada.Containers.Hash_Tables; ! with Ada.Streams; ! with Ada.Finalization; generic type Element_Type (<>) is private; --- 14,39 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! private with Ada.Containers.Hash_Tables; ! private with Ada.Streams; ! private with Ada.Finalization; generic type Element_Type (<>) is private; *************** private *** 417,424 **** --- 414,423 ---- HT : HT_Types.Hash_Table_Type; end record; + overriding procedure Adjust (Container : in out Set); + overriding procedure Finalize (Container : in out Set); use HT_Types; diff -Nrcpad gcc-4.3.3/gcc/ada/a-ciorma.adb gcc-4.4.0/gcc/ada/a-ciorma.adb *** gcc-4.3.3/gcc/ada/a-ciorma.adb Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/a-ciorma.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- I N D E F I N I T E _ O R D E R E D _ M A P S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-ciorma.ads gcc-4.4.0/gcc/ada/a-ciorma.ads *** gcc-4.3.3/gcc/ada/a-ciorma.ads Tue Aug 14 08:45:48 2007 --- gcc-4.4.0/gcc/ada/a-ciorma.ads Thu Apr 9 23:23:07 2009 *************** *** 2,13 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- I N D E F I N I T E _ O R D E R E D _ M A P S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 2,12 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,42 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! with Ada.Containers.Red_Black_Trees; ! with Ada.Finalization; ! with Ada.Streams; generic type Key_Type (<>) is private; --- 14,39 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! private with Ada.Containers.Red_Black_Trees; ! private with Ada.Finalization; ! private with Ada.Streams; generic type Key_Type (<>) is private; *************** private *** 203,210 **** --- 200,209 ---- Tree : Tree_Types.Tree_Type; end record; + overriding procedure Adjust (Container : in out Map); + overriding procedure Finalize (Container : in out Map) renames Clear; use Red_Black_Trees; diff -Nrcpad gcc-4.3.3/gcc/ada/a-ciormu.adb gcc-4.4.0/gcc/ada/a-ciormu.adb *** gcc-4.3.3/gcc/ada/a-ciormu.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-ciormu.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- I N D E F I N I T E _ O R D E R E D _ M U L T I S E T S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-ciormu.ads gcc-4.4.0/gcc/ada/a-ciormu.ads *** gcc-4.3.3/gcc/ada/a-ciormu.ads Tue Aug 14 08:45:48 2007 --- gcc-4.4.0/gcc/ada/a-ciormu.ads Thu Apr 9 23:23:07 2009 *************** *** 2,42 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- I N D E F I N I T E _ O R D E R E D _ M U L T I S E T S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- ! -- -- ! -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. The copyright notice above, and the license provisions that follow -- ! -- apply solely to the contents of the part following the private keyword. -- -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! with Ada.Containers.Red_Black_Trees; ! with Ada.Finalization; ! with Ada.Streams; generic type Element_Type (<>) is private; --- 2,40 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! -- The indefinite ordered multiset container is similar to the indefinite ! -- ordered set, but with the difference that multiple equivalent elements are ! -- allowed. It also provides additional operations, to iterate over items that ! -- are equivalent. ! ! private with Ada.Containers.Red_Black_Trees; ! private with Ada.Finalization; ! private with Ada.Streams; generic type Element_Type (<>) is private; *************** package Ada.Containers.Indefinite_Ordere *** 49,54 **** --- 47,54 ---- pragma Remote_Types; function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + -- Returns False if Left is less than Right, or Right is less than Left; + -- otherwise, it returns True. type Set is tagged private; pragma Preelaborable_Initialization (Set); *************** package Ada.Containers.Indefinite_Ordere *** 57,96 **** --- 57,147 ---- pragma Preelaborable_Initialization (Cursor); Empty_Set : constant Set; + -- The default value for set objects declared without an explicit + -- initialization expression. No_Element : constant Cursor; + -- The default value for cursor objects declared without an explicit + -- initialization expression. function "=" (Left, Right : Set) return Boolean; + -- If Left denotes the same set object as Right, then equality returns + -- True. If the length of Left is different from the length of Right, then + -- it returns False. Otherwise, set equality iterates over Left and Right, + -- comparing the element of Left to the element of Right using the equality + -- operator for elements. If the elements compare False, then the iteration + -- terminates and set equality returns False. Otherwise, if all elements + -- compare True, then set equality returns True. function Equivalent_Sets (Left, Right : Set) return Boolean; + -- Similar to set equality, but with the difference that elements are + -- compared for equivalence instead of equality. function To_Set (New_Item : Element_Type) return Set; + -- Constructs a set object with New_Item as its single element function Length (Container : Set) return Count_Type; + -- Returns the total number of elements in Container function Is_Empty (Container : Set) return Boolean; + -- Returns True if Container.Length is 0 procedure Clear (Container : in out Set); + -- Deletes all elements from Container function Element (Position : Cursor) return Element_Type; + -- If Position equals No_Element, then Constraint_Error is raised. + -- Otherwise, function Element returns the element designed by Position. procedure Replace_Element (Container : in out Set; Position : Cursor; New_Item : Element_Type); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a set different from Container, then + -- Program_Error is raised. If New_Item is equivalent to the element + -- designated by Position, then if Container is locked (element tampering + -- has been attempted), Program_Error is raised; otherwise, the element + -- designated by Position is assigned the value of New_Item. If New_Item is + -- not equivalent to the element designated by Position, then if the + -- container is busy (cursor tampering has been attempted), Program_Error + -- is raised; otherwise, the element designed by Position is assigned the + -- value of New_Item, and the node is moved to its new position (in + -- canonical insertion order). procedure Query_Element (Position : Cursor; Process : not null access procedure (Element : Element_Type)); + -- If Position equals No_Element, then Constraint_Error is + -- raised. Otherwise, it calls Process with the element designated by + -- Position as the parameter. This call locks the container, so attempts to + -- change the value of the element while Process is executing (to "tamper + -- with elements") will raise Program_Error. procedure Move (Target : in out Set; Source : in out Set); + -- If Target denotes the same object as Source, the operation does + -- nothing. If either Target or Source is busy (cursor tampering is + -- attempted), then it raises Program_Error. Otherwise, Target is cleared, + -- and the nodes from Source are moved (not copied) to Target (so Source + -- becomes empty). procedure Insert (Container : in out Set; New_Item : Element_Type; Position : out Cursor); + -- Insert adds New_Item to Container, and returns cursor Position + -- designating the newly inserted node. The node is inserted after any + -- existing elements less than or equivalent to New_Item (and before any + -- elements greater than New_Item). Note that the issue of where the new + -- node is inserted relative to equivalent elements does not arise for + -- unique-key containers, since in that case the insertion would simply + -- fail. For a multiple-key container (the case here), insertion always + -- succeeds, and is defined such that the new item is positioned after any + -- equivalent elements already in the container. procedure Insert (Container : in out Set; New_Item : Element_Type); + -- Inserts New_Item in Container, but does not return a cursor designating + -- the newly-inserted node. -- TODO: include Replace too??? -- *************** package Ada.Containers.Indefinite_Ordere *** 99,196 **** --- 150,333 ---- -- New_Item : Element_Type); procedure Exclude (Container : in out Set; Item : Element_Type); + -- Deletes from Container all of the elements equivalent to Item procedure Delete (Container : in out Set; Item : Element_Type); + -- Deletes from Container all of the elements equivalent to Item. If there + -- are no elements equivalent to Item, then it raises Constraint_Error. procedure Delete (Container : in out Set; Position : in out Cursor); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a set different from Container, then + -- Program_Error is raised. Otherwise, the node designated by Position is + -- removed from Container, and Position is set to No_Element. procedure Delete_First (Container : in out Set); + -- Removes the first node from Container procedure Delete_Last (Container : in out Set); + -- Removes the last node from Container procedure Union (Target : in out Set; Source : Set); + -- If Target is busy (cursor tampering is attempted), then Program_Error is + -- raised. Otherwise, it inserts each element of Source into Target. + -- Elements are inserted in the canonical order for multisets, such that + -- the elements from Source are inserted after equivalent elements already + -- in Target. function Union (Left, Right : Set) return Set; + -- Returns a set comprising the all elements from Left and all of the + -- elements from Right. The elements from Right follow the equivalent + -- elements from Left. function "or" (Left, Right : Set) return Set renames Union; procedure Intersection (Target : in out Set; Source : Set); + -- If Target denotes the same object as Source, the operation does + -- nothing. If Target is busy (cursor tampering is attempted), + -- Program_Error is raised. Otherwise, the elements in Target having no + -- equivalent element in Source are deleted from Target. function Intersection (Left, Right : Set) return Set; + -- If Left denotes the same object as Right, then the function returns a + -- copy of Left. Otherwise, it returns a set comprising the equivalent + -- elements from both Left and Right. Items are inserted in the result set + -- in canonical order, such that the elements from Left precede the + -- equivalent elements from Right. function "and" (Left, Right : Set) return Set renames Intersection; procedure Difference (Target : in out Set; Source : Set); + -- If Target is busy (cursor tampering is attempted), then Program_Error is + -- raised. Otherwise, the elements in Target that are equivalent to + -- elements in Source are deleted from Target. function Difference (Left, Right : Set) return Set; + -- Returns a set comprising the elements from Left that have no equivalent + -- element in Right. function "-" (Left, Right : Set) return Set renames Difference; procedure Symmetric_Difference (Target : in out Set; Source : Set); + -- If Target is busy, then Program_Error is raised. Otherwise, the elements + -- in Target equivalent to elements in Source are deleted from Target, and + -- the elements in Source not equivalent to elements in Target are inserted + -- into Target. function Symmetric_Difference (Left, Right : Set) return Set; + -- Returns a set comprising the union of the elements from Target having no + -- equivalent in Source, and the elements of Source having no equivalent in + -- Target. function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; function Overlap (Left, Right : Set) return Boolean; + -- Returns True if Left contains an element equivalent to an element of + -- Right. function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + -- Returns True if every element in Subset has an equivalent element in + -- Of_Set. function First (Container : Set) return Cursor; + -- If Container is empty, the function returns No_Element. Otherwise, it + -- returns a cursor designating the smallest element. function First_Element (Container : Set) return Element_Type; + -- Equivalent to Element (First (Container)) function Last (Container : Set) return Cursor; + -- If Container is empty, the function returns No_Element. Otherwise, it + -- returns a cursor designating the largest element. function Last_Element (Container : Set) return Element_Type; + -- Equivalent to Element (Last (Container)) function Next (Position : Cursor) return Cursor; + -- If Position equals No_Element or Last (Container), the function returns + -- No_Element. Otherwise, it returns a cursor designating the node that + -- immediately follows (as per the insertion order) the node designated by + -- Position. procedure Next (Position : in out Cursor); + -- Equivalent to Position := Next (Position) function Previous (Position : Cursor) return Cursor; + -- If Position equals No_Element or First (Container), the function returns + -- No_Element. Otherwise, it returns a cursor designating the node that + -- immediately precedes (as per the insertion order) the node designated by + -- Position. procedure Previous (Position : in out Cursor); + -- Equivalent to Position := Previous (Position) function Find (Container : Set; Item : Element_Type) return Cursor; + -- Returns a cursor designating the first element in Container equivalent + -- to Item. If there is no equivalent element, it returns No_Element. function Floor (Container : Set; Item : Element_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to elements in Container, it returns a cursor designating the + -- first equivalent element. Otherwise, it returns a cursor designating the + -- largest element less than Item, or No_Element if all elements are + -- greater than Item. function Ceiling (Container : Set; Item : Element_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to elements of Container, it returns a cursor designating the + -- last equivalent element. Otherwise, it returns a cursor designating the + -- smallest element greater than Item, or No_Element if all elements are + -- less than Item. function Contains (Container : Set; Item : Element_Type) return Boolean; + -- Equivalent to Container.Find (Item) /= No_Element function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element function "<" (Left, Right : Cursor) return Boolean; + -- Equivalent to Element (Left) < Element (Right) function ">" (Left, Right : Cursor) return Boolean; + -- Equivalent to Element (Right) < Element (Left) function "<" (Left : Cursor; Right : Element_Type) return Boolean; + -- Equivalent to Element (Left) < Right function ">" (Left : Cursor; Right : Element_Type) return Boolean; + -- Equivalent to Right < Element (Left) function "<" (Left : Element_Type; Right : Cursor) return Boolean; + -- Equivalent to Left < Element (Right) function ">" (Left : Element_Type; Right : Cursor) return Boolean; + -- Equivalent to Element (Right) < Left procedure Iterate (Container : Set; Process : not null access procedure (Position : Cursor)); + -- Calls Process with a cursor designating each element of Container, in + -- order from Container.First to Container.Last. procedure Reverse_Iterate (Container : Set; Process : not null access procedure (Position : Cursor)); + -- Calls Process with a cursor designating each element of Container, in + -- order from Container.Last to Container.First. procedure Iterate (Container : Set; Item : Element_Type; Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to Item, + -- in order from Container.Floor (Item) to Container.Ceiling (Item). procedure Reverse_Iterate (Container : Set; Item : Element_Type; Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to Item, + -- in order from Container.Ceiling (Item) to Container.Floor (Item). generic type Key_Type (<>) is private; *************** package Ada.Containers.Indefinite_Ordere *** 202,239 **** package Generic_Keys is function Equivalent_Keys (Left, Right : Key_Type) return Boolean; function Key (Position : Cursor) return Key_Type; function Element (Container : Set; Key : Key_Type) return Element_Type; procedure Exclude (Container : in out Set; Key : Key_Type); procedure Delete (Container : in out Set; Key : Key_Type); function Find (Container : Set; Key : Key_Type) return Cursor; function Floor (Container : Set; Key : Key_Type) return Cursor; function Ceiling (Container : Set; Key : Key_Type) return Cursor; function Contains (Container : Set; Key : Key_Type) return Boolean; ! procedure Update_Element (Container : in out Set; Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); procedure Iterate (Container : Set; Key : Key_Type; Process : not null access procedure (Position : Cursor)); procedure Reverse_Iterate (Container : Set; Key : Key_Type; Process : not null access procedure (Position : Cursor)); end Generic_Keys; --- 339,413 ---- package Generic_Keys is function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + -- Returns False if Left is less than Right, or Right is less than Left; + -- otherwise, it returns True. function Key (Position : Cursor) return Key_Type; + -- Equivalent to Key (Element (Position)) function Element (Container : Set; Key : Key_Type) return Element_Type; + -- Equivalent to Element (Find (Container, Key)) procedure Exclude (Container : in out Set; Key : Key_Type); + -- Deletes from Container any elements whose key is equivalent to Key procedure Delete (Container : in out Set; Key : Key_Type); + -- Deletes from Container any elements whose key is equivalent to + -- Key. If there are no such elements, then it raises Constraint_Error. function Find (Container : Set; Key : Key_Type) return Cursor; + -- Returns a cursor designating the first element in Container whose key + -- is equivalent to Key. If there is no equivalent element, it returns + -- No_Element. function Floor (Container : Set; Key : Key_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to the keys of elements in Container, it returns a cursor + -- designating the first such element. Otherwise, it returns a cursor + -- designating the largest element whose key is less than Item, or + -- No_Element if all keys are greater than Item. function Ceiling (Container : Set; Key : Key_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to the keys of elements of Container, it returns a cursor + -- designating the last such element. Otherwise, it returns a cursor + -- designating the smallest element whose key is greater than Item, or + -- No_Element if all keys are less than Item. function Contains (Container : Set; Key : Key_Type) return Boolean; + -- Equivalent to Find (Container, Key) /= No_Element ! procedure Update_Element -- Update_Element_Preserving_Key ??? (Container : in out Set; Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a set object different from Container, + -- then Program_Error is raised. Otherwise, it makes a copy of the key + -- of the element designated by Position, and then calls Process with + -- the element as the parameter. Update_Element then compares the key + -- value obtained before calling Process to the key value obtained from + -- the element after calling Process. If the keys are equivalent then + -- the operation terminates. If Container is busy (cursor tampering has + -- been attempted), then Program_Error is raised. Otherwise, the node + -- is moved to its new position (in canonical order). procedure Iterate (Container : Set; Key : Key_Type; Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to + -- Key, in order from Floor (Container, Key) to + -- Ceiling (Container, Key). procedure Reverse_Iterate (Container : Set; Key : Key_Type; Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to + -- Key, in order from Ceiling (Container, Key) to + -- Floor (Container, Key). end Generic_Keys; *************** private *** 263,270 **** --- 437,446 ---- Tree : Tree_Types.Tree_Type; end record; + overriding procedure Adjust (Container : in out Set); + overriding procedure Finalize (Container : in out Set) renames Clear; use Red_Black_Trees; diff -Nrcpad gcc-4.3.3/gcc/ada/a-ciorse.adb gcc-4.4.0/gcc/ada/a-ciorse.adb *** gcc-4.3.3/gcc/ada/a-ciorse.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-ciorse.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- I N D E F I N I T E _ O R D E R E D _ S E T S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ *************** package body Ada.Containers.Indefinite_O *** 1177,1183 **** T : Tree_Type renames Container.Tree'Unrestricted_Access.all; B : Natural renames T.Busy; ! -- Start of prccessing for Iterate begin B := B + 1; --- 1174,1180 ---- T : Tree_Type renames Container.Tree'Unrestricted_Access.all; B : Natural renames T.Busy; ! -- Start of processing for Iterate begin B := B + 1; diff -Nrcpad gcc-4.3.3/gcc/ada/a-ciorse.ads gcc-4.4.0/gcc/ada/a-ciorse.ads *** gcc-4.3.3/gcc/ada/a-ciorse.ads Tue Aug 14 08:45:48 2007 --- gcc-4.4.0/gcc/ada/a-ciorse.ads Thu Apr 9 23:23:07 2009 *************** *** 2,13 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- I N D E F I N I T E _ O R D E R E D _ S E T S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 2,12 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,42 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! with Ada.Containers.Red_Black_Trees; ! with Ada.Finalization; ! with Ada.Streams; generic type Element_Type (<>) is private; --- 14,39 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! private with Ada.Containers.Red_Black_Trees; ! private with Ada.Finalization; ! private with Ada.Streams; generic type Element_Type (<>) is private; *************** private *** 267,274 **** --- 264,273 ---- Tree : Tree_Types.Tree_Type; end record; + overriding procedure Adjust (Container : in out Set); + overriding procedure Finalize (Container : in out Set) renames Clear; use Red_Black_Trees; diff -Nrcpad gcc-4.3.3/gcc/ada/a-clrefi.adb gcc-4.4.0/gcc/ada/a-clrefi.adb *** gcc-4.3.3/gcc/ada/a-clrefi.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/a-clrefi.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-clrefi.ads gcc-4.4.0/gcc/ada/a-clrefi.ads *** gcc-4.3.3/gcc/ada/a-clrefi.ads Wed Jun 6 10:35:54 2007 --- gcc-4.4.0/gcc/ada/a-clrefi.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Ada.Command_Line.Response_File i *** 82,88 **** -- response file. -- -- Each non empty line of the response file contains one or several ! -- arguments sparated by white space. Empty lines or lines containing only -- white space are ignored. Arguments containing white space or a double -- quote ('"')must be quoted. A double quote inside a quote string is -- indicated by two consecutive double quotes. Example: "-Idir with quote --- 80,86 ---- -- response file. -- -- Each non empty line of the response file contains one or several ! -- arguments separated by white space. Empty lines or lines containing only -- white space are ignored. Arguments containing white space or a double -- quote ('"')must be quoted. A double quote inside a quote string is -- indicated by two consecutive double quotes. Example: "-Idir with quote diff -Nrcpad gcc-4.3.3/gcc/ada/a-cohama.adb gcc-4.4.0/gcc/ada/a-cohama.adb *** gcc-4.3.3/gcc/ada/a-cohama.adb Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/a-cohama.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-cohama.ads gcc-4.4.0/gcc/ada/a-cohama.ads *** gcc-4.3.3/gcc/ada/a-cohama.ads Thu Dec 13 10:42:54 2007 --- gcc-4.4.0/gcc/ada/a-cohama.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ *************** package Ada.Containers.Hashed_Maps is *** 81,87 **** procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type); -- Adjusts the current capacity, by allocating a new buckets array. If the -- requested capacity is less than the current capacity, then the capacity ! -- is contracted (to a value not less than the curent length). If the -- requested capacity is greater than the current capacity, then the -- capacity is expanded (to a value not less than what is requested). In -- either case, the nodes are rehashed from the old buckets array onto the --- 79,85 ---- procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type); -- Adjusts the current capacity, by allocating a new buckets array. If the -- requested capacity is less than the current capacity, then the capacity ! -- is contracted (to a value not less than the current length). If the -- requested capacity is greater than the current capacity, then the -- capacity is expanded (to a value not less than what is requested). In -- either case, the nodes are rehashed from the old buckets array onto the *************** package Ada.Containers.Hashed_Maps is *** 199,205 **** procedure Delete (Container : in out Map; Key : Key_Type); -- Searches for Key in the map (which involves calling both Hash and -- Equivalent_Keys). If the search fails, then the operation raises ! -- Constraint_Eror. Otherwise it removes the node from the map and then -- deallocates it. (This is the deletion analog of non-conditional -- Insert. It is intended for use when you want to assert that the item is -- already in the map.) --- 197,203 ---- procedure Delete (Container : in out Map; Key : Key_Type); -- Searches for Key in the map (which involves calling both Hash and -- Equivalent_Keys). If the search fails, then the operation raises ! -- Constraint_Error. Otherwise it removes the node from the map and then -- deallocates it. (This is the deletion analog of non-conditional -- Insert. It is intended for use when you want to assert that the item is -- already in the map.) diff -Nrcpad gcc-4.3.3/gcc/ada/a-cohase.adb gcc-4.4.0/gcc/ada/a-cohase.adb *** gcc-4.3.3/gcc/ada/a-cohase.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-cohase.adb Thu Apr 9 23:23:07 2009 *************** *** 6,32 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- ! -- This unit has originally being developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; --- 6,30 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- ! -- -- ! -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; diff -Nrcpad gcc-4.3.3/gcc/ada/a-cohase.ads gcc-4.4.0/gcc/ada/a-cohase.ads *** gcc-4.3.3/gcc/ada/a-cohase.ads Thu Dec 13 10:42:54 2007 --- gcc-4.4.0/gcc/ada/a-cohase.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,41 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! with Ada.Containers.Hash_Tables; ! with Ada.Streams; ! with Ada.Finalization; generic type Element_Type is private; --- 14,39 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! private with Ada.Containers.Hash_Tables; ! private with Ada.Streams; ! private with Ada.Finalization; generic type Element_Type is private; *************** private *** 416,423 **** --- 414,423 ---- HT : HT_Types.Hash_Table_Type; end record; + overriding procedure Adjust (Container : in out Set); + overriding procedure Finalize (Container : in out Set); use HT_Types; diff -Nrcpad gcc-4.3.3/gcc/ada/a-cohata.ads gcc-4.4.0/gcc/ada/a-cohata.ads *** gcc-4.3.3/gcc/ada/a-cohata.ads Tue Aug 14 08:45:48 2007 --- gcc-4.4.0/gcc/ada/a-cohata.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-coinve.adb gcc-4.4.0/gcc/ada/a-coinve.adb *** gcc-4.3.3/gcc/ada/a-coinve.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-coinve.adb Thu Apr 9 23:23:07 2009 *************** *** 6,32 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- ! -- This unit has originally being developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with Ada.Containers.Generic_Array_Sort; --- 6,30 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- ! -- -- ! -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with Ada.Containers.Generic_Array_Sort; *************** package body Ada.Containers.Indefinite_V *** 1124,1136 **** Index : constant Index_Type := Index_Type (Index_As_Int); ! J : Index_Type'Base; begin E (Index .. New_Last) := E (Before .. Container.Last); Container.Last := New_Last; - J := Before; while J < Index loop E (J) := new Element_Type'(New_Item); J := J + 1; --- 1122,1133 ---- Index : constant Index_Type := Index_Type (Index_As_Int); ! J : Index_Type'Base := Before; begin E (Index .. New_Last) := E (Before .. Container.Last); Container.Last := New_Last; while J < Index loop E (J) := new Element_Type'(New_Item); J := J + 1; diff -Nrcpad gcc-4.3.3/gcc/ada/a-coinve.ads gcc-4.4.0/gcc/ada/a-coinve.ads *** gcc-4.3.3/gcc/ada/a-coinve.ads Tue Aug 14 08:45:48 2007 --- gcc-4.4.0/gcc/ada/a-coinve.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-colien.adb gcc-4.4.0/gcc/ada/a-colien.adb *** gcc-4.3.3/gcc/ada/a-colien.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-colien.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-colien.ads gcc-4.4.0/gcc/ada/a-colien.ads *** gcc-4.3.3/gcc/ada/a-colien.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-colien.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-colire.adb gcc-4.4.0/gcc/ada/a-colire.adb *** gcc-4.3.3/gcc/ada/a-colire.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-colire.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-colire.ads gcc-4.4.0/gcc/ada/a-colire.ads *** gcc-4.3.3/gcc/ada/a-colire.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-colire.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-comlin.adb gcc-4.4.0/gcc/ada/a-comlin.adb *** gcc-4.3.3/gcc/ada/a-comlin.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-comlin.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-comlin.ads gcc-4.4.0/gcc/ada/a-comlin.ads *** gcc-4.3.3/gcc/ada/a-comlin.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-comlin.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 110,116 **** Failure : constant Exit_Status := 1; -- The following locations support the operation of the package ! -- Ada.Command_Line.Remove, whih provides facilities for logically -- removing arguments from the command line. If one of the remove -- procedures is called in this unit, then Remove_Args/Remove_Count -- are set to indicate which arguments are removed. If no such calls --- 108,114 ---- Failure : constant Exit_Status := 1; -- The following locations support the operation of the package ! -- Ada.Command_Line.Remove, which provides facilities for logically -- removing arguments from the command line. If one of the remove -- procedures is called in this unit, then Remove_Args/Remove_Count -- are set to indicate which arguments are removed. If no such calls diff -Nrcpad gcc-4.3.3/gcc/ada/a-convec.adb gcc-4.4.0/gcc/ada/a-convec.adb *** gcc-4.3.3/gcc/ada/a-convec.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-convec.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ *************** package body Ada.Containers.Vectors is *** 2077,2090 **** end if; declare ! EI : Element_Type renames Container.Elements.EA (I); ! EJ : Element_Type renames Container.Elements.EA (J); ! ! EI_Copy : constant Element_Type := EI; ! begin ! EI := EJ; ! EJ := EI_Copy; end; end Swap; --- 2075,2084 ---- end if; declare ! EI_Copy : constant Element_Type := Container.Elements.EA (I); begin ! Container.Elements.EA (I) := Container.Elements.EA (J); ! Container.Elements.EA (J) := EI_Copy; end; end Swap; diff -Nrcpad gcc-4.3.3/gcc/ada/a-convec.ads gcc-4.4.0/gcc/ada/a-convec.ads *** gcc-4.3.3/gcc/ada/a-convec.ads Tue Aug 14 08:45:48 2007 --- gcc-4.4.0/gcc/ada/a-convec.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-coorma.adb gcc-4.4.0/gcc/ada/a-coorma.adb *** gcc-4.3.3/gcc/ada/a-coorma.adb Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/a-coorma.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-coorma.ads gcc-4.4.0/gcc/ada/a-coorma.ads *** gcc-4.3.3/gcc/ada/a-coorma.ads Tue Aug 14 08:45:48 2007 --- gcc-4.4.0/gcc/ada/a-coorma.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,41 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! with Ada.Containers.Red_Black_Trees; ! with Ada.Finalization; ! with Ada.Streams; generic type Key_Type is private; --- 14,39 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! private with Ada.Containers.Red_Black_Trees; ! private with Ada.Finalization; ! private with Ada.Streams; generic type Key_Type is private; *************** private *** 205,212 **** --- 203,212 ---- Tree : Tree_Types.Tree_Type; end record; + overriding procedure Adjust (Container : in out Map); + overriding procedure Finalize (Container : in out Map) renames Clear; use Red_Black_Trees; diff -Nrcpad gcc-4.3.3/gcc/ada/a-coormu.adb gcc-4.4.0/gcc/ada/a-coormu.adb *** gcc-4.3.3/gcc/ada/a-coormu.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-coormu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-coormu.ads gcc-4.4.0/gcc/ada/a-coormu.ads *** gcc-4.3.3/gcc/ada/a-coormu.ads Tue Aug 14 08:45:48 2007 --- gcc-4.4.0/gcc/ada/a-coormu.ads Thu Apr 9 23:23:07 2009 *************** *** 6,41 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- ! -- -- ! -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. The copyright notice above, and the license provisions that follow -- ! -- apply solely to the contents of the part following the private keyword. -- -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! with Ada.Containers.Red_Black_Trees; ! with Ada.Finalization; ! with Ada.Streams; generic type Element_Type is private; --- 6,39 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! -- The ordered multiset container is similar to the ordered set, but with the ! -- difference that multiple equivalent elements are allowed. It also provides ! -- additional operations, to iterate over items that are equivalent. ! ! private with Ada.Containers.Red_Black_Trees; ! private with Ada.Finalization; ! private with Ada.Streams; generic type Element_Type is private; *************** package Ada.Containers.Ordered_Multisets *** 48,53 **** --- 46,53 ---- pragma Remote_Types; function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + -- Returns False if Left is less than Right, or Right is less than Left; + -- otherwise, it returns True. type Set is tagged private; pragma Preelaborable_Initialization (Set); *************** package Ada.Containers.Ordered_Multisets *** 56,97 **** --- 56,148 ---- pragma Preelaborable_Initialization (Cursor); Empty_Set : constant Set; + -- The default value for set objects declared without an explicit + -- initialization expression. No_Element : constant Cursor; + -- The default value for cursor objects declared without an explicit + -- initialization expression. function "=" (Left, Right : Set) return Boolean; + -- If Left denotes the same set object as Right, then equality returns + -- True. If the length of Left is different from the length of Right, then + -- it returns False. Otherwise, set equality iterates over Left and Right, + -- comparing the element of Left to the element of Right using the equality + -- operator for elements. If the elements compare False, then the iteration + -- terminates and set equality returns False. Otherwise, if all elements + -- compare True, then set equality returns True. function Equivalent_Sets (Left, Right : Set) return Boolean; + -- Similar to set equality, but with the difference that elements are + -- compared for equivalence instead of equality. function To_Set (New_Item : Element_Type) return Set; + -- Constructs a set object with New_Item as its single element function Length (Container : Set) return Count_Type; + -- Returns the total number of elements in Container function Is_Empty (Container : Set) return Boolean; + -- Returns True if Container.Length is 0 procedure Clear (Container : in out Set); + -- Deletes all elements from Container function Element (Position : Cursor) return Element_Type; + -- If Position equals No_Element, then Constraint_Error is raised. + -- Otherwise, function Element returns the element designed by Position. procedure Replace_Element (Container : in out Set; Position : Cursor; New_Item : Element_Type); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a set different from Container, then + -- Program_Error is raised. If New_Item is equivalent to the element + -- designated by Position, then if Container is locked (element tampering + -- has been attempted), Program_Error is raised; otherwise, the element + -- designated by Position is assigned the value of New_Item. If New_Item is + -- not equivalent to the element designated by Position, then if the + -- container is busy (cursor tampering has been attempted), Program_Error + -- is raised; otherwise, the element designed by Position is assigned the + -- value of New_Item, and the node is moved to its new position (in + -- canonical insertion order). procedure Query_Element (Position : Cursor; Process : not null access procedure (Element : Element_Type)); + -- If Position equals No_Element, then Constraint_Error is + -- raised. Otherwise, it calls Process with the element designated by + -- Position as the parameter. This call locks the container, so attempts to + -- change the value of the element while Process is executing (to "tamper + -- with elements") will raise Program_Error. procedure Move (Target : in out Set; Source : in out Set); + -- If Target denotes the same object as Source, the operation does + -- nothing. If either Target or Source is busy (cursor tampering is + -- attempted), then it raises Program_Error. Otherwise, Target is cleared, + -- and the nodes from Source are moved (not copied) to Target (so Source + -- becomes empty). procedure Insert (Container : in out Set; New_Item : Element_Type; Position : out Cursor); + -- Insert adds New_Item to Container, and returns cursor Position + -- designating the newly inserted node. The node is inserted after any + -- existing elements less than or equivalent to New_Item (and before any + -- elements greater than New_Item). Note that the issue of where the new + -- node is inserted relative to equivalent elements does not arise for + -- unique-key containers, since in that case the insertion would simply + -- fail. For a multiple-key container (the case here), insertion always + -- succeeds, and is defined such that the new item is positioned after any + -- equivalent elements already in the container. procedure Insert (Container : in out Set; New_Item : Element_Type); + -- Inserts New_Item in Container, but does not return a cursor designating + -- the newly-inserted node. -- TODO: include Replace too??? -- *************** package Ada.Containers.Ordered_Multisets *** 102,203 **** --- 153,340 ---- procedure Exclude (Container : in out Set; Item : Element_Type); + -- Deletes from Container all of the elements equivalent to Item procedure Delete (Container : in out Set; Item : Element_Type); + -- Deletes from Container all of the elements equivalent to Item. If there + -- are no elements equivalent to Item, then it raises Constraint_Error. procedure Delete (Container : in out Set; Position : in out Cursor); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a set different from Container, then + -- Program_Error is raised. Otherwise, the node designated by Position is + -- removed from Container, and Position is set to No_Element. procedure Delete_First (Container : in out Set); + -- Removes the first node from Container procedure Delete_Last (Container : in out Set); + -- Removes the last node from Container procedure Union (Target : in out Set; Source : Set); + -- If Target is busy (cursor tampering is attempted), the Program_Error is + -- raised. Otherwise, it inserts each element of Source into + -- Target. Elements are inserted in the canonical order for multisets, such + -- that the elements from Source are inserted after equivalent elements + -- already in Target. function Union (Left, Right : Set) return Set; + -- Returns a set comprising the all elements from Left and all of the + -- elements from Right. The elements from Right follow the equivalent + -- elements from Left. function "or" (Left, Right : Set) return Set renames Union; procedure Intersection (Target : in out Set; Source : Set); + -- If Target denotes the same object as Source, the operation does + -- nothing. If Target is busy (cursor tampering is attempted), + -- Program_Error is raised. Otherwise, the elements in Target having no + -- equivalent element in Source are deleted from Target. function Intersection (Left, Right : Set) return Set; + -- If Left denotes the same object as Right, then the function returns a + -- copy of Left. Otherwise, it returns a set comprising the equivalent + -- elements from both Left and Right. Items are inserted in the result set + -- in canonical order, such that the elements from Left precede the + -- equivalent elements from Right. function "and" (Left, Right : Set) return Set renames Intersection; procedure Difference (Target : in out Set; Source : Set); + -- If Target is busy (cursor tampering is attempted), then Program_Error is + -- raised. Otherwise, the elements in Target that are equivalent to + -- elements in Source are deleted from Target. function Difference (Left, Right : Set) return Set; + -- Returns a set comprising the elements from Left that have no equivalent + -- element in Right. function "-" (Left, Right : Set) return Set renames Difference; procedure Symmetric_Difference (Target : in out Set; Source : Set); + -- If Target is busy, then Program_Error is raised. Otherwise, the elements + -- in Target equivalent to elements in Source are deleted from Target, and + -- the elements in Source not equivalent to elements in Target are inserted + -- into Target. function Symmetric_Difference (Left, Right : Set) return Set; + -- Returns a set comprising the union of the elements from Target having no + -- equivalent in Source, and the elements of Source having no equivalent in + -- Target. function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; function Overlap (Left, Right : Set) return Boolean; + -- Returns True if Left contains an element equivalent to an element of + -- Right. function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + -- Returns True if every element in Subset has an equivalent element in + -- Of_Set. function First (Container : Set) return Cursor; + -- If Container is empty, the function returns No_Element. Otherwise, it + -- returns a cursor designating the smallest element. function First_Element (Container : Set) return Element_Type; + -- Equivalent to Element (First (Container)) function Last (Container : Set) return Cursor; + -- If Container is empty, the function returns No_Element. Otherwise, it + -- returns a cursor designating the largest element. function Last_Element (Container : Set) return Element_Type; + -- Equivalent to Element (Last (Container)) function Next (Position : Cursor) return Cursor; + -- If Position equals No_Element or Last (Container), the function returns + -- No_Element. Otherwise, it returns a cursor designating the node that + -- immediately follows (as per the insertion order) the node designated by + -- Position. procedure Next (Position : in out Cursor); + -- Equivalent to Position := Next (Position) function Previous (Position : Cursor) return Cursor; + -- If Position equals No_Element or First (Container), the function returns + -- No_Element. Otherwise, it returns a cursor designating the node that + -- immediately precedes (as per the insertion order) the node designated by + -- Position. procedure Previous (Position : in out Cursor); + -- Equivalent to Position := Previous (Position) function Find (Container : Set; Item : Element_Type) return Cursor; + -- Returns a cursor designating the first element in Container equivalent + -- to Item. If there is no equivalent element, it returns No_Element. function Floor (Container : Set; Item : Element_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to elements in Container, it returns a cursor designating the + -- first equivalent element. Otherwise, it returns a cursor designating the + -- largest element less than Item, or No_Element if all elements are + -- greater than Item. function Ceiling (Container : Set; Item : Element_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to elements of Container, it returns a cursor designating the + -- last equivalent element. Otherwise, it returns a cursor designating the + -- smallest element greater than Item, or No_Element if all elements are + -- less than Item. function Contains (Container : Set; Item : Element_Type) return Boolean; + -- Equivalent to Container.Find (Item) /= No_Element function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element function "<" (Left, Right : Cursor) return Boolean; + -- Equivalent to Element (Left) < Element (Right) function ">" (Left, Right : Cursor) return Boolean; + -- Equivalent to Element (Right) < Element (Left) function "<" (Left : Cursor; Right : Element_Type) return Boolean; + -- Equivalent to Element (Left) < Right function ">" (Left : Cursor; Right : Element_Type) return Boolean; + -- Equivalent to Right < Element (Left) function "<" (Left : Element_Type; Right : Cursor) return Boolean; + -- Equivalent to Left < Element (Right) function ">" (Left : Element_Type; Right : Cursor) return Boolean; + -- Equivalent to Element (Right) < Left procedure Iterate (Container : Set; Process : not null access procedure (Position : Cursor)); + -- Calls Process with a cursor designating each element of Container, in + -- order from Container.First to Container.Last. procedure Reverse_Iterate (Container : Set; Process : not null access procedure (Position : Cursor)); + -- Calls Process with a cursor designating each element of Container, in + -- order from Container.Last to Container.First. procedure Iterate (Container : Set; Item : Element_Type; Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to Item, + -- in order from Container.Floor (Item) to Container.Ceiling (Item). procedure Reverse_Iterate (Container : Set; Item : Element_Type; Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to Item, + -- in order from Container.Ceiling (Item) to Container.Floor (Item). generic type Key_Type (<>) is private; *************** package Ada.Containers.Ordered_Multisets *** 209,246 **** package Generic_Keys is function Equivalent_Keys (Left, Right : Key_Type) return Boolean; function Key (Position : Cursor) return Key_Type; function Element (Container : Set; Key : Key_Type) return Element_Type; procedure Exclude (Container : in out Set; Key : Key_Type); procedure Delete (Container : in out Set; Key : Key_Type); function Find (Container : Set; Key : Key_Type) return Cursor; function Floor (Container : Set; Key : Key_Type) return Cursor; function Ceiling (Container : Set; Key : Key_Type) return Cursor; function Contains (Container : Set; Key : Key_Type) return Boolean; ! procedure Update_Element (Container : in out Set; Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); procedure Iterate (Container : Set; Key : Key_Type; Process : not null access procedure (Position : Cursor)); procedure Reverse_Iterate (Container : Set; Key : Key_Type; Process : not null access procedure (Position : Cursor)); end Generic_Keys; --- 346,420 ---- package Generic_Keys is function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + -- Returns False if Left is less than Right, or Right is less than Left; + -- otherwise, it returns True. function Key (Position : Cursor) return Key_Type; + -- Equivalent to Key (Element (Position)) function Element (Container : Set; Key : Key_Type) return Element_Type; + -- Equivalent to Element (Find (Container, Key)) procedure Exclude (Container : in out Set; Key : Key_Type); + -- Deletes from Container any elements whose key is equivalent to Key procedure Delete (Container : in out Set; Key : Key_Type); + -- Deletes from Container any elements whose key is equivalent to + -- Key. If there are no such elements, then it raises Constraint_Error. function Find (Container : Set; Key : Key_Type) return Cursor; + -- Returns a cursor designating the first element in Container whose key + -- is equivalent to Key. If there is no equivalent element, it returns + -- No_Element. function Floor (Container : Set; Key : Key_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to the keys of elements in Container, it returns a cursor + -- designating the first such element. Otherwise, it returns a cursor + -- designating the largest element whose key is less than Item, or + -- No_Element if all keys are greater than Item. function Ceiling (Container : Set; Key : Key_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to the keys of elements of Container, it returns a cursor + -- designating the last such element. Otherwise, it returns a cursor + -- designating the smallest element whose key is greater than Item, or + -- No_Element if all keys are less than Item. function Contains (Container : Set; Key : Key_Type) return Boolean; + -- Equivalent to Find (Container, Key) /= No_Element ! procedure Update_Element -- Update_Element_Preserving_Key ??? (Container : in out Set; Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a set object different from Container, + -- then Program_Error is raised. Otherwise, it makes a copy of the key + -- of the element designated by Position, and then calls Process with + -- the element as the parameter. Update_Element then compares the key + -- value obtained before calling Process to the key value obtained from + -- the element after calling Process. If the keys are equivalent then + -- the operation terminates. If Container is busy (cursor tampering has + -- been attempted), then Program_Error is raised. Otherwise, the node + -- is moved to its new position (in canonical order). procedure Iterate (Container : Set; Key : Key_Type; Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to + -- Key, in order from Floor (Container, Key) to + -- Ceiling (Container, Key). procedure Reverse_Iterate (Container : Set; Key : Key_Type; Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to + -- Key, in order from Ceiling (Container, Key) to + -- Floor (Container, Key). end Generic_Keys; *************** private *** 268,275 **** --- 442,451 ---- Tree : Tree_Types.Tree_Type; end record; + overriding procedure Adjust (Container : in out Set); + overriding procedure Finalize (Container : in out Set) renames Clear; use Red_Black_Trees; diff -Nrcpad gcc-4.3.3/gcc/ada/a-coorse.adb gcc-4.4.0/gcc/ada/a-coorse.adb *** gcc-4.3.3/gcc/ada/a-coorse.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-coorse.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ *************** package body Ada.Containers.Ordered_Sets *** 47,53 **** ------------------------------ -- These subprograms provide functional notation for access to fields ! -- of a node, and procedural notation for modifiying these fields. function Color (Node : Node_Access) return Color_Type; pragma Inline (Color); --- 45,51 ---- ------------------------------ -- These subprograms provide functional notation for access to fields ! -- of a node, and procedural notation for modifying these fields. function Color (Node : Node_Access) return Color_Type; pragma Inline (Color); *************** package body Ada.Containers.Ordered_Sets *** 1103,1109 **** T : Tree_Type renames Container.Tree'Unrestricted_Access.all; B : Natural renames T.Busy; ! -- Start of prccessing for Iterate begin B := B + 1; --- 1101,1107 ---- T : Tree_Type renames Container.Tree'Unrestricted_Access.all; B : Natural renames T.Busy; ! -- Start of processing for Iterate begin B := B + 1; diff -Nrcpad gcc-4.3.3/gcc/ada/a-coorse.ads gcc-4.4.0/gcc/ada/a-coorse.ads *** gcc-4.3.3/gcc/ada/a-coorse.ads Tue Aug 14 08:45:48 2007 --- gcc-4.4.0/gcc/ada/a-coorse.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,41 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! with Ada.Containers.Red_Black_Trees; ! with Ada.Finalization; ! with Ada.Streams; generic type Element_Type is private; --- 14,39 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ ! private with Ada.Containers.Red_Black_Trees; ! private with Ada.Finalization; ! private with Ada.Streams; generic type Element_Type is private; *************** private *** 256,263 **** --- 254,263 ---- Tree : Tree_Types.Tree_Type; end record; + overriding procedure Adjust (Container : in out Set); + overriding procedure Finalize (Container : in out Set) renames Clear; use Red_Black_Trees; diff -Nrcpad gcc-4.3.3/gcc/ada/a-coprnu.adb gcc-4.4.0/gcc/ada/a-coprnu.adb *** gcc-4.3.3/gcc/ada/a-coprnu.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-coprnu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-coprnu.ads gcc-4.4.0/gcc/ada/a-coprnu.ads *** gcc-4.3.3/gcc/ada/a-coprnu.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-coprnu.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-crbltr.ads gcc-4.4.0/gcc/ada/a-crbltr.ads *** gcc-4.3.3/gcc/ada/a-crbltr.ads Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-crbltr.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-crbtgk.adb gcc-4.4.0/gcc/ada/a-crbtgk.adb *** gcc-4.3.3/gcc/ada/a-crbtgk.adb Tue Oct 31 18:13:22 2006 --- gcc-4.4.0/gcc/ada/a-crbtgk.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . -- ! -- G E N E R I C _ K E Y S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ *************** package body Ada.Containers.Red_Black_Tr *** 185,191 **** -- is not a search and the only comparisons that occur are with -- the hint and its neighbor. ! -- If Position is null, this is intepreted to mean that Key is -- large relative to the nodes in the tree. If the tree is empty, -- or Key is greater than the last node in the tree, then we're -- done; otherwise the hint was "wrong" and we must search. --- 182,188 ---- -- is not a search and the only comparisons that occur are with -- the hint and its neighbor. ! -- If Position is null, this is interpreted to mean that Key is -- large relative to the nodes in the tree. If the tree is empty, -- or Key is greater than the last node in the tree, then we're -- done; otherwise the hint was "wrong" and we must search. *************** package body Ada.Containers.Red_Black_Tr *** 206,212 **** pragma Assert (Tree.Length > 0); -- A hint can either name the node that immediately follows Key, ! -- or immediately precedes Key. We first test whether Key is is -- less than the hint, and if so we compare Key to the node that -- precedes the hint. If Key is both less than the hint and -- greater than the hint's preceding neighbor, then we're done; --- 203,209 ---- pragma Assert (Tree.Length > 0); -- A hint can either name the node that immediately follows Key, ! -- or immediately precedes Key. We first test whether Key is -- less than the hint, and if so we compare Key to the node that -- precedes the hint. If Key is both less than the hint and -- greater than the hint's preceding neighbor, then we're done; *************** package body Ada.Containers.Red_Black_Tr *** 507,513 **** -- equivalent node. That wouldn't break any container invariants, -- but our rule above says that new nodes always get inserted -- after equivalent nodes. So here we test whether Key is both ! -- less than the hint and and equal to or greater than the hint's -- previous neighbor, and if so insert it before the hint. if Is_Less_Key_Node (Key, Hint) then --- 504,510 ---- -- equivalent node. That wouldn't break any container invariants, -- but our rule above says that new nodes always get inserted -- after equivalent nodes. So here we test whether Key is both ! -- less than the hint and equal to or greater than the hint's -- previous neighbor, and if so insert it before the hint. if Is_Less_Key_Node (Key, Hint) then diff -Nrcpad gcc-4.3.3/gcc/ada/a-crbtgk.ads gcc-4.4.0/gcc/ada/a-crbtgk.ads *** gcc-4.3.3/gcc/ada/a-crbtgk.ads Tue Oct 31 18:13:22 2006 --- gcc-4.4.0/gcc/ada/a-crbtgk.ads Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . -- ! -- G E N E R I C _ K E Y S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-crbtgo.adb gcc-4.4.0/gcc/ada/a-crbtgo.adb *** gcc-4.3.3/gcc/ada/a-crbtgo.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-crbtgo.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . -- ! -- G E N E R I C _ O P E R A T I O N S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-crbtgo.ads gcc-4.4.0/gcc/ada/a-crbtgo.ads *** gcc-4.3.3/gcc/ada/a-crbtgo.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-crbtgo.ads Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . -- ! -- G E N E R I C _ O P E R A T I O N S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-crdlli.adb gcc-4.4.0/gcc/ada/a-crdlli.adb *** gcc-4.3.3/gcc/ada/a-crdlli.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-crdlli.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- R E S R I C T E D _ D O U B L Y _ L I N K E D _ L I S T S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.RESTRICTED_DOUBLY_LINKED_LISTS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-crdlli.ads gcc-4.4.0/gcc/ada/a-crdlli.ads *** gcc-4.3.3/gcc/ada/a-crdlli.ads Tue Oct 31 18:21:54 2006 --- gcc-4.4.0/gcc/ada/a-crdlli.ads Thu Apr 9 23:23:07 2009 *************** *** 2,39 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . -- ! -- R E S R I C T E D _ D O U B L Y _ L I N K E D _ L I S T S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- ! -- -- ! -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. The copyright notice above, and the license provisions that follow -- ! -- apply solely to the contents of the part following the private keyword. -- -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ generic type Element_Type is private; --- 2,42 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.RESTRICTED_DOUBLY_LINKED_LISTS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ + -- The doubly-linked list container provides constant-time insertion and + -- deletion at all positions, and allows iteration in both the forward and + -- reverse directions. This list form allocates storage for all nodes + -- statically (there is no dynamic allocation), and a discriminant is used to + -- specify the capacity. This container is also "restricted", meaning that + -- even though it does raise exceptions (as described below), it does not use + -- internal exception handlers. No state changes are made that would need to + -- be reverted (in the event of an exception), and so as a consequence, this + -- container cannot detect tampering (of cursors or elements). + generic type Element_Type is private; *************** package Ada.Containers.Restricted_Doubly *** 50,89 **** --- 53,133 ---- pragma Preelaborable_Initialization (Cursor); Empty_List : constant List; + -- The default value for list objects declared without an explicit + -- initialization expression. No_Element : constant Cursor; + -- The default value for cursor objects declared without an explicit + -- initialization expression. function "=" (Left, Right : List) return Boolean; + -- If Left denotes the same list object as Right, then equality returns + -- True. If the length of Left is different from the length of Right, then + -- it returns False. Otherwise, list equality iterates over Left and Right, + -- comparing the element of Left to the corresponding element of Right + -- using the generic actual equality operator for elements. If the elements + -- compare False, then the iteration terminates and list equality returns + -- False. Otherwise, if all elements return True, then list equality + -- returns True. procedure Assign (Target : in out List; Source : List); + -- If Target denotes the same list object as Source, the operation does + -- nothing. If Target.Capacity is less than Source.Length, then it raises + -- Constraint_Error. Otherwise, it clears Target, and then inserts each + -- element of Source into Target. function Length (Container : List) return Count_Type; + -- Returns the total number of (active) elements in Container function Is_Empty (Container : List) return Boolean; + -- Returns True if Container.Length is 0 procedure Clear (Container : in out List); + -- Deletes all elements from Container. Note that this is a bounded + -- container and so the element is not "deallocated" in the same sense that + -- an unbounded form would deallocate the element. Rather, the node is + -- relinked off of the active part of the list and onto the inactive part + -- of the list (the storage from which new elements are "allocated"). function Element (Position : Cursor) return Element_Type; + -- If Position equals No_Element, then Constraint_Error is raised. + -- Otherwise, function Element returns the element designed by Position. procedure Replace_Element (Container : in out List; Position : Cursor; New_Item : Element_Type); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a list object different from Container, + -- Program_Error is raised. Otherwise, the element designated by Position + -- is assigned the value New_Item. procedure Query_Element (Position : Cursor; Process : not null access procedure (Element : Element_Type)); + -- If Position equals No_Element, then Constraint_Error is raised. + -- Otherwise, it calls Process with (a constant view of) the element + -- designated by Position as the parameter. procedure Update_Element (Container : in out List; Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); + -- If Position equals No_Element, then Constraint_Error is raised. + -- Otherwise, it calls Process with (a variable view of) the element + -- designated by Position as the parameter. procedure Insert (Container : in out List; Before : Cursor; New_Item : Element_Type; Count : Count_Type := 1); + -- Inserts Count new elements, all with the value New_Item, into Container, + -- immediately prior to the position specified by Before. If Before has the + -- value No_Element, this is interpreted to mean that the elements are + -- appended to the list. If Before is associated with a list object + -- different from Container, then Program_Error is raised. If there are + -- fewer than Count nodes available, then Constraint_Error is raised. procedure Insert (Container : in out List; *************** package Ada.Containers.Restricted_Doubly *** 91,188 **** --- 135,305 ---- New_Item : Element_Type; Position : out Cursor; Count : Count_Type := 1); + -- Inserts elements into Container as described above, but with the + -- difference that cursor Position is returned, which designates the first + -- of the new elements inserted. If Count is 0, Position returns the value + -- Before. procedure Insert (Container : in out List; Before : Cursor; Position : out Cursor; Count : Count_Type := 1); + -- Inserts elements in Container as described above, but with the + -- difference that the new elements are initialized to the default value + -- for objects of type Element_Type. procedure Prepend (Container : in out List; New_Item : Element_Type; Count : Count_Type := 1); + -- Inserts Count elements, all having the value New_Item, prior to the + -- first element of Container. procedure Append (Container : in out List; New_Item : Element_Type; Count : Count_Type := 1); + -- Inserts Count elements, all having the value New_Item, following the + -- last element of Container. procedure Delete (Container : in out List; Position : in out Cursor; Count : Count_Type := 1); + -- If Position equals No_Element, Constraint_Error is raised. If Position + -- is associated with a list object different from Container, then + -- Program_Error is raised. Otherwise, the Count nodes starting from + -- Position are removed from Container ("removed" meaning that the nodes + -- are unlinked from the active nodes of the list and relinked to inactive + -- storage). On return, Position is set to No_Element. procedure Delete_First (Container : in out List; Count : Count_Type := 1); + -- Removes the first Count nodes from Container procedure Delete_Last (Container : in out List; Count : Count_Type := 1); + -- Removes the last Count nodes from Container procedure Reverse_Elements (Container : in out List); + -- Relinks the nodes in reverse order procedure Swap (Container : in out List; I, J : Cursor); + -- If I or J equals No_Element, then Constraint_Error is raised. If I or J + -- is associated with a list object different from Container, then + -- Program_Error is raised. Otherwise, Swap exchanges (copies) the values + -- of the elements (on the nodes) designated by I and J. procedure Swap_Links (Container : in out List; I, J : Cursor); + -- If I or J equals No_Element, then Constraint_Error is raised. If I or J + -- is associated with a list object different from Container, then + -- Program_Error is raised. Otherwise, Swap exchanges (relinks) the nodes + -- designated by I and J. procedure Splice (Container : in out List; Before : Cursor; Position : in out Cursor); + -- If Before is associated with a list object different from Container, + -- then Program_Error is raised. If Position equals No_element, then + -- Constraint_Error is raised; if it associated with a list object + -- different from Container, then Program_Error is raised. Otherwise, the + -- node designated by Position is relinked immediately prior to Before. If + -- Before equals No_Element, this is interpreted to mean to move the node + -- designed by Position to the last end of the list. function First (Container : List) return Cursor; + -- If Container is empty, the function returns No_Element. Otherwise, it + -- returns a cursor designating the first element. function First_Element (Container : List) return Element_Type; + -- Equivalent to Element (First (Container)) function Last (Container : List) return Cursor; + -- If Container is empty, the function returns No_Element. Otherwise, it + -- returns a cursor designating the last element. function Last_Element (Container : List) return Element_Type; + -- Equivalent to Element (Last (Container)) function Next (Position : Cursor) return Cursor; + -- If Position equals No_Element or Last (Container), the function returns + -- No_Element. Otherwise, it returns a cursor designating the node that + -- immediately follows the node designated by Position. procedure Next (Position : in out Cursor); + -- Equivalent to Position := Next (Position) function Previous (Position : Cursor) return Cursor; + -- If Position equals No_Element or First (Container), the function returns + -- No_Element. Otherwise, it returns a cursor designating the node that + -- immediately precedes the node designated by Position. procedure Previous (Position : in out Cursor); + -- Equivalent to Position := Previous (Position) function Find (Container : List; Item : Element_Type; Position : Cursor := No_Element) return Cursor; + -- Searches for the node whose element is equal to Item, starting from + -- Position and continuing to the last end of the list. If Position equals + -- No_Element, the search starts from the first node. If Position is + -- associated with a list object different from Container, then + -- Program_Error is raised. If no node is found having an element equal to + -- Item, then Find returns No_Element. function Reverse_Find (Container : List; Item : Element_Type; Position : Cursor := No_Element) return Cursor; + -- Searches in reverse for the node whose element is equal to Item, + -- starting from Position and continuing to the first end of the list. If + -- Position equals No_Element, the search starts from the last node. If + -- Position is associated with a list object different from Container, then + -- Program_Error is raised. If no node is found having an element equal to + -- Item, then Reverse_Find returns No_Element. function Contains (Container : List; Item : Element_Type) return Boolean; + -- Equivalent to Container.Find (Item) /= No_Element function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element procedure Iterate (Container : List; Process : not null access procedure (Position : Cursor)); + -- Calls Process with a cursor designating each element of Container, in + -- order from Container.First to Container.Last. procedure Reverse_Iterate (Container : List; Process : not null access procedure (Position : Cursor)); + -- Calls Process with a cursor designating each element of Container, in + -- order from Container.Last to Container.First. generic with function "<" (Left, Right : Element_Type) return Boolean is <>; package Generic_Sorting is function Is_Sorted (Container : List) return Boolean; + -- Returns False if there exists an element which is less than its + -- predecessor. procedure Sort (Container : in out List); + -- Sorts the elements of Container (by relinking nodes), according to + -- the order specified by the generic formal less-than operator, such + -- that smaller elements are first in the list. The sort is stable, + -- meaning that the relative order of elements is preserved. end Generic_Sorting; diff -Nrcpad gcc-4.3.3/gcc/ada/a-cwila1.ads gcc-4.4.0/gcc/ada/a-cwila1.ads *** gcc-4.3.3/gcc/ada/a-cwila1.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-cwila1.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-cwila9.ads gcc-4.4.0/gcc/ada/a-cwila9.ads *** gcc-4.3.3/gcc/ada/a-cwila9.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-cwila9.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-decima.adb gcc-4.4.0/gcc/ada/a-decima.adb *** gcc-4.3.3/gcc/ada/a-decima.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-decima.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-decima.ads gcc-4.4.0/gcc/ada/a-decima.ads *** gcc-4.3.3/gcc/ada/a-decima.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-decima.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-diocst.adb gcc-4.4.0/gcc/ada/a-diocst.adb *** gcc-4.3.3/gcc/ada/a-diocst.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-diocst.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-diocst.ads gcc-4.4.0/gcc/ada/a-diocst.ads *** gcc-4.3.3/gcc/ada/a-diocst.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-diocst.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-direct.adb gcc-4.4.0/gcc/ada/a-direct.adb *** gcc-4.3.3/gcc/ada/a-direct.adb Thu Dec 13 10:41:38 2007 --- gcc-4.4.0/gcc/ada/a-direct.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Directories is *** 158,174 **** if Containing_Directory /= "" and then not Is_Valid_Path_Name (Containing_Directory) then ! raise Name_Error; elsif Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name)) then ! raise Name_Error; elsif Extension'Length /= 0 and then not Is_Valid_Simple_Name (Name & '.' & Extension) then ! raise Name_Error; -- This is not an invalid case so build the path name --- 156,175 ---- if Containing_Directory /= "" and then not Is_Valid_Path_Name (Containing_Directory) then ! raise Name_Error with ! "invalid directory path name """ & Containing_Directory & '"'; elsif Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name)) then ! raise Name_Error with ! "invalid simple name """ & Name & '"'; elsif Extension'Length /= 0 and then not Is_Valid_Simple_Name (Name & '.' & Extension) then ! raise Name_Error with ! "invalid file name """ & Name & '.' & Extension & '"'; -- This is not an invalid case so build the path name *************** package body Ada.Directories is *** 211,217 **** -- First, the invalid case if not Is_Valid_Path_Name (Name) then ! raise Name_Error; else declare --- 212,218 ---- -- First, the invalid case if not Is_Valid_Path_Name (Name) then ! raise Name_Error with "invalid path name """ & Name & '"'; else declare *************** package body Ada.Directories is *** 242,248 **** and then (Norm (Norm'First) in 'a' .. 'z' or else Norm (Norm'First) in 'A' .. 'Z')))) then ! raise Use_Error; else declare --- 243,250 ---- and then (Norm (Norm'First) in 'a' .. 'z' or else Norm (Norm'First) in 'A' .. 'Z')))) then ! raise Use_Error with ! "directory """ & Name & """ has no containing directory"; else declare *************** package body Ada.Directories is *** 309,322 **** begin -- First, the invalid cases ! if not Is_Valid_Path_Name (Source_Name) ! or else not Is_Valid_Path_Name (Target_Name) ! or else not Is_Regular_File (Source_Name) ! then ! raise Name_Error; elsif Is_Directory (Target_Name) then ! raise Use_Error; else -- The implementation uses System.OS_Lib.Copy_File, with parameters --- 311,329 ---- begin -- First, the invalid cases ! if not Is_Valid_Path_Name (Source_Name) then ! raise Name_Error with ! "invalid source path name """ & Source_Name & '"'; ! ! elsif not Is_Valid_Path_Name (Target_Name) then ! raise Name_Error with ! "invalid target path name """ & Target_Name & '"'; ! ! elsif not Is_Regular_File (Source_Name) then ! raise Name_Error with '"' & Source_Name & """ is not a file"; elsif Is_Directory (Target_Name) then ! raise Use_Error with "target """ & Target_Name & """ is a directory"; else -- The implementation uses System.OS_Lib.Copy_File, with parameters *************** package body Ada.Directories is *** 325,331 **** Copy_File (Source_Name, Target_Name, Success, Overwrite, None); if not Success then ! raise Use_Error; end if; end if; end Copy_File; --- 332,338 ---- Copy_File (Source_Name, Target_Name, Success, Overwrite, None); if not Success then ! raise Use_Error with "copy of """ & Source_Name & """ failed"; end if; end if; end Copy_File; *************** package body Ada.Directories is *** 349,359 **** -- First, the invalid case if not Is_Valid_Path_Name (New_Directory) then ! raise Name_Error; else if mkdir (C_Dir_Name) /= 0 then ! raise Use_Error; end if; end if; end Create_Directory; --- 356,368 ---- -- First, the invalid case if not Is_Valid_Path_Name (New_Directory) then ! raise Name_Error with ! "invalid new directory path name """ & New_Directory & '"'; else if mkdir (C_Dir_Name) /= 0 then ! raise Use_Error with ! "creation of new directory """ & New_Directory & """ failed"; end if; end if; end Create_Directory; *************** package body Ada.Directories is *** 375,381 **** -- First, the invalid case if not Is_Valid_Path_Name (New_Directory) then ! raise Name_Error; else -- Build New_Dir with a directory separator at the end, so that the --- 384,391 ---- -- First, the invalid case if not Is_Valid_Path_Name (New_Directory) then ! raise Name_Error with ! "invalid new directory path name """ & New_Directory & '"'; else -- Build New_Dir with a directory separator at the end, so that the *************** package body Ada.Directories is *** 410,416 **** -- It is an error if a file with such a name already exists elsif Is_Regular_File (New_Dir (1 .. Last)) then ! raise Use_Error; else Create_Directory (New_Directory => New_Dir (1 .. Last)); --- 420,427 ---- -- It is an error if a file with such a name already exists elsif Is_Regular_File (New_Dir (1 .. Last)) then ! raise Use_Error with ! "file """ & New_Dir (1 .. Last) & """ already exists"; else Create_Directory (New_Directory => New_Dir (1 .. Last)); *************** package body Ada.Directories is *** 459,477 **** -- First, the invalid cases if not Is_Valid_Path_Name (Directory) then ! raise Name_Error; elsif not Is_Directory (Directory) then ! raise Name_Error; else declare C_Dir_Name : constant String := Directory & ASCII.NUL; begin rmdir (C_Dir_Name); if System.OS_Lib.Is_Directory (Directory) then ! raise Use_Error; end if; end; end if; --- 470,491 ---- -- First, the invalid cases if not Is_Valid_Path_Name (Directory) then ! raise Name_Error with ! "invalid directory path name """ & Directory & '"'; elsif not Is_Directory (Directory) then ! raise Name_Error with '"' & Directory & """ not a directory"; else declare C_Dir_Name : constant String := Directory & ASCII.NUL; + begin rmdir (C_Dir_Name); if System.OS_Lib.Is_Directory (Directory) then ! raise Use_Error with ! "deletion of directory """ & Directory & """ failed"; end if; end; end if; *************** package body Ada.Directories is *** 488,497 **** -- First, the invalid cases if not Is_Valid_Path_Name (Name) then ! raise Name_Error; elsif not Is_Regular_File (Name) then ! raise Name_Error; else -- The implementation uses System.OS_Lib.Delete_File --- 502,511 ---- -- First, the invalid cases if not Is_Valid_Path_Name (Name) then ! raise Name_Error with "invalid path name """ & Name & '"'; elsif not Is_Regular_File (Name) then ! raise Name_Error with "file """ & Name & """ does not exist"; else -- The implementation uses System.OS_Lib.Delete_File *************** package body Ada.Directories is *** 499,505 **** Delete_File (Name, Success); if not Success then ! raise Use_Error; end if; end if; end Delete_File; --- 513,519 ---- Delete_File (Name, Success); if not Success then ! raise Use_Error with "file """ & Name & """ could not be deleted"; end if; end if; end Delete_File; *************** package body Ada.Directories is *** 516,525 **** -- First, the invalid cases if not Is_Valid_Path_Name (Directory) then ! raise Name_Error; elsif not Is_Directory (Directory) then ! raise Name_Error; else Set_Directory (Directory); --- 530,540 ---- -- First, the invalid cases if not Is_Valid_Path_Name (Directory) then ! raise Name_Error with ! "invalid directory path name """ & Directory & '"'; elsif not Is_Directory (Directory) then ! raise Name_Error with '"' & Directory & """ not a directory"; else Set_Directory (Directory); *************** package body Ada.Directories is *** 553,559 **** rmdir (C_Dir_Name); if System.OS_Lib.Is_Directory (Directory) then ! raise Use_Error; end if; end; end if; --- 568,576 ---- rmdir (C_Dir_Name); if System.OS_Lib.Is_Directory (Directory) then ! raise Use_Error with ! "directory tree rooted at """ & ! Directory & """ could not be deleted"; end if; end; end if; *************** package body Ada.Directories is *** 568,574 **** -- First, the invalid case if not Is_Valid_Path_Name (Name) then ! raise Name_Error; else -- The implementation is in File_Exists --- 585,591 ---- -- First, the invalid case if not Is_Valid_Path_Name (Name) then ! raise Name_Error with "invalid path name """ & Name & '"'; else -- The implementation is in File_Exists *************** package body Ada.Directories is *** 586,592 **** -- First, the invalid case if not Is_Valid_Path_Name (Name) then ! raise Name_Error; else -- Look for first dot that is not followed by a directory separator --- 603,609 ---- -- First, the invalid case if not Is_Valid_Path_Name (Name) then ! raise Name_Error with "invalid path name """ & Name & '"'; else -- Look for first dot that is not followed by a directory separator *************** package body Ada.Directories is *** 769,775 **** -- First, the invalid case if not Is_Valid_Path_Name (Name) then ! raise Name_Error; else -- Build the return value with lower bound 1 --- 786,792 ---- -- First, the invalid case if not Is_Valid_Path_Name (Name) then ! raise Name_Error with "invalid path name """ & Name & '"'; else -- Build the return value with lower bound 1 *************** package body Ada.Directories is *** 791,797 **** -- First, the invalid case if not Directory_Entry.Is_Valid then ! raise Status_Error; else -- The value to return has already been computed --- 808,814 ---- -- First, the invalid case if not Directory_Entry.Is_Valid then ! raise Status_Error with "invalid directory entry"; else -- The value to return has already been computed *************** package body Ada.Directories is *** 812,818 **** -- First, the invalid case if Search.Value = null or else not Search.Value.Is_Valid then ! raise Status_Error; end if; -- Fetch the next entry, if needed --- 829,835 ---- -- First, the invalid case if Search.Value = null or else not Search.Value.Is_Valid then ! raise Status_Error with "invalid search"; end if; -- Fetch the next entry, if needed *************** package body Ada.Directories is *** 824,833 **** -- It is an error if no valid entry is found if not Search.Value.Is_Valid then ! raise Status_Error; else ! -- Reset Entry_Fatched and return the entry Search.Value.Entry_Fetched := False; Directory_Entry := Search.Value.Dir_Entry; --- 841,850 ---- -- It is an error if no valid entry is found if not Search.Value.Is_Valid then ! raise Status_Error with "no next entry"; else ! -- Reset Entry_Fetched and return the entry Search.Value.Entry_Fetched := False; Directory_Entry := Search.Value.Dir_Entry; *************** package body Ada.Directories is *** 843,849 **** -- First, the invalid case if not File_Exists (Name) then ! raise Name_Error; elsif Is_Regular_File (Name) then return Ordinary_File; --- 860,866 ---- -- First, the invalid case if not File_Exists (Name) then ! raise Name_Error with "file """ & Name & """ does not exist"; elsif Is_Regular_File (Name) then return Ordinary_File; *************** package body Ada.Directories is *** 861,867 **** -- First, the invalid case if not Directory_Entry.Is_Valid then ! raise Status_Error; else -- The value to return has already be computed --- 878,884 ---- -- First, the invalid case if not Directory_Entry.Is_Valid then ! raise Status_Error with "invalid directory entry"; else -- The value to return has already be computed *************** package body Ada.Directories is *** 888,894 **** -- First, the invalid cases if not (Is_Regular_File (Name) or else Is_Directory (Name)) then ! raise Name_Error; else Date := File_Time_Stamp (Name); --- 905,911 ---- -- First, the invalid cases if not (Is_Regular_File (Name) or else Is_Directory (Name)) then ! raise Name_Error with '"' & Name & """ not a file or directory"; else Date := File_Time_Stamp (Name); *************** package body Ada.Directories is *** 928,934 **** -- First, the invalid case if not Directory_Entry.Is_Valid then ! raise Status_Error; else -- The value to return has already be computed --- 945,951 ---- -- First, the invalid case if not Directory_Entry.Is_Valid then ! raise Status_Error with "invalid directory entry"; else -- The value to return has already be computed *************** package body Ada.Directories is *** 968,982 **** begin -- First, the invalid cases ! if not Is_Valid_Path_Name (Old_Name) ! or else not Is_Valid_Path_Name (New_Name) ! or else (not Is_Regular_File (Old_Name) ! and then not Is_Directory (Old_Name)) then ! raise Name_Error; elsif Is_Regular_File (New_Name) or Is_Directory (New_Name) then ! raise Use_Error; else -- The implementation uses System.OS_Lib.Rename_File --- 985,1005 ---- begin -- First, the invalid cases ! if not Is_Valid_Path_Name (Old_Name) then ! raise Name_Error with "invalid old path name """ & Old_Name & '"'; ! ! elsif not Is_Valid_Path_Name (New_Name) then ! raise Name_Error with "invalid new path name """ & New_Name & '"'; ! ! elsif not Is_Regular_File (Old_Name) ! and then not Is_Directory (Old_Name) then ! raise Name_Error with "old file """ & Old_Name & """ does not exist"; elsif Is_Regular_File (New_Name) or Is_Directory (New_Name) then ! raise Use_Error with ! "new name """ & New_Name ! & """ designates a file that already exists"; else -- The implementation uses System.OS_Lib.Rename_File *************** package body Ada.Directories is *** 984,990 **** Rename_File (Old_Name, New_Name, Success); if not Success then ! raise Use_Error; end if; end if; end Rename; --- 1007,1014 ---- Rename_File (Old_Name, New_Name, Success); if not Success then ! raise Use_Error with ! "file """ & Old_Name & """ could not be renamed"; end if; end if; end Rename; *************** package body Ada.Directories is *** 1025,1032 **** pragma Import (C, chdir, "chdir"); begin ! if chdir (C_Dir_Name) /= 0 then ! raise Name_Error; end if; end Set_Directory; --- 1049,1065 ---- pragma Import (C, chdir, "chdir"); begin ! if not Is_Valid_Path_Name (Directory) then ! raise Name_Error with ! "invalid directory path name & """ & Directory & '"'; ! ! elsif not Is_Directory (Directory) then ! raise Name_Error with ! "directory """ & Directory & """ does not exist"; ! ! elsif chdir (C_Dir_Name) /= 0 then ! raise Name_Error with ! "could not set to designated directory """ & Directory & '"'; end if; end Set_Directory; *************** package body Ada.Directories is *** 1103,1109 **** -- First, the invalid case if not Is_Valid_Path_Name (Name) then ! raise Name_Error; else -- Build the value to return with lower bound 1 --- 1136,1142 ---- -- First, the invalid case if not Is_Valid_Path_Name (Name) then ! raise Name_Error with "invalid path name """ & Name & '"'; else -- Build the value to return with lower bound 1 *************** package body Ada.Directories is *** 1135,1141 **** -- First, the invalid case if not Directory_Entry.Is_Valid then ! raise Status_Error; else -- The value to return has already be computed --- 1168,1174 ---- -- First, the invalid case if not Directory_Entry.Is_Valid then ! raise Status_Error with "invalid directory entry"; else -- The value to return has already be computed *************** package body Ada.Directories is *** 1158,1164 **** -- First, the invalid case if not Is_Regular_File (Name) then ! raise Name_Error; else C_Name (1 .. Name'Length) := Name; --- 1191,1197 ---- -- First, the invalid case if not Is_Regular_File (Name) then ! raise Name_Error with "file """ & Name & """ does not exist"; else C_Name (1 .. Name'Length) := Name; *************** package body Ada.Directories is *** 1172,1178 **** -- First, the invalid case if not Directory_Entry.Is_Valid then ! raise Status_Error; else -- The value to return has already be computed --- 1205,1211 ---- -- First, the invalid case if not Directory_Entry.Is_Valid then ! raise Status_Error with "invalid directory entry"; else -- The value to return has already be computed *************** package body Ada.Directories is *** 1195,1206 **** pragma Import (C, opendir, "__gnat_opendir"); C_File_Name : constant String := Directory & ASCII.NUL; begin ! -- First, the invalid case if not Is_Directory (Directory) then ! raise Name_Error; end if; -- If needed, finalize Search --- 1228,1259 ---- pragma Import (C, opendir, "__gnat_opendir"); C_File_Name : constant String := Directory & ASCII.NUL; + Pat : Regexp; + Dir : Dir_Type_Value; begin ! -- First, the invalid case Name_Error if not Is_Directory (Directory) then ! raise Name_Error with ! "unknown directory """ & Simple_Name (Directory) & '"'; ! end if; ! ! -- Check the pattern ! ! begin ! Pat := Compile (Pattern, Glob => True); ! exception ! when Error_In_Regexp => ! Free (Search.Value); ! raise Name_Error with "invalid pattern """ & Pattern & '"'; ! end; ! ! Dir := Dir_Type_Value (opendir (C_File_Name)); ! ! if Dir = No_Dir then ! raise Use_Error with ! "unreadable directory """ & Simple_Name (Directory) & '"'; end if; -- If needed, finalize Search *************** package body Ada.Directories is *** 1211,1232 **** Search.Value := new Search_Data; - begin - -- Check the pattern - - Search.Value.Pattern := Compile (Pattern, Glob => True); - - exception - when Error_In_Regexp => - Free (Search.Value); - raise Name_Error; - end; - -- Initialize some Search components ! Search.Value.Filter := Filter; ! Search.Value.Name := To_Unbounded_String (Full_Name (Directory)); ! Search.Value.Dir := Dir_Type_Value (opendir (C_File_Name)); Search.Value.Is_Valid := True; end Start_Search; --- 1264,1275 ---- Search.Value := new Search_Data; -- Initialize some Search components ! Search.Value.Filter := Filter; ! Search.Value.Name := To_Unbounded_String (Full_Name (Directory)); ! Search.Value.Pattern := Pat; ! Search.Value.Dir := Dir; Search.Value.Is_Valid := True; end Start_Search; diff -Nrcpad gcc-4.3.3/gcc/ada/a-direct.ads gcc-4.4.0/gcc/ada/a-direct.ads *** gcc-4.3.3/gcc/ada/a-direct.ads Wed Jun 6 10:49:20 2007 --- gcc-4.4.0/gcc/ada/a-direct.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived for use with GNAT from AI-00248, which is -- -- expected to be a part of a future expected revised Ada Reference Manual. -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived for use with GNAT from AI-00248, which is -- -- expected to be a part of a future expected revised Ada Reference Manual. -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Ada.Directories is *** 317,323 **** procedure End_Search (Search : in out Search_Type); -- Ends the search represented by Search. After a successful call on -- End_Search, the object Search will have no entries available. Note ! -- that is is not necessary to call End_Search if the call to Start_Search -- was unsuccessful and raised an exception (but it is harmless to make -- the call in this case). --- 315,321 ---- procedure End_Search (Search : in out Search_Type); -- Ends the search represented by Search. After a successful call on -- End_Search, the object Search will have no entries available. Note ! -- that it is not necessary to call End_Search if the call to Start_Search -- was unsuccessful and raised an exception (but it is harmless to make -- the call in this case). diff -Nrcpad gcc-4.3.3/gcc/ada/a-direio.adb gcc-4.4.0/gcc/ada/a-direio.adb *** gcc-4.3.3/gcc/ada/a-direio.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-direio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Direct_IO is *** 74,80 **** procedure Close (File : in out File_Type) is begin ! FIO.Close (AP (File)); end Close; ------------ --- 72,78 ---- procedure Close (File : in out File_Type) is begin ! FIO.Close (AP (File)'Unrestricted_Access); end Close; ------------ *************** package body Ada.Direct_IO is *** 98,104 **** procedure Delete (File : in out File_Type) is begin ! FIO.Delete (AP (File)); end Delete; ----------------- --- 96,102 ---- procedure Delete (File : in out File_Type) is begin ! FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- diff -Nrcpad gcc-4.3.3/gcc/ada/a-direio.ads gcc-4.4.0/gcc/ada/a-direio.ads *** gcc-4.3.3/gcc/ada/a-direio.ads Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/a-direio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Ada.Direct_IO is *** 48,53 **** --- 46,55 ---- (Element_Type'Has_Access_Values, "Element_Type for Direct_IO instance has access values"); + pragma Compile_Time_Warning + (Element_Type'Has_Tagged_Values, + "Element_Type for Direct_IO instance has tagged values"); + type File_Type is limited private; type File_Mode is (In_File, Inout_File, Out_File); *************** package Ada.Direct_IO is *** 134,139 **** --- 136,167 ---- Data_Error : exception renames IO_Exceptions.Data_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + type File_Type is new System.Direct_IO.File_Type; Bytes : constant Interfaces.C_Streams.size_t := diff -Nrcpad gcc-4.3.3/gcc/ada/a-dirval-mingw.adb gcc-4.4.0/gcc/ada/a-dirval-mingw.adb *** gcc-4.3.3/gcc/ada/a-dirval-mingw.adb Wed Jun 6 10:49:20 2007 --- gcc-4.4.0/gcc/ada/a-dirval-mingw.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (Windows Version) -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- B o d y -- -- (Windows Version) -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-dirval-vms.adb gcc-4.4.0/gcc/ada/a-dirval-vms.adb *** gcc-4.3.3/gcc/ada/a-dirval-vms.adb Wed Jun 6 10:49:20 2007 --- gcc-4.4.0/gcc/ada/a-dirval-vms.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (VMS Version) -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- B o d y -- -- (VMS Version) -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-dirval.adb gcc-4.4.0/gcc/ada/a-dirval.adb *** gcc-4.3.3/gcc/ada/a-dirval.adb Wed Jun 6 10:49:20 2007 --- gcc-4.4.0/gcc/ada/a-dirval.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (POSIX Version) -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- B o d y -- -- (POSIX Version) -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-dirval.ads gcc-4.4.0/gcc/ada/a-dirval.ads *** gcc-4.3.3/gcc/ada/a-dirval.ads Wed Jun 6 10:49:20 2007 --- gcc-4.4.0/gcc/ada/a-dirval.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-dynpri.adb gcc-4.4.0/gcc/ada/a-dynpri.adb *** gcc-4.3.3/gcc/ada/a-dynpri.adb Wed Jun 6 10:14:59 2007 --- gcc-4.4.0/gcc/ada/a-dynpri.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 32,52 **** ------------------------------------------------------------------------------ with System.Task_Primitives.Operations; - -- used for Write_Lock - -- Unlock - -- Set_Priority - -- Wakeup - -- Self - with System.Tasking; - -- used for Task_Id - with System.Parameters; - -- used for Single_Lock - with System.Soft_Links; - -- use for Abort_Defer - -- Abort_Undefer with Ada.Unchecked_Conversion; --- 30,38 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/a-einuoc.adb gcc-4.4.0/gcc/ada/a-einuoc.adb *** gcc-4.3.3/gcc/ada/a-einuoc.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/a-einuoc.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-einuoc.ads gcc-4.4.0/gcc/ada/a-einuoc.ads *** gcc-4.3.3/gcc/ada/a-einuoc.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/a-einuoc.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-elchha.adb gcc-4.4.0/gcc/ada/a-elchha.adb *** gcc-4.3.3/gcc/ada/a-elchha.adb Thu Sep 13 12:52:18 2007 --- gcc-4.4.0/gcc/ada/a-elchha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** pragma Compiler_Unit; *** 38,48 **** pragma Warnings (On); with System.Standard_Library; use System.Standard_Library; - -- Used for Adafinal - with System.Soft_Links; - -- Used for Task_Termination_Handler - -- Task_Termination_NT procedure Ada.Exceptions.Last_Chance_Handler (Except : Exception_Occurrence) --- 36,42 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/a-elchha.ads gcc-4.4.0/gcc/ada/a-elchha.ads *** gcc-4.3.3/gcc/ada/a-elchha.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/a-elchha.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-envvar.adb gcc-4.4.0/gcc/ada/a-envvar.adb *** gcc-4.3.3/gcc/ada/a-envvar.adb Wed Feb 15 09:32:52 2006 --- gcc-4.4.0/gcc/ada/a-envvar.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-excach.adb gcc-4.4.0/gcc/ada/a-excach.adb *** gcc-4.3.3/gcc/ada/a-excach.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-excach.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-except-2005.adb gcc-4.4.0/gcc/ada/a-except-2005.adb *** gcc-4.3.3/gcc/ada/a-except-2005.adb Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/a-except-2005.adb Thu Apr 9 23:23:07 2009 *************** *** 6,46 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This version is used for all Ada 2005 builds. It differs from a-except.ads ! -- only with respect to the addition of Wide_[Wide]Exception_Name functions. -- The reason for this splitting off of a separate version is that bootstrap -- compilers often will be used that do not support Ada 2005 features, and -- Ada.Exceptions is part of the compiler sources. - -- The base version of this unit Ada.Exceptions omits the Wide version of - -- Exception_Name and is used to build the compiler and other basic tools. - pragma Style_Checks (All_Checks); -- No subprogram ordering check, due to logical grouping --- 6,42 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This version of Ada.Exceptions fully supports both Ada 95 and Ada 2005. ! -- It is used in all situations except for the build of the compiler and ! -- other basic tools. For these latter builds, we use an Ada 95-only version. -- The reason for this splitting off of a separate version is that bootstrap -- compilers often will be used that do not support Ada 2005 features, and -- Ada.Exceptions is part of the compiler sources. pragma Style_Checks (All_Checks); -- No subprogram ordering check, due to logical grouping *************** package body Ada.Exceptions is *** 398,404 **** -- is deferred before the reraise operation. -- Save_Occurrence variations: As the management of the private data ! -- attached to occurrences is delicate, wether or not pointers to such -- data has to be copied in various situations is better made explicit. -- The following procedures provide an internal interface to help making -- this explicit. --- 394,400 ---- -- is deferred before the reraise operation. -- Save_Occurrence variations: As the management of the private data ! -- attached to occurrences is delicate, whether or not pointers to such -- data has to be copied in various situations is better made explicit. -- The following procedures provide an internal interface to help making -- this explicit. *************** package body Ada.Exceptions is *** 422,432 **** -- Run-Time Check Routines -- ----------------------------- ! -- These routines are called from the runtime to raise a specific ! -- exception with a reason message attached. The parameters are ! -- the file name and line number in each case. The names are keyed ! -- to the codes defined in Types.ads and a-types.h (for example, ! -- the name Rcheck_05 refers to the Reason whose Pos code is 5). procedure Rcheck_00 (File : System.Address; Line : Integer); procedure Rcheck_01 (File : System.Address; Line : Integer); --- 418,428 ---- -- Run-Time Check Routines -- ----------------------------- ! -- These routines raise a specific exception with a reason message ! -- attached. The parameters are the file name and line number in each ! -- case. The names are keyed to the codes defined in types.ads and ! -- a-types.h (for example, the name Rcheck_05 refers to the Reason ! -- RT_Exception_Code'Val (5)). procedure Rcheck_00 (File : System.Address; Line : Integer); procedure Rcheck_01 (File : System.Address; Line : Integer); *************** package body Ada.Exceptions is *** 840,859 **** (E : Exception_Id; Message : String := "") is begin ! if E /= null then ! Exception_Data.Set_Exception_Msg (E, Message); ! Abort_Defer.all; ! Raise_Current_Excep (E); end if; ! -- Note: if E is null, then we simply return, which is correct Ada 95 ! -- semantics. If we are operating in Ada 2005 mode, then the expander ! -- generates a raise Constraint_Error immediately following the call ! -- to provide the required Ada 2005 semantics (see AI-329). We do it ! -- this way to avoid having run time dependencies on the Ada version. ! return; end Raise_Exception; ---------------------------- --- 836,855 ---- (E : Exception_Id; Message : String := "") is + EF : Exception_Id := E; + begin ! -- Raise CE if E = Null_ID (AI-446) ! ! if E = null then ! EF := Constraint_Error'Identity; end if; ! -- Go ahead and raise appropriate exception ! Exception_Data.Set_Exception_Msg (EF, Message); ! Abort_Defer.all; ! Raise_Current_Excep (EF); end Raise_Exception; ---------------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/a-except-2005.ads gcc-4.4.0/gcc/ada/a-except-2005.ads *** gcc-4.3.3/gcc/ada/a-except-2005.ads Wed Jun 6 10:46:09 2007 --- gcc-4.4.0/gcc/ada/a-except-2005.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,52 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This version is used for all Ada 2005 builds. It differs from a-except.ads ! -- only with respect to the addition of Wide_[Wide]Exception_Name functions. ! -- The additional entities are marked with pragma Ada_05, so this extended ! -- unit is also perfectly suitable for use in Ada 95 or Ada 83 mode. -- The reason for this splitting off of a separate version is that bootstrap -- compilers often will be used that do not support Ada 2005 features, and -- Ada.Exceptions is part of the compiler sources. - -- The base version of this unit Ada.Exceptions omits the Wide version of - -- Exception_Name and is used to build the compiler and other basic tools. - pragma Polling (Off); -- We must turn polling off for this unit, because otherwise we get -- elaboration circularities with ourself. --- 14,46 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This version of Ada.Exceptions fully supports both Ada 95 and Ada 2005. ! -- It is used in all situations except for the build of the compiler and ! -- other basic tools. For these latter builds, we use an Ada 95-only version. -- The reason for this splitting off of a separate version is that bootstrap -- compilers often will be used that do not support Ada 2005 features, and -- Ada.Exceptions is part of the compiler sources. pragma Polling (Off); -- We must turn polling off for this unit, because otherwise we get -- elaboration circularities with ourself. *************** package Ada.Exceptions is *** 97,108 **** pragma Ada_05 (Wide_Wide_Exception_Name); procedure Raise_Exception (E : Exception_Id; Message : String := ""); ! -- Note: it would be really nice to give a pragma No_Return for this ! -- procedure, but it would be wrong, since Raise_Exception does return ! -- if given the null exception. However we do special case the name in ! -- the test in the compiler for issuing a warning for a missing return ! -- after this call. Program_Error seems reasonable enough in such a case. ! -- See also the routine Raise_Exception_Always in the private part. function Exception_Message (X : Exception_Occurrence) return String; --- 91,98 ---- pragma Ada_05 (Wide_Wide_Exception_Name); procedure Raise_Exception (E : Exception_Id; Message : String := ""); ! pragma No_Return (Raise_Exception); ! -- Note: In accordance with AI-466, CE is raised if E = Null_Id function Exception_Message (X : Exception_Occurrence) return String; *************** package Ada.Exceptions is *** 139,149 **** (Source : Exception_Occurrence) return Exception_Occurrence_Access; ! -- Ada 2005 (AI-438): The language revision introduces the ! -- following subprograms and attribute definitions. We do not ! -- provide them explicitly; instead, the corresponding stream ! -- attributes are made available through a pragma Stream_Convert ! -- in the private part of this package. -- procedure Read_Exception_Occurrence -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; --- 129,138 ---- (Source : Exception_Occurrence) return Exception_Occurrence_Access; ! -- Ada 2005 (AI-438): The language revision introduces the following ! -- subprograms and attribute definitions. We do not provide them ! -- explicitly. instead, the corresponding stream attributes are made ! -- available through a pragma Stream_Convert in the private part. -- procedure Read_Exception_Occurrence -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; *************** private *** 213,222 **** pragma No_Return (Raise_Exception_Always); pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); -- This differs from Raise_Exception only in that the caller has determined ! -- that for sure the parameter E is not null, and that therefore the call ! -- to this procedure cannot return. The expander converts Raise_Exception ! -- calls to Raise_Exception_Always if it can determine this is the case. ! -- The Export allows this routine to be accessed from Pure units. procedure Raise_From_Signal_Handler (E : Exception_Id; --- 202,211 ---- pragma No_Return (Raise_Exception_Always); pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); -- This differs from Raise_Exception only in that the caller has determined ! -- that for sure the parameter E is not null, and that therefore no check ! -- for Null_Id is required. The expander converts Raise_Exception calls to ! -- Raise_Exception_Always if it can determine this is the case. The Export ! -- allows this routine to be accessed from Pure units. procedure Raise_From_Signal_Handler (E : Exception_Id; *************** private *** 239,245 **** procedure Raise_From_Controlled_Operation (X : Ada.Exceptions.Exception_Occurrence); pragma No_Return (Raise_From_Controlled_Operation); ! -- Raise Program_Error, proviving information about X (an exception -- raised during a controlled operation) in the exception message. procedure Reraise_Occurrence_Always (X : Exception_Occurrence); --- 228,234 ---- procedure Raise_From_Controlled_Operation (X : Ada.Exceptions.Exception_Occurrence); pragma No_Return (Raise_From_Controlled_Operation); ! -- Raise Program_Error, providing information about X (an exception -- raised during a controlled operation) in the exception message. procedure Reraise_Occurrence_Always (X : Exception_Occurrence); *************** private *** 270,276 **** -- purposes (e.g. implementing watchpoints in software or in the debugger). -- In the GNAT technology itself, this interface is used to implement ! -- immediate aynschronous transfer of control and immediate abort on -- targets which do not provide for one thread interrupting another. -- Note: this used to be in a separate unit called System.Poll, but that --- 259,265 ---- -- purposes (e.g. implementing watchpoints in software or in the debugger). -- In the GNAT technology itself, this interface is used to implement ! -- immediate asynchronous transfer of control and immediate abort on -- targets which do not provide for one thread interrupting another. -- Note: this used to be in a separate unit called System.Poll, but that diff -Nrcpad gcc-4.3.3/gcc/ada/a-except.adb gcc-4.4.0/gcc/ada/a-except.adb *** gcc-4.3.3/gcc/ada/a-except.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/a-except.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 39,45 **** -- builds may be done with bootstrap compilers that cannot handle these -- additions. The full version of Ada.Exceptions can be found in the files -- a-except-2005.ads/adb, and is used for all other builds where full Ada ! -- 2005 functionality is required. in particular, it is used for building -- run times on all targets. pragma Warnings (Off); --- 37,43 ---- -- builds may be done with bootstrap compilers that cannot handle these -- additions. The full version of Ada.Exceptions can be found in the files -- a-except-2005.ads/adb, and is used for all other builds where full Ada ! -- 2005 functionality is required. In particular, it is used for building -- run times on all targets. pragma Warnings (Off); *************** package body Ada.Exceptions is *** 353,359 **** -- is deferred before the reraise operation. -- Save_Occurrence variations: As the management of the private data ! -- attached to occurrences is delicate, wether or not pointers to such -- data has to be copied in various situations is better made explicit. -- The following procedures provide an internal interface to help making -- this explicit. --- 351,357 ---- -- is deferred before the reraise operation. -- Save_Occurrence variations: As the management of the private data ! -- attached to occurrences is delicate, whether or not pointers to such -- data has to be copied in various situations is better made explicit. -- The following procedures provide an internal interface to help making -- this explicit. *************** package body Ada.Exceptions is *** 377,387 **** -- Run-Time Check Routines -- ----------------------------- ! -- These routines are called from the runtime to raise a specific ! -- exception with a reason message attached. The parameters are ! -- the file name and line number in each case. The names are keyed ! -- to the codes defined in Types.ads and a-types.h (for example, ! -- the name Rcheck_05 refers to the Reason whose Pos code is 5). procedure Rcheck_00 (File : System.Address; Line : Integer); procedure Rcheck_01 (File : System.Address; Line : Integer); --- 375,385 ---- -- Run-Time Check Routines -- ----------------------------- ! -- These routines raise a specific exception with a reason message ! -- attached. The parameters are the file name and line number in each ! -- case. The names are keyed to the codes defined in types.ads and ! -- a-types.h (for example, the name Rcheck_05 refers to the Reason ! -- RT_Exception_Code'Val (5)). procedure Rcheck_00 (File : System.Address; Line : Integer); procedure Rcheck_01 (File : System.Address; Line : Integer); *************** package body Ada.Exceptions is *** 807,822 **** (E : Exception_Id; Message : String := "") is begin ! if E /= null then ! Exception_Data.Set_Exception_Msg (E, Message); ! Abort_Defer.all; ! Raise_Current_Excep (E); end if; ! -- Note: if E is null then just return (Ada 95 semantics) ! return; end Raise_Exception; ---------------------------- --- 805,824 ---- (E : Exception_Id; Message : String := "") is + EF : Exception_Id := E; + begin ! -- Raise CE if E = Null_ID (AI-446) ! ! if E = null then ! EF := Constraint_Error'Identity; end if; ! -- Go ahead and raise appropriate exception ! Exception_Data.Set_Exception_Msg (EF, Message); ! Abort_Defer.all; ! Raise_Current_Excep (EF); end Raise_Exception; ---------------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/a-except.ads gcc-4.4.0/gcc/ada/a-except.ads *** gcc-4.3.3/gcc/ada/a-except.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/a-except.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 43,49 **** -- builds may be done with bootstrap compilers that cannot handle these -- additions. The full version of Ada.Exceptions can be found in the files -- a-except-2005.ads/adb, and is used for all other builds where full Ada ! -- 2005 functionality is required. in particular, it is used for building -- run times on all targets. pragma Polling (Off); --- 41,47 ---- -- builds may be done with bootstrap compilers that cannot handle these -- additions. The full version of Ada.Exceptions can be found in the files -- a-except-2005.ads/adb, and is used for all other builds where full Ada ! -- 2005 functionality is required. In particular, it is used for building -- run times on all targets. pragma Polling (Off); *************** package Ada.Exceptions is *** 84,95 **** function Exception_Name (Id : Exception_Id) return String; procedure Raise_Exception (E : Exception_Id; Message : String := ""); ! -- Note: it would be really nice to give a pragma No_Return for this ! -- procedure, but it would be wrong, since Raise_Exception does return if ! -- given the null exception in Ada 95 mode. However we do special case the ! -- name in the test in the compiler for issuing a warning for a missing ! -- return after this call. Program_Error seems reasonable enough in such a ! -- case. See also the routine Raise_Exception_Always in the private part. function Exception_Message (X : Exception_Occurrence) return String; --- 82,89 ---- function Exception_Name (Id : Exception_Id) return String; procedure Raise_Exception (E : Exception_Id; Message : String := ""); ! pragma No_Return (Raise_Exception); ! -- Note: In accordance with AI-466, CE is raised if E = Null_Id function Exception_Message (X : Exception_Occurrence) return String; *************** private *** 183,192 **** pragma No_Return (Raise_Exception_Always); pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); -- This differs from Raise_Exception only in that the caller has determined ! -- that for sure the parameter E is not null, and that therefore the call ! -- to this procedure cannot return. The expander converts Raise_Exception ! -- calls to Raise_Exception_Always if it can determine this is the case. ! -- The Export allows this routine to be accessed from Pure units. procedure Raise_From_Signal_Handler (E : Exception_Id; --- 177,186 ---- pragma No_Return (Raise_Exception_Always); pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); -- This differs from Raise_Exception only in that the caller has determined ! -- that for sure the parameter E is not null, and that therefore no check ! -- for Null_Id is required. The expander converts Raise_Exception calls to ! -- Raise_Exception_Always if it can determine this is the case. The Export ! -- allows this routine to be accessed from Pure units. procedure Raise_From_Signal_Handler (E : Exception_Id; *************** private *** 209,215 **** procedure Raise_From_Controlled_Operation (X : Ada.Exceptions.Exception_Occurrence); pragma No_Return (Raise_From_Controlled_Operation); ! -- Raise Program_Error, proviving information about X (an exception -- raised during a controlled operation) in the exception message. procedure Reraise_Occurrence_Always (X : Exception_Occurrence); --- 203,209 ---- procedure Raise_From_Controlled_Operation (X : Ada.Exceptions.Exception_Occurrence); pragma No_Return (Raise_From_Controlled_Operation); ! -- Raise Program_Error, providing information about X (an exception -- raised during a controlled operation) in the exception message. procedure Reraise_Occurrence_Always (X : Exception_Occurrence); *************** private *** 240,246 **** -- purposes (e.g. implementing watchpoints in software or in the debugger). -- In the GNAT technology itself, this interface is used to implement ! -- immediate aynschronous transfer of control and immediate abort on -- targets which do not provide for one thread interrupting another. -- Note: this used to be in a separate unit called System.Poll, but that --- 234,240 ---- -- purposes (e.g. implementing watchpoints in software or in the debugger). -- In the GNAT technology itself, this interface is used to implement ! -- immediate asynchronous transfer of control and immediate abort on -- targets which do not provide for one thread interrupting another. -- Note: this used to be in a separate unit called System.Poll, but that diff -Nrcpad gcc-4.3.3/gcc/ada/a-excpol-abort.adb gcc-4.4.0/gcc/ada/a-excpol-abort.adb *** gcc-4.3.3/gcc/ada/a-excpol-abort.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/a-excpol-abort.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 7,29 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** pragma Warnings (Off); *** 45,51 **** -- It is safe in the context of the run-time to violate the rules! with System.Soft_Links; - -- used for Check_Abort_Status pragma Warnings (On); --- 43,48 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/a-excpol.adb gcc-4.4.0/gcc/ada/a-excpol.adb *** gcc-4.3.3/gcc/ada/a-excpol.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/a-excpol.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (dummy version where polling is not used) -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 7,29 ---- -- B o d y -- -- (dummy version where polling is not used) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-exctra.adb gcc-4.4.0/gcc/ada/a-exctra.adb *** gcc-4.3.3/gcc/ada/a-exctra.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-exctra.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-exctra.ads gcc-4.4.0/gcc/ada/a-exctra.ads *** gcc-4.3.3/gcc/ada/a-exctra.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-exctra.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-exetim-mingw.adb gcc-4.4.0/gcc/ada/a-exetim-mingw.adb *** gcc-4.3.3/gcc/ada/a-exetim-mingw.adb Tue Aug 14 08:44:02 2007 --- gcc-4.4.0/gcc/ada/a-exetim-mingw.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** with Ada.Unchecked_Conversion; *** 39,44 **** --- 37,43 ---- with System.OS_Interface; use System.OS_Interface; with System.Task_Primitives.Operations; use System.Task_Primitives.Operations; with System.Tasking; use System.Tasking; + with System.Win32; use System.Win32; package body Ada.Execution_Time is *************** package body Ada.Execution_Time is *** 118,124 **** (HANDLE (Get_Thread_Id (To_Task_Id (T))), C_Time'Access, E_Time'Access, K_Time'Access, U_Time'Access); ! if Res = False then raise Program_Error; end if; --- 117,123 ---- (HANDLE (Get_Thread_Id (To_Task_Id (T))), C_Time'Access, E_Time'Access, K_Time'Access, U_Time'Access); ! if Res = System.Win32.FALSE then raise Program_Error; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/a-exetim-mingw.ads gcc-4.4.0/gcc/ada/a-exetim-mingw.ads *** gcc-4.3.3/gcc/ada/a-exetim-mingw.ads Tue Aug 14 08:44:02 2007 --- gcc-4.4.0/gcc/ada/a-exetim-mingw.ads Thu Apr 9 23:23:07 2009 *************** *** 6,32 **** -- -- -- S p e c -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- -- apply solely to the contents of the part following the private keyword. -- -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,32 ---- -- -- -- S p e c -- -- -- + -- Copyright (C) 2009 Free Software Foundation, Inc. -- + -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- -- apply solely to the contents of the part following the private keyword. -- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-exexda.adb gcc-4.4.0/gcc/ada/a-exexda.adb *** gcc-4.3.3/gcc/ada/a-exexda.adb Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/a-exexda.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Exception_Data is *** 186,192 **** function Basic_Exception_Traceback (X : Exception_Occurrence) return String; -- Returns an image of the complete call chain associated with an ! -- exception occurence in its most basic form, that is as a raw sequence -- of hexadecimal binary addresses. function Tailored_Exception_Traceback --- 184,190 ---- function Basic_Exception_Traceback (X : Exception_Occurrence) return String; -- Returns an image of the complete call chain associated with an ! -- exception occurrence in its most basic form, that is as a raw sequence -- of hexadecimal binary addresses. function Tailored_Exception_Traceback *************** package body Exception_Data is *** 327,333 **** Ptr : in out Natural) is Name : String (1 .. Exception_Name_Length (X)); ! -- Bufer in which to fetch the exception name, in order to check -- whether this is an internal _ABORT_SIGNAL or a regular occurrence. Name_Ptr : Natural := Name'First - 1; --- 325,331 ---- Ptr : in out Natural) is Name : String (1 .. Exception_Name_Length (X)); ! -- Buffer in which to fetch the exception name, in order to check -- whether this is an internal _ABORT_SIGNAL or a regular occurrence. Name_Ptr : Natural := Name'First - 1; diff -Nrcpad gcc-4.3.3/gcc/ada/a-exexpr-gcc.adb gcc-4.4.0/gcc/ada/a-exexpr-gcc.adb *** gcc-4.3.3/gcc/ada/a-exexpr-gcc.adb Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/a-exexpr-gcc.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Exception_Propagation is *** 47,53 **** -- These come from "C++ ABI for Itanium: Exception handling", which is -- the reference for GCC. They are used only when we are relying on ! -- back-end tables for exception propagation, which in turn is currenly -- only the case for Zero_Cost_Exceptions in GNAT5. -- Return codes from the GCC runtime functions used to propagate --- 45,51 ---- -- These come from "C++ ABI for Itanium: Exception handling", which is -- the reference for GCC. They are used only when we are relying on ! -- back-end tables for exception propagation, which in turn is currently -- only the case for Zero_Cost_Exceptions in GNAT5. -- Return codes from the GCC runtime functions used to propagate *************** package body Exception_Propagation is *** 132,138 **** Id : Exception_Id; -- GNAT Exception identifier. This is filled by Propagate_Exception -- and then used by the personality routine to determine if the context ! -- it examines contains a handler for the exception beeing propagated. N_Cleanups_To_Trigger : Integer; -- Number of cleanup only frames encountered in SEARCH phase. This is --- 130,136 ---- Id : Exception_Id; -- GNAT Exception identifier. This is filled by Propagate_Exception -- and then used by the personality routine to determine if the context ! -- it examines contains a handler for the exception being propagated. N_Cleanups_To_Trigger : Integer; -- Number of cleanup only frames encountered in SEARCH phase. This is *************** package body Exception_Propagation is *** 160,167 **** -- by the personality routine through the accessors declared below. Ada -- specific fields are thus always accessed through consistent layout, and -- we expect the actual alignment to always be large enough to avoid traps ! -- from the C accesses to the common header. Besides, accessors aleviate ! -- the need for a C struct whole conterpart, both painful and errorprone -- to maintain anyway. type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; --- 158,165 ---- -- by the personality routine through the accessors declared below. Ada -- specific fields are thus always accessed through consistent layout, and -- we expect the actual alignment to always be large enough to avoid traps ! -- from the C accesses to the common header. Besides, accessors alleviate ! -- the need for a C struct whole counterpart, both painful and error-prone -- to maintain anyway. type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; *************** package body Exception_Propagation is *** 670,676 **** ----------- -- The current model implemented for the stack of occurrences is a ! -- simplification of previous attempts, which all prooved to be flawed or -- would have needed significant additional circuitry to be made to work -- correctly. --- 668,674 ---- ----------- -- The current model implemented for the stack of occurrences is a ! -- simplification of previous attempts, which all proved to be flawed or -- would have needed significant additional circuitry to be made to work -- correctly. *************** package body Exception_Propagation is *** 685,691 **** -- interface. -- The basic point is that arranging for an occurrence to always appear at ! -- most once on the stack requires a way to determine if a given occurence -- is already there, which is not as easy as it might seem. -- An attempt was made to use the Private_Data pointer for this purpose. --- 683,689 ---- -- interface. -- The basic point is that arranging for an occurrence to always appear at ! -- most once on the stack requires a way to determine if a given occurrence -- is already there, which is not as easy as it might seem. -- An attempt was made to use the Private_Data pointer for this purpose. *************** package body Exception_Propagation is *** 725,731 **** -- but making this to work while still avoiding memory leaks is far -- from trivial. ! -- The current scheme has the advantage of beeing simple, and induces -- extra costs only in reraise cases which is acceptable. end Exception_Propagation; --- 723,729 ---- -- but making this to work while still avoiding memory leaks is far -- from trivial. ! -- The current scheme has the advantage of being simple, and induces -- extra costs only in reraise cases which is acceptable. end Exception_Propagation; diff -Nrcpad gcc-4.3.3/gcc/ada/a-exexpr.adb gcc-4.4.0/gcc/ada/a-exexpr.adb *** gcc-4.3.3/gcc/ada/a-exexpr.adb Wed Feb 15 09:31:54 2006 --- gcc-4.4.0/gcc/ada/a-exexpr.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Exception_Propagation is *** 58,64 **** is pragma Unreferenced (Excep, Current, Reraised); begin ! -- In the GNAT-SJLJ case this "stack" only exists implicitely, by way of -- local occurrence declarations together with save/restore operations -- generated by the front-end, and this routine has nothing to do. --- 56,62 ---- is pragma Unreferenced (Excep, Current, Reraised); begin ! -- In the GNAT-SJLJ case this "stack" only exists implicitly, by way of -- local occurrence declarations together with save/restore operations -- generated by the front-end, and this routine has nothing to do. diff -Nrcpad gcc-4.3.3/gcc/ada/a-exextr.adb gcc-4.4.0/gcc/ada/a-exextr.adb *** gcc-4.3.3/gcc/ada/a-exextr.adb Wed Jun 6 10:18:34 2007 --- gcc-4.4.0/gcc/ada/a-exextr.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Exception_Traces is *** 208,214 **** -- the termination routine. Avoiding the second output is possible but so -- far has been considered undesirable. It would mean changing the order -- of outputs between the two runs with or without exception traces, while ! -- it seems preferrable to only have additional outputs in the former -- case. end Exception_Traces; --- 206,212 ---- -- the termination routine. Avoiding the second output is possible but so -- far has been considered undesirable. It would mean changing the order -- of outputs between the two runs with or without exception traces, while ! -- it seems preferable to only have additional outputs in the former -- case. end Exception_Traces; diff -Nrcpad gcc-4.3.3/gcc/ada/a-exstat.adb gcc-4.4.0/gcc/ada/a-exstat.adb *** gcc-4.3.3/gcc/ada/a-exstat.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-exstat.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-filico.adb gcc-4.4.0/gcc/ada/a-filico.adb *** gcc-4.3.3/gcc/ada/a-filico.adb Tue Oct 31 17:48:46 2006 --- gcc-4.4.0/gcc/ada/a-filico.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-filico.ads gcc-4.4.0/gcc/ada/a-filico.ads *** gcc-4.3.3/gcc/ada/a-filico.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-filico.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Ada.Finalization.List_Controller *** 58,64 **** -- List_Controller -- --------------------- ! -- Management of a bidirectional linked heterogenous list of -- dynamically Allocated objects. To simplify the management of the -- linked list, the First and Last elements are statically part of the -- original List controller: --- 56,62 ---- -- List_Controller -- --------------------- ! -- Management of a bidirectional linked heterogeneous list of -- dynamically Allocated objects. To simplify the management of the -- linked list, the First and Last elements are statically part of the -- original List controller: diff -Nrcpad gcc-4.3.3/gcc/ada/a-finali.adb gcc-4.4.0/gcc/ada/a-finali.adb *** gcc-4.3.3/gcc/ada/a-finali.adb Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/a-finali.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-finali.ads gcc-4.4.0/gcc/ada/a-finali.ads *** gcc-4.3.3/gcc/ada/a-finali.ads Wed Jun 6 10:18:51 2007 --- gcc-4.4.0/gcc/ada/a-finali.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 64,70 **** type Controlled is abstract new SFR.Root_Controlled with null record; function "=" (A, B : Controlled) return Boolean; ! -- Need to be defined explictly because we don't want to compare the -- hidden pointers type Limited_Controlled is --- 62,68 ---- type Controlled is abstract new SFR.Root_Controlled with null record; function "=" (A, B : Controlled) return Boolean; ! -- Need to be defined explicitly because we don't want to compare the -- hidden pointers type Limited_Controlled is diff -Nrcpad gcc-4.3.3/gcc/ada/a-interr.ads gcc-4.4.0/gcc/ada/a-interr.ads *** gcc-4.3.3/gcc/ada/a-interr.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-interr.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 36,42 **** ------------------------------------------------------------------------------ with System.Interrupts; - -- used for Ada_Interrupt_ID package Ada.Interrupts is --- 34,39 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-aix.ads gcc-4.4.0/gcc/ada/a-intnam-aix.ads *** gcc-4.3.3/gcc/ada/a-intnam-aix.ads Wed Jun 6 10:14:35 2007 --- gcc-4.4.0/gcc/ada/a-intnam-aix.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2006, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 51,63 **** -- supported by the local system. with System.OS_Interface; - -- used for names of interrupts package Ada.Interrupts.Names is -- Beware that the mapping of names to signals may be many-to-one. There ! -- may be aliases. Also, for all signal names that are not supported on the ! -- current system the value of the corresponding constant will be zero. SIGHUP : constant Interrupt_ID := System.OS_Interface.SIGHUP; -- hangup --- 49,60 ---- -- supported by the local system. with System.OS_Interface; package Ada.Interrupts.Names is -- Beware that the mapping of names to signals may be many-to-one. There ! -- may be aliases. Also, for all signal names that are not supported on ! -- the current system the value of the corresponding constant will be zero. SIGHUP : constant Interrupt_ID := System.OS_Interface.SIGHUP; -- hangup *************** package Ada.Interrupts.Names is *** 189,195 **** System.OS_Interface.SIGGRANT; -- monitor mode granted SIGRETRACT : constant Interrupt_ID := ! System.OS_Interface.SIGRETRACT; -- monitor mode should be relinguished SIGSOUND : constant Interrupt_ID := System.OS_Interface.SIGSOUND; -- sound control has completed --- 186,192 ---- System.OS_Interface.SIGGRANT; -- monitor mode granted SIGRETRACT : constant Interrupt_ID := ! System.OS_Interface.SIGRETRACT; -- monitor mode should be relinquished SIGSOUND : constant Interrupt_ID := System.OS_Interface.SIGSOUND; -- sound control has completed diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-darwin.ads gcc-4.4.0/gcc/ada/a-intnam-darwin.ads *** gcc-4.3.3/gcc/ada/a-intnam-darwin.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-intnam-darwin.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 45,51 **** -- supported by the local system. with System.OS_Interface; - -- used for names of interrupts package Ada.Interrupts.Names is --- 43,48 ---- *************** package Ada.Interrupts.Names is *** 53,152 **** -- may be aliases. Also, for all signal names that are not supported on the -- current system the value of the corresponding constant will be zero. ! SIGHUP : constant Interrupt_ID := System.OS_Interface.SIGHUP; -- hangup ! SIGINT : constant Interrupt_ID := System.OS_Interface.SIGINT; -- interrupt (rubout) ! SIGQUIT : constant Interrupt_ID := System.OS_Interface.SIGQUIT; -- quit (ASCD FS) ! SIGILL : constant Interrupt_ID := System.OS_Interface.SIGILL; -- illegal instruction (not reset) ! SIGTRAP : constant Interrupt_ID := System.OS_Interface.SIGTRAP; -- trace trap (not reset) ! SIGIOT : constant Interrupt_ID := System.OS_Interface.SIGIOT; -- IOT instruction ! SIGABRT : constant Interrupt_ID := -- used by abort, System.OS_Interface.SIGABRT; -- replace SIGIOT in the future ! SIGEMT : constant Interrupt_ID := System.OS_Interface.SIGEMT; -- EMT instruction ! SIGFPE : constant Interrupt_ID := System.OS_Interface.SIGFPE; -- floating point exception ! SIGKILL : constant Interrupt_ID := System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) ! SIGBUS : constant Interrupt_ID := System.OS_Interface.SIGBUS; -- bus error ! SIGSEGV : constant Interrupt_ID := System.OS_Interface.SIGSEGV; -- segmentation violation ! SIGSYS : constant Interrupt_ID := System.OS_Interface.SIGSYS; -- bad argument to system call ! SIGPIPE : constant Interrupt_ID := -- write on a pipe with System.OS_Interface.SIGPIPE; -- no one to read it ! SIGALRM : constant Interrupt_ID := System.OS_Interface.SIGALRM; -- alarm clock ! SIGTERM : constant Interrupt_ID := System.OS_Interface.SIGTERM; -- software termination signal from kill ! SIGURG : constant Interrupt_ID := System.OS_Interface.SIGURG; -- urgent condition on IO channel ! SIGSTOP : constant Interrupt_ID := System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) ! SIGTSTP : constant Interrupt_ID := System.OS_Interface.SIGTSTP; -- user stop requested from tty ! SIGCONT : constant Interrupt_ID := System.OS_Interface.SIGCONT; -- stopped process has been continued ! SIGCHLD : constant Interrupt_ID := System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD ! SIGTTIN : constant Interrupt_ID := System.OS_Interface.SIGTTIN; -- background tty read attempted ! SIGTTOU : constant Interrupt_ID := System.OS_Interface.SIGTTOU; -- background tty write attempted ! SIGIO : constant Interrupt_ID := -- input/output possible, System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) ! SIGXCPU : constant Interrupt_ID := System.OS_Interface.SIGXCPU; -- CPU time limit exceeded ! SIGXFSZ : constant Interrupt_ID := System.OS_Interface.SIGXFSZ; -- filesize limit exceeded SIGVTALRM : constant Interrupt_ID := System.OS_Interface.SIGVTALRM; -- virtual timer expired ! SIGPROF : constant Interrupt_ID := System.OS_Interface.SIGPROF; -- profiling timer expired ! SIGWINCH : constant Interrupt_ID := System.OS_Interface.SIGWINCH; -- window size change ! SIGINFO : constant Interrupt_ID := System.OS_Interface.SIGINFO; -- information request ! SIGUSR1 : constant Interrupt_ID := System.OS_Interface.SIGUSR1; -- user defined signal 1 ! SIGUSR2 : constant Interrupt_ID := System.OS_Interface.SIGUSR2; -- user defined signal 2 end Ada.Interrupts.Names; --- 50,149 ---- -- may be aliases. Also, for all signal names that are not supported on the -- current system the value of the corresponding constant will be zero. ! SIGHUP : constant Interrupt_ID := System.OS_Interface.SIGHUP; -- hangup ! SIGINT : constant Interrupt_ID := System.OS_Interface.SIGINT; -- interrupt (rubout) ! SIGQUIT : constant Interrupt_ID := System.OS_Interface.SIGQUIT; -- quit (ASCD FS) ! SIGILL : constant Interrupt_ID := System.OS_Interface.SIGILL; -- illegal instruction (not reset) ! SIGTRAP : constant Interrupt_ID := System.OS_Interface.SIGTRAP; -- trace trap (not reset) ! SIGIOT : constant Interrupt_ID := System.OS_Interface.SIGIOT; -- IOT instruction ! SIGABRT : constant Interrupt_ID := -- used by abort, System.OS_Interface.SIGABRT; -- replace SIGIOT in the future ! SIGEMT : constant Interrupt_ID := System.OS_Interface.SIGEMT; -- EMT instruction ! SIGFPE : constant Interrupt_ID := System.OS_Interface.SIGFPE; -- floating point exception ! SIGKILL : constant Interrupt_ID := System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) ! SIGBUS : constant Interrupt_ID := System.OS_Interface.SIGBUS; -- bus error ! SIGSEGV : constant Interrupt_ID := System.OS_Interface.SIGSEGV; -- segmentation violation ! SIGSYS : constant Interrupt_ID := System.OS_Interface.SIGSYS; -- bad argument to system call ! SIGPIPE : constant Interrupt_ID := -- write on a pipe with System.OS_Interface.SIGPIPE; -- no one to read it ! SIGALRM : constant Interrupt_ID := System.OS_Interface.SIGALRM; -- alarm clock ! SIGTERM : constant Interrupt_ID := System.OS_Interface.SIGTERM; -- software termination signal from kill ! SIGURG : constant Interrupt_ID := System.OS_Interface.SIGURG; -- urgent condition on IO channel ! SIGSTOP : constant Interrupt_ID := System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) ! SIGTSTP : constant Interrupt_ID := System.OS_Interface.SIGTSTP; -- user stop requested from tty ! SIGCONT : constant Interrupt_ID := System.OS_Interface.SIGCONT; -- stopped process has been continued ! SIGCHLD : constant Interrupt_ID := System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD ! SIGTTIN : constant Interrupt_ID := System.OS_Interface.SIGTTIN; -- background tty read attempted ! SIGTTOU : constant Interrupt_ID := System.OS_Interface.SIGTTOU; -- background tty write attempted ! SIGIO : constant Interrupt_ID := -- input/output possible, System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) ! SIGXCPU : constant Interrupt_ID := System.OS_Interface.SIGXCPU; -- CPU time limit exceeded ! SIGXFSZ : constant Interrupt_ID := System.OS_Interface.SIGXFSZ; -- filesize limit exceeded SIGVTALRM : constant Interrupt_ID := System.OS_Interface.SIGVTALRM; -- virtual timer expired ! SIGPROF : constant Interrupt_ID := System.OS_Interface.SIGPROF; -- profiling timer expired ! SIGWINCH : constant Interrupt_ID := System.OS_Interface.SIGWINCH; -- window size change ! SIGINFO : constant Interrupt_ID := System.OS_Interface.SIGINFO; -- information request ! SIGUSR1 : constant Interrupt_ID := System.OS_Interface.SIGUSR1; -- user defined signal 1 ! SIGUSR2 : constant Interrupt_ID := System.OS_Interface.SIGUSR2; -- user defined signal 2 end Ada.Interrupts.Names; diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-dummy.ads gcc-4.4.0/gcc/ada/a-intnam-dummy.ads *** gcc-4.3.3/gcc/ada/a-intnam-dummy.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-intnam-dummy.ads Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- S p e c -- -- (No Tasking Version) -- -- -- ! -- Copyright (C) 1991-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 7,29 ---- -- S p e c -- -- (No Tasking Version) -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-freebsd.ads gcc-4.4.0/gcc/ada/a-intnam-freebsd.ads *** gcc-4.3.3/gcc/ada/a-intnam-freebsd.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-intnam-freebsd.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 34,43 **** -- This is the FreeBSD THREADS version of this package with System.OS_Interface; - -- used for names of interrupts package Ada.Interrupts.Names is SIGHUP : constant Interrupt_ID := System.OS_Interface.SIGHUP; -- hangup --- 32,44 ---- -- This is the FreeBSD THREADS version of this package with System.OS_Interface; package Ada.Interrupts.Names is + -- Beware that the mapping of names to signals may be many-to-one. There + -- may be aliases. Also, for all signal names that are not supported on + -- the current system the value of the corresponding constant will be zero. + SIGHUP : constant Interrupt_ID := System.OS_Interface.SIGHUP; -- hangup *************** package Ada.Interrupts.Names is *** 128,136 **** SIGUSR2 : constant Interrupt_ID := System.OS_Interface.SIGUSR2; -- user defined signal 2 - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. Also, for all - -- signal names that are not supported on the current system - -- the value of the corresponding constant will be zero. - end Ada.Interrupts.Names; --- 129,132 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-hpux.ads gcc-4.4.0/gcc/ada/a-intnam-hpux.ads *** gcc-4.3.3/gcc/ada/a-intnam-hpux.ads Mon Sep 5 08:07:00 2005 --- gcc-4.4.0/gcc/ada/a-intnam-hpux.ads Thu Apr 9 23:23:07 2009 *************** *** 6,31 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2005, AdaCore -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 47,60 **** -- supported by the local system. with System.OS_Interface; - -- used for names of interrupts package Ada.Interrupts.Names is ! -- Beware that the mapping of names to signals may be ! -- many-to-one. There may be aliases. Also, for all ! -- signal names that are not supported on the current system ! -- the value of the corresponding constant will be zero. SIGHUP : constant Interrupt_ID := System.OS_Interface.SIGHUP; -- hangup --- 44,55 ---- -- supported by the local system. with System.OS_Interface; package Ada.Interrupts.Names is ! -- Beware that the mapping of names to signals may be many-to-one. There ! -- may be aliases. Also, for all signal names that are not supported on ! -- the current system the value of the corresponding constant will be zero. SIGHUP : constant Interrupt_ID := System.OS_Interface.SIGHUP; -- hangup diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-irix.ads gcc-4.4.0/gcc/ada/a-intnam-irix.ads *** gcc-4.3.3/gcc/ada/a-intnam-irix.ads Mon Sep 5 08:07:00 2005 --- gcc-4.4.0/gcc/ada/a-intnam-irix.ads Thu Apr 9 23:23:07 2009 *************** *** 6,31 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2005, AdaCore -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- ! -- terms of the GNU Library General Public License as published by the -- ! -- Free Software Foundation; either version 2, or (at your option) any -- ! -- later version. GNARL is distributed in the hope that it will be use- -- ! -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of -- ! -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Gen- -- ! -- eral Library Public License for more details. You should have received -- ! -- a copy of the GNU Library General Public License along with GNARL; see -- ! -- file COPYING.LIB. If not, write to the Free Software Foundation, 51 -- ! -- Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- ! -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 53,66 **** -- supported by the local system. with System.OS_Interface; - -- used for names of interrupts package Ada.Interrupts.Names is ! -- Beware that the mapping of names to signals may be ! -- many-to-one. There may be aliases. Also, for all ! -- signal names that are not supported on the current system ! -- the value of the corresponding constant will be zero. SIGHUP : constant Interrupt_ID := System.OS_Interface.SIGHUP; -- hangup --- 50,61 ---- -- supported by the local system. with System.OS_Interface; package Ada.Interrupts.Names is ! -- Beware that the mapping of names to signals may be many-to-one. There ! -- may be aliases. Also, for all signal names that are not supported on ! -- the current system the value of the corresponding constant will be zero. SIGHUP : constant Interrupt_ID := System.OS_Interface.SIGHUP; -- hangup diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-linux.ads gcc-4.4.0/gcc/ada/a-intnam-linux.ads *** gcc-4.3.3/gcc/ada/a-intnam-linux.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-intnam-linux.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 51,57 **** -- supported by the local system. with System.OS_Interface; - -- used for names of interrupts package Ada.Interrupts.Names is --- 49,54 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-lynxos.ads gcc-4.4.0/gcc/ada/a-intnam-lynxos.ads *** gcc-4.3.3/gcc/ada/a-intnam-lynxos.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-intnam-lynxos.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 43,49 **** -- SIGINT: made available for Ada handler with System.OS_Interface; - -- used for names of interrupts package Ada.Interrupts.Names is --- 41,46 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-mingw.ads gcc-4.4.0/gcc/ada/a-intnam-mingw.ads *** gcc-4.3.3/gcc/ada/a-intnam-mingw.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-intnam-mingw.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 37,43 **** -- by the local system. with System.OS_Interface; - -- used for names of interrupts package Ada.Interrupts.Names is --- 35,40 ---- *************** package Ada.Interrupts.Names is *** 45,66 **** -- may be aliases. Also, for all signal names that are not supported on the -- current system the value of the corresponding constant will be zero. ! SIGINT : constant Interrupt_ID := ! System.OS_Interface.SIGINT; -- interrupt (rubout) ! SIGILL : constant Interrupt_ID := ! System.OS_Interface.SIGILL; -- illegal instruction (not reset) ! SIGABRT : constant Interrupt_ID := -- used by abort, ! System.OS_Interface.SIGABRT; -- replace SIGIOT in the future ! SIGFPE : constant Interrupt_ID := ! System.OS_Interface.SIGFPE; -- floating point exception ! SIGSEGV : constant Interrupt_ID := ! System.OS_Interface.SIGSEGV; -- segmentation violation ! SIGTERM : constant Interrupt_ID := ! System.OS_Interface.SIGTERM; -- software termination signal from kill end Ada.Interrupts.Names; --- 42,63 ---- -- may be aliases. Also, for all signal names that are not supported on the -- current system the value of the corresponding constant will be zero. ! SIGINT : constant Interrupt_ID := -- interrupt (rubout) ! System.OS_Interface.SIGINT; ! SIGILL : constant Interrupt_ID := -- illegal instruction (not reset) ! System.OS_Interface.SIGILL; ! SIGABRT : constant Interrupt_ID := -- used by abort (use SIGIOT in future) ! System.OS_Interface.SIGABRT; ! SIGFPE : constant Interrupt_ID := -- floating point exception ! System.OS_Interface.SIGFPE; ! SIGSEGV : constant Interrupt_ID := -- segmentation violation ! System.OS_Interface.SIGSEGV; ! SIGTERM : constant Interrupt_ID := -- software termination signal from kill ! System.OS_Interface.SIGTERM; end Ada.Interrupts.Names; diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-rtems.ads gcc-4.4.0/gcc/ada/a-intnam-rtems.ads *** gcc-4.3.3/gcc/ada/a-intnam-rtems.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/a-intnam-rtems.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2002 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-solaris.ads gcc-4.4.0/gcc/ada/a-intnam-solaris.ads *** gcc-4.3.3/gcc/ada/a-intnam-solaris.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-intnam-solaris.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 41,54 **** -- The following signals are reserved by the run time (FSU threads): -- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT, ! -- SIGLWP, SIGALRM, SIGVTALRM, SIGAITING, SIGSTOP, SIGKILL -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- SIGINT: made available for Ada handlers with System.OS_Interface; - -- used for names of interrupts package Ada.Interrupts.Names is --- 39,51 ---- -- The following signals are reserved by the run time (FSU threads): -- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT, ! -- SIGLWP, SIGALRM, SIGVTALRM, SIGWAITING, SIGSTOP, SIGKILL -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- SIGINT: made available for Ada handlers with System.OS_Interface; package Ada.Interrupts.Names is diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-tru64.ads gcc-4.4.0/gcc/ada/a-intnam-tru64.ads *** gcc-4.3.3/gcc/ada/a-intnam-tru64.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-intnam-tru64.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 43,49 **** -- SIGINT: made available for Ada handler with System.OS_Interface; - -- used for names of interrupts package Ada.Interrupts.Names is --- 41,46 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-vms.ads gcc-4.4.0/gcc/ada/a-intnam-vms.ads *** gcc-4.3.3/gcc/ada/a-intnam-vms.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-intnam-vms.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 37,42 **** --- 35,41 ---- -- supported by the local system. with System.OS_Interface; + package Ada.Interrupts.Names is package OS renames System.OS_Interface; diff -Nrcpad gcc-4.3.3/gcc/ada/a-intnam-vxworks.ads gcc-4.4.0/gcc/ada/a-intnam-vxworks.ads *** gcc-4.3.3/gcc/ada/a-intnam-vxworks.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-intnam-vxworks.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-intsig.adb gcc-4.4.0/gcc/ada/a-intsig.adb *** gcc-4.3.3/gcc/ada/a-intsig.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-intsig.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-intsig.ads gcc-4.4.0/gcc/ada/a-intsig.ads *** gcc-4.3.3/gcc/ada/a-intsig.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-intsig.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-llfzti.ads gcc-4.4.0/gcc/ada/a-llfzti.ads *** gcc-4.3.3/gcc/ada/a-llfzti.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-llfzti.ads Mon Mar 24 10:57:32 2008 *************** *** 2,8 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! --A D A . L O N G _ L O N G _ F L O A T _ W I D E _ W I D E _ T E X T _ I O -- -- -- -- S p e c -- -- -- --- 2,8 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- ADA.LONG_LONG_FLOAT_WIDE_WIDE_TEXT_IO -- -- -- -- S p e c -- -- -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ngcefu.adb gcc-4.4.0/gcc/ada/a-ngcefu.adb *** gcc-4.3.3/gcc/ada/a-ngcefu.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-ngcefu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Numerics.Generic_Comple *** 247,253 **** end Arccot; -------------- ! -- Arctcoth -- -------------- function Arccoth (X : Complex) return Complex is --- 245,251 ---- end Arccot; -------------- ! -- Arccoth -- -------------- function Arccoth (X : Complex) return Complex is diff -Nrcpad gcc-4.3.3/gcc/ada/a-ngcoar.adb gcc-4.4.0/gcc/ada/a-ngcoar.adb *** gcc-4.3.3/gcc/ada/a-ngcoar.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/a-ngcoar.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Numerics.Generic_Comple *** 1194,1200 **** Info => Info'Access); if Info /= 0 then ! raise Constraint_Error with "inverting non-Hermetian matrix"; end if; for J in Values'Range loop --- 1192,1198 ---- Info => Info'Access); if Info /= 0 then ! raise Constraint_Error with "inverting non-Hermitian matrix"; end if; for J in Values'Range loop diff -Nrcpad gcc-4.3.3/gcc/ada/a-ngcoty.adb gcc-4.4.0/gcc/ada/a-ngcoty.adb *** gcc-4.3.3/gcc/ada/a-ngcoty.adb Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/a-ngcoty.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ngcoty.ads gcc-4.4.0/gcc/ada/a-ngcoty.ads *** gcc-4.3.3/gcc/ada/a-ngcoty.ads Tue Oct 31 17:49:05 2006 --- gcc-4.4.0/gcc/ada/a-ngcoty.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ngelfu.adb gcc-4.4.0/gcc/ada/a-ngelfu.adb *** gcc-4.3.3/gcc/ada/a-ngelfu.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-ngelfu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Numerics.Generic_Elemen *** 73,79 **** (Y : Float_Type'Base; X : Float_Type'Base := 1.0) return Float_Type'Base; ! -- Common code for arc tangent after cyele reduction ---------- -- "**" -- --- 71,77 ---- (Y : Float_Type'Base; X : Float_Type'Base := 1.0) return Float_Type'Base; ! -- Common code for arc tangent after cycle reduction ---------- -- "**" -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ngrear.adb gcc-4.4.0/gcc/ada/a-ngrear.adb *** gcc-4.3.3/gcc/ada/a-ngrear.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-ngrear.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Numerics.Generic_Real_A *** 368,374 **** begin if Left'Length (2) /= Right'Length (1) then raise Constraint_Error with ! "incompatible dimensions in matrix-matrix multipication"; end if; gemm (Trans_A => No_Trans'Access, --- 366,372 ---- begin if Left'Length (2) /= Right'Length (1) then raise Constraint_Error with ! "incompatible dimensions in matrix-matrix multiplication"; end if; gemm (Trans_A => No_Trans'Access, diff -Nrcpad gcc-4.3.3/gcc/ada/a-ngrear.ads gcc-4.4.0/gcc/ada/a-ngrear.ads *** gcc-4.3.3/gcc/ada/a-ngrear.ads Fri Apr 6 09:23:23 2007 --- gcc-4.4.0/gcc/ada/a-ngrear.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-nllrar.ads gcc-4.4.0/gcc/ada/a-nllrar.ads *** gcc-4.3.3/gcc/ada/a-nllrar.ads Fri Apr 6 09:23:23 2007 --- gcc-4.4.0/gcc/ada/a-nllrar.ads Mon Mar 24 10:57:32 2008 *************** *** 2,8 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- ADA.NUMERICS.LONG_LONG_REAL_ARRAYS -- -- -- -- S p e c -- -- -- --- 2,8 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- A D A . N U M E R I C S . L O N G _ L O N G _R E A L _ A R R A Y S -- -- -- -- S p e c -- -- -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-nlrear.ads gcc-4.4.0/gcc/ada/a-nlrear.ads *** gcc-4.3.3/gcc/ada/a-nlrear.ads Fri Apr 6 09:23:23 2007 --- gcc-4.4.0/gcc/ada/a-nlrear.ads Mon Mar 24 10:57:32 2008 *************** *** 2,8 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- ADA.NUMERICS.LONG_REAL_ARRAYS -- -- -- -- S p e c -- -- -- --- 2,8 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- A D A . N U M E R I C S . L O N G _ R E A L _ A R R A Y S -- -- -- -- S p e c -- -- -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-nucoar.ads gcc-4.4.0/gcc/ada/a-nucoar.ads *** gcc-4.3.3/gcc/ada/a-nucoar.ads Fri Apr 6 09:23:23 2007 --- gcc-4.4.0/gcc/ada/a-nucoar.ads Mon Mar 24 10:57:32 2008 *************** *** 2,8 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- ADA.NUMERICS.COMPLEX_ARRAYS -- -- -- -- S p e c -- -- -- --- 2,8 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- A D A . N U M E R I C S . C O M P L E X _ A R R A Y S -- -- -- -- S p e c -- -- -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-nudira.adb gcc-4.4.0/gcc/ada/a-nudira.adb *** gcc-4.3.3/gcc/ada/a-nudira.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-nudira.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-nudira.ads gcc-4.4.0/gcc/ada/a-nudira.ads *** gcc-4.3.3/gcc/ada/a-nudira.ads Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/a-nudira.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-nuflra.adb gcc-4.4.0/gcc/ada/a-nuflra.adb *** gcc-4.3.3/gcc/ada/a-nuflra.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-nuflra.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-nuflra.ads gcc-4.4.0/gcc/ada/a-nuflra.ads *** gcc-4.3.3/gcc/ada/a-nuflra.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-nuflra.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-numaux-darwin.adb gcc-4.4.0/gcc/ada/a-numaux-darwin.adb *** gcc-4.3.3/gcc/ada/a-numaux-darwin.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-numaux-darwin.adb Thu Apr 9 23:23:07 2009 *************** *** 7,38 **** -- B o d y -- -- (Apple OS X Version) -- -- -- ! -- Copyright (C) 1998-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- File a-numaux.adb <- a-numaux-d arwin.adb package body Ada.Numerics.Aux is --- 7,36 ---- -- B o d y -- -- (Apple OS X Version) -- -- -- ! -- Copyright (C) 1998-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- File a-numaux.adb <- a-numaux-darwin.adb package body Ada.Numerics.Aux is *************** package body Ada.Numerics.Aux is *** 45,51 **** -- result in the range 0 .. 3. The absolute value of X is at most Pi/4. -- The following three functions implement Chebishev approximations ! -- of the trigoniometric functions in their reduced domain. -- These approximations have been computed using Maple. function Sine_Approx (X : Double) return Double; --- 43,49 ---- -- result in the range 0 .. 3. The absolute value of X is at most Pi/4. -- The following three functions implement Chebishev approximations ! -- of the trigonometric functions in their reduced domain. -- These approximations have been computed using Maple. function Sine_Approx (X : Double) return Double; diff -Nrcpad gcc-4.3.3/gcc/ada/a-numaux-darwin.ads gcc-4.4.0/gcc/ada/a-numaux-darwin.ads *** gcc-4.3.3/gcc/ada/a-numaux-darwin.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-numaux-darwin.ads Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- S p e c -- -- (Apple OS X Version) -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- S p e c -- -- (Apple OS X Version) -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-numaux-libc-x86.ads gcc-4.4.0/gcc/ada/a-numaux-libc-x86.ads *** gcc-4.3.3/gcc/ada/a-numaux-libc-x86.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-numaux-libc-x86.ads Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- S p e c -- -- (C Library Version for x86) -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- S p e c -- -- (C Library Version for x86) -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-numaux-vxworks.ads gcc-4.4.0/gcc/ada/a-numaux-vxworks.ads *** gcc-4.3.3/gcc/ada/a-numaux-vxworks.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-numaux-vxworks.ads Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- S p e c -- -- (C Library Version, VxWorks) -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- S p e c -- -- (C Library Version, VxWorks) -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-numaux-x86.adb gcc-4.4.0/gcc/ada/a-numaux-x86.adb *** gcc-4.3.3/gcc/ada/a-numaux-x86.adb Mon Sep 10 10:14:16 2007 --- gcc-4.4.0/gcc/ada/a-numaux-x86.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (Machine Version for x86) -- -- -- ! -- Copyright (C) 1998-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- B o d y -- -- (Machine Version for x86) -- -- -- ! -- Copyright (C) 1998-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-numaux-x86.ads gcc-4.4.0/gcc/ada/a-numaux-x86.ads *** gcc-4.3.3/gcc/ada/a-numaux-x86.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-numaux-x86.ads Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- S p e c -- -- (Machine Version for x86) -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- S p e c -- -- (Machine Version for x86) -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-numaux.ads gcc-4.4.0/gcc/ada/a-numaux.ads *** gcc-4.3.3/gcc/ada/a-numaux.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-numaux.ads Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- S p e c -- -- (C Library Version, non-x86) -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- S p e c -- -- (C Library Version, non-x86) -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-numeri.ads gcc-4.4.0/gcc/ada/a-numeri.ads *** gcc-4.3.3/gcc/ada/a-numeri.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-numeri.ads Mon Mar 24 17:48:07 2008 *************** package Ada.Numerics is *** 22,28 **** 3.14159_26535_89793_23846_26433_83279_50288_41971_69399_37511; ["03C0"] : constant := Pi; ! -- This is the greek letter Pi (for Ada 2005 AI-388). Note that it is -- conforming to have this constant present even in Ada 95 mode, as there -- is no way for a normal mode Ada 95 program to reference this identifier. --- 22,28 ---- 3.14159_26535_89793_23846_26433_83279_50288_41971_69399_37511; ["03C0"] : constant := Pi; ! -- This is the Greek letter Pi (for Ada 2005 AI-388). Note that it is -- conforming to have this constant present even in Ada 95 mode, as there -- is no way for a normal mode Ada 95 program to reference this identifier. diff -Nrcpad gcc-4.3.3/gcc/ada/a-nurear.ads gcc-4.4.0/gcc/ada/a-nurear.ads *** gcc-4.3.3/gcc/ada/a-nurear.ads Fri Apr 6 09:23:23 2007 --- gcc-4.4.0/gcc/ada/a-nurear.ads Mon Mar 24 10:57:32 2008 *************** *** 2,8 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- ADA.NUMERICS.REAL_ARRAYS -- -- -- -- S p e c -- -- -- --- 2,8 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- A D A . N U M E R I C S . R E A L _ A R R A Y S -- -- -- -- S p e c -- -- -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-rbtgso.adb gcc-4.4.0/gcc/ada/a-rbtgso.adb *** gcc-4.3.3/gcc/ada/a-rbtgso.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-rbtgso.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . -- ! -- G E N E R I C _ S E T _ O P E R A T I O N S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-rbtgso.ads gcc-4.4.0/gcc/ada/a-rbtgso.ads *** gcc-4.3.3/gcc/ada/a-rbtgso.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-rbtgso.ads Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . -- ! -- G E N E R I C _ S E T _ O P E R A T I O N S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-reatim.ads gcc-4.4.0/gcc/ada/a-reatim.ads *** gcc-4.3.3/gcc/ada/a-reatim.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-reatim.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-retide.adb gcc-4.4.0/gcc/ada/a-retide.adb *** gcc-4.3.3/gcc/ada/a-retide.adb Fri Apr 6 09:17:12 2007 --- gcc-4.4.0/gcc/ada/a-retide.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 32,46 **** ------------------------------------------------------------------------------ with Ada.Exceptions; - -- Used for Raise_Exception with System.Tasking; - -- Used for Task_Id - -- Initialize - with System.Task_Primitives.Operations; - -- Used for Timed_Delay - -- Self package body Ada.Real_Time.Delays is --- 30,38 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/a-retide.ads gcc-4.4.0/gcc/ada/a-retide.ads *** gcc-4.3.3/gcc/ada/a-retide.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/a-retide.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-rttiev.adb gcc-4.4.0/gcc/ada/a-rttiev.adb *** gcc-4.3.3/gcc/ada/a-rttiev.adb Tue Oct 31 18:14:09 2006 --- gcc-4.4.0/gcc/ada/a-rttiev.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 34,40 **** with System.Task_Primitives.Operations; with System.Tasking.Utilities; with System.Soft_Links; - -- used for Abort_Defer/Undefer with Ada.Containers.Doubly_Linked_Lists; pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists); --- 32,37 ---- *************** pragma Elaborate_All (Ada.Containers.Dou *** 46,52 **** package body Ada.Real_Time.Timing_Events is use System.Task_Primitives.Operations; - -- for Write_Lock and Unlock package SSL renames System.Soft_Links; --- 43,48 ---- *************** package body Ada.Real_Time.Timing_Events *** 68,75 **** -- Used for mutually exclusive access to All_Events procedure Process_Queued_Events; ! -- Examine the queue of pending events for any that have timed-out. For ! -- those that have timed-out, remove them from the queue and invoke their -- handler (unless the user has cancelled the event by setting the handler -- pointer to null). Mutually exclusive access is held via Event_Queue_Lock -- during part of the processing. --- 64,71 ---- -- Used for mutually exclusive access to All_Events procedure Process_Queued_Events; ! -- Examine the queue of pending events for any that have timed out. For ! -- those that have timed out, remove them from the queue and invoke their -- handler (unless the user has cancelled the event by setting the handler -- pointer to null). Mutually exclusive access is held via Event_Queue_Lock -- during part of the processing. *************** package body Ada.Real_Time.Timing_Events *** 144,150 **** if Next_Event.Timeout > Clock then ! -- We found one that has not yet timed-out. The queue is in -- ascending order by Timeout so there is no need to continue -- processing (and indeed we must not continue since we always -- delete the first element). --- 140,146 ---- if Next_Event.Timeout > Clock then ! -- We found one that has not yet timed out. The queue is in -- ascending order by Timeout so there is no need to continue -- processing (and indeed we must not continue since we always -- delete the first element). *************** package body Ada.Real_Time.Timing_Events *** 154,161 **** return; end if; ! -- We have an event that has timed out so we will process it. It ! -- must be the first in the queue so no search is needed. All_Events.Delete_First; --- 150,157 ---- return; end if; ! -- We have an event that has timed out so we will process it. It must ! -- be the first in the queue so no search is needed. All_Events.Delete_First; *************** package body Ada.Real_Time.Timing_Events *** 176,182 **** declare Handler : constant Timing_Event_Handler := Next_Event.Handler; begin ! -- The first act is to clear the event, per D.15 (13/2). Besides, -- we cannot clear the handler pointer *after* invoking the -- handler because the handler may have re-inserted the event via -- Set_Event. Thus we take a copy and then clear the component. --- 172,178 ---- declare Handler : constant Timing_Event_Handler := Next_Event.Handler; begin ! -- The first act is to clear the event, per D.15(13/2). Besides, -- we cannot clear the handler pointer *after* invoking the -- handler because the handler may have re-inserted the event via -- Set_Event. Thus we take a copy and then clear the component. *************** package body Ada.Real_Time.Timing_Events *** 184,191 **** Next_Event.Handler := null; if Handler /= null then ! Handler (Timing_Event (Next_Event.all)); end if; exception when others => null; --- 180,191 ---- Next_Event.Handler := null; if Handler /= null then ! Handler.all (Timing_Event (Next_Event.all)); end if; + + -- Ignore exceptions propagated by Handler.all, as required by + -- RM D.15(21/2). + exception when others => null; *************** package body Ada.Real_Time.Timing_Events *** 263,274 **** begin Remove_From_Queue (Event'Unchecked_Access); Event.Handler := null; ! if At_Time <= Clock then ! if Handler /= null then ! Handler (Event); ! end if; ! return; ! end if; if Handler /= null then Event.Timeout := At_Time; Event.Handler := Handler; --- 263,277 ---- begin Remove_From_Queue (Event'Unchecked_Access); Event.Handler := null; ! ! -- RM D.15(15/2) requires that at this point, we check whether the time ! -- has already passed, and if so, call Handler.all directly from here ! -- instead of doing the enqueuing below. However, this causes a nasty ! -- race condition and potential deadlock. If the current task has ! -- already locked the protected object of Handler.all, and the time has ! -- passed, deadlock would occur. Therefore, we ignore the requirement. ! -- The same comment applies to the other Set_Handler below. ! if Handler /= null then Event.Timeout := At_Time; Event.Handler := Handler; *************** package body Ada.Real_Time.Timing_Events *** 288,299 **** begin Remove_From_Queue (Event'Unchecked_Access); Event.Handler := null; ! if In_Time <= Time_Span_Zero then ! if Handler /= null then ! Handler (Event); ! end if; ! return; ! end if; if Handler /= null then Event.Timeout := Clock + In_Time; Event.Handler := Handler; --- 291,299 ---- begin Remove_From_Queue (Event'Unchecked_Access); Event.Handler := null; ! ! -- See comment in the other Set_Handler above ! if Handler /= null then Event.Timeout := Clock + In_Time; Event.Handler := Handler; diff -Nrcpad gcc-4.3.3/gcc/ada/a-rttiev.ads gcc-4.4.0/gcc/ada/a-rttiev.ads *** gcc-4.3.3/gcc/ada/a-rttiev.ads Tue Oct 31 18:14:09 2006 --- gcc-4.4.0/gcc/ada/a-rttiev.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-secain.adb gcc-4.4.0/gcc/ada/a-secain.adb *** gcc-4.3.3/gcc/ada/a-secain.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-secain.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-secain.ads gcc-4.4.0/gcc/ada/a-secain.ads *** gcc-4.3.3/gcc/ada/a-secain.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-secain.ads Thu Apr 9 23:23:07 2009 *************** *** 6,19 **** -- -- -- S p e c -- -- -- ! -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. In accordance with the copyright of that document, you can freely -- ! -- copy and modify this specification, provided that if you redistribute a -- ! -- modified version, any changes that you have made are clearly indicated. -- -- -- ------------------------------------------------------------------------------ function Ada.Strings.Equal_Case_Insensitive (Left, Right : String) return Boolean; - pragma Pure (Ada.Strings.Equal_Case_Insensitive); --- 6,38 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ function Ada.Strings.Equal_Case_Insensitive (Left, Right : String) return Boolean; pragma Pure (Ada.Strings.Equal_Case_Insensitive); + -- Performs a case-insensitive equality test of Left and Right. This is + -- useful as the generic actual equivalence operation (Equivalent_Keys) + -- when instantiating a hashed container package with type String as the + -- key. It is also useful as the generic actual equality operator when + -- instantiating a container package with type String as the element, + -- allowing case-insensitive container equality tests. diff -Nrcpad gcc-4.3.3/gcc/ada/a-sequio.adb gcc-4.4.0/gcc/ada/a-sequio.adb *** gcc-4.3.3/gcc/ada/a-sequio.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-sequio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Sequential_IO is *** 67,73 **** procedure Close (File : in out File_Type) is begin ! FIO.Close (AP (File)); end Close; ------------ --- 65,71 ---- procedure Close (File : in out File_Type) is begin ! FIO.Close (AP (File)'Unrestricted_Access); end Close; ------------ *************** package body Ada.Sequential_IO is *** 90,96 **** procedure Delete (File : in out File_Type) is begin ! FIO.Delete (AP (File)); end Delete; ----------------- --- 88,94 ---- procedure Delete (File : in out File_Type) is begin ! FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- *************** package body Ada.Sequential_IO is *** 240,251 **** procedure Reset (File : in out File_Type; Mode : File_Mode) is begin ! FIO.Reset (AP (File), To_FCB (Mode)); end Reset; procedure Reset (File : in out File_Type) is begin ! FIO.Reset (AP (File)); end Reset; ----------- --- 238,249 ---- procedure Reset (File : in out File_Type; Mode : File_Mode) is begin ! FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); end Reset; procedure Reset (File : in out File_Type) is begin ! FIO.Reset (AP (File)'Unrestricted_Access); end Reset; ----------- diff -Nrcpad gcc-4.3.3/gcc/ada/a-sequio.ads gcc-4.4.0/gcc/ada/a-sequio.ads *** gcc-4.3.3/gcc/ada/a-sequio.ads Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/a-sequio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Ada.Sequential_IO is *** 48,53 **** --- 46,55 ---- (Element_Type'Has_Access_Values, "Element_Type for Sequential_IO instance has access values"); + pragma Compile_Time_Warning + (Element_Type'Has_Tagged_Values, + "Element_Type for Sequential_IO instance has tagged values"); + type File_Type is limited private; type File_Mode is (In_File, Out_File, Append_File); *************** package Ada.Sequential_IO is *** 57,63 **** -- used in this package and System.File_IO. for File_Mode use ! (In_File => 0, -- System.FIle_IO.File_Mode'Pos (In_File) Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) --- 59,65 ---- -- used in this package and System.File_IO. for File_Mode use ! (In_File => 0, -- System.File_IO.File_Mode'Pos (In_File) Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) *************** package Ada.Sequential_IO is *** 110,115 **** --- 112,143 ---- Data_Error : exception renames IO_Exceptions.Data_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + type File_Type is new System.Sequential_IO.File_Type; -- All subprograms are inlined diff -Nrcpad gcc-4.3.3/gcc/ada/a-shcain.adb gcc-4.4.0/gcc/ada/a-shcain.adb *** gcc-4.3.3/gcc/ada/a-shcain.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-shcain.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-shcain.ads gcc-4.4.0/gcc/ada/a-shcain.ads *** gcc-4.3.3/gcc/ada/a-shcain.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-shcain.ads Thu Apr 9 23:23:07 2009 *************** *** 6,21 **** -- -- -- S p e c -- -- -- ! -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. In accordance with the copyright of that document, you can freely -- ! -- copy and modify this specification, provided that if you redistribute a -- ! -- modified version, any changes that you have made are clearly indicated. -- -- -- ------------------------------------------------------------------------------ with Ada.Containers; function Ada.Strings.Hash_Case_Insensitive (Key : String) return Containers.Hash_Type; - pragma Pure (Ada.Strings.Hash_Case_Insensitive); --- 6,37 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- ! -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- ! -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with Ada.Containers; function Ada.Strings.Hash_Case_Insensitive (Key : String) return Containers.Hash_Type; pragma Pure (Ada.Strings.Hash_Case_Insensitive); + -- Computes a hash value for Key without regard for character case. This is + -- useful as the generic actual Hash function when instantiating a hashed + -- container package with type String as the key. diff -Nrcpad gcc-4.3.3/gcc/ada/a-siocst.adb gcc-4.4.0/gcc/ada/a-siocst.adb *** gcc-4.3.3/gcc/ada/a-siocst.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-siocst.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-siocst.ads gcc-4.4.0/gcc/ada/a-siocst.ads *** gcc-4.3.3/gcc/ada/a-siocst.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-siocst.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-slcain.adb gcc-4.4.0/gcc/ada/a-slcain.adb *** gcc-4.3.3/gcc/ada/a-slcain.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-slcain.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-slcain.ads gcc-4.4.0/gcc/ada/a-slcain.ads *** gcc-4.3.3/gcc/ada/a-slcain.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-slcain.ads Thu Apr 9 23:23:07 2009 *************** *** 6,19 **** -- -- -- S p e c -- -- -- ! -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. In accordance with the copyright of that document, you can freely -- ! -- copy and modify this specification, provided that if you redistribute a -- ! -- modified version, any changes that you have made are clearly indicated. -- -- -- ------------------------------------------------------------------------------ function Ada.Strings.Less_Case_Insensitive (Left, Right : String) return Boolean; - pragma Pure (Ada.Strings.Less_Case_Insensitive); --- 6,36 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- ! -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ function Ada.Strings.Less_Case_Insensitive (Left, Right : String) return Boolean; pragma Pure (Ada.Strings.Less_Case_Insensitive); + -- Performs a case-insensitive lexicographic comparison of Left and + -- Right. This is useful as the generic actual less-than operator when + -- instantiating an ordered container package with type String as the key, + -- allowing case-insensitive equivalence tests. diff -Nrcpad gcc-4.3.3/gcc/ada/a-ssicst.adb gcc-4.4.0/gcc/ada/a-ssicst.adb *** gcc-4.3.3/gcc/ada/a-ssicst.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-ssicst.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ssicst.ads gcc-4.4.0/gcc/ada/a-ssicst.ads *** gcc-4.3.3/gcc/ada/a-ssicst.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ssicst.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stboha.adb gcc-4.4.0/gcc/ada/a-stboha.adb *** gcc-4.3.3/gcc/ada/a-stboha.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-stboha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-stmaco.ads gcc-4.4.0/gcc/ada/a-stmaco.ads *** gcc-4.3.3/gcc/ada/a-stmaco.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-stmaco.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-storio.adb gcc-4.4.0/gcc/ada/a-storio.adb *** gcc-4.3.3/gcc/ada/a-storio.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-storio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-strbou.adb gcc-4.4.0/gcc/ada/a-strbou.adb *** gcc-4.3.3/gcc/ada/a-strbou.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-strbou.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Strings.Bounded is *** 60,65 **** --- 58,72 ---- return Times (Left, Right, Max_Length); end "*"; + ----------------- + -- From_String -- + ----------------- + + function From_String (Source : String) return Bounded_String is + begin + return To_Super_String (Source, Max_Length, Error); + end From_String; + --------------- -- Replicate -- --------------- diff -Nrcpad gcc-4.3.3/gcc/ada/a-strbou.ads gcc-4.4.0/gcc/ada/a-strbou.ads *** gcc-4.3.3/gcc/ada/a-strbou.ads Tue Oct 31 17:49:05 2006 --- gcc-4.4.0/gcc/ada/a-strbou.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Ada.Strings.Bounded is *** 456,462 **** -- is at least one Bounded_String argument from which the maximum -- length can be obtained. For all such routines, the implementation -- in this private part is simply a renaming of the corresponding ! -- routine in the super bouded package. -- The five exceptions are the * and Replicate routines operating on -- character values. For these cases, we have a routine in the body --- 454,460 ---- -- is at least one Bounded_String argument from which the maximum -- length can be obtained. For all such routines, the implementation -- in this private part is simply a renaming of the corresponding ! -- routine in the superbounded package. -- The five exceptions are the * and Replicate routines operating on -- character values. For these cases, we have a routine in the body *************** package Ada.Strings.Bounded is *** 469,474 **** --- 467,478 ---- -- the generic instantiation is compatible with the Super_String -- type declared in the Superbounded package. + function From_String (Source : String) return Bounded_String; + -- Private routine used only by Stream_Convert + + pragma Stream_Convert (Bounded_String, From_String, To_String); + -- Provide stream routines without dragging in Ada.Streams + Null_Bounded_String : constant Bounded_String := (Max_Length => Max_Length, Current_Length => 0, diff -Nrcpad gcc-4.3.3/gcc/ada/a-stream.ads gcc-4.4.0/gcc/ada/a-stream.ads *** gcc-4.3.3/gcc/ada/a-stream.ads Tue Oct 31 17:49:05 2006 --- gcc-4.4.0/gcc/ada/a-stream.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-strfix.adb gcc-4.4.0/gcc/ada/a-strfix.adb *** gcc-4.3.3/gcc/ada/a-strfix.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-strfix.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 36,42 **** -- of Is_In, so that we are not dependent on inlining. Note that the search -- function implementations are to be found in the auxiliary package -- Ada.Strings.Search. Also the Move procedure is directly incorporated (ADAR ! -- used a subunit for this procedure). number of errors having to do with -- bounds of function return results were also fixed, and use of & removed for -- efficiency reasons. --- 34,40 ---- -- of Is_In, so that we are not dependent on inlining. Note that the search -- function implementations are to be found in the auxiliary package -- Ada.Strings.Search. Also the Move procedure is directly incorporated (ADAR ! -- used a subunit for this procedure). The number of errors having to do with -- bounds of function return results were also fixed, and use of & removed for -- efficiency reasons. diff -Nrcpad gcc-4.3.3/gcc/ada/a-strhas.adb gcc-4.4.0/gcc/ada/a-strhas.adb *** gcc-4.3.3/gcc/ada/a-strhas.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-strhas.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-strmap.adb gcc-4.4.0/gcc/ada/a-strmap.adb *** gcc-4.3.3/gcc/ada/a-strmap.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-strmap.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-strmap.ads gcc-4.4.0/gcc/ada/a-strmap.ads *** gcc-4.3.3/gcc/ada/a-strmap.ads Tue Oct 31 17:49:05 2006 --- gcc-4.4.0/gcc/ada/a-strmap.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-strsea.adb gcc-4.4.0/gcc/ada/a-strsea.adb *** gcc-4.3.3/gcc/ada/a-strsea.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-strsea.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-strsea.ads gcc-4.4.0/gcc/ada/a-strsea.ads *** gcc-4.3.3/gcc/ada/a-strsea.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-strsea.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-strsup.adb gcc-4.4.0/gcc/ada/a-strsup.adb *** gcc-4.3.3/gcc/ada/a-strsup.adb Tue Aug 14 08:37:26 2007 --- gcc-4.4.0/gcc/ada/a-strsup.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-strsup.ads gcc-4.4.0/gcc/ada/a-strsup.ads *** gcc-4.3.3/gcc/ada/a-strsup.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-strsup.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-strunb.adb gcc-4.4.0/gcc/ada/a-strunb.adb *** gcc-4.3.3/gcc/ada/a-strunb.adb Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/a-strunb.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-strunb.ads gcc-4.4.0/gcc/ada/a-strunb.ads *** gcc-4.3.3/gcc/ada/a-strunb.ads Tue Oct 31 17:49:05 2006 --- gcc-4.4.0/gcc/ada/a-strunb.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 395,401 **** Reference : String_Access := Null_String'Access; Last : Natural := 0; end record; - -- The Unbounded_String is using a buffered implementation to increase -- speed of the Append/Delete/Insert procedures. The Reference string -- pointer above contains the current string value and extra room at the --- 393,398 ---- *************** private *** 404,409 **** --- 401,407 ---- -- Reference (1 .. Last). pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String); + -- Provide stream routines without dragging in Ada.Streams pragma Finalize_Storage_Only (Unbounded_String); -- Finalization is required only for freeing storage diff -Nrcpad gcc-4.3.3/gcc/ada/a-ststio.adb gcc-4.4.0/gcc/ada/a-ststio.adb *** gcc-4.3.3/gcc/ada/a-ststio.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-ststio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Streams.Stream_IO is *** 102,108 **** procedure Close (File : in out File_Type) is begin ! FIO.Close (AP (File)); end Close; ------------ --- 100,106 ---- procedure Close (File : in out File_Type) is begin ! FIO.Close (AP (File)'Unrestricted_Access); end Close; ------------ *************** package body Ada.Streams.Stream_IO is *** 138,144 **** procedure Delete (File : in out File_Type) is begin ! FIO.Delete (AP (File)); end Delete; ----------------- --- 136,142 ---- procedure Delete (File : in out File_Type) is begin ! FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- *************** package body Ada.Streams.Stream_IO is *** 362,368 **** if ((File.Mode = FCB.In_File) /= (Mode = In_File)) and then not File.Update_Mode then ! FIO.Reset (AP (File), FCB.Inout_File); File.Update_Mode := True; end if; --- 360,366 ---- if ((File.Mode = FCB.In_File) /= (Mode = In_File)) and then not File.Update_Mode then ! FIO.Reset (AP (File)'Unrestricted_Access, FCB.Inout_File); File.Update_Mode := True; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/a-ststio.ads gcc-4.4.0/gcc/ada/a-ststio.ads *** gcc-4.3.3/gcc/ada/a-ststio.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-ststio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Ada.Streams.Stream_IO is *** 144,149 **** --- 142,177 ---- Data_Error : exception renames IO_Exceptions.Data_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + pragma Export_Procedure + (Internal => Set_Mode, + External => "", + Mechanism => (File => Reference)); + package FCB renames System.File_Control_Block; ----------------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stunau.adb gcc-4.4.0/gcc/ada/a-stunau.adb *** gcc-4.3.3/gcc/ada/a-stunau.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/a-stunau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stunau.ads gcc-4.4.0/gcc/ada/a-stunau.ads *** gcc-4.3.3/gcc/ada/a-stunau.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/a-stunau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stunha.adb gcc-4.4.0/gcc/ada/a-stunha.adb *** gcc-4.3.3/gcc/ada/a-stunha.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-stunha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-stwibo.adb gcc-4.4.0/gcc/ada/a-stwibo.adb *** gcc-4.3.3/gcc/ada/a-stwibo.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-stwibo.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stwibo.ads gcc-4.4.0/gcc/ada/a-stwibo.ads *** gcc-4.3.3/gcc/ada/a-stwibo.ads Tue Oct 31 17:49:05 2006 --- gcc-4.4.0/gcc/ada/a-stwibo.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stwifi.adb gcc-4.4.0/gcc/ada/a-stwifi.adb *** gcc-4.3.3/gcc/ada/a-stwifi.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-stwifi.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stwiha.adb gcc-4.4.0/gcc/ada/a-stwiha.adb *** gcc-4.3.3/gcc/ada/a-stwiha.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-stwiha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-stwima.adb gcc-4.4.0/gcc/ada/a-stwima.adb *** gcc-4.3.3/gcc/ada/a-stwima.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-stwima.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stwima.ads gcc-4.4.0/gcc/ada/a-stwima.ads *** gcc-4.3.3/gcc/ada/a-stwima.ads Tue Oct 31 17:49:05 2006 --- gcc-4.4.0/gcc/ada/a-stwima.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stwise.adb gcc-4.4.0/gcc/ada/a-stwise.adb *** gcc-4.3.3/gcc/ada/a-stwise.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-stwise.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stwise.ads gcc-4.4.0/gcc/ada/a-stwise.ads *** gcc-4.3.3/gcc/ada/a-stwise.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-stwise.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stwisu.adb gcc-4.4.0/gcc/ada/a-stwisu.adb *** gcc-4.3.3/gcc/ada/a-stwisu.adb Tue Aug 14 08:37:26 2007 --- gcc-4.4.0/gcc/ada/a-stwisu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stwisu.ads gcc-4.4.0/gcc/ada/a-stwisu.ads *** gcc-4.3.3/gcc/ada/a-stwisu.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-stwisu.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stwiun.adb gcc-4.4.0/gcc/ada/a-stwiun.adb *** gcc-4.3.3/gcc/ada/a-stwiun.adb Wed Jun 6 10:20:30 2007 --- gcc-4.4.0/gcc/ada/a-stwiun.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stwiun.ads gcc-4.4.0/gcc/ada/a-stwiun.ads *** gcc-4.3.3/gcc/ada/a-stwiun.ads Tue Oct 31 17:49:05 2006 --- gcc-4.4.0/gcc/ada/a-stwiun.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stzbou.adb gcc-4.4.0/gcc/ada/a-stzbou.adb *** gcc-4.3.3/gcc/ada/a-stzbou.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-stzbou.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stzbou.ads gcc-4.4.0/gcc/ada/a-stzbou.ads *** gcc-4.3.3/gcc/ada/a-stzbou.ads Tue Oct 31 17:49:05 2006 --- gcc-4.4.0/gcc/ada/a-stzbou.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stzfix.adb gcc-4.4.0/gcc/ada/a-stzfix.adb *** gcc-4.3.3/gcc/ada/a-stzfix.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-stzfix.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stzhas.adb gcc-4.4.0/gcc/ada/a-stzhas.adb *** gcc-4.3.3/gcc/ada/a-stzhas.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-stzhas.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-stzhas.ads gcc-4.4.0/gcc/ada/a-stzhas.ads *** gcc-4.3.3/gcc/ada/a-stzhas.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-stzhas.ads Mon Mar 24 10:57:32 2008 *************** *** 13,18 **** --- 13,20 ---- -- -- ------------------------------------------------------------------------------ + -- Is this really an RM unit? Doc needed??? + with Ada.Containers; function Ada.Strings.Wide_Wide_Hash diff -Nrcpad gcc-4.3.3/gcc/ada/a-stzmap.adb gcc-4.4.0/gcc/ada/a-stzmap.adb *** gcc-4.3.3/gcc/ada/a-stzmap.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-stzmap.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stzmap.ads gcc-4.4.0/gcc/ada/a-stzmap.ads *** gcc-4.3.3/gcc/ada/a-stzmap.ads Tue Oct 31 17:49:05 2006 --- gcc-4.4.0/gcc/ada/a-stzmap.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stzsea.adb gcc-4.4.0/gcc/ada/a-stzsea.adb *** gcc-4.3.3/gcc/ada/a-stzsea.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-stzsea.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stzsea.ads gcc-4.4.0/gcc/ada/a-stzsea.ads *** gcc-4.3.3/gcc/ada/a-stzsea.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-stzsea.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stzsup.adb gcc-4.4.0/gcc/ada/a-stzsup.adb *** gcc-4.3.3/gcc/ada/a-stzsup.adb Tue Aug 14 08:37:26 2007 --- gcc-4.4.0/gcc/ada/a-stzsup.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stzsup.ads gcc-4.4.0/gcc/ada/a-stzsup.ads *** gcc-4.3.3/gcc/ada/a-stzsup.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-stzsup.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stzunb.adb gcc-4.4.0/gcc/ada/a-stzunb.adb *** gcc-4.3.3/gcc/ada/a-stzunb.adb Wed Jun 6 10:20:30 2007 --- gcc-4.4.0/gcc/ada/a-stzunb.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-stzunb.ads gcc-4.4.0/gcc/ada/a-stzunb.ads *** gcc-4.3.3/gcc/ada/a-stzunb.ads Tue Oct 31 17:49:05 2006 --- gcc-4.4.0/gcc/ada/a-stzunb.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-suteio.adb gcc-4.4.0/gcc/ada/a-suteio.adb *** gcc-4.3.3/gcc/ada/a-suteio.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-suteio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Strings.Unbounded.Text_ *** 51,57 **** Str1 := new String'(Buffer (1 .. Last)); while Last = Buffer'Last loop Get_Line (Buffer, Last); ! Str2 := new String'(Str1.all & Buffer (1 .. Last)); Free (Str1); Str1 := Str2; end loop; --- 49,57 ---- Str1 := new String'(Buffer (1 .. Last)); while Last = Buffer'Last loop Get_Line (Buffer, Last); ! Str2 := new String (1 .. Str1'Last + Last); ! Str2 (Str1'Range) := Str1.all; ! Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); Free (Str1); Str1 := Str2; end loop; *************** package body Ada.Strings.Unbounded.Text_ *** 73,79 **** Str1 := new String'(Buffer (1 .. Last)); while Last = Buffer'Last loop Get_Line (File, Buffer, Last); ! Str2 := new String'(Str1.all & Buffer (1 .. Last)); Free (Str1); Str1 := Str2; end loop; --- 73,81 ---- Str1 := new String'(Buffer (1 .. Last)); while Last = Buffer'Last loop Get_Line (File, Buffer, Last); ! Str2 := new String (1 .. Str1'Last + Last); ! Str2 (Str1'Range) := Str1.all; ! Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); Free (Str1); Str1 := Str2; end loop; diff -Nrcpad gcc-4.3.3/gcc/ada/a-suteio.ads gcc-4.4.0/gcc/ada/a-suteio.ads *** gcc-4.3.3/gcc/ada/a-suteio.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-suteio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-swbwha.adb gcc-4.4.0/gcc/ada/a-swbwha.adb *** gcc-4.3.3/gcc/ada/a-swbwha.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-swbwha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-swmwco.ads gcc-4.4.0/gcc/ada/a-swmwco.ads *** gcc-4.3.3/gcc/ada/a-swmwco.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-swmwco.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-swunau.adb gcc-4.4.0/gcc/ada/a-swunau.adb *** gcc-4.3.3/gcc/ada/a-swunau.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/a-swunau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-swunau.ads gcc-4.4.0/gcc/ada/a-swunau.ads *** gcc-4.3.3/gcc/ada/a-swunau.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/a-swunau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-swuwha.adb gcc-4.4.0/gcc/ada/a-swuwha.adb *** gcc-4.3.3/gcc/ada/a-swuwha.adb Wed Sep 12 11:59:17 2007 --- gcc-4.4.0/gcc/ada/a-swuwha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-swuwha.ads gcc-4.4.0/gcc/ada/a-swuwha.ads *** gcc-4.3.3/gcc/ada/a-swuwha.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-swuwha.ads Mon Mar 24 10:57:32 2008 *************** *** 13,18 **** --- 13,20 ---- -- -- ------------------------------------------------------------------------------ + -- Is this really an RM unit? Doc needed ??? + with Ada.Containers; function Ada.Strings.Wide_Unbounded.Wide_Hash diff -Nrcpad gcc-4.3.3/gcc/ada/a-swuwti.adb gcc-4.4.0/gcc/ada/a-swuwti.adb *** gcc-4.3.3/gcc/ada/a-swuwti.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-swuwti.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Strings.Wide_Unbounded. *** 51,57 **** Str1 := new Wide_String'(Buffer (1 .. Last)); while Last = Buffer'Last loop Get_Line (Buffer, Last); ! Str2 := new Wide_String'(Str1.all & Buffer (1 .. Last)); Free (Str1); Str1 := Str2; end loop; --- 49,57 ---- Str1 := new Wide_String'(Buffer (1 .. Last)); while Last = Buffer'Last loop Get_Line (Buffer, Last); ! Str2 := new Wide_String (1 .. Str1'Last + Last); ! Str2 (Str1'Range) := Str1.all; ! Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); Free (Str1); Str1 := Str2; end loop; *************** package body Ada.Strings.Wide_Unbounded. *** 75,81 **** Str1 := new Wide_String'(Buffer (1 .. Last)); while Last = Buffer'Last loop Get_Line (File, Buffer, Last); ! Str2 := new Wide_String'(Str1.all & Buffer (1 .. Last)); Free (Str1); Str1 := Str2; end loop; --- 75,83 ---- Str1 := new Wide_String'(Buffer (1 .. Last)); while Last = Buffer'Last loop Get_Line (File, Buffer, Last); ! Str2 := new Wide_String (1 .. Str1'Last + Last); ! Str2 (Str1'Range) := Str1.all; ! Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); Free (Str1); Str1 := Str2; end loop; diff -Nrcpad gcc-4.3.3/gcc/ada/a-swuwti.ads gcc-4.4.0/gcc/ada/a-swuwti.ads *** gcc-4.3.3/gcc/ada/a-swuwti.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-swuwti.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-sytaco.adb gcc-4.4.0/gcc/ada/a-sytaco.adb *** gcc-4.3.3/gcc/ada/a-sytaco.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-sytaco.adb Thu Apr 9 23:23:07 2009 *************** *** 6,50 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ - with System.Tasking; - -- Used for Detect_Blocking - -- Self - with Ada.Exceptions; - -- Used for Raise_Exception with System.Task_Primitives.Operations; - -- Used for Initialize - -- Finalize - -- Current_State - -- Set_False - -- Set_True - -- Suspend_Until_True package body Ada.Synchronous_Task_Control is --- 6,38 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; + with System.Tasking; with System.Task_Primitives.Operations; package body Ada.Synchronous_Task_Control is diff -Nrcpad gcc-4.3.3/gcc/ada/a-sytaco.ads gcc-4.4.0/gcc/ada/a-sytaco.ads *** gcc-4.3.3/gcc/ada/a-sytaco.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-sytaco.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 36,45 **** ------------------------------------------------------------------------------ with System.Task_Primitives; - -- Used for Suspension_Object with Ada.Finalization; - -- Used for Limited_Controlled package Ada.Synchronous_Task_Control is pragma Preelaborate_05; --- 34,41 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/a-szbzha.adb gcc-4.4.0/gcc/ada/a-szbzha.adb *** gcc-4.3.3/gcc/ada/a-szbzha.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-szbzha.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . S T R I N G S . W I D E _ W I D E _ B O U N D E D . -- ! -- W I D E _ W I D E _ H A S H -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 2,28 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.STRINGS.WIDE_WIDE_BOUNDED.WIDE_WIDE_HASH -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-szbzha.ads gcc-4.4.0/gcc/ada/a-szbzha.ads *** gcc-4.3.3/gcc/ada/a-szbzha.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-szbzha.ads Mon Mar 24 10:57:32 2008 *************** *** 2,9 **** -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- A D A . S T R I N G S . W I D E _ W I D E _ B O U N D E D . -- ! -- W I D E _ W I D E _ H A S H -- -- -- -- S p e c -- -- -- --- 2,8 ---- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- ! -- ADA.STRINGS.WIDE_WIDE_BOUNDED.WIDE_WIDE_HASH -- -- -- -- S p e c -- -- -- *************** *** 14,19 **** --- 13,20 ---- -- -- ------------------------------------------------------------------------------ + -- Is this really an RM unit? doc needed ??? + with Ada.Containers; generic diff -Nrcpad gcc-4.3.3/gcc/ada/a-szmzco.ads gcc-4.4.0/gcc/ada/a-szmzco.ads *** gcc-4.3.3/gcc/ada/a-szmzco.ads Mon Sep 5 08:11:07 2005 --- gcc-4.4.0/gcc/ada/a-szmzco.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-szunau.adb gcc-4.4.0/gcc/ada/a-szunau.adb *** gcc-4.3.3/gcc/ada/a-szunau.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/a-szunau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-szunau.ads gcc-4.4.0/gcc/ada/a-szunau.ads *** gcc-4.3.3/gcc/ada/a-szunau.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/a-szunau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-szuzha.adb gcc-4.4.0/gcc/ada/a-szuzha.adb *** gcc-4.3.3/gcc/ada/a-szuzha.adb Tue Oct 31 17:43:17 2006 --- gcc-4.4.0/gcc/ada/a-szuzha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/a-szuzti.adb gcc-4.4.0/gcc/ada/a-szuzti.adb *** gcc-4.3.3/gcc/ada/a-szuzti.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-szuzti.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Strings.Wide_Wide_Unbou *** 51,57 **** Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); while Last = Buffer'Last loop Get_Line (Buffer, Last); ! Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last)); Free (Str1); Str1 := Str2; end loop; --- 49,57 ---- Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); while Last = Buffer'Last loop Get_Line (Buffer, Last); ! Str2 := new Wide_Wide_String (1 .. Str1'Last + Last); ! Str2 (Str1'Range) := Str1.all; ! Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); Free (Str1); Str1 := Str2; end loop; *************** package body Ada.Strings.Wide_Wide_Unbou *** 76,82 **** while Last = Buffer'Last loop Get_Line (File, Buffer, Last); ! Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last)); Free (Str1); Str1 := Str2; end loop; --- 76,84 ---- while Last = Buffer'Last loop Get_Line (File, Buffer, Last); ! Str2 := new Wide_Wide_String (1 .. Str1'Last + Last); ! Str2 (Str1'Range) := Str1.all; ! Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); Free (Str1); Str1 := Str2; end loop; diff -Nrcpad gcc-4.3.3/gcc/ada/a-szuzti.ads gcc-4.4.0/gcc/ada/a-szuzti.ads *** gcc-4.3.3/gcc/ada/a-szuzti.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-szuzti.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tags.adb gcc-4.4.0/gcc/ada/a-tags.adb *** gcc-4.3.3/gcc/ada/a-tags.adb Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/a-tags.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Tags is *** 105,129 **** function To_Object_Specific_Data_Ptr is new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); - function To_Predef_Prims_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Predef_Prims_Table_Ptr); - function To_Tag_Ptr is new Ada.Unchecked_Conversion (System.Address, Tag_Ptr); function To_Type_Specific_Data_Ptr is new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); - ------------------------------------------------ - -- Unchecked Conversions for other components -- - ------------------------------------------------ - - type Acc_Size - is access function (A : System.Address) return Long_Long_Integer; - - function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size); - -- The profile of the implicitly defined _size primitive - ------------------------------- -- Inline_Always Subprograms -- ------------------------------- --- 103,114 ---- *************** package body Ada.Tags is *** 733,739 **** begin Len := 1; ! while Str (Len) /= ASCII.Nul loop Len := Len + 1; end loop; --- 718,724 ---- begin Len := 1; ! while Str (Len) /= ASCII.NUL loop Len := Len + 1; end loop; *************** package body Ada.Tags is *** 778,812 **** -- The tag of the parent is always in the first slot of the table of -- ancestor tags. - Size_Slot : constant Positive := 1; - -- The pointer to the _size primitive is always in the first slot of - -- the dispatch table. - TSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); TSD : constant Type_Specific_Data_Ptr := To_Type_Specific_Data_Ptr (TSD_Ptr.all); -- Pointer to the TSD ! Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot); ! Parent_Predef_Prims_Ptr : constant Addr_Ptr := ! To_Addr_Ptr (To_Address (Parent_Tag) ! - DT_Predef_Prims_Offset); ! Parent_Predef_Prims : constant Predef_Prims_Table_Ptr := ! To_Predef_Prims_Table_Ptr ! (Parent_Predef_Prims_Ptr.all); ! ! -- The tag of the parent type through the dispatch table and its ! -- Predef_Prims field. ! ! F : constant Acc_Size := ! To_Acc_Size (Parent_Predef_Prims (Size_Slot)); ! -- Access to the _size primitive of the parent begin -- Here we compute the size of the _parent field of the object ! return SSE.Storage_Count (F.all (Obj)); end Parent_Size; ---------------- --- 763,785 ---- -- The tag of the parent is always in the first slot of the table of -- ancestor tags. TSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); TSD : constant Type_Specific_Data_Ptr := To_Type_Specific_Data_Ptr (TSD_Ptr.all); -- Pointer to the TSD ! Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot); ! Parent_TSD_Ptr : constant Addr_Ptr := ! To_Addr_Ptr (To_Address (Parent_Tag) ! - DT_Typeinfo_Ptr_Size); ! Parent_TSD : constant Type_Specific_Data_Ptr := ! To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all); begin -- Here we compute the size of the _parent field of the object ! return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj)); end Parent_Size; ---------------- *************** package body Ada.Tags is *** 837,842 **** --- 810,865 ---- end if; end Parent_Tag; + ------------------------------- + -- Register_Interface_Offset -- + ------------------------------- + + procedure Register_Interface_Offset + (This : System.Address; + Interface_T : Tag; + Is_Static : Boolean; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr) + is + Prim_DT : Dispatch_Table_Ptr; + Iface_Table : Interface_Data_Ptr; + + begin + -- "This" points to the primary DT and we must save Offset_Value in + -- the Offset_To_Top field of the corresponding dispatch table. + + Prim_DT := DT (To_Tag_Ptr (This).all); + Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; + + -- Save Offset_Value in the table of interfaces of the primary DT. + -- This data will be used by the subprogram "Displace" to give support + -- to backward abstract interface type conversions. + + -- Register the offset in the table of interfaces + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then + if Is_Static or else Offset_Value = 0 then + Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True; + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value := + Offset_Value; + else + Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False; + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func := + Offset_Func; + end if; + + return; + end if; + end loop; + end if; + + -- If we arrive here there is some error in the run-time data structure + + raise Program_Error; + end Register_Interface_Offset; + ------------------ -- Register_Tag -- ------------------ *************** package body Ada.Tags is *** 892,959 **** -- Set_Offset_To_Top -- ----------------------- ! procedure Set_Offset_To_Top (This : System.Address; Interface_T : Tag; - Is_Static : Boolean; Offset_Value : SSE.Storage_Offset; Offset_Func : Offset_To_Top_Function_Ptr) is ! Prim_DT : Dispatch_Table_Ptr; ! Sec_Base : System.Address; ! Sec_DT : Dispatch_Table_Ptr; ! Iface_Table : Interface_Data_Ptr; ! begin -- Save the offset to top field in the secondary dispatch table if Offset_Value /= 0 then Sec_Base := This + Offset_Value; ! Sec_DT := DT (To_Tag_Ptr (Sec_Base).all); ! ! if Is_Static then ! Sec_DT.Offset_To_Top := Offset_Value; ! else ! Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last; ! end if; ! end if; ! ! -- "This" points to the primary DT and we must save Offset_Value in ! -- the Offset_To_Top field of the corresponding secondary dispatch ! -- table. ! ! Prim_DT := DT (To_Tag_Ptr (This).all); ! Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; ! ! -- Save Offset_Value in the table of interfaces of the primary DT. ! -- This data will be used by the subprogram "Displace" to give support ! -- to backward abstract interface type conversions. ! ! -- Register the offset in the table of interfaces ! ! if Iface_Table /= null then ! for Id in 1 .. Iface_Table.Nb_Ifaces loop ! if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then ! Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := ! Is_Static; ! ! if Is_Static then ! Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value ! := Offset_Value; ! else ! Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func ! := Offset_Func; ! end if; ! ! return; ! end if; ! end loop; end if; ! -- If we arrive here there is some error in the run-time data structure ! ! raise Program_Error; ! end Set_Offset_To_Top; ---------------------- -- Set_Prim_Op_Kind -- --- 915,940 ---- -- Set_Offset_To_Top -- ----------------------- ! procedure Set_Dynamic_Offset_To_Top (This : System.Address; Interface_T : Tag; Offset_Value : SSE.Storage_Offset; Offset_Func : Offset_To_Top_Function_Ptr) is ! Sec_Base : System.Address; ! Sec_DT : Dispatch_Table_Ptr; begin -- Save the offset to top field in the secondary dispatch table if Offset_Value /= 0 then Sec_Base := This + Offset_Value; ! Sec_DT := DT (To_Tag_Ptr (Sec_Base).all); ! Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last; end if; ! Register_Interface_Offset ! (This, Interface_T, False, Offset_Value, Offset_Func); ! end Set_Dynamic_Offset_To_Top; ---------------------- -- Set_Prim_Op_Kind -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tags.ads gcc-4.4.0/gcc/ada/a-tags.ads *** gcc-4.3.3/gcc/ada/a-tags.ads Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/a-tags.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 222,228 **** -- type. This construct is used in the handling of dispatching triggers -- in select statements. ! type Address_Array is array (Positive range <>) of System.Address; subtype Dispatch_Table is Address_Array (1 .. 1); -- Used by GDB to identify the _tags and traverse the run-time structure --- 220,227 ---- -- type. This construct is used in the handling of dispatching triggers -- in select statements. ! type Prim_Ptr is access procedure; ! type Address_Array is array (Positive range <>) of Prim_Ptr; subtype Dispatch_Table is Address_Array (1 .. 1); -- Used by GDB to identify the _tags and traverse the run-time structure *************** private *** 242,249 **** --- 241,254 ---- type Tag_Ptr is access all Tag; pragma No_Strict_Aliasing (Tag_Ptr); + type Offset_To_Top_Ptr is access all SSE.Storage_Offset; + pragma No_Strict_Aliasing (Offset_To_Top_Ptr); + type Tag_Table is array (Natural range <>) of Tag; + type Size_Ptr is + access function (A : System.Address) return Long_Long_Integer; + type Type_Specific_Data (Idepth : Natural) is record -- The discriminant Idepth is the Inheritance Depth Level: Used to -- implement the membership test associated with single inheritance of *************** private *** 279,284 **** --- 284,295 ---- -- Controller Offset: Used to give support to tagged controlled objects -- (see Get_Deep_Controller at s-finimp) + Size_Func : Size_Ptr; + -- Pointer to the subprogram computing the _size of the object. Used by + -- the run-time whenever a call to the 'size primitive is required. We + -- cannot assume that the contents of dispatch tables are addresses + -- because in some architectures the ABI allows descriptors. + Interfaces_Table : Interface_Data_Ptr; -- Pointer to the table of interface tags. It is used to implement the -- membership test associated with interfaces and also for backward *************** private *** 370,375 **** --- 381,390 ---- use type System.Storage_Elements.Storage_Offset; + DT_Offset_To_Top_Offset : constant SSE.Storage_Count := + DT_Typeinfo_Ptr_Size + + DT_Offset_To_Top_Size; + DT_Predef_Prims_Offset : constant SSE.Storage_Count := DT_Typeinfo_Ptr_Size + DT_Offset_To_Top_Size *************** private *** 474,501 **** pragma Export (Ada, Parent_Size, "ada__tags__parent_size"); -- This procedure is used in s-finimp and is thus exported manually procedure Register_Tag (T : Tag); -- Insert the Tag and its associated external_tag in a table for the -- sake of Internal_Tag ! procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive); ! -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's ! -- TSD table indexed by Position. ! ! procedure Set_Offset_To_Top (This : System.Address; Interface_T : Tag; - Is_Static : Boolean; Offset_Value : SSE.Storage_Offset; Offset_Func : Offset_To_Top_Function_Ptr); ! -- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of ! -- the dispatch table. In primary dispatch tables the value of "This" is ! -- not required (and the compiler passes always the Null_Address value) and ! -- the Offset_Value is always cero; in secondary dispatch tables "This" ! -- points to the object, Interface_T is the interface for which the ! -- secondary dispatch table is being initialized, and Offset_Value is the ! -- distance from "This" to the object component containing the tag of the ! -- secondary dispatch table. procedure Set_Prim_Op_Kind (T : Tag; --- 489,532 ---- pragma Export (Ada, Parent_Size, "ada__tags__parent_size"); -- This procedure is used in s-finimp and is thus exported manually + procedure Register_Interface_Offset + (This : System.Address; + Interface_T : Tag; + Is_Static : Boolean; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr); + -- Register in the table of interfaces of the tagged type associated with + -- "This" object the offset of the record component associated with the + -- progenitor Interface_T (that is, the distance from "This" to the object + -- component containing the tag of the secondary dispatch table). In case + -- of constant offset, Is_Static is true and Offset_Value has such value. + -- In case of variable offset, Is_Static is false and Offset_Func is an + -- access to function that must be called to evaluate the offset. + procedure Register_Tag (T : Tag); -- Insert the Tag and its associated external_tag in a table for the -- sake of Internal_Tag ! procedure Set_Dynamic_Offset_To_Top (This : System.Address; Interface_T : Tag; Offset_Value : SSE.Storage_Offset; Offset_Func : Offset_To_Top_Function_Ptr); ! -- Ada 2005 (AI-251): The compiler generates calls to this routine only ! -- when initializing the Offset_To_Top field of dispatch tables associated ! -- with tagged type whose parent has variable size components. "This" is ! -- the object whose dispatch table is being initialized. Interface_T is the ! -- interface for which the secondary dispatch table is being initialized, ! -- and Offset_Value is the distance from "This" to the object component ! -- containing the tag of the secondary dispatch table (a zero value means ! -- that this interface shares the primary dispatch table). Offset_Func ! -- references a function that must be called to evaluate the offset at ! -- runtime. This routine also takes care of registering these values in ! -- the table of interfaces of the type. ! ! procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive); ! -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's ! -- TSD table indexed by Position. procedure Set_Prim_Op_Kind (T : Tag; *************** private *** 532,536 **** type Addr_Ptr is access System.Address; pragma No_Strict_Aliasing (Addr_Ptr); ! -- Why is this needed ??? end Ada.Tags; --- 563,569 ---- type Addr_Ptr is access System.Address; pragma No_Strict_Aliasing (Addr_Ptr); ! -- This type is used by the frontend to generate the code that handles ! -- dispatch table slots of types declared at the local level. ! end Ada.Tags; diff -Nrcpad gcc-4.3.3/gcc/ada/a-tasatt.adb gcc-4.4.0/gcc/ada/a-tasatt.adb *** gcc-4.3.3/gcc/ada/a-tasatt.adb Tue Nov 13 14:11:18 2007 --- gcc-4.4.0/gcc/ada/a-tasatt.adb Sun Sep 14 06:21:12 2008 *************** *** 7,13 **** -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, AdaCore -- -- -- -- GNARL 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- -- --- 7,13 ---- -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNARL 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- -- *************** *** 222,260 **** -- instantiated from within a local context. with System.Error_Reporting; - -- Used for Shutdown; - with System.Storage_Elements; - -- Used for Integer_Address - with System.Task_Primitives.Operations; - -- Used for Write_Lock - -- Unlock - -- Lock/Unlock_RTS - with System.Tasking; - -- Used for Access_Address - -- Task_Id - -- Direct_Index_Vector - -- Direct_Index - with System.Tasking.Initialization; - -- Used for Defer_Abort - -- Undefer_Abort - -- Initialize_Attributes_Link - -- Finalize_Attributes_Link - with System.Tasking.Task_Attributes; - -- Used for Access_Node - -- Access_Dummy_Wrapper - -- Deallocator - -- Instance - -- Node - -- Access_Instance with Ada.Exceptions; - -- Used for Raise_Exception - with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; --- 222,234 ---- *************** begin *** 745,751 **** In_Use := In_Use or Two_To_J; Local.Index := J; ! -- This unchecked conversions can give a warning when the the -- alignment is incorrect, but it will not be used in such a -- case anyway, so the warning can be safely ignored. --- 719,725 ---- In_Use := In_Use or Two_To_J; Local.Index := J; ! -- This unchecked conversions can give a warning when the -- alignment is incorrect, but it will not be used in such a -- case anyway, so the warning can be safely ignored. diff -Nrcpad gcc-4.3.3/gcc/ada/a-tasatt.ads gcc-4.4.0/gcc/ada/a-tasatt.ads *** gcc-4.3.3/gcc/ada/a-tasatt.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-tasatt.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-taside.adb gcc-4.4.0/gcc/ada/a-taside.adb *** gcc-4.3.3/gcc/ada/a-taside.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-taside.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 34,39 **** --- 32,38 ---- with System.Address_Image; with System.Parameters; with System.Soft_Links; + with System.Task_Primitives; with System.Task_Primitives.Operations; with Ada.Unchecked_Conversion; *************** pragma Warnings (Off); *** 43,49 **** -- It is safe in the context of the run-time to violate the rules! with System.Tasking.Utilities; - -- Used for Abort_Tasks pragma Warnings (On); --- 42,47 ---- *************** package body Ada.Task_Identification is *** 114,120 **** function Image (T : Task_Id) return String is function To_Address is new ! Ada.Unchecked_Conversion (Task_Id, System.Address); begin if T = Null_Task_Id then --- 112,119 ---- function Image (T : Task_Id) return String is function To_Address is new ! Ada.Unchecked_Conversion ! (Task_Id, System.Task_Primitives.Task_Address); begin if T = Null_Task_Id then diff -Nrcpad gcc-4.3.3/gcc/ada/a-taside.ads gcc-4.4.0/gcc/ada/a-taside.ads *** gcc-4.3.3/gcc/ada/a-taside.ads Tue Oct 31 17:49:05 2006 --- gcc-4.4.0/gcc/ada/a-taside.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-taster.adb gcc-4.4.0/gcc/ada/a-taster.adb *** gcc-4.3.3/gcc/ada/a-taster.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-taster.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 32,52 **** ------------------------------------------------------------------------------ with System.Tasking; - -- used for Task_Id - with System.Task_Primitives.Operations; - -- used for Self - -- Write_Lock - -- Unlock - -- Lock_RTS - -- Unlock_RTS - with System.Parameters; - -- used for Single_Lock - with System.Soft_Links; - -- use for Abort_Defer - -- Abort_Undefer with Ada.Unchecked_Conversion; --- 30,38 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/a-teioed.adb gcc-4.4.0/gcc/ada/a-teioed.adb *** gcc-4.3.3/gcc/ada/a-teioed.adb Tue Aug 14 08:36:48 2007 --- gcc-4.4.0/gcc/ada/a-teioed.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Text_IO.Editing is *** 84,89 **** --- 82,91 ---- -- character has already been made, so a count of one is a -- no-op, and a count of zero erases a character. + if Result_Index + Count - 2 > Result'Last then + raise Picture_Error; + end if; + for J in 2 .. Count loop Result (Result_Index + J - 2) := Picture (Picture_Index - 1); end loop; *************** package body Ada.Text_IO.Editing is *** 98,103 **** --- 100,109 ---- raise Picture_Error; when others => + if Result_Index > Result'Last then + raise Picture_Error; + end if; + Result (Result_Index) := Picture (Picture_Index); Picture_Index := Picture_Index + 1; Result_Index := Result_Index + 1; *************** package body Ada.Text_IO.Editing is *** 417,423 **** Answer (J) := Separator_Character; elsif Answer (J) = 'b' then ! Answer (J) := '*'; end if; end loop; --- 423,429 ---- Answer (J) := Separator_Character; elsif Answer (J) = 'b' then ! Answer (J) := Fill_Character; end if; end loop; *************** package body Ada.Text_IO.Editing is *** 426,432 **** end if; for J in Pic.Start_Float .. Position loop ! Answer (J) := '*'; end loop; else --- 432,438 ---- end if; for J in Pic.Start_Float .. Position loop ! Answer (J) := Fill_Character; end loop; else diff -Nrcpad gcc-4.3.3/gcc/ada/a-teioed.ads gcc-4.4.0/gcc/ada/a-teioed.ads *** gcc-4.3.3/gcc/ada/a-teioed.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-teioed.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Ada.Text_IO.Editing is *** 55,61 **** Picture_Error : exception; Default_Currency : constant String := "$"; ! Default_Fill : constant Character := ' '; Default_Separator : constant Character := ','; Default_Radix_Mark : constant Character := '.'; --- 53,59 ---- Picture_Error : exception; Default_Currency : constant String := "$"; ! Default_Fill : constant Character := '*'; Default_Separator : constant Character := ','; Default_Radix_Mark : constant Character := '.'; diff -Nrcpad gcc-4.3.3/gcc/ada/a-textio.adb gcc-4.4.0/gcc/ada/a-textio.adb *** gcc-4.3.3/gcc/ada/a-textio.adb Thu Dec 13 10:20:52 2007 --- gcc-4.4.0/gcc/ada/a-textio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Text_IO is *** 148,154 **** procedure Close (File : in out File_Type) is begin ! FIO.Close (AP (File)); end Close; --------- --- 146,152 ---- procedure Close (File : in out File_Type) is begin ! FIO.Close (AP (File)'Unrestricted_Access); end Close; --------- *************** package body Ada.Text_IO is *** 247,253 **** procedure Delete (File : in out File_Type) is begin ! FIO.Delete (AP (File)); end Delete; ----------------- --- 245,251 ---- procedure Delete (File : in out File_Type) is begin ! FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- *************** package body Ada.Text_IO is *** 858,865 **** Result := WC_In (C, File.WC_Method); if Wide_Character'Pos (Result) > 16#FF# then ! raise Constraint_Error ! with "invalid wide character in Text_'I'O input"; else return Character'Val (Wide_Character'Pos (Result)); end if; --- 856,863 ---- Result := WC_In (C, File.WC_Method); if Wide_Character'Pos (Result) > 16#FF# then ! raise Constraint_Error with ! "invalid wide character in Text_'I'O input"; else return Character'Val (Wide_Character'Pos (Result)); end if; *************** package body Ada.Text_IO is *** 901,908 **** Result := WC_In (C, File.WC_Method); if Wide_Character'Pos (Result) > 16#FF# then ! raise Constraint_Error ! with "invalid wide character in Text_'I'O input"; else return Character'Val (Wide_Character'Pos (Result)); end if; --- 899,906 ---- Result := WC_In (C, File.WC_Method); if Wide_Character'Pos (Result) > 16#FF# then ! raise Constraint_Error with ! "invalid wide character in Text_'I'O input"; else return Character'Val (Wide_Character'Pos (Result)); end if; *************** package body Ada.Text_IO is *** 1037,1043 **** Item := ASCII.NUL; -- If we are before an upper half character just return it (this can ! -- happen if there are two calls to Look_Ahead in a row. elsif File.Before_Upper_Half_Character then End_Of_Line := False; --- 1035,1041 ---- Item := ASCII.NUL; -- If we are before an upper half character just return it (this can ! -- happen if there are two calls to Look_Ahead in a row). elsif File.Before_Upper_Half_Character then End_Of_Line := False; *************** package body Ada.Text_IO is *** 1585,1591 **** end if; Terminate_Line (File); ! FIO.Reset (AP (File), To_FCB (Mode)); File.Page := 1; File.Line := 1; File.Col := 1; --- 1583,1589 ---- end if; Terminate_Line (File); ! FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); File.Page := 1; File.Line := 1; File.Col := 1; *************** package body Ada.Text_IO is *** 1598,1604 **** procedure Reset (File : in out File_Type) is begin Terminate_Line (File); ! FIO.Reset (AP (File)); File.Page := 1; File.Line := 1; File.Col := 1; --- 1596,1602 ---- procedure Reset (File : in out File_Type) is begin Terminate_Line (File); ! FIO.Reset (AP (File)'Unrestricted_Access); File.Page := 1; File.Line := 1; File.Col := 1; *************** package body Ada.Text_IO is *** 1856,1862 **** if Start = 0 then File.WC_Method := WCEM_Brackets; ! elsif Start /= 0 then if Stop = Start then for J in WC_Encoding_Letters'Range loop if File.Form (Start) = WC_Encoding_Letters (J) then --- 1854,1860 ---- if Start = 0 then File.WC_Method := WCEM_Brackets; ! else if Stop = Start then for J in WC_Encoding_Letters'Range loop if File.Form (Start) = WC_Encoding_Letters (J) then *************** package body Ada.Text_IO is *** 2212,2220 **** -- null character in the runtime, here the null characters are added just -- to have a correct filename length. ! Err_Name : aliased String := "*stderr" & ASCII.Nul; ! In_Name : aliased String := "*stdin" & ASCII.Nul; ! Out_Name : aliased String := "*stdout" & ASCII.Nul; begin ------------------------------- --- 2210,2218 ---- -- null character in the runtime, here the null characters are added just -- to have a correct filename length. ! Err_Name : aliased String := "*stderr" & ASCII.NUL; ! In_Name : aliased String := "*stdin" & ASCII.NUL; ! Out_Name : aliased String := "*stdout" & ASCII.NUL; begin ------------------------------- *************** begin *** 2253,2259 **** Standard_In.Is_Text_File := True; Standard_In.Access_Method := 'T'; Standard_In.Self := Standard_In; ! Standard_In.WC_Method := Default_WCEM; Standard_Out.Stream := stdout; Standard_Out.Name := Out_Name'Access; --- 2251,2257 ---- Standard_In.Is_Text_File := True; Standard_In.Access_Method := 'T'; Standard_In.Self := Standard_In; ! Standard_In.WC_Method := Default_WCEM; Standard_Out.Stream := stdout; Standard_Out.Name := Out_Name'Access; diff -Nrcpad gcc-4.3.3/gcc/ada/a-textio.ads gcc-4.4.0/gcc/ada/a-textio.ads *** gcc-4.3.3/gcc/ada/a-textio.ads Thu Dec 13 10:20:52 2007 --- gcc-4.4.0/gcc/ada/a-textio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Ada.Text_IO is *** 301,306 **** --- 299,330 ---- Layout_Error : exception renames IO_Exceptions.Layout_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + ----------------------------------- -- Handling of Format Characters -- ----------------------------------- *************** private *** 317,323 **** -- omitted on output unless an explicit New_Page call is made before -- closing the file. No page mark is added when a file is appended to, -- so, in accordance with the permission in (RM A.10.2(4)), there may ! -- or may not be a page mark separating preexising text in the file -- from the new text to be written. -- A file mark is marked by the physical end of file. In DOS translation --- 341,347 ---- -- omitted on output unless an explicit New_Page call is made before -- closing the file. No page mark is added when a file is appended to, -- so, in accordance with the permission in (RM A.10.2(4)), there may ! -- or may not be a page mark separating preexisting text in the file -- from the new text to be written. -- A file mark is marked by the physical end of file. In DOS translation *************** private *** 354,360 **** Self : aliased File_Type; -- Set to point to the containing Text_AFCB block. This is used to ! -- implement the Current_{Error,Input,Ouput} functions which return -- a File_Access, the file access value returned is a pointer to -- the Self field of the corresponding file. --- 378,384 ---- Self : aliased File_Type; -- Set to point to the containing Text_AFCB block. This is used to ! -- implement the Current_{Error,Input,Output} functions which return -- a File_Access, the file access value returned is a pointer to -- the Self field of the corresponding file. diff -Nrcpad gcc-4.3.3/gcc/ada/a-tiboio.adb gcc-4.4.0/gcc/ada/a-tiboio.adb *** gcc-4.3.3/gcc/ada/a-tiboio.adb Wed Feb 15 09:34:21 2006 --- gcc-4.4.0/gcc/ada/a-tiboio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ticoau.adb gcc-4.4.0/gcc/ada/a-ticoau.adb *** gcc-4.3.3/gcc/ada/a-ticoau.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-ticoau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ticoau.ads gcc-4.4.0/gcc/ada/a-ticoau.ads *** gcc-4.3.3/gcc/ada/a-ticoau.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-ticoau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ticoio.adb gcc-4.4.0/gcc/ada/a-ticoio.adb *** gcc-4.3.3/gcc/ada/a-ticoio.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-ticoio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ticoio.ads gcc-4.4.0/gcc/ada/a-ticoio.ads *** gcc-4.3.3/gcc/ada/a-ticoio.ads Wed Feb 15 09:33:28 2006 --- gcc-4.4.0/gcc/ada/a-ticoio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tideau.adb gcc-4.4.0/gcc/ada/a-tideau.adb *** gcc-4.3.3/gcc/ada/a-tideau.adb Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-tideau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Text_IO.Decimal_Aux is *** 201,216 **** Ptr : Natural := 0; begin ! if Exp = 0 then ! Fore := To'Length - 1 - Aft; ! else ! Fore := To'Length - 2 - Aft - Exp; end if; if Fore < 1 then raise Layout_Error; end if; Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); if Ptr > To'Length then --- 199,222 ---- Ptr : Natural := 0; begin ! -- Compute Fore, allowing for Aft digits and the decimal dot ! ! Fore := To'Length - Field'Max (1, Aft) - 1; ! ! -- Allow for Exp and two more for E+ or E- if exponent present ! ! if Exp /= 0 then ! Fore := Fore - 2 - Exp; end if; + -- Make sure we have enough room + if Fore < 1 then raise Layout_Error; end if; + -- Do the conversion and check length of result + Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); if Ptr > To'Length then diff -Nrcpad gcc-4.3.3/gcc/ada/a-tideau.ads gcc-4.4.0/gcc/ada/a-tideau.ads *** gcc-4.3.3/gcc/ada/a-tideau.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-tideau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tideio.adb gcc-4.4.0/gcc/ada/a-tideio.adb *** gcc-4.3.3/gcc/ada/a-tideio.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-tideio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tideio.ads gcc-4.4.0/gcc/ada/a-tideio.ads *** gcc-4.3.3/gcc/ada/a-tideio.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-tideio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tienau.adb gcc-4.4.0/gcc/ada/a-tienau.adb *** gcc-4.3.3/gcc/ada/a-tienau.adb Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/a-tienau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tienau.ads gcc-4.4.0/gcc/ada/a-tienau.ads *** gcc-4.3.3/gcc/ada/a-tienau.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-tienau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tienio.adb gcc-4.4.0/gcc/ada/a-tienio.adb *** gcc-4.3.3/gcc/ada/a-tienio.adb Wed Jun 6 10:21:11 2007 --- gcc-4.4.0/gcc/ada/a-tienio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tienio.ads gcc-4.4.0/gcc/ada/a-tienio.ads *** gcc-4.3.3/gcc/ada/a-tienio.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-tienio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tifiio.adb gcc-4.4.0/gcc/ada/a-tifiio.adb *** gcc-4.3.3/gcc/ada/a-tifiio.adb Thu Dec 13 10:21:51 2007 --- gcc-4.4.0/gcc/ada/a-tifiio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Text_IO.Fixed_IO is *** 638,648 **** -- been generated, compute the Aft next digits (without rounding). -- Once a non-zero digit is generated, determine the exact number -- of digits remaining and compute them with rounding. -- Since a large number of iterations might be necessary in case -- of Aft = 1, the following optimization would be desirable. -- Count the number Z of leading zero bits in the integer ! -- representation of X, and start with producing ! -- Aft + Z * 1000 / 3322 digits in the first scaled division. -- However, the floating-point routines are still used now ??? --- 636,648 ---- -- been generated, compute the Aft next digits (without rounding). -- Once a non-zero digit is generated, determine the exact number -- of digits remaining and compute them with rounding. + -- Since a large number of iterations might be necessary in case -- of Aft = 1, the following optimization would be desirable. + -- Count the number Z of leading zero bits in the integer ! -- representation of X, and start with producing Aft + Z * 1000 / ! -- 3322 digits in the first scaled division. -- However, the floating-point routines are still used now ??? diff -Nrcpad gcc-4.3.3/gcc/ada/a-tifiio.ads gcc-4.4.0/gcc/ada/a-tifiio.ads *** gcc-4.3.3/gcc/ada/a-tifiio.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-tifiio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tiflau.adb gcc-4.4.0/gcc/ada/a-tiflau.adb *** gcc-4.3.3/gcc/ada/a-tiflau.adb Wed Jun 6 10:21:54 2007 --- gcc-4.4.0/gcc/ada/a-tiflau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tiflau.ads gcc-4.4.0/gcc/ada/a-tiflau.ads *** gcc-4.3.3/gcc/ada/a-tiflau.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-tiflau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tiflio.adb gcc-4.4.0/gcc/ada/a-tiflio.adb *** gcc-4.3.3/gcc/ada/a-tiflio.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-tiflio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tiflio.ads gcc-4.4.0/gcc/ada/a-tiflio.ads *** gcc-4.3.3/gcc/ada/a-tiflio.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-tiflio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tigeau.adb gcc-4.4.0/gcc/ada/a-tigeau.adb *** gcc-4.3.3/gcc/ada/a-tigeau.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-tigeau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tigeau.ads gcc-4.4.0/gcc/ada/a-tigeau.ads *** gcc-4.3.3/gcc/ada/a-tigeau.ads Wed Jun 6 10:22:05 2007 --- gcc-4.4.0/gcc/ada/a-tigeau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private package Ada.Text_IO.Generic_Aux *** 178,184 **** procedure String_Skip (Str : String; Ptr : out Integer); -- Used in the Get from string procedures to skip leading blanks in the -- string. Ptr is set to the index of the first non-blank. If the string ! -- is all blanks, then the excption End_Error is raised, Note that blank -- is defined as a space or horizontal tab (RM A.10.6(5)). procedure Ungetc (ch : Integer; File : File_Type); --- 176,182 ---- procedure String_Skip (Str : String; Ptr : out Integer); -- Used in the Get from string procedures to skip leading blanks in the -- string. Ptr is set to the index of the first non-blank. If the string ! -- is all blanks, then the exception End_Error is raised, Note that blank -- is defined as a space or horizontal tab (RM A.10.6(5)). procedure Ungetc (ch : Integer; File : File_Type); diff -Nrcpad gcc-4.3.3/gcc/ada/a-tiinau.adb gcc-4.4.0/gcc/ada/a-tiinau.adb *** gcc-4.3.3/gcc/ada/a-tiinau.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-tiinau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tiinau.ads gcc-4.4.0/gcc/ada/a-tiinau.ads *** gcc-4.3.3/gcc/ada/a-tiinau.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-tiinau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tiinio.adb gcc-4.4.0/gcc/ada/a-tiinio.adb *** gcc-4.3.3/gcc/ada/a-tiinio.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-tiinio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tiinio.ads gcc-4.4.0/gcc/ada/a-tiinio.ads *** gcc-4.3.3/gcc/ada/a-tiinio.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-tiinio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-timoau.adb gcc-4.4.0/gcc/ada/a-timoau.adb *** gcc-4.3.3/gcc/ada/a-timoau.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-timoau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-timoau.ads gcc-4.4.0/gcc/ada/a-timoau.ads *** gcc-4.3.3/gcc/ada/a-timoau.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/a-timoau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2001 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-timoio.adb gcc-4.4.0/gcc/ada/a-timoio.adb *** gcc-4.3.3/gcc/ada/a-timoio.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-timoio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-timoio.ads gcc-4.4.0/gcc/ada/a-timoio.ads *** gcc-4.3.3/gcc/ada/a-timoio.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-timoio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1993-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1993-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tiocst.adb gcc-4.4.0/gcc/ada/a-tiocst.adb *** gcc-4.3.3/gcc/ada/a-tiocst.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-tiocst.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-tiocst.ads gcc-4.4.0/gcc/ada/a-tiocst.ads *** gcc-4.3.3/gcc/ada/a-tiocst.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-tiocst.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-titest.adb gcc-4.4.0/gcc/ada/a-titest.adb *** gcc-4.3.3/gcc/ada/a-titest.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-titest.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wichun.adb gcc-4.4.0/gcc/ada/a-wichun.adb *** gcc-4.3.3/gcc/ada/a-wichun.adb Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/a-wichun.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wichun.ads gcc-4.4.0/gcc/ada/a-wichun.ads *** gcc-4.3.3/gcc/ada/a-wichun.ads Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/a-wichun.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-witeio.adb gcc-4.4.0/gcc/ada/a-witeio.adb *** gcc-4.3.3/gcc/ada/a-witeio.adb Thu Dec 13 10:20:52 2007 --- gcc-4.4.0/gcc/ada/a-witeio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Wide_Text_IO is *** 134,140 **** procedure Close (File : in out File_Type) is begin ! FIO.Close (AP (File)); end Close; --------- --- 132,138 ---- procedure Close (File : in out File_Type) is begin ! FIO.Close (AP (File)'Unrestricted_Access); end Close; --------- *************** package body Ada.Wide_Text_IO is *** 180,185 **** --- 178,185 ---- Amethod => 'W', Creat => True, Text => True); + + File.Self := File; Set_WCEM (File); end Create; *************** package body Ada.Wide_Text_IO is *** 194,200 **** function Current_Error return File_Access is begin ! return Current_Err'Access; end Current_Error; ------------------- --- 194,200 ---- function Current_Error return File_Access is begin ! return Current_Err.Self'Access; end Current_Error; ------------------- *************** package body Ada.Wide_Text_IO is *** 208,214 **** function Current_Input return File_Access is begin ! return Current_In'Access; end Current_Input; -------------------- --- 208,214 ---- function Current_Input return File_Access is begin ! return Current_In.Self'Access; end Current_Input; -------------------- *************** package body Ada.Wide_Text_IO is *** 222,228 **** function Current_Output return File_Access is begin ! return Current_Out'Access; end Current_Output; ------------ --- 222,228 ---- function Current_Output return File_Access is begin ! return Current_Out.Self'Access; end Current_Output; ------------ *************** package body Ada.Wide_Text_IO is *** 231,237 **** procedure Delete (File : in out File_Type) is begin ! FIO.Delete (AP (File)); end Delete; ----------------- --- 231,237 ---- procedure Delete (File : in out File_Type) is begin ! FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- *************** package body Ada.Wide_Text_IO is *** 754,759 **** --- 754,760 ---- -- Start of processing for Get_Wide_Char begin + FIO.Check_Read_Status (AP (File)); return WC_In (C, File.WC_Method); end Get_Wide_Char; *************** package body Ada.Wide_Text_IO is *** 788,793 **** --- 789,795 ---- -- Start of processing for Get_Wide_Char_Immed begin + FIO.Check_Read_Status (AP (File)); return WC_In (C, File.WC_Method); end Get_Wide_Char_Immed; *************** package body Ada.Wide_Text_IO is *** 1089,1094 **** --- 1091,1098 ---- Amethod => 'W', Creat => False, Text => True); + + File.Self := File; Set_WCEM (File); end Open; *************** package body Ada.Wide_Text_IO is *** 1151,1156 **** --- 1155,1161 ---- -- Start of processing for Put begin + FIO.Check_Write_Status (AP (File)); WC_Out (Item, File.WC_Method); File.Col := File.Col + 1; end Put; *************** package body Ada.Wide_Text_IO is *** 1313,1319 **** end if; Terminate_Line (File); ! FIO.Reset (AP (File), To_FCB (Mode)); File.Page := 1; File.Line := 1; File.Col := 1; --- 1318,1324 ---- end if; Terminate_Line (File); ! FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); File.Page := 1; File.Line := 1; File.Col := 1; *************** package body Ada.Wide_Text_IO is *** 1326,1332 **** procedure Reset (File : in out File_Type) is begin Terminate_Line (File); ! FIO.Reset (AP (File)); File.Page := 1; File.Line := 1; File.Col := 1; --- 1331,1337 ---- procedure Reset (File : in out File_Type) is begin Terminate_Line (File); ! FIO.Reset (AP (File)'Unrestricted_Access); File.Page := 1; File.Line := 1; File.Col := 1; *************** package body Ada.Wide_Text_IO is *** 1545,1551 **** if Start = 0 then File.WC_Method := WCEM_Brackets; ! elsif Start /= 0 then if Stop = Start then for J in WC_Encoding_Letters'Range loop if File.Form (Start) = WC_Encoding_Letters (J) then --- 1550,1556 ---- if Start = 0 then File.WC_Method := WCEM_Brackets; ! else if Stop = Start then for J in WC_Encoding_Letters'Range loop if File.Form (Start) = WC_Encoding_Letters (J) then *************** package body Ada.Wide_Text_IO is *** 1841,1849 **** -- a null character in the runtime, here the null characters are added -- just to have a correct filename length. ! Err_Name : aliased String := "*stderr" & ASCII.Nul; ! In_Name : aliased String := "*stdin" & ASCII.Nul; ! Out_Name : aliased String := "*stdout" & ASCII.Nul; begin ------------------------------- --- 1846,1854 ---- -- a null character in the runtime, here the null characters are added -- just to have a correct filename length. ! Err_Name : aliased String := "*stderr" & ASCII.NUL; ! In_Name : aliased String := "*stdin" & ASCII.NUL; ! Out_Name : aliased String := "*stdout" & ASCII.NUL; begin ------------------------------- *************** begin *** 1869,1886 **** Standard_Err.Is_System_File := True; Standard_Err.Is_Text_File := True; Standard_Err.Access_Method := 'T'; Standard_Err.WC_Method := Default_WCEM; ! Standard_In.Stream := stdin; ! Standard_In.Name := In_Name'Access; ! Standard_In.Form := Null_Str'Unrestricted_Access; ! Standard_In.Mode := FCB.In_File; ! Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; ! Standard_In.Is_Temporary_File := False; ! Standard_In.Is_System_File := True; ! Standard_In.Is_Text_File := True; ! Standard_In.Access_Method := 'T'; ! Standard_In.WC_Method := Default_WCEM; Standard_Out.Stream := stdout; Standard_Out.Name := Out_Name'Access; --- 1874,1893 ---- Standard_Err.Is_System_File := True; Standard_Err.Is_Text_File := True; Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; Standard_Err.WC_Method := Default_WCEM; ! Standard_In.Stream := stdin; ! Standard_In.Name := In_Name'Access; ! Standard_In.Form := Null_Str'Unrestricted_Access; ! Standard_In.Mode := FCB.In_File; ! Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; ! Standard_In.Is_Temporary_File := False; ! Standard_In.Is_System_File := True; ! Standard_In.Is_Text_File := True; ! Standard_In.Access_Method := 'T'; ! Standard_In.Self := Standard_In; ! Standard_In.WC_Method := Default_WCEM; Standard_Out.Stream := stdout; Standard_Out.Name := Out_Name'Access; *************** begin *** 1891,1896 **** --- 1898,1904 ---- Standard_Out.Is_System_File := True; Standard_Out.Is_Text_File := True; Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; Standard_Out.WC_Method := Default_WCEM; FIO.Chain_File (AP (Standard_In)); diff -Nrcpad gcc-4.3.3/gcc/ada/a-witeio.ads gcc-4.4.0/gcc/ada/a-witeio.ads *** gcc-4.3.3/gcc/ada/a-witeio.ads Thu Dec 13 10:20:52 2007 --- gcc-4.4.0/gcc/ada/a-witeio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Ada.Wide_Text_IO is *** 138,144 **** -- Buffer control -- -------------------- ! -- Note: The paramter file is in out in the RM, but as pointed out -- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight. procedure Flush (File : File_Type); --- 136,142 ---- -- Buffer control -- -------------------- ! -- Note: The parameter file is in out in the RM, but as pointed out -- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight. procedure Flush (File : File_Type); *************** package Ada.Wide_Text_IO is *** 301,306 **** --- 299,330 ---- Layout_Error : exception renames IO_Exceptions.Layout_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + package WCh_Con renames System.WCh_Con; ----------------------------------- *************** private *** 319,325 **** -- omitted on output unless an explicit New_Page call is made before -- closing the file. No page mark is added when a file is appended to, -- so, in accordance with the permission in (RM A.10.2(4)), there may ! -- or may not be a page mark separating preexising text in the file -- from the new text to be written. -- A file mark is marked by the physical end of file. In DOS translation --- 343,349 ---- -- omitted on output unless an explicit New_Page call is made before -- closing the file. No page mark is added when a file is appended to, -- so, in accordance with the permission in (RM A.10.2(4)), there may ! -- or may not be a page mark separating preexisting text in the file -- from the new text to be written. -- A file mark is marked by the physical end of file. In DOS translation *************** private *** 350,357 **** Line_Length : Count := 0; Page_Length : Count := 0; Before_LM : Boolean := False; ! -- This flag is used to deal with the anomolies introduced by the -- peculiar definition of End_Of_File and End_Of_Page in Ada. These -- functions require looking ahead more than one character. Since -- there is no convenient way of backing up more than one character, --- 374,387 ---- Line_Length : Count := 0; Page_Length : Count := 0; + Self : aliased File_Type; + -- Set to point to the containing Text_AFCB block. This is used to + -- implement the Current_{Error,Input,Output} functions which return + -- a File_Access, the file access value returned is a pointer to + -- the Self field of the corresponding file. + Before_LM : Boolean := False; ! -- This flag is used to deal with the anomalies introduced by the -- peculiar definition of End_Of_File and End_Of_Page in Ada. These -- functions require looking ahead more than one character. Since -- there is no convenient way of backing up more than one character, diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtcoau.adb gcc-4.4.0/gcc/ada/a-wtcoau.adb *** gcc-4.3.3/gcc/ada/a-wtcoau.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-wtcoau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtcoau.ads gcc-4.4.0/gcc/ada/a-wtcoau.ads *** gcc-4.3.3/gcc/ada/a-wtcoau.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-wtcoau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtcoio.adb gcc-4.4.0/gcc/ada/a-wtcoio.adb *** gcc-4.3.3/gcc/ada/a-wtcoio.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtcoio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtcstr.adb gcc-4.4.0/gcc/ada/a-wtcstr.adb *** gcc-4.3.3/gcc/ada/a-wtcstr.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-wtcstr.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtcstr.ads gcc-4.4.0/gcc/ada/a-wtcstr.ads *** gcc-4.3.3/gcc/ada/a-wtcstr.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-wtcstr.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtdeau.adb gcc-4.4.0/gcc/ada/a-wtdeau.adb *** gcc-4.3.3/gcc/ada/a-wtdeau.adb Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-wtdeau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Wide_Text_IO.Decimal_Au *** 203,218 **** Ptr : Natural := 0; begin ! if Exp = 0 then ! Fore := To'Length - 1 - Aft; ! else ! Fore := To'Length - 2 - Aft - Exp; end if; if Fore < 1 then raise Layout_Error; end if; Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); if Ptr > To'Length then --- 201,224 ---- Ptr : Natural := 0; begin ! -- Compute Fore, allowing for Aft digits and the decimal dot ! ! Fore := To'Length - Field'Max (1, Aft) - 1; ! ! -- Allow for Exp and two more for E+ or E- if exponent present ! ! if Exp /= 0 then ! Fore := Fore - 2 - Exp; end if; + -- Make sure we have enough room + if Fore < 1 then raise Layout_Error; end if; + -- Do the conversion and check length of result + Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); if Ptr > To'Length then diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtdeau.ads gcc-4.4.0/gcc/ada/a-wtdeau.ads *** gcc-4.3.3/gcc/ada/a-wtdeau.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-wtdeau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtdeio.adb gcc-4.4.0/gcc/ada/a-wtdeio.adb *** gcc-4.3.3/gcc/ada/a-wtdeio.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtdeio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Wide_Text_IO.Decimal_IO *** 139,148 **** Aft : Field := Default_Aft; Exp : Field := Default_Exp) is - pragma Unreferenced (Fore); - -- ??? how come this is unreferenced, sounds wrong ??? begin ! Put (Current_Output, Item, Aft, Exp); end Put; procedure Put --- 137,144 ---- Aft : Field := Default_Aft; Exp : Field := Default_Exp) is begin ! Put (Current_Output, Item, Fore, Aft, Exp); end Put; procedure Put diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtdeio.ads gcc-4.4.0/gcc/ada/a-wtdeio.ads *** gcc-4.3.3/gcc/ada/a-wtdeio.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtdeio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtedit.adb gcc-4.4.0/gcc/ada/a-wtedit.adb *** gcc-4.3.3/gcc/ada/a-wtedit.adb Tue Aug 14 08:36:48 2007 --- gcc-4.4.0/gcc/ada/a-wtedit.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtedit.ads gcc-4.4.0/gcc/ada/a-wtedit.ads *** gcc-4.3.3/gcc/ada/a-wtedit.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtedit.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtenau.adb gcc-4.4.0/gcc/ada/a-wtenau.adb *** gcc-4.3.3/gcc/ada/a-wtenau.adb Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/a-wtenau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtenau.ads gcc-4.4.0/gcc/ada/a-wtenau.ads *** gcc-4.3.3/gcc/ada/a-wtenau.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtenau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtenio.adb gcc-4.4.0/gcc/ada/a-wtenio.adb *** gcc-4.3.3/gcc/ada/a-wtenio.adb Tue Oct 31 18:21:54 2006 --- gcc-4.4.0/gcc/ada/a-wtenio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtenio.ads gcc-4.4.0/gcc/ada/a-wtenio.ads *** gcc-4.3.3/gcc/ada/a-wtenio.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtenio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtfiio.adb gcc-4.4.0/gcc/ada/a-wtfiio.adb *** gcc-4.3.3/gcc/ada/a-wtfiio.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtfiio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtfiio.ads gcc-4.4.0/gcc/ada/a-wtfiio.ads *** gcc-4.3.3/gcc/ada/a-wtfiio.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtfiio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtflau.adb gcc-4.4.0/gcc/ada/a-wtflau.adb *** gcc-4.3.3/gcc/ada/a-wtflau.adb Wed Jun 6 10:21:54 2007 --- gcc-4.4.0/gcc/ada/a-wtflau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtflau.ads gcc-4.4.0/gcc/ada/a-wtflau.ads *** gcc-4.3.3/gcc/ada/a-wtflau.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtflau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtflio.adb gcc-4.4.0/gcc/ada/a-wtflio.adb *** gcc-4.3.3/gcc/ada/a-wtflio.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtflio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtflio.ads gcc-4.4.0/gcc/ada/a-wtflio.ads *** gcc-4.3.3/gcc/ada/a-wtflio.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtflio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtgeau.adb gcc-4.4.0/gcc/ada/a-wtgeau.adb *** gcc-4.3.3/gcc/ada/a-wtgeau.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-wtgeau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtgeau.ads gcc-4.4.0/gcc/ada/a-wtgeau.ads *** gcc-4.3.3/gcc/ada/a-wtgeau.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtgeau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtinau.adb gcc-4.4.0/gcc/ada/a-wtinau.adb *** gcc-4.3.3/gcc/ada/a-wtinau.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtinau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtinau.ads gcc-4.4.0/gcc/ada/a-wtinau.ads *** gcc-4.3.3/gcc/ada/a-wtinau.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtinau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtinio.adb gcc-4.4.0/gcc/ada/a-wtinio.adb *** gcc-4.3.3/gcc/ada/a-wtinio.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtinio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtmoau.adb gcc-4.4.0/gcc/ada/a-wtmoau.adb *** gcc-4.3.3/gcc/ada/a-wtmoau.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtmoau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtmoau.ads gcc-4.4.0/gcc/ada/a-wtmoau.ads *** gcc-4.3.3/gcc/ada/a-wtmoau.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtmoau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtmoio.adb gcc-4.4.0/gcc/ada/a-wtmoio.adb *** gcc-4.3.3/gcc/ada/a-wtmoio.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtmoio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wtmoio.ads gcc-4.4.0/gcc/ada/a-wtmoio.ads *** gcc-4.3.3/gcc/ada/a-wtmoio.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-wtmoio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wttest.adb gcc-4.4.0/gcc/ada/a-wttest.adb *** gcc-4.3.3/gcc/ada/a-wttest.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-wttest.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-wwboio.adb gcc-4.4.0/gcc/ada/a-wwboio.adb *** gcc-4.3.3/gcc/ada/a-wwboio.adb Wed Feb 15 09:34:21 2006 --- gcc-4.4.0/gcc/ada/a-wwboio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-zchuni.adb gcc-4.4.0/gcc/ada/a-zchuni.adb *** gcc-4.3.3/gcc/ada/a-zchuni.adb Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/a-zchuni.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-zchuni.ads gcc-4.4.0/gcc/ada/a-zchuni.ads *** gcc-4.3.3/gcc/ada/a-zchuni.ads Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/a-zchuni.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztcoau.adb gcc-4.4.0/gcc/ada/a-ztcoau.adb *** gcc-4.3.3/gcc/ada/a-ztcoau.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztcoau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztcoau.ads gcc-4.4.0/gcc/ada/a-ztcoau.ads *** gcc-4.3.3/gcc/ada/a-ztcoau.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztcoau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztcoio.adb gcc-4.4.0/gcc/ada/a-ztcoio.adb *** gcc-4.3.3/gcc/ada/a-ztcoio.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-ztcoio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztcstr.adb gcc-4.4.0/gcc/ada/a-ztcstr.adb *** gcc-4.3.3/gcc/ada/a-ztcstr.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/a-ztcstr.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztcstr.ads gcc-4.4.0/gcc/ada/a-ztcstr.ads *** gcc-4.3.3/gcc/ada/a-ztcstr.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztcstr.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztdeau.adb gcc-4.4.0/gcc/ada/a-ztdeau.adb *** gcc-4.3.3/gcc/ada/a-ztdeau.adb Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-ztdeau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Wide_Wide_Text_IO.Decim *** 203,218 **** Ptr : Natural := 0; begin ! if Exp = 0 then ! Fore := To'Length - 1 - Aft; ! else ! Fore := To'Length - 2 - Aft - Exp; end if; if Fore < 1 then raise Layout_Error; end if; Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); if Ptr > To'Length then --- 201,224 ---- Ptr : Natural := 0; begin ! -- Compute Fore, allowing for Aft digits and the decimal dot ! ! Fore := To'Length - Field'Max (1, Aft) - 1; ! ! -- Allow for Exp and two more for E+ or E- if exponent present ! ! if Exp /= 0 then ! Fore := Fore - 2 - Exp; end if; + -- Make sure we have enough room + if Fore < 1 then raise Layout_Error; end if; + -- Do the conversion and check length of result + Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); if Ptr > To'Length then diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztdeau.ads gcc-4.4.0/gcc/ada/a-ztdeau.ads *** gcc-4.3.3/gcc/ada/a-ztdeau.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/a-ztdeau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztdeio.adb gcc-4.4.0/gcc/ada/a-ztdeio.adb *** gcc-4.3.3/gcc/ada/a-ztdeio.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztdeio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Wide_Wide_Text_IO.Decim *** 139,148 **** Aft : Field := Default_Aft; Exp : Field := Default_Exp) is - pragma Unreferenced (Fore); - -- ??? how come this is unreferenced, sounds wrong ??? begin ! Put (Current_Output, Item, Aft, Exp); end Put; procedure Put --- 137,144 ---- Aft : Field := Default_Aft; Exp : Field := Default_Exp) is begin ! Put (Current_Output, Item, Fore, Aft, Exp); end Put; procedure Put diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztdeio.ads gcc-4.4.0/gcc/ada/a-ztdeio.ads *** gcc-4.3.3/gcc/ada/a-ztdeio.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztdeio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztedit.adb gcc-4.4.0/gcc/ada/a-ztedit.adb *** gcc-4.3.3/gcc/ada/a-ztedit.adb Tue Aug 14 08:36:48 2007 --- gcc-4.4.0/gcc/ada/a-ztedit.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztedit.ads gcc-4.4.0/gcc/ada/a-ztedit.ads *** gcc-4.3.3/gcc/ada/a-ztedit.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-ztedit.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztenau.adb gcc-4.4.0/gcc/ada/a-ztenau.adb *** gcc-4.3.3/gcc/ada/a-ztenau.adb Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/a-ztenau.adb Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X-- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- ADA.WIDE_WIDE_TEXT_IO.ENUMERATION_AUX -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztenau.ads gcc-4.4.0/gcc/ada/a-ztenau.ads *** gcc-4.3.3/gcc/ada/a-ztenau.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/a-ztenau.ads Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X-- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- ADA.WIDE_WIDE_TEXT_IO.ENUMERATION_AUX -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztenio.adb gcc-4.4.0/gcc/ada/a-ztenio.adb *** gcc-4.3.3/gcc/ada/a-ztenio.adb Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/a-ztenio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztenio.ads gcc-4.4.0/gcc/ada/a-ztenio.ads *** gcc-4.3.3/gcc/ada/a-ztenio.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztenio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztexio.adb gcc-4.4.0/gcc/ada/a-ztexio.adb *** gcc-4.3.3/gcc/ada/a-ztexio.adb Thu Dec 13 10:20:52 2007 --- gcc-4.4.0/gcc/ada/a-ztexio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Ada.Wide_Wide_Text_IO is *** 134,140 **** procedure Close (File : in out File_Type) is begin ! FIO.Close (AP (File)); end Close; --------- --- 132,138 ---- procedure Close (File : in out File_Type) is begin ! FIO.Close (AP (File)'Unrestricted_Access); end Close; --------- *************** package body Ada.Wide_Wide_Text_IO is *** 180,185 **** --- 178,185 ---- Amethod => 'W', Creat => True, Text => True); + + File.Self := File; Set_WCEM (File); end Create; *************** package body Ada.Wide_Wide_Text_IO is *** 194,200 **** function Current_Error return File_Access is begin ! return Current_Err'Access; end Current_Error; ------------------- --- 194,200 ---- function Current_Error return File_Access is begin ! return Current_Err.Self'Access; end Current_Error; ------------------- *************** package body Ada.Wide_Wide_Text_IO is *** 208,214 **** function Current_Input return File_Access is begin ! return Current_In'Access; end Current_Input; -------------------- --- 208,214 ---- function Current_Input return File_Access is begin ! return Current_In.Self'Access; end Current_Input; -------------------- *************** package body Ada.Wide_Wide_Text_IO is *** 222,228 **** function Current_Output return File_Access is begin ! return Current_Out'Access; end Current_Output; ------------ --- 222,228 ---- function Current_Output return File_Access is begin ! return Current_Out.Self'Access; end Current_Output; ------------ *************** package body Ada.Wide_Wide_Text_IO is *** 231,237 **** procedure Delete (File : in out File_Type) is begin ! FIO.Delete (AP (File)); end Delete; ----------------- --- 231,237 ---- procedure Delete (File : in out File_Type) is begin ! FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- *************** package body Ada.Wide_Wide_Text_IO is *** 754,759 **** --- 754,760 ---- -- Start of processing for Get_Wide_Wide_Char begin + FIO.Check_Read_Status (AP (File)); return Wide_Wide_Character'Val (WC_In (C, File.WC_Method)); end Get_Wide_Wide_Char; *************** package body Ada.Wide_Wide_Text_IO is *** 788,793 **** --- 789,795 ---- -- Start of processing for Get_Wide_Wide_Char_Immed begin + FIO.Check_Read_Status (AP (File)); return Wide_Wide_Character'Val (WC_In (C, File.WC_Method)); end Get_Wide_Wide_Char_Immed; *************** package body Ada.Wide_Wide_Text_IO is *** 1089,1094 **** --- 1091,1098 ---- Amethod => 'W', Creat => False, Text => True); + + File.Self := File; Set_WCEM (File); end Open; *************** package body Ada.Wide_Wide_Text_IO is *** 1151,1156 **** --- 1155,1161 ---- -- Start of processing for Put begin + FIO.Check_Write_Status (AP (File)); WC_Out (Wide_Wide_Character'Pos (Item), File.WC_Method); File.Col := File.Col + 1; end Put; *************** package body Ada.Wide_Wide_Text_IO is *** 1313,1319 **** end if; Terminate_Line (File); ! FIO.Reset (AP (File), To_FCB (Mode)); File.Page := 1; File.Line := 1; File.Col := 1; --- 1318,1324 ---- end if; Terminate_Line (File); ! FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); File.Page := 1; File.Line := 1; File.Col := 1; *************** package body Ada.Wide_Wide_Text_IO is *** 1326,1332 **** procedure Reset (File : in out File_Type) is begin Terminate_Line (File); ! FIO.Reset (AP (File)); File.Page := 1; File.Line := 1; File.Col := 1; --- 1331,1337 ---- procedure Reset (File : in out File_Type) is begin Terminate_Line (File); ! FIO.Reset (AP (File)'Unrestricted_Access); File.Page := 1; File.Line := 1; File.Col := 1; *************** package body Ada.Wide_Wide_Text_IO is *** 1545,1551 **** if Start = 0 then File.WC_Method := WCEM_Brackets; ! elsif Start /= 0 then if Stop = Start then for J in WC_Encoding_Letters'Range loop if File.Form (Start) = WC_Encoding_Letters (J) then --- 1550,1556 ---- if Start = 0 then File.WC_Method := WCEM_Brackets; ! else if Stop = Start then for J in WC_Encoding_Letters'Range loop if File.Form (Start) = WC_Encoding_Letters (J) then *************** package body Ada.Wide_Wide_Text_IO is *** 1841,1849 **** -- a null character in the runtime, here the null characters are added -- just to have a correct filename length. ! Err_Name : aliased String := "*stderr" & ASCII.Nul; ! In_Name : aliased String := "*stdin" & ASCII.Nul; ! Out_Name : aliased String := "*stdout" & ASCII.Nul; begin ------------------------------- --- 1846,1854 ---- -- a null character in the runtime, here the null characters are added -- just to have a correct filename length. ! Err_Name : aliased String := "*stderr" & ASCII.NUL; ! In_Name : aliased String := "*stdin" & ASCII.NUL; ! Out_Name : aliased String := "*stdout" & ASCII.NUL; begin ------------------------------- *************** begin *** 1869,1886 **** Standard_Err.Is_System_File := True; Standard_Err.Is_Text_File := True; Standard_Err.Access_Method := 'T'; Standard_Err.WC_Method := Default_WCEM; ! Standard_In.Stream := stdin; ! Standard_In.Name := In_Name'Access; ! Standard_In.Form := Null_Str'Unrestricted_Access; ! Standard_In.Mode := FCB.In_File; ! Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; ! Standard_In.Is_Temporary_File := False; ! Standard_In.Is_System_File := True; ! Standard_In.Is_Text_File := True; ! Standard_In.Access_Method := 'T'; ! Standard_In.WC_Method := Default_WCEM; Standard_Out.Stream := stdout; Standard_Out.Name := Out_Name'Access; --- 1874,1893 ---- Standard_Err.Is_System_File := True; Standard_Err.Is_Text_File := True; Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; Standard_Err.WC_Method := Default_WCEM; ! Standard_In.Stream := stdin; ! Standard_In.Name := In_Name'Access; ! Standard_In.Form := Null_Str'Unrestricted_Access; ! Standard_In.Mode := FCB.In_File; ! Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; ! Standard_In.Is_Temporary_File := False; ! Standard_In.Is_System_File := True; ! Standard_In.Is_Text_File := True; ! Standard_In.Access_Method := 'T'; ! Standard_In.Self := Standard_In; ! Standard_In.WC_Method := Default_WCEM; Standard_Out.Stream := stdout; Standard_Out.Name := Out_Name'Access; *************** begin *** 1891,1896 **** --- 1898,1904 ---- Standard_Out.Is_System_File := True; Standard_Out.Is_Text_File := True; Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; Standard_Out.WC_Method := Default_WCEM; FIO.Chain_File (AP (Standard_In)); diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztexio.ads gcc-4.4.0/gcc/ada/a-ztexio.ads *** gcc-4.3.3/gcc/ada/a-ztexio.ads Thu Dec 13 10:20:52 2007 --- gcc-4.4.0/gcc/ada/a-ztexio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Ada.Wide_Wide_Text_IO is *** 138,144 **** -- Buffer control -- -------------------- ! -- Note: The paramter file is in out in the RM, but as pointed out -- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight. procedure Flush (File : File_Type); --- 136,142 ---- -- Buffer control -- -------------------- ! -- Note: The parameter file is in out in the RM, but as pointed out -- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight. procedure Flush (File : File_Type); *************** package Ada.Wide_Wide_Text_IO is *** 301,306 **** --- 299,330 ---- Layout_Error : exception renames IO_Exceptions.Layout_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + package WCh_Con renames System.WCh_Con; ----------------------------------- *************** private *** 319,325 **** -- omitted on output unless an explicit New_Page call is made before -- closing the file. No page mark is added when a file is appended to, -- so, in accordance with the permission in (RM A.10.2(4)), there may ! -- or may not be a page mark separating preexising text in the file -- from the new text to be written. -- A file mark is marked by the physical end of file. In DOS translation --- 343,349 ---- -- omitted on output unless an explicit New_Page call is made before -- closing the file. No page mark is added when a file is appended to, -- so, in accordance with the permission in (RM A.10.2(4)), there may ! -- or may not be a page mark separating preexisting text in the file -- from the new text to be written. -- A file mark is marked by the physical end of file. In DOS translation *************** private *** 350,357 **** Line_Length : Count := 0; Page_Length : Count := 0; Before_LM : Boolean := False; ! -- This flag is used to deal with the anomolies introduced by the -- peculiar definition of End_Of_File and End_Of_Page in Ada. These -- functions require looking ahead more than one character. Since -- there is no convenient way of backing up more than one character, --- 374,387 ---- Line_Length : Count := 0; Page_Length : Count := 0; + Self : aliased File_Type; + -- Set to point to the containing Text_AFCB block. This is used to + -- implement the Current_{Error,Input,Output} functions which return + -- a File_Access, the file access value returned is a pointer to + -- the Self field of the corresponding file. + Before_LM : Boolean := False; ! -- This flag is used to deal with the anomalies introduced by the -- peculiar definition of End_Of_File and End_Of_Page in Ada. These -- functions require looking ahead more than one character. Since -- there is no convenient way of backing up more than one character, diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztfiio.adb gcc-4.4.0/gcc/ada/a-ztfiio.adb *** gcc-4.3.3/gcc/ada/a-ztfiio.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztfiio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztfiio.ads gcc-4.4.0/gcc/ada/a-ztfiio.ads *** gcc-4.3.3/gcc/ada/a-ztfiio.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztfiio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztflau.adb gcc-4.4.0/gcc/ada/a-ztflau.adb *** gcc-4.3.3/gcc/ada/a-ztflau.adb Wed Jun 6 10:21:54 2007 --- gcc-4.4.0/gcc/ada/a-ztflau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztflau.ads gcc-4.4.0/gcc/ada/a-ztflau.ads *** gcc-4.3.3/gcc/ada/a-ztflau.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztflau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztflio.adb gcc-4.4.0/gcc/ada/a-ztflio.adb *** gcc-4.3.3/gcc/ada/a-ztflio.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztflio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztflio.ads gcc-4.4.0/gcc/ada/a-ztflio.ads *** gcc-4.3.3/gcc/ada/a-ztflio.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztflio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztgeau.adb gcc-4.4.0/gcc/ada/a-ztgeau.adb *** gcc-4.3.3/gcc/ada/a-ztgeau.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/a-ztgeau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztgeau.ads gcc-4.4.0/gcc/ada/a-ztgeau.ads *** gcc-4.3.3/gcc/ada/a-ztgeau.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztgeau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztinau.adb gcc-4.4.0/gcc/ada/a-ztinau.adb *** gcc-4.3.3/gcc/ada/a-ztinau.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztinau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztinau.ads gcc-4.4.0/gcc/ada/a-ztinau.ads *** gcc-4.3.3/gcc/ada/a-ztinau.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztinau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 32,41 **** ------------------------------------------------------------------------------ -- This package contains the routines for Ada.Wide_Wide_Text_IO.Integer_IO ! -- that are shared among separate instantiations of this package. The ! -- routines in this package are identical semantically to those in Integer_IO ! -- itself, except that the generic parameter Num has been replaced by Integer ! -- or Long_Long_Integer, and the default parameters have been removed because -- they are supplied explicitly by the calls from within the generic template. private package Ada.Wide_Wide_Text_IO.Integer_Aux is --- 30,39 ---- ------------------------------------------------------------------------------ -- This package contains the routines for Ada.Wide_Wide_Text_IO.Integer_IO ! -- that are shared among separate instantiations of this package. The routines ! -- in this package are identical semantically to those in Integer_IO itself, ! -- except that the generic parameter Num has been replaced by Integer or ! -- Long_Long_Integer, and the default parameters have been removed because -- they are supplied explicitly by the calls from within the generic template. private package Ada.Wide_Wide_Text_IO.Integer_Aux is diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztinio.adb gcc-4.4.0/gcc/ada/a-ztinio.adb *** gcc-4.3.3/gcc/ada/a-ztinio.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztinio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztmoau.adb gcc-4.4.0/gcc/ada/a-ztmoau.adb *** gcc-4.3.3/gcc/ada/a-ztmoau.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/a-ztmoau.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2003 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztmoau.ads gcc-4.4.0/gcc/ada/a-ztmoau.ads *** gcc-4.3.3/gcc/ada/a-ztmoau.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztmoau.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztmoio.adb gcc-4.4.0/gcc/ada/a-ztmoio.adb *** gcc-4.3.3/gcc/ada/a-ztmoio.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztmoio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-ztmoio.ads gcc-4.4.0/gcc/ada/a-ztmoio.ads *** gcc-4.3.3/gcc/ada/a-ztmoio.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-ztmoio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-zttest.adb gcc-4.4.0/gcc/ada/a-zttest.adb *** gcc-4.3.3/gcc/ada/a-zttest.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/a-zttest.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/a-zzboio.adb gcc-4.4.0/gcc/ada/a-zzboio.adb *** gcc-4.3.3/gcc/ada/a-zzboio.adb Wed Feb 15 09:34:21 2006 --- gcc-4.4.0/gcc/ada/a-zzboio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/ada-tree.def gcc-4.4.0/gcc/ada/ada-tree.def *** gcc-4.3.3/gcc/ada/ada-tree.def Mon Sep 3 10:06:52 2007 --- gcc-4.4.0/gcc/ada/ada-tree.def Thu Jan 1 00:00:00 1970 *************** *** 1,81 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * GNAT-SPECIFIC GCC TREE CODES * - * * - * Specification * - * * - * Copyright (C) 1992-2004, 2007 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- * - * ware Foundation; either version 3, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License along with GCC; see the file COPYING3. If not see * - * . * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - /* A type that is an unconstrained array itself. This node is never passed - to GCC. TREE_TYPE is the type of the fat pointer and TYPE_OBJECT_RECORD_TYPE - is the type of a record containing the template and data. */ - - DEFTREECODE (UNCONSTRAINED_ARRAY_TYPE, "unconstrained_array_type", tcc_type, 0) - - /* A reference to an unconstrained array. This node only exists as an - intermediate node during the translation of a GNAT tree to a GCC tree; - it is never passed to GCC. The only field used is operand 0, which - is the fat pointer object. */ - - DEFTREECODE (UNCONSTRAINED_ARRAY_REF, "unconstrained_array_ref", - tcc_reference, 1) - - /* An expression that returns an RTL suitable for its type. Operand 0 - is an expression to be evaluated for side effects only. */ - DEFTREECODE (NULL_EXPR, "null_expr", tcc_expression, 1) - - /* Same as ADDR_EXPR, except that if the operand represents a bit field, - return the address of the byte containing the bit. This is used - for the 'Address attribute and never shows up in the tree. */ - DEFTREECODE (ATTR_ADDR_EXPR, "attr_addr_expr", tcc_reference, 1) - - /* Here are the tree codes for the statement types known to Ada. These - must be at the end of this file to allow IS_ADA_STMT to work. */ - - /* This is how record_code_position and insert_code_for work. The former - makes this tree node, whose operand is a statement. The latter inserts - the actual statements into this node. Gimplification consists of - just returning the inner statement. */ - DEFTREECODE (STMT_STMT, "stmt_stmt", tcc_statement, 1) - - /* A loop. LOOP_STMT_TOP_COND and LOOP_STMT_BOT_COND are the tests to exit a - loop at the top and bottom, respectively. LOOP_STMT_UPDATE is the statement - to update the loop iterator at the continue point. LOOP_STMT_BODY are the - statements in the body of the loop. LOOP_STMT_LABEL points to the LABEL_DECL - of the end label of the loop. */ - DEFTREECODE (LOOP_STMT, "loop_stmt", tcc_statement, 5) - - /* Conditionally exit a loop. EXIT_STMT_COND is the condition, which, if - true, will cause the loop to be exited. If no condition is specified, - the loop is unconditionally exited. EXIT_STMT_LABEL is the end label - corresponding to the loop to exit. */ - DEFTREECODE (EXIT_STMT, "exit_stmt", tcc_statement, 2) - - /* A exception region. REGION_STMT_BODY is the statement to be executed - inside the region. REGION_STMT_HANDLE is a statement that represents - the exception handlers (usually a BLOCK_STMT of HANDLE_STMTs). - REGION_STMT_BLOCK is the BLOCK node for the declarative region, if any. */ - DEFTREECODE (REGION_STMT, "region_stmt", tcc_statement, 3) - - /* An exception handler. HANDLER_STMT_ARG is the value to pass to - expand_start_catch, HANDLER_STMT_LIST is the list of statements for the - handler itself, and HANDLER_STMT_BLOCK is the BLOCK node for this - binding. */ - DEFTREECODE (HANDLER_STMT, "handler_stmt", tcc_statement, 3) --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/ada-tree.h gcc-4.4.0/gcc/ada/ada-tree.h *** gcc-4.3.3/gcc/ada/ada-tree.h Mon Dec 10 23:15:17 2007 --- gcc-4.4.0/gcc/ada/ada-tree.h Thu Jan 1 00:00:00 1970 *************** *** 1,323 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * A D A - T R E E * - * * - * C Header File * - * * - * Copyright (C) 1992-2007, 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- * - * ware Foundation; either version 3, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License along with GCC; see the file COPYING3. If not see * - * . * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - /* Ada language-specific GC tree codes. */ - #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) SYM, - enum gnat_tree_code { - __DUMMY = LAST_AND_UNUSED_TREE_CODE, - #include "ada-tree.def" - LAST_GNAT_TREE_CODE - }; - #undef DEFTREECODE - - /* Ada uses the lang_decl and lang_type fields to hold a tree. */ - union lang_tree_node - GTY((desc ("0"), - chain_next ("(union lang_tree_node *)GENERIC_NEXT (&%h.t)"))) - { - union tree_node GTY((tag ("0"))) t; - }; - struct lang_decl GTY(()) {tree t; }; - struct lang_type GTY(()) {tree t; }; - - /* Define macros to get and set the tree in TYPE_ and DECL_LANG_SPECIFIC. */ - #define GET_TYPE_LANG_SPECIFIC(NODE) \ - (TYPE_LANG_SPECIFIC (NODE) ? TYPE_LANG_SPECIFIC (NODE)->t : NULL_TREE) - #define SET_TYPE_LANG_SPECIFIC(NODE, X) \ - (TYPE_LANG_SPECIFIC (NODE) \ - = (TYPE_LANG_SPECIFIC (NODE) \ - ? TYPE_LANG_SPECIFIC (NODE) : ggc_alloc (sizeof (struct lang_type)))) \ - ->t = X; - - #define GET_DECL_LANG_SPECIFIC(NODE) \ - (DECL_LANG_SPECIFIC (NODE) ? DECL_LANG_SPECIFIC (NODE)->t : NULL_TREE) - #define SET_DECL_LANG_SPECIFIC(NODE, VALUE) \ - (DECL_LANG_SPECIFIC (NODE) \ - = (DECL_LANG_SPECIFIC (NODE) \ - ? DECL_LANG_SPECIFIC (NODE) : ggc_alloc (sizeof (struct lang_decl)))) \ - ->t = VALUE; - - /* Flags added to GCC type nodes. */ - - /* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is a - record being used as a fat pointer (only true for RECORD_TYPE). */ - #define TYPE_IS_FAT_POINTER_P(NODE) \ - TYPE_LANG_FLAG_0 (RECORD_OR_UNION_CHECK (NODE)) - - #define TYPE_FAT_POINTER_P(NODE) \ - (TREE_CODE (NODE) == RECORD_TYPE && TYPE_IS_FAT_POINTER_P (NODE)) - - /* For integral types and array types, nonzero if this is a packed array type. - Such types should not be extended to a larger size. */ - #define TYPE_PACKED_ARRAY_TYPE_P(NODE) TYPE_LANG_FLAG_0 (NODE) - - #define TYPE_IS_PACKED_ARRAY_TYPE_P(NODE) \ - ((TREE_CODE (NODE) == INTEGER_TYPE || TREE_CODE (NODE) == ARRAY_TYPE) \ - && TYPE_PACKED_ARRAY_TYPE_P (NODE)) - - /* For INTEGER_TYPE, nonzero if this is a modular type with a modulus that - is not equal to two to the power of its mode's size. */ - #define TYPE_MODULAR_P(NODE) TYPE_LANG_FLAG_1 (INTEGER_TYPE_CHECK (NODE)) - - /* For ARRAY_TYPE, nonzero if this type corresponds to a dimension of - an Ada array other than the first. */ - #define TYPE_MULTI_ARRAY_P(NODE) TYPE_LANG_FLAG_1 (ARRAY_TYPE_CHECK (NODE)) - - /* For FUNCTION_TYPE, nonzero if this denotes a function returning an - unconstrained array or record. */ - #define TYPE_RETURNS_UNCONSTRAINED_P(NODE) \ - TYPE_LANG_FLAG_1 (FUNCTION_TYPE_CHECK (NODE)) - - /* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this denotes - a justified modular type (will only be true for RECORD_TYPE). */ - #define TYPE_JUSTIFIED_MODULAR_P(NODE) \ - TYPE_LANG_FLAG_1 (RECORD_OR_UNION_CHECK (NODE)) - - /* Nonzero in an arithmetic subtype if this is a subtype not known to the - front-end. */ - #define TYPE_EXTRA_SUBTYPE_P(NODE) TYPE_LANG_FLAG_2 (NODE) - - /* Nonzero for composite types if this is a by-reference type. */ - #define TYPE_BY_REFERENCE_P(NODE) TYPE_LANG_FLAG_2 (NODE) - - /* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is the - type for an object whose type includes its template in addition to - its value (only true for RECORD_TYPE). */ - #define TYPE_CONTAINS_TEMPLATE_P(NODE) \ - TYPE_LANG_FLAG_3 (RECORD_OR_UNION_CHECK (NODE)) - - /* For INTEGER_TYPE, nonzero if this really represents a VAX - floating-point type. */ - #define TYPE_VAX_FLOATING_POINT_P(NODE) \ - TYPE_LANG_FLAG_3 (INTEGER_TYPE_CHECK (NODE)) - - /* True if NODE is a thin pointer. */ - #define TYPE_THIN_POINTER_P(NODE) \ - (POINTER_TYPE_P (NODE) \ - && TREE_CODE (TREE_TYPE (NODE)) == RECORD_TYPE \ - && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (NODE))) - - /* True if TYPE is either a fat or thin pointer to an unconstrained - array. */ - #define TYPE_FAT_OR_THIN_POINTER_P(NODE) \ - (TYPE_FAT_POINTER_P (NODE) || TYPE_THIN_POINTER_P (NODE)) - - /* For INTEGER_TYPEs, nonzero if the type has a biased representation. */ - #define TYPE_BIASED_REPRESENTATION_P(NODE) \ - TYPE_LANG_FLAG_4 (INTEGER_TYPE_CHECK (NODE)) - - /* For ARRAY_TYPEs, nonzero if the array type has Convention_Fortran. */ - #define TYPE_CONVENTION_FORTRAN_P(NODE) \ - TYPE_LANG_FLAG_4 (ARRAY_TYPE_CHECK (NODE)) - - /* For FUNCTION_TYPEs, nonzero if the function returns by reference. */ - #define TYPE_RETURNS_BY_REF_P(NODE) \ - TYPE_LANG_FLAG_4 (FUNCTION_TYPE_CHECK (NODE)) - - /* For VOID_TYPE, ENUMERAL_TYPE, UNION_TYPE, and RECORD_TYPE, nonzero if this - is a dummy type, made to correspond to a private or incomplete type. */ - #define TYPE_DUMMY_P(NODE) TYPE_LANG_FLAG_4 (NODE) - - /* True if TYPE is such a dummy type. */ - #define TYPE_IS_DUMMY_P(NODE) \ - ((TREE_CODE (NODE) == VOID_TYPE || TREE_CODE (NODE) == RECORD_TYPE \ - || TREE_CODE (NODE) == UNION_TYPE || TREE_CODE (NODE) == ENUMERAL_TYPE) \ - && TYPE_DUMMY_P (NODE)) - - /* For FUNCTION_TYPEs, nonzero if function returns by being passed a pointer - to a place to store its result. */ - #define TYPE_RETURNS_BY_TARGET_PTR_P(NODE) \ - TYPE_LANG_FLAG_5 (FUNCTION_TYPE_CHECK (NODE)) - - /* For an INTEGER_TYPE, nonzero if TYPE_ACTUAL_BOUNDS is present. */ - #define TYPE_HAS_ACTUAL_BOUNDS_P(NODE) \ - TYPE_LANG_FLAG_5 (INTEGER_TYPE_CHECK (NODE)) - - /* For a RECORD_TYPE, nonzero if this was made just to supply needed - padding or alignment. */ - #define TYPE_IS_PADDING_P(NODE) TYPE_LANG_FLAG_5 (RECORD_TYPE_CHECK (NODE)) - - /* True if TYPE can alias any other types. */ - #define TYPE_UNIVERSAL_ALIASING_P(NODE) TYPE_LANG_FLAG_6 (NODE) - - /* This field is only defined for FUNCTION_TYPE nodes. If the Ada - subprogram contains no parameters passed by copy in/copy out then this - field is 0. Otherwise it points to a list of nodes used to specify the - return values of the out (or in out) parameters that qualify to be passed - by copy in copy out. It is a CONSTRUCTOR. For a full description of the - cico parameter passing mechanism refer to the routine gnat_to_gnu_entity. */ - #define TYPE_CI_CO_LIST(NODE) TYPE_LANG_SLOT_1 (FUNCTION_TYPE_CHECK (NODE)) - - /* For an INTEGER_TYPE with TYPE_MODULAR_P, this is the value of the - modulus. */ - #define TYPE_MODULUS(NODE) GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) - #define SET_TYPE_MODULUS(NODE, X) \ - SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X) - - /* For an INTEGER_TYPE that is the TYPE_DOMAIN of some ARRAY_TYPE, points to - the type corresponding to the Ada index type. */ - #define TYPE_INDEX_TYPE(NODE) \ - GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) - #define SET_TYPE_INDEX_TYPE(NODE, X) \ - SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X) - - /* For an INTEGER_TYPE with TYPE_VAX_FLOATING_POINT_P, stores the - Digits_Value. */ - #define TYPE_DIGITS_VALUE(NODE) \ - GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) - #define SET_TYPE_DIGITS_VALUE(NODE, X) \ - SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X) - - /* For numeric types, stores the RM_Size of the type. */ - #define TYPE_RM_SIZE_NUM(NODE) TYPE_LANG_SLOT_1 (NUMERICAL_TYPE_CHECK (NODE)) - - #define TYPE_RM_SIZE(NODE) \ - (INTEGRAL_TYPE_P (NODE) || TREE_CODE (NODE) == REAL_TYPE \ - ? TYPE_RM_SIZE_NUM (NODE) : 0) - - /* For a RECORD_TYPE that is a fat pointer, point to the type for the - unconstrained object. Likewise for a RECORD_TYPE that is pointed - to by a thin pointer. */ - #define TYPE_UNCONSTRAINED_ARRAY(NODE) \ - GET_TYPE_LANG_SPECIFIC (RECORD_TYPE_CHECK (NODE)) - #define SET_TYPE_UNCONSTRAINED_ARRAY(NODE, X) \ - SET_TYPE_LANG_SPECIFIC (RECORD_TYPE_CHECK (NODE), X) - - /* For other RECORD_TYPEs and all UNION_TYPEs and QUAL_UNION_TYPEs, the Ada - size of the object. This differs from the GCC size in that it does not - include any rounding up to the alignment of the type. */ - #define TYPE_ADA_SIZE(NODE) \ - GET_TYPE_LANG_SPECIFIC (RECORD_OR_UNION_CHECK (NODE)) - #define SET_TYPE_ADA_SIZE(NODE, X) \ - SET_TYPE_LANG_SPECIFIC (RECORD_OR_UNION_CHECK (NODE), X) - - /* For an INTEGER_TYPE with TYPE_HAS_ACTUAL_BOUNDS_P or an ARRAY_TYPE, this is - the index type that should be used when the actual bounds are required for - a template. This is used in the case of packed arrays. */ - #define TYPE_ACTUAL_BOUNDS(NODE) \ - GET_TYPE_LANG_SPECIFIC (TREE_CHECK2 (NODE, INTEGER_TYPE, ARRAY_TYPE)) - #define SET_TYPE_ACTUAL_BOUNDS(NODE, X) \ - SET_TYPE_LANG_SPECIFIC (TREE_CHECK2 (NODE, INTEGER_TYPE, ARRAY_TYPE), X) - - /* In an UNCONSTRAINED_ARRAY_TYPE, points to the record containing both - the template and object. - - ??? We also put this on an ENUMERAL_TYPE that's dummy. Technically, - this is a conflict on the minval field, but there doesn't seem to be - simple fix, so we'll live with this kludge for now. */ - #define TYPE_OBJECT_RECORD_TYPE(NODE) \ - (TREE_CHECK2 ((NODE), UNCONSTRAINED_ARRAY_TYPE, ENUMERAL_TYPE)->type.minval) - - /* Nonzero in a FUNCTION_DECL that represents a stubbed function - discriminant. */ - #define DECL_STUBBED_P(NODE) DECL_LANG_FLAG_0 (FUNCTION_DECL_CHECK (NODE)) - - /* Nonzero in a VAR_DECL if it is guaranteed to be constant after having - been elaborated and TREE_READONLY is not set on it. */ - #define DECL_READONLY_ONCE_ELAB(NODE) DECL_LANG_FLAG_0 (VAR_DECL_CHECK (NODE)) - - /* Nonzero if this decl is always used by reference; i.e., an INDIRECT_REF - is needed to access the object. */ - #define DECL_BY_REF_P(NODE) DECL_LANG_FLAG_1 (NODE) - - /* Nonzero if this decl is a PARM_DECL for an Ada array being passed to a - foreign convention subprogram. */ - #define DECL_BY_COMPONENT_PTR_P(NODE) DECL_LANG_FLAG_2 (PARM_DECL_CHECK (NODE)) - - /* Nonzero in a FIELD_DECL that is a dummy built for some internal reason. */ - #define DECL_INTERNAL_P(NODE) DECL_LANG_FLAG_3 (FIELD_DECL_CHECK (NODE)) - - /* Nonzero in a FUNCTION_DECL that corresponds to an elaboration procedure. */ - #define DECL_ELABORATION_PROC_P(NODE) \ - DECL_LANG_FLAG_3 (FUNCTION_DECL_CHECK (NODE)) - - /* Nonzero if this is a decl for a pointer that points to something which - is readonly. Used mostly for fat pointers. */ - #define DECL_POINTS_TO_READONLY_P(NODE) DECL_LANG_FLAG_4 (NODE) - - /* Nonzero in a FIELD_DECL if there was a record rep clause. */ - #define DECL_HAS_REP_P(NODE) DECL_LANG_FLAG_5 (FIELD_DECL_CHECK (NODE)) - - /* Nonzero in a PARM_DECL if we are to pass by descriptor. */ - #define DECL_BY_DESCRIPTOR_P(NODE) DECL_LANG_FLAG_5 (PARM_DECL_CHECK (NODE)) - - /* Nonzero in a VAR_DECL if it is a pointer renaming a global object. */ - #define DECL_RENAMING_GLOBAL_P(NODE) DECL_LANG_FLAG_5 (VAR_DECL_CHECK (NODE)) - - /* In a CONST_DECL, points to a VAR_DECL that is allocatable to - memory. Used when a scalar constant is aliased or has its - address taken. */ - #define DECL_CONST_CORRESPONDING_VAR(NODE) \ - GET_DECL_LANG_SPECIFIC (CONST_DECL_CHECK (NODE)) - #define SET_DECL_CONST_CORRESPONDING_VAR(NODE, X) \ - SET_DECL_LANG_SPECIFIC (CONST_DECL_CHECK (NODE), X) - - /* In a FIELD_DECL, points to the FIELD_DECL that was the ultimate - source of the decl. */ - #define DECL_ORIGINAL_FIELD(NODE) \ - GET_DECL_LANG_SPECIFIC (FIELD_DECL_CHECK (NODE)) - #define SET_DECL_ORIGINAL_FIELD(NODE, X) \ - SET_DECL_LANG_SPECIFIC (FIELD_DECL_CHECK (NODE), X) - - /* In a VAR_DECL, points to the object being renamed if the VAR_DECL is a - renaming pointer, otherwise 0. Note that this object is guaranteed to - be protected against multiple evaluations. */ - #define DECL_RENAMED_OBJECT(NODE) \ - GET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE)) - #define SET_DECL_RENAMED_OBJECT(NODE, X) \ - SET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE), X) - - /* In a FUNCTION_DECL, points to the stub associated with the function - if any, otherwise 0. */ - #define DECL_FUNCTION_STUB(NODE) \ - GET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE)) - #define SET_DECL_FUNCTION_STUB(NODE, X) \ - SET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE), X) - - /* In a FIELD_DECL corresponding to a discriminant, contains the - discriminant number. */ - #define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE)) - - /* Define fields and macros for statements. - - Start by defining which tree codes are used for statements. */ - #define IS_STMT(NODE) (STATEMENT_CLASS_P (NODE)) - #define IS_ADA_STMT(NODE) (IS_STMT (NODE) \ - && TREE_CODE (NODE) >= STMT_STMT) - - #define STMT_STMT_STMT(NODE) TREE_OPERAND_CHECK_CODE (NODE, STMT_STMT, 0) - #define LOOP_STMT_TOP_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 0) - #define LOOP_STMT_BOT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 1) - #define LOOP_STMT_UPDATE(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 2) - #define LOOP_STMT_BODY(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 3) - #define LOOP_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 4) - #define EXIT_STMT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 0) - #define EXIT_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 1) - #define REGION_STMT_BODY(NODE) TREE_OPERAND_CHECK_CODE (NODE, REGION_STMT, 0) - #define REGION_STMT_HANDLE(NODE) TREE_OPERAND_CHECK_CODE (NODE, REGION_STMT, 1) - #define REGION_STMT_BLOCK(NODE) TREE_OPERAND_CHECK_CODE (NODE, REGION_STMT, 2) - #define HANDLER_STMT_ARG(NODE) TREE_OPERAND_CHECK_CODE (NODE, HANDLER_STMT, 0) - #define HANDLER_STMT_LIST(NODE) TREE_OPERAND_CHECK_CODE (NODE, HANDLER_STMT, 1) - #define HANDLER_STMT_BLOCK(NODE) TREE_OPERAND_CHECK_CODE(NODE, HANDLER_STMT, 2) --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/ada.h gcc-4.4.0/gcc/ada/ada.h *** gcc-4.3.3/gcc/ada/ada.h Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/ada.h Thu Jan 1 00:00:00 1970 *************** *** 1,80 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * A D A * - * * - * C Header File * - * * - * Copyright (C) 1992-2003 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- * - * ware Foundation; either version 2, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License distributed with GNAT; see file COPYING. If not, write * - * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * - * Boston, MA 02110-1301, USA. * - * * - * As a special exception, if you link this file with other files to * - * produce an executable, this file does not by itself cause the resulting * - * executable to be covered by the GNU General Public License. This except- * - * ion does not however invalidate any other reasons why the executable * - * file might be covered by the GNU Public License. * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - /* This file contains some standard macros for performing Ada-like - operations. These are used to aid in the translation of other headers. */ - - #ifndef GCC_ADA_H - #define GCC_ADA_H - - /* Inlined functions in header are preceded by INLINE, which is normally set - to extern inline for GCC, but may be set to static for use in standard - ANSI-C. */ - - #ifndef INLINE - #ifdef __GNUC__ - #define INLINE static inline - #else - #define INLINE static - #endif - #endif - - /* Define a macro to concatenate two strings. Write it for ANSI C and - for traditional C. */ - - #ifdef __STDC__ - #define CAT(A,B) A##B - #else - #define _ECHO(A) A - #define CAT(A,B) ECHO(A)B - #endif - - /* The following macro definition simulates the effect of a declaration of - a subtype, where the first two parameters give the name of the type and - subtype, and the third and fourth parameters give the subtype range. The - effect is to compile a typedef defining the subtype as a synonym for the - type, together with two constants defining the end points. */ - - #define SUBTYPE(SUBTYPE,TYPE,FIRST,LAST) \ - typedef TYPE SUBTYPE; \ - enum { CAT (SUBTYPE,__First) = FIRST, \ - CAT (SUBTYPE,__Last) = LAST }; - - /* The following definitions provide the equivalent of the Ada IN and NOT IN - operators, assuming that the subtype involved has been defined using the - SUBTYPE macro defined above. */ - - #define IN(VALUE,SUBTYPE) \ - (((VALUE) >= (SUBTYPE) CAT (SUBTYPE,__First)) \ - && ((VALUE) <= (SUBTYPE) CAT (SUBTYPE,__Last))) - - #endif --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/adadecode.c gcc-4.4.0/gcc/ada/adadecode.c *** gcc-4.3.3/gcc/ada/adadecode.c Wed Feb 15 09:30:24 2006 --- gcc-4.4.0/gcc/ada/adadecode.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 2001-2006, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 2001-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * diff -Nrcpad gcc-4.3.3/gcc/ada/adadecode.h gcc-4.4.0/gcc/ada/adadecode.h *** gcc-4.3.3/gcc/ada/adadecode.h Wed Feb 15 09:30:24 2006 --- gcc-4.4.0/gcc/ada/adadecode.h Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Header File * * * ! * Copyright (C) 2001-2006, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Header File * * * ! * Copyright (C) 2001-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * diff -Nrcpad gcc-4.3.3/gcc/ada/adaint.c gcc-4.4.0/gcc/ada/adaint.c *** gcc-4.3.3/gcc/ada/adaint.c Thu Jan 3 09:35:04 2008 --- gcc-4.4.0/gcc/ada/adaint.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** *** 85,91 **** --- 84,98 ---- #include "mingw32.h" #include + + /* For isalpha-like tests in the compiler, we're expected to resort to + safe-ctype.h/ISALPHA. This isn't available for the runtime library + build, so we fallback on ctype.h/isalpha there. */ + + #ifdef IN_RTS #include + #define ISALPHA isalpha + #endif #elif defined (__Lynx__) *************** struct vstring *** 179,184 **** --- 186,193 ---- #if defined (_WIN32) #include #include + #include + #include #undef DIR_SEPARATOR #define DIR_SEPARATOR '\\' #endif *************** __gnat_current_time *** 359,364 **** --- 368,397 ---- return (OS_Time) res; } + /* Return the current local time as a string in the ISO 8601 format of + "YYYY-MM-DD HH:MM:SS.SS". The returned string is 22 + 1 (NULL) characters + long. */ + + void + __gnat_current_time_string + (char *result) + { + const char *format = "%Y-%m-%d %H:%M:%S"; + /* Format string necessary to describe the ISO 8601 format */ + + const time_t t_val = time (NULL); + + strftime (result, 22, format, localtime (&t_val)); + /* Convert the local time into a string following the ISO format, copying + at most 22 characters into the result string. */ + + result [19] = '.'; + result [20] = '0'; + result [21] = '0'; + /* The sub-seconds are manually set to zero since type time_t lacks the + precision necessary for nanoseconds. */ + } + void __gnat_to_gm_time (OS_Time *p_time, *************** __gnat_symlink (char *oldpath ATTRIBUTE_ *** 434,440 **** /* Try to lock a file, return 1 if success. */ ! #if defined (__vxworks) || defined (__nucleus__) || defined (MSDOS) || defined (_WIN32) /* Version that does not use link. */ --- 467,474 ---- /* Try to lock a file, return 1 if success. */ ! #if defined (__vxworks) || defined (__nucleus__) || defined (MSDOS) \ ! || defined (_WIN32) /* Version that does not use link. */ *************** __gnat_get_debuggable_suffix_ptr (int *l *** 643,651 **** /* Returns the OS filename and corresponding encoding. */ void ! __gnat_os_filename (char *filename, char *w_filename, char *os_name, int *o_length, ! char *encoding, int *e_length) { #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE) WS2SU (os_name, (TCHAR *)w_filename, o_length); --- 677,685 ---- /* Returns the OS filename and corresponding encoding. */ void ! __gnat_os_filename (char *filename, char *w_filename ATTRIBUTE_UNUSED, char *os_name, int *o_length, ! char *encoding ATTRIBUTE_UNUSED, int *e_length) { #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE) WS2SU (os_name, (TCHAR *)w_filename, o_length); *************** __gnat_os_filename (char *filename, char *** 660,666 **** } FILE * ! __gnat_fopen (char *path, char *mode, int encoding) { #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE) TCHAR wpath[GNAT_MAX_PATH_LEN]; --- 694,700 ---- } FILE * ! __gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED) { #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE) TCHAR wpath[GNAT_MAX_PATH_LEN]; *************** __gnat_fopen (char *path, char *mode, in *** 682,688 **** } FILE * ! __gnat_freopen (char *path, char *mode, FILE *stream, int encoding) { #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE) TCHAR wpath[GNAT_MAX_PATH_LEN]; --- 716,722 ---- } FILE * ! __gnat_freopen (char *path, char *mode, FILE *stream, int encoding ATTRIBUTE_UNUSED) { #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE) TCHAR wpath[GNAT_MAX_PATH_LEN]; *************** __gnat_open_new_temp (char *path, int fm *** 888,894 **** strcpy (path, "GNAT-XXXXXX"); #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \ ! || defined (linux)) && !defined (__vxworks) return mkstemp (path); #elif defined (__Lynx__) mktemp (path); --- 922,928 ---- strcpy (path, "GNAT-XXXXXX"); #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \ ! || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks) return mkstemp (path); #elif defined (__Lynx__) mktemp (path); *************** __gnat_named_file_length (char *name) *** 949,955 **** void __gnat_tmp_name (char *tmp_filename) { ! #ifdef __MINGW32__ { char *pname; --- 983,997 ---- void __gnat_tmp_name (char *tmp_filename) { ! #ifdef RTX ! /* Variable used to create a series of unique names */ ! static int counter = 0; ! ! /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */ ! strcpy (tmp_filename, "c:\\WINDOWS\\Temp\\gnat-"); ! sprintf (&tmp_filename[strlen (tmp_filename)], "%d\0", counter++); ! ! #elif defined (__MINGW32__) { char *pname; *************** __gnat_tmp_name (char *tmp_filename) *** 981,987 **** } #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \ ! || defined (__OpenBSD__) #define MAX_SAFE_PATH 1000 char *tmpdir = getenv ("TMPDIR"); --- 1023,1029 ---- } #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \ ! || defined (__OpenBSD__) || defined(__GLIBC__) #define MAX_SAFE_PATH 1000 char *tmpdir = getenv ("TMPDIR"); *************** __gnat_readdir (DIR *dirp, char *buffer, *** 1028,1033 **** --- 1070,1076 ---- /* Not supported in RTX */ return NULL; + #elif defined (__MINGW32__) struct _tdirent *dirent = _treaddir ((_TDIR*)dirp); *************** __gnat_set_file_time_name (char *name, t *** 1470,1479 **** #endif } - #ifdef _WIN32 - #include - #endif - /* Get the list of installed standard libraries from the HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries key. */ --- 1513,1518 ---- *************** __gnat_stat (char *name, struct stat *st *** 1573,1579 **** int __gnat_file_exists (char *name) { ! #if defined (__MINGW32__) && !defined (RTX) /* On Windows do not use __gnat_stat() because a bug in Microsoft _stat() routine. When the system time-zone is set with a negative offset the _stat() routine fails on specific files like CON: */ --- 1612,1618 ---- int __gnat_file_exists (char *name) { ! #ifdef __MINGW32__ /* On Windows do not use __gnat_stat() because a bug in Microsoft _stat() routine. When the system time-zone is set with a negative offset the _stat() routine fails on specific files like CON: */ *************** __gnat_is_absolute_path (char *name, int *** 1617,1623 **** return (length != 0) && (*name == '/' || *name == DIR_SEPARATOR #if defined (__EMX__) || defined (MSDOS) || defined (WINNT) ! || (length > 1 && isalpha (name[0]) && name[1] == ':') #endif ); #endif --- 1656,1662 ---- return (length != 0) && (*name == '/' || *name == DIR_SEPARATOR #if defined (__EMX__) || defined (MSDOS) || defined (WINNT) ! || (length > 1 && ISALPHA (name[0]) && name[1] == ':') #endif ); #endif *************** __gnat_is_directory (char *name) *** 1643,1711 **** return (!ret && S_ISDIR (statbuf.st_mode)); } int __gnat_is_readable_file (char *name) { int ret; int mode; struct stat statbuf; ! ret = __gnat_stat (name, &statbuf); mode = statbuf.st_mode & S_IRUSR; return (!ret && mode); } int __gnat_is_writable_file (char *name) { int ret; int mode; struct stat statbuf; ! ret = __gnat_stat (name, &statbuf); mode = statbuf.st_mode & S_IWUSR; return (!ret && mode); } void __gnat_set_writable (char *name) { ! #if ! defined (__vxworks) && ! defined(__nucleus__) struct stat statbuf; if (stat (name, &statbuf) == 0) ! { ! statbuf.st_mode = statbuf.st_mode | S_IWUSR; ! chmod (name, statbuf.st_mode); ! } #endif } void __gnat_set_executable (char *name) { ! #if ! defined (__vxworks) && ! defined(__nucleus__) struct stat statbuf; if (stat (name, &statbuf) == 0) ! { ! statbuf.st_mode = statbuf.st_mode | S_IXUSR; ! chmod (name, statbuf.st_mode); ! } #endif } void ! __gnat_set_readonly (char *name) { ! #if ! defined (__vxworks) && ! defined(__nucleus__) struct stat statbuf; if (stat (name, &statbuf) == 0) ! { ! statbuf.st_mode = statbuf.st_mode & 07577; ! chmod (name, statbuf.st_mode); ! } #endif } --- 1682,1976 ---- return (!ret && S_ISDIR (statbuf.st_mode)); } + #if defined (_WIN32) && !defined (RTX) + /* This MingW section contains code to work with ACL. */ + static int + __gnat_check_OWNER_ACL + (TCHAR *wname, + DWORD CheckAccessDesired, + GENERIC_MAPPING CheckGenericMapping) + { + DWORD dwAccessDesired, dwAccessAllowed; + PRIVILEGE_SET PrivilegeSet; + DWORD dwPrivSetSize = sizeof (PRIVILEGE_SET); + BOOL fAccessGranted = FALSE; + HANDLE hToken; + DWORD nLength; + SECURITY_DESCRIPTOR* pSD = NULL; + + GetFileSecurity + (wname, OWNER_SECURITY_INFORMATION | + GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION, + NULL, 0, &nLength); + + if ((pSD = (PSECURITY_DESCRIPTOR) HeapAlloc + (GetProcessHeap (), HEAP_ZERO_MEMORY, nLength)) == NULL) + return 0; + + /* Obtain the security descriptor. */ + + if (!GetFileSecurity + (wname, OWNER_SECURITY_INFORMATION | + GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION, + pSD, nLength, &nLength)) + return 0; + + if (!ImpersonateSelf (SecurityImpersonation)) + return 0; + + if (!OpenThreadToken + (GetCurrentThread(), TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken)) + return 0; + + /* Undoes the effect of ImpersonateSelf. */ + + RevertToSelf (); + + /* We want to test for write permissions. */ + + dwAccessDesired = CheckAccessDesired; + + MapGenericMask (&dwAccessDesired, &CheckGenericMapping); + + if (!AccessCheck + (pSD , /* security descriptor to check */ + hToken, /* impersonation token */ + dwAccessDesired, /* requested access rights */ + &CheckGenericMapping, /* pointer to GENERIC_MAPPING */ + &PrivilegeSet, /* receives privileges used in check */ + &dwPrivSetSize, /* size of PrivilegeSet buffer */ + &dwAccessAllowed, /* receives mask of allowed access rights */ + &fAccessGranted)) + return 0; + + return fAccessGranted; + } + + static void + __gnat_set_OWNER_ACL + (TCHAR *wname, + DWORD AccessMode, + DWORD AccessPermissions) + { + ACL* pOldDACL = NULL; + ACL* pNewDACL = NULL; + SECURITY_DESCRIPTOR* pSD = NULL; + EXPLICIT_ACCESS ea; + TCHAR username [100]; + DWORD unsize = 100; + + /* Get current user, he will act as the owner */ + + if (!GetUserName (username, &unsize)) + return; + + if (GetNamedSecurityInfo + (wname, + SE_FILE_OBJECT, + DACL_SECURITY_INFORMATION, + NULL, NULL, &pOldDACL, NULL, &pSD) != ERROR_SUCCESS) + return; + + BuildExplicitAccessWithName + (&ea, username, AccessPermissions, AccessMode, NO_INHERITANCE); + + if (AccessMode == SET_ACCESS) + { + /* SET_ACCESS, we want to set an explicte set of permissions, do not + merge with current DACL. */ + if (SetEntriesInAcl (1, &ea, NULL, &pNewDACL) != ERROR_SUCCESS) + return; + } + else + if (SetEntriesInAcl (1, &ea, pOldDACL, &pNewDACL) != ERROR_SUCCESS) + return; + + if (SetNamedSecurityInfo + (wname, SE_FILE_OBJECT, + DACL_SECURITY_INFORMATION, NULL, NULL, pNewDACL, NULL) != ERROR_SUCCESS) + return; + + LocalFree (pSD); + LocalFree (pNewDACL); + } + #endif /* defined (_WIN32) && !defined (RTX) */ + int __gnat_is_readable_file (char *name) { + #if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; + + S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); + + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericRead = GENERIC_READ; + + return __gnat_check_OWNER_ACL (wname, FILE_READ_DATA, GenericMapping); + #else int ret; int mode; struct stat statbuf; ! ret = stat (name, &statbuf); mode = statbuf.st_mode & S_IRUSR; return (!ret && mode); + #endif } int __gnat_is_writable_file (char *name) { + #if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; + + S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); + + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericWrite = GENERIC_WRITE; + + return __gnat_check_OWNER_ACL + (wname, FILE_WRITE_DATA | FILE_APPEND_DATA, GenericMapping) + && !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY); + #else int ret; int mode; struct stat statbuf; ! ret = stat (name, &statbuf); mode = statbuf.st_mode & S_IWUSR; return (!ret && mode); + #endif + } + + int + __gnat_is_executable_file (char *name) + { + #if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; + + S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); + + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericExecute = GENERIC_EXECUTE; + + return __gnat_check_OWNER_ACL (wname, FILE_EXECUTE, GenericMapping); + #else + int ret; + int mode; + struct stat statbuf; + + ret = stat (name, &statbuf); + mode = statbuf.st_mode & S_IXUSR; + return (!ret && mode); + #endif } void __gnat_set_writable (char *name) { ! #if defined (_WIN32) && !defined (RTX) ! TCHAR wname [GNAT_MAX_PATH_LEN + 2]; ! ! S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); ! ! __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_WRITE); ! SetFileAttributes ! (wname, GetFileAttributes (wname) & ~FILE_ATTRIBUTE_READONLY); ! #elif ! defined (__vxworks) && ! defined(__nucleus__) struct stat statbuf; if (stat (name, &statbuf) == 0) ! { ! statbuf.st_mode = statbuf.st_mode | S_IWUSR; ! chmod (name, statbuf.st_mode); ! } #endif } void __gnat_set_executable (char *name) { ! #if defined (_WIN32) && !defined (RTX) ! TCHAR wname [GNAT_MAX_PATH_LEN + 2]; ! ! S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); ! ! __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_EXECUTE); ! #elif ! defined (__vxworks) && ! defined(__nucleus__) struct stat statbuf; if (stat (name, &statbuf) == 0) ! { ! statbuf.st_mode = statbuf.st_mode | S_IXUSR; ! chmod (name, statbuf.st_mode); ! } #endif } void ! __gnat_set_non_writable (char *name) { ! #if defined (_WIN32) && !defined (RTX) ! TCHAR wname [GNAT_MAX_PATH_LEN + 2]; ! ! S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); ! ! __gnat_set_OWNER_ACL ! (wname, DENY_ACCESS, ! FILE_WRITE_DATA | FILE_APPEND_DATA | ! FILE_WRITE_EA | FILE_WRITE_ATTRIBUTES); ! SetFileAttributes ! (wname, GetFileAttributes (wname) | FILE_ATTRIBUTE_READONLY); ! #elif ! defined (__vxworks) && ! defined(__nucleus__) struct stat statbuf; if (stat (name, &statbuf) == 0) ! { ! statbuf.st_mode = statbuf.st_mode & 07577; ! chmod (name, statbuf.st_mode); ! } ! #endif ! } ! ! void ! __gnat_set_readable (char *name) ! { ! #if defined (_WIN32) && !defined (RTX) ! TCHAR wname [GNAT_MAX_PATH_LEN + 2]; ! ! S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); ! ! __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_READ); ! #elif ! defined (__vxworks) && ! defined(__nucleus__) ! struct stat statbuf; ! ! if (stat (name, &statbuf) == 0) ! { ! chmod (name, statbuf.st_mode | S_IREAD); ! } ! #endif ! } ! ! void ! __gnat_set_non_readable (char *name) ! { ! #if defined (_WIN32) && !defined (RTX) ! TCHAR wname [GNAT_MAX_PATH_LEN + 2]; ! ! S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); ! ! __gnat_set_OWNER_ACL (wname, DENY_ACCESS, FILE_GENERIC_READ); ! #elif ! defined (__vxworks) && ! defined(__nucleus__) ! struct stat statbuf; ! ! if (stat (name, &statbuf) == 0) ! { ! chmod (name, statbuf.st_mode & (~S_IREAD)); ! } #endif } *************** __gnat_dup2 (int oldfd, int newfd) *** 1835,1859 **** /* Synchronization code, to be thread safe. */ ! static CRITICAL_SECTION plist_cs; ! void ! __gnat_plist_init (void) ! { ! InitializeCriticalSection (&plist_cs); ! } ! static void ! plist_enter (void) ! { ! EnterCriticalSection (&plist_cs); ! } ! static void ! plist_leave (void) ! { ! LeaveCriticalSection (&plist_cs); ! } typedef struct _process_list { --- 2100,2125 ---- /* Synchronization code, to be thread safe. */ ! #ifdef CERT ! /* For the Cert run times on native Windows we use dummy functions ! for locking and unlocking tasks since we do not support multiple ! threads on this configuration (Cert run time on native Windows). */ ! void dummy (void) {} ! void (*Lock_Task) () = &dummy; ! void (*Unlock_Task) () = &dummy; ! ! #else ! ! #define Lock_Task system__soft_links__lock_task ! extern void (*Lock_Task) (void); ! ! #define Unlock_Task system__soft_links__unlock_task ! extern void (*Unlock_Task) (void); ! ! #endif typedef struct _process_list { *************** add_handle (HANDLE h) *** 1872,1887 **** pl = (Process_List *) xmalloc (sizeof (Process_List)); - plist_enter(); - /* -------------------- critical section -------------------- */ pl->h = h; pl->next = PLIST; PLIST = pl; ++plist_length; - /* -------------------- critical section -------------------- */ ! plist_leave(); } static void --- 2138,2153 ---- pl = (Process_List *) xmalloc (sizeof (Process_List)); /* -------------------- critical section -------------------- */ + (*Lock_Task) (); + pl->h = h; pl->next = PLIST; PLIST = pl; ++plist_length; ! (*Unlock_Task) (); ! /* -------------------- critical section -------------------- */ } static void *************** remove_handle (HANDLE h) *** 1890,1898 **** Process_List *pl; Process_List *prev = NULL; - plist_enter(); - /* -------------------- critical section -------------------- */ pl = PLIST; while (pl) { --- 2156,2164 ---- Process_List *pl; Process_List *prev = NULL; /* -------------------- critical section -------------------- */ + (*Lock_Task) (); + pl = PLIST; while (pl) { *************** remove_handle (HANDLE h) *** 1913,1921 **** } --plist_length; - /* -------------------- critical section -------------------- */ ! plist_leave(); } static int --- 2179,2187 ---- } --plist_length; ! (*Unlock_Task) (); ! /* -------------------- critical section -------------------- */ } static int *************** win32_wait (int *status) *** 2000,2005 **** --- 2266,2272 ---- DWORD res; int k; Process_List *pl; + int hl_len; if (plist_length == 0) { *************** win32_wait (int *status) *** 2007,2029 **** return -1; } - hl = (HANDLE *) xmalloc (sizeof (HANDLE) * plist_length); - k = 0; - plist_enter(); /* -------------------- critical section -------------------- */ pl = PLIST; while (pl) { hl[k++] = pl->h; pl = pl->next; } - /* -------------------- critical section -------------------- */ ! plist_leave(); ! res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE); h = hl[res - WAIT_OBJECT_0]; free (hl); --- 2274,2299 ---- return -1; } k = 0; /* -------------------- critical section -------------------- */ + (*Lock_Task) (); + + hl_len = plist_length; + + hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len); + pl = PLIST; while (pl) { hl[k++] = pl->h; pl = pl->next; } ! (*Unlock_Task) (); ! /* -------------------- critical section -------------------- */ ! res = WaitForMultipleObjects (hl_len, hl, FALSE, INFINITE); h = hl[res - WAIT_OBJECT_0]; free (hl); *************** char * *** 2122,2128 **** __gnat_locate_regular_file (char *file_name, char *path_val) { char *ptr; ! char *file_path = alloca (strlen (file_name) + 1); int absolute; /* Return immediately if file_name is empty */ --- 2392,2398 ---- __gnat_locate_regular_file (char *file_name, char *path_val) { char *ptr; ! char *file_path = (char *) alloca (strlen (file_name) + 1); int absolute; /* Return immediately if file_name is empty */ *************** __gnat_locate_regular_file (char *file_n *** 2171,2177 **** { /* The result has to be smaller than path_val + file_name. */ ! char *file_path = alloca (strlen (path_val) + strlen (file_name) + 2); for (;;) { --- 2441,2447 ---- { /* The result has to be smaller than path_val + file_name. */ ! char *file_path = (char *) alloca (strlen (path_val) + strlen (file_name) + 2); for (;;) { *************** __gnat_locate_exec (char *exec_name, cha *** 2220,2226 **** if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX)) { char *full_exec_name ! = alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1); strcpy (full_exec_name, exec_name); strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX); --- 2490,2496 ---- if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX)) { char *full_exec_name ! = (char *) alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1); strcpy (full_exec_name, exec_name); strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX); *************** __gnat_locate_exec_on_path (char *exec_n *** 2273,2279 **** char *path_val = getenv ("PATH"); #endif if (path_val == NULL) return NULL; ! apath_val = alloca (strlen (path_val) + 1); strcpy (apath_val, path_val); return __gnat_locate_exec (exec_name, apath_val); #endif --- 2543,2549 ---- char *path_val = getenv ("PATH"); #endif if (path_val == NULL) return NULL; ! apath_val = (char *) alloca (strlen (path_val) + 1); strcpy (apath_val, path_val); return __gnat_locate_exec (exec_name, apath_val); #endif *************** _flush_cache() *** 2857,2862 **** --- 3127,3133 ---- && defined (__SVR4)) \ && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \ && ! (defined (linux) && defined (__ia64__)) \ + && ! (defined (linux) && defined (powerpc)) \ && ! defined (__FreeBSD__) \ && ! defined (__hpux__) \ && ! defined (__APPLE__) \ *************** get_gcc_version (void) *** 2970,2976 **** int __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED, ! int close_on_exec_p ATTRIBUTE_UNUSED) { #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks) int flags = fcntl (fd, F_GETFD, 0); --- 3241,3247 ---- int __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED, ! int close_on_exec_p ATTRIBUTE_UNUSED) { #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks) int flags = fcntl (fd, F_GETFD, 0); *************** __gnat_set_close_on_exec (int fd ATTRIBU *** 2981,2992 **** else flags &= ~FD_CLOEXEC; return fcntl (fd, F_SETFD, flags | FD_CLOEXEC); #else return -1; - /* For the Windows case, we should use SetHandleInformation to remove - the HANDLE_INHERIT property from fd. This is not implemented yet, - but for our purposes (support of GNAT.Expect) this does not matter, - as by default handles are *not* inherited. */ #endif } --- 3252,3268 ---- else flags &= ~FD_CLOEXEC; return fcntl (fd, F_SETFD, flags | FD_CLOEXEC); + #elif defined(_WIN32) + HANDLE h = (HANDLE) _get_osfhandle (fd); + if (h == (HANDLE) -1) + return -1; + if (close_on_exec_p) + return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT, 0); + return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT, + HANDLE_FLAG_INHERIT); #else + /* TODO: Unimplemented. */ return -1; #endif } *************** __gnat_sals_init_using_constructors () *** 3014,3024 **** #endif } /* In RTX mode, the procedure to get the time (as file time) is different in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file, we introduce an intermediate procedure to link against the corresponding one in each situation. */ ! #ifdef RTX void GetTimeAsFileTime(LPFILETIME pTime) { --- 3290,3303 ---- #endif } + #ifdef RTX + /* In RTX mode, the procedure to get the time (as file time) is different in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file, we introduce an intermediate procedure to link against the corresponding one in each situation. */ ! ! extern void GetTimeAsFileTime(LPFILETIME pTime); void GetTimeAsFileTime(LPFILETIME pTime) { *************** void GetTimeAsFileTime(LPFILETIME pTime) *** 3028,3038 **** GetSystemTimeAsFileTime (pTime); /* w32 interface */ #endif } #endif ! #if defined (linux) /* pthread affinity support */ #ifdef CPU_SETSIZE #include int --- 3307,3331 ---- GetSystemTimeAsFileTime (pTime); /* w32 interface */ #endif } + + #ifdef RTSS + /* Add symbol that is required to link. It would otherwise be taken from + libgcc.a and it would try to use the gcc constructors that are not + supported by Microsoft linker. */ + + extern void __main (void); + + void __main (void) {} + #endif #endif ! #if defined (linux) || defined(__GLIBC__) /* pthread affinity support */ + int __gnat_pthread_setaffinity_np (pthread_t th, + size_t cpusetsize, + const void *cpuset); + #ifdef CPU_SETSIZE #include int *************** __gnat_pthread_setaffinity_np (pthread_t *** 3044,3052 **** } #else int ! __gnat_pthread_setaffinity_np (pthread_t th, ! size_t cpusetsize, ! const void *cpuset) { return 0; } --- 3337,3345 ---- } #else int ! __gnat_pthread_setaffinity_np (pthread_t th ATTRIBUTE_UNUSED, ! size_t cpusetsize ATTRIBUTE_UNUSED, ! const void *cpuset ATTRIBUTE_UNUSED) { return 0; } diff -Nrcpad gcc-4.3.3/gcc/ada/adaint.h gcc-4.4.0/gcc/ada/adaint.h *** gcc-4.3.3/gcc/ada/adaint.h Thu Dec 13 10:19:55 2007 --- gcc-4.4.0/gcc/ada/adaint.h Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Header File * * * ! * Copyright (C) 1992-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Header File * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** typedef long OS_Time; /* Type correspond *** 47,52 **** --- 46,52 ---- extern int __gnat_max_path_len; extern OS_Time __gnat_current_time (void); + extern void __gnat_current_time_string (char *); extern void __gnat_to_gm_time (OS_Time *, int *, int *, int *, int *, int *, int *); *************** extern int __gnat_is_absolute_path *** 100,108 **** extern int __gnat_is_directory (char *); extern int __gnat_is_writable_file (char *); extern int __gnat_is_readable_file (char *name); ! extern void __gnat_set_readonly (char *name); extern void __gnat_set_writable (char *name); extern void __gnat_set_executable (char *name); extern int __gnat_is_symbolic_link (char *name); extern int __gnat_portable_spawn (char *[]); extern int __gnat_portable_no_block_spawn (char *[]); --- 100,111 ---- extern int __gnat_is_directory (char *); extern int __gnat_is_writable_file (char *); extern int __gnat_is_readable_file (char *name); ! extern int __gnat_is_executable_file (char *name); ! extern void __gnat_set_non_writable (char *name); extern void __gnat_set_writable (char *name); extern void __gnat_set_executable (char *name); + extern void __gnat_set_readable (char *name); + extern void __gnat_set_non_readable (char *name); extern int __gnat_is_symbolic_link (char *name); extern int __gnat_portable_spawn (char *[]); extern int __gnat_portable_no_block_spawn (char *[]); diff -Nrcpad gcc-4.3.3/gcc/ada/ali.adb gcc-4.4.0/gcc/ada/ali.adb *** gcc-4.3.3/gcc/ada/ali.adb Thu Dec 13 10:20:52 2007 --- gcc-4.4.0/gcc/ada/ali.adb Wed Aug 20 16:11:55 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body ALI is *** 53,58 **** --- 53,59 ---- 'D' => True, -- dependency 'X' => True, -- xref 'S' => True, -- specific dispatching + 'Y' => True, -- limited_with others => False); -------------------- *************** package body ALI is *** 772,778 **** -- Acquire lines to be ignored if Read_Xref then ! Ignore := ('U' | 'W' | 'D' | 'X' => False, others => True); -- Read_Lines parameter given --- 773,779 ---- -- Acquire lines to be ignored if Read_Xref then ! Ignore := ('U' | 'W' | 'Y' | 'D' | 'X' => False, others => True); -- Read_Lines parameter given *************** package body ALI is *** 1418,1423 **** --- 1419,1425 ---- UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; UL.Body_Needed_For_SAL := False; UL.Elaborate_Body_Desirable := False; + UL.Optimize_Alignment := 'O'; if Debug_Flag_U then Write_Str (" ----> reading unit "); *************** package body ALI is *** 1620,1625 **** --- 1622,1640 ---- Check_At_End_Of_Field; + -- OL/OO/OS/OT parameters + + elsif C = 'O' then + C := Getc; + + if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then + Units.Table (Units.Last).Optimize_Alignment := C; + else + Fatal_Error_Ignore; + end if; + + Check_At_End_Of_Field; + -- RC/RT parameters elsif C = 'R' then *************** package body ALI is *** 1672,1678 **** With_Loop : loop Check_Unknown_Line; ! exit With_Loop when C /= 'W'; if Ignore ('W') then Skip_Line; --- 1687,1693 ---- With_Loop : loop Check_Unknown_Line; ! exit With_Loop when C /= 'W' and then C /= 'Y'; if Ignore ('W') then Skip_Line; *************** package body ALI is *** 1687,1692 **** --- 1702,1708 ---- Withs.Table (Withs.Last).Elab_Desirable := False; Withs.Table (Withs.Last).Elab_All_Desirable := False; Withs.Table (Withs.Last).SAL_Interface := False; + Withs.Table (Withs.Last).Limited_With := (C = 'Y'); -- Generic case with no object file available *************** package body ALI is *** 1822,1828 **** end if; end loop; ! Add_Char_To_Name_Buffer (nul); Skip_Eol; end if; --- 1838,1844 ---- end if; end loop; ! Add_Char_To_Name_Buffer (NUL); Skip_Eol; end if; *************** package body ALI is *** 1983,1995 **** if Nextc not in '0' .. '9' then Name_Len := 0; - while not At_End_Of_Field loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Getc; end loop; ! Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter; Skip_Space; end if; --- 1999,2015 ---- if Nextc not in '0' .. '9' then Name_Len := 0; while not At_End_Of_Field loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Getc; end loop; ! -- Set the subunit name. Note that we use Name_Find rather ! -- than Name_Enter here as the subunit name may already ! -- have been put in the name table by the Project Manager. ! ! Sdep.Table (Sdep.Last).Subunit_Name := Name_Find; ! Skip_Space; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/ali.ads gcc-4.4.0/gcc/ada/ali.ads *** gcc-4.3.3/gcc/ada/ali.ads Thu Dec 13 10:19:19 2007 --- gcc-4.4.0/gcc/ada/ali.ads Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package ALI is *** 122,203 **** -- Id of last Sdep table entry for this file Main_Program : Main_Program_Type; ! -- Indicator of whether first unit can be used as main program. ! -- Not set if 'M' appears in Ignore_Lines. Main_Priority : Int; ! -- Indicates priority value if Main_Program field indicates that ! -- this can be a main program. A value of -1 (No_Main_Priority) ! -- indicates that no parameter was found, or no M line was present. ! -- Not set if 'M' appears in Ignore_Lines. Time_Slice_Value : Int; -- Indicates value of time slice parameter from T=xxx on main program ! -- line. A value of -1 indicates that no T=xxx parameter was found, ! -- or no M line was present. ! -- Not set if 'M' appears in Ignore_Lines. WC_Encoding : Character; -- Wide character encoding if main procedure. Otherwise not relevant. -- Not set if 'M' appears in Ignore_Lines. Locking_Policy : Character; ! -- Indicates locking policy for units in this file. Space means ! -- tasking was not used, or that no Locking_Policy pragma was ! -- present or that this is a language defined unit. Otherwise set ! -- to first character (upper case) of policy name. ! -- Not set if 'P' appears in Ignore_Lines. Queuing_Policy : Character; ! -- Indicates queuing policy for units in this file. Space means ! -- tasking was not used, or that no Queuing_Policy pragma was ! -- present or that this is a language defined unit. Otherwise set ! -- to first character (upper case) of policy name. ! -- Not set if 'P' appears in Ignore_Lines. Task_Dispatching_Policy : Character; ! -- Indicates task dispatching policy for units in this file. Space ! -- means tasking was not used, or that no Task_Dispatching_Policy ! -- pragma was present or that this is a language defined unit. ! -- Otherwise set to first character (upper case) of policy name. ! -- Not set if 'P' appears in Ignore_Lines. Compile_Errors : Boolean; ! -- Set to True if compile errors for unit. Note that No_Object ! -- will always be set as well in this case. ! -- Not set if 'P' appears in Ignore_Lines. Float_Format : Character; ! -- Set to float format (set to I if no float-format given). ! -- Not set if 'P' appears in Ignore_Lines. No_Object : Boolean; ! -- Set to True if no object file generated. ! -- Not set if 'P' appears in Ignore_Lines. Normalize_Scalars : Boolean; ! -- Set to True if file was compiled with Normalize_Scalars. ! -- Not set if 'P' appears in Ignore_Lines. Unit_Exception_Table : Boolean; ! -- Set to True if unit exception table pointer generated. ! -- Not set if 'P' appears in Ignore_Lines. Zero_Cost_Exceptions : Boolean; ! -- Set to True if file was compiled with zero cost exceptions. ! -- Not set if 'P' appears in Ignore_Lines. Restrictions : Restrictions_Info; -- Restrictions information reconstructed from R lines First_Interrupt_State : Interrupt_State_Id; Last_Interrupt_State : Interrupt_State_Id'Base; ! -- These point to the first and last entries in the interrupt ! -- state table for this unit. If there are no entries, then ! -- Last_Interrupt_State = First_Interrupt_State - 1 (that's ! -- why the 'Base reference is there, it can be one less than ! -- the lower bound of the subtype). ! -- Not set if 'I' appears in Ignore_Lines First_Specific_Dispatching : Priority_Specific_Dispatching_Id; Last_Specific_Dispatching : Priority_Specific_Dispatching_Id'Base; --- 122,199 ---- -- Id of last Sdep table entry for this file Main_Program : Main_Program_Type; ! -- Indicator of whether first unit can be used as main program. Not set ! -- if 'M' appears in Ignore_Lines. Main_Priority : Int; ! -- Indicates priority value if Main_Program field indicates that this ! -- can be a main program. A value of -1 (No_Main_Priority) indicates ! -- that no parameter was found, or no M line was present. Not set if ! -- 'M' appears in Ignore_Lines. Time_Slice_Value : Int; -- Indicates value of time slice parameter from T=xxx on main program ! -- line. A value of -1 indicates that no T=xxx parameter was found, or ! -- no M line was present. Not set if 'M' appears in Ignore_Lines. WC_Encoding : Character; -- Wide character encoding if main procedure. Otherwise not relevant. -- Not set if 'M' appears in Ignore_Lines. Locking_Policy : Character; ! -- Indicates locking policy for units in this file. Space means tasking ! -- was not used, or that no Locking_Policy pragma was present or that ! -- this is a language defined unit. Otherwise set to first character ! -- (upper case) of policy name. Not set if 'P' appears in Ignore_Lines. Queuing_Policy : Character; ! -- Indicates queuing policy for units in this file. Space means tasking ! -- was not used, or that no Queuing_Policy pragma was present or that ! -- this is a language defined unit. Otherwise set to first character ! -- (upper case) of policy name. Not set if 'P' appears in Ignore_Lines. Task_Dispatching_Policy : Character; ! -- Indicates task dispatching policy for units in this file. Space means ! -- tasking was not used, or that no Task_Dispatching_Policy pragma was ! -- present or that this is a language defined unit. Otherwise set to ! -- first character (upper case) of policy name. Not set if 'P' appears ! -- in Ignore_Lines. Compile_Errors : Boolean; ! -- Set to True if compile errors for unit. Note that No_Object will ! -- always be set as well in this case. Not set if 'P' appears in ! -- Ignore_Lines. Float_Format : Character; ! -- Set to float format (set to I if no float-format given). Not set if ! -- 'P' appears in Ignore_Lines. No_Object : Boolean; ! -- Set to True if no object file generated. Not set if 'P' appears in ! -- Ignore_Lines. Normalize_Scalars : Boolean; ! -- Set to True if file was compiled with Normalize_Scalars. Not set if ! -- 'P' appears in Ignore_Lines. Unit_Exception_Table : Boolean; ! -- Set to True if unit exception table pointer generated. Not set if 'P' ! -- appears in Ignore_Lines. Zero_Cost_Exceptions : Boolean; ! -- Set to True if file was compiled with zero cost exceptions. Not set ! -- if 'P' appears in Ignore_Lines. Restrictions : Restrictions_Info; -- Restrictions information reconstructed from R lines First_Interrupt_State : Interrupt_State_Id; Last_Interrupt_State : Interrupt_State_Id'Base; ! -- These point to the first and last entries in the interrupt state ! -- table for this unit. If no entries, then Last_Interrupt_State = ! -- First_Interrupt_State - 1 (that's why the 'Base reference is there, ! -- it can be one less than the lower bound of the subtype). Not set if ! -- 'I' appears in Ignore_Lines First_Specific_Dispatching : Priority_Specific_Dispatching_Id; Last_Specific_Dispatching : Priority_Specific_Dispatching_Id'Base; *************** package ALI is *** 357,362 **** --- 353,361 ---- -- for the body right after the call for the spec, or at least as close -- together as possible. + Optimize_Alignment : Character; + -- Optimize_Alignment setting. Set to L/S/T/O for OL/OS/OT/OO present + end record; package Units is new Table.Table ( *************** package ALI is *** 445,451 **** Float_Format_Specified : Character := ' '; -- Set to blank by Initialize_ALI. Set to appropriate float format ! -- character (V or I, see Opt.Float_Format) if an an ali file that -- is read contains an F line setting the floating point format. Initialize_Scalars_Used : Boolean := False; --- 444,450 ---- Float_Format_Specified : Character := ' '; -- Set to blank by Initialize_ALI. Set to appropriate float format ! -- character (V or I, see Opt.Float_Format) if an ali file that -- is read contains an F line setting the floating point format. Initialize_Scalars_Used : Boolean := False; *************** package ALI is *** 538,543 **** --- 537,544 ---- SAL_Interface : Boolean := False; -- True if the Unit is an Interface of a Stand-Alone Library + Limited_With : Boolean := False; + -- True if unit is named in a limited_with_clause end record; package Withs is new Table.Table ( *************** package ALI is *** 668,675 **** -- Sdep (Source Dependency) Table -- ------------------------------------ ! -- Each source dependency (D line) in an ALI file generates an ! -- entry in the Sdep table. -- Note: there will be no entries in this table if 'D' lines are ignored --- 669,676 ---- -- Sdep (Source Dependency) Table -- ------------------------------------ ! -- Each source dependency (D line) in an ALI file generates an entry in the ! -- Sdep table. -- Note: there will be no entries in this table if 'D' lines are ignored *************** package ALI is *** 677,685 **** -- Special value indicating no Sdep table entry First_Sdep_Entry : Sdep_Id := No_Sdep_Id + 1; ! -- Id of first Sdep entry for current ali file. This is initialized to ! -- the first Sdep entry in the table, and then incremented appropriately ! -- as successive ALI files are scanned. type Sdep_Record is record --- 678,686 ---- -- Special value indicating no Sdep table entry First_Sdep_Entry : Sdep_Id := No_Sdep_Id + 1; ! -- Id of first Sdep entry for current ali file. This is initialized to the ! -- first Sdep entry in the table, and then incremented appropriately as ! -- successive ALI files are scanned. type Sdep_Record is record *************** package ALI is *** 687,710 **** -- Name of source file Stamp : Time_Stamp_Type; ! -- Time stamp value. Note that this will be all zero characters ! -- for the dummy entries for missing or non-dependent files. Checksum : Word; ! -- Checksum value. Note that this will be all zero characters ! -- for the dummy entries for missing or non-dependent files Dummy_Entry : Boolean; ! -- Set True for dummy entries that correspond to missing files ! -- or files where no dependency relationship exists. Subunit_Name : Name_Id; -- Name_Id for subunit name if present, else No_Name Rfile : File_Name_Type; ! -- Reference file name. Same as Sfile unless a Source_Reference ! -- pragma was used, in which case it reflects the name used in ! -- the pragma. Start_Line : Nat; -- Starting line number in file. Always 1, unless a Source_Reference --- 688,710 ---- -- Name of source file Stamp : Time_Stamp_Type; ! -- Time stamp value. Note that this will be all zero characters for the ! -- dummy entries for missing or non-dependent files. Checksum : Word; ! -- Checksum value. Note that this will be all zero characters for the ! -- dummy entries for missing or non-dependent files Dummy_Entry : Boolean; ! -- Set True for dummy entries that correspond to missing files or files ! -- where no dependency relationship exists. Subunit_Name : Name_Id; -- Name_Id for subunit name if present, else No_Name Rfile : File_Name_Type; ! -- Reference file name. Same as Sfile unless a Source_Reference pragma ! -- was used, in which case it reflects the name used in the pragma. Start_Line : Nat; -- Starting line number in file. Always 1, unless a Source_Reference *************** package ALI is *** 725,732 **** -- Use of Name Table Info -- ---------------------------- ! -- All unit names and file names are entered into the Names table. The ! -- Info fields of these entries are used as follows: -- Unit name Info field has Unit_Id of unit table entry -- ALI file name Info field has ALI_Id of ALI table entry --- 725,732 ---- -- Use of Name Table Info -- ---------------------------- ! -- All unit names and file names are entered into the Names table. The Info ! -- fields of these entries are used as follows: -- Unit name Info field has Unit_Id of unit table entry -- ALI file name Info field has ALI_Id of ALI table entry *************** package ALI is *** 736,743 **** -- Cross-Reference Data -- -------------------------- ! -- The following table records cross-reference sections, there is one ! -- entry for each X header line in the ALI file for an xref section. -- Note: there will be no entries in this table if 'X' lines are ignored --- 736,743 ---- -- Cross-Reference Data -- -------------------------- ! -- The following table records cross-reference sections, there is one entry ! -- for each X header line in the ALI file for an xref section. -- Note: there will be no entries in this table if 'X' lines are ignored *************** package ALI is *** 844,855 **** Oref_File_Num : Sdep_Id; -- This field is set to No_Sdep_Id if the entity doesn't override any ! -- other entity, or to the dependency reference for the overriden -- entity. Oref_Line : Nat; Oref_Col : Nat; ! -- These two fields are set to the line and column of the overriden -- entity. First_Xref : Nat; --- 844,855 ---- Oref_File_Num : Sdep_Id; -- This field is set to No_Sdep_Id if the entity doesn't override any ! -- other entity, or to the dependency reference for the overridden -- entity. Oref_Line : Nat; Oref_Col : Nat; ! -- These two fields are set to the line and column of the overridden -- entity. First_Xref : Nat; *************** package ALI is *** 959,965 **** -- Ignore_Lines requests that Scan_ALI ignore any lines that start -- with any given key character. The default value of X causes all -- Xref lines to be ignored. The corresponding data in the ALI ! -- tables will not be filled in in this case. It is not possible -- to ignore U (unit) lines, they are always read. -- -- Read_Lines requests that Scan_ALI process only lines that start --- 959,965 ---- -- Ignore_Lines requests that Scan_ALI ignore any lines that start -- with any given key character. The default value of X causes all -- Xref lines to be ignored. The corresponding data in the ALI ! -- tables will not be filled in this case. It is not possible -- to ignore U (unit) lines, they are always read. -- -- Read_Lines requests that Scan_ALI process only lines that start diff -Nrcpad gcc-4.3.3/gcc/ada/alloc.ads gcc-4.4.0/gcc/ada/alloc.ads *** gcc-4.3.3/gcc/ada/alloc.ads Tue Aug 14 08:37:08 2007 --- gcc-4.4.0/gcc/ada/alloc.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Alloc is *** 99,104 **** --- 97,105 ---- Nodes_Initial : constant := 50_000; -- Atree Nodes_Increment : constant := 100; + Obsolescent_Warnings_Initial : constant := 50; -- Sem_Prag + Obsolescent_Warnings_Increment : constant := 200; + Orig_Nodes_Initial : constant := 50_000; -- Atree Orig_Nodes_Increment : constant := 100; *************** package Alloc is *** 141,146 **** --- 142,150 ---- Unreferenced_Entities_Initial : constant := 1_000; -- Sem_Warn Unreferenced_Entities_Increment : constant := 100; + Warnings_Off_Pragmas_Initial : constant := 500; -- Sem_Warn + Warnings_Off_Pragmas_Increment : constant := 100; + With_List_Initial : constant := 10; -- Features With_List_Increment : constant := 300; diff -Nrcpad gcc-4.3.3/gcc/ada/argv.c gcc-4.4.0/gcc/ada/argv.c *** gcc-4.3.3/gcc/ada/argv.c Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/argv.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** int gnat_argc = 0; *** 61,67 **** const char **gnat_argv = (const char **) 0; const char **gnat_envp = (const char **) 0; ! #ifdef _WIN32 /* Note that on Windows environment the environ point to a buffer that could be reallocated if needed. It means that gnat_envp needs to be updated before using gnat_envp to point to the right environment space */ --- 60,66 ---- const char **gnat_argv = (const char **) 0; const char **gnat_envp = (const char **) 0; ! #if defined (_WIN32) && !defined (RTX) /* Note that on Windows environment the environ point to a buffer that could be reallocated if needed. It means that gnat_envp needs to be updated before using gnat_envp to point to the right environment space */ diff -Nrcpad gcc-4.3.3/gcc/ada/arit64.c gcc-4.4.0/gcc/ada/arit64.c *** gcc-4.3.3/gcc/ada/arit64.c Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/arit64.c Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,57 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A R I T 6 4 . C * + * * + * C Implementation File * + * * + * Copyright (C) 2009, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + extern void __gnat_rcheck_10(char *file, int line) + __attribute__ ((__noreturn__)); + + long long int __gnat_mulv64 (long long int x, long long int y) + { + unsigned neg = (x >= 0) ^ (y >= 0); + long long unsigned xa = x >= 0 ? (long long unsigned) x + : -(long long unsigned) x; + long long unsigned ya = y >= 0 ? (long long unsigned) y + : -(long long unsigned) y; + unsigned xhi = (unsigned) (xa >> 32); + unsigned yhi = (unsigned) (ya >> 32); + unsigned xlo = (unsigned) xa; + unsigned ylo = (unsigned) ya; + long long unsigned mid + = xhi ? (long long unsigned) xhi * (long long unsigned) ylo + : (long long unsigned) yhi * (long long unsigned) xlo; + long long unsigned low = (long long unsigned) xlo * (long long unsigned) ylo; + + if ((xhi && yhi) || mid + (low >> 32) > 0x7fffffff + neg) + __gnat_rcheck_10 (__FILE__, __LINE__); + + low += ((long long unsigned) (unsigned) mid) << 32; + + return (long long int) (neg ? -low : low); + } diff -Nrcpad gcc-4.3.3/gcc/ada/atree.adb gcc-4.4.0/gcc/ada/atree.adb *** gcc-4.3.3/gcc/ada/atree.adb Wed Dec 19 16:22:40 2007 --- gcc-4.4.0/gcc/ada/atree.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Atree is *** 562,570 **** -- Local Subprograms -- ----------------------- ! procedure Fix_Parents (Old_Node, New_Node : Node_Id); ! -- Fixup parent pointers for the syntactic children of New_Node after ! -- a copy, setting them to New_Node when they pointed to Old_Node. function Allocate_Initialize_Node (Src : Node_Id; --- 560,568 ---- -- Local Subprograms -- ----------------------- ! procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id); ! -- Fixup parent pointers for the syntactic children of Fix_Node after ! -- a copy, setting them to Fix_Node when they pointed to Ref_Node. function Allocate_Initialize_Node (Src : Node_Id; *************** package body Atree is *** 988,1005 **** -- Fix_Parents -- ----------------- ! procedure Fix_Parents (Old_Node, New_Node : Node_Id) is ! procedure Fix_Parent (Field : Union_Id; Old_Node, New_Node : Node_Id); ! -- Fixup one parent pointer. Field is checked to see if it ! -- points to a node, list, or element list that has a parent that ! -- points to Old_Node. If so, the parent is reset to point to New_Node. ---------------- -- Fix_Parent -- ---------------- ! procedure Fix_Parent (Field : Union_Id; Old_Node, New_Node : Node_Id) is begin -- Fix parent of node that is referenced by Field. Note that we must -- exclude the case where the node is a member of a list, because in --- 986,1003 ---- -- Fix_Parents -- ----------------- ! procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id) is ! procedure Fix_Parent (Field : Union_Id); ! -- Fixup one parent pointer. Field is checked to see if it points to ! -- a node, list, or element list that has a parent that points to ! -- Ref_Node. If so, the parent is reset to point to Fix_Node. ---------------- -- Fix_Parent -- ---------------- ! procedure Fix_Parent (Field : Union_Id) is begin -- Fix parent of node that is referenced by Field. Note that we must -- exclude the case where the node is a member of a list, because in *************** package body Atree is *** 1008,1035 **** if Field in Node_Range and then Present (Node_Id (Field)) and then not Nodes.Table (Node_Id (Field)).In_List ! and then Parent (Node_Id (Field)) = Old_Node then ! Set_Parent (Node_Id (Field), New_Node); -- Fix parent of list that is referenced by Field elsif Field in List_Range and then Present (List_Id (Field)) ! and then Parent (List_Id (Field)) = Old_Node then ! Set_Parent (List_Id (Field), New_Node); end if; end Fix_Parent; -- Start of processing for Fix_Parents begin ! Fix_Parent (Field1 (New_Node), Old_Node, New_Node); ! Fix_Parent (Field2 (New_Node), Old_Node, New_Node); ! Fix_Parent (Field3 (New_Node), Old_Node, New_Node); ! Fix_Parent (Field4 (New_Node), Old_Node, New_Node); ! Fix_Parent (Field5 (New_Node), Old_Node, New_Node); end Fix_Parents; ----------------------------------- --- 1006,1033 ---- if Field in Node_Range and then Present (Node_Id (Field)) and then not Nodes.Table (Node_Id (Field)).In_List ! and then Parent (Node_Id (Field)) = Ref_Node then ! Set_Parent (Node_Id (Field), Fix_Node); -- Fix parent of list that is referenced by Field elsif Field in List_Range and then Present (List_Id (Field)) ! and then Parent (List_Id (Field)) = Ref_Node then ! Set_Parent (List_Id (Field), Fix_Node); end if; end Fix_Parent; -- Start of processing for Fix_Parents begin ! Fix_Parent (Field1 (Fix_Node)); ! Fix_Parent (Field2 (Fix_Node)); ! Fix_Parent (Field3 (Fix_Node)); ! Fix_Parent (Field4 (Fix_Node)); ! Fix_Parent (Field5 (Fix_Node)); end Fix_Parents; ----------------------------------- *************** package body Atree is *** 2404,2410 **** end if; New_Node := New_Copy (Source); ! Fix_Parents (Source, New_Node); -- We now set the parent of the new node to be the same as the -- parent of the source. Almost always this parent will be --- 2402,2408 ---- end if; New_Node := New_Copy (Source); ! Fix_Parents (Ref_Node => Source, Fix_Node => New_Node); -- We now set the parent of the new node to be the same as the -- parent of the source. Almost always this parent will be *************** package body Atree is *** 2448,2454 **** -- Fix parents of substituted node, since it has changed identity ! Fix_Parents (New_Node, Old_Node); -- Since we are doing a replace, we assume that the original node -- is intended to become the new replaced node. The call would be --- 2446,2452 ---- -- Fix parents of substituted node, since it has changed identity ! Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node); -- Since we are doing a replace, we assume that the original node -- is intended to become the new replaced node. The call would be *************** package body Atree is *** 2511,2517 **** Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze); end if; ! Fix_Parents (New_Node, Old_Node); end Rewrite; ------------------ --- 2509,2515 ---- Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze); end if; ! Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node); end Rewrite; ------------------ *************** package body Atree is *** 2738,2749 **** if Field2 (Cur_Node) not in Node_Range then return Traverse_Field (Cur_Node, Field2 (Cur_Node), 2); ! elsif Is_Syntactic_Field (Nkind (Cur_Node), 2) and then ! Field2 (Cur_Node) /= Empty_List_Or_Node then ! -- Here is the tail recursion step, we reset Cur_Node and jump ! -- back to the start of the procedure, which has the same ! -- semantic effect as a call. Cur_Node := Node_Id (Field2 (Cur_Node)); goto Tail_Recurse; --- 2736,2748 ---- if Field2 (Cur_Node) not in Node_Range then return Traverse_Field (Cur_Node, Field2 (Cur_Node), 2); ! ! elsif Is_Syntactic_Field (Nkind (Cur_Node), 2) ! and then Field2 (Cur_Node) /= Empty_List_Or_Node then ! -- Here is the tail recursion step, we reset Cur_Node and jump back ! -- to the start of the procedure, which has the same semantic effect ! -- as a call. Cur_Node := Node_Id (Field2 (Cur_Node)); goto Tail_Recurse; *************** package body Atree is *** 7336,7342 **** pragma Assert (N <= Nodes.Last); if Val > Error then ! Set_Parent (Val, N); end if; Set_Node1 (N, Val); --- 7335,7341 ---- pragma Assert (N <= Nodes.Last); if Val > Error then ! Set_Parent (N => Val, Val => N); end if; Set_Node1 (N, Val); *************** package body Atree is *** 7347,7353 **** pragma Assert (N <= Nodes.Last); if Val > Error then ! Set_Parent (Val, N); end if; Set_Node2 (N, Val); --- 7346,7352 ---- pragma Assert (N <= Nodes.Last); if Val > Error then ! Set_Parent (N => Val, Val => N); end if; Set_Node2 (N, Val); *************** package body Atree is *** 7358,7364 **** pragma Assert (N <= Nodes.Last); if Val > Error then ! Set_Parent (Val, N); end if; Set_Node3 (N, Val); --- 7357,7363 ---- pragma Assert (N <= Nodes.Last); if Val > Error then ! Set_Parent (N => Val, Val => N); end if; Set_Node3 (N, Val); *************** package body Atree is *** 7369,7375 **** pragma Assert (N <= Nodes.Last); if Val > Error then ! Set_Parent (Val, N); end if; Set_Node4 (N, Val); --- 7368,7374 ---- pragma Assert (N <= Nodes.Last); if Val > Error then ! Set_Parent (N => Val, Val => N); end if; Set_Node4 (N, Val); *************** package body Atree is *** 7380,7386 **** pragma Assert (N <= Nodes.Last); if Val > Error then ! Set_Parent (Val, N); end if; Set_Node5 (N, Val); --- 7379,7385 ---- pragma Assert (N <= Nodes.Last); if Val > Error then ! Set_Parent (N => Val, Val => N); end if; Set_Node5 (N, Val); diff -Nrcpad gcc-4.3.3/gcc/ada/atree.ads gcc-4.4.0/gcc/ada/atree.ads *** gcc-4.3.3/gcc/ada/atree.ads Wed Dec 19 16:22:40 2007 --- gcc-4.4.0/gcc/ada/atree.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/aux-io.c gcc-4.4.0/gcc/ada/aux-io.c *** gcc-4.3.3/gcc/ada/aux-io.c Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/aux-io.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2003 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * diff -Nrcpad gcc-4.3.3/gcc/ada/back_end.adb gcc-4.4.0/gcc/ada/back_end.adb *** gcc-4.3.3/gcc/ada/back_end.adb Thu Dec 13 10:22:45 2007 --- gcc-4.4.0/gcc/ada/back_end.adb Wed Jul 30 23:54:56 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Back_End is *** 59,66 **** File_Info_Array : array (1 .. Last_Source_File) of File_Info_Type; ! procedure gigi ( ! gnat_root : Int; max_gnat_node : Int; number_name : Nat; nodes_ptr : Address; --- 59,66 ---- File_Info_Array : array (1 .. Last_Source_File) of File_Info_Type; ! procedure gigi ! (gnat_root : Int; max_gnat_node : Int; number_name : Nat; nodes_ptr : Address; *************** package body Back_End is *** 76,81 **** --- 76,82 ---- number_file : Nat; file_info_ptr : Address; + gigi_standard_boolean : Entity_Id; gigi_standard_integer : Entity_Id; gigi_standard_long_long_float : Entity_Id; gigi_standard_exception_type : Entity_Id; *************** package body Back_End is *** 90,102 **** return; end if; ! for I in 1 .. Last_Source_File loop ! File_Info_Array (I).File_Name := Full_Debug_Name (I); ! File_Info_Array (I).Num_Source_Lines := Num_Source_Lines (I); end loop; ! gigi ( ! gnat_root => Int (Cunit (Main_Unit)), max_gnat_node => Int (Last_Node_Id - First_Node_Id + 1), number_name => Name_Entries_Count, nodes_ptr => Nodes_Address, --- 91,103 ---- return; end if; ! for J in 1 .. Last_Source_File loop ! File_Info_Array (J).File_Name := Full_Debug_Name (J); ! File_Info_Array (J).Num_Source_Lines := Num_Source_Lines (J); end loop; ! gigi ! (gnat_root => Int (Cunit (Main_Unit)), max_gnat_node => Int (Last_Node_Id - First_Node_Id + 1), number_name => Name_Entries_Count, nodes_ptr => Nodes_Address, *************** package body Back_End is *** 112,117 **** --- 113,119 ---- number_file => Num_Source_Files, file_info_ptr => File_Info_Array'Address, + gigi_standard_boolean => Standard_Boolean, gigi_standard_integer => Standard_Integer, gigi_standard_long_long_float => Standard_Long_Long_Float, gigi_standard_exception_type => Standard_Exception_Type, *************** package body Back_End is *** 125,156 **** procedure Scan_Compiler_Arguments is Next_Arg : Pos := 1; ! subtype Big_String is String (Positive); ! type BSP is access Big_String; ! ! type Arg_Array is array (Nat) of BSP; type Arg_Array_Ptr is access Arg_Array; - -- Import flag_stack_check from toplev.c - flag_stack_check : Int; ! pragma Import (C, flag_stack_check); -- Import from toplev.c save_argc : Nat; ! pragma Import (C, save_argc); -- Import from toplev.c save_argv : Arg_Array_Ptr; ! pragma Import (C, save_argv); -- Import from toplev.c Output_File_Name_Seen : Boolean := False; ! -- Set to True after having scanned the file_name for ! -- switch "-gnatO file_name" -- Local functions function Len_Arg (Arg : Pos) return Nat; ! -- Determine length of argument number Arg on the original ! -- command line from gnat1 procedure Scan_Back_End_Switches (Switch_Chars : String); -- Procedure to scan out switches stored in Switch_Chars. The first --- 127,155 ---- procedure Scan_Compiler_Arguments is Next_Arg : Pos := 1; ! type Arg_Array is array (Nat) of Big_String_Ptr; type Arg_Array_Ptr is access Arg_Array; flag_stack_check : Int; ! pragma Import (C, flag_stack_check); ! -- Import from toplev.c save_argc : Nat; ! pragma Import (C, save_argc); ! -- Import from toplev.c save_argv : Arg_Array_Ptr; ! pragma Import (C, save_argv); ! -- Import from toplev.c Output_File_Name_Seen : Boolean := False; ! -- Set to True after having scanned file_name for switch "-gnatO file" -- Local functions function Len_Arg (Arg : Pos) return Nat; ! -- Determine length of argument number Arg on the original command line ! -- from gnat1. procedure Scan_Back_End_Switches (Switch_Chars : String); -- Procedure to scan out switches stored in Switch_Chars. The first *************** package body Back_End is *** 196,208 **** Last := Last - 1; end if; ! -- For these switches, skip following argument and do not ! -- store either the switch or the following argument ! ! if Switch_Chars (First .. Last) = "o" ! or else Switch_Chars (First .. Last) = "dumpbase" ! or else Switch_Chars (First .. Last) = "-param" then Next_Arg := Next_Arg + 1; --- 195,206 ---- Last := Last - 1; end if; ! -- For switches -o, -dumpbase, --param, skip following argument and ! -- do not store either the switch or the following argument. + if Switch_Chars (First .. Last) = "o" or else + Switch_Chars (First .. Last) = "dumpbase" or else + Switch_Chars (First .. Last) = "-param" then Next_Arg := Next_Arg + 1; *************** package body Back_End is *** 211,219 **** elsif Switch_Chars (First .. Last) = "quiet" then null; ! else ! -- Store any other GCC switches Store_Compilation_Switch (Switch_Chars); -- Special check, the back end switch -fno-inline also sets the --- 209,217 ---- elsif Switch_Chars (First .. Last) = "quiet" then null; ! -- Store any other GCC switches + else Store_Compilation_Switch (Switch_Chars); -- Special check, the back end switch -fno-inline also sets the *************** package body Back_End is *** 236,244 **** while Next_Arg < save_argc loop Look_At_Arg : declare ! Argv_Ptr : constant BSP := save_argv (Next_Arg); ! Argv_Len : constant Nat := Len_Arg (Next_Arg); ! Argv : constant String := Argv_Ptr (1 .. Natural (Argv_Len)); begin -- If the previous switch has set the Output_File_Name_Present --- 234,243 ---- while Next_Arg < save_argc loop Look_At_Arg : declare ! Argv_Ptr : constant Big_String_Ptr := save_argv (Next_Arg); ! Argv_Len : constant Nat := Len_Arg (Next_Arg); ! Argv : constant String := ! Argv_Ptr (1 .. Natural (Argv_Len)); begin -- If the previous switch has set the Output_File_Name_Present *************** package body Back_End is *** 256,264 **** Output_File_Name_Seen := True; end if; ! -- If the previous switch has set the Search_Directory_Present ! -- flag (that is if we have just seen -I), then the next ! -- argument is a search directory path. elsif Search_Directory_Present then if Is_Switch (Argv) then --- 255,263 ---- Output_File_Name_Seen := True; end if; ! -- If the previous switch has set the Search_Directory_Present ! -- flag (that is if we have just seen -I), then the next argument ! -- is a search directory path. elsif Search_Directory_Present then if Is_Switch (Argv) then diff -Nrcpad gcc-4.3.3/gcc/ada/back_end.ads gcc-4.4.0/gcc/ada/back_end.ads *** gcc-4.3.3/gcc/ada/back_end.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/back_end.ads Fri Feb 20 15:20:38 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Back_End is *** 52,66 **** procedure Scan_Compiler_Arguments; -- Acquires command-line parameters passed to the compiler and processes ! -- them. Calls Scan_Front_End_Switches for any front-end switches ! -- encountered. -- ! -- The processing of arguments is private to the back end, since ! -- the way of acquiring the arguments as well as the set of allowable ! -- back end switches is different depending on the particular back end ! -- being used. -- ! -- Any processed switches that influence the result of a compilation ! -- must be added to the Compilation_Arguments table. end Back_End; --- 52,64 ---- procedure Scan_Compiler_Arguments; -- Acquires command-line parameters passed to the compiler and processes ! -- them. Calls Scan_Front_End_Switches for any front-end switches found. -- ! -- The processing of arguments is private to the back end, since the way ! -- of acquiring the arguments as well as the set of allowable back end ! -- switches is different depending on the particular back end being used. -- ! -- Any processed switches that influence the result of a compilation must ! -- be added to the Compilation_Arguments table. end Back_End; diff -Nrcpad gcc-4.3.3/gcc/ada/bcheck.adb gcc-4.4.0/gcc/ada/bcheck.adb *** gcc-4.3.3/gcc/ada/bcheck.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/bcheck.adb Mon Apr 14 21:07:59 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Bcheck is *** 43,49 **** ----------------------- -- The following checking subprograms make up the parts of the ! -- configuration consistency check. procedure Check_Consistent_Dispatching_Policy; procedure Check_Consistent_Dynamic_Elaboration_Checking; --- 43,49 ---- ----------------------- -- The following checking subprograms make up the parts of the ! -- configuration consistency check. See bodies for details of checks. procedure Check_Consistent_Dispatching_Policy; procedure Check_Consistent_Dynamic_Elaboration_Checking; *************** package body Bcheck is *** 51,58 **** --- 51,60 ---- procedure Check_Consistent_Interrupt_States; procedure Check_Consistent_Locking_Policy; procedure Check_Consistent_Normalize_Scalars; + procedure Check_Consistent_Optimize_Alignment; procedure Check_Consistent_Queuing_Policy; procedure Check_Consistent_Restrictions; + procedure Check_Consistent_Restriction_No_Default_Initialization; procedure Check_Consistent_Zero_Cost_Exception_Handling; procedure Consistency_Error_Msg (Msg : String); *************** package body Bcheck is *** 86,94 **** end if; Check_Consistent_Normalize_Scalars; Check_Consistent_Dynamic_Elaboration_Checking; - Check_Consistent_Restrictions; Check_Consistent_Interrupt_States; Check_Consistent_Dispatching_Policy; end Check_Configuration_Consistency; --- 88,97 ---- end if; Check_Consistent_Normalize_Scalars; + Check_Consistent_Optimize_Alignment; Check_Consistent_Dynamic_Elaboration_Checking; Check_Consistent_Restrictions; + Check_Consistent_Restriction_No_Default_Initialization; Check_Consistent_Interrupt_States; Check_Consistent_Dispatching_Policy; end Check_Configuration_Consistency; *************** package body Bcheck is *** 657,668 **** -- then all other units in the partition must also be compiled with -- Normalized_Scalars in effect. ! -- There is some issue as to whether this consistency check is ! -- desirable, it is certainly required at the moment by the RM. ! -- We should keep a watch on the ARG and HRG deliberations here. ! -- GNAT no longer depends on this consistency (it used to do so, ! -- but that has been corrected in the latest version, since the ! -- Initialize_Scalars pragma does not require consistency. procedure Check_Consistent_Normalize_Scalars is begin --- 660,670 ---- -- then all other units in the partition must also be compiled with -- Normalized_Scalars in effect. ! -- There is some issue as to whether this consistency check is desirable, ! -- it is certainly required at the moment by the RM. We should keep a watch ! -- on the ARG and HRG deliberations here. GNAT no longer depends on this ! -- consistency (it used to do so, but that is no longer the case, since ! -- pragma Initialize_Scalars pragma does not require consistency.) procedure Check_Consistent_Normalize_Scalars is begin *************** package body Bcheck is *** 696,701 **** --- 698,747 ---- end if; end Check_Consistent_Normalize_Scalars; + ----------------------------------------- + -- Check_Consistent_Optimize_Alignment -- + ----------------------------------------- + + -- The rule is that all units which depend on the global default setting + -- of Optimize_Alignment must be compiled with the same setting for this + -- default. Units which specify an explicit local value for this setting + -- are exempt from the consistency rule (this includes all internal units). + + procedure Check_Consistent_Optimize_Alignment is + OA_Setting : Character := ' '; + -- Reset when we find a unit that depends on the default and does + -- not have a local specification of the Optimize_Alignment setting. + + OA_Unit : Unit_Id; + -- Id of unit from which OA_Setting was set + + C : Character; + + begin + for U in First_Unit_Entry .. Units.Last loop + C := Units.Table (U).Optimize_Alignment; + + if C /= 'L' then + if OA_Setting = ' ' then + OA_Setting := C; + OA_Unit := U; + + elsif OA_Setting = C then + null; + + else + Error_Msg_Unit_1 := Units.Table (OA_Unit).Uname; + Error_Msg_Unit_2 := Units.Table (U).Uname; + + Consistency_Error_Msg + ("$ and $ compiled with different " + & "default Optimize_Alignment settings"); + return; + end if; + end if; + end loop; + end Check_Consistent_Optimize_Alignment; + ------------------------------------- -- Check_Consistent_Queuing_Policy -- ------------------------------------- *************** package body Bcheck is *** 737,746 **** -- Check_Consistent_Restrictions -- ----------------------------------- ! -- The rule is that if a restriction is specified in any unit, ! -- then all units must obey the restriction. The check applies ! -- only to restrictions which require partition wide consistency, ! -- and not to internal units. procedure Check_Consistent_Restrictions is Restriction_File_Output : Boolean; --- 783,791 ---- -- Check_Consistent_Restrictions -- ----------------------------------- ! -- The rule is that if a restriction is specified in any unit, then all ! -- units must obey the restriction. The check applies only to restrictions ! -- which require partition wide consistency, and not to internal units. procedure Check_Consistent_Restrictions is Restriction_File_Output : Boolean; *************** package body Bcheck is *** 773,779 **** declare M1 : constant String := "{ has restriction "; S : constant String := Restriction_Id'Image (R); ! M2 : String (1 .. 200); -- big enough! P : Integer; begin --- 818,824 ---- declare M1 : constant String := "{ has restriction "; S : constant String := Restriction_Id'Image (R); ! M2 : String (1 .. 2000); -- big enough! P : Integer; begin *************** package body Bcheck is *** 864,870 **** (" { (count = at least #)"); else Consistency_Error_Msg ! (" % (count = #)"); end if; end if; end if; --- 909,915 ---- (" { (count = at least #)"); else Consistency_Error_Msg ! (" { (count = #)"); end if; end if; end if; *************** package body Bcheck is *** 912,917 **** --- 957,1031 ---- end loop; end Check_Consistent_Restrictions; + ------------------------------------------------------------ + -- Check_Consistent_Restriction_No_Default_Initialization -- + ------------------------------------------------------------ + + -- The Restriction (No_Default_Initialization) has special consistency + -- rules. The rule is that no unit compiled without this restriction + -- that violates the restriction can WITH a unit that is compiled with + -- the restriction. + + procedure Check_Consistent_Restriction_No_Default_Initialization is + begin + -- Nothing to do if no one set this restriction + + if not Cumulative_Restrictions.Set (No_Default_Initialization) then + return; + end if; + + -- Nothing to do if no one violates the restriction + + if not Cumulative_Restrictions.Violated (No_Default_Initialization) then + return; + end if; + + -- Otherwise we go into a full scan to find possible problems + + for U in Units.First .. Units.Last loop + declare + UTE : Unit_Record renames Units.Table (U); + ATE : ALIs_Record renames ALIs.Table (UTE.My_ALI); + + begin + if ATE.Restrictions.Violated (No_Default_Initialization) then + for W in UTE.First_With .. UTE.Last_With loop + declare + AFN : constant File_Name_Type := Withs.Table (W).Afile; + + begin + -- The file name may not be present for withs of certain + -- generic run-time files. The test can be safely left + -- out in such cases anyway. + + if AFN /= No_File then + declare + WAI : constant ALI_Id := + ALI_Id (Get_Name_Table_Info (AFN)); + WTE : ALIs_Record renames ALIs.Table (WAI); + + begin + if WTE.Restrictions.Set + (No_Default_Initialization) + then + Error_Msg_Unit_1 := UTE.Uname; + Consistency_Error_Msg + ("unit $ compiled without restriction " + & "No_Default_Initialization"); + Error_Msg_Unit_1 := Withs.Table (W).Uname; + Consistency_Error_Msg + ("withs unit $, compiled with restriction " + & "No_Default_Initialization"); + end if; + end; + end if; + end; + end loop; + end if; + end; + end loop; + end Check_Consistent_Restriction_No_Default_Initialization; + --------------------------------------------------- -- Check_Consistent_Zero_Cost_Exception_Handling -- --------------------------------------------------- *************** package body Bcheck is *** 1018,1032 **** -- If consistency errors are tolerated, -- output the message as a warning. ! declare ! Warning_Msg : String (1 .. Msg'Length + 1); ! ! begin ! Warning_Msg (1) := '?'; ! Warning_Msg (2 .. Warning_Msg'Last) := Msg; ! ! Error_Msg (Warning_Msg); ! end; -- Otherwise the consistency error is a true error --- 1132,1138 ---- -- If consistency errors are tolerated, -- output the message as a warning. ! Error_Msg ('?' & Msg); -- Otherwise the consistency error is a true error diff -Nrcpad gcc-4.3.3/gcc/ada/binde.adb gcc-4.4.0/gcc/ada/binde.adb *** gcc-4.3.3/gcc/ada/binde.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/binde.adb Tue Apr 8 06:57:48 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Binde is *** 867,876 **** -- Skip if this with is an interface to a stand-alone library. -- Skip also if no ALI file for this WITH, happens for language -- defined generics while bootstrapping the compiler (see body of ! -- Lib.Writ.Write_With_Lines). if not Withs.Table (W).SAL_Interface and then Withs.Table (W).Afile /= No_File then declare Info : constant Int := --- 867,878 ---- -- Skip if this with is an interface to a stand-alone library. -- Skip also if no ALI file for this WITH, happens for language -- defined generics while bootstrapping the compiler (see body of ! -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited ! -- with clause, which does not impose an elaboration link. if not Withs.Table (W).SAL_Interface and then Withs.Table (W).Afile /= No_File + and then not Withs.Table (W).Limited_With then declare Info : constant Int := *************** package body Binde is *** 1237,1244 **** Make_Elab_Entry (Withs.Table (W).Uname, No_Elab_All_Link)); ! -- Elaborate_All_Desirable case, for this we establish ! -- the same links as above, but with a different reason. elsif Withs.Table (W).Elab_All_Desirable then --- 1239,1246 ---- Make_Elab_Entry (Withs.Table (W).Uname, No_Elab_All_Link)); ! -- Elaborate_All_Desirable case, for this we establish the ! -- same links as above, but with a different reason. elsif Withs.Table (W).Elab_All_Desirable then *************** package body Binde is *** 1256,1270 **** Make_Elab_Entry (Withs.Table (W).Uname, No_Elab_All_Link)); ! -- Pragma Elaborate case. We must build a link for the ! -- withed unit itself, and also the corresponding body ! -- if there is one. ! -- However, skip this processing if there is no ALI file ! -- for the WITH entry, because this means it is a ! -- generic (even when we fix the generics so that an ALI ! -- file is present, we probably still will have no ALI ! -- file for unchecked and other special cases). elsif Withs.Table (W).Elaborate and then Withs.Table (W).Afile /= No_File --- 1258,1272 ---- Make_Elab_Entry (Withs.Table (W).Uname, No_Elab_All_Link)); ! -- Pragma Elaborate case. We must build a link for the ! -- withed unit itself, and also the corresponding body if ! -- there is one. ! -- However, skip this processing if there is no ALI file for ! -- the WITH entry, because this means it is a generic (even ! -- when we fix the generics so that an ALI file is present, ! -- we probably still will have no ALI file for unchecked and ! -- other special cases). elsif Withs.Table (W).Elaborate and then Withs.Table (W).Afile /= No_File *************** package body Binde is *** 1276,1283 **** (Corresponding_Body (Withed_Unit), U, Elab); end if; ! -- Elaborate_Desirable case, for this we establish ! -- the same links as above, but with a different reason. elsif Withs.Table (W).Elab_Desirable then Build_Link (Withed_Unit, U, Withed); --- 1278,1285 ---- (Corresponding_Body (Withed_Unit), U, Elab); end if; ! -- Elaborate_Desirable case, for this we establish ! -- the same links as above, but with a different reason. elsif Withs.Table (W).Elab_Desirable then Build_Link (Withed_Unit, U, Withed); *************** package body Binde is *** 1288,1295 **** U, Elab_Desirable); end if; ! -- Case of normal WITH with no elaboration pragmas, just ! -- build the single link to the directly referenced unit else Build_Link (Withed_Unit, U, Withed); --- 1290,1303 ---- U, Elab_Desirable); end if; ! -- A limited_with does not establish an elaboration ! -- dependence (that's the whole point!). ! ! elsif Withs.Table (W).Limited_With then ! null; ! ! -- Case of normal WITH with no elaboration pragmas, just ! -- build the single link to the directly referenced unit else Build_Link (Withed_Unit, U, Withed); diff -Nrcpad gcc-4.3.3/gcc/ada/bindgen.adb gcc-4.4.0/gcc/ada/bindgen.adb *** gcc-4.3.3/gcc/ada/bindgen.adb Thu Dec 13 10:20:52 2007 --- gcc-4.4.0/gcc/ada/bindgen.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Bindgen is *** 127,164 **** -- Default_Stack_Size : Integer; -- Leap_Seconds_Support : Integer; ! -- Main_Priority is the priority value set by pragma Priority in the ! -- main program. If no such pragma is present, the value is -1. ! -- Time_Slice_Value is the time slice value set by pragma Time_Slice ! -- in the main program, or by the use of a -Tnnn parameter for the ! -- binder (if both are present, the binder value overrides). The ! -- value is in milliseconds. A value of zero indicates that time ! -- slicing should be suppressed. If no pragma is present, and no ! -- -T switch was used, the value is -1. ! -- WC_Encoding shows the wide character encoding method used for ! -- the main program. This is one of the encoding letters defined ! -- in System.WCh_Con.WC_Encoding_Letters. ! -- Locking_Policy is a space if no locking policy was specified ! -- for the partition. If a locking policy was specified, the value ! -- is the upper case first character of the locking policy name, ! -- for example, 'C' for Ceiling_Locking. ! -- Queuing_Policy is a space if no queuing policy was specified ! -- for the partition. If a queuing policy was specified, the value ! -- is the upper case first character of the queuing policy name ! -- for example, 'F' for FIFO_Queuing. ! -- Task_Dispatching_Policy is a space if no task dispatching policy ! -- was specified for the partition. If a task dispatching policy ! -- was specified, the value is the upper case first character of ! -- the policy name, e.g. 'F' for FIFO_Within_Priorities. ! -- Priority_Specific_Dispatching is the address of a string used to ! -- store the task dispatching policy specified for the different priorities ! -- in the partition. The length of this string is determined by the last -- priority for which such a pragma applies (the string will be a null -- string if no specific dispatching policies were used). If pragma were -- present, the entries apply to the priorities in sequence from the first --- 127,163 ---- -- Default_Stack_Size : Integer; -- Leap_Seconds_Support : Integer; ! -- Main_Priority is the priority value set by pragma Priority in the main ! -- program. If no such pragma is present, the value is -1. ! -- Time_Slice_Value is the time slice value set by pragma Time_Slice in the ! -- main program, or by the use of a -Tnnn parameter for the binder (if both ! -- are present, the binder value overrides). The value is in milliseconds. ! -- A value of zero indicates that time slicing should be suppressed. If no ! -- pragma is present, and no -T switch was used, the value is -1. ! -- WC_Encoding shows the wide character encoding method used for the main ! -- program. This is one of the encoding letters defined in ! -- System.WCh_Con.WC_Encoding_Letters. ! -- Locking_Policy is a space if no locking policy was specified for the ! -- partition. If a locking policy was specified, the value is the upper ! -- case first character of the locking policy name, for example, 'C' for ! -- Ceiling_Locking. ! -- Queuing_Policy is a space if no queuing policy was specified for the ! -- partition. If a queuing policy was specified, the value is the upper ! -- case first character of the queuing policy name for example, 'F' for ! -- FIFO_Queuing. ! -- Task_Dispatching_Policy is a space if no task dispatching policy was ! -- specified for the partition. If a task dispatching policy was specified, ! -- the value is the upper case first character of the policy name, e.g. 'F' ! -- for FIFO_Within_Priorities. ! -- Priority_Specific_Dispatching is the address of a string used to store ! -- the task dispatching policy specified for the different priorities in ! -- the partition. The length of this string is determined by the last -- priority for which such a pragma applies (the string will be a null -- string if no specific dispatching policies were used). If pragma were -- present, the entries apply to the priorities in sequence from the first *************** package body Bindgen is *** 182,193 **** -- such a pragma is given (the string will be a null string if no pragmas -- were used). If pragma were present the entries apply to the interrupts -- in sequence from the first interrupt, and are set to one of four ! -- possible settings: 'n' for not specified, 'u' for user, 'r' for ! -- run time, 's' for system, see description of Interrupt_State pragma ! -- for further details. ! -- Num_Interrupt_States is the length of the Interrupt_States string. ! -- It will be set to zero if no Interrupt_State pragmas are present. -- Unreserve_All_Interrupts is set to one if at least one unit in the -- partition had a pragma Unreserve_All_Interrupts, and zero otherwise. --- 181,192 ---- -- such a pragma is given (the string will be a null string if no pragmas -- were used). If pragma were present the entries apply to the interrupts -- in sequence from the first interrupt, and are set to one of four ! -- possible settings: 'n' for not specified, 'u' for user, 'r' for run ! -- time, 's' for system, see description of Interrupt_State pragma for ! -- further details. ! -- Num_Interrupt_States is the length of the Interrupt_States string. It ! -- will be set to zero if no Interrupt_State pragmas are present. -- Unreserve_All_Interrupts is set to one if at least one unit in the -- partition had a pragma Unreserve_All_Interrupts, and zero otherwise. *************** package body Bindgen is *** 201,213 **** -- this partition, and to zero if longjmp/setjmp exceptions are used. -- the use of zero ! -- Detect_Blocking indicates whether pragma Detect_Blocking is ! -- active or not. A value of zero indicates that the pragma is not ! -- present, while a value of 1 signals its presence in the ! -- partition. ! -- Default_Stack_Size is the default stack size used when creating an ! -- Ada task with no explicit Storize_Size clause. -- Leap_Seconds_Support denotes whether leap seconds have been enabled or -- disabled. A value of zero indicates that leap seconds are turned "off", --- 200,211 ---- -- this partition, and to zero if longjmp/setjmp exceptions are used. -- the use of zero ! -- Detect_Blocking indicates whether pragma Detect_Blocking is active or ! -- not. A value of zero indicates that the pragma is not present, while a ! -- value of 1 signals its presence in the partition. ! -- Default_Stack_Size is the default stack size used when creating an Ada ! -- task with no explicit Storage_Size clause. -- Leap_Seconds_Support denotes whether leap seconds have been enabled or -- disabled. A value of zero indicates that leap seconds are turned "off", *************** package body Bindgen is *** 606,613 **** WBI (" pragma Import (C, Handler_Installed, " & """__gnat_handler_installed"");"); -- Initialize stack limit variable of the environment task if the ! -- stack check method is stack limit and if stack check is enabled. if Stack_Check_Limits_On_Target and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) --- 604,625 ---- WBI (" pragma Import (C, Handler_Installed, " & """__gnat_handler_installed"");"); + -- Import entry point for environment feature enable/disable + -- routine, and indication that it's been called previously. + + if OpenVMS_On_Target then + WBI (""); + WBI (" procedure Set_Features;"); + WBI (" pragma Import (C, Set_Features, " & + """__gnat_set_features"");"); + WBI (""); + WBI (" Features_Set : Integer;"); + WBI (" pragma Import (C, Features_Set, " & + """__gnat_features_set"");"); + end if; + -- Initialize stack limit variable of the environment task if the ! -- stack check method is stack limit and stack check is enabled. if Stack_Check_Limits_On_Target and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) *************** package body Bindgen is *** 618,633 **** --- 630,656 ---- """__gnat_initialize_stack_limit"");"); end if; + -- Special processing when main program is CIL function/procedure + if VM_Target = CLI_Target + and then Bind_Main_Program and then not No_Main_Subprogram then WBI (""); + -- Function case, use Set_Exit_Status to report the returned + -- status code, since that is the only mechanism available. + if ALIs.Table (ALIs.First).Main_Program = Func then WBI (" Result : Integer;"); + WBI (" procedure Set_Exit_Status (Code : Integer);"); + WBI (" pragma Import (C, Set_Exit_Status, " & + """__gnat_set_exit_status"");"); WBI (""); WBI (" function Ada_Main_Program return Integer;"); + -- Procedure case + else WBI (" procedure Ada_Main_Program;"); end if; *************** package body Bindgen is *** 756,761 **** --- 779,793 ---- WBI (" if Handler_Installed = 0 then"); WBI (" Install_Handler;"); WBI (" end if;"); + + -- Generate call to Set_Features + + if OpenVMS_On_Target then + WBI (""); + WBI (" if Features_Set = 0 then"); + WBI (" Set_Features;"); + WBI (" end if;"); + end if; end if; -- Generate call to set Initialize_Scalar values if active *************** package body Bindgen is *** 782,788 **** end if; -- Initialize stack limit variable of the environment task if the ! -- stack check method is stack limit and if stack check is enabled. if Stack_Check_Limits_On_Target and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) --- 814,820 ---- end if; -- Initialize stack limit variable of the environment task if the ! -- stack check method is stack limit and stack check is enabled. if Stack_Check_Limits_On_Target and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) *************** package body Bindgen is *** 796,806 **** --- 828,847 ---- WBI (""); Gen_Elab_Calls_Ada; + -- Case of main program is CIL function or procedure + if VM_Target = CLI_Target + and then Bind_Main_Program and then not No_Main_Subprogram then + -- For function case, use Set_Exit_Status to set result + if ALIs.Table (ALIs.First).Main_Program = Func then WBI (" Result := Ada_Main_Program;"); + WBI (" Set_Exit_Status (Result);"); + + -- Procedure case + else WBI (" Ada_Main_Program;"); end if; *************** package body Bindgen is *** 1030,1039 **** WBI (" {"); WBI (" __gnat_install_handler ();"); WBI (" }"); end if; -- Initialize stack limit for the environment task if the stack ! -- check method is stack limit and if stack check is enabled. if Stack_Check_Limits_On_Target and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) --- 1071,1089 ---- WBI (" {"); WBI (" __gnat_install_handler ();"); WBI (" }"); + + -- Call feature enable/disable routine + + if OpenVMS_On_Target then + WBI (" if (__gnat_features_set == 0)"); + WBI (" {"); + WBI (" __gnat_set_features ();"); + WBI (" }"); + end if; end if; -- Initialize stack limit for the environment task if the stack ! -- check method is stack limit and stack check is enabled. if Stack_Check_Limits_On_Target and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) *************** package body Bindgen is *** 2249,2265 **** WBI (" gnat_exit_status : Integer;"); WBI (" pragma Import (C, gnat_exit_status);"); end if; - - -- Generate the GNAT_Version and Ada_Main_Program_Name info only - -- for the main program. Otherwise, it can lead under some - -- circumstances to a symbol duplication during the link (for - -- instance when a C program uses 2 Ada libraries) end if; WBI (""); WBI (" GNAT_Version : constant String :="); WBI (" ""GNAT Version: " & ! Gnat_Version_String & """;"); WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");"); WBI (""); --- 2299,2317 ---- WBI (" gnat_exit_status : Integer;"); WBI (" pragma Import (C, gnat_exit_status);"); end if; end if; + -- Generate the GNAT_Version and Ada_Main_Program_Name info only for + -- the main program. Otherwise, it can lead under some circumstances + -- to a symbol duplication during the link (for instance when a C + -- program uses two Ada libraries). Also zero terminate the string + -- so that its end can be found reliably at run time. + WBI (""); WBI (" GNAT_Version : constant String :="); WBI (" ""GNAT Version: " & ! Gnat_Version_String & ! """ & ASCII.NUL;"); WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");"); WBI (""); *************** package body Bindgen is *** 2268,2274 **** if VM_Target = No_VM then Set_Main_Program_Name; ! Set_String (""" & Ascii.NUL;"); else Set_String (Name_Buffer (1 .. Name_Len - 2) & """;"); end if; --- 2320,2326 ---- if VM_Target = No_VM then Set_Main_Program_Name; ! Set_String (""" & ASCII.NUL;"); else Set_String (Name_Buffer (1 .. Name_Len - 2) & """;"); end if; *************** package body Bindgen is *** 2566,2572 **** end if; -- Initialize stack limit for the environment task if the stack ! -- check method is stack limit and if stack check is enabled. if Stack_Check_Limits_On_Target and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) --- 2618,2624 ---- end if; -- Initialize stack limit for the environment task if the stack ! -- check method is stack limit and stack check is enabled. if Stack_Check_Limits_On_Target and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) *************** package body Bindgen is *** 2579,2590 **** Gen_Elab_Defs_C; ! -- Imported variable used to track elaboration/finalization phase. ! -- Used only when we have a runtime. if not Suppress_Standard_Library_On_Target then WBI ("extern int __gnat_handler_installed;"); WBI (""); end if; -- Write argv/argc exit status stuff if main program case --- 2631,2651 ---- Gen_Elab_Defs_C; ! -- Imported variables used only when we have a runtime. if not Suppress_Standard_Library_On_Target then + + -- Track elaboration/finalization phase. + WBI ("extern int __gnat_handler_installed;"); WBI (""); + + -- Track feature enable/disable on VMS. + + if OpenVMS_On_Target then + WBI ("extern int __gnat_features_set;"); + WBI (""); + end if; end if; -- Write argv/argc exit status stuff if main program case *************** package body Bindgen is *** 3240,3253 **** for E in Elab_Order.First .. Elab_Order.Last loop Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); ! -- The procedure of looking for specific packages and setting ! -- flags is somewhat dubious, but there isn't a good alternative ! -- at the current time ??? if Name_Buffer (1 .. 19) = "system.os_interface" then With_GNARL := True; end if; if OpenVMS_On_Target and then Name_Buffer (1 .. 5) = "dec%s" then With_DECGNAT := True; end if; --- 3301,3317 ---- for E in Elab_Order.First .. Elab_Order.Last loop Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); ! -- This is not a perfect approach, but is the current protocol ! -- between the run-time and the binder to indicate that tasking ! -- is used: system.os_interface should always be used by any ! -- tasking application. if Name_Buffer (1 .. 19) = "system.os_interface" then With_GNARL := True; end if; + -- Ditto for declib and the "dec" package + if OpenVMS_On_Target and then Name_Buffer (1 .. 5) = "dec%s" then With_DECGNAT := True; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/bindusg.adb gcc-4.4.0/gcc/ada/bindusg.adb *** gcc-4.3.3/gcc/ada/bindusg.adb Thu Dec 13 10:20:52 2007 --- gcc-4.4.0/gcc/ada/bindusg.adb Tue Apr 8 06:57:39 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Bindusg is *** 271,277 **** -- Line for --RTS ! Write_Line (" --RTS=dir specify the default source and " & "object search path"); -- Line for sfile --- 271,277 ---- -- Line for --RTS ! Write_Line (" --RTS=dir Specify the default source and " & "object search path"); -- Line for sfile diff -Nrcpad gcc-4.3.3/gcc/ada/cal.c gcc-4.4.0/gcc/ada/cal.c *** gcc-4.3.3/gcc/ada/cal.c Mon Oct 15 13:54:02 2007 --- gcc-4.4.0/gcc/ada/cal.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * diff -Nrcpad gcc-4.3.3/gcc/ada/casing.adb gcc-4.4.0/gcc/ada/casing.adb *** gcc-4.3.3/gcc/ada/casing.adb Mon Sep 5 07:50:46 2005 --- gcc-4.4.0/gcc/ada/casing.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/casing.ads gcc-4.4.0/gcc/ada/casing.ads *** gcc-4.3.3/gcc/ada/casing.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/casing.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2000 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/ceinfo.adb gcc-4.4.0/gcc/ada/ceinfo.adb *** gcc-4.3.3/gcc/ada/ceinfo.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/ceinfo.adb Fri Feb 20 15:20:38 2009 *************** *** 6,23 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,22 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2008, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING3. If not, go to -- ! -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** procedure CEinfo is *** 43,51 **** Infil : File_Type; Lineno : Natural := 0; - Err : exception; - -- Raised on fatal error - Fieldnm : VString; Accessfunc : VString; Line : VString; --- 42,47 ---- *************** procedure CEinfo is *** 53,77 **** Fields : GNAT.Spitbol.Table_VString.Table (500); -- Maps field names to underlying field access name ! UC : Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); ! Fnam : Pattern := (UC & Break (' ')) * Fieldnm; ! Field_Def : Pattern := "-- " & Fnam & " (" & Break (')') * Accessfunc; ! Field_Ref : Pattern := " -- " & Fnam & Break ('(') & Len (1) & ! Break (')') * Accessfunc; ! Field_Com : Pattern := " -- " & Fnam & Span (' ') & ! (Break (' ') or Rest) * Accessfunc; ! Func_Hedr : Pattern := " function " & Fnam; ! Func_Retn : Pattern := " return " & Break (' ') * Accessfunc; ! Proc_Hedr : Pattern := " procedure " & Fnam; ! Proc_Setf : Pattern := " Set_" & Break (' ') * Accessfunc; procedure Next_Line; -- Read next line trimmed from Infil into Line and bump Lineno --- 49,75 ---- Fields : GNAT.Spitbol.Table_VString.Table (500); -- Maps field names to underlying field access name ! UC : constant Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); ! Fnam : constant Pattern := (UC & Break (' ')) * Fieldnm; ! Field_Def : constant Pattern := ! "-- " & Fnam & " (" & Break (')') * Accessfunc; ! Field_Ref : constant Pattern := ! " -- " & Fnam & Break ('(') & Len (1) & ! Break (')') * Accessfunc; ! Field_Com : constant Pattern := " -- " & Fnam & Span (' ') & ! (Break (' ') or Rest) * Accessfunc; ! Func_Hedr : constant Pattern := " function " & Fnam; ! Func_Retn : constant Pattern := " return " & Break (' ') * Accessfunc; ! Proc_Hedr : constant Pattern := " procedure " & Fnam; ! Proc_Setf : constant Pattern := " Set_" & Break (' ') * Accessfunc; procedure Next_Line; -- Read next line trimmed from Infil into Line and bump Lineno diff -Nrcpad gcc-4.3.3/gcc/ada/checks.adb gcc-4.4.0/gcc/ada/checks.adb *** gcc-4.3.3/gcc/ada/checks.adb Wed Dec 19 16:22:40 2007 --- gcc-4.4.0/gcc/ada/checks.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Checks is *** 450,455 **** --- 450,466 ---- return; end if; + -- No check if accessing the Offset_To_Top component of a dispatch + -- table. They are safe by construction. + + if Present (Etype (P)) + and then RTU_Loaded (Ada_Tags) + and then RTE_Available (RE_Offset_To_Top_Ptr) + and then Etype (P) = RTE (RE_Offset_To_Top_Ptr) + then + return; + end if; + -- Otherwise go ahead and install the check Install_Null_Excluding_Check (P); *************** package body Checks is *** 459,465 **** -- Apply_Accessibility_Check -- ------------------------------- ! procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); Param_Ent : constant Entity_Id := Param_Entity (N); Param_Level : Node_Id; --- 470,480 ---- -- Apply_Accessibility_Check -- ------------------------------- ! procedure Apply_Accessibility_Check ! (N : Node_Id; ! Typ : Entity_Id; ! Insert_Node : Node_Id) ! is Loc : constant Source_Ptr := Sloc (N); Param_Ent : constant Entity_Id := Param_Entity (N); Param_Level : Node_Id; *************** package body Checks is *** 487,496 **** Type_Level := Make_Integer_Literal (Loc, Type_Access_Level (Typ)); ! -- Raise Program_Error if the accessibility level of the the access -- parameter is deeper than the level of the target access type. ! Insert_Action (N, Make_Raise_Program_Error (Loc, Condition => Make_Op_Gt (Loc, --- 502,511 ---- Type_Level := Make_Integer_Literal (Loc, Type_Access_Level (Typ)); ! -- Raise Program_Error if the accessibility level of the access -- parameter is deeper than the level of the target access type. ! Insert_Action (Insert_Node, Make_Raise_Program_Error (Loc, Condition => Make_Op_Gt (Loc, *************** package body Checks is *** 619,625 **** if Obj_Size /= No_Uint and then Exp_Size /= No_Uint and then Obj_Size > Exp_Size ! and then not Warnings_Off (E) then if Address_Clause_Overlay_Warnings then Error_Msg_FE --- 634,640 ---- if Obj_Size /= No_Uint and then Exp_Size /= No_Uint and then Obj_Size > Exp_Size ! and then not Has_Warnings_Off (E) then if Address_Clause_Overlay_Warnings then Error_Msg_FE *************** package body Checks is *** 754,901 **** -- Apply_Arithmetic_Overflow_Check -- ------------------------------------- ! -- This routine is called only if the type is an integer type, and ! -- a software arithmetic overflow check must be performed for op ! -- (add, subtract, multiply). The check is performed only if ! -- Software_Overflow_Checking is enabled and Do_Overflow_Check ! -- is set. In this case we expand the operation into a more complex ! -- sequence of tests that ensures that overflow is properly caught. procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); ! Typ : constant Entity_Id := Etype (N); ! Rtyp : constant Entity_Id := Root_Type (Typ); ! Siz : constant Int := UI_To_Int (Esize (Rtyp)); ! Dsiz : constant Int := Siz * 2; ! Opnod : Node_Id; ! Ctyp : Entity_Id; ! Opnd : Node_Id; ! Cent : RE_Id; begin ! -- Skip this if overflow checks are done in back end, or the overflow ! -- flag is not set anyway, or we are not doing code expansion. ! -- Special case CLI target, where arithmetic overflow checks can be ! -- performed for integer and long_integer ! if Backend_Overflow_Checks_On_Target ! or else (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size) ! or else not Do_Overflow_Check (N) ! or else not Expander_Active then ! return; ! end if; ! -- Otherwise, we generate the full general code for front end overflow ! -- detection, which works by doing arithmetic in a larger type: ! -- x op y ! -- is expanded into ! -- Typ (Checktyp (x) op Checktyp (y)); ! -- where Typ is the type of the original expression, and Checktyp is ! -- an integer type of sufficient length to hold the largest possible ! -- result. ! -- In the case where check type exceeds the size of Long_Long_Integer, ! -- we use a different approach, expanding to: ! -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y))) ! -- where xxx is Add, Multiply or Subtract as appropriate ! -- Find check type if one exists ! if Dsiz <= Standard_Integer_Size then ! Ctyp := Standard_Integer; ! elsif Dsiz <= Standard_Long_Long_Integer_Size then ! Ctyp := Standard_Long_Long_Integer; ! -- No check type exists, use runtime call ! else ! if Nkind (N) = N_Op_Add then ! Cent := RE_Add_With_Ovflo_Check; ! elsif Nkind (N) = N_Op_Multiply then ! Cent := RE_Multiply_With_Ovflo_Check; ! else ! pragma Assert (Nkind (N) = N_Op_Subtract); ! Cent := RE_Subtract_With_Ovflo_Check; end if; ! Rewrite (N, ! OK_Convert_To (Typ, ! Make_Function_Call (Loc, ! Name => New_Reference_To (RTE (Cent), Loc), ! Parameter_Associations => New_List ( ! OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)), ! OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N)))))); ! Analyze_And_Resolve (N, Typ); ! return; ! end if; ! -- If we fall through, we have the case where we do the arithmetic in ! -- the next higher type and get the check by conversion. In these cases ! -- Ctyp is set to the type to be used as the check type. ! Opnod := Relocate_Node (N); ! Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod)); ! Analyze (Opnd); ! Set_Etype (Opnd, Ctyp); ! Set_Analyzed (Opnd, True); ! Set_Left_Opnd (Opnod, Opnd); ! Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod)); ! Analyze (Opnd); ! Set_Etype (Opnd, Ctyp); ! Set_Analyzed (Opnd, True); ! Set_Right_Opnd (Opnod, Opnd); ! -- The type of the operation changes to the base type of the check type, ! -- and we reset the overflow check indication, since clearly no overflow ! -- is possible now that we are using a double length type. We also set ! -- the Analyzed flag to avoid a recursive attempt to expand the node. ! Set_Etype (Opnod, Base_Type (Ctyp)); ! Set_Do_Overflow_Check (Opnod, False); ! Set_Analyzed (Opnod, True); ! -- Now build the outer conversion ! Opnd := OK_Convert_To (Typ, Opnod); ! Analyze (Opnd); ! Set_Etype (Opnd, Typ); ! -- In the discrete type case, we directly generate the range check for ! -- the outer operand. This range check will implement the required ! -- overflow check. ! if Is_Discrete_Type (Typ) then ! Rewrite (N, Opnd); ! Generate_Range_Check (Expression (N), Typ, CE_Overflow_Check_Failed); ! -- For other types, we enable overflow checking on the conversion, ! -- after setting the node as analyzed to prevent recursive attempts ! -- to expand the conversion node. ! else Set_Analyzed (Opnd, True); ! Enable_Overflow_Check (Opnd); ! Rewrite (N, Opnd); ! end if; ! exception ! when RE_Not_Available => ! return; end Apply_Arithmetic_Overflow_Check; ---------------------------- --- 769,1024 ---- -- Apply_Arithmetic_Overflow_Check -- ------------------------------------- ! -- This routine is called only if the type is an integer type, and a ! -- software arithmetic overflow check may be needed for op (add, subtract, ! -- or multiply). This check is performed only if Software_Overflow_Checking ! -- is enabled and Do_Overflow_Check is set. In this case we expand the ! -- operation into a more complex sequence of tests that ensures that ! -- overflow is properly caught. procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); ! Typ : Entity_Id := Etype (N); ! Rtyp : Entity_Id := Root_Type (Typ); begin ! -- An interesting special case. If the arithmetic operation appears as ! -- the operand of a type conversion: ! -- type1 (x op y) ! ! -- and all the following conditions apply: ! ! -- arithmetic operation is for a signed integer type ! -- target type type1 is a static integer subtype ! -- range of x and y are both included in the range of type1 ! -- range of x op y is included in the range of type1 ! -- size of type1 is at least twice the result size of op ! ! -- then we don't do an overflow check in any case, instead we transform ! -- the operation so that we end up with: ! ! -- type1 (type1 (x) op type1 (y)) ! ! -- This avoids intermediate overflow before the conversion. It is ! -- explicitly permitted by RM 3.5.4(24): ! ! -- For the execution of a predefined operation of a signed integer ! -- type, the implementation need not raise Constraint_Error if the ! -- result is outside the base range of the type, so long as the ! -- correct result is produced. ! ! -- It's hard to imagine that any programmer counts on the exception ! -- being raised in this case, and in any case it's wrong coding to ! -- have this expectation, given the RM permission. Furthermore, other ! -- Ada compilers do allow such out of range results. ! ! -- Note that we do this transformation even if overflow checking is ! -- off, since this is precisely about giving the "right" result and ! -- avoiding the need for an overflow check. ! ! if Is_Signed_Integer_Type (Typ) ! and then Nkind (Parent (N)) = N_Type_Conversion then ! declare ! Target_Type : constant Entity_Id := ! Base_Type (Entity (Subtype_Mark (Parent (N)))); ! Llo, Lhi : Uint; ! Rlo, Rhi : Uint; ! LOK, ROK : Boolean; ! Vlo : Uint; ! Vhi : Uint; ! VOK : Boolean; ! Tlo : Uint; ! Thi : Uint; ! begin ! if Is_Integer_Type (Target_Type) ! and then RM_Size (Root_Type (Target_Type)) >= 2 * RM_Size (Rtyp) ! then ! Tlo := Expr_Value (Type_Low_Bound (Target_Type)); ! Thi := Expr_Value (Type_High_Bound (Target_Type)); ! Determine_Range (Left_Opnd (N), LOK, Llo, Lhi); ! Determine_Range (Right_Opnd (N), ROK, Rlo, Rhi); ! if (LOK and ROK) ! and then Tlo <= Llo and then Lhi <= Thi ! and then Tlo <= Rlo and then Rhi <= Thi ! then ! Determine_Range (N, VOK, Vlo, Vhi); ! if VOK and then Tlo <= Vlo and then Vhi <= Thi then ! Rewrite (Left_Opnd (N), ! Make_Type_Conversion (Loc, ! Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), ! Expression => Relocate_Node (Left_Opnd (N)))); ! Rewrite (Right_Opnd (N), ! Make_Type_Conversion (Loc, ! Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), ! Expression => Relocate_Node (Right_Opnd (N)))); ! Set_Etype (N, Target_Type); ! Typ := Target_Type; ! Rtyp := Root_Type (Typ); ! Analyze_And_Resolve (Left_Opnd (N), Target_Type); ! Analyze_And_Resolve (Right_Opnd (N), Target_Type); ! -- Given that the target type is twice the size of the ! -- source type, overflow is now impossible, so we can ! -- safely kill the overflow check and return. ! Set_Do_Overflow_Check (N, False); ! return; ! end if; ! end if; ! end if; ! end; ! end if; ! -- Now see if an overflow check is required ! declare ! Siz : constant Int := UI_To_Int (Esize (Rtyp)); ! Dsiz : constant Int := Siz * 2; ! Opnod : Node_Id; ! Ctyp : Entity_Id; ! Opnd : Node_Id; ! Cent : RE_Id; ! begin ! -- Skip check if back end does overflow checks, or the overflow flag ! -- is not set anyway, or we are not doing code expansion. ! -- Special case CLI target, where arithmetic overflow checks can be ! -- performed for integer and long_integer ! ! if Backend_Overflow_Checks_On_Target ! or else not Do_Overflow_Check (N) ! or else not Expander_Active ! or else ! (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size) ! then ! return; end if; ! -- Otherwise, generate the full general code for front end overflow ! -- detection, which works by doing arithmetic in a larger type: ! -- x op y ! -- is expanded into ! -- Typ (Checktyp (x) op Checktyp (y)); ! -- where Typ is the type of the original expression, and Checktyp is ! -- an integer type of sufficient length to hold the largest possible ! -- result. ! -- If the size of check type exceeds the size of Long_Long_Integer, ! -- we use a different approach, expanding to: ! -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y))) ! -- where xxx is Add, Multiply or Subtract as appropriate ! -- Find check type if one exists ! if Dsiz <= Standard_Integer_Size then ! Ctyp := Standard_Integer; ! elsif Dsiz <= Standard_Long_Long_Integer_Size then ! Ctyp := Standard_Long_Long_Integer; ! -- No check type exists, use runtime call ! else ! if Nkind (N) = N_Op_Add then ! Cent := RE_Add_With_Ovflo_Check; ! elsif Nkind (N) = N_Op_Multiply then ! Cent := RE_Multiply_With_Ovflo_Check; ! else ! pragma Assert (Nkind (N) = N_Op_Subtract); ! Cent := RE_Subtract_With_Ovflo_Check; ! end if; ! Rewrite (N, ! OK_Convert_To (Typ, ! Make_Function_Call (Loc, ! Name => New_Reference_To (RTE (Cent), Loc), ! Parameter_Associations => New_List ( ! OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)), ! OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N)))))); ! ! Analyze_And_Resolve (N, Typ); ! return; ! end if; ! ! -- If we fall through, we have the case where we do the arithmetic ! -- in the next higher type and get the check by conversion. In these ! -- cases Ctyp is set to the type to be used as the check type. ! ! Opnod := Relocate_Node (N); ! ! Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod)); ! ! Analyze (Opnd); ! Set_Etype (Opnd, Ctyp); Set_Analyzed (Opnd, True); ! Set_Left_Opnd (Opnod, Opnd); ! Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod)); ! ! Analyze (Opnd); ! Set_Etype (Opnd, Ctyp); ! Set_Analyzed (Opnd, True); ! Set_Right_Opnd (Opnod, Opnd); ! ! -- The type of the operation changes to the base type of the check ! -- type, and we reset the overflow check indication, since clearly no ! -- overflow is possible now that we are using a double length type. ! -- We also set the Analyzed flag to avoid a recursive attempt to ! -- expand the node. ! ! Set_Etype (Opnod, Base_Type (Ctyp)); ! Set_Do_Overflow_Check (Opnod, False); ! Set_Analyzed (Opnod, True); ! ! -- Now build the outer conversion ! ! Opnd := OK_Convert_To (Typ, Opnod); ! Analyze (Opnd); ! Set_Etype (Opnd, Typ); ! ! -- In the discrete type case, we directly generate the range check ! -- for the outer operand. This range check will implement the ! -- required overflow check. ! ! if Is_Discrete_Type (Typ) then ! Rewrite (N, Opnd); ! Generate_Range_Check ! (Expression (N), Typ, CE_Overflow_Check_Failed); ! ! -- For other types, we enable overflow checking on the conversion, ! -- after setting the node as analyzed to prevent recursive attempts ! -- to expand the conversion node. ! ! else ! Set_Analyzed (Opnd, True); ! Enable_Overflow_Check (Opnd); ! Rewrite (N, Opnd); ! end if; ! ! exception ! when RE_Not_Available => ! return; ! end; end Apply_Arithmetic_Overflow_Check; ---------------------------- *************** package body Checks is *** 973,979 **** Apply_Discriminant_Check (N, Typ); end if; ! -- Apply the the 2005 Null_Excluding check. Note that we do not apply -- this check if the constraint node is illegal, as shown by having -- an error posted. This additional guard prevents cascaded errors -- and compiler aborts on illegal programs involving Ada 2005 checks. --- 1096,1102 ---- Apply_Discriminant_Check (N, Typ); end if; ! -- Apply the 2005 Null_Excluding check. Note that we do not apply -- this check if the constraint node is illegal, as shown by having -- an error posted. This additional guard prevents cascaded errors -- and compiler aborts on illegal programs involving Ada 2005 checks. *************** package body Checks is *** 1239,1250 **** return; end if; ! exit when ! not Is_OK_Static_Expression (ItemS) ! or else ! not Is_OK_Static_Expression (ItemT); ! if Expr_Value (ItemS) /= Expr_Value (ItemT) then if Do_Access then -- needs run-time check. exit; else --- 1362,1384 ---- return; end if; ! -- If the expressions for the discriminants are identical ! -- and it is side-effect free (for now just an entity), ! -- this may be a shared constraint, e.g. from a subtype ! -- without a constraint introduced as a generic actual. ! -- Examine other discriminants if any. ! if ItemS = ItemT ! and then Is_Entity_Name (ItemS) ! then ! null; ! ! elsif not Is_OK_Static_Expression (ItemS) ! or else not Is_OK_Static_Expression (ItemT) ! then ! exit; ! ! elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then if Do_Access then -- needs run-time check. exit; else *************** package body Checks is *** 1499,1509 **** end; end if; ! -- Get the bounds of the target type Ifirst := Expr_Value (LB); Ilast := Expr_Value (HB); -- Check against lower bound if Truncate and then Ifirst > 0 then --- 1633,1668 ---- end; end if; ! -- Get the (static) bounds of the target type Ifirst := Expr_Value (LB); Ilast := Expr_Value (HB); + -- A simple optimization: if the expression is a universal literal, + -- we can do the comparison with the bounds and the conversion to + -- an integer type statically. The range checks are unchanged. + + if Nkind (Ck_Node) = N_Real_Literal + and then Etype (Ck_Node) = Universal_Real + and then Is_Integer_Type (Target_Typ) + and then Nkind (Parent (Ck_Node)) = N_Type_Conversion + then + declare + Int_Val : constant Uint := UR_To_Uint (Realval (Ck_Node)); + + begin + if Int_Val <= Ilast and then Int_Val >= Ifirst then + + -- Conversion is safe + + Rewrite (Parent (Ck_Node), + Make_Integer_Literal (Loc, UI_To_Int (Int_Val))); + Analyze_And_Resolve (Parent (Ck_Node), Target_Typ); + return; + end if; + end; + end if; + -- Check against lower bound if Truncate and then Ifirst > 0 then *************** package body Checks is *** 1883,1889 **** and then Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ) and then ! (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int) or else Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real)) then --- 2042,2050 ---- and then Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ) and then ! (In_Subrange_Of (S_Typ, Target_Typ, ! Assume_Valid => True, ! Fixed_Int => Fixed_Int) or else Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real)) then *************** package body Checks is *** 2190,2196 **** begin if not Overflow_Checks_Suppressed (Target_Base) ! and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK) and then not Float_To_Int then Activate_Overflow_Check (N); --- 2351,2360 ---- begin if not Overflow_Checks_Suppressed (Target_Base) ! and then not ! In_Subrange_Of (Expr_Type, Target_Base, ! Assume_Valid => True, ! Fixed_Int => Conv_OK) and then not Float_To_Int then Activate_Overflow_Check (N); *************** package body Checks is *** 2209,2214 **** --- 2373,2379 ---- end; elsif Comes_From_Source (N) + and then not Discriminant_Checks_Suppressed (Target_Type) and then Is_Record_Type (Target_Type) and then Is_Derived_Type (Target_Type) and then not Is_Tagged_Type (Target_Type) *************** package body Checks is *** 2711,2721 **** -- be applied to a [sub]type that does not exclude null already. elsif Can_Never_Be_Null (Typ) ! ! -- No need to check itypes that have a null exclusion because ! -- they are already examined at their point of creation. ! ! and then not Is_Itype (Typ) then Error_Msg_NE ("`NOT NULL` not allowed (& already excludes null)", --- 2876,2882 ---- -- be applied to a [sub]type that does not exclude null already. elsif Can_Never_Be_Null (Typ) ! and then Comes_From_Source (Typ) then Error_Msg_NE ("`NOT NULL` not allowed (& already excludes null)", *************** package body Checks is *** 2723,2732 **** end if; end if; ! -- Check that null-excluding objects are always initialized if K = N_Object_Declaration and then No (Expression (N)) and then not No_Initialization (N) then -- Add an expression that assigns null. This node is needed by --- 2884,2896 ---- end if; end if; ! -- Check that null-excluding objects are always initialized, except for ! -- deferred constants, for which the expression will appear in the full ! -- declaration. if K = N_Object_Declaration and then No (Expression (N)) + and then not Constant_Present (N) and then not No_Initialization (N) then -- Add an expression that assigns null. This node is needed by *************** package body Checks is *** 2742,2750 **** Reason => CE_Null_Not_Allowed); end if; ! -- Check that a null-excluding component, formal or object is not ! -- being assigned a null value. Otherwise generate a warning message ! -- and replace Expression (N) by a N_Contraint_Error node. if K /= N_Function_Specification then Expr := Expression (N); --- 2906,2914 ---- Reason => CE_Null_Not_Allowed); end if; ! -- Check that a null-excluding component, formal or object is not being ! -- assigned a null value. Otherwise generate a warning message and ! -- replace Expression (N) by an N_Constraint_Error node. if K /= N_Function_Specification then Expr := Expression (N); *************** package body Checks is *** 2862,2868 **** Lo : out Uint; Hi : out Uint) is ! Typ : constant Entity_Id := Etype (N); Lo_Left : Uint; Hi_Left : Uint; --- 3026,3033 ---- Lo : out Uint; Hi : out Uint) is ! Typ : Entity_Id := Etype (N); ! -- Type to use, may get reset to base type for possibly invalid entity Lo_Left : Uint; Hi_Left : Uint; *************** package body Checks is *** 2957,2962 **** --- 3122,3137 ---- -- overflow situation, which is a separate check, we are talking here -- only about the expression value). + -- First step, change to use base type if the expression is an entity + -- which we do not know is valid. + + if Is_Entity_Name (N) + and then not Is_Known_Valid (Entity (N)) + and then not Assume_No_Invalid_Values + then + Typ := Base_Type (Typ); + end if; + -- We use the actual bound unless it is dynamic, in which case use the -- corresponding base type bound if possible. If we can't get a bound -- then we figure we can't determine the range (a peculiar case, that *************** package body Checks is *** 3368,3381 **** -- Nothing to do if the range of the result is known OK. We skip this -- for conversions, since the caller already did the check, and in any -- case the condition for deleting the check for a type conversion is ! -- different in any case. if Nkind (N) /= N_Type_Conversion then Determine_Range (N, OK, Lo, Hi); ! -- Note in the test below that we assume that if a bound of the ! -- range is equal to that of the type. That's not quite accurate ! -- but we do this for the following reasons: -- a) The way that Determine_Range works, it will typically report -- the bounds of the value as being equal to the bounds of the --- 3543,3556 ---- -- Nothing to do if the range of the result is known OK. We skip this -- for conversions, since the caller already did the check, and in any -- case the condition for deleting the check for a type conversion is ! -- different. if Nkind (N) /= N_Type_Conversion then Determine_Range (N, OK, Lo, Hi); ! -- Note in the test below that we assume that the range is not OK ! -- if a bound of the range is equal to that of the type. That's not ! -- quite accurate but we do this for the following reasons: -- a) The way that Determine_Range works, it will typically report -- the bounds of the value as being equal to the bounds of the *************** package body Checks is *** 3385,3391 **** -- b) It is very unusual to have a situation in which this would -- generate an unnecessary overflow check (an example would be -- a subtype with a range 0 .. Integer'Last - 1 to which the ! -- literal value one is added. -- c) The alternative is a lot of special casing in this routine -- which would partially duplicate Determine_Range processing. --- 3560,3566 ---- -- b) It is very unusual to have a situation in which this would -- generate an unnecessary overflow check (an example would be -- a subtype with a range 0 .. Integer'Last - 1 to which the ! -- literal value one is added). -- c) The alternative is a lot of special casing in this routine -- which would partially duplicate Determine_Range processing. *************** package body Checks is *** 3890,3895 **** --- 4065,4076 ---- -- If we fall through, a validity check is required Insert_Valid_Check (Expr); + + if Is_Entity_Name (Expr) + and then Safe_To_Capture_Value (Expr, Entity (Expr)) + then + Set_Is_Known_Valid (Entity (Expr)); + end if; end Ensure_Valid; ---------------------- *************** package body Checks is *** 4115,4126 **** -- appropriate one for our purposes. if (Ekind (Ent) = E_Variable ! or else ! Ekind (Ent) = E_Constant ! or else ! Ekind (Ent) = E_Loop_Parameter ! or else ! Ekind (Ent) = E_In_Parameter) and then not Is_Library_Level_Entity (Ent) then Entry_OK := True; --- 4296,4302 ---- -- appropriate one for our purposes. if (Ekind (Ent) = E_Variable ! or else Is_Constant_Object (Ent)) and then not Is_Library_Level_Entity (Ent) then Entry_OK := True; *************** package body Checks is *** 4365,4371 **** Duplicate_Subexpr_Move_Checks (Sub)), Right_Opnd => Make_Attribute_Reference (Loc, ! Prefix => Duplicate_Subexpr_Move_Checks (A), Attribute_Name => Name_Range, Expressions => Num)), Reason => CE_Index_Check_Failed)); --- 4541,4548 ---- Duplicate_Subexpr_Move_Checks (Sub)), Right_Opnd => Make_Attribute_Reference (Loc, ! Prefix => ! Duplicate_Subexpr_Move_Checks (A, Name_Req => True), Attribute_Name => Name_Range, Expressions => Num)), Reason => CE_Index_Check_Failed)); *************** package body Checks is *** 4400,4406 **** -- case the literal has already been labeled as having the subtype of -- the target. ! if In_Subrange_Of (Source_Type, Target_Type) and then not (Nkind (N) = N_Integer_Literal or else --- 4577,4583 ---- -- case the literal has already been labeled as having the subtype of -- the target. ! if In_Subrange_Of (Source_Type, Target_Type, Assume_Valid => True) and then not (Nkind (N) = N_Integer_Literal or else *************** package body Checks is *** 4455,4461 **** -- The conversions will always work and need no check ! elsif In_Subrange_Of (Target_Type, Source_Base_Type) then Insert_Action (N, Make_Raise_Constraint_Error (Loc, Condition => --- 4632,4640 ---- -- The conversions will always work and need no check ! elsif In_Subrange_Of ! (Target_Type, Source_Base_Type, Assume_Valid => True) ! then Insert_Action (N, Make_Raise_Constraint_Error (Loc, Condition => *************** package body Checks is *** 4487,4493 **** -- If that is the case, we can freely convert the source to the target, -- and then test the target result against the bounds. ! elsif In_Subrange_Of (Source_Type, Target_Base_Type) then -- We make a temporary to hold the value of the converted value -- (converted to the base type), and then we will do the test against --- 4666,4674 ---- -- If that is the case, we can freely convert the source to the target, -- and then test the target result against the bounds. ! elsif In_Subrange_Of ! (Source_Type, Target_Base_Type, Assume_Valid => True) ! then -- We make a temporary to hold the value of the converted value -- (converted to the base type), and then we will do the test against *************** package body Checks is *** 5141,5150 **** -- If known to be null, here is where we generate a compile time check if Known_Null (N) then ! Apply_Compile_Time_Constraint_Error ! (N, ! "null value not allowed here?", ! CE_Access_Check_Failed); Mark_Non_Null; return; end if; --- 5322,5341 ---- -- If known to be null, here is where we generate a compile time check if Known_Null (N) then ! ! -- Avoid generating warning message inside init procs ! ! if not Inside_Init_Proc then ! Apply_Compile_Time_Constraint_Error ! (N, ! "null value not allowed here?", ! CE_Access_Check_Failed); ! else ! Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, ! Reason => CE_Access_Check_Failed)); ! end if; ! Mark_Non_Null; return; end if; *************** package body Checks is *** 6640,6646 **** -- range of the target type. else ! if not In_Subrange_Of (S_Typ, T_Typ) then Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); end if; end if; --- 6831,6837 ---- -- range of the target type. else ! if not In_Subrange_Of (S_Typ, T_Typ, Assume_Valid => True) then Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); end if; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/checks.ads gcc-4.4.0/gcc/ada/checks.ads *** gcc-4.3.3/gcc/ada/checks.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/checks.ads Tue Aug 5 09:28:03 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Checks is *** 102,112 **** -- Determines whether an expression node requires a runtime access -- check and if so inserts the appropriate run-time check. ! procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id); -- Given a name N denoting an access parameter, emits a run-time -- accessibility check (if necessary), checking that the level of -- the object denoted by the access parameter is not deeper than the -- level of the type Typ. Program_Error is raised if the check fails. procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id); -- E is the entity for an object which has an address clause. If checks --- 102,116 ---- -- Determines whether an expression node requires a runtime access -- check and if so inserts the appropriate run-time check. ! procedure Apply_Accessibility_Check ! (N : Node_Id; ! Typ : Entity_Id; ! Insert_Node : Node_Id); -- Given a name N denoting an access parameter, emits a run-time -- accessibility check (if necessary), checking that the level of -- the object denoted by the access parameter is not deeper than the -- level of the type Typ. Program_Error is raised if the check fails. + -- Insert_Node indicates the node where the check should be inserted. procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id); -- E is the entity for an object which has an address clause. If checks *************** package Checks is *** 132,138 **** No_Sliding : Boolean := False); -- Top-level procedure, calls all the others depending on the class of Typ. -- Checks that expression N verifies the constraint of type Typ. No_Sliding ! -- is only relevant for constrained array types, id set to true, it -- checks that indexes are in range. procedure Apply_Discriminant_Check --- 136,142 ---- No_Sliding : Boolean := False); -- Top-level procedure, calls all the others depending on the class of Typ. -- Checks that expression N verifies the constraint of type Typ. No_Sliding ! -- is only relevant for constrained array types, if set to True, it -- checks that indexes are in range. procedure Apply_Discriminant_Check *************** package Checks is *** 211,217 **** -- by the back end, but many are done by the front end. -- Overflow checks are similarly controlled by the Do_Overflow_Check flag. ! -- The difference here is that if Backend_Overflow_Checks is is -- (Backend_Overflow_Checks_On_Target set False), then the actual overflow -- checks are generated by the front end, but if back end overflow checks -- are active (Backend_Overflow_Checks_On_Target set True), then the back --- 215,221 ---- -- by the back end, but many are done by the front end. -- Overflow checks are similarly controlled by the Do_Overflow_Check flag. ! -- The difference here is that if back end overflow checks are inactive -- (Backend_Overflow_Checks_On_Target set False), then the actual overflow -- checks are generated by the front end, but if back end overflow checks -- are active (Backend_Overflow_Checks_On_Target set True), then the back diff -Nrcpad gcc-4.3.3/gcc/ada/cio.c gcc-4.4.0/gcc/ada/cio.c *** gcc-4.3.3/gcc/ada/cio.c Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/cio.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2005, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** *** 56,61 **** --- 55,65 ---- #undef getchar #endif + #ifdef RTX + #include + #include + #endif + int get_char (void) { *************** get_int (void) *** 78,104 **** --- 82,124 ---- void put_int (int x) { + #ifdef RTX + RtPrintf ("%d", x); + #else /* Use fprintf rather than printf, since the latter is unbuffered on vxworks */ fprintf (stdout, "%d", x); + #endif } void put_int_stderr (int x) { + #ifdef RTX + RtPrintf ("%d", x); + #else fprintf (stderr, "%d", x); + #endif } void put_char (int c) { + #ifdef RTX + RtPrintf ("%c", c); + #else putchar (c); + #endif } void put_char_stderr (int c) { + #ifdef RTX + RtPrintf ("%c", c); + #else fputc (c, stderr); + #endif } #ifdef __vxworks diff -Nrcpad gcc-4.3.3/gcc/ada/clean.adb gcc-4.4.0/gcc/ada/clean.adb *** gcc-4.3.3/gcc/ada/clean.adb Thu Dec 13 10:23:29 2007 --- gcc-4.4.0/gcc/ada/clean.adb Thu Jul 31 08:18:53 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2008, 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- -- *************** package body Clean is *** 346,352 **** -- The name of the archive dependency file for this project Obj_Dir : constant String := ! Get_Name_String (Data.Display_Object_Dir); begin Change_Dir (Obj_Dir); --- 346,352 ---- -- The name of the archive dependency file for this project Obj_Dir : constant String := ! Get_Name_String (Data.Object_Directory.Display_Name); begin Change_Dir (Obj_Dir); *************** package body Clean is *** 551,560 **** Unit : Unit_Data; begin ! if Data.Library and then Data.Library_Src_Dir /= No_Path then declare Directory : constant String := ! Get_Name_String (Data.Display_Library_Src_Dir); begin Change_Dir (Directory); --- 551,560 ---- Unit : Unit_Data; begin ! if Data.Library and then Data.Library_Src_Dir /= No_Path_Information then declare Directory : constant String := ! Get_Name_String (Data.Library_Src_Dir.Display_Name); begin Change_Dir (Directory); *************** package body Clean is *** 663,672 **** declare Lib_Directory : constant String := ! Get_Name_String (Data.Display_Library_Dir); Lib_ALI_Directory : constant String := Get_Name_String ! (Data.Display_Library_ALI_Dir); begin Canonical_Case_File_Name (Archive_Name); --- 663,673 ---- declare Lib_Directory : constant String := ! Get_Name_String ! (Data.Library_Dir.Display_Name); Lib_ALI_Directory : constant String := Get_Name_String ! (Data.Library_ALI_Dir.Display_Name); begin Canonical_Case_File_Name (Archive_Name); *************** package body Clean is *** 825,833 **** Index2 : Int; Lib_File : File_Name_Type; - Source_Id : Other_Source_Id; - Source : Other_Source; - Global_Archive : Boolean := False; begin --- 826,831 ---- *************** package body Clean is *** 863,872 **** Processed_Projects.Increment_Last; Processed_Projects.Table (Processed_Projects.Last) := Project; ! if Data.Object_Directory /= No_Path then declare Obj_Dir : constant String := ! Get_Name_String (Data.Display_Object_Dir); begin Change_Dir (Obj_Dir); --- 861,871 ---- Processed_Projects.Increment_Last; Processed_Projects.Table (Processed_Projects.Last) := Project; ! if Data.Object_Directory /= No_Path_Information then declare Obj_Dir : constant String := ! Get_Name_String ! (Data.Object_Directory.Display_Name); begin Change_Dir (Obj_Dir); *************** package body Clean is *** 879,885 **** -- Source_Dirs or Source_Files is specified as an empty list, -- so always look for Ada units in extending projects. ! if Data.Langs (Ada_Language_Index) or else Data.Extends /= No_Project then for Unit in Unit_Table.First .. --- 878,884 ---- -- Source_Dirs or Source_Files is specified as an empty list, -- so always look for Ada units in extending projects. ! if Data.Ada_Sources_Present or else Data.Extends /= No_Project then for Unit in Unit_Table.First .. *************** package body Clean is *** 1042,1081 **** end if; end if; - if Data.Other_Sources_Present then - - -- There is non-Ada code: delete the object files and - -- the dependency files if they exist. - - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := - Project_Tree.Other_Sources.Table (Source_Id); - - if Is_Regular_File - (Get_Name_String (Source.Object_Name)) - then - Delete (Obj_Dir, Get_Name_String (Source.Object_Name)); - end if; - - if - Is_Regular_File (Get_Name_String (Source.Dep_Name)) - then - Delete (Obj_Dir, Get_Name_String (Source.Dep_Name)); - end if; - - Source_Id := Source.Next; - end loop; - - -- If it is a library with only non Ada sources, delete - -- the fake archive and the dependency file, if they exist. - - if Data.Library - and then not Data.Langs (Ada_Language_Index) - then - Clean_Archive (Project, Global => False); - end if; - end if; end; end if; --- 1041,1046 ---- *************** package body Clean is *** 1089,1104 **** if not Compile_Only then Clean_Library_Directory (Project); ! if Data.Library_Src_Dir /= No_Path then Clean_Interface_Copy_Directory (Project); end if; end if; if Data.Standalone_Library and then ! Data.Object_Directory /= No_Path then Delete_Binder_Generated_Files ! (Get_Name_String (Data.Display_Object_Dir), File_Name_Type (Data.Library_Name)); end if; end if; --- 1054,1069 ---- if not Compile_Only then Clean_Library_Directory (Project); ! if Data.Library_Src_Dir /= No_Path_Information then Clean_Interface_Copy_Directory (Project); end if; end if; if Data.Standalone_Library and then ! Data.Object_Directory /= No_Path_Information then Delete_Binder_Generated_Files ! (Get_Name_String (Data.Object_Directory.Display_Name), File_Name_Type (Data.Library_Name)); end if; end if; *************** package body Clean is *** 1156,1165 **** -- The executables are deleted only if switch -c is not specified ! if Project = Main_Project and then Data.Exec_Directory /= No_Path then declare Exec_Dir : constant String := ! Get_Name_String (Data.Display_Exec_Dir); begin Change_Dir (Exec_Dir); --- 1121,1132 ---- -- The executables are deleted only if switch -c is not specified ! if Project = Main_Project ! and then Data.Exec_Directory /= No_Path_Information ! then declare Exec_Dir : constant String := ! Get_Name_String (Data.Exec_Directory.Display_Name); begin Change_Dir (Exec_Dir); *************** package body Clean is *** 1193,1201 **** end; end if; ! if Data.Object_Directory /= No_Path then Delete_Binder_Generated_Files ! (Get_Name_String (Data.Display_Object_Dir), Strip_Suffix (Main_Source_File)); end if; end loop; --- 1160,1168 ---- end; end if; ! if Data.Object_Directory /= No_Path_Information then Delete_Binder_Generated_Files ! (Get_Name_String (Data.Object_Directory.Display_Name), Strip_Suffix (Main_Source_File)); end if; end loop; *************** package body Clean is *** 1669,1674 **** --- 1636,1653 ---- end if; case Arg (2) is + when '-' => + if Arg'Length > Subdirs_Option'Length and then + Arg (1 .. Subdirs_Option'Length) = Subdirs_Option + then + Subdirs := + new String' + (Arg (Subdirs_Option'Length + 1 .. Arg'Last)); + + else + Bad_Argument; + end if; + when 'a' => if Arg'Length < 4 then Bad_Argument; *************** package body Clean is *** 1725,1730 **** --- 1704,1717 ---- end; end if; + when 'e' => + if Arg = "-eL" then + Follow_Links_For_Files := True; + + else + Bad_Argument; + end if; + when 'f' => Force_Deletions := True; *************** package body Clean is *** 1954,1961 **** --- 1941,1953 ---- Put_Line (" names may be omitted if -P is specified"); New_Line; + Put_Line (" --subdirs=dir real obj/lib/exec dirs are subdirs"); + New_Line; + Put_Line (" -c Only delete compiler generated files"); Put_Line (" -D dir Specify dir as the object library"); + Put_Line (" -eL Follow symbolic links when processing " & + "project files"); Put_Line (" -f Force deletions of unwritable files"); Put_Line (" -F Full project path name " & "in brief error messages"); diff -Nrcpad gcc-4.3.3/gcc/ada/comperr.adb gcc-4.4.0/gcc/ada/comperr.adb *** gcc-4.3.3/gcc/ada/comperr.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/comperr.adb Tue Apr 8 06:58:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Output; use Output; *** 39,44 **** --- 39,45 ---- with Sinput; use Sinput; with Sprint; use Sprint; with Sdefault; use Sdefault; + with Targparm; use Targparm; with Treepr; use Treepr; with Types; use Types; *************** package body Comperr is *** 112,117 **** --- 113,143 ---- Abort_In_Progress := True; + -- Generate a "standard" error message instead of a bug box in case of + -- .NET compiler, since we do not support all constructs of the + -- language. Of course ideally, we should detect this before bombing + -- on e.g. an assertion error, but in practice most of these bombs + -- are due to a legitimate case of a construct not being supported (in + -- a sense they all are, since for sure we are not supporting something + -- if we bomb!) By giving this message, we provide a more reasonable + -- practical interface, since giving scary bug boxes on unsupported + -- features is definitely not helpful. + + -- Note that the call to Error_Msg_N below sets Serious_Errors_Detected + -- to 1, so we use the regular mechanism below in order to display a + -- "compilation abandoned" message and exit, so we still know we have + -- this case (and -gnatdk can still be used to get the bug box). + + if VM_Target = CLI_Target + and then Serious_Errors_Detected = 0 + and then not Debug_Flag_K + and then Sloc (Current_Error_Node) > No_Location + then + Error_Msg_N + ("unsupported construct in this context", + Current_Error_Node); + end if; + -- If any errors have already occurred, then we guess that the abort -- may well be caused by previous errors, and we don't make too much -- fuss about it, since we want to let programmer fix the errors first. diff -Nrcpad gcc-4.3.3/gcc/ada/config-lang.in gcc-4.4.0/gcc/ada/config-lang.in *** gcc-4.3.3/gcc/ada/config-lang.in Mon Sep 3 10:06:52 2007 --- gcc-4.4.0/gcc/ada/config-lang.in Thu Apr 9 23:23:07 2009 *************** *** 1,5 **** # Top level configure fragment for GNU Ada (GNAT). ! # Copyright (C) 1994-2003, 2007 Free Software Foundation, Inc. #This file is part of GCC. --- 1,5 ---- # Top level configure fragment for GNU Ada (GNAT). ! # Copyright (C) 1994-2009 Free Software Foundation, Inc. #This file is part of GCC. *************** *** 17,41 **** #along with GCC; see the file COPYING3. If not see #. - # Configure looks for the existence of this file to auto-config each language. - # We define several parameters used by configure: - # - # language - name of language as it would appear in $(LANGUAGES) - # boot_language - "yes" if we need to build this language in stage1 - # compilers - value to add to $(COMPILERS) - language="ada" ! boot_language=yes ! boot_language_boot_flags='ADAFLAGS="$(BOOT_ADAFLAGS)"' ! ! compilers="gnat1\$(exeext)" ! ! gtfiles="\$(srcdir)/ada/ada-tree.h \$(srcdir)/ada/gigi.h \$(srcdir)/ada/decl.c \$(srcdir)/ada/trans.c \$(srcdir)/ada/utils.c" ! ! outputs=ada/Makefile ! ! target_libs="target-libada" ! lang_dirs="gnattools" ! # Ada will not work until the front end starts emitting GIMPLE trees. ! build_by_default=no --- 17,27 ---- #along with GCC; see the file COPYING3. If not see #. language="ada" ! gcc_subdir="ada/gcc-interface" ! if [ -f ${srcdir}/gcc/ada/gcc-interface/config-lang.in ]; then ! . ${srcdir}/gcc/ada/gcc-interface/config-lang.in ! else ! . ${srcdir}/ada/gcc-interface/config-lang.in ! fi diff -Nrcpad gcc-4.3.3/gcc/ada/csets.adb gcc-4.4.0/gcc/ada/csets.adb *** gcc-4.3.3/gcc/ada/csets.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/csets.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/csets.ads gcc-4.4.0/gcc/ada/csets.ads *** gcc-4.3.3/gcc/ada/csets.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/csets.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/csinfo.adb gcc-4.4.0/gcc/ada/csinfo.adb *** gcc-4.3.3/gcc/ada/csinfo.adb Mon Sep 5 08:12:54 2005 --- gcc-4.4.0/gcc/ada/csinfo.adb Mon May 26 11:43:27 2008 *************** *** 6,23 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,22 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING3. If not, go to -- ! -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** procedure CSinfo is *** 55,61 **** Done : exception; -- Raised after error is found to terminate run ! WSP : Pattern := Span (' ' & ASCII.HT); Fields : TV.Table (300); Fields1 : TV.Table (300); --- 54,60 ---- Done : exception; -- Raised after error is found to terminate run ! WSP : constant Pattern := Span (' ' & ASCII.HT); Fields : TV.Table (300); Fields1 : TV.Table (300); *************** procedure CSinfo is *** 87,136 **** Flags : TV.Table (20); -- Maps flag numbers to letters ! N_Fields : Pattern := BreakX ("JL"); ! E_Fields : Pattern := BreakX ("5EFGHIJLOP"); ! U_Fields : Pattern := BreakX ("1345EFGHIJKLOPQ"); ! B_Fields : Pattern := BreakX ("12345EFGHIJKLOPQ"); Line : VString; Bad : Boolean; ! Field : VString := Nul; Fields_Used : VString := Nul; ! Name : VString := Nul; ! Next : VString := Nul; Node : VString := Nul; Ref : VString := Nul; ! Synonym : VString := Nul; ! Nxtref : VString := Nul; Which_Field : aliased VString := Nul; ! Node_Search : Pattern := WSP & "-- N_" & Rest * Node; ! Break_Punc : Pattern := Break (" .,"); ! Plus_Binary : Pattern := WSP & "-- plus fields for binary operator"; ! Plus_Unary : Pattern := WSP & "-- plus fields for unary operator"; ! Plus_Expr : Pattern := WSP & "-- plus fields for expression"; ! Break_Syn : Pattern := WSP & "-- " & Break (' ') * Synonym & ! " (" & Break (')') * Field; ! Break_Field : Pattern := BreakX ('-') * Field; ! Get_Field : Pattern := BreakX (Decimal_Digit_Set) & ! Span (Decimal_Digit_Set) * Which_Field; ! Break_WFld : Pattern := Break (Which_Field'Access); ! Get_Funcsyn : Pattern := WSP & "function " & Rest * Synonym; ! Extr_Field : Pattern := BreakX ('-') & "-- " & Rest * Field; ! Get_Procsyn : Pattern := WSP & "procedure Set_" & Rest * Synonym; ! Get_Inline : Pattern := WSP & "pragma Inline (" & Break (')') * Name; ! Set_Name : Pattern := "Set_" & Rest * Name; ! Func_Rest : Pattern := " function " & Rest * Synonym; ! Get_Nxtref : Pattern := Break (',') * Nxtref & ','; ! Test_Syn : Pattern := Break ('=') & "= N_" & ! (Break (" ,)") or Rest) * Next; ! Chop_Comma : Pattern := BreakX (',') * Next; ! Return_Fld : Pattern := WSP & "return " & Break (' ') * Field; ! Set_Syn : Pattern := " procedure Set_" & Rest * Synonym; ! Set_Fld : Pattern := WSP & "Set_" & Break (' ') * Field & " (N, Val)"; ! Break_With : Pattern := Break ('_') ** Field & "_With_Parent"; type VStringA is array (Natural range <>) of VString; --- 86,141 ---- Flags : TV.Table (20); -- Maps flag numbers to letters ! N_Fields : constant Pattern := BreakX ("JL"); ! E_Fields : constant Pattern := BreakX ("5EFGHIJLOP"); ! U_Fields : constant Pattern := BreakX ("1345EFGHIJKLOPQ"); ! B_Fields : constant Pattern := BreakX ("12345EFGHIJKLOPQ"); Line : VString; Bad : Boolean; ! Field : constant VString := Nul; Fields_Used : VString := Nul; ! Name : constant VString := Nul; ! Next : constant VString := Nul; Node : VString := Nul; Ref : VString := Nul; ! Synonym : constant VString := Nul; ! Nxtref : constant VString := Nul; Which_Field : aliased VString := Nul; ! Node_Search : constant Pattern := WSP & "-- N_" & Rest * Node; ! Break_Punc : constant Pattern := Break (" .,"); ! Plus_Binary : constant Pattern := WSP ! & "-- plus fields for binary operator"; ! Plus_Unary : constant Pattern := WSP ! & "-- plus fields for unary operator"; ! Plus_Expr : constant Pattern := WSP ! & "-- plus fields for expression"; ! Break_Syn : constant Pattern := WSP & "-- " ! & Break (' ') * Synonym ! & " (" & Break (')') * Field; ! Break_Field : constant Pattern := BreakX ('-') * Field; ! Get_Field : constant Pattern := BreakX (Decimal_Digit_Set) ! & Span (Decimal_Digit_Set) * Which_Field; ! Break_WFld : constant Pattern := Break (Which_Field'Access); ! Get_Funcsyn : constant Pattern := WSP & "function " & Rest * Synonym; ! Extr_Field : constant Pattern := BreakX ('-') & "-- " & Rest * Field; ! Get_Procsyn : constant Pattern := WSP & "procedure Set_" & Rest * Synonym; ! Get_Inline : constant Pattern := WSP & "pragma Inline (" ! & Break (')') * Name; ! Set_Name : constant Pattern := "Set_" & Rest * Name; ! Func_Rest : constant Pattern := " function " & Rest * Synonym; ! Get_Nxtref : constant Pattern := Break (',') * Nxtref & ','; ! Test_Syn : constant Pattern := Break ('=') & "= N_" ! & (Break (" ,)") or Rest) * Next; ! Chop_Comma : constant Pattern := BreakX (',') * Next; ! Return_Fld : constant Pattern := WSP & "return " & Break (' ') * Field; ! Set_Syn : constant Pattern := " procedure Set_" & Rest * Synonym; ! Set_Fld : constant Pattern := WSP & "Set_" & Break (' ') * Field ! & " (N, Val)"; ! Break_With : constant Pattern := Break ('_') ** Field & "_With_Parent"; type VStringA is array (Natural range <>) of VString; *************** begin *** 187,195 **** Set (Flags, "17", V ("Q")); Set (Flags, "18", V ("R")); ! -- Special fields table. The following fields are not recorded or checked ! -- by Csinfo, since they are specially handled. This means that both the ! -- field definitions, and the corresponding subprograms are ignored. Set (Special, "Analyzed", True); Set (Special, "Assignment_OK", True); --- 192,200 ---- Set (Flags, "17", V ("Q")); Set (Flags, "18", V ("R")); ! -- Special fields table. The following names are not recorded or checked ! -- by Csinfo, since they are specially handled. This means that any field ! -- definition or subprogram with a matching name is ignored. Set (Special, "Analyzed", True); Set (Special, "Assignment_OK", True); *************** begin *** 214,220 **** --- 219,227 ---- Set (Special, "Is_Static_Expression", True); Set (Special, "Left_Opnd", True); Set (Special, "Must_Not_Freeze", True); + Set (Special, "Nkind_In", True); Set (Special, "Parens", True); + Set (Special, "Pragma_Name", True); Set (Special, "Raises_Constraint_Error", True); Set (Special, "Right_Opnd", True); *************** begin *** 334,340 **** Put_Line ("Check for missing functions"); declare ! List : TV.Table_Array := Convert_To_Array (Fields1); begin if List'Length > 0 then --- 341,347 ---- Put_Line ("Check for missing functions"); declare ! List : constant TV.Table_Array := Convert_To_Array (Fields1); begin if List'Length > 0 then *************** begin *** 385,391 **** Put_Line ("Check for missing set procedures"); declare ! List : TV.Table_Array := Convert_To_Array (Fields1); begin if List'Length > 0 then --- 392,398 ---- Put_Line ("Check for missing set procedures"); declare ! List : constant TV.Table_Array := Convert_To_Array (Fields1); begin if List'Length > 0 then *************** begin *** 424,430 **** Put_Line ("Check no pragma Inlines were omitted"); declare ! List : TV.Table_Array := Convert_To_Array (Fields); Nxt : VString := Nul; begin --- 431,437 ---- Put_Line ("Check no pragma Inlines were omitted"); declare ! List : constant TV.Table_Array := Convert_To_Array (Fields); Nxt : VString := Nul; begin *************** begin *** 523,529 **** Put_Line ("Check for missing functions in body"); declare ! List : TV.Table_Array := Convert_To_Array (Refs); begin if List'Length /= 0 then --- 530,536 ---- Put_Line ("Check for missing functions in body"); declare ! List : constant TV.Table_Array := Convert_To_Array (Refs); begin if List'Length /= 0 then *************** begin *** 613,619 **** Put_Line ("Check for missing set procedures in body"); declare ! List : TV.Table_Array := Convert_To_Array (Fields1); begin if List'Length /= 0 then --- 620,626 ---- Put_Line ("Check for missing set procedures in body"); declare ! List : constant TV.Table_Array := Convert_To_Array (Fields1); begin if List'Length /= 0 then diff -Nrcpad gcc-4.3.3/gcc/ada/cstand.adb gcc-4.4.0/gcc/ada/cstand.adb *** gcc-4.3.3/gcc/ada/cstand.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/cstand.adb Tue May 20 12:44:33 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body CStand is *** 379,391 **** Set_Is_Pure (Standard_Standard); Set_Is_Compilation_Unit (Standard_Standard); ! -- Create type declaration nodes for standard types for S in S_Types loop ! Decl := New_Node (N_Full_Type_Declaration, Stloc); ! Set_Defining_Identifier (Decl, Standard_Entity (S)); Set_Is_Frozen (Standard_Entity (S)); Set_Is_Public (Standard_Entity (S)); Append (Decl, Decl_S); end loop; --- 379,404 ---- Set_Is_Pure (Standard_Standard); Set_Is_Compilation_Unit (Standard_Standard); ! -- Create type/subtype declaration nodes for standard types for S in S_Types loop ! ! -- Subtype declaration case ! ! if S = S_Natural or else S = S_Positive then ! Decl := New_Node (N_Subtype_Declaration, Stloc); ! Set_Subtype_Indication (Decl, ! New_Occurrence_Of (Standard_Integer, Stloc)); ! ! -- Full type declaration case ! ! else ! Decl := New_Node (N_Full_Type_Declaration, Stloc); ! end if; ! Set_Is_Frozen (Standard_Entity (S)); Set_Is_Public (Standard_Entity (S)); + Set_Defining_Identifier (Decl, Standard_Entity (S)); Append (Decl, Decl_S); end loop; *************** package body CStand is *** 768,780 **** Set_Entity (E_Id, Standard_Positive); Set_Etype (E_Id, Standard_Positive); ! -- Create subtype declaration for Natural ! ! Decl := New_Node (N_Subtype_Declaration, Stloc); ! Set_Defining_Identifier (Decl, Standard_Natural); ! Set_Subtype_Indication (Decl, ! New_Occurrence_Of (Standard_Integer, Stloc)); ! Append (Decl, Decl_S); Set_Ekind (Standard_Natural, E_Signed_Integer_Subtype); Set_Etype (Standard_Natural, Base_Type (Standard_Integer)); --- 781,787 ---- Set_Entity (E_Id, Standard_Positive); Set_Etype (E_Id, Standard_Positive); ! -- Setup entity for Naturalend Create_Standard; Set_Ekind (Standard_Natural, E_Signed_Integer_Subtype); Set_Etype (Standard_Natural, Base_Type (Standard_Integer)); *************** package body CStand is *** 788,803 **** Lb => Uint_0, Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); Set_Is_Constrained (Standard_Natural); - Set_Is_Frozen (Standard_Natural); - Set_Is_Public (Standard_Natural); ! -- Create subtype declaration for Positive ! ! Decl := New_Node (N_Subtype_Declaration, Stloc); ! Set_Defining_Identifier (Decl, Standard_Positive); ! Set_Subtype_Indication (Decl, ! New_Occurrence_Of (Standard_Integer, Stloc)); ! Append (Decl, Decl_S); Set_Ekind (Standard_Positive, E_Signed_Integer_Subtype); Set_Etype (Standard_Positive, Base_Type (Standard_Integer)); --- 795,802 ---- Lb => Uint_0, Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); Set_Is_Constrained (Standard_Natural); ! -- Setup entity for Positive Set_Ekind (Standard_Positive, E_Signed_Integer_Subtype); Set_Etype (Standard_Positive, Base_Type (Standard_Integer)); *************** package body CStand is *** 812,819 **** Lb => Uint_1, Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); Set_Is_Constrained (Standard_Positive); - Set_Is_Frozen (Standard_Positive); - Set_Is_Public (Standard_Positive); -- Create declaration for package ASCII --- 811,816 ---- *************** package body CStand is *** 1730,1736 **** Write_Eol; P ("package Standard is"); ! P ("pragma Pure(Standard);"); Write_Eol; P (" type Boolean is (False, True);"); --- 1727,1733 ---- Write_Eol; P ("package Standard is"); ! P ("pragma Pure (Standard);"); Write_Eol; P (" type Boolean is (False, True);"); *************** package body CStand is *** 1832,1838 **** Write_Eol; P (" type Wide_Wide_Character is (...)"); ! Write_Str (" for Wide_Character'Size use "); Write_Int (Standard_Wide_Wide_Character_Size); P (";"); P (" -- See RM A.1(36) for details of this type"); --- 1829,1835 ---- Write_Eol; P (" type Wide_Wide_Character is (...)"); ! Write_Str (" for Wide_Wide_Character'Size use "); Write_Int (Standard_Wide_Wide_Character_Size); P (";"); P (" -- See RM A.1(36) for details of this type"); diff -Nrcpad gcc-4.3.3/gcc/ada/cstreams.c gcc-4.4.0/gcc/ada/cstreams.c *** gcc-4.3.3/gcc/ada/cstreams.c Tue Aug 14 08:44:42 2007 --- gcc-4.4.0/gcc/ada/cstreams.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * Auxiliary C functions for Interfaces.C.Streams * * * ! * Copyright (C) 1992-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * Auxiliary C functions for Interfaces.C.Streams * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** __gnat_constant_stdout (void) *** 156,162 **** char * __gnat_full_name (char *nam, char *buffer) { ! #if defined(__EMX__) || defined (__MINGW32__) /* If this is a device file return it as is; under Windows NT and OS/2 a device file end with ":". */ if (nam[strlen (nam) - 1] == ':') --- 155,172 ---- char * __gnat_full_name (char *nam, char *buffer) { ! #ifdef RTSS ! /* RTSS applications have no current-directory notion, so RTSS file I/O ! requests must use fully qualified path names, such as: ! c:\temp\MyFile.txt (for a file system object) ! \\.\MyDevice0 (for a device object) ! */ ! if (nam[1] == ':' || nam[0] == '\\') ! strcpy (buffer, nam); ! else ! buffer[0] = '\0'; ! ! #elif defined(__EMX__) || defined (__MINGW32__) /* If this is a device file return it as is; under Windows NT and OS/2 a device file end with ":". */ if (nam[strlen (nam) - 1] == ':') diff -Nrcpad gcc-4.3.3/gcc/ada/ctrl_c.c gcc-4.4.0/gcc/ada/ctrl_c.c *** gcc-4.3.3/gcc/ada/ctrl_c.c Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/ctrl_c.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 2002-2003, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 2002-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** void __gnat_uninstall_int_handler (void) *** 50,56 **** /* POSIX implementation */ ! #if (defined (_AIX) || defined (unix)) && !defined (__vxworks) #include --- 49,56 ---- /* POSIX implementation */ ! #if (defined (__unix__) || defined (_AIX) || defined (__APPLE__)) \ ! && !defined (__vxworks) #include *************** __gnat_install_int_handler (void (*proc) *** 75,81 **** --- 75,86 ---- if (sigint_intercepted == 0) { act.sa_handler = __gnat_int_handler; + #if defined (__Lynx__) + /* LynxOS does not support SA_RESTART. */ + act.sa_flags = 0; + #else act.sa_flags = SA_RESTART; + #endif sigemptyset (&act.sa_mask); sigaction (SIGINT, &act, &original_act); } *************** __gnat_int_handler (DWORD dwCtrlType) *** 112,118 **** case CTRL_C_EVENT: case CTRL_BREAK_EVENT: if (sigint_intercepted != 0) ! sigint_intercepted (); break; case CTRL_CLOSE_EVENT: --- 117,126 ---- case CTRL_C_EVENT: case CTRL_BREAK_EVENT: if (sigint_intercepted != 0) ! { ! sigint_intercepted (); ! return TRUE; ! } break; case CTRL_CLOSE_EVENT: *************** __gnat_int_handler (DWORD dwCtrlType) *** 120,125 **** --- 128,135 ---- case CTRL_SHUTDOWN_EVENT: break; } + + return FALSE; } void diff -Nrcpad gcc-4.3.3/gcc/ada/cuintp.c gcc-4.4.0/gcc/ada/cuintp.c *** gcc-4.3.3/gcc/ada/cuintp.c Mon Sep 3 10:06:52 2007 --- gcc-4.4.0/gcc/ada/cuintp.c Thu Jan 1 00:00:00 1970 *************** *** 1,138 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * C U I N T P * - * * - * C Implementation File * - * * - * Copyright (C) 1992-2007, 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- * - * ware Foundation; either version 3, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License along with GCC; see the file COPYING3. If not see * - * . * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - /* This file corresponds to the Ada package body Uintp. It was created - manually from the files uintp.ads and uintp.adb. */ - - #include "config.h" - #include "system.h" - #include "coretypes.h" - #include "tm.h" - #include "tree.h" - #include "ada.h" - #include "types.h" - #include "uintp.h" - #include "atree.h" - #include "elists.h" - #include "nlists.h" - #include "stringt.h" - #include "fe.h" - #include "gigi.h" - #include "ada-tree.h" - - /* Universal integers are represented by the Uint type which is an index into - the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an - index and length for getting the "digits" of the universal integer from the - Udigits_Ptr table. - - For efficiency, this method is used only for integer values larger than the - constant Uint_Bias. If a Uint is less than this constant, then it contains - the integer value itself. The origin of the Uints_Ptr table is adjusted so - that a Uint value of Uint_Bias indexes the first element. - - First define a utility function that operates like build_int_cst for - integral types and does a conversion to floating-point for real types. */ - - static tree - build_cst_from_int (tree type, HOST_WIDE_INT low) - { - if (TREE_CODE (type) == REAL_TYPE) - return convert (type, build_int_cst (NULL_TREE, low)); - else - return build_int_cst_type (type, low); - } - - /* Similar to UI_To_Int, but return a GCC INTEGER_CST or REAL_CST node, - depending on whether TYPE is an integral or real type. Overflow is tested - by the constant-folding used to build the node. TYPE is the GCC type of - the resulting node. */ - - tree - UI_To_gnu (Uint Input, tree type) - { - tree gnu_ret; - - /* We might have a TYPE with biased representation and be passed an - unbiased value that doesn't fit. We always use an unbiased type able - to hold any such possible value for intermediate computations, and - then rely on a conversion back to TYPE to perform the bias adjustment - when need be. */ - - int biased_type_p - = (TREE_CODE (type) == INTEGER_TYPE - && TYPE_BIASED_REPRESENTATION_P (type)); - - tree comp_type = biased_type_p ? get_base_type (type) : type; - - if (Input <= Uint_Direct_Last) - gnu_ret = build_cst_from_int (comp_type, Input - Uint_Direct_Bias); - else - { - Int Idx = Uints_Ptr[Input].Loc; - Pos Length = Uints_Ptr[Input].Length; - Int First = Udigits_Ptr[Idx]; - tree gnu_base; - - gcc_assert (Length > 0); - - /* The computations we perform below always require a type at least as - large as an integer not to overflow. REAL types are always fine, but - INTEGER or ENUMERAL types we are handed may be too short. We use a - base integer type node for the computations in this case and will - convert the final result back to the incoming type later on. */ - - if (TREE_CODE (comp_type) != REAL_TYPE - && TYPE_PRECISION (comp_type) < TYPE_PRECISION (integer_type_node)) - comp_type = integer_type_node; - - gnu_base = build_cst_from_int (comp_type, Base); - - gnu_ret = build_cst_from_int (comp_type, First); - if (First < 0) - for (Idx++, Length--; Length; Idx++, Length--) - gnu_ret = fold_build2 (MINUS_EXPR, comp_type, - fold_build2 (MULT_EXPR, comp_type, - gnu_ret, gnu_base), - build_cst_from_int (comp_type, - Udigits_Ptr[Idx])); - else - for (Idx++, Length--; Length; Idx++, Length--) - gnu_ret = fold_build2 (PLUS_EXPR, comp_type, - fold_build2 (MULT_EXPR, comp_type, - gnu_ret, gnu_base), - build_cst_from_int (comp_type, - Udigits_Ptr[Idx])); - } - - gnu_ret = convert (type, gnu_ret); - - /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RET. */ - while ((TREE_CODE (gnu_ret) == NOP_EXPR - || TREE_CODE (gnu_ret) == NON_LVALUE_EXPR) - && TREE_TYPE (TREE_OPERAND (gnu_ret, 0)) == TREE_TYPE (gnu_ret)) - gnu_ret = TREE_OPERAND (gnu_ret, 0); - - return gnu_ret; - } --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/debug.adb gcc-4.4.0/gcc/ada/debug.adb *** gcc-4.3.3/gcc/ada/debug.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/debug.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Debug is *** 93,99 **** -- dY Enable configurable run-time mode -- dZ Generate listing showing the contents of the dispatch tables ! -- d.a Disable OpenVMS alignment optimization on types -- d.b -- d.c -- d.d --- 91,97 ---- -- dY Enable configurable run-time mode -- dZ Generate listing showing the contents of the dispatch tables ! -- d.a -- d.b -- d.c -- d.d *************** package body Debug is *** 110,120 **** -- d.o -- d.p -- d.q ! -- d.r -- d.s Disable expansion of slice move, use memmove -- d.t Disable static allocation of library level dispatch tables -- d.u ! -- d.v -- d.w Do not check for infinite while loops -- d.x No exception handlers -- d.y --- 108,118 ---- -- d.o -- d.p -- d.q ! -- d.r Enable OK_To_Reorder_Components in non-variant records -- d.s Disable expansion of slice move, use memmove -- d.t Disable static allocation of library level dispatch tables -- d.u ! -- d.v Enable OK_To_Reorder_Components in variant records -- d.w Do not check for infinite while loops -- d.x No exception handlers -- d.y *************** package body Debug is *** 138,145 **** -- d.P -- d.Q -- d.R ! -- d.S ! -- d.T -- d.U -- d.V -- d.W --- 136,143 ---- -- d.P -- d.Q -- d.R ! -- d.S Force Optimize_Alignment (Space) ! -- d.T Force Optimize_Alignment (Time) -- d.U -- d.V -- d.W *************** package body Debug is *** 474,506 **** -- line has an internally generated number used for references between -- tagged types and primitives. For each primitive the output has the -- following fields: -- - Letter 'P' or letter 's': The former indicates that this -- primitive will be located in a primary dispatch table. The -- latter indicates that it will be located in a secondary -- dispatch table. -- - Name of the primitive. In case of predefined Ada primitives -- the text "(predefined)" is added before the name, and these -- acronyms are used: SR (Stream_Read), SW (Stream_Write), SI -- (Stream_Input), SO (Stream_Output), DA (Deep_Adjust), DF -- (Deep_Finalize). In addition Oeq identifies the equality -- operator, and "_assign" the assignment. -- - If the primitive covers interface types, two extra fields -- referencing other primitives are generated: "Alias" references -- the primitive of the tagged type that covers an interface -- primitive, and "AI_Alias" references the covered interface -- primitive. -- - The expression "at #xx" indicates the slot of the dispatch -- table occupied by such primitive in its corresponding primary -- or secondary dispatch table. -- - In case of abstract subprograms the text "is abstract" is -- added at the end of the line. - -- d.a Disable OpenVMS alignment optimization on types. On OpenVMS, - -- record types whose size is odd "in between" (e.g. 17 bits) are - -- over-aligned to the next power of 2 (until 8 bytes). This over - -- alignment improve generated code and is more consistent with - -- what Dec Ada does. - -- d.f Suppress folding of static expressions. This of course results -- in seriously non-conforming behavior, but is useful sometimes -- when tracking down handling of complex expressions. --- 472,503 ---- -- line has an internally generated number used for references between -- tagged types and primitives. For each primitive the output has the -- following fields: + -- -- - Letter 'P' or letter 's': The former indicates that this -- primitive will be located in a primary dispatch table. The -- latter indicates that it will be located in a secondary -- dispatch table. + -- -- - Name of the primitive. In case of predefined Ada primitives -- the text "(predefined)" is added before the name, and these -- acronyms are used: SR (Stream_Read), SW (Stream_Write), SI -- (Stream_Input), SO (Stream_Output), DA (Deep_Adjust), DF -- (Deep_Finalize). In addition Oeq identifies the equality -- operator, and "_assign" the assignment. + -- -- - If the primitive covers interface types, two extra fields -- referencing other primitives are generated: "Alias" references -- the primitive of the tagged type that covers an interface -- primitive, and "AI_Alias" references the covered interface -- primitive. + -- -- - The expression "at #xx" indicates the slot of the dispatch -- table occupied by such primitive in its corresponding primary -- or secondary dispatch table. + -- -- - In case of abstract subprograms the text "is abstract" is -- added at the end of the line. -- d.f Suppress folding of static expressions. This of course results -- in seriously non-conforming behavior, but is useful sometimes -- when tracking down handling of complex expressions. *************** package body Debug is *** 520,525 **** --- 517,525 ---- -- main source (this corresponds to a previous behavior of -gnatl and -- is used for running the ACATS tests). + -- d.r Forces the flag OK_To_Reorder_Components to be set in all record + -- base types that have no discriminants. + -- d.s Normally the compiler expands slice moves into loops if overlap -- might be possible. This debug flag inhibits that expansion, and -- the back end is expected to use an appropriate routine to handle *************** package body Debug is *** 531,536 **** --- 531,539 ---- -- previous dynamic construction of tables. It is there as a possible -- work around if we run into trouble with the new implementation. + -- d.v Forces the flag OK_To_Reorder_Components to be set in all record + -- base types that have at least one discriminant (v = variant). + -- d.w This flag turns off the scanning of while loops to detect possible -- infinite loops. *************** package body Debug is *** 543,548 **** --- 546,555 ---- -- byte code, even in case of unsupported construct, for the sake -- of static analysis tools. + -- d.S Force Optimize_Alignment (Space) mode as the default + + -- d.T Force Optimize_Alignment (Time) mode as the default + -- d1 Error messages have node numbers where possible. Normally error -- messages have only source locations. This option is useful when -- debugging errors caused by expanded code, where the source location *************** package body Debug is *** 627,632 **** --- 634,641 ---- -- Documentation for gnatmake Debug Flags -- -------------------------------------------- + -- df Only output file names, not path names, in log + -- dn Do not delete temporary files created by gnatmake at the end -- of execution, such as temporary config pragma files, mapping -- files or project path files. diff -Nrcpad gcc-4.3.3/gcc/ada/debug.ads gcc-4.4.0/gcc/ada/debug.ads *** gcc-4.3.3/gcc/ada/debug.ads Wed Jun 6 10:52:32 2007 --- gcc-4.4.0/gcc/ada/debug.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/dec.ads gcc-4.4.0/gcc/ada/dec.ads *** gcc-4.3.3/gcc/ada/dec.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/dec.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/decl.c gcc-4.4.0/gcc/ada/decl.c *** gcc-4.3.3/gcc/ada/decl.c Sun Jan 11 12:25:21 2009 --- gcc-4.4.0/gcc/ada/decl.c Thu Jan 1 00:00:00 1970 *************** *** 1,7256 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * D E C L * - * * - * C Implementation File * - * * - * Copyright (C) 1992-2008, 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- * - * ware Foundation; either version 3, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License along with GCC; see the file COPYING3. If not see * - * . * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - #include "config.h" - #include "system.h" - #include "coretypes.h" - #include "tm.h" - #include "tree.h" - #include "flags.h" - #include "toplev.h" - #include "convert.h" - #include "ggc.h" - #include "obstack.h" - #include "target.h" - #include "expr.h" - - #include "ada.h" - #include "types.h" - #include "atree.h" - #include "elists.h" - #include "namet.h" - #include "nlists.h" - #include "repinfo.h" - #include "snames.h" - #include "stringt.h" - #include "uintp.h" - #include "fe.h" - #include "sinfo.h" - #include "einfo.h" - #include "hashtab.h" - #include "ada-tree.h" - #include "gigi.h" - - /* Convention_Stdcall should be processed in a specific way on Windows targets - only. The macro below is a helper to avoid having to check for a Windows - specific attribute throughout this unit. */ - - #if TARGET_DLLIMPORT_DECL_ATTRIBUTES - #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall) - #else - #define Has_Stdcall_Convention(E) (0) - #endif - - struct incomplete - { - struct incomplete *next; - tree old_type; - Entity_Id full_type; - }; - - /* These variables are used to defer recursively expanding incomplete types - while we are processing an array, a record or a subprogram type. */ - static int defer_incomplete_level = 0; - static struct incomplete *defer_incomplete_list; - - /* This variable is used to delay expanding From_With_Type types until the - end of the spec. */ - static struct incomplete *defer_limited_with; - - /* These variables are used to defer finalizing types. The element of the - list is the TYPE_DECL associated with the type. */ - static int defer_finalize_level = 0; - static VEC (tree,heap) *defer_finalize_list; - - /* A hash table used to cache the result of annotate_value. */ - static GTY ((if_marked ("tree_int_map_marked_p"), - param_is (struct tree_int_map))) htab_t annotate_value_cache; - - static void copy_alias_set (tree, tree); - static tree substitution_list (Entity_Id, Entity_Id, tree, bool); - static bool allocatable_size_p (tree, bool); - static void prepend_one_attribute_to (struct attrib **, - enum attr_type, tree, tree, Node_Id); - static void prepend_attributes (Entity_Id, struct attrib **); - static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool); - static bool is_variable_size (tree); - static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree, - bool, bool); - static tree make_packable_type (tree); - static tree gnat_to_gnu_field (Entity_Id, tree, int, bool); - static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool, - bool *); - static bool same_discriminant_p (Entity_Id, Entity_Id); - static bool array_type_has_nonaliased_component (Entity_Id, tree); - static void components_to_record (tree, Node_Id, tree, int, bool, tree *, - bool, bool, bool, bool); - static Uint annotate_value (tree); - static void annotate_rep (Entity_Id, tree); - static tree compute_field_positions (tree, tree, tree, tree, unsigned int); - static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool); - static void set_rm_size (Uint, tree, Entity_Id); - static tree make_type_from_size (tree, tree, bool); - static unsigned int validate_alignment (Uint, Entity_Id, unsigned int); - static unsigned int ceil_alignment (unsigned HOST_WIDE_INT); - static void check_ok_for_atomic (tree, Entity_Id, bool); - static int compatible_signatures_p (tree ftype1, tree ftype2); - - /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a - GCC type corresponding to that entity. GNAT_ENTITY is assumed to - refer to an Ada type. */ - - tree - gnat_to_gnu_type (Entity_Id gnat_entity) - { - tree gnu_decl; - - /* The back end never attempts to annotate generic types */ - if (Is_Generic_Type (gnat_entity) && type_annotate_only) - return void_type_node; - - /* Convert the ada entity type into a GCC TYPE_DECL node. */ - gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); - gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL); - return TREE_TYPE (gnu_decl); - } - - /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada - entity, this routine returns the equivalent GCC tree for that entity - (an ..._DECL node) and associates the ..._DECL node with the input GNAT - defining identifier. - - If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its - initial value (in GCC tree form). This is optional for variables. - For renamed entities, GNU_EXPR gives the object being renamed. - - DEFINITION is nonzero if this call is intended for a definition. This is - used for separate compilation where it necessary to know whether an - external declaration or a definition should be created if the GCC equivalent - was not created previously. The value of 1 is normally used for a nonzero - DEFINITION, but a value of 2 is used in special circumstances, defined in - the code. */ - - tree - gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) - { - Entity_Id gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity); - tree gnu_entity_id; - tree gnu_type = NULL_TREE; - /* Contains the gnu XXXX_DECL tree node which is equivalent to the input - GNAT tree. This node will be associated with the GNAT node by calling - the save_gnu_tree routine at the end of the `switch' statement. */ - tree gnu_decl = NULL_TREE; - /* true if we have already saved gnu_decl as a gnat association. */ - bool saved = false; - /* Nonzero if we incremented defer_incomplete_level. */ - bool this_deferred = false; - /* Nonzero if we incremented force_global. */ - bool this_global = false; - /* Nonzero if we should check to see if elaborated during processing. */ - bool maybe_present = false; - /* Nonzero if we made GNU_DECL and its type here. */ - bool this_made_decl = false; - struct attrib *attr_list = NULL; - bool debug_info_p = (Needs_Debug_Info (gnat_entity) - || debug_info_level == DINFO_LEVEL_VERBOSE); - Entity_Kind kind = Ekind (gnat_entity); - Entity_Id gnat_temp; - unsigned int esize - = ((Known_Esize (gnat_entity) - && UI_Is_In_Int_Range (Esize (gnat_entity))) - ? MIN (UI_To_Int (Esize (gnat_entity)), - IN (kind, Float_Kind) - ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE) - : IN (kind, Access_Kind) ? POINTER_SIZE * 2 - : LONG_LONG_TYPE_SIZE) - : LONG_LONG_TYPE_SIZE); - tree gnu_size = 0; - bool imported_p - = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity))); - unsigned int align = 0; - - /* Since a use of an Itype is a definition, process it as such if it - is not in a with'ed unit. */ - - if (!definition && Is_Itype (gnat_entity) - && !present_gnu_tree (gnat_entity) - && In_Extended_Main_Code_Unit (gnat_entity)) - { - /* Ensure that we are in a subprogram mentioned in the Scope - chain of this entity, our current scope is global, - or that we encountered a task or entry (where we can't currently - accurately check scoping). */ - if (!current_function_decl - || DECL_ELABORATION_PROC_P (current_function_decl)) - { - process_type (gnat_entity); - return get_gnu_tree (gnat_entity); - } - - for (gnat_temp = Scope (gnat_entity); - Present (gnat_temp); gnat_temp = Scope (gnat_temp)) - { - if (Is_Type (gnat_temp)) - gnat_temp = Underlying_Type (gnat_temp); - - if (Ekind (gnat_temp) == E_Subprogram_Body) - gnat_temp - = Corresponding_Spec (Parent (Declaration_Node (gnat_temp))); - - if (IN (Ekind (gnat_temp), Subprogram_Kind) - && Present (Protected_Body_Subprogram (gnat_temp))) - gnat_temp = Protected_Body_Subprogram (gnat_temp); - - if (Ekind (gnat_temp) == E_Entry - || Ekind (gnat_temp) == E_Entry_Family - || Ekind (gnat_temp) == E_Task_Type - || (IN (Ekind (gnat_temp), Subprogram_Kind) - && present_gnu_tree (gnat_temp) - && (current_function_decl - == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0)))) - { - process_type (gnat_entity); - return get_gnu_tree (gnat_entity); - } - } - - /* This abort means the entity "gnat_entity" has an incorrect scope, - i.e. that its scope does not correspond to the subprogram in which - it is declared */ - gcc_unreachable (); - } - - /* If this is entity 0, something went badly wrong. */ - gcc_assert (Present (gnat_entity)); - - /* If we've already processed this entity, return what we got last time. - If we are defining the node, we should not have already processed it. - In that case, we will abort below when we try to save a new GCC tree for - this object. We also need to handle the case of getting a dummy type - when a Full_View exists. */ - - if (present_gnu_tree (gnat_entity) - && (!definition || (Is_Type (gnat_entity) && imported_p))) - { - gnu_decl = get_gnu_tree (gnat_entity); - - if (TREE_CODE (gnu_decl) == TYPE_DECL - && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)) - && IN (kind, Incomplete_Or_Private_Kind) - && Present (Full_View (gnat_entity))) - { - gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), - NULL_TREE, 0); - - save_gnu_tree (gnat_entity, NULL_TREE, false); - save_gnu_tree (gnat_entity, gnu_decl, false); - } - - return gnu_decl; - } - - /* If this is a numeric or enumeral type, or an access type, a nonzero - Esize must be specified unless it was specified by the programmer. */ - gcc_assert (!Unknown_Esize (gnat_entity) - || Has_Size_Clause (gnat_entity) - || (!IN (kind, Numeric_Kind) && !IN (kind, Enumeration_Kind) - && (!IN (kind, Access_Kind) - || kind == E_Access_Protected_Subprogram_Type - || kind == E_Anonymous_Access_Protected_Subprogram_Type - || kind == E_Access_Subtype))); - - /* Likewise, RM_Size must be specified for all discrete and fixed-point - types. */ - gcc_assert (!IN (kind, Discrete_Or_Fixed_Point_Kind) - || !Unknown_RM_Size (gnat_entity)); - - /* Get the name of the entity and set up the line number and filename of - the original definition for use in any decl we make. */ - gnu_entity_id = get_entity_name (gnat_entity); - Sloc_to_locus (Sloc (gnat_entity), &input_location); - - /* If we get here, it means we have not yet done anything with this - entity. If we are not defining it here, it must be external, - otherwise we should have defined it already. */ - gcc_assert (definition || Is_Public (gnat_entity) || type_annotate_only - || kind == E_Discriminant || kind == E_Component - || kind == E_Label - || (kind == E_Constant && Present (Full_View (gnat_entity))) - || IN (kind, Type_Kind)); - - /* For cases when we are not defining (i.e., we are referencing from - another compilation unit) Public entities, show we are at global level - for the purpose of computing scopes. Don't do this for components or - discriminants since the relevant test is whether or not the record is - being defined. But do this for Imported functions or procedures in - all cases. */ - if ((!definition && Is_Public (gnat_entity) - && !Is_Statically_Allocated (gnat_entity) - && kind != E_Discriminant && kind != E_Component) - || (Is_Imported (gnat_entity) - && (kind == E_Function || kind == E_Procedure))) - force_global++, this_global = true; - - /* Handle any attributes directly attached to the entity. */ - if (Has_Gigi_Rep_Item (gnat_entity)) - prepend_attributes (gnat_entity, &attr_list); - - /* Machine_Attributes on types are expected to be propagated to subtypes. - The corresponding Gigi_Rep_Items are only attached to the first subtype - though, so we handle the propagation here. */ - if (Is_Type (gnat_entity) && Base_Type (gnat_entity) != gnat_entity - && !Is_First_Subtype (gnat_entity) - && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity)))) - prepend_attributes (First_Subtype (Base_Type (gnat_entity)), &attr_list); - - switch (kind) - { - case E_Constant: - /* If this is a use of a deferred constant, get its full - declaration. */ - if (!definition && Present (Full_View (gnat_entity))) - { - gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), - gnu_expr, 0); - saved = true; - break; - } - - /* If we have an external constant that we are not defining, get the - expression that is was defined to represent. We may throw that - expression away later if it is not a constant. Do not retrieve the - expression if it is an aggregate or allocator, because in complex - instantiation contexts it may not be expanded */ - if (!definition - && Present (Expression (Declaration_Node (gnat_entity))) - && !No_Initialization (Declaration_Node (gnat_entity)) - && (Nkind (Expression (Declaration_Node (gnat_entity))) - != N_Aggregate) - && (Nkind (Expression (Declaration_Node (gnat_entity))) - != N_Allocator)) - gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity))); - - /* Ignore deferred constant definitions; they are processed fully in the - front-end. For deferred constant references get the full definition. - On the other hand, constants that are renamings are handled like - variable renamings. If No_Initialization is set, this is not a - deferred constant but a constant whose value is built manually. */ - if (definition && !gnu_expr - && !No_Initialization (Declaration_Node (gnat_entity)) - && No (Renamed_Object (gnat_entity))) - { - gnu_decl = error_mark_node; - saved = true; - break; - } - else if (!definition && IN (kind, Incomplete_Or_Private_Kind) - && Present (Full_View (gnat_entity))) - { - gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), - NULL_TREE, 0); - saved = true; - break; - } - - goto object; - - case E_Exception: - /* We used to special case VMS exceptions here to directly map them to - their associated condition code. Since this code had to be masked - dynamically to strip off the severity bits, this caused trouble in - the GCC/ZCX case because the "type" pointers we store in the tables - have to be static. We now don't special case here anymore, and let - the regular processing take place, which leaves us with a regular - exception data object for VMS exceptions too. The condition code - mapping is taken care of by the front end and the bitmasking by the - runtime library. */ - goto object; - - case E_Discriminant: - case E_Component: - { - /* The GNAT record where the component was defined. */ - Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity)); - - /* If the variable is an inherited record component (in the case of - extended record types), just return the inherited entity, which - must be a FIELD_DECL. Likewise for discriminants. - For discriminants of untagged records which have explicit - stored discriminants, return the entity for the corresponding - stored discriminant. Also use Original_Record_Component - if the record has a private extension. */ - - if (Present (Original_Record_Component (gnat_entity)) - && Original_Record_Component (gnat_entity) != gnat_entity) - { - gnu_decl - = gnat_to_gnu_entity (Original_Record_Component (gnat_entity), - gnu_expr, definition); - saved = true; - break; - } - - /* If the enclosing record has explicit stored discriminants, - then it is an untagged record. If the Corresponding_Discriminant - is not empty then this must be a renamed discriminant and its - Original_Record_Component must point to the corresponding explicit - stored discriminant (i.e., we should have taken the previous - branch). */ - - else if (Present (Corresponding_Discriminant (gnat_entity)) - && Is_Tagged_Type (gnat_record)) - { - /* A tagged record has no explicit stored discriminants. */ - - gcc_assert (First_Discriminant (gnat_record) - == First_Stored_Discriminant (gnat_record)); - gnu_decl - = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity), - gnu_expr, definition); - saved = true; - break; - } - - else if (Present (CR_Discriminant (gnat_entity)) - && type_annotate_only) - { - gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity), - gnu_expr, definition); - saved = true; - break; - } - - /* If the enclosing record has explicit stored discriminants, - then it is an untagged record. If the Corresponding_Discriminant - is not empty then this must be a renamed discriminant and its - Original_Record_Component must point to the corresponding explicit - stored discriminant (i.e., we should have taken the first - branch). */ - - else if (Present (Corresponding_Discriminant (gnat_entity)) - && (First_Discriminant (gnat_record) - != First_Stored_Discriminant (gnat_record))) - gcc_unreachable (); - - /* Otherwise, if we are not defining this and we have no GCC type - for the containing record, make one for it. Then we should - have made our own equivalent. */ - else if (!definition && !present_gnu_tree (gnat_record)) - { - /* ??? If this is in a record whose scope is a protected - type and we have an Original_Record_Component, use it. - This is a workaround for major problems in protected type - handling. */ - Entity_Id Scop = Scope (Scope (gnat_entity)); - if ((Is_Protected_Type (Scop) - || (Is_Private_Type (Scop) - && Present (Full_View (Scop)) - && Is_Protected_Type (Full_View (Scop)))) - && Present (Original_Record_Component (gnat_entity))) - { - gnu_decl - = gnat_to_gnu_entity (Original_Record_Component - (gnat_entity), - gnu_expr, 0); - saved = true; - break; - } - - gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0); - gnu_decl = get_gnu_tree (gnat_entity); - saved = true; - break; - } - - else - /* Here we have no GCC type and this is a reference rather than a - definition. This should never happen. Most likely the cause is a - reference before declaration in the gnat tree for gnat_entity. */ - gcc_unreachable (); - } - - case E_Loop_Parameter: - case E_Out_Parameter: - case E_Variable: - - /* Simple variables, loop variables, Out parameters, and exceptions. */ - object: - { - bool used_by_ref = false; - bool const_flag - = ((kind == E_Constant || kind == E_Variable) - && Is_True_Constant (gnat_entity) - && (((Nkind (Declaration_Node (gnat_entity)) - == N_Object_Declaration) - && Present (Expression (Declaration_Node (gnat_entity)))) - || Present (Renamed_Object (gnat_entity)))); - bool inner_const_flag = const_flag; - bool static_p = Is_Statically_Allocated (gnat_entity); - bool mutable_p = false; - tree gnu_ext_name = NULL_TREE; - tree renamed_obj = NULL_TREE; - - if (Present (Renamed_Object (gnat_entity)) && !definition) - { - if (kind == E_Exception) - gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity), - NULL_TREE, 0); - else - gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity)); - } - - /* Get the type after elaborating the renamed object. */ - gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); - - /* For a debug renaming declaration, build a pure debug entity. */ - if (Present (Debug_Renaming_Link (gnat_entity))) - { - rtx addr; - gnu_decl = build_decl (VAR_DECL, gnu_entity_id, gnu_type); - /* The (MEM (CONST (0))) pattern is prescribed by STABS. */ - if (global_bindings_p ()) - addr = gen_rtx_CONST (VOIDmode, const0_rtx); - else - addr = stack_pointer_rtx; - SET_DECL_RTL (gnu_decl, gen_rtx_MEM (Pmode, addr)); - gnat_pushdecl (gnu_decl, gnat_entity); - break; - } - - /* If this is a loop variable, its type should be the base type. - This is because the code for processing a loop determines whether - a normal loop end test can be done by comparing the bounds of the - loop against those of the base type, which is presumed to be the - size used for computation. But this is not correct when the size - of the subtype is smaller than the type. */ - if (kind == E_Loop_Parameter) - gnu_type = get_base_type (gnu_type); - - /* Reject non-renamed objects whose types are unconstrained arrays or - any object whose type is a dummy type or VOID_TYPE. */ - - if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE - && No (Renamed_Object (gnat_entity))) - || TYPE_IS_DUMMY_P (gnu_type) - || TREE_CODE (gnu_type) == VOID_TYPE) - { - gcc_assert (type_annotate_only); - if (this_global) - force_global--; - return error_mark_node; - } - - /* If an alignment is specified, use it if valid. Note that - exceptions are objects but don't have alignments. We must do this - before we validate the size, since the alignment can affect the - size. */ - if (kind != E_Exception && Known_Alignment (gnat_entity)) - { - gcc_assert (Present (Alignment (gnat_entity))); - align = validate_alignment (Alignment (gnat_entity), gnat_entity, - TYPE_ALIGN (gnu_type)); - gnu_type = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity, - "PAD", false, definition, true); - } - - /* If we are defining the object, see if it has a Size value and - validate it if so. If we are not defining the object and a Size - clause applies, simply retrieve the value. We don't want to ignore - the clause and it is expected to have been validated already. Then - get the new type, if any. */ - if (definition) - gnu_size = validate_size (Esize (gnat_entity), gnu_type, - gnat_entity, VAR_DECL, false, - Has_Size_Clause (gnat_entity)); - else if (Has_Size_Clause (gnat_entity)) - gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype); - - if (gnu_size) - { - gnu_type - = make_type_from_size (gnu_type, gnu_size, - Has_Biased_Representation (gnat_entity)); - - if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)) - gnu_size = NULL_TREE; - } - - /* If this object has self-referential size, it must be a record with - a default value. We are supposed to allocate an object of the - maximum size in this case unless it is a constant with an - initializing expression, in which case we can get the size from - that. Note that the resulting size may still be a variable, so - this may end up with an indirect allocation. */ - - if (No (Renamed_Object (gnat_entity)) - && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) - { - if (gnu_expr && kind == E_Constant) - gnu_size - = SUBSTITUTE_PLACEHOLDER_IN_EXPR - (TYPE_SIZE (TREE_TYPE (gnu_expr)), gnu_expr); - - /* We may have no GNU_EXPR because No_Initialization is - set even though there's an Expression. */ - else if (kind == E_Constant - && (Nkind (Declaration_Node (gnat_entity)) - == N_Object_Declaration) - && Present (Expression (Declaration_Node (gnat_entity)))) - gnu_size - = TYPE_SIZE (gnat_to_gnu_type - (Etype - (Expression (Declaration_Node (gnat_entity))))); - else - { - gnu_size = max_size (TYPE_SIZE (gnu_type), true); - mutable_p = true; - } - } - - /* If the size is zero bytes, make it one byte since some linkers have - trouble with zero-sized objects. If the object will have a - template, that will make it nonzero so don't bother. Also avoid - doing that for an object renaming or an object with an address - clause, as we would lose useful information on the view size - (e.g. for null array slices) and we are not allocating the object - here anyway. */ - if (((gnu_size - && integer_zerop (gnu_size) - && !TREE_OVERFLOW (gnu_size)) - || (TYPE_SIZE (gnu_type) - && integer_zerop (TYPE_SIZE (gnu_type)) - && !TREE_OVERFLOW (TYPE_SIZE (gnu_type)))) - && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) - || !Is_Array_Type (Etype (gnat_entity))) - && !Present (Renamed_Object (gnat_entity)) - && !Present (Address_Clause (gnat_entity))) - gnu_size = bitsize_unit_node; - - /* If this is an atomic object with no specified size and alignment, - but where the size of the type is a constant, set the alignment to - the smallest not less than the size, or to the biggest meaningful - alignment, whichever is smaller. */ - if (Is_Atomic (gnat_entity) && !gnu_size && align == 0 - && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST) - { - if (!host_integerp (TYPE_SIZE (gnu_type), 1) - || 0 <= compare_tree_int (TYPE_SIZE (gnu_type), - BIGGEST_ALIGNMENT)) - align = BIGGEST_ALIGNMENT; - else - align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1)); - } - - /* If the object is set to have atomic components, find the component - type and validate it. - - ??? Note that we ignore Has_Volatile_Components on objects; it's - not at all clear what to do in that case. */ - - if (Has_Atomic_Components (gnat_entity)) - { - tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE - ? TREE_TYPE (gnu_type) : gnu_type); - - while (TREE_CODE (gnu_inner) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (gnu_inner)) - gnu_inner = TREE_TYPE (gnu_inner); - - check_ok_for_atomic (gnu_inner, gnat_entity, true); - } - - /* Now check if the type of the object allows atomic access. Note - that we must test the type, even if this object has size and - alignment to allow such access, because we will be going - inside the padded record to assign to the object. We could fix - this by always copying via an intermediate value, but it's not - clear it's worth the effort. */ - if (Is_Atomic (gnat_entity)) - check_ok_for_atomic (gnu_type, gnat_entity, false); - - /* If this is an aliased object with an unconstrained nominal subtype, - make a type that includes the template. */ - if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) - && Is_Array_Type (Etype (gnat_entity)) - && !type_annotate_only) - { - tree gnu_fat - = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity)))); - - gnu_type - = build_unc_object_type_from_ptr (gnu_fat, gnu_type, - concat_id_with_name (gnu_entity_id, - "UNC")); - } - - #ifdef MINIMUM_ATOMIC_ALIGNMENT - /* If the size is a constant and no alignment is specified, force - the alignment to be the minimum valid atomic alignment. The - restriction on constant size avoids problems with variable-size - temporaries; if the size is variable, there's no issue with - atomic access. Also don't do this for a constant, since it isn't - necessary and can interfere with constant replacement. Finally, - do not do it for Out parameters since that creates an - size inconsistency with In parameters. */ - if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type) - && !FLOAT_TYPE_P (gnu_type) - && !const_flag && No (Renamed_Object (gnat_entity)) - && !imported_p && No (Address_Clause (gnat_entity)) - && kind != E_Out_Parameter - && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST - : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)) - align = MINIMUM_ATOMIC_ALIGNMENT; - #endif - - /* Make a new type with the desired size and alignment, if needed. */ - gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity, - "PAD", false, definition, true); - - /* Make a volatile version of this object's type if we are to make - the object volatile. We also interpret 13.3(19) conservatively - and disallow any optimizations for an object covered by it. */ - if ((Treat_As_Volatile (gnat_entity) - || (Is_Exported (gnat_entity) - /* Exclude exported constants created by the compiler, - which should boil down to static dispatch tables and - make it possible to put them in read-only memory. */ - && (Comes_From_Source (gnat_entity) || !const_flag)) - || Is_Imported (gnat_entity) - || Present (Address_Clause (gnat_entity))) - && !TYPE_VOLATILE (gnu_type)) - gnu_type = build_qualified_type (gnu_type, - (TYPE_QUALS (gnu_type) - | TYPE_QUAL_VOLATILE)); - - /* If this is a renaming, avoid as much as possible to create a new - object. However, in several cases, creating it is required. - This processing needs to be applied to the raw expression so - as to make it more likely to rename the underlying object. */ - if (Present (Renamed_Object (gnat_entity))) - { - bool create_normal_object = false; - - /* If the renamed object had padding, strip off the reference - to the inner object and reset our type. */ - if ((TREE_CODE (gnu_expr) == COMPONENT_REF - && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) - == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) - /* Strip useless conversions around the object. */ - || TREE_CODE (gnu_expr) == NOP_EXPR) - { - gnu_expr = TREE_OPERAND (gnu_expr, 0); - gnu_type = TREE_TYPE (gnu_expr); - } - - /* Case 1: If this is a constant renaming stemming from a function - call, treat it as a normal object whose initial value is what - is being renamed. RM 3.3 says that the result of evaluating a - function call is a constant object. As a consequence, it can - be the inner object of a constant renaming. In this case, the - renaming must be fully instantiated, i.e. it cannot be a mere - reference to (part of) an existing object. */ - if (const_flag) - { - tree inner_object = gnu_expr; - while (handled_component_p (inner_object)) - inner_object = TREE_OPERAND (inner_object, 0); - if (TREE_CODE (inner_object) == CALL_EXPR) - create_normal_object = true; - } - - /* Otherwise, see if we can proceed with a stabilized version of - the renamed entity or if we need to make a new object. */ - if (!create_normal_object) - { - tree maybe_stable_expr = NULL_TREE; - bool stable = false; - - /* Case 2: If the renaming entity need not be materialized and - the renamed expression is something we can stabilize, use - that for the renaming. At the global level, we can only do - this if we know no SAVE_EXPRs need be made, because the - expression we return might be used in arbitrary conditional - branches so we must force the SAVE_EXPRs evaluation - immediately and this requires a function context. */ - if (!Materialize_Entity (gnat_entity) - && (!global_bindings_p () - || (staticp (gnu_expr) - && !TREE_SIDE_EFFECTS (gnu_expr)))) - { - maybe_stable_expr - = maybe_stabilize_reference (gnu_expr, true, &stable); - - if (stable) - { - gnu_decl = maybe_stable_expr; - /* ??? No DECL_EXPR is created so we need to mark - the expression manually lest it is shared. */ - if (global_bindings_p ()) - TREE_VISITED (gnu_decl) = 1; - save_gnu_tree (gnat_entity, gnu_decl, true); - saved = true; - break; - } - - /* The stabilization failed. Keep maybe_stable_expr - untouched here to let the pointer case below know - about that failure. */ - } - - /* Case 3: If this is a constant renaming and creating a - new object is allowed and cheap, treat it as a normal - object whose initial value is what is being renamed. */ - if (const_flag && Is_Elementary_Type (Etype (gnat_entity))) - ; - - /* Case 4: Make this into a constant pointer to the object we - are to rename and attach the object to the pointer if it is - something we can stabilize. - - From the proper scope, attached objects will be referenced - directly instead of indirectly via the pointer to avoid - subtle aliasing problems with non-addressable entities. - They have to be stable because we must not evaluate the - variables in the expression every time the renaming is used. - The pointer is called a "renaming" pointer in this case. - - In the rare cases where we cannot stabilize the renamed - object, we just make a "bare" pointer, and the renamed - entity is always accessed indirectly through it. */ - else - { - gnu_type = build_reference_type (gnu_type); - inner_const_flag = TREE_READONLY (gnu_expr); - const_flag = true; - - /* If the previous attempt at stabilizing failed, there - is no point in trying again and we reuse the result - without attaching it to the pointer. In this case it - will only be used as the initializing expression of - the pointer and thus needs no special treatment with - regard to multiple evaluations. */ - if (maybe_stable_expr) - ; - - /* Otherwise, try to stabilize and attach the expression - to the pointer if the stabilization succeeds. - - Note that this might introduce SAVE_EXPRs and we don't - check whether we're at the global level or not. This - is fine since we are building a pointer initializer and - neither the pointer nor the initializing expression can - be accessed before the pointer elaboration has taken - place in a correct program. - - These SAVE_EXPRs will be evaluated at the right place - by either the evaluation of the initializer for the - non-global case or the elaboration code for the global - case, and will be attached to the elaboration procedure - in the latter case. */ - else - { - maybe_stable_expr - = maybe_stabilize_reference (gnu_expr, true, &stable); - - if (stable) - renamed_obj = maybe_stable_expr; - - /* Attaching is actually performed downstream, as soon - as we have a VAR_DECL for the pointer we make. */ - } - - gnu_expr - = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr); - - gnu_size = NULL_TREE; - used_by_ref = true; - } - } - } - - /* If this is an aliased object whose nominal subtype is unconstrained, - the object is a record that contains both the template and - the object. If there is an initializer, it will have already - been converted to the right type, but we need to create the - template if there is no initializer. */ - else if (definition - && TREE_CODE (gnu_type) == RECORD_TYPE - && (TYPE_CONTAINS_TEMPLATE_P (gnu_type) - /* Beware that padding might have been introduced - via maybe_pad_type above. */ - || (TYPE_IS_PADDING_P (gnu_type) - && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) - == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P - (TREE_TYPE (TYPE_FIELDS (gnu_type))))) - && !gnu_expr) - { - tree template_field - = TYPE_IS_PADDING_P (gnu_type) - ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type))) - : TYPE_FIELDS (gnu_type); - - gnu_expr - = gnat_build_constructor - (gnu_type, - tree_cons - (template_field, - build_template (TREE_TYPE (template_field), - TREE_TYPE (TREE_CHAIN (template_field)), - NULL_TREE), - NULL_TREE)); - } - - /* Convert the expression to the type of the object except in the - case where the object's type is unconstrained or the object's type - is a padded record whose field is of self-referential size. In - the former case, converting will generate unnecessary evaluations - of the CONSTRUCTOR to compute the size and in the latter case, we - want to only copy the actual data. */ - if (gnu_expr - && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE - && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) - && !(TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_type) - && (CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))) - gnu_expr = convert (gnu_type, gnu_expr); - - /* If this is a pointer and it does not have an initializing - expression, initialize it to NULL, unless the object is - imported. */ - if (definition - && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type)) - && !Is_Imported (gnat_entity) && !gnu_expr) - gnu_expr = integer_zero_node; - - /* If we are defining the object and it has an Address clause we must - get the address expression from the saved GCC tree for the - object if the object has a Freeze_Node. Otherwise, we elaborate - the address expression here since the front-end has guaranteed - in that case that the elaboration has no effects. Note that - only the latter mechanism is currently in use. */ - if (definition && Present (Address_Clause (gnat_entity))) - { - tree gnu_address - = (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) - : gnat_to_gnu (Expression (Address_Clause (gnat_entity)))); - - save_gnu_tree (gnat_entity, NULL_TREE, false); - - /* Ignore the size. It's either meaningless or was handled - above. */ - gnu_size = NULL_TREE; - /* Convert the type of the object to a reference type that can - alias everything as per 13.3(19). */ - gnu_type - = build_reference_type_for_mode (gnu_type, ptr_mode, true); - gnu_address = convert (gnu_type, gnu_address); - used_by_ref = true; - const_flag = !Is_Public (gnat_entity); - - /* If we don't have an initializing expression for the underlying - variable, the initializing expression for the pointer is the - specified address. Otherwise, we have to make a COMPOUND_EXPR - to assign both the address and the initial value. */ - if (!gnu_expr) - gnu_expr = gnu_address; - else - gnu_expr - = build2 (COMPOUND_EXPR, gnu_type, - build_binary_op - (MODIFY_EXPR, NULL_TREE, - build_unary_op (INDIRECT_REF, NULL_TREE, - gnu_address), - gnu_expr), - gnu_address); - } - - /* If it has an address clause and we are not defining it, mark it - as an indirect object. Likewise for Stdcall objects that are - imported. */ - if ((!definition && Present (Address_Clause (gnat_entity))) - || (Is_Imported (gnat_entity) - && Has_Stdcall_Convention (gnat_entity))) - { - /* Convert the type of the object to a reference type that can - alias everything as per 13.3(19). */ - gnu_type - = build_reference_type_for_mode (gnu_type, ptr_mode, true); - gnu_size = NULL_TREE; - - gnu_expr = NULL_TREE; - /* No point in taking the address of an initializing expression - that isn't going to be used. */ - - used_by_ref = true; - } - - /* If we are at top level and this object is of variable size, - make the actual type a hidden pointer to the real type and - make the initializer be a memory allocation and initialization. - Likewise for objects we aren't defining (presumed to be - external references from other packages), but there we do - not set up an initialization. - - If the object's size overflows, make an allocator too, so that - Storage_Error gets raised. Note that we will never free - such memory, so we presume it never will get allocated. */ - - if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type), - global_bindings_p () || !definition - || static_p) - || (gnu_size - && ! allocatable_size_p (gnu_size, - global_bindings_p () || !definition - || static_p))) - { - gnu_type = build_reference_type (gnu_type); - gnu_size = NULL_TREE; - used_by_ref = true; - const_flag = true; - - /* In case this was a aliased object whose nominal subtype is - unconstrained, the pointer above will be a thin pointer and - build_allocator will automatically make the template. - - If we have a template initializer only (that we made above), - pretend there is none and rely on what build_allocator creates - again anyway. Otherwise (if we have a full initializer), get - the data part and feed that to build_allocator. - - If we are elaborating a mutable object, tell build_allocator to - ignore a possibly simpler size from the initializer, if any, as - we must allocate the maximum possible size in this case. */ - - if (definition) - { - tree gnu_alloc_type = TREE_TYPE (gnu_type); - - if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type)) - { - gnu_alloc_type - = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type))); - - if (TREE_CODE (gnu_expr) == CONSTRUCTOR - && 1 == VEC_length (constructor_elt, - CONSTRUCTOR_ELTS (gnu_expr))) - gnu_expr = 0; - else - gnu_expr - = build_component_ref - (gnu_expr, NULL_TREE, - TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), - false); - } - - if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST - && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type)) - && !Is_Imported (gnat_entity)) - post_error ("?Storage_Error will be raised at run-time!", - gnat_entity); - - gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, gnu_type, - 0, 0, gnat_entity, mutable_p); - } - else - { - gnu_expr = NULL_TREE; - const_flag = false; - } - } - - /* If this object would go into the stack and has an alignment larger - than the largest stack alignment the back-end can honor, resort to - a variable of "aligning type". */ - if (!global_bindings_p () && !static_p && definition - && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT) - { - /* Create the new variable. No need for extra room before the - aligned field as this is in automatic storage. */ - tree gnu_new_type - = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type), - TYPE_SIZE_UNIT (gnu_type), - BIGGEST_ALIGNMENT, 0); - tree gnu_new_var - = create_var_decl (create_concat_name (gnat_entity, "ALIGN"), - NULL_TREE, gnu_new_type, NULL_TREE, false, - false, false, false, NULL, gnat_entity); - - /* Initialize the aligned field if we have an initializer. */ - if (gnu_expr) - add_stmt_with_node - (build_binary_op (MODIFY_EXPR, NULL_TREE, - build_component_ref - (gnu_new_var, NULL_TREE, - TYPE_FIELDS (gnu_new_type), false), - gnu_expr), - gnat_entity); - - /* And setup this entity as a reference to the aligned field. */ - gnu_type = build_reference_type (gnu_type); - gnu_expr - = build_unary_op - (ADDR_EXPR, gnu_type, - build_component_ref (gnu_new_var, NULL_TREE, - TYPE_FIELDS (gnu_new_type), false)); - - gnu_size = NULL_TREE; - used_by_ref = true; - const_flag = true; - } - - if (const_flag) - gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type) - | TYPE_QUAL_CONST)); - - /* Convert the expression to the type of the object except in the - case where the object's type is unconstrained or the object's type - is a padded record whose field is of self-referential size. In - the former case, converting will generate unnecessary evaluations - of the CONSTRUCTOR to compute the size and in the latter case, we - want to only copy the actual data. */ - if (gnu_expr - && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE - && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) - && !(TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_type) - && (CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))) - gnu_expr = convert (gnu_type, gnu_expr); - - /* If this name is external or there was a name specified, use it, - unless this is a VMS exception object since this would conflict - with the symbol we need to export in addition. Don't use the - Interface_Name if there is an address clause (see CD30005). */ - if (!Is_VMS_Exception (gnat_entity) - && ((Present (Interface_Name (gnat_entity)) - && No (Address_Clause (gnat_entity))) - || (Is_Public (gnat_entity) - && (!Is_Imported (gnat_entity) - || Is_Exported (gnat_entity))))) - gnu_ext_name = create_concat_name (gnat_entity, 0); - - /* If this is constant initialized to a static constant and the - object has an aggregate type, force it to be statically - allocated. */ - if (const_flag && gnu_expr && TREE_CONSTANT (gnu_expr) - && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1) - && (AGGREGATE_TYPE_P (gnu_type) - && !(TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_type)))) - static_p = true; - - gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, - gnu_expr, const_flag, - Is_Public (gnat_entity), - imported_p || !definition, - static_p, attr_list, gnat_entity); - DECL_BY_REF_P (gnu_decl) = used_by_ref; - DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag; - if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj) - { - SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj); - if (global_bindings_p ()) - { - DECL_RENAMING_GLOBAL_P (gnu_decl) = 1; - record_global_renaming_pointer (gnu_decl); - } - } - - if (definition && DECL_SIZE (gnu_decl) - && get_block_jmpbuf_decl () - && (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST - || (flag_stack_check && !STACK_CHECK_BUILTIN - && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl), - STACK_CHECK_MAX_VAR_SIZE)))) - add_stmt_with_node (build_call_1_expr - (update_setjmp_buf_decl, - build_unary_op (ADDR_EXPR, NULL_TREE, - get_block_jmpbuf_decl ())), - gnat_entity); - - /* If this is a public constant or we're not optimizing and we're not - making a VAR_DECL for it, make one just for export or debugger use. - Likewise if the address is taken or if either the object or type is - aliased. Make an external declaration for a reference, unless this - is a Standard entity since there no real symbol at the object level - for these. */ - if (TREE_CODE (gnu_decl) == CONST_DECL - && (definition || Sloc (gnat_entity) > Standard_Location) - && (Is_Public (gnat_entity) - || optimize == 0 - || Address_Taken (gnat_entity) - || Is_Aliased (gnat_entity) - || Is_Aliased (Etype (gnat_entity)))) - { - tree gnu_corr_var - = create_true_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, - gnu_expr, true, Is_Public (gnat_entity), - !definition, static_p, NULL, - gnat_entity); - - SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var); - } - - /* If this is declared in a block that contains a block with an - exception handler, we must force this variable in memory to - suppress an invalid optimization. */ - if (Has_Nested_Block_With_Handler (Scope (gnat_entity)) - && Exception_Mechanism != Back_End_Exceptions) - TREE_ADDRESSABLE (gnu_decl) = 1; - - gnu_type = TREE_TYPE (gnu_decl); - - /* Back-annotate Alignment and Esize of the object if not already - known, except for when the object is actually a pointer to the - real object, since alignment and size of a pointer don't have - anything to do with those of the designated object. Note that - we pick the values of the type, not those of the object, to - shield ourselves from low-level platform-dependent adjustments - like alignment promotion. This is both consistent with all the - treatment above, where alignment and size are set on the type of - the object and not on the object directly, and makes it possible - to support confirming representation clauses in all cases. */ - - if (!used_by_ref && Unknown_Alignment (gnat_entity)) - Set_Alignment (gnat_entity, - UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); - - if (!used_by_ref && Unknown_Esize (gnat_entity)) - { - tree gnu_back_size; - - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) - gnu_back_size - = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))); - else - gnu_back_size = TYPE_SIZE (gnu_type); - - Set_Esize (gnat_entity, annotate_value (gnu_back_size)); - } - } - break; - - case E_Void: - /* Return a TYPE_DECL for "void" that we previously made. */ - gnu_decl = void_type_decl_node; - break; - - case E_Enumeration_Type: - /* A special case, for the types Character and Wide_Character in - Standard, we do not list all the literals. So if the literals - are not specified, make this an unsigned type. */ - if (No (First_Literal (gnat_entity))) - { - gnu_type = make_unsigned_type (esize); - TYPE_NAME (gnu_type) = gnu_entity_id; - - /* Set the TYPE_STRING_FLAG for Ada Character and - Wide_Character types. This is needed by the dwarf-2 debug writer to - distinguish between unsigned integer types and character types. */ - TYPE_STRING_FLAG (gnu_type) = 1; - break; - } - - /* Normal case of non-character type, or non-Standard character type */ - { - /* Here we have a list of enumeral constants in First_Literal. - We make a CONST_DECL for each and build into GNU_LITERAL_LIST - the list to be places into TYPE_FIELDS. Each node in the list - is a TREE_LIST node whose TREE_VALUE is the literal name - and whose TREE_PURPOSE is the value of the literal. - - Esize contains the number of bits needed to represent the enumeral - type, Type_Low_Bound also points to the first literal and - Type_High_Bound points to the last literal. */ - - Entity_Id gnat_literal; - tree gnu_literal_list = NULL_TREE; - - if (Is_Unsigned_Type (gnat_entity)) - gnu_type = make_unsigned_type (esize); - else - gnu_type = make_signed_type (esize); - - TREE_SET_CODE (gnu_type, ENUMERAL_TYPE); - - for (gnat_literal = First_Literal (gnat_entity); - Present (gnat_literal); - gnat_literal = Next_Literal (gnat_literal)) - { - tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal), - gnu_type); - tree gnu_literal - = create_var_decl (get_entity_name (gnat_literal), NULL_TREE, - gnu_type, gnu_value, true, false, false, - false, NULL, gnat_literal); - - save_gnu_tree (gnat_literal, gnu_literal, false); - gnu_literal_list = tree_cons (DECL_NAME (gnu_literal), - gnu_value, gnu_literal_list); - } - - TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list); - - /* Note that the bounds are updated at the end of this function - because to avoid an infinite recursion when we get the bounds of - this type, since those bounds are objects of this type. */ - } - break; - - case E_Signed_Integer_Type: - case E_Ordinary_Fixed_Point_Type: - case E_Decimal_Fixed_Point_Type: - /* For integer types, just make a signed type the appropriate number - of bits. */ - gnu_type = make_signed_type (esize); - break; - - case E_Modular_Integer_Type: - /* For modular types, make the unsigned type of the proper number of - bits and then set up the modulus, if required. */ - { - enum machine_mode mode; - tree gnu_modulus; - tree gnu_high = 0; - - if (Is_Packed_Array_Type (gnat_entity)) - esize = UI_To_Int (RM_Size (gnat_entity)); - - /* Find the smallest mode at least ESIZE bits wide and make a class - using that mode. */ - - for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); - GET_MODE_BITSIZE (mode) < esize; - mode = GET_MODE_WIDER_MODE (mode)) - ; - - gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode)); - TYPE_PACKED_ARRAY_TYPE_P (gnu_type) - = Is_Packed_Array_Type (gnat_entity); - - /* Get the modulus in this type. If it overflows, assume it is because - it is equal to 2**Esize. Note that there is no overflow checking - done on unsigned type, so we detect the overflow by looking for - a modulus of zero, which is otherwise invalid. */ - gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type); - - if (!integer_zerop (gnu_modulus)) - { - TYPE_MODULAR_P (gnu_type) = 1; - SET_TYPE_MODULUS (gnu_type, gnu_modulus); - gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus, - convert (gnu_type, integer_one_node)); - } - - /* If we have to set TYPE_PRECISION different from its natural value, - make a subtype to do do. Likewise if there is a modulus and - it is not one greater than TYPE_MAX_VALUE. */ - if (TYPE_PRECISION (gnu_type) != esize - || (TYPE_MODULAR_P (gnu_type) - && !tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high))) - { - tree gnu_subtype = make_node (INTEGER_TYPE); - - TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT"); - TREE_TYPE (gnu_subtype) = gnu_type; - TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type); - TYPE_MAX_VALUE (gnu_subtype) - = TYPE_MODULAR_P (gnu_type) - ? gnu_high : TYPE_MAX_VALUE (gnu_type); - TYPE_PRECISION (gnu_subtype) = esize; - TYPE_UNSIGNED (gnu_subtype) = 1; - TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1; - TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype) - = Is_Packed_Array_Type (gnat_entity); - layout_type (gnu_subtype); - - gnu_type = gnu_subtype; - } - } - break; - - case E_Signed_Integer_Subtype: - case E_Enumeration_Subtype: - case E_Modular_Integer_Subtype: - case E_Ordinary_Fixed_Point_Subtype: - case E_Decimal_Fixed_Point_Subtype: - - /* For integral subtypes, we make a new INTEGER_TYPE. Note - that we do not want to call build_range_type since we would - like each subtype node to be distinct. This will be important - when memory aliasing is implemented. - - The TREE_TYPE field of the INTEGER_TYPE we make points to the - parent type; this fact is used by the arithmetic conversion - functions. - - We elaborate the Ancestor_Subtype if it is not in the current - unit and one of our bounds is non-static. We do this to ensure - consistent naming in the case where several subtypes share the same - bounds by always elaborating the first such subtype first, thus - using its name. */ - - if (!definition - && Present (Ancestor_Subtype (gnat_entity)) - && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) - && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) - || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) - gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), - gnu_expr, 0); - - gnu_type = make_node (INTEGER_TYPE); - if (Is_Packed_Array_Type (gnat_entity)) - { - esize = UI_To_Int (RM_Size (gnat_entity)); - TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1; - } - - TYPE_PRECISION (gnu_type) = esize; - TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); - - TYPE_MIN_VALUE (gnu_type) - = convert (TREE_TYPE (gnu_type), - elaborate_expression (Type_Low_Bound (gnat_entity), - gnat_entity, - get_identifier ("L"), definition, 1, - Needs_Debug_Info (gnat_entity))); - - TYPE_MAX_VALUE (gnu_type) - = convert (TREE_TYPE (gnu_type), - elaborate_expression (Type_High_Bound (gnat_entity), - gnat_entity, - get_identifier ("U"), definition, 1, - Needs_Debug_Info (gnat_entity))); - - /* One of the above calls might have caused us to be elaborated, - so don't blow up if so. */ - if (present_gnu_tree (gnat_entity)) - { - maybe_present = true; - break; - } - - TYPE_BIASED_REPRESENTATION_P (gnu_type) - = Has_Biased_Representation (gnat_entity); - - /* This should be an unsigned type if the lower bound is constant - and non-negative or if the base type is unsigned; a signed type - otherwise. */ - TYPE_UNSIGNED (gnu_type) - = (TYPE_UNSIGNED (TREE_TYPE (gnu_type)) - || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST - && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0) - || TYPE_BIASED_REPRESENTATION_P (gnu_type) - || Is_Unsigned_Type (gnat_entity)); - - layout_type (gnu_type); - - /* Inherit our alias set from what we're a subtype of. Subtypes - are not different types and a pointer can designate any instance - within a subtype hierarchy. */ - copy_alias_set (gnu_type, TREE_TYPE (gnu_type)); - - /* If the type we are dealing with is to represent a packed array, - we need to have the bits left justified on big-endian targets - and right justified on little-endian targets. We also need to - ensure that when the value is read (e.g. for comparison of two - such values), we only get the good bits, since the unused bits - are uninitialized. Both goals are accomplished by wrapping the - modular value in an enclosing struct. */ - if (Is_Packed_Array_Type (gnat_entity)) - { - tree gnu_field_type = gnu_type; - tree gnu_field; - - TYPE_RM_SIZE_NUM (gnu_field_type) - = UI_To_gnu (RM_Size (gnat_entity), bitsizetype); - gnu_type = make_node (RECORD_TYPE); - TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM"); - TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type); - TYPE_USER_ALIGN (gnu_type) = TYPE_USER_ALIGN (gnu_field_type); - TYPE_PACKED (gnu_type) = 1; - - /* Create a stripped-down declaration of the original type, mainly - for debugging. */ - create_type_decl (get_entity_name (gnat_entity), gnu_field_type, - NULL, true, debug_info_p, gnat_entity); - - /* Don't notify the field as "addressable", since we won't be taking - it's address and it would prevent create_field_decl from making a - bitfield. */ - gnu_field = create_field_decl (get_identifier ("OBJECT"), - gnu_field_type, gnu_type, 1, 0, 0, 0); - - finish_record_type (gnu_type, gnu_field, 0, false); - TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1; - SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize)); - - copy_alias_set (gnu_type, gnu_field_type); - } - - break; - - case E_Floating_Point_Type: - /* If this is a VAX floating-point type, use an integer of the proper - size. All the operations will be handled with ASM statements. */ - if (Vax_Float (gnat_entity)) - { - gnu_type = make_signed_type (esize); - TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1; - SET_TYPE_DIGITS_VALUE (gnu_type, - UI_To_gnu (Digits_Value (gnat_entity), - sizetype)); - break; - } - - /* The type of the Low and High bounds can be our type if this is - a type from Standard, so set them at the end of the function. */ - gnu_type = make_node (REAL_TYPE); - TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize); - layout_type (gnu_type); - break; - - case E_Floating_Point_Subtype: - if (Vax_Float (gnat_entity)) - { - gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); - break; - } - - { - if (!definition - && Present (Ancestor_Subtype (gnat_entity)) - && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) - && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) - || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) - gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), - gnu_expr, 0); - - gnu_type = make_node (REAL_TYPE); - TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); - TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize); - - TYPE_MIN_VALUE (gnu_type) - = convert (TREE_TYPE (gnu_type), - elaborate_expression (Type_Low_Bound (gnat_entity), - gnat_entity, get_identifier ("L"), - definition, 1, - Needs_Debug_Info (gnat_entity))); - - TYPE_MAX_VALUE (gnu_type) - = convert (TREE_TYPE (gnu_type), - elaborate_expression (Type_High_Bound (gnat_entity), - gnat_entity, get_identifier ("U"), - definition, 1, - Needs_Debug_Info (gnat_entity))); - - /* One of the above calls might have caused us to be elaborated, - so don't blow up if so. */ - if (present_gnu_tree (gnat_entity)) - { - maybe_present = true; - break; - } - - layout_type (gnu_type); - - /* Inherit our alias set from what we're a subtype of, as for - integer subtypes. */ - copy_alias_set (gnu_type, TREE_TYPE (gnu_type)); - } - break; - - /* Array and String Types and Subtypes - - Unconstrained array types are represented by E_Array_Type and - constrained array types are represented by E_Array_Subtype. There - are no actual objects of an unconstrained array type; all we have - are pointers to that type. - - The following fields are defined on array types and subtypes: - - Component_Type Component type of the array. - Number_Dimensions Number of dimensions (an int). - First_Index Type of first index. */ - - case E_String_Type: - case E_Array_Type: - { - tree gnu_template_fields = NULL_TREE; - tree gnu_template_type = make_node (RECORD_TYPE); - tree gnu_ptr_template = build_pointer_type (gnu_template_type); - tree gnu_fat_type = make_node (RECORD_TYPE); - int ndim = Number_Dimensions (gnat_entity); - int firstdim - = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0; - int nextdim - = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1; - tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *)); - tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *)); - tree gnu_comp_size = 0; - tree gnu_max_size = size_one_node; - tree gnu_max_size_unit; - int index; - Entity_Id gnat_ind_subtype; - Entity_Id gnat_ind_base_subtype; - tree gnu_template_reference; - tree tem; - - TYPE_NAME (gnu_template_type) - = create_concat_name (gnat_entity, "XUB"); - - /* Make a node for the array. If we are not defining the array - suppress expanding incomplete types. */ - gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE); - - if (!definition) - defer_incomplete_level++, this_deferred = true; - - /* Build the fat pointer type. Use a "void *" object instead of - a pointer to the array type since we don't have the array type - yet (it will reference the fat pointer via the bounds). */ - tem = chainon (chainon (NULL_TREE, - create_field_decl (get_identifier ("P_ARRAY"), - ptr_void_type_node, - gnu_fat_type, 0, 0, 0, 0)), - create_field_decl (get_identifier ("P_BOUNDS"), - gnu_ptr_template, - gnu_fat_type, 0, 0, 0, 0)); - - /* Make sure we can put this into a register. */ - TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); - - /* Do not finalize this record type since the types of its fields - are still incomplete at this point. */ - finish_record_type (gnu_fat_type, tem, 0, true); - TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1; - - /* Build a reference to the template from a PLACEHOLDER_EXPR that - is the fat pointer. This will be used to access the individual - fields once we build them. */ - tem = build3 (COMPONENT_REF, gnu_ptr_template, - build0 (PLACEHOLDER_EXPR, gnu_fat_type), - TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE); - gnu_template_reference - = build_unary_op (INDIRECT_REF, gnu_template_type, tem); - TREE_READONLY (gnu_template_reference) = 1; - - /* Now create the GCC type for each index and add the fields for - that index to the template. */ - for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity), - gnat_ind_base_subtype - = First_Index (Implementation_Base_Type (gnat_entity)); - index < ndim && index >= 0; - index += nextdim, - gnat_ind_subtype = Next_Index (gnat_ind_subtype), - gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype)) - { - char field_name[10]; - tree gnu_ind_subtype - = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype))); - tree gnu_base_subtype - = get_unpadded_type (Etype (gnat_ind_base_subtype)); - tree gnu_base_min - = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype)); - tree gnu_base_max - = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype)); - tree gnu_min_field, gnu_max_field, gnu_min, gnu_max; - - /* Make the FIELD_DECLs for the minimum and maximum of this - type and then make extractions of that field from the - template. */ - sprintf (field_name, "LB%d", index); - gnu_min_field = create_field_decl (get_identifier (field_name), - gnu_ind_subtype, - gnu_template_type, 0, 0, 0, 0); - field_name[0] = 'U'; - gnu_max_field = create_field_decl (get_identifier (field_name), - gnu_ind_subtype, - gnu_template_type, 0, 0, 0, 0); - - Sloc_to_locus (Sloc (gnat_entity), - &DECL_SOURCE_LOCATION (gnu_min_field)); - Sloc_to_locus (Sloc (gnat_entity), - &DECL_SOURCE_LOCATION (gnu_max_field)); - gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field); - - /* We can't use build_component_ref here since the template - type isn't complete yet. */ - gnu_min = build3 (COMPONENT_REF, gnu_ind_subtype, - gnu_template_reference, gnu_min_field, - NULL_TREE); - gnu_max = build3 (COMPONENT_REF, gnu_ind_subtype, - gnu_template_reference, gnu_max_field, - NULL_TREE); - TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1; - - /* Make a range type with the new ranges, but using - the Ada subtype. Then we convert to sizetype. */ - gnu_index_types[index] - = create_index_type (convert (sizetype, gnu_min), - convert (sizetype, gnu_max), - build_range_type (gnu_ind_subtype, - gnu_min, gnu_max), - gnat_entity); - /* Update the maximum size of the array, in elements. */ - gnu_max_size - = size_binop (MULT_EXPR, gnu_max_size, - size_binop (PLUS_EXPR, size_one_node, - size_binop (MINUS_EXPR, gnu_base_max, - gnu_base_min))); - - TYPE_NAME (gnu_index_types[index]) - = create_concat_name (gnat_entity, field_name); - } - - for (index = 0; index < ndim; index++) - gnu_template_fields - = chainon (gnu_template_fields, gnu_temp_fields[index]); - - /* Install all the fields into the template. */ - finish_record_type (gnu_template_type, gnu_template_fields, 0, false); - TYPE_READONLY (gnu_template_type) = 1; - - /* Now make the array of arrays and update the pointer to the array - in the fat pointer. Note that it is the first field. */ - tem = gnat_to_gnu_type (Component_Type (gnat_entity)); - - /* Get and validate any specified Component_Size, but if Packed, - ignore it since the front end will have taken care of it. */ - gnu_comp_size - = validate_size (Component_Size (gnat_entity), tem, - gnat_entity, - (Is_Bit_Packed_Array (gnat_entity) - ? TYPE_DECL : VAR_DECL), - true, Has_Component_Size_Clause (gnat_entity)); - - if (Has_Atomic_Components (gnat_entity)) - check_ok_for_atomic (tem, gnat_entity, true); - - /* If the component type is a RECORD_TYPE that has a self-referential - size, use the maxium size. */ - if (!gnu_comp_size && TREE_CODE (tem) == RECORD_TYPE - && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem))) - gnu_comp_size = max_size (TYPE_SIZE (tem), true); - - if (!Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size) - { - tree orig_tem; - tem = make_type_from_size (tem, gnu_comp_size, false); - orig_tem = tem; - tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity, - "C_PAD", false, definition, true); - /* If a padding record was made, declare it now since it will - never be declared otherwise. This is necessary in order to - ensure that its subtrees are properly marked. */ - if (tem != orig_tem) - create_type_decl (TYPE_NAME (tem), tem, NULL, true, false, - gnat_entity); - } - - if (Has_Volatile_Components (gnat_entity)) - tem = build_qualified_type (tem, - TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE); - - /* If Component_Size is not already specified, annotate it with the - size of the component. */ - if (Unknown_Component_Size (gnat_entity)) - Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem))); - - gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node, - size_binop (MULT_EXPR, gnu_max_size, - TYPE_SIZE_UNIT (tem))); - gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node, - size_binop (MULT_EXPR, - convert (bitsizetype, - gnu_max_size), - TYPE_SIZE (tem))); - - for (index = ndim - 1; index >= 0; index--) - { - tem = build_array_type (tem, gnu_index_types[index]); - TYPE_MULTI_ARRAY_P (tem) = (index > 0); - if (array_type_has_nonaliased_component (gnat_entity, tem)) - TYPE_NONALIASED_COMPONENT (tem) = 1; - } - - /* If an alignment is specified, use it if valid. But ignore it for - types that represent the unpacked base type for packed arrays. If - the alignment was requested with an explicit user alignment clause, - state so. */ - if (No (Packed_Array_Type (gnat_entity)) - && Known_Alignment (gnat_entity)) - { - gcc_assert (Present (Alignment (gnat_entity))); - TYPE_ALIGN (tem) - = validate_alignment (Alignment (gnat_entity), gnat_entity, - TYPE_ALIGN (tem)); - if (Present (Alignment_Clause (gnat_entity))) - TYPE_USER_ALIGN (tem) = 1; - } - - TYPE_CONVENTION_FORTRAN_P (tem) - = (Convention (gnat_entity) == Convention_Fortran); - TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem); - - /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the - corresponding fat pointer. */ - TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) - = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type; - TYPE_MODE (gnu_type) = BLKmode; - TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem); - SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type); - - /* If the maximum size doesn't overflow, use it. */ - if (TREE_CODE (gnu_max_size) == INTEGER_CST - && !TREE_OVERFLOW (gnu_max_size)) - TYPE_SIZE (tem) - = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem)); - if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST - && !TREE_OVERFLOW (gnu_max_size_unit)) - TYPE_SIZE_UNIT (tem) - = size_binop (MIN_EXPR, gnu_max_size_unit, - TYPE_SIZE_UNIT (tem)); - - create_type_decl (create_concat_name (gnat_entity, "XUA"), - tem, NULL, !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); - - /* Give the fat pointer type a name. */ - create_type_decl (create_concat_name (gnat_entity, "XUP"), - gnu_fat_type, NULL, !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); - - /* Create the type to be used as what a thin pointer designates: an - record type for the object and its template with the field offsets - shifted to have the template at a negative offset. */ - tem = build_unc_object_type (gnu_template_type, tem, - create_concat_name (gnat_entity, "XUT")); - shift_unc_components_for_thin_pointers (tem); - - SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type); - TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem; - - /* Give the thin pointer type a name. */ - create_type_decl (create_concat_name (gnat_entity, "XUX"), - build_pointer_type (tem), NULL, - !Comes_From_Source (gnat_entity), debug_info_p, - gnat_entity); - } - break; - - case E_String_Subtype: - case E_Array_Subtype: - - /* This is the actual data type for array variables. Multidimensional - arrays are implemented in the gnu tree as arrays of arrays. Note - that for the moment arrays which have sparse enumeration subtypes as - index components create sparse arrays, which is obviously space - inefficient but so much easier to code for now. - - Also note that the subtype never refers to the unconstrained - array type, which is somewhat at variance with Ada semantics. - - First check to see if this is simply a renaming of the array - type. If so, the result is the array type. */ - - gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); - if (!Is_Constrained (gnat_entity)) - break; - else - { - int index; - int array_dim = Number_Dimensions (gnat_entity); - int first_dim - = ((Convention (gnat_entity) == Convention_Fortran) - ? array_dim - 1 : 0); - int next_dim - = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1; - Entity_Id gnat_ind_subtype; - Entity_Id gnat_ind_base_subtype; - tree gnu_base_type = gnu_type; - tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *)); - tree gnu_comp_size = NULL_TREE; - tree gnu_max_size = size_one_node; - tree gnu_max_size_unit; - bool need_index_type_struct = false; - bool max_overflow = false; - - /* First create the gnu types for each index. Create types for - debugging information to point to the index types if the - are not integer types, have variable bounds, or are - wider than sizetype. */ - - for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity), - gnat_ind_base_subtype - = First_Index (Implementation_Base_Type (gnat_entity)); - index < array_dim && index >= 0; - index += next_dim, - gnat_ind_subtype = Next_Index (gnat_ind_subtype), - gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype)) - { - tree gnu_index_subtype - = get_unpadded_type (Etype (gnat_ind_subtype)); - tree gnu_min - = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype)); - tree gnu_max - = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype)); - tree gnu_base_subtype - = get_unpadded_type (Etype (gnat_ind_base_subtype)); - tree gnu_base_min - = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype)); - tree gnu_base_max - = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype)); - tree gnu_base_type = get_base_type (gnu_base_subtype); - tree gnu_base_base_min - = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type)); - tree gnu_base_base_max - = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type)); - tree gnu_high; - tree gnu_this_max; - - /* If the minimum and maximum values both overflow in - SIZETYPE, but the difference in the original type - does not overflow in SIZETYPE, ignore the overflow - indications. */ - if ((TYPE_PRECISION (gnu_index_subtype) - > TYPE_PRECISION (sizetype) - || TYPE_UNSIGNED (gnu_index_subtype) - != TYPE_UNSIGNED (sizetype)) - && TREE_CODE (gnu_min) == INTEGER_CST - && TREE_CODE (gnu_max) == INTEGER_CST - && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max) - && (!TREE_OVERFLOW - (fold_build2 (MINUS_EXPR, gnu_index_subtype, - TYPE_MAX_VALUE (gnu_index_subtype), - TYPE_MIN_VALUE (gnu_index_subtype))))) - { - TREE_OVERFLOW (gnu_min) = 0; - TREE_OVERFLOW (gnu_max) = 0; - } - - /* Similarly, if the range is null, use bounds of 1..0 for - the sizetype bounds. */ - else if ((TYPE_PRECISION (gnu_index_subtype) - > TYPE_PRECISION (sizetype) - || TYPE_UNSIGNED (gnu_index_subtype) - != TYPE_UNSIGNED (sizetype)) - && TREE_CODE (gnu_min) == INTEGER_CST - && TREE_CODE (gnu_max) == INTEGER_CST - && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max)) - && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype), - TYPE_MIN_VALUE (gnu_index_subtype))) - gnu_min = size_one_node, gnu_max = size_zero_node; - - /* Now compute the size of this bound. We need to provide - GCC with an upper bound to use but have to deal with the - "superflat" case. There are three ways to do this. If we - can prove that the array can never be superflat, we can - just use the high bound of the index subtype. If we can - prove that the low bound minus one can't overflow, we - can do this as MAX (hb, lb - 1). Otherwise, we have to use - the expression hb >= lb ? hb : lb - 1. */ - gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node); - - /* See if the base array type is already flat. If it is, we - are probably compiling an ACVC test, but it will cause the - code below to malfunction if we don't handle it specially. */ - if (TREE_CODE (gnu_base_min) == INTEGER_CST - && TREE_CODE (gnu_base_max) == INTEGER_CST - && !TREE_OVERFLOW (gnu_base_min) - && !TREE_OVERFLOW (gnu_base_max) - && tree_int_cst_lt (gnu_base_max, gnu_base_min)) - gnu_high = size_zero_node, gnu_min = size_one_node; - - /* If gnu_high is now an integer which overflowed, the array - cannot be superflat. */ - else if (TREE_CODE (gnu_high) == INTEGER_CST - && TREE_OVERFLOW (gnu_high)) - gnu_high = gnu_max; - else if (TYPE_UNSIGNED (gnu_base_subtype) - || TREE_CODE (gnu_high) == INTEGER_CST) - gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high); - else - gnu_high - = build_cond_expr - (sizetype, build_binary_op (GE_EXPR, integer_type_node, - gnu_max, gnu_min), - gnu_max, gnu_high); - - gnu_index_type[index] - = create_index_type (gnu_min, gnu_high, gnu_index_subtype, - gnat_entity); - - /* Also compute the maximum size of the array. Here we - see if any constraint on the index type of the base type - can be used in the case of self-referential bound on - the index type of the subtype. We look for a non-"infinite" - and non-self-referential bound from any type involved and - handle each bound separately. */ - - if ((TREE_CODE (gnu_min) == INTEGER_CST - && !TREE_OVERFLOW (gnu_min) - && !operand_equal_p (gnu_min, gnu_base_base_min, 0)) - || !CONTAINS_PLACEHOLDER_P (gnu_min) - || !(TREE_CODE (gnu_base_min) == INTEGER_CST - && !TREE_OVERFLOW (gnu_base_min))) - gnu_base_min = gnu_min; - - if ((TREE_CODE (gnu_max) == INTEGER_CST - && !TREE_OVERFLOW (gnu_max) - && !operand_equal_p (gnu_max, gnu_base_base_max, 0)) - || !CONTAINS_PLACEHOLDER_P (gnu_max) - || !(TREE_CODE (gnu_base_max) == INTEGER_CST - && !TREE_OVERFLOW (gnu_base_max))) - gnu_base_max = gnu_max; - - if ((TREE_CODE (gnu_base_min) == INTEGER_CST - && TREE_OVERFLOW (gnu_base_min)) - || operand_equal_p (gnu_base_min, gnu_base_base_min, 0) - || (TREE_CODE (gnu_base_max) == INTEGER_CST - && TREE_OVERFLOW (gnu_base_max)) - || operand_equal_p (gnu_base_max, gnu_base_base_max, 0)) - max_overflow = true; - - gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min); - gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max); - - gnu_this_max - = size_binop (MAX_EXPR, - size_binop (PLUS_EXPR, size_one_node, - size_binop (MINUS_EXPR, gnu_base_max, - gnu_base_min)), - size_zero_node); - - if (TREE_CODE (gnu_this_max) == INTEGER_CST - && TREE_OVERFLOW (gnu_this_max)) - max_overflow = true; - - gnu_max_size - = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max); - - if (!integer_onep (TYPE_MIN_VALUE (gnu_index_subtype)) - || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype)) - != INTEGER_CST) - || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE - || (TREE_TYPE (gnu_index_subtype) - && (TREE_CODE (TREE_TYPE (gnu_index_subtype)) - != INTEGER_TYPE)) - || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype) - || (TYPE_PRECISION (gnu_index_subtype) - > TYPE_PRECISION (sizetype))) - need_index_type_struct = true; - } - - /* Then flatten: create the array of arrays. */ - - gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity)); - - /* One of the above calls might have caused us to be elaborated, - so don't blow up if so. */ - if (present_gnu_tree (gnat_entity)) - { - maybe_present = true; - break; - } - - /* Get and validate any specified Component_Size, but if Packed, - ignore it since the front end will have taken care of it. */ - gnu_comp_size - = validate_size (Component_Size (gnat_entity), gnu_type, - gnat_entity, - (Is_Bit_Packed_Array (gnat_entity) - ? TYPE_DECL : VAR_DECL), - true, Has_Component_Size_Clause (gnat_entity)); - - /* If the component type is a RECORD_TYPE that has a self-referential - size, use the maxium size. */ - if (!gnu_comp_size && TREE_CODE (gnu_type) == RECORD_TYPE - && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) - gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true); - - if (!Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size) - { - tree orig_gnu_type; - gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false); - orig_gnu_type = gnu_type; - gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, - gnat_entity, "C_PAD", false, - definition, true); - /* If a padding record was made, declare it now since it will - never be declared otherwise. This is necessary in order to - ensure that its subtrees are properly marked. */ - if (gnu_type != orig_gnu_type) - create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true, - false, gnat_entity); - } - - if (Has_Volatile_Components (Base_Type (gnat_entity))) - gnu_type = build_qualified_type (gnu_type, - (TYPE_QUALS (gnu_type) - | TYPE_QUAL_VOLATILE)); - - gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size, - TYPE_SIZE_UNIT (gnu_type)); - gnu_max_size = size_binop (MULT_EXPR, - convert (bitsizetype, gnu_max_size), - TYPE_SIZE (gnu_type)); - - for (index = array_dim - 1; index >= 0; index --) - { - gnu_type = build_array_type (gnu_type, gnu_index_type[index]); - TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0); - if (array_type_has_nonaliased_component (gnat_entity, gnu_type)) - TYPE_NONALIASED_COMPONENT (gnu_type) = 1; - } - - /* If we are at file level and this is a multi-dimensional array, we - need to make a variable corresponding to the stride of the - inner dimensions. */ - if (global_bindings_p () && array_dim > 1) - { - tree gnu_str_name = get_identifier ("ST"); - tree gnu_arr_type; - - for (gnu_arr_type = TREE_TYPE (gnu_type); - TREE_CODE (gnu_arr_type) == ARRAY_TYPE; - gnu_arr_type = TREE_TYPE (gnu_arr_type), - gnu_str_name = concat_id_with_name (gnu_str_name, "ST")) - { - tree eltype = TREE_TYPE (gnu_arr_type); - - TYPE_SIZE (gnu_arr_type) - = elaborate_expression_1 (gnat_entity, gnat_entity, - TYPE_SIZE (gnu_arr_type), - gnu_str_name, definition, 0); - - /* ??? For now, store the size as a multiple of the - alignment of the element type in bytes so that we - can see the alignment from the tree. */ - TYPE_SIZE_UNIT (gnu_arr_type) - = build_binary_op - (MULT_EXPR, sizetype, - elaborate_expression_1 - (gnat_entity, gnat_entity, - build_binary_op (EXACT_DIV_EXPR, sizetype, - TYPE_SIZE_UNIT (gnu_arr_type), - size_int (TYPE_ALIGN (eltype) - / BITS_PER_UNIT)), - concat_id_with_name (gnu_str_name, "A_U"), - definition, 0), - size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT)); - - /* ??? create_type_decl is not invoked on the inner types so - the MULT_EXPR node built above will never be marked. */ - TREE_VISITED (TYPE_SIZE_UNIT (gnu_arr_type)) = 1; - } - } - - /* If we need to write out a record type giving the names of - the bounds, do it now. */ - if (need_index_type_struct && debug_info_p) - { - tree gnu_bound_rec_type = make_node (RECORD_TYPE); - tree gnu_field_list = NULL_TREE; - tree gnu_field; - - TYPE_NAME (gnu_bound_rec_type) - = create_concat_name (gnat_entity, "XA"); - - for (index = array_dim - 1; index >= 0; index--) - { - tree gnu_type_name - = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index])); - - if (TREE_CODE (gnu_type_name) == TYPE_DECL) - gnu_type_name = DECL_NAME (gnu_type_name); - - gnu_field = create_field_decl (gnu_type_name, - integer_type_node, - gnu_bound_rec_type, - 0, NULL_TREE, NULL_TREE, 0); - TREE_CHAIN (gnu_field) = gnu_field_list; - gnu_field_list = gnu_field; - } - - finish_record_type (gnu_bound_rec_type, gnu_field_list, - 0, false); - } - - TYPE_CONVENTION_FORTRAN_P (gnu_type) - = (Convention (gnat_entity) == Convention_Fortran); - TYPE_PACKED_ARRAY_TYPE_P (gnu_type) - = Is_Packed_Array_Type (gnat_entity); - - /* If our size depends on a placeholder and the maximum size doesn't - overflow, use it. */ - if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) - && !(TREE_CODE (gnu_max_size) == INTEGER_CST - && TREE_OVERFLOW (gnu_max_size)) - && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST - && TREE_OVERFLOW (gnu_max_size_unit)) - && !max_overflow) - { - TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size, - TYPE_SIZE (gnu_type)); - TYPE_SIZE_UNIT (gnu_type) - = size_binop (MIN_EXPR, gnu_max_size_unit, - TYPE_SIZE_UNIT (gnu_type)); - } - - /* Set our alias set to that of our base type. This gives all - array subtypes the same alias set. */ - copy_alias_set (gnu_type, gnu_base_type); - } - - /* If this is a packed type, make this type the same as the packed - array type, but do some adjusting in the type first. */ - - if (Present (Packed_Array_Type (gnat_entity))) - { - Entity_Id gnat_index; - tree gnu_inner_type; - - /* First finish the type we had been making so that we output - debugging information for it */ - gnu_type - = build_qualified_type (gnu_type, - (TYPE_QUALS (gnu_type) - | (TYPE_QUAL_VOLATILE - * Treat_As_Volatile (gnat_entity)))); - gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, - !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); - if (!Comes_From_Source (gnat_entity)) - DECL_ARTIFICIAL (gnu_decl) = 1; - - /* Save it as our equivalent in case the call below elaborates - this type again. */ - save_gnu_tree (gnat_entity, gnu_decl, false); - - gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity), - NULL_TREE, 0); - this_made_decl = true; - gnu_type = TREE_TYPE (gnu_decl); - save_gnu_tree (gnat_entity, NULL_TREE, false); - - gnu_inner_type = gnu_type; - while (TREE_CODE (gnu_inner_type) == RECORD_TYPE - && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner_type) - || TYPE_IS_PADDING_P (gnu_inner_type))) - gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type)); - - /* We need to point the type we just made to our index type so - the actual bounds can be put into a template. */ - - if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE - && !TYPE_ACTUAL_BOUNDS (gnu_inner_type)) - || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE - && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type))) - { - if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE) - { - /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus. - If it is, we need to make another type. */ - if (TYPE_MODULAR_P (gnu_inner_type)) - { - tree gnu_subtype; - - gnu_subtype = make_node (INTEGER_TYPE); - - TREE_TYPE (gnu_subtype) = gnu_inner_type; - TYPE_MIN_VALUE (gnu_subtype) - = TYPE_MIN_VALUE (gnu_inner_type); - TYPE_MAX_VALUE (gnu_subtype) - = TYPE_MAX_VALUE (gnu_inner_type); - TYPE_PRECISION (gnu_subtype) - = TYPE_PRECISION (gnu_inner_type); - TYPE_UNSIGNED (gnu_subtype) - = TYPE_UNSIGNED (gnu_inner_type); - TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1; - layout_type (gnu_subtype); - - gnu_inner_type = gnu_subtype; - } - - TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1; - } - - SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE); - - for (gnat_index = First_Index (gnat_entity); - Present (gnat_index); gnat_index = Next_Index (gnat_index)) - SET_TYPE_ACTUAL_BOUNDS - (gnu_inner_type, - tree_cons (NULL_TREE, - get_unpadded_type (Etype (gnat_index)), - TYPE_ACTUAL_BOUNDS (gnu_inner_type))); - - if (Convention (gnat_entity) != Convention_Fortran) - SET_TYPE_ACTUAL_BOUNDS - (gnu_inner_type, - nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type))); - - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (gnu_type)) - TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type; - } - } - - /* Abort if packed array with no packed array type field set. */ - else - gcc_assert (!Is_Packed (gnat_entity)); - - break; - - case E_String_Literal_Subtype: - /* Create the type for a string literal. */ - { - Entity_Id gnat_full_type - = (IN (Ekind (Etype (gnat_entity)), Private_Kind) - && Present (Full_View (Etype (gnat_entity))) - ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity)); - tree gnu_string_type = get_unpadded_type (gnat_full_type); - tree gnu_string_array_type - = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type)))); - tree gnu_string_index_type - = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE - (TYPE_DOMAIN (gnu_string_array_type)))); - tree gnu_lower_bound - = convert (gnu_string_index_type, - gnat_to_gnu (String_Literal_Low_Bound (gnat_entity))); - int length = UI_To_Int (String_Literal_Length (gnat_entity)); - tree gnu_length = ssize_int (length - 1); - tree gnu_upper_bound - = build_binary_op (PLUS_EXPR, gnu_string_index_type, - gnu_lower_bound, - convert (gnu_string_index_type, gnu_length)); - tree gnu_range_type - = build_range_type (gnu_string_index_type, - gnu_lower_bound, gnu_upper_bound); - tree gnu_index_type - = create_index_type (convert (sizetype, - TYPE_MIN_VALUE (gnu_range_type)), - convert (sizetype, - TYPE_MAX_VALUE (gnu_range_type)), - gnu_range_type, gnat_entity); - - gnu_type - = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)), - gnu_index_type); - copy_alias_set (gnu_type, gnu_string_type); - } - break; - - /* Record Types and Subtypes - - The following fields are defined on record types: - - Has_Discriminants True if the record has discriminants - First_Discriminant Points to head of list of discriminants - First_Entity Points to head of list of fields - Is_Tagged_Type True if the record is tagged - - Implementation of Ada records and discriminated records: - - A record type definition is transformed into the equivalent of a C - struct definition. The fields that are the discriminants which are - found in the Full_Type_Declaration node and the elements of the - Component_List found in the Record_Type_Definition node. The - Component_List can be a recursive structure since each Variant of - the Variant_Part of the Component_List has a Component_List. - - Processing of a record type definition comprises starting the list of - field declarations here from the discriminants and the calling the - function components_to_record to add the rest of the fields from the - component list and return the gnu type node. The function - components_to_record will call itself recursively as it traverses - the tree. */ - - case E_Record_Type: - if (Has_Complex_Representation (gnat_entity)) - { - gnu_type - = build_complex_type - (get_unpadded_type - (Etype (Defining_Entity - (First (Component_Items - (Component_List - (Type_Definition - (Declaration_Node (gnat_entity))))))))); - - break; - } - - { - Node_Id full_definition = Declaration_Node (gnat_entity); - Node_Id record_definition = Type_Definition (full_definition); - Entity_Id gnat_field; - tree gnu_field; - tree gnu_field_list = NULL_TREE; - tree gnu_get_parent; - /* Set PACKED in keeping with gnat_to_gnu_field. */ - int packed - = Is_Packed (gnat_entity) - ? 1 - : Component_Alignment (gnat_entity) == Calign_Storage_Unit - ? -1 - : (Known_Alignment (gnat_entity) - || (Strict_Alignment (gnat_entity) - && Known_Static_Esize (gnat_entity))) - ? -2 - : 0; - bool has_rep = Has_Specified_Layout (gnat_entity); - bool all_rep = has_rep; - bool is_extension - = (Is_Tagged_Type (gnat_entity) - && Nkind (record_definition) == N_Derived_Type_Definition); - - /* See if all fields have a rep clause. Stop when we find one - that doesn't. */ - for (gnat_field = First_Entity (gnat_entity); - Present (gnat_field) && all_rep; - gnat_field = Next_Entity (gnat_field)) - if ((Ekind (gnat_field) == E_Component - || Ekind (gnat_field) == E_Discriminant) - && No (Component_Clause (gnat_field))) - all_rep = false; - - /* If this is a record extension, go a level further to find the - record definition. Also, verify we have a Parent_Subtype. */ - if (is_extension) - { - if (!type_annotate_only - || Present (Record_Extension_Part (record_definition))) - record_definition = Record_Extension_Part (record_definition); - - gcc_assert (type_annotate_only - || Present (Parent_Subtype (gnat_entity))); - } - - /* Make a node for the record. If we are not defining the record, - suppress expanding incomplete types. */ - gnu_type = make_node (tree_code_for_record_type (gnat_entity)); - TYPE_NAME (gnu_type) = gnu_entity_id; - TYPE_PACKED (gnu_type) = (packed != 0) || has_rep; - - if (!definition) - defer_incomplete_level++, this_deferred = true; - - /* If both a size and rep clause was specified, put the size in - the record type now so that it can get the proper mode. */ - if (has_rep && Known_Esize (gnat_entity)) - TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype); - - /* Always set the alignment here so that it can be used to - set the mode, if it is making the alignment stricter. If - it is invalid, it will be checked again below. If this is to - be Atomic, choose a default alignment of a word unless we know - the size and it's smaller. */ - if (Known_Alignment (gnat_entity)) - TYPE_ALIGN (gnu_type) - = validate_alignment (Alignment (gnat_entity), gnat_entity, 0); - else if (Is_Atomic (gnat_entity)) - TYPE_ALIGN (gnu_type) - = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize); - /* If a type needs strict alignment, the minimum size will be the - type size instead of the RM size (see validate_size). Cap the - alignment, lest it causes this type size to become too large. */ - else if (Strict_Alignment (gnat_entity) - && Known_Static_Esize (gnat_entity)) - { - unsigned int raw_size = UI_To_Int (Esize (gnat_entity)); - TYPE_ALIGN (gnu_type) - = MIN (BIGGEST_ALIGNMENT, raw_size & -raw_size); - } - else - TYPE_ALIGN (gnu_type) = 0; - - /* If we have a Parent_Subtype, make a field for the parent. If - this record has rep clauses, force the position to zero. */ - if (Present (Parent_Subtype (gnat_entity))) - { - Entity_Id gnat_parent = Parent_Subtype (gnat_entity); - tree gnu_parent; - - /* A major complexity here is that the parent subtype will - reference our discriminants in its Discriminant_Constraint - list. But those must reference the parent component of this - record which is of the parent subtype we have not built yet! - To break the circle we first build a dummy COMPONENT_REF which - represents the "get to the parent" operation and initialize - each of those discriminants to a COMPONENT_REF of the above - dummy parent referencing the corresponding discriminant of the - base type of the parent subtype. */ - gnu_get_parent = build3 (COMPONENT_REF, void_type_node, - build0 (PLACEHOLDER_EXPR, gnu_type), - build_decl (FIELD_DECL, NULL_TREE, - void_type_node), - NULL_TREE); - - if (Has_Discriminants (gnat_entity)) - for (gnat_field = First_Stored_Discriminant (gnat_entity); - Present (gnat_field); - gnat_field = Next_Stored_Discriminant (gnat_field)) - if (Present (Corresponding_Discriminant (gnat_field))) - save_gnu_tree - (gnat_field, - build3 (COMPONENT_REF, - get_unpadded_type (Etype (gnat_field)), - gnu_get_parent, - gnat_to_gnu_field_decl (Corresponding_Discriminant - (gnat_field)), - NULL_TREE), - true); - - /* Then we build the parent subtype. */ - gnu_parent = gnat_to_gnu_type (gnat_parent); - - /* Finally we fix up both kinds of twisted COMPONENT_REF we have - initially built. The discriminants must reference the fields - of the parent subtype and not those of its base type for the - placeholder machinery to properly work. */ - if (Has_Discriminants (gnat_entity)) - for (gnat_field = First_Stored_Discriminant (gnat_entity); - Present (gnat_field); - gnat_field = Next_Stored_Discriminant (gnat_field)) - if (Present (Corresponding_Discriminant (gnat_field))) - { - Entity_Id field = Empty; - for (field = First_Stored_Discriminant (gnat_parent); - Present (field); - field = Next_Stored_Discriminant (field)) - if (same_discriminant_p (gnat_field, field)) - break; - gcc_assert (Present (field)); - TREE_OPERAND (get_gnu_tree (gnat_field), 1) - = gnat_to_gnu_field_decl (field); - } - - /* The "get to the parent" COMPONENT_REF must be given its - proper type... */ - TREE_TYPE (gnu_get_parent) = gnu_parent; - - /* ...and reference the _parent field of this record. */ - gnu_field_list - = create_field_decl (get_identifier - (Get_Name_String (Name_uParent)), - gnu_parent, gnu_type, 0, - has_rep ? TYPE_SIZE (gnu_parent) : 0, - has_rep ? bitsize_zero_node : 0, 1); - DECL_INTERNAL_P (gnu_field_list) = 1; - TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list; - } - - /* Make the fields for the discriminants and put them into the record - unless it's an Unchecked_Union. */ - if (Has_Discriminants (gnat_entity)) - for (gnat_field = First_Stored_Discriminant (gnat_entity); - Present (gnat_field); - gnat_field = Next_Stored_Discriminant (gnat_field)) - { - /* If this is a record extension and this discriminant - is the renaming of another discriminant, we've already - handled the discriminant above. */ - if (Present (Parent_Subtype (gnat_entity)) - && Present (Corresponding_Discriminant (gnat_field))) - continue; - - gnu_field - = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition); - - /* Make an expression using a PLACEHOLDER_EXPR from the - FIELD_DECL node just created and link that with the - corresponding GNAT defining identifier. Then add to the - list of fields. */ - save_gnu_tree (gnat_field, - build3 (COMPONENT_REF, TREE_TYPE (gnu_field), - build0 (PLACEHOLDER_EXPR, - DECL_CONTEXT (gnu_field)), - gnu_field, NULL_TREE), - true); - - if (!Is_Unchecked_Union (gnat_entity)) - { - TREE_CHAIN (gnu_field) = gnu_field_list; - gnu_field_list = gnu_field; - } - } - - /* Put the discriminants into the record (backwards), so we can - know the appropriate discriminant to use for the names of the - variants. */ - TYPE_FIELDS (gnu_type) = gnu_field_list; - - /* Add the listed fields into the record and finish it up. */ - components_to_record (gnu_type, Component_List (record_definition), - gnu_field_list, packed, definition, NULL, - false, all_rep, false, - Is_Unchecked_Union (gnat_entity)); - - /* We used to remove the associations of the discriminants and - _Parent for validity checking, but we may need them if there's - Freeze_Node for a subtype used in this record. */ - TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity); - TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity); - - /* If it is a tagged record force the type to BLKmode to insure - that these objects will always be placed in memory. Do the - same thing for limited record types. */ - if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity)) - TYPE_MODE (gnu_type) = BLKmode; - - /* If this is a derived type, we must make the alias set of this type - the same as that of the type we are derived from. We assume here - that the other type is already frozen. */ - if (Etype (gnat_entity) != gnat_entity - && !(Is_Private_Type (Etype (gnat_entity)) - && Full_View (Etype (gnat_entity)) == gnat_entity)) - copy_alias_set (gnu_type, gnat_to_gnu_type (Etype (gnat_entity))); - - /* Fill in locations of fields. */ - annotate_rep (gnat_entity, gnu_type); - - /* If there are any entities in the chain corresponding to - components that we did not elaborate, ensure we elaborate their - types if they are Itypes. */ - for (gnat_temp = First_Entity (gnat_entity); - Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp)) - if ((Ekind (gnat_temp) == E_Component - || Ekind (gnat_temp) == E_Discriminant) - && Is_Itype (Etype (gnat_temp)) - && !present_gnu_tree (gnat_temp)) - gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); - } - break; - - case E_Class_Wide_Subtype: - /* If an equivalent type is present, that is what we should use. - Otherwise, fall through to handle this like a record subtype - since it may have constraints. */ - if (gnat_equiv_type != gnat_entity) - { - gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0); - maybe_present = true; - break; - } - - /* ... fall through ... */ - - case E_Record_Subtype: - - /* If Cloned_Subtype is Present it means this record subtype has - identical layout to that type or subtype and we should use - that GCC type for this one. The front end guarantees that - the component list is shared. */ - if (Present (Cloned_Subtype (gnat_entity))) - { - gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity), - NULL_TREE, 0); - maybe_present = true; - } - - /* Otherwise, first ensure the base type is elaborated. Then, if we are - changing the type, make a new type with each field having the - type of the field in the new subtype but having the position - computed by transforming every discriminant reference according - to the constraints. We don't see any difference between - private and nonprivate type here since derivations from types should - have been deferred until the completion of the private type. */ - else - { - Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity); - tree gnu_base_type; - tree gnu_orig_type; - - if (!definition) - defer_incomplete_level++, this_deferred = true; - - /* Get the base type initially for its alignment and sizes. But - if it is a padded type, we do all the other work with the - unpadded type. */ - gnu_base_type = gnat_to_gnu_type (gnat_base_type); - - if (TREE_CODE (gnu_base_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_base_type)) - gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type)); - else - gnu_type = gnu_orig_type = gnu_base_type; - - if (present_gnu_tree (gnat_entity)) - { - maybe_present = true; - break; - } - - /* When the type has discriminants, and these discriminants - affect the shape of what it built, factor them in. - - If we are making a subtype of an Unchecked_Union (must be an - Itype), just return the type. - - We can't just use Is_Constrained because private subtypes without - discriminants of full types with discriminants with default - expressions are Is_Constrained but aren't constrained! */ - - if (IN (Ekind (gnat_base_type), Record_Kind) - && !Is_For_Access_Subtype (gnat_entity) - && !Is_Unchecked_Union (gnat_base_type) - && Is_Constrained (gnat_entity) - && Stored_Constraint (gnat_entity) != No_Elist - && Present (Discriminant_Constraint (gnat_entity))) - { - Entity_Id gnat_field; - tree gnu_field_list = 0; - tree gnu_pos_list - = compute_field_positions (gnu_orig_type, NULL_TREE, - size_zero_node, bitsize_zero_node, - BIGGEST_ALIGNMENT); - tree gnu_subst_list - = substitution_list (gnat_entity, gnat_base_type, NULL_TREE, - definition); - tree gnu_temp; - - gnu_type = make_node (RECORD_TYPE); - TYPE_NAME (gnu_type) = gnu_entity_id; - TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type); - TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity); - - for (gnat_field = First_Entity (gnat_entity); - Present (gnat_field); gnat_field = Next_Entity (gnat_field)) - if ((Ekind (gnat_field) == E_Component - || Ekind (gnat_field) == E_Discriminant) - && (Underlying_Type (Scope (Original_Record_Component - (gnat_field))) - == gnat_base_type) - && (No (Corresponding_Discriminant (gnat_field)) - || !Is_Tagged_Type (gnat_base_type))) - { - tree gnu_old_field - = gnat_to_gnu_field_decl (Original_Record_Component - (gnat_field)); - tree gnu_offset - = TREE_VALUE (purpose_member (gnu_old_field, - gnu_pos_list)); - tree gnu_pos = TREE_PURPOSE (gnu_offset); - tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset)); - tree gnu_field_type - = gnat_to_gnu_type (Etype (gnat_field)); - tree gnu_size = TYPE_SIZE (gnu_field_type); - tree gnu_new_pos = 0; - unsigned int offset_align - = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)), - 1); - tree gnu_field; - - /* If there was a component clause, the field types must be - the same for the type and subtype, so copy the data from - the old field to avoid recomputation here. Also if the - field is justified modular and the optimization in - gnat_to_gnu_field was applied. */ - if (Present (Component_Clause - (Original_Record_Component (gnat_field))) - || (TREE_CODE (gnu_field_type) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type) - && TREE_TYPE (TYPE_FIELDS (gnu_field_type)) - == TREE_TYPE (gnu_old_field))) - { - gnu_size = DECL_SIZE (gnu_old_field); - gnu_field_type = TREE_TYPE (gnu_old_field); - } - - /* If the old field was packed and of constant size, we - have to get the old size here, as it might differ from - what the Etype conveys and the latter might overlap - onto the following field. Try to arrange the type for - possible better packing along the way. */ - else if (DECL_PACKED (gnu_old_field) - && TREE_CODE (DECL_SIZE (gnu_old_field)) - == INTEGER_CST) - { - gnu_size = DECL_SIZE (gnu_old_field); - if (TYPE_MODE (gnu_field_type) == BLKmode - && TREE_CODE (gnu_field_type) == RECORD_TYPE - && host_integerp (TYPE_SIZE (gnu_field_type), 1)) - gnu_field_type = make_packable_type (gnu_field_type); - } - - if (CONTAINS_PLACEHOLDER_P (gnu_pos)) - for (gnu_temp = gnu_subst_list; - gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) - gnu_pos = substitute_in_expr (gnu_pos, - TREE_PURPOSE (gnu_temp), - TREE_VALUE (gnu_temp)); - - /* If the size is now a constant, we can set it as the - size of the field when we make it. Otherwise, we need - to deal with it specially. */ - if (TREE_CONSTANT (gnu_pos)) - gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos); - - gnu_field - = create_field_decl - (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type, - DECL_PACKED (gnu_old_field), gnu_size, gnu_new_pos, - !DECL_NONADDRESSABLE_P (gnu_old_field)); - - if (!TREE_CONSTANT (gnu_pos)) - { - normalize_offset (&gnu_pos, &gnu_bitpos, offset_align); - DECL_FIELD_OFFSET (gnu_field) = gnu_pos; - DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos; - SET_DECL_OFFSET_ALIGN (gnu_field, offset_align); - DECL_SIZE (gnu_field) = gnu_size; - DECL_SIZE_UNIT (gnu_field) - = convert (sizetype, - size_binop (CEIL_DIV_EXPR, gnu_size, - bitsize_unit_node)); - layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field)); - } - - DECL_INTERNAL_P (gnu_field) - = DECL_INTERNAL_P (gnu_old_field); - SET_DECL_ORIGINAL_FIELD - (gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field) - ? DECL_ORIGINAL_FIELD (gnu_old_field) - : gnu_old_field)); - DECL_DISCRIMINANT_NUMBER (gnu_field) - = DECL_DISCRIMINANT_NUMBER (gnu_old_field); - TREE_THIS_VOLATILE (gnu_field) - = TREE_THIS_VOLATILE (gnu_old_field); - - /* To match the layout crafted in components_to_record, if - this is the _Tag field, put it before any discriminants - instead of after them as for all other fields. */ - if (Chars (gnat_field) == Name_uTag) - gnu_field_list = chainon (gnu_field_list, gnu_field); - else - { - TREE_CHAIN (gnu_field) = gnu_field_list; - gnu_field_list = gnu_field; - } - - save_gnu_tree (gnat_field, gnu_field, false); - } - - /* Now go through the entities again looking for Itypes that - we have not elaborated but should (e.g., Etypes of fields - that have Original_Components). */ - for (gnat_field = First_Entity (gnat_entity); - Present (gnat_field); gnat_field = Next_Entity (gnat_field)) - if ((Ekind (gnat_field) == E_Discriminant - || Ekind (gnat_field) == E_Component) - && !present_gnu_tree (Etype (gnat_field))) - gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0); - - /* Do not finalize it since we're going to modify it below. */ - finish_record_type (gnu_type, nreverse (gnu_field_list), - 2, true); - - /* Now set the size, alignment and alias set of the new type to - match that of the old one, doing any substitutions, as - above. */ - TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type); - TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type); - TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type); - SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type)); - copy_alias_set (gnu_type, gnu_base_type); - - if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) - for (gnu_temp = gnu_subst_list; - gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) - TYPE_SIZE (gnu_type) - = substitute_in_expr (TYPE_SIZE (gnu_type), - TREE_PURPOSE (gnu_temp), - TREE_VALUE (gnu_temp)); - - if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type))) - for (gnu_temp = gnu_subst_list; - gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) - TYPE_SIZE_UNIT (gnu_type) - = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type), - TREE_PURPOSE (gnu_temp), - TREE_VALUE (gnu_temp)); - - if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type))) - for (gnu_temp = gnu_subst_list; - gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) - SET_TYPE_ADA_SIZE - (gnu_type, substitute_in_expr (TYPE_ADA_SIZE (gnu_type), - TREE_PURPOSE (gnu_temp), - TREE_VALUE (gnu_temp))); - - /* Reapply variable_size since we have changed the sizes. */ - TYPE_SIZE (gnu_type) = variable_size (TYPE_SIZE (gnu_type)); - TYPE_SIZE_UNIT (gnu_type) - = variable_size (TYPE_SIZE_UNIT (gnu_type)); - - /* Recompute the mode of this record type now that we know its - actual size. */ - compute_record_mode (gnu_type); - - /* Fill in locations of fields. */ - annotate_rep (gnat_entity, gnu_type); - - /* We've built a new type, make an XVS type to show what this - is a subtype of. Some debuggers require the XVS type to be - output first, so do it in that order. */ - if (debug_info_p) - { - tree gnu_subtype_marker = make_node (RECORD_TYPE); - tree gnu_orig_name = TYPE_NAME (gnu_orig_type); - - if (TREE_CODE (gnu_orig_name) == TYPE_DECL) - gnu_orig_name = DECL_NAME (gnu_orig_name); - - TYPE_NAME (gnu_subtype_marker) - = create_concat_name (gnat_entity, "XVS"); - finish_record_type (gnu_subtype_marker, - create_field_decl (gnu_orig_name, - integer_type_node, - gnu_subtype_marker, - 0, NULL_TREE, - NULL_TREE, 0), - 0, false); - } - - /* Now we can finalize it. */ - rest_of_record_type_compilation (gnu_type); - } - - /* Otherwise, go down all the components in the new type and - make them equivalent to those in the base type. */ - else - for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp); - gnat_temp = Next_Entity (gnat_temp)) - if ((Ekind (gnat_temp) == E_Discriminant - && !Is_Unchecked_Union (gnat_base_type)) - || Ekind (gnat_temp) == E_Component) - save_gnu_tree (gnat_temp, - gnat_to_gnu_field_decl - (Original_Record_Component (gnat_temp)), false); - } - break; - - case E_Access_Subprogram_Type: - case E_Anonymous_Access_Subprogram_Type: - /* If we are not defining this entity, and we have incomplete - entities being processed above us, make a dummy type and - fill it in later. */ - if (!definition && defer_incomplete_level != 0) - { - struct incomplete *p - = (struct incomplete *) xmalloc (sizeof (struct incomplete)); - - gnu_type - = build_pointer_type - (make_dummy_type (Directly_Designated_Type (gnat_entity))); - gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, - !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); - this_made_decl = true; - gnu_type = TREE_TYPE (gnu_decl); - save_gnu_tree (gnat_entity, gnu_decl, false); - saved = true; - - p->old_type = TREE_TYPE (gnu_type); - p->full_type = Directly_Designated_Type (gnat_entity); - p->next = defer_incomplete_list; - defer_incomplete_list = p; - break; - } - - /* ... fall through ... */ - - case E_Allocator_Type: - case E_Access_Type: - case E_Access_Attribute_Type: - case E_Anonymous_Access_Type: - case E_General_Access_Type: - { - Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity); - Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type); - bool is_from_limited_with - = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind) - && From_With_Type (gnat_desig_equiv)); - - /* Get the "full view" of this entity. If this is an incomplete - entity from a limited with, treat its non-limited view as the full - view. Otherwise, if this is an incomplete or private type, use the - full view. In the former case, we might point to a private type, - in which case, we need its full view. Also, we want to look at the - actual type used for the representation, so this takes a total of - three steps. */ - Entity_Id gnat_desig_full_direct_first - = (is_from_limited_with ? Non_Limited_View (gnat_desig_equiv) - : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind) - ? Full_View (gnat_desig_equiv) : Empty)); - Entity_Id gnat_desig_full_direct - = ((is_from_limited_with - && Present (gnat_desig_full_direct_first) - && IN (Ekind (gnat_desig_full_direct_first), Private_Kind)) - ? Full_View (gnat_desig_full_direct_first) - : gnat_desig_full_direct_first); - Entity_Id gnat_desig_full - = Gigi_Equivalent_Type (gnat_desig_full_direct); - - /* This the type actually used to represent the designated type, - either gnat_desig_full or gnat_desig_equiv. */ - Entity_Id gnat_desig_rep; - - /* Nonzero if this is a pointer to an unconstrained array. */ - bool is_unconstrained_array; - - /* We want to know if we'll be seeing the freeze node for any - incomplete type we may be pointing to. */ - bool in_main_unit - = (Present (gnat_desig_full) - ? In_Extended_Main_Code_Unit (gnat_desig_full) - : In_Extended_Main_Code_Unit (gnat_desig_type)); - - /* Nonzero if we make a dummy type here. */ - bool got_fat_p = false; - /* Nonzero if the dummy is a fat pointer. */ - bool made_dummy = false; - tree gnu_desig_type = NULL_TREE; - enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0); - - if (!targetm.valid_pointer_mode (p_mode)) - p_mode = ptr_mode; - - /* If either the designated type or its full view is an unconstrained - array subtype, replace it with the type it's a subtype of. This - avoids problems with multiple copies of unconstrained array types. - Likewise, if the designated type is a subtype of an incomplete - record type, use the parent type to avoid order of elaboration - issues. This can lose some code efficiency, but there is no - alternative. */ - if (Ekind (gnat_desig_equiv) == E_Array_Subtype - && ! Is_Constrained (gnat_desig_equiv)) - gnat_desig_equiv = Etype (gnat_desig_equiv); - if (Present (gnat_desig_full) - && ((Ekind (gnat_desig_full) == E_Array_Subtype - && ! Is_Constrained (gnat_desig_full)) - || (Ekind (gnat_desig_full) == E_Record_Subtype - && Ekind (Etype (gnat_desig_full)) == E_Record_Type))) - gnat_desig_full = Etype (gnat_desig_full); - - /* Now set the type that actually marks the representation of - the designated type and also flag whether we have a unconstrained - array. */ - gnat_desig_rep = gnat_desig_full ? gnat_desig_full : gnat_desig_equiv; - is_unconstrained_array - = (Is_Array_Type (gnat_desig_rep) - && ! Is_Constrained (gnat_desig_rep)); - - /* If we are pointing to an incomplete type whose completion is an - unconstrained array, make a fat pointer type. The two types in our - fields will be pointers to dummy nodes and will be replaced in - update_pointer_to. Similarly, if the type itself is a dummy type or - an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE - in case we have any thin pointers to it. */ - if (is_unconstrained_array - && (Present (gnat_desig_full) - || (present_gnu_tree (gnat_desig_equiv) - && TYPE_IS_DUMMY_P (TREE_TYPE - (get_gnu_tree (gnat_desig_equiv)))) - || (No (gnat_desig_full) && ! in_main_unit - && defer_incomplete_level != 0 - && ! present_gnu_tree (gnat_desig_equiv)) - || (in_main_unit && is_from_limited_with - && Present (Freeze_Node (gnat_desig_rep))))) - { - tree gnu_old - = (present_gnu_tree (gnat_desig_rep) - ? TREE_TYPE (get_gnu_tree (gnat_desig_rep)) - : make_dummy_type (gnat_desig_rep)); - tree fields; - - /* Show the dummy we get will be a fat pointer. */ - got_fat_p = made_dummy = true; - - /* If the call above got something that has a pointer, that - pointer is our type. This could have happened either - because the type was elaborated or because somebody - else executed the code below. */ - gnu_type = TYPE_POINTER_TO (gnu_old); - if (!gnu_type) - { - tree gnu_template_type = make_node (ENUMERAL_TYPE); - tree gnu_ptr_template = build_pointer_type (gnu_template_type); - tree gnu_array_type = make_node (ENUMERAL_TYPE); - tree gnu_ptr_array = build_pointer_type (gnu_array_type); - - TYPE_NAME (gnu_template_type) - = concat_id_with_name (get_entity_name (gnat_desig_equiv), - "XUB"); - TYPE_DUMMY_P (gnu_template_type) = 1; - - TYPE_NAME (gnu_array_type) - = concat_id_with_name (get_entity_name (gnat_desig_equiv), - "XUA"); - TYPE_DUMMY_P (gnu_array_type) = 1; - - gnu_type = make_node (RECORD_TYPE); - SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old); - TYPE_POINTER_TO (gnu_old) = gnu_type; - - Sloc_to_locus (Sloc (gnat_entity), &input_location); - fields - = chainon (chainon (NULL_TREE, - create_field_decl - (get_identifier ("P_ARRAY"), - gnu_ptr_array, - gnu_type, 0, 0, 0, 0)), - create_field_decl (get_identifier ("P_BOUNDS"), - gnu_ptr_template, - gnu_type, 0, 0, 0, 0)); - - /* Make sure we can place this into a register. */ - TYPE_ALIGN (gnu_type) - = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); - TYPE_IS_FAT_POINTER_P (gnu_type) = 1; - - /* Do not finalize this record type since the types of - its fields are incomplete. */ - finish_record_type (gnu_type, fields, 0, true); - - TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE); - TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old)) - = concat_id_with_name (get_entity_name (gnat_desig_equiv), - "XUT"); - TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1; - } - } - - /* If we already know what the full type is, use it. */ - else if (Present (gnat_desig_full) - && present_gnu_tree (gnat_desig_full)) - gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full)); - - /* Get the type of the thing we are to point to and build a pointer - to it. If it is a reference to an incomplete or private type with a - full view that is a record, make a dummy type node and get the - actual type later when we have verified it is safe. */ - else if ((! in_main_unit - && ! present_gnu_tree (gnat_desig_equiv) - && Present (gnat_desig_full) - && ! present_gnu_tree (gnat_desig_full) - && Is_Record_Type (gnat_desig_full)) - /* Likewise if we are pointing to a record or array and we - are to defer elaborating incomplete types. We do this - since this access type may be the full view of some - private type. Note that the unconstrained array case is - handled above. */ - || ((! in_main_unit || imported_p) - && defer_incomplete_level != 0 - && ! present_gnu_tree (gnat_desig_equiv) - && ((Is_Record_Type (gnat_desig_rep) - || Is_Array_Type (gnat_desig_rep)))) - /* If this is a reference from a limited_with type back to our - main unit and there's a Freeze_Node for it, either we have - already processed the declaration and made the dummy type, - in which case we just reuse the latter, or we have not yet, - in which case we make the dummy type and it will be reused - when the declaration is processed. In both cases, the - pointer eventually created below will be automatically - adjusted when the Freeze_Node is processed. Note that the - unconstrained array case is handled above. */ - || (in_main_unit && is_from_limited_with - && Present (Freeze_Node (gnat_desig_rep)))) - { - gnu_desig_type = make_dummy_type (gnat_desig_equiv); - made_dummy = true; - } - - /* Otherwise handle the case of a pointer to itself. */ - else if (gnat_desig_equiv == gnat_entity) - { - gnu_type - = build_pointer_type_for_mode (void_type_node, p_mode, - No_Strict_Aliasing (gnat_entity)); - TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type; - } - - /* If expansion is disabled, the equivalent type of a concurrent - type is absent, so build a dummy pointer type. */ - else if (type_annotate_only && No (gnat_desig_equiv)) - gnu_type = ptr_void_type_node; - - /* Finally, handle the straightforward case where we can just - elaborate our designated type and point to it. */ - else - gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv); - - /* It is possible that a call to gnat_to_gnu_type above resolved our - type. If so, just return it. */ - if (present_gnu_tree (gnat_entity)) - { - maybe_present = true; - break; - } - - /* If we have a GCC type for the designated type, possibly modify it - if we are pointing only to constant objects and then make a pointer - to it. Don't do this for unconstrained arrays. */ - if (!gnu_type && gnu_desig_type) - { - if (Is_Access_Constant (gnat_entity) - && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE) - { - gnu_desig_type - = build_qualified_type - (gnu_desig_type, - TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST); - - /* Some extra processing is required if we are building a - pointer to an incomplete type (in the GCC sense). We might - have such a type if we just made a dummy, or directly out - of the call to gnat_to_gnu_type above if we are processing - an access type for a record component designating the - record type itself. */ - if (TYPE_MODE (gnu_desig_type) == VOIDmode) - { - /* We must ensure that the pointer to variant we make will - be processed by update_pointer_to when the initial type - is completed. Pretend we made a dummy and let further - processing act as usual. */ - made_dummy = true; - - /* We must ensure that update_pointer_to will not retrieve - the dummy variant when building a properly qualified - version of the complete type. We take advantage of the - fact that get_qualified_type is requiring TYPE_NAMEs to - match to influence build_qualified_type and then also - update_pointer_to here. */ - TYPE_NAME (gnu_desig_type) - = create_concat_name (gnat_desig_type, "INCOMPLETE_CST"); - } - } - - gnu_type - = build_pointer_type_for_mode (gnu_desig_type, p_mode, - No_Strict_Aliasing (gnat_entity)); - } - - /* If we are not defining this object and we made a dummy pointer, - save our current definition, evaluate the actual type, and replace - the tentative type we made with the actual one. If we are to defer - actually looking up the actual type, make an entry in the - deferred list. If this is from a limited with, we have to defer - to the end of the current spec in two cases: first if the - designated type is in the current unit and second if the access - type is. */ - if ((! in_main_unit || is_from_limited_with) && made_dummy) - { - tree gnu_old_type - = TYPE_FAT_POINTER_P (gnu_type) - ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type); - - if (esize == POINTER_SIZE - && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type))) - gnu_type - = build_pointer_type - (TYPE_OBJECT_RECORD_TYPE - (TYPE_UNCONSTRAINED_ARRAY (gnu_type))); - - gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, - !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); - this_made_decl = true; - gnu_type = TREE_TYPE (gnu_decl); - save_gnu_tree (gnat_entity, gnu_decl, false); - saved = true; - - if (defer_incomplete_level == 0 - && ! (is_from_limited_with - && (in_main_unit - || In_Extended_Main_Code_Unit (gnat_entity)))) - update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type), - gnat_to_gnu_type (gnat_desig_equiv)); - - /* Note that the call to gnat_to_gnu_type here might have - updated gnu_old_type directly, in which case it is not a - dummy type any more when we get into update_pointer_to. - - This may happen for instance when the designated type is a - record type, because their elaboration starts with an - initial node from make_dummy_type, which may yield the same - node as the one we got. - - Besides, variants of this non-dummy type might have been - created along the way. update_pointer_to is expected to - properly take care of those situations. */ - else - { - struct incomplete *p - = (struct incomplete *) xmalloc (sizeof - (struct incomplete)); - struct incomplete **head - = (is_from_limited_with - && (in_main_unit - || In_Extended_Main_Code_Unit (gnat_entity)) - ? &defer_limited_with : &defer_incomplete_list); - - p->old_type = gnu_old_type; - p->full_type = gnat_desig_equiv; - p->next = *head; - *head = p; - } - } - } - break; - - case E_Access_Protected_Subprogram_Type: - case E_Anonymous_Access_Protected_Subprogram_Type: - if (type_annotate_only && No (gnat_equiv_type)) - gnu_type = ptr_void_type_node; - else - { - /* The runtime representation is the equivalent type. */ - gnu_type = gnat_to_gnu_type (gnat_equiv_type); - maybe_present = 1; - } - - if (Is_Itype (Directly_Designated_Type (gnat_entity)) - && !present_gnu_tree (Directly_Designated_Type (gnat_entity)) - && No (Freeze_Node (Directly_Designated_Type (gnat_entity))) - && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity)))) - gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity), - NULL_TREE, 0); - - break; - - case E_Access_Subtype: - - /* We treat this as identical to its base type; any constraint is - meaningful only to the front end. - - The designated type must be elaborated as well, if it does - not have its own freeze node. Designated (sub)types created - for constrained components of records with discriminants are - not frozen by the front end and thus not elaborated by gigi, - because their use may appear before the base type is frozen, - and because it is not clear that they are needed anywhere in - Gigi. With the current model, there is no correct place where - they could be elaborated. */ - - gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); - if (Is_Itype (Directly_Designated_Type (gnat_entity)) - && !present_gnu_tree (Directly_Designated_Type (gnat_entity)) - && Is_Frozen (Directly_Designated_Type (gnat_entity)) - && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))) - { - /* If we are not defining this entity, and we have incomplete - entities being processed above us, make a dummy type and - elaborate it later. */ - if (!definition && defer_incomplete_level != 0) - { - struct incomplete *p - = (struct incomplete *) xmalloc (sizeof (struct incomplete)); - tree gnu_ptr_type - = build_pointer_type - (make_dummy_type (Directly_Designated_Type (gnat_entity))); - - p->old_type = TREE_TYPE (gnu_ptr_type); - p->full_type = Directly_Designated_Type (gnat_entity); - p->next = defer_incomplete_list; - defer_incomplete_list = p; - } - else if (!IN (Ekind (Base_Type - (Directly_Designated_Type (gnat_entity))), - Incomplete_Or_Private_Kind)) - gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity), - NULL_TREE, 0); - } - - maybe_present = true; - break; - - /* Subprogram Entities - - The following access functions are defined for subprograms (functions - or procedures): - - First_Formal The first formal parameter. - Is_Imported Indicates that the subprogram has appeared in - an INTERFACE or IMPORT pragma. For now we - assume that the external language is C. - Is_Exported Likewise but for an EXPORT pragma. - Is_Inlined True if the subprogram is to be inlined. - - In addition for function subprograms we have: - - Etype Return type of the function. - - Each parameter is first checked by calling must_pass_by_ref on its - type to determine if it is passed by reference. For parameters which - are copied in, if they are Ada In Out or Out parameters, their return - value becomes part of a record which becomes the return type of the - function (C function - note that this applies only to Ada procedures - so there is no Ada return type). Additional code to store back the - parameters will be generated on the caller side. This transformation - is done here, not in the front-end. - - The intended result of the transformation can be seen from the - equivalent source rewritings that follow: - - struct temp {int a,b}; - procedure P (A,B: In Out ...) is temp P (int A,B) - begin { - .. .. - end P; return {A,B}; - } - - temp t; - P(X,Y); t = P(X,Y); - X = t.a , Y = t.b; - - For subprogram types we need to perform mainly the same conversions to - GCC form that are needed for procedures and function declarations. The - only difference is that at the end, we make a type declaration instead - of a function declaration. */ - - case E_Subprogram_Type: - case E_Function: - case E_Procedure: - { - /* The first GCC parameter declaration (a PARM_DECL node). The - PARM_DECL nodes are chained through the TREE_CHAIN field, so this - actually is the head of this parameter list. */ - tree gnu_param_list = NULL_TREE; - /* Likewise for the stub associated with an exported procedure. */ - tree gnu_stub_param_list = NULL_TREE; - /* The type returned by a function. If the subprogram is a procedure - this type should be void_type_node. */ - tree gnu_return_type = void_type_node; - /* List of fields in return type of procedure with copy-in copy-out - parameters. */ - tree gnu_field_list = NULL_TREE; - /* Non-null for subprograms containing parameters passed by copy-in - copy-out (Ada In Out or Out parameters not passed by reference), - in which case it is the list of nodes used to specify the values of - the in out/out parameters that are returned as a record upon - procedure return. The TREE_PURPOSE of an element of this list is - a field of the record and the TREE_VALUE is the PARM_DECL - corresponding to that field. This list will be saved in the - TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */ - tree gnu_return_list = NULL_TREE; - /* If an import pragma asks to map this subprogram to a GCC builtin, - this is the builtin DECL node. */ - tree gnu_builtin_decl = NULL_TREE; - /* For the stub associated with an exported procedure. */ - tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE; - tree gnu_ext_name = create_concat_name (gnat_entity, NULL); - Entity_Id gnat_param; - bool inline_flag = Is_Inlined (gnat_entity); - bool public_flag = Is_Public (gnat_entity); - bool extern_flag - = (Is_Public (gnat_entity) && !definition) || imported_p; - bool pure_flag = Is_Pure (gnat_entity); - bool volatile_flag = No_Return (gnat_entity); - bool returns_by_ref = false; - bool returns_unconstrained = false; - bool returns_by_target_ptr = false; - bool has_copy_in_out = false; - bool has_stub = false; - int parmnum; - - if (kind == E_Subprogram_Type && !definition) - /* A parameter may refer to this type, so defer completion - of any incomplete types. */ - defer_incomplete_level++, this_deferred = true; - - /* If the subprogram has an alias, it is probably inherited, so - we can use the original one. If the original "subprogram" - is actually an enumeration literal, it may be the first use - of its type, so we must elaborate that type now. */ - if (Present (Alias (gnat_entity))) - { - if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal) - gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0); - - gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), - gnu_expr, 0); - - /* Elaborate any Itypes in the parameters of this entity. */ - for (gnat_temp = First_Formal_With_Extras (gnat_entity); - Present (gnat_temp); - gnat_temp = Next_Formal_With_Extras (gnat_temp)) - if (Is_Itype (Etype (gnat_temp))) - gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); - - break; - } - - /* If this subprogram is expectedly bound to a GCC builtin, fetch the - corresponding DECL node. - - We still want the parameter associations to take place because the - proper generation of calls depends on it (a GNAT parameter without - a corresponding GCC tree has a very specific meaning), so we don't - just break here. */ - if (Convention (gnat_entity) == Convention_Intrinsic) - gnu_builtin_decl = builtin_decl_for (gnu_ext_name); - - /* ??? What if we don't find the builtin node above ? warn ? err ? - In the current state we neither warn nor err, and calls will just - be handled as for regular subprograms. */ - - if (kind == E_Function || kind == E_Subprogram_Type) - gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity)); - - /* If this function returns by reference, make the actual - return type of this function the pointer and mark the decl. */ - if (Returns_By_Ref (gnat_entity)) - { - returns_by_ref = true; - gnu_return_type = build_pointer_type (gnu_return_type); - } - - /* If the Mechanism is By_Reference, ensure the return type uses - the machine's by-reference mechanism, which may not the same - as above (e.g., it might be by passing a fake parameter). */ - else if (kind == E_Function - && Mechanism (gnat_entity) == By_Reference) - { - TREE_ADDRESSABLE (gnu_return_type) = 1; - - /* We expect this bit to be reset by gigi shortly, so can avoid a - type node copy here. This actually also prevents troubles with - the generation of debug information for the function, because - we might have issued such info for this type already, and would - be attaching a distinct type node to the function if we made a - copy here. */ - } - - /* If we are supposed to return an unconstrained array, - actually return a fat pointer and make a note of that. Return - a pointer to an unconstrained record of variable size. */ - else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE) - { - gnu_return_type = TREE_TYPE (gnu_return_type); - returns_unconstrained = true; - } - - /* If the type requires a transient scope, the result is allocated - on the secondary stack, so the result type of the function is - just a pointer. */ - else if (Requires_Transient_Scope (Etype (gnat_entity))) - { - gnu_return_type = build_pointer_type (gnu_return_type); - returns_unconstrained = true; - } - - /* If the type is a padded type and the underlying type would not - be passed by reference or this function has a foreign convention, - return the underlying type. */ - else if (TREE_CODE (gnu_return_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_return_type) - && (!default_pass_by_ref (TREE_TYPE - (TYPE_FIELDS (gnu_return_type))) - || Has_Foreign_Convention (gnat_entity))) - gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type)); - - /* If the return type is unconstrained, that means it must have a - maximum size. We convert the function into a procedure and its - caller will pass a pointer to an object of that maximum size as the - first parameter when we call the function. */ - if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type))) - { - returns_by_target_ptr = true; - gnu_param_list - = create_param_decl (get_identifier ("TARGET"), - build_reference_type (gnu_return_type), - true); - gnu_return_type = void_type_node; - } - - /* If the return type has a size that overflows, we cannot have - a function that returns that type. This usage doesn't make - sense anyway, so give an error here. */ - if (TYPE_SIZE_UNIT (gnu_return_type) - && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type)) - && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type))) - { - post_error ("cannot return type whose size overflows", - gnat_entity); - gnu_return_type = copy_node (gnu_return_type); - TYPE_SIZE (gnu_return_type) = bitsize_zero_node; - TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node; - TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type; - TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE; - } - - /* Look at all our parameters and get the type of - each. While doing this, build a copy-out structure if - we need one. */ - - /* Loop over the parameters and get their associated GCC tree. - While doing this, build a copy-out structure if we need one. */ - for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0; - Present (gnat_param); - gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++) - { - tree gnu_param_name = get_entity_name (gnat_param); - tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param)); - tree gnu_param, gnu_field; - bool copy_in_copy_out = false; - Mechanism_Type mech = Mechanism (gnat_param); - - /* Builtins are expanded inline and there is no real call sequence - involved. So the type expected by the underlying expander is - always the type of each argument "as is". */ - if (gnu_builtin_decl) - mech = By_Copy; - /* Handle the first parameter of a valued procedure specially. */ - else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0) - mech = By_Copy_Return; - /* Otherwise, see if a Mechanism was supplied that forced this - parameter to be passed one way or another. */ - else if (mech == Default - || mech == By_Copy || mech == By_Reference) - ; - else if (By_Descriptor_Last <= mech && mech <= By_Descriptor) - mech = By_Descriptor; - else if (mech > 0) - { - if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE - || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST - || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type), - mech)) - mech = By_Reference; - else - mech = By_Copy; - } - else - { - post_error ("unsupported mechanism for&", gnat_param); - mech = Default; - } - - gnu_param - = gnat_to_gnu_param (gnat_param, mech, gnat_entity, - Has_Foreign_Convention (gnat_entity), - ©_in_copy_out); - - /* We are returned either a PARM_DECL or a type if no parameter - needs to be passed; in either case, adjust the type. */ - if (DECL_P (gnu_param)) - gnu_param_type = TREE_TYPE (gnu_param); - else - { - gnu_param_type = gnu_param; - gnu_param = NULL_TREE; - } - - if (gnu_param) - { - /* If it's an exported subprogram, we build a parameter list - in parallel, in case we need to emit a stub for it. */ - if (Is_Exported (gnat_entity)) - { - gnu_stub_param_list - = chainon (gnu_param, gnu_stub_param_list); - /* Change By_Descriptor parameter to By_Reference for - the internal version of an exported subprogram. */ - if (mech == By_Descriptor) - { - gnu_param - = gnat_to_gnu_param (gnat_param, By_Reference, - gnat_entity, false, - ©_in_copy_out); - has_stub = true; - } - else - gnu_param = copy_node (gnu_param); - } - - gnu_param_list = chainon (gnu_param, gnu_param_list); - Sloc_to_locus (Sloc (gnat_param), - &DECL_SOURCE_LOCATION (gnu_param)); - save_gnu_tree (gnat_param, gnu_param, false); - - /* If a parameter is a pointer, this function may modify - memory through it and thus shouldn't be considered - a pure function. Also, the memory may be modified - between two calls, so they can't be CSE'ed. The latter - case also handles by-ref parameters. */ - if (POINTER_TYPE_P (gnu_param_type) - || TYPE_FAT_POINTER_P (gnu_param_type)) - pure_flag = false; - } - - if (copy_in_copy_out) - { - if (!has_copy_in_out) - { - gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE); - gnu_return_type = make_node (RECORD_TYPE); - TYPE_NAME (gnu_return_type) = get_identifier ("RETURN"); - has_copy_in_out = true; - } - - gnu_field = create_field_decl (gnu_param_name, gnu_param_type, - gnu_return_type, 0, 0, 0, 0); - Sloc_to_locus (Sloc (gnat_param), - &DECL_SOURCE_LOCATION (gnu_field)); - TREE_CHAIN (gnu_field) = gnu_field_list; - gnu_field_list = gnu_field; - gnu_return_list = tree_cons (gnu_field, gnu_param, - gnu_return_list); - } - } - - /* Do not compute record for out parameters if subprogram is - stubbed since structures are incomplete for the back-end. */ - if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed) - finish_record_type (gnu_return_type, nreverse (gnu_field_list), - 0, false); - - /* If we have a CICO list but it has only one entry, we convert - this function into a function that simply returns that one - object. */ - if (list_length (gnu_return_list) == 1) - gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list)); - - if (Has_Stdcall_Convention (gnat_entity)) - prepend_one_attribute_to - (&attr_list, ATTR_MACHINE_ATTRIBUTE, - get_identifier ("stdcall"), NULL_TREE, - gnat_entity); - - /* The lists have been built in reverse. */ - gnu_param_list = nreverse (gnu_param_list); - if (has_stub) - gnu_stub_param_list = nreverse (gnu_stub_param_list); - gnu_return_list = nreverse (gnu_return_list); - - if (Ekind (gnat_entity) == E_Function) - Set_Mechanism (gnat_entity, - (returns_by_ref || returns_unconstrained - ? By_Reference : By_Copy)); - gnu_type - = create_subprog_type (gnu_return_type, gnu_param_list, - gnu_return_list, returns_unconstrained, - returns_by_ref, - Function_Returns_With_DSP (gnat_entity), - returns_by_target_ptr); - - if (has_stub) - gnu_stub_type - = create_subprog_type (gnu_return_type, gnu_stub_param_list, - gnu_return_list, returns_unconstrained, - returns_by_ref, - Function_Returns_With_DSP (gnat_entity), - returns_by_target_ptr); - - /* A subprogram (something that doesn't return anything) shouldn't - be considered Pure since there would be no reason for such a - subprogram. Note that procedures with Out (or In Out) parameters - have already been converted into a function with a return type. */ - if (TREE_CODE (gnu_return_type) == VOID_TYPE) - pure_flag = false; - - /* The semantics of "pure" in Ada essentially matches that of "const" - in the back-end. In particular, both properties are orthogonal to - the "nothrow" property. But this is true only if the EH circuitry - is explicit in the internal representation of the back-end. If we - are to completely hide the EH circuitry from it, we need to declare - that calls to pure Ada subprograms that can throw have side effects - since they can trigger an "abnormal" transfer of control flow; thus - they can be neither "const" nor "pure" in the back-end sense. */ - gnu_type - = build_qualified_type (gnu_type, - TYPE_QUALS (gnu_type) - | (Exception_Mechanism == Back_End_Exceptions - ? TYPE_QUAL_CONST * pure_flag : 0) - | (TYPE_QUAL_VOLATILE * volatile_flag)); - - Sloc_to_locus (Sloc (gnat_entity), &input_location); - - if (has_stub) - gnu_stub_type - = build_qualified_type (gnu_stub_type, - TYPE_QUALS (gnu_stub_type) - | (Exception_Mechanism == Back_End_Exceptions - ? TYPE_QUAL_CONST * pure_flag : 0) - | (TYPE_QUAL_VOLATILE * volatile_flag)); - - /* If we have a builtin decl for that function, check the signatures - compatibilities. If the signatures are compatible, use the builtin - decl. If they are not, we expect the checker predicate to have - posted the appropriate errors, and just continue with what we have - so far. */ - if (gnu_builtin_decl) - { - tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl); - - if (compatible_signatures_p (gnu_type, gnu_builtin_type)) - { - gnu_decl = gnu_builtin_decl; - gnu_type = gnu_builtin_type; - break; - } - } - - /* If there was no specified Interface_Name and the external and - internal names of the subprogram are the same, only use the - internal name to allow disambiguation of nested subprograms. */ - if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id) - gnu_ext_name = NULL_TREE; - - /* If we are defining the subprogram and it has an Address clause - we must get the address expression from the saved GCC tree for the - subprogram if it has a Freeze_Node. Otherwise, we elaborate - the address expression here since the front-end has guaranteed - in that case that the elaboration has no effects. If there is - an Address clause and we are not defining the object, just - make it a constant. */ - if (Present (Address_Clause (gnat_entity))) - { - tree gnu_address = NULL_TREE; - - if (definition) - gnu_address - = (present_gnu_tree (gnat_entity) - ? get_gnu_tree (gnat_entity) - : gnat_to_gnu (Expression (Address_Clause (gnat_entity)))); - - save_gnu_tree (gnat_entity, NULL_TREE, false); - - /* Convert the type of the object to a reference type that can - alias everything as per 13.3(19). */ - gnu_type - = build_reference_type_for_mode (gnu_type, ptr_mode, true); - if (gnu_address) - gnu_address = convert (gnu_type, gnu_address); - - gnu_decl - = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, - gnu_address, false, Is_Public (gnat_entity), - extern_flag, false, NULL, gnat_entity); - DECL_BY_REF_P (gnu_decl) = 1; - } - - else if (kind == E_Subprogram_Type) - gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, - !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); - else - { - if (has_stub) - { - gnu_stub_name = gnu_ext_name; - gnu_ext_name = create_concat_name (gnat_entity, "internal"); - public_flag = false; - } - - gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name, - gnu_type, gnu_param_list, - inline_flag, public_flag, - extern_flag, attr_list, - gnat_entity); - if (has_stub) - { - tree gnu_stub_decl - = create_subprog_decl (gnu_entity_id, gnu_stub_name, - gnu_stub_type, gnu_stub_param_list, - inline_flag, true, - extern_flag, attr_list, - gnat_entity); - SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl); - } - - /* This is unrelated to the stub built right above. */ - DECL_STUBBED_P (gnu_decl) - = Convention (gnat_entity) == Convention_Stubbed; - } - } - break; - - case E_Incomplete_Type: - case E_Incomplete_Subtype: - case E_Private_Type: - case E_Private_Subtype: - case E_Limited_Private_Type: - case E_Limited_Private_Subtype: - case E_Record_Type_With_Private: - case E_Record_Subtype_With_Private: - { - /* Get the "full view" of this entity. If this is an incomplete - entity from a limited with, treat its non-limited view as the - full view. Otherwise, use either the full view or the underlying - full view, whichever is present. This is used in all the tests - below. */ - Entity_Id full_view - = (IN (Ekind (gnat_entity), Incomplete_Kind) - && From_With_Type (gnat_entity)) - ? Non_Limited_View (gnat_entity) - : Present (Full_View (gnat_entity)) - ? Full_View (gnat_entity) - : Underlying_Full_View (gnat_entity); - - /* If this is an incomplete type with no full view, it must be a Taft - Amendment type, in which case we return a dummy type. Otherwise, - just get the type from its Etype. */ - if (No (full_view)) - { - if (kind == E_Incomplete_Type) - gnu_type = make_dummy_type (gnat_entity); - else - { - gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity), - NULL_TREE, 0); - maybe_present = true; - } - break; - } - - /* If we already made a type for the full view, reuse it. */ - else if (present_gnu_tree (full_view)) - { - gnu_decl = get_gnu_tree (full_view); - break; - } - - /* Otherwise, if we are not defining the type now, get the type - from the full view. But always get the type from the full view - for define on use types, since otherwise we won't see them! */ - else if (!definition - || (Is_Itype (full_view) - && No (Freeze_Node (gnat_entity))) - || (Is_Itype (gnat_entity) - && No (Freeze_Node (full_view)))) - { - gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0); - maybe_present = true; - break; - } - - /* For incomplete types, make a dummy type entry which will be - replaced later. */ - gnu_type = make_dummy_type (gnat_entity); - - /* Save this type as the full declaration's type so we can do any - needed updates when we see it. */ - gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, - !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); - save_gnu_tree (full_view, gnu_decl, 0); - break; - } - - /* Simple class_wide types are always viewed as their root_type - by Gigi unless an Equivalent_Type is specified. */ - case E_Class_Wide_Type: - gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0); - maybe_present = true; - break; - - case E_Task_Type: - case E_Task_Subtype: - case E_Protected_Type: - case E_Protected_Subtype: - if (type_annotate_only && No (gnat_equiv_type)) - gnu_type = void_type_node; - else - gnu_type = gnat_to_gnu_type (gnat_equiv_type); - - maybe_present = true; - break; - - case E_Label: - gnu_decl = create_label_decl (gnu_entity_id); - break; - - case E_Block: - case E_Loop: - /* Nothing at all to do here, so just return an ERROR_MARK and claim - we've already saved it, so we don't try to. */ - gnu_decl = error_mark_node; - saved = true; - break; - - default: - gcc_unreachable (); - } - - /* If we had a case where we evaluated another type and it might have - defined this one, handle it here. */ - if (maybe_present && present_gnu_tree (gnat_entity)) - { - gnu_decl = get_gnu_tree (gnat_entity); - saved = true; - } - - /* If we are processing a type and there is either no decl for it or - we just made one, do some common processing for the type, such as - handling alignment and possible padding. */ - - if ((!gnu_decl || this_made_decl) && IN (kind, Type_Kind)) - { - if (Is_Tagged_Type (gnat_entity) - || Is_Class_Wide_Equivalent_Type (gnat_entity)) - TYPE_ALIGN_OK (gnu_type) = 1; - - if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity)) - TYPE_BY_REFERENCE_P (gnu_type) = 1; - - /* ??? Don't set the size for a String_Literal since it is either - confirming or we don't handle it properly (if the low bound is - non-constant). */ - if (!gnu_size && kind != E_String_Literal_Subtype) - gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity, - TYPE_DECL, false, - Has_Size_Clause (gnat_entity)); - - /* If a size was specified, see if we can make a new type of that size - by rearranging the type, for example from a fat to a thin pointer. */ - if (gnu_size) - { - gnu_type - = make_type_from_size (gnu_type, gnu_size, - Has_Biased_Representation (gnat_entity)); - - if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0) - && operand_equal_p (rm_size (gnu_type), gnu_size, 0)) - gnu_size = 0; - } - - /* If the alignment hasn't already been processed and this is - not an unconstrained array, see if an alignment is specified. - If not, we pick a default alignment for atomic objects. */ - if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) - ; - else if (Known_Alignment (gnat_entity)) - align = validate_alignment (Alignment (gnat_entity), gnat_entity, - TYPE_ALIGN (gnu_type)); - else if (Is_Atomic (gnat_entity) && !gnu_size - && host_integerp (TYPE_SIZE (gnu_type), 1) - && integer_pow2p (TYPE_SIZE (gnu_type))) - align = MIN (BIGGEST_ALIGNMENT, - tree_low_cst (TYPE_SIZE (gnu_type), 1)); - else if (Is_Atomic (gnat_entity) && gnu_size - && host_integerp (gnu_size, 1) - && integer_pow2p (gnu_size)) - align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1)); - - /* See if we need to pad the type. If we did, and made a record, - the name of the new type may be changed. So get it back for - us when we make the new TYPE_DECL below. */ - gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity, "PAD", - true, definition, false); - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_type)) - { - gnu_entity_id = TYPE_NAME (gnu_type); - if (TREE_CODE (gnu_entity_id) == TYPE_DECL) - gnu_entity_id = DECL_NAME (gnu_entity_id); - } - - set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity); - - /* If we are at global level, GCC will have applied variable_size to - the type, but that won't have done anything. So, if it's not - a constant or self-referential, call elaborate_expression_1 to - make a variable for the size rather than calculating it each time. - Handle both the RM size and the actual size. */ - if (global_bindings_p () - && TYPE_SIZE (gnu_type) - && !TREE_CONSTANT (TYPE_SIZE (gnu_type)) - && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) - { - if (TREE_CODE (gnu_type) == RECORD_TYPE - && operand_equal_p (TYPE_ADA_SIZE (gnu_type), - TYPE_SIZE (gnu_type), 0)) - { - TYPE_SIZE (gnu_type) - = elaborate_expression_1 (gnat_entity, gnat_entity, - TYPE_SIZE (gnu_type), - get_identifier ("SIZE"), - definition, 0); - SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type)); - } - else - { - TYPE_SIZE (gnu_type) - = elaborate_expression_1 (gnat_entity, gnat_entity, - TYPE_SIZE (gnu_type), - get_identifier ("SIZE"), - definition, 0); - - /* ??? For now, store the size as a multiple of the alignment - in bytes so that we can see the alignment from the tree. */ - TYPE_SIZE_UNIT (gnu_type) - = build_binary_op - (MULT_EXPR, sizetype, - elaborate_expression_1 - (gnat_entity, gnat_entity, - build_binary_op (EXACT_DIV_EXPR, sizetype, - TYPE_SIZE_UNIT (gnu_type), - size_int (TYPE_ALIGN (gnu_type) - / BITS_PER_UNIT)), - get_identifier ("SIZE_A_UNIT"), - definition, 0), - size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); - - if (TREE_CODE (gnu_type) == RECORD_TYPE) - SET_TYPE_ADA_SIZE - (gnu_type, - elaborate_expression_1 (gnat_entity, - gnat_entity, - TYPE_ADA_SIZE (gnu_type), - get_identifier ("RM_SIZE"), - definition, 0)); - } - } - - /* If this is a record type or subtype, call elaborate_expression_1 on - any field position. Do this for both global and local types. - Skip any fields that we haven't made trees for to avoid problems with - class wide types. */ - if (IN (kind, Record_Kind)) - for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp); - gnat_temp = Next_Entity (gnat_temp)) - if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp)) - { - tree gnu_field = get_gnu_tree (gnat_temp); - - /* ??? Unfortunately, GCC needs to be able to prove the - alignment of this offset and if it's a variable, it can't. - In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but - right now, we have to put in an explicit multiply and - divide by that value. */ - if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field))) - { - DECL_FIELD_OFFSET (gnu_field) - = build_binary_op - (MULT_EXPR, sizetype, - elaborate_expression_1 - (gnat_temp, gnat_temp, - build_binary_op (EXACT_DIV_EXPR, sizetype, - DECL_FIELD_OFFSET (gnu_field), - size_int (DECL_OFFSET_ALIGN (gnu_field) - / BITS_PER_UNIT)), - get_identifier ("OFFSET"), - definition, 0), - size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT)); - - /* ??? The context of gnu_field is not necessarily gnu_type so - the MULT_EXPR node built above may not be marked by the call - to create_type_decl below. Mark it manually for now. */ - if (global_bindings_p ()) - TREE_VISITED (DECL_FIELD_OFFSET (gnu_field)) = 1; - } - } - - gnu_type = build_qualified_type (gnu_type, - (TYPE_QUALS (gnu_type) - | (TYPE_QUAL_VOLATILE - * Treat_As_Volatile (gnat_entity)))); - - if (Is_Atomic (gnat_entity)) - check_ok_for_atomic (gnu_type, gnat_entity, false); - - if (Present (Alignment_Clause (gnat_entity))) - TYPE_USER_ALIGN (gnu_type) = 1; - - if (Universal_Aliasing (gnat_entity)) - TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1; - - if (!gnu_decl) - gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, - !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); - else - TREE_TYPE (gnu_decl) = gnu_type; - } - - if (IN (kind, Type_Kind) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))) - { - gnu_type = TREE_TYPE (gnu_decl); - - /* Back-annotate the Alignment of the type if not already in the - tree. Likewise for sizes. */ - if (Unknown_Alignment (gnat_entity)) - Set_Alignment (gnat_entity, - UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); - - if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type)) - { - /* If the size is self-referential, we annotate the maximum - value of that size. */ - tree gnu_size = TYPE_SIZE (gnu_type); - - if (CONTAINS_PLACEHOLDER_P (gnu_size)) - gnu_size = max_size (gnu_size, true); - - Set_Esize (gnat_entity, annotate_value (gnu_size)); - - if (type_annotate_only && Is_Tagged_Type (gnat_entity)) - { - /* In this mode the tag and the parent components are not - generated by the front-end, so the sizes must be adjusted - explicitly now. */ - int size_offset, new_size; - - if (Is_Derived_Type (gnat_entity)) - { - size_offset - = UI_To_Int (Esize (Etype (Base_Type (gnat_entity)))); - Set_Alignment (gnat_entity, - Alignment (Etype (Base_Type (gnat_entity)))); - } - else - size_offset = POINTER_SIZE; - - new_size = UI_To_Int (Esize (gnat_entity)) + size_offset; - Set_Esize (gnat_entity, - UI_From_Int (((new_size + (POINTER_SIZE - 1)) - / POINTER_SIZE) * POINTER_SIZE)); - Set_RM_Size (gnat_entity, Esize (gnat_entity)); - } - } - - if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type)) - Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type))); - } - - if (!Comes_From_Source (gnat_entity) && DECL_P (gnu_decl)) - DECL_ARTIFICIAL (gnu_decl) = 1; - - if (!debug_info_p && DECL_P (gnu_decl) - && TREE_CODE (gnu_decl) != FUNCTION_DECL - && No (Renamed_Object (gnat_entity))) - DECL_IGNORED_P (gnu_decl) = 1; - - /* If we haven't already, associate the ..._DECL node that we just made with - the input GNAT entity node. */ - if (!saved) - save_gnu_tree (gnat_entity, gnu_decl, false); - - /* If this is an enumeral or floating-point type, we were not able to set - the bounds since they refer to the type. These bounds are always static. - - For enumeration types, also write debugging information and declare the - enumeration literal table, if needed. */ - - if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity))) - || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity))) - { - tree gnu_scalar_type = gnu_type; - - /* If this is a padded type, we need to use the underlying type. */ - if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_scalar_type)) - gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type)); - - /* If this is a floating point type and we haven't set a floating - point type yet, use this in the evaluation of the bounds. */ - if (!longest_float_type_node && kind == E_Floating_Point_Type) - longest_float_type_node = gnu_type; - - TYPE_MIN_VALUE (gnu_scalar_type) - = gnat_to_gnu (Type_Low_Bound (gnat_entity)); - TYPE_MAX_VALUE (gnu_scalar_type) - = gnat_to_gnu (Type_High_Bound (gnat_entity)); - - if (TREE_CODE (gnu_scalar_type) == ENUMERAL_TYPE) - { - TYPE_STUB_DECL (gnu_scalar_type) = gnu_decl; - - /* Since this has both a typedef and a tag, avoid outputting - the name twice. */ - DECL_ARTIFICIAL (gnu_decl) = 1; - rest_of_type_compilation (gnu_scalar_type, global_bindings_p ()); - } - } - - /* If we deferred processing of incomplete types, re-enable it. If there - were no other disables and we have some to process, do so. */ - if (this_deferred && --defer_incomplete_level == 0) - { - if (defer_incomplete_list) - { - struct incomplete *incp, *next; - - /* We are back to level 0 for the deferring of incomplete types. - But processing these incomplete types below may itself require - deferring, so preserve what we have and restart from scratch. */ - incp = defer_incomplete_list; - defer_incomplete_list = NULL; - - /* For finalization, however, all types must be complete so we - cannot do the same because deferred incomplete types may end up - referencing each other. Process them all recursively first. */ - defer_finalize_level++; - - for (; incp; incp = next) - { - next = incp->next; - - if (incp->old_type) - update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type), - gnat_to_gnu_type (incp->full_type)); - free (incp); - } - - defer_finalize_level--; - } - - /* All the deferred incomplete types have been processed so we can - now proceed with the finalization of the deferred types. */ - if (defer_finalize_level == 0 && defer_finalize_list) - { - int toplev = global_bindings_p (); - unsigned int i; - tree t; - - for (i = 0; VEC_iterate (tree, defer_finalize_list, i, t); i++) - rest_of_decl_compilation (t, toplev, 0); - - VEC_free (tree, heap, defer_finalize_list); - } - } - - /* If we are not defining this type, see if it's in the incomplete list. - If so, handle that list entry now. */ - else if (!definition) - { - struct incomplete *incp; - - for (incp = defer_incomplete_list; incp; incp = incp->next) - if (incp->old_type && incp->full_type == gnat_entity) - { - update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type), - TREE_TYPE (gnu_decl)); - incp->old_type = NULL_TREE; - } - } - - if (this_global) - force_global--; - - if (Is_Packed_Array_Type (gnat_entity) - && Is_Itype (Associated_Node_For_Itype (gnat_entity)) - && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity))) - && !present_gnu_tree (Associated_Node_For_Itype (gnat_entity))) - gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0); - - return gnu_decl; - } - - /* Similar, but if the returned value is a COMPONENT_REF, return the - FIELD_DECL. */ - - tree - gnat_to_gnu_field_decl (Entity_Id gnat_entity) - { - tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); - - if (TREE_CODE (gnu_field) == COMPONENT_REF) - gnu_field = TREE_OPERAND (gnu_field, 1); - - return gnu_field; - } - - /* Wrap up compilation of T, a TYPE_DECL, possibly deferring it. */ - - void - rest_of_type_decl_compilation (tree t) - { - /* We need to defer finalizing the type if incomplete types - are being deferred or if they are being processed. */ - if (defer_incomplete_level || defer_finalize_level) - VEC_safe_push (tree, heap, defer_finalize_list, t); - else - rest_of_decl_compilation (t, global_bindings_p (), 0); - } - - /* Finalize any From_With_Type incomplete types. We do this after processing - our compilation unit and after processing its spec, if this is a body. */ - - void - finalize_from_with_types (void) - { - struct incomplete *incp = defer_limited_with; - struct incomplete *next; - - defer_limited_with = 0; - for (; incp; incp = next) - { - next = incp->next; - - if (incp->old_type != 0) - update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type), - gnat_to_gnu_type (incp->full_type)); - free (incp); - } - } - - /* Return the equivalent type to be used for GNAT_ENTITY, if it's a - kind of type (such E_Task_Type) that has a different type which Gigi - uses for its representation. If the type does not have a special type - for its representation, return GNAT_ENTITY. If a type is supposed to - exist, but does not, abort unless annotating types, in which case - return Empty. If GNAT_ENTITY is Empty, return Empty. */ - - Entity_Id - Gigi_Equivalent_Type (Entity_Id gnat_entity) - { - Entity_Id gnat_equiv = gnat_entity; - - if (No (gnat_entity)) - return gnat_entity; - - switch (Ekind (gnat_entity)) - { - case E_Class_Wide_Subtype: - if (Present (Equivalent_Type (gnat_entity))) - gnat_equiv = Equivalent_Type (gnat_entity); - break; - - case E_Access_Protected_Subprogram_Type: - case E_Anonymous_Access_Protected_Subprogram_Type: - gnat_equiv = Equivalent_Type (gnat_entity); - break; - - case E_Class_Wide_Type: - gnat_equiv = ((Present (Equivalent_Type (gnat_entity))) - ? Equivalent_Type (gnat_entity) - : Root_Type (gnat_entity)); - break; - - case E_Task_Type: - case E_Task_Subtype: - case E_Protected_Type: - case E_Protected_Subtype: - gnat_equiv = Corresponding_Record_Type (gnat_entity); - break; - - default: - break; - } - - gcc_assert (Present (gnat_equiv) || type_annotate_only); - return gnat_equiv; - } - - /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and - using MECH as its passing mechanism, to be placed in the parameter - list built for GNAT_SUBPROG. Assume a foreign convention for the - latter if FOREIGN is true. Also set CICO to true if the parameter - must use the copy-in copy-out implementation mechanism. - - The returned tree is a PARM_DECL, except for those cases where no - parameter needs to be actually passed to the subprogram; the type - of this "shadow" parameter is then returned instead. */ - - static tree - gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, - Entity_Id gnat_subprog, bool foreign, bool *cico) - { - tree gnu_param_name = get_entity_name (gnat_param); - tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param)); - bool in_param = (Ekind (gnat_param) == E_In_Parameter); - /* The parameter can be indirectly modified if its address is taken. */ - bool ro_param = in_param && !Address_Taken (gnat_param); - bool by_return = false, by_component_ptr = false, by_ref = false; - tree gnu_param; - - /* Copy-return is used only for the first parameter of a valued procedure. - It's a copy mechanism for which a parameter is never allocated. */ - if (mech == By_Copy_Return) - { - gcc_assert (Ekind (gnat_param) == E_Out_Parameter); - mech = By_Copy; - by_return = true; - } - - /* If this is either a foreign function or if the underlying type won't - be passed by reference, strip off possible padding type. */ - if (TREE_CODE (gnu_param_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_param_type)) - { - tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type)); - - if (mech == By_Reference - || foreign - || (!must_pass_by_ref (unpadded_type) - && (mech == By_Copy || !default_pass_by_ref (unpadded_type)))) - gnu_param_type = unpadded_type; - } - - /* If this is a read-only parameter, make a variant of the type that is - read-only. ??? However, if this is an unconstrained array, that type - can be very complex, so skip it for now. Likewise for any other - self-referential type. */ - if (ro_param - && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE - && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type))) - gnu_param_type = build_qualified_type (gnu_param_type, - (TYPE_QUALS (gnu_param_type) - | TYPE_QUAL_CONST)); - - /* For foreign conventions, pass arrays as pointers to the element type. - First check for unconstrained array and get the underlying array. */ - if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE) - gnu_param_type - = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type)))); - - /* VMS descriptors are themselves passed by reference. */ - if (mech == By_Descriptor) - gnu_param_type - = build_pointer_type (build_vms_descriptor (gnu_param_type, - Mechanism (gnat_param), - gnat_subprog)); - - /* Arrays are passed as pointers to element type for foreign conventions. */ - else if (foreign - && mech != By_Copy - && TREE_CODE (gnu_param_type) == ARRAY_TYPE) - { - /* Strip off any multi-dimensional entries, then strip - off the last array to get the component type. */ - while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type))) - gnu_param_type = TREE_TYPE (gnu_param_type); - - by_component_ptr = true; - gnu_param_type = TREE_TYPE (gnu_param_type); - - if (ro_param) - gnu_param_type = build_qualified_type (gnu_param_type, - (TYPE_QUALS (gnu_param_type) - | TYPE_QUAL_CONST)); - - gnu_param_type = build_pointer_type (gnu_param_type); - } - - /* Fat pointers are passed as thin pointers for foreign conventions. */ - else if (foreign && TYPE_FAT_POINTER_P (gnu_param_type)) - gnu_param_type - = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0); - - /* If we must pass or were requested to pass by reference, do so. - If we were requested to pass by copy, do so. - Otherwise, for foreign conventions, pass In Out or Out parameters - or aggregates by reference. For COBOL and Fortran, pass all - integer and FP types that way too. For Convention Ada, use - the standard Ada default. */ - else if (must_pass_by_ref (gnu_param_type) - || mech == By_Reference - || (mech != By_Copy - && ((foreign - && (!in_param || AGGREGATE_TYPE_P (gnu_param_type))) - || (foreign - && (Convention (gnat_subprog) == Convention_Fortran - || Convention (gnat_subprog) == Convention_COBOL) - && (INTEGRAL_TYPE_P (gnu_param_type) - || FLOAT_TYPE_P (gnu_param_type))) - || (!foreign - && default_pass_by_ref (gnu_param_type))))) - { - gnu_param_type = build_reference_type (gnu_param_type); - by_ref = true; - } - - /* Pass In Out or Out parameters using copy-in copy-out mechanism. */ - else if (!in_param) - *cico = true; - - if (mech == By_Copy && (by_ref || by_component_ptr)) - post_error ("?cannot pass & by copy", gnat_param); - - /* If this is an Out parameter that isn't passed by reference and isn't - a pointer or aggregate, we don't make a PARM_DECL for it. Instead, - it will be a VAR_DECL created when we process the procedure, so just - return its type. For the special parameter of a valued procedure, - never pass it in. - - An exception is made to cover the RM-6.4.1 rule requiring "by copy" - Out parameters with discriminants or implicit initial values to be - handled like In Out parameters. These type are normally built as - aggregates, hence passed by reference, except for some packed arrays - which end up encoded in special integer types. - - The exception we need to make is then for packed arrays of records - with discriminants or implicit initial values. We have no light/easy - way to check for the latter case, so we merely check for packed arrays - of records. This may lead to useless copy-in operations, but in very - rare cases only, as these would be exceptions in a set of already - exceptional situations. */ - if (Ekind (gnat_param) == E_Out_Parameter - && !by_ref - && (by_return - || (mech != By_Descriptor - && !POINTER_TYPE_P (gnu_param_type) - && !AGGREGATE_TYPE_P (gnu_param_type))) - && !(Is_Array_Type (Etype (gnat_param)) - && Is_Packed (Etype (gnat_param)) - && Is_Composite_Type (Component_Type (Etype (gnat_param))))) - return gnu_param_type; - - gnu_param = create_param_decl (gnu_param_name, gnu_param_type, - ro_param || by_ref || by_component_ptr); - DECL_BY_REF_P (gnu_param) = by_ref; - DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr; - DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor); - DECL_POINTS_TO_READONLY_P (gnu_param) - = (ro_param && (by_ref || by_component_ptr)); - - /* If no Mechanism was specified, indicate what we're using, then - back-annotate it. */ - if (mech == Default) - mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy; - - Set_Mechanism (gnat_param, mech); - return gnu_param; - } - - /* Return true if DISCR1 and DISCR2 represent the same discriminant. */ - - static bool - same_discriminant_p (Entity_Id discr1, Entity_Id discr2) - { - while (Present (Corresponding_Discriminant (discr1))) - discr1 = Corresponding_Discriminant (discr1); - - while (Present (Corresponding_Discriminant (discr2))) - discr2 = Corresponding_Discriminant (discr2); - - return - Original_Record_Component (discr1) == Original_Record_Component (discr2); - } - - /* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has - a non-aliased component in the back-end sense. */ - - static bool - array_type_has_nonaliased_component (Entity_Id gnat_type, tree gnu_type) - { - /* If the type below this is a multi-array type, then - this does not have aliased components. */ - if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) - return true; - - if (Has_Aliased_Components (gnat_type)) - return false; - - return type_for_nonaliased_component_p (TREE_TYPE (gnu_type)); - } - - /* Given GNAT_ENTITY, elaborate all expressions that are required to - be elaborated at the point of its definition, but do nothing else. */ - - void - elaborate_entity (Entity_Id gnat_entity) - { - switch (Ekind (gnat_entity)) - { - case E_Signed_Integer_Subtype: - case E_Modular_Integer_Subtype: - case E_Enumeration_Subtype: - case E_Ordinary_Fixed_Point_Subtype: - case E_Decimal_Fixed_Point_Subtype: - case E_Floating_Point_Subtype: - { - Node_Id gnat_lb = Type_Low_Bound (gnat_entity); - Node_Id gnat_hb = Type_High_Bound (gnat_entity); - - /* ??? Tests for avoiding static constraint error expression - is needed until the front stops generating bogus conversions - on bounds of real types. */ - - if (!Raises_Constraint_Error (gnat_lb)) - elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"), - 1, 0, Needs_Debug_Info (gnat_entity)); - if (!Raises_Constraint_Error (gnat_hb)) - elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"), - 1, 0, Needs_Debug_Info (gnat_entity)); - break; - } - - case E_Record_Type: - { - Node_Id full_definition = Declaration_Node (gnat_entity); - Node_Id record_definition = Type_Definition (full_definition); - - /* If this is a record extension, go a level further to find the - record definition. */ - if (Nkind (record_definition) == N_Derived_Type_Definition) - record_definition = Record_Extension_Part (record_definition); - } - break; - - case E_Record_Subtype: - case E_Private_Subtype: - case E_Limited_Private_Subtype: - case E_Record_Subtype_With_Private: - if (Is_Constrained (gnat_entity) - && Has_Discriminants (Base_Type (gnat_entity)) - && Present (Discriminant_Constraint (gnat_entity))) - { - Node_Id gnat_discriminant_expr; - Entity_Id gnat_field; - - for (gnat_field = First_Discriminant (Base_Type (gnat_entity)), - gnat_discriminant_expr - = First_Elmt (Discriminant_Constraint (gnat_entity)); - Present (gnat_field); - gnat_field = Next_Discriminant (gnat_field), - gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr)) - /* ??? For now, ignore access discriminants. */ - if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr)))) - elaborate_expression (Node (gnat_discriminant_expr), - gnat_entity, - get_entity_name (gnat_field), 1, 0, 0); - } - break; - - } - } - - /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark - any entities on its entity chain similarly. */ - - void - mark_out_of_scope (Entity_Id gnat_entity) - { - Entity_Id gnat_sub_entity; - unsigned int kind = Ekind (gnat_entity); - - /* If this has an entity list, process all in the list. */ - if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind) - || IN (kind, Private_Kind) - || kind == E_Block || kind == E_Entry || kind == E_Entry_Family - || kind == E_Function || kind == E_Generic_Function - || kind == E_Generic_Package || kind == E_Generic_Procedure - || kind == E_Loop || kind == E_Operator || kind == E_Package - || kind == E_Package_Body || kind == E_Procedure - || kind == E_Record_Type || kind == E_Record_Subtype - || kind == E_Subprogram_Body || kind == E_Subprogram_Type) - for (gnat_sub_entity = First_Entity (gnat_entity); - Present (gnat_sub_entity); - gnat_sub_entity = Next_Entity (gnat_sub_entity)) - if (Scope (gnat_sub_entity) == gnat_entity - && gnat_sub_entity != gnat_entity) - mark_out_of_scope (gnat_sub_entity); - - /* Now clear this if it has been defined, but only do so if it isn't - a subprogram or parameter. We could refine this, but it isn't - worth it. If this is statically allocated, it is supposed to - hang around out of cope. */ - if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity) - && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind)) - { - save_gnu_tree (gnat_entity, NULL_TREE, true); - save_gnu_tree (gnat_entity, error_mark_node, true); - } - } - - /* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this - is a multi-dimensional array type, do this recursively. */ - - static void - copy_alias_set (tree gnu_new_type, tree gnu_old_type) - { - /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case - of a one-dimensional array, since the padding has the same alias set - as the field type, but if it's a multi-dimensional array, we need to - see the inner types. */ - while (TREE_CODE (gnu_old_type) == RECORD_TYPE - && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type) - || TYPE_IS_PADDING_P (gnu_old_type))) - gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type)); - - /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained - array. In that case, it doesn't have the same shape as GNU_NEW_TYPE, - so we need to go down to what does. */ - if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE) - gnu_old_type - = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type)))); - - if (TREE_CODE (gnu_new_type) == ARRAY_TYPE - && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type))) - copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type)); - - TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type); - record_component_aliases (gnu_new_type); - } - - /* Return a TREE_LIST describing the substitutions needed to reflect - discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add - them to GNU_LIST. If GNAT_TYPE is not specified, use the base type - of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE - gives the tree for the discriminant and TREE_VALUES is the replacement - value. They are in the form of operands to substitute_in_expr. - DEFINITION is as in gnat_to_gnu_entity. */ - - static tree - substitution_list (Entity_Id gnat_subtype, Entity_Id gnat_type, - tree gnu_list, bool definition) - { - Entity_Id gnat_discrim; - Node_Id gnat_value; - - if (No (gnat_type)) - gnat_type = Implementation_Base_Type (gnat_subtype); - - if (Has_Discriminants (gnat_type)) - for (gnat_discrim = First_Stored_Discriminant (gnat_type), - gnat_value = First_Elmt (Stored_Constraint (gnat_subtype)); - Present (gnat_discrim); - gnat_discrim = Next_Stored_Discriminant (gnat_discrim), - gnat_value = Next_Elmt (gnat_value)) - /* Ignore access discriminants. */ - if (!Is_Access_Type (Etype (Node (gnat_value)))) - gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim), - elaborate_expression - (Node (gnat_value), gnat_subtype, - get_entity_name (gnat_discrim), definition, - 1, 0), - gnu_list); - - return gnu_list; - } - - /* Return true if the size represented by GNU_SIZE can be handled by an - allocation. If STATIC_P is true, consider only what can be done with a - static allocation. */ - - static bool - allocatable_size_p (tree gnu_size, bool static_p) - { - HOST_WIDE_INT our_size; - - /* If this is not a static allocation, the only case we want to forbid - is an overflowing size. That will be converted into a raise a - Storage_Error. */ - if (!static_p) - return !(TREE_CODE (gnu_size) == INTEGER_CST - && TREE_OVERFLOW (gnu_size)); - - /* Otherwise, we need to deal with both variable sizes and constant - sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT - since assemblers may not like very large sizes. */ - if (!host_integerp (gnu_size, 1)) - return false; - - our_size = tree_low_cst (gnu_size, 1); - return (int) our_size == our_size; - } - - /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE, - NAME, ARGS and ERROR_POINT. */ - - static void - prepend_one_attribute_to (struct attrib ** attr_list, - enum attr_type attr_type, - tree attr_name, - tree attr_args, - Node_Id attr_error_point) - { - struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib)); - - attr->type = attr_type; - attr->name = attr_name; - attr->args = attr_args; - attr->error_point = attr_error_point; - - attr->next = *attr_list; - *attr_list = attr; - } - - /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */ - - static void - prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list) - { - Node_Id gnat_temp; - - for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp); - gnat_temp = Next_Rep_Item (gnat_temp)) - if (Nkind (gnat_temp) == N_Pragma) - { - tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE; - Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp); - enum attr_type etype; - - if (Present (gnat_assoc) && Present (First (gnat_assoc)) - && Present (Next (First (gnat_assoc))) - && (Nkind (Expression (Next (First (gnat_assoc)))) - == N_String_Literal)) - { - gnu_arg0 = get_identifier (TREE_STRING_POINTER - (gnat_to_gnu - (Expression (Next - (First (gnat_assoc)))))); - if (Present (Next (Next (First (gnat_assoc)))) - && (Nkind (Expression (Next (Next (First (gnat_assoc))))) - == N_String_Literal)) - gnu_arg1 = get_identifier (TREE_STRING_POINTER - (gnat_to_gnu - (Expression - (Next (Next - (First (gnat_assoc))))))); - } - - switch (Get_Pragma_Id (Chars (gnat_temp))) - { - case Pragma_Machine_Attribute: - etype = ATTR_MACHINE_ATTRIBUTE; - break; - - case Pragma_Linker_Alias: - etype = ATTR_LINK_ALIAS; - break; - - case Pragma_Linker_Section: - etype = ATTR_LINK_SECTION; - break; - - case Pragma_Linker_Constructor: - etype = ATTR_LINK_CONSTRUCTOR; - break; - - case Pragma_Linker_Destructor: - etype = ATTR_LINK_DESTRUCTOR; - break; - - case Pragma_Weak_External: - etype = ATTR_WEAK_EXTERNAL; - break; - - default: - continue; - } - - - /* Prepend to the list now. Make a list of the argument we might - have, as GCC expects it. */ - prepend_one_attribute_to - (attr_list, - etype, gnu_arg0, - (gnu_arg1 != NULL_TREE) - ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE, - Present (Next (First (gnat_assoc))) - ? Expression (Next (First (gnat_assoc))) : gnat_temp); - } - } - - /* Get the unpadded version of a GNAT type. */ - - tree - get_unpadded_type (Entity_Id gnat_entity) - { - tree type = gnat_to_gnu_type (gnat_entity); - - if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) - type = TREE_TYPE (TYPE_FIELDS (type)); - - return type; - } - - /* Called when we need to protect a variable object using a save_expr. */ - - tree - maybe_variable (tree gnu_operand) - { - if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand) - || TREE_CODE (gnu_operand) == SAVE_EXPR - || TREE_CODE (gnu_operand) == NULL_EXPR) - return gnu_operand; - - if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF) - { - tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF, - TREE_TYPE (gnu_operand), - variable_size (TREE_OPERAND (gnu_operand, 0))); - - TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) - = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand))); - return gnu_result; - } - else - return variable_size (gnu_operand); - } - - /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a - type definition (either a bound or a discriminant value) for GNAT_ENTITY, - return the GCC tree to use for that expression. GNU_NAME is the - qualification to use if an external name is appropriate and DEFINITION is - nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero, - we need a result. Otherwise, we are just elaborating this for - side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging - purposes even if it isn't needed for code generation. */ - - static tree - elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, - tree gnu_name, bool definition, bool need_value, - bool need_debug) - { - tree gnu_expr; - - /* If we already elaborated this expression (e.g., it was involved - in the definition of a private type), use the old value. */ - if (present_gnu_tree (gnat_expr)) - return get_gnu_tree (gnat_expr); - - /* If we don't need a value and this is static or a discriminant, we - don't need to do anything. */ - else if (!need_value - && (Is_OK_Static_Expression (gnat_expr) - || (Nkind (gnat_expr) == N_Identifier - && Ekind (Entity (gnat_expr)) == E_Discriminant))) - return 0; - - /* Otherwise, convert this tree to its GCC equivalent. */ - gnu_expr - = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr), - gnu_name, definition, need_debug); - - /* Save the expression in case we try to elaborate this entity again. Since - this is not a DECL, don't check it. Don't save if it's a discriminant. */ - if (!CONTAINS_PLACEHOLDER_P (gnu_expr)) - save_gnu_tree (gnat_expr, gnu_expr, true); - - return need_value ? gnu_expr : error_mark_node; - } - - /* Similar, but take a GNU expression. */ - - static tree - elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity, - tree gnu_expr, tree gnu_name, bool definition, - bool need_debug) - { - tree gnu_decl = NULL_TREE; - /* Strip any conversions to see if the expression is a readonly variable. - ??? This really should remain readonly, but we have to think about - the typing of the tree here. */ - tree gnu_inner_expr = remove_conversions (gnu_expr, true); - bool expr_global = Is_Public (gnat_entity) || global_bindings_p (); - bool expr_variable; - - /* In most cases, we won't see a naked FIELD_DECL here because a - discriminant reference will have been replaced with a COMPONENT_REF - when the type is being elaborated. However, there are some cases - involving child types where we will. So convert it to a COMPONENT_REF - here. We have to hope it will be at the highest level of the - expression in these cases. */ - if (TREE_CODE (gnu_expr) == FIELD_DECL) - gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr), - build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)), - gnu_expr, NULL_TREE); - - /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable - that is a constant, make a variable that is initialized to contain the - bound when the package containing the definition is elaborated. If - this entity is defined at top level and a bound or discriminant value - isn't a constant or a reference to a discriminant, replace the bound - by the variable; otherwise use a SAVE_EXPR if needed. Note that we - rely here on the fact that an expression cannot contain both the - discriminant and some other variable. */ - - expr_variable = (!CONSTANT_CLASS_P (gnu_expr) - && !(TREE_CODE (gnu_inner_expr) == VAR_DECL - && (TREE_READONLY (gnu_inner_expr) - || DECL_READONLY_ONCE_ELAB (gnu_inner_expr))) - && !CONTAINS_PLACEHOLDER_P (gnu_expr)); - - /* If this is a static expression or contains a discriminant, we don't - need the variable for debugging (and can't elaborate anyway if a - discriminant). */ - if (need_debug - && (Is_OK_Static_Expression (gnat_expr) - || CONTAINS_PLACEHOLDER_P (gnu_expr))) - need_debug = false; - - /* Now create the variable if we need it. */ - if (need_debug || (expr_variable && expr_global)) - gnu_decl - = create_var_decl (create_concat_name (gnat_entity, - IDENTIFIER_POINTER (gnu_name)), - NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, - !need_debug, Is_Public (gnat_entity), - !definition, false, NULL, gnat_entity); - - /* We only need to use this variable if we are in global context since GCC - can do the right thing in the local case. */ - if (expr_global && expr_variable) - return gnu_decl; - else if (!expr_variable) - return gnu_expr; - else - return maybe_variable (gnu_expr); - } - - /* Create a record type that contains a SIZE bytes long field of TYPE with a - starting bit position so that it is aligned to ALIGN bits, and leaving at - least ROOM bytes free before the field. BASE_ALIGN is the alignment the - record is guaranteed to get. */ - - tree - make_aligning_type (tree type, unsigned int align, tree size, - unsigned int base_align, int room) - { - /* We will be crafting a record type with one field at a position set to be - the next multiple of ALIGN past record'address + room bytes. We use a - record placeholder to express record'address. */ - - tree record_type = make_node (RECORD_TYPE); - tree record = build0 (PLACEHOLDER_EXPR, record_type); - - tree record_addr_st - = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record)); - - /* The diagram below summarizes the shape of what we manipulate: - - <--------- pos ----------> - { +------------+-------------+-----------------+ - record =>{ |############| ... | field (type) | - { +------------+-------------+-----------------+ - |<-- room -->|<- voffset ->|<---- size ----->| - o o - | | - record_addr vblock_addr - - Every length is in sizetype bytes there, except "pos" which has to be - set as a bit position in the GCC tree for the record. */ - - tree room_st = size_int (room); - tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st); - tree voffset_st, pos, field; - - tree name = TYPE_NAME (type); - - if (TREE_CODE (name) == TYPE_DECL) - name = DECL_NAME (name); - - TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN"); - - /* Compute VOFFSET and then POS. The next byte position multiple of some - alignment after some address is obtained by "and"ing the alignment minus - 1 with the two's complement of the address. */ - - voffset_st = size_binop (BIT_AND_EXPR, - size_diffop (size_zero_node, vblock_addr_st), - ssize_int ((align / BITS_PER_UNIT) - 1)); - - /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */ - - pos = size_binop (MULT_EXPR, - convert (bitsizetype, - size_binop (PLUS_EXPR, room_st, voffset_st)), - bitsize_unit_node); - - /* Craft the GCC record representation. We exceptionally do everything - manually here because 1) our generic circuitry is not quite ready to - handle the complex position/size expressions we are setting up, 2) we - have a strong simplifying factor at hand: we know the maximum possible - value of voffset, and 3) we have to set/reset at least the sizes in - accordance with this maximum value anyway, as we need them to convey - what should be "alloc"ated for this type. - - Use -1 as the 'addressable' indication for the field to prevent the - creation of a bitfield. We don't need one, it would have damaging - consequences on the alignment computation, and create_field_decl would - make one without this special argument, for instance because of the - complex position expression. */ - - field = create_field_decl (get_identifier ("F"), type, record_type, - 1, size, pos, -1); - TYPE_FIELDS (record_type) = field; - - TYPE_ALIGN (record_type) = base_align; - TYPE_USER_ALIGN (record_type) = 1; - - TYPE_SIZE (record_type) - = size_binop (PLUS_EXPR, - size_binop (MULT_EXPR, convert (bitsizetype, size), - bitsize_unit_node), - bitsize_int (align + room * BITS_PER_UNIT)); - TYPE_SIZE_UNIT (record_type) - = size_binop (PLUS_EXPR, size, - size_int (room + align / BITS_PER_UNIT)); - - TYPE_MODE (record_type) = BLKmode; - - copy_alias_set (record_type, type); - return record_type; - } - - /* TYPE is a RECORD_TYPE, UNION_TYPE, or QUAL_UNION_TYPE, with BLKmode that's - being used as the field type of a packed record. See if we can rewrite it - as a record that has a non-BLKmode type, which we can pack tighter. If so, - return the new type. If not, return the original type. */ - - static tree - make_packable_type (tree type) - { - tree new_type = make_node (TREE_CODE (type)); - tree field_list = NULL_TREE; - tree old_field; - - /* Copy the name and flags from the old type to that of the new. Note - that we rely on the pointer equality created here for TYPE_NAME at - the end of gnat_to_gnu. For QUAL_UNION_TYPE, also copy the size. */ - TYPE_NAME (new_type) = TYPE_NAME (type); - TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type); - TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type); - - if (TREE_CODE (type) == RECORD_TYPE) - TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type); - else if (TREE_CODE (type) == QUAL_UNION_TYPE) - { - TYPE_SIZE (new_type) = TYPE_SIZE (type); - TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type); - } - - /* Set the alignment to try for an integral type. */ - TYPE_ALIGN (new_type) = ceil_alignment (tree_low_cst (TYPE_SIZE (type), 1)); - TYPE_USER_ALIGN (new_type) = 1; - - /* Now copy the fields, keeping the position and size. */ - for (old_field = TYPE_FIELDS (type); old_field; - old_field = TREE_CHAIN (old_field)) - { - tree new_field_type = TREE_TYPE (old_field); - tree new_field; - - if (TYPE_MODE (new_field_type) == BLKmode - && (TREE_CODE (new_field_type) == RECORD_TYPE - || TREE_CODE (new_field_type) == UNION_TYPE - || TREE_CODE (new_field_type) == QUAL_UNION_TYPE) - && host_integerp (TYPE_SIZE (new_field_type), 1)) - new_field_type = make_packable_type (new_field_type); - - new_field = create_field_decl (DECL_NAME (old_field), new_field_type, - new_type, TYPE_PACKED (type), - DECL_SIZE (old_field), - bit_position (old_field), - !DECL_NONADDRESSABLE_P (old_field)); - - DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field); - SET_DECL_ORIGINAL_FIELD - (new_field, (DECL_ORIGINAL_FIELD (old_field) - ? DECL_ORIGINAL_FIELD (old_field) : old_field)); - - if (TREE_CODE (new_type) == QUAL_UNION_TYPE) - DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field); - - TREE_CHAIN (new_field) = field_list; - field_list = new_field; - } - - finish_record_type (new_type, nreverse (field_list), 1, true); - copy_alias_set (new_type, type); - - /* Try harder to get a packable type if necessary, for example - in case the record itself contains a BLKmode field. */ - if (TYPE_MODE (new_type) == BLKmode) - TYPE_MODE (new_type) - = mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1); - - return TYPE_MODE (new_type) == BLKmode ? type : new_type; - } - - /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type - if needed. We have already verified that SIZE and TYPE are large enough. - - GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and - to issue a warning. - - IS_USER_TYPE is true if we must be sure we complete the original type. - - DEFINITION is true if this type is being defined. - - SAME_RM_SIZE is true if the RM_Size of the resulting type is to be - set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original - type. */ - - tree - maybe_pad_type (tree type, tree size, unsigned int align, - Entity_Id gnat_entity, const char *name_trailer, - bool is_user_type, bool definition, bool same_rm_size) - { - tree orig_size = TYPE_SIZE (type); - unsigned int orig_align = align; - tree record; - tree field; - - /* If TYPE is a padded type, see if it agrees with any size and alignment - we were given. If so, return the original type. Otherwise, strip - off the padding, since we will either be returning the inner type - or repadding it. If no size or alignment is specified, use that of - the original padded type. */ - - if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) - { - if ((!size - || operand_equal_p (round_up (size, - MAX (align, TYPE_ALIGN (type))), - round_up (TYPE_SIZE (type), - MAX (align, TYPE_ALIGN (type))), - 0)) - && (align == 0 || align == TYPE_ALIGN (type))) - return type; - - if (!size) - size = TYPE_SIZE (type); - if (align == 0) - align = TYPE_ALIGN (type); - - type = TREE_TYPE (TYPE_FIELDS (type)); - orig_size = TYPE_SIZE (type); - } - - /* If the size is either not being changed or is being made smaller (which - is not done here (and is only valid for bitfields anyway), show the size - isn't changing. Likewise, clear the alignment if it isn't being - changed. Then return if we aren't doing anything. */ - - if (size - && (operand_equal_p (size, orig_size, 0) - || (TREE_CODE (orig_size) == INTEGER_CST - && tree_int_cst_lt (size, orig_size)))) - size = NULL_TREE; - - if (align == TYPE_ALIGN (type)) - align = 0; - - if (align == 0 && !size) - return type; - - /* We used to modify the record in place in some cases, but that could - generate incorrect debugging information. So make a new record - type and name. */ - record = make_node (RECORD_TYPE); - - if (Present (gnat_entity)) - TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer); - - /* If we were making a type, complete the original type and give it a - name. */ - if (is_user_type) - create_type_decl (get_entity_name (gnat_entity), type, - NULL, !Comes_From_Source (gnat_entity), - !(TYPE_NAME (type) - && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL - && DECL_IGNORED_P (TYPE_NAME (type))), - gnat_entity); - - /* If we are changing the alignment and the input type is a record with - BLKmode and a small constant size, try to make a form that has an - integral mode. That might allow this record to have an integral mode, - which will be much more efficient. There is no point in doing this if a - size is specified unless it is also smaller than the biggest alignment - and it is incorrect to do this if the size of the original type is not a - multiple of the alignment. */ - if (align != 0 - && TREE_CODE (type) == RECORD_TYPE - && TYPE_MODE (type) == BLKmode - && host_integerp (orig_size, 1) - && compare_tree_int (orig_size, BIGGEST_ALIGNMENT) <= 0 - && (!size - || (TREE_CODE (size) == INTEGER_CST - && compare_tree_int (size, BIGGEST_ALIGNMENT) <= 0)) - && tree_low_cst (orig_size, 1) % align == 0) - type = make_packable_type (type); - - field = create_field_decl (get_identifier ("F"), type, record, 0, - NULL_TREE, bitsize_zero_node, 1); - - DECL_INTERNAL_P (field) = 1; - TYPE_SIZE (record) = size ? size : orig_size; - TYPE_SIZE_UNIT (record) - = (size ? convert (sizetype, - size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node)) - : TYPE_SIZE_UNIT (type)); - - TYPE_ALIGN (record) = align; - if (orig_align) - TYPE_USER_ALIGN (record) = align; - - TYPE_IS_PADDING_P (record) = 1; - TYPE_VOLATILE (record) - = Present (gnat_entity) && Treat_As_Volatile (gnat_entity); - /* Do not finalize it until after the auxiliary record is built. */ - finish_record_type (record, field, 1, true); - - /* Keep the RM_Size of the padded record as that of the old record - if requested. */ - SET_TYPE_ADA_SIZE (record, same_rm_size ? size : rm_size (type)); - - /* Unless debugging information isn't being written for the input type, - write a record that shows what we are a subtype of and also make a - variable that indicates our size, if variable. */ - if (TYPE_NAME (record) - && AGGREGATE_TYPE_P (type) - && (TREE_CODE (TYPE_NAME (type)) != TYPE_DECL - || !DECL_IGNORED_P (TYPE_NAME (type)))) - { - tree marker = make_node (RECORD_TYPE); - tree name = TYPE_NAME (record); - tree orig_name = TYPE_NAME (type); - - if (TREE_CODE (name) == TYPE_DECL) - name = DECL_NAME (name); - - if (TREE_CODE (orig_name) == TYPE_DECL) - orig_name = DECL_NAME (orig_name); - - TYPE_NAME (marker) = concat_id_with_name (name, "XVS"); - finish_record_type (marker, - create_field_decl (orig_name, integer_type_node, - marker, 0, NULL_TREE, NULL_TREE, - 0), - 0, false); - - if (size && TREE_CODE (size) != INTEGER_CST && definition) - create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE, - bitsizetype, TYPE_SIZE (record), false, false, false, - false, NULL, gnat_entity); - } - - rest_of_record_type_compilation (record); - - /* If the size was widened explicitly, maybe give a warning. Take the - original size as the maximum size of the input if there was an - unconstrained record involved and round it up to the specified alignment, - if one was specified. */ - if (CONTAINS_PLACEHOLDER_P (orig_size)) - orig_size = max_size (orig_size, true); - - if (align) - orig_size = round_up (orig_size, align); - - if (size && Present (gnat_entity) - && !operand_equal_p (size, orig_size, 0) - && !(TREE_CODE (size) == INTEGER_CST - && TREE_CODE (orig_size) == INTEGER_CST - && tree_int_cst_lt (size, orig_size))) - { - Node_Id gnat_error_node = Empty; - - if (Is_Packed_Array_Type (gnat_entity)) - gnat_entity = Associated_Node_For_Itype (gnat_entity); - - if ((Ekind (gnat_entity) == E_Component - || Ekind (gnat_entity) == E_Discriminant) - && Present (Component_Clause (gnat_entity))) - gnat_error_node = Last_Bit (Component_Clause (gnat_entity)); - else if (Present (Size_Clause (gnat_entity))) - gnat_error_node = Expression (Size_Clause (gnat_entity)); - - /* Generate message only for entities that come from source, since - if we have an entity created by expansion, the message will be - generated for some other corresponding source entity. */ - if (Comes_From_Source (gnat_entity) && Present (gnat_error_node)) - post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node, - gnat_entity, - size_diffop (size, orig_size)); - - else if (*name_trailer == 'C' && !Is_Internal (gnat_entity)) - post_error_ne_tree ("component of& padded{ by ^ bits}?", - gnat_entity, gnat_entity, - size_diffop (size, orig_size)); - } - - return record; - } - - /* Given a GNU tree and a GNAT list of choices, generate an expression to test - the value passed against the list of choices. */ - - tree - choices_to_gnu (tree operand, Node_Id choices) - { - Node_Id choice; - Node_Id gnat_temp; - tree result = integer_zero_node; - tree this_test, low = 0, high = 0, single = 0; - - for (choice = First (choices); Present (choice); choice = Next (choice)) - { - switch (Nkind (choice)) - { - case N_Range: - low = gnat_to_gnu (Low_Bound (choice)); - high = gnat_to_gnu (High_Bound (choice)); - - /* There's no good type to use here, so we might as well use - integer_type_node. */ - this_test - = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, - build_binary_op (GE_EXPR, integer_type_node, - operand, low), - build_binary_op (LE_EXPR, integer_type_node, - operand, high)); - - break; - - case N_Subtype_Indication: - gnat_temp = Range_Expression (Constraint (choice)); - low = gnat_to_gnu (Low_Bound (gnat_temp)); - high = gnat_to_gnu (High_Bound (gnat_temp)); - - this_test - = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, - build_binary_op (GE_EXPR, integer_type_node, - operand, low), - build_binary_op (LE_EXPR, integer_type_node, - operand, high)); - break; - - case N_Identifier: - case N_Expanded_Name: - /* This represents either a subtype range, an enumeration - literal, or a constant Ekind says which. If an enumeration - literal or constant, fall through to the next case. */ - if (Ekind (Entity (choice)) != E_Enumeration_Literal - && Ekind (Entity (choice)) != E_Constant) - { - tree type = gnat_to_gnu_type (Entity (choice)); - - low = TYPE_MIN_VALUE (type); - high = TYPE_MAX_VALUE (type); - - this_test - = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, - build_binary_op (GE_EXPR, integer_type_node, - operand, low), - build_binary_op (LE_EXPR, integer_type_node, - operand, high)); - break; - } - /* ... fall through ... */ - case N_Character_Literal: - case N_Integer_Literal: - single = gnat_to_gnu (choice); - this_test = build_binary_op (EQ_EXPR, integer_type_node, operand, - single); - break; - - case N_Others_Choice: - this_test = integer_one_node; - break; - - default: - gcc_unreachable (); - } - - result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, - result, this_test); - } - - return result; - } - - /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of - type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */ - - static int - adjust_packed (tree field_type, tree record_type, int packed) - { - /* If the field contains an item of variable size, we cannot pack it - because we cannot create temporaries of non-fixed size. */ - if (is_variable_size (field_type)) - return 0; - - /* If the alignment of the record is specified and the field type - is over-aligned, request Storage_Unit alignment for the field. */ - if (packed == -2) - { - if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type)) - return -1; - else - return 0; - } - - return packed; - } - - /* Return a GCC tree for a field corresponding to GNAT_FIELD to be - placed in GNU_RECORD_TYPE. - - PACKED is 1 if the enclosing record is packed, -1 if the enclosing - record has Component_Alignment of Storage_Unit, -2 if the enclosing - record has a specified alignment. - - DEFINITION is true if this field is for a record being defined. */ - - static tree - gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, - bool definition) - { - tree gnu_field_id = get_entity_name (gnat_field); - tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); - tree gnu_field, gnu_size, gnu_pos; - bool needs_strict_alignment - = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field)) - || Treat_As_Volatile (gnat_field)); - - /* If this field requires strict alignment, we cannot pack it because - it would very likely be under-aligned in the record. */ - if (needs_strict_alignment) - packed = 0; - else - packed = adjust_packed (gnu_field_type, gnu_record_type, packed); - - /* If a size is specified, use it. Otherwise, if the record type is packed, - use the official RM size. See "Handling of Type'Size Values" in Einfo - for further details. */ - if (Known_Static_Esize (gnat_field)) - gnu_size = validate_size (Esize (gnat_field), gnu_field_type, - gnat_field, FIELD_DECL, false, true); - else if (packed == 1) - gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type, - gnat_field, FIELD_DECL, false, true); - else - gnu_size = NULL_TREE; - - /* If we have a specified size that's smaller than that of the field type, - or a position is specified, and the field type is also a record that's - BLKmode and with a small constant size, see if we can get an integral - mode form of the type when appropriate. If we can, show a size was - specified for the field if there wasn't one already, so we know to make - this a bitfield and avoid making things wider. - - Doing this is first useful if the record is packed because we can then - place the field at a non-byte-aligned position and so achieve tighter - packing. - - This is in addition *required* if the field shares a byte with another - field and the front-end lets the back-end handle the references, because - GCC does not handle BLKmode bitfields properly. - - We avoid the transformation if it is not required or potentially useful, - as it might entail an increase of the field's alignment and have ripple - effects on the outer record type. A typical case is a field known to be - byte aligned and not to share a byte with another field. - - Besides, we don't even look the possibility of a transformation in cases - known to be in error already, for instance when an invalid size results - from a component clause. */ - - if (TREE_CODE (gnu_field_type) == RECORD_TYPE - && TYPE_MODE (gnu_field_type) == BLKmode - && host_integerp (TYPE_SIZE (gnu_field_type), 1) - && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0 - && (packed == 1 - || (gnu_size - && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type)) - || Present (Component_Clause (gnat_field)))))) - { - /* See what the alternate type and size would be. */ - tree gnu_packable_type = make_packable_type (gnu_field_type); - - bool has_byte_aligned_clause - = Present (Component_Clause (gnat_field)) - && (UI_To_Int (Component_Bit_Offset (gnat_field)) - % BITS_PER_UNIT == 0); - - /* Compute whether we should avoid the substitution. */ - bool reject - /* There is no point substituting if there is no change... */ - = (gnu_packable_type == gnu_field_type) - /* ... nor when the field is known to be byte aligned and not to - share a byte with another field. */ - || (has_byte_aligned_clause - && value_factor_p (gnu_size, BITS_PER_UNIT)) - /* The size of an aliased field must be an exact multiple of the - type's alignment, which the substitution might increase. Reject - substitutions that would so invalidate a component clause when the - specified position is byte aligned, as the change would have no - real benefit from the packing standpoint anyway. */ - || (Is_Aliased (gnat_field) - && has_byte_aligned_clause - && !value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type))); - - /* Substitute unless told otherwise. */ - if (!reject) - { - gnu_field_type = gnu_packable_type; - - if (!gnu_size) - gnu_size = rm_size (gnu_field_type); - } - } - - /* If we are packing the record and the field is BLKmode, round the - size up to a byte boundary. */ - if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size) - gnu_size = round_up (gnu_size, BITS_PER_UNIT); - - if (Present (Component_Clause (gnat_field))) - { - gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype); - gnu_size = validate_size (Esize (gnat_field), gnu_field_type, - gnat_field, FIELD_DECL, false, true); - - /* Ensure the position does not overlap with the parent subtype, - if there is one. */ - if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field))))) - { - tree gnu_parent - = gnat_to_gnu_type (Parent_Subtype - (Underlying_Type (Scope (gnat_field)))); - - if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST - && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent))) - { - post_error_ne_tree - ("offset of& must be beyond parent{, minimum allowed is ^}", - First_Bit (Component_Clause (gnat_field)), gnat_field, - TYPE_SIZE_UNIT (gnu_parent)); - } - } - - /* If this field needs strict alignment, ensure the record is - sufficiently aligned and that that position and size are - consistent with the alignment. */ - if (needs_strict_alignment) - { - TYPE_ALIGN (gnu_record_type) - = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type)); - - if (gnu_size - && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0)) - { - if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field))) - post_error_ne_tree - ("atomic field& must be natural size of type{ (^)}", - Last_Bit (Component_Clause (gnat_field)), gnat_field, - TYPE_SIZE (gnu_field_type)); - - else if (Is_Aliased (gnat_field)) - post_error_ne_tree - ("size of aliased field& must be ^ bits", - Last_Bit (Component_Clause (gnat_field)), gnat_field, - TYPE_SIZE (gnu_field_type)); - - else if (Strict_Alignment (Etype (gnat_field))) - post_error_ne_tree - ("size of & with aliased or tagged components not ^ bits", - Last_Bit (Component_Clause (gnat_field)), gnat_field, - TYPE_SIZE (gnu_field_type)); - - gnu_size = NULL_TREE; - } - - if (!integer_zerop (size_binop - (TRUNC_MOD_EXPR, gnu_pos, - bitsize_int (TYPE_ALIGN (gnu_field_type))))) - { - if (Is_Aliased (gnat_field)) - post_error_ne_num - ("position of aliased field& must be multiple of ^ bits", - First_Bit (Component_Clause (gnat_field)), gnat_field, - TYPE_ALIGN (gnu_field_type)); - - else if (Treat_As_Volatile (gnat_field)) - post_error_ne_num - ("position of volatile field& must be multiple of ^ bits", - First_Bit (Component_Clause (gnat_field)), gnat_field, - TYPE_ALIGN (gnu_field_type)); - - else if (Strict_Alignment (Etype (gnat_field))) - post_error_ne_num - ("position of & with aliased or tagged components not multiple of ^ bits", - First_Bit (Component_Clause (gnat_field)), gnat_field, - TYPE_ALIGN (gnu_field_type)); - - else - gcc_unreachable (); - - gnu_pos = NULL_TREE; - } - } - - if (Is_Atomic (gnat_field)) - check_ok_for_atomic (gnu_field_type, gnat_field, false); - } - - /* If the record has rep clauses and this is the tag field, make a rep - clause for it as well. */ - else if (Has_Specified_Layout (Scope (gnat_field)) - && Chars (gnat_field) == Name_uTag) - { - gnu_pos = bitsize_zero_node; - gnu_size = TYPE_SIZE (gnu_field_type); - } - - else - gnu_pos = NULL_TREE; - - /* We need to make the size the maximum for the type if it is - self-referential and an unconstrained type. In that case, we can't - pack the field since we can't make a copy to align it. */ - if (TREE_CODE (gnu_field_type) == RECORD_TYPE - && !gnu_size - && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type)) - && !Is_Constrained (Underlying_Type (Etype (gnat_field)))) - { - gnu_size = max_size (TYPE_SIZE (gnu_field_type), true); - packed = 0; - } - - /* If a size is specified, adjust the field's type to it. */ - if (gnu_size) - { - /* If the field's type is justified modular, we would need to remove - the wrapper to (better) meet the layout requirements. However we - can do so only if the field is not aliased to preserve the unique - layout and if the prescribed size is not greater than that of the - packed array to preserve the justification. */ - if (!needs_strict_alignment - && TREE_CODE (gnu_field_type) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type) - && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type)) - <= 0) - gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type)); - - gnu_field_type - = make_type_from_size (gnu_field_type, gnu_size, - Has_Biased_Representation (gnat_field)); - gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field, - "PAD", false, definition, true); - } - - /* Otherwise (or if there was an error), don't specify a position. */ - else - gnu_pos = NULL_TREE; - - gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE - || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type)); - - /* Now create the decl for the field. */ - gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type, - packed, gnu_size, gnu_pos, - Is_Aliased (gnat_field)); - Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field)); - TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field); - - if (Ekind (gnat_field) == E_Discriminant) - DECL_DISCRIMINANT_NUMBER (gnu_field) - = UI_To_gnu (Discriminant_Number (gnat_field), sizetype); - - return gnu_field; - } - - /* Return true if TYPE is a type with variable size, a padding type with a - field of variable size or is a record that has a field such a field. */ - - static bool - is_variable_size (tree type) - { - tree field; - - if (!TREE_CONSTANT (TYPE_SIZE (type))) - return true; - - if (TREE_CODE (type) == RECORD_TYPE - && TYPE_IS_PADDING_P (type) - && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type)))) - return true; - - if (TREE_CODE (type) != RECORD_TYPE - && TREE_CODE (type) != UNION_TYPE - && TREE_CODE (type) != QUAL_UNION_TYPE) - return false; - - for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) - if (is_variable_size (TREE_TYPE (field))) - return true; - - return false; - } - - /* qsort comparer for the bit positions of two record components. */ - - static int - compare_field_bitpos (const PTR rt1, const PTR rt2) - { - const_tree const field1 = * (const_tree const *) rt1; - const_tree const field2 = * (const_tree const *) rt2; - const int ret - = tree_int_cst_compare (bit_position (field1), bit_position (field2)); - - return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2)); - } - - /* Return a GCC tree for a record type given a GNAT Component_List and a chain - of GCC trees for fields that are in the record and have already been - processed. When called from gnat_to_gnu_entity during the processing of a - record type definition, the GCC nodes for the discriminants will be on - the chain. The other calls to this function are recursive calls from - itself for the Component_List of a variant and the chain is empty. - - PACKED is 1 if this is for a packed record, -1 if this is for a record - with Component_Alignment of Storage_Unit, -2 if this is for a record - with a specified alignment. - - DEFINITION is true if we are defining this record. - - P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field - with a rep clause is to be added. If it is nonzero, that is all that - should be done with such fields. - - CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before - laying out the record. This means the alignment only serves to force fields - to be bitfields, but not require the record to be that aligned. This is - used for variants. - - ALL_REP, if true, means a rep clause was found for all the fields. This - simplifies the logic since we know we're not in the mixed case. - - DO_NOT_FINALIZE, if true, means that the record type is expected to be - modified afterwards so it will not be sent to the back-end for finalization. - - UNCHECKED_UNION, if true, means that we are building a type for a record - with a Pragma Unchecked_Union. - - The processing of the component list fills in the chain with all of the - fields of the record and then the record type is finished. */ - - static void - components_to_record (tree gnu_record_type, Node_Id component_list, - tree gnu_field_list, int packed, bool definition, - tree *p_gnu_rep_list, bool cancel_alignment, - bool all_rep, bool do_not_finalize, bool unchecked_union) - { - Node_Id component_decl; - Entity_Id gnat_field; - Node_Id variant_part; - tree gnu_our_rep_list = NULL_TREE; - tree gnu_field, gnu_last; - bool layout_with_rep = false; - bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type); - - /* For each variable within each component declaration create a GCC field - and add it to the list, skipping any pragmas in the list. */ - if (Present (Component_Items (component_list))) - for (component_decl = First_Non_Pragma (Component_Items (component_list)); - Present (component_decl); - component_decl = Next_Non_Pragma (component_decl)) - { - gnat_field = Defining_Entity (component_decl); - - if (Chars (gnat_field) == Name_uParent) - gnu_field = tree_last (TYPE_FIELDS (gnu_record_type)); - else - { - gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, - packed, definition); - - /* If this is the _Tag field, put it before any discriminants, - instead of after them as is the case for all other fields. */ - if (Chars (gnat_field) == Name_uTag) - gnu_field_list = chainon (gnu_field_list, gnu_field); - else - { - TREE_CHAIN (gnu_field) = gnu_field_list; - gnu_field_list = gnu_field; - } - } - - save_gnu_tree (gnat_field, gnu_field, false); - } - - /* At the end of the component list there may be a variant part. */ - variant_part = Variant_Part (component_list); - - /* We create a QUAL_UNION_TYPE for the variant part since the variants are - mutually exclusive and should go in the same memory. To do this we need - to treat each variant as a record whose elements are created from the - component list for the variant. So here we create the records from the - lists for the variants and put them all into the QUAL_UNION_TYPE. - If this is an Unchecked_Union, we make a UNION_TYPE instead or - use GNU_RECORD_TYPE if there are no fields so far. */ - if (Present (variant_part)) - { - tree gnu_discriminant = gnat_to_gnu (Name (variant_part)); - Node_Id variant; - tree gnu_name = TYPE_NAME (gnu_record_type); - tree gnu_var_name - = concat_id_with_name (get_identifier (Get_Name_String - (Chars (Name (variant_part)))), - "XVN"); - tree gnu_union_type; - tree gnu_union_name; - tree gnu_union_field; - tree gnu_variant_list = NULL_TREE; - - if (TREE_CODE (gnu_name) == TYPE_DECL) - gnu_name = DECL_NAME (gnu_name); - - gnu_union_name = concat_id_with_name (gnu_name, - IDENTIFIER_POINTER (gnu_var_name)); - - /* Reuse an enclosing union if all fields are in the variant part - and there is no representation clause on the record, to match - the layout of C unions. There is an associated check below. */ - if (!gnu_field_list - && TREE_CODE (gnu_record_type) == UNION_TYPE - && !TYPE_PACKED (gnu_record_type)) - gnu_union_type = gnu_record_type; - else - { - gnu_union_type - = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE); - - TYPE_NAME (gnu_union_type) = gnu_union_name; - TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type); - } - - for (variant = First_Non_Pragma (Variants (variant_part)); - Present (variant); - variant = Next_Non_Pragma (variant)) - { - tree gnu_variant_type = make_node (RECORD_TYPE); - tree gnu_inner_name; - tree gnu_qual; - - Get_Variant_Encoding (variant); - gnu_inner_name = get_identifier (Name_Buffer); - TYPE_NAME (gnu_variant_type) - = concat_id_with_name (gnu_union_name, - IDENTIFIER_POINTER (gnu_inner_name)); - - /* Set the alignment of the inner type in case we need to make - inner objects into bitfields, but then clear it out - so the record actually gets only the alignment required. */ - TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type); - TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type); - - /* Similarly, if the outer record has a size specified and all fields - have record rep clauses, we can propagate the size into the - variant part. */ - if (all_rep_and_size) - { - TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type); - TYPE_SIZE_UNIT (gnu_variant_type) - = TYPE_SIZE_UNIT (gnu_record_type); - } - - /* Create the record type for the variant. Note that we defer - finalizing it until after we are sure to actually use it. */ - components_to_record (gnu_variant_type, Component_List (variant), - NULL_TREE, packed, definition, - &gnu_our_rep_list, !all_rep_and_size, all_rep, - true, unchecked_union); - - gnu_qual = choices_to_gnu (gnu_discriminant, - Discrete_Choices (variant)); - - Set_Present_Expr (variant, annotate_value (gnu_qual)); - - /* If this is an Unchecked_Union and we have exactly one field, - use this field directly to match the layout of C unions. */ - if (unchecked_union - && TYPE_FIELDS (gnu_variant_type) - && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type))) - gnu_field = TYPE_FIELDS (gnu_variant_type); - else - { - /* Deal with packedness like in gnat_to_gnu_field. */ - int field_packed - = adjust_packed (gnu_variant_type, gnu_record_type, packed); - - /* Finalize the record type now. We used to throw away - empty records but we no longer do that because we need - them to generate complete debug info for the variant; - otherwise, the union type definition will be lacking - the fields associated with these empty variants. */ - rest_of_record_type_compilation (gnu_variant_type); - - gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type, - gnu_union_type, field_packed, - (all_rep_and_size - ? TYPE_SIZE (gnu_variant_type) - : 0), - (all_rep_and_size - ? bitsize_zero_node : 0), - 0); - - DECL_INTERNAL_P (gnu_field) = 1; - - if (!unchecked_union) - DECL_QUALIFIER (gnu_field) = gnu_qual; - } - - TREE_CHAIN (gnu_field) = gnu_variant_list; - gnu_variant_list = gnu_field; - } - - /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */ - if (gnu_variant_list) - { - int union_field_packed; - - if (all_rep_and_size) - { - TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type); - TYPE_SIZE_UNIT (gnu_union_type) - = TYPE_SIZE_UNIT (gnu_record_type); - } - - finish_record_type (gnu_union_type, nreverse (gnu_variant_list), - all_rep_and_size ? 1 : 0, false); - - /* If GNU_UNION_TYPE is our record type, it means we must have an - Unchecked_Union with no fields. Verify that and, if so, just - return. */ - if (gnu_union_type == gnu_record_type) - { - gcc_assert (unchecked_union - && !gnu_field_list - && !gnu_our_rep_list); - return; - } - - /* Deal with packedness like in gnat_to_gnu_field. */ - union_field_packed - = adjust_packed (gnu_union_type, gnu_record_type, packed); - - gnu_union_field - = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type, - union_field_packed, - all_rep ? TYPE_SIZE (gnu_union_type) : 0, - all_rep ? bitsize_zero_node : 0, 0); - - DECL_INTERNAL_P (gnu_union_field) = 1; - TREE_CHAIN (gnu_union_field) = gnu_field_list; - gnu_field_list = gnu_union_field; - } - } - - /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they - do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this - in a separate pass since we want to handle the discriminants but can't - play with them until we've used them in debugging data above. - - ??? Note: if we then reorder them, debugging information will be wrong, - but there's nothing that can be done about this at the moment. */ - for (gnu_field = gnu_field_list, gnu_last = NULL_TREE; gnu_field; ) - { - if (DECL_FIELD_OFFSET (gnu_field)) - { - tree gnu_next = TREE_CHAIN (gnu_field); - - if (!gnu_last) - gnu_field_list = gnu_next; - else - TREE_CHAIN (gnu_last) = gnu_next; - - TREE_CHAIN (gnu_field) = gnu_our_rep_list; - gnu_our_rep_list = gnu_field; - gnu_field = gnu_next; - } - else - { - gnu_last = gnu_field; - gnu_field = TREE_CHAIN (gnu_field); - } - } - - /* If we have any items in our rep'ed field list, it is not the case that all - the fields in the record have rep clauses, and P_REP_LIST is nonzero, - set it and ignore the items. */ - if (gnu_our_rep_list && p_gnu_rep_list && !all_rep) - *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list); - else if (gnu_our_rep_list) - { - /* Otherwise, sort the fields by bit position and put them into their - own record if we have any fields without rep clauses. */ - tree gnu_rep_type - = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type); - int len = list_length (gnu_our_rep_list); - tree *gnu_arr = (tree *) alloca (sizeof (tree) * len); - int i; - - for (i = 0, gnu_field = gnu_our_rep_list; gnu_field; - gnu_field = TREE_CHAIN (gnu_field), i++) - gnu_arr[i] = gnu_field; - - qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos); - - /* Put the fields in the list in order of increasing position, which - means we start from the end. */ - gnu_our_rep_list = NULL_TREE; - for (i = len - 1; i >= 0; i--) - { - TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list; - gnu_our_rep_list = gnu_arr[i]; - DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type; - } - - if (gnu_field_list) - { - finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, false); - gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type, - gnu_record_type, 0, 0, 0, 1); - DECL_INTERNAL_P (gnu_field) = 1; - gnu_field_list = chainon (gnu_field_list, gnu_field); - } - else - { - layout_with_rep = true; - gnu_field_list = nreverse (gnu_our_rep_list); - } - } - - if (cancel_alignment) - TYPE_ALIGN (gnu_record_type) = 0; - - finish_record_type (gnu_record_type, nreverse (gnu_field_list), - layout_with_rep ? 1 : 0, do_not_finalize); - } - - /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be - placed into an Esize, Component_Bit_Offset, or Component_Size value - in the GNAT tree. */ - - static Uint - annotate_value (tree gnu_size) - { - int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size)); - TCode tcode; - Node_Ref_Or_Val ops[3], ret; - int i; - int size; - struct tree_int_map **h = NULL; - - /* See if we've already saved the value for this node. */ - if (EXPR_P (gnu_size)) - { - struct tree_int_map in; - if (!annotate_value_cache) - annotate_value_cache = htab_create_ggc (512, tree_int_map_hash, - tree_int_map_eq, 0); - in.base.from = gnu_size; - h = (struct tree_int_map **) - htab_find_slot (annotate_value_cache, &in, INSERT); - - if (*h) - return (Node_Ref_Or_Val) (*h)->to; - } - - /* If we do not return inside this switch, TCODE will be set to the - code to use for a Create_Node operand and LEN (set above) will be - the number of recursive calls for us to make. */ - - switch (TREE_CODE (gnu_size)) - { - case INTEGER_CST: - if (TREE_OVERFLOW (gnu_size)) - return No_Uint; - - /* This may have come from a conversion from some smaller type, - so ensure this is in bitsizetype. */ - gnu_size = convert (bitsizetype, gnu_size); - - /* For negative values, use NEGATE_EXPR of the supplied value. */ - if (tree_int_cst_sgn (gnu_size) < 0) - { - /* The ridiculous code below is to handle the case of the largest - negative integer. */ - tree negative_size = size_diffop (bitsize_zero_node, gnu_size); - bool adjust = false; - tree temp; - - if (TREE_OVERFLOW (negative_size)) - { - negative_size - = size_binop (MINUS_EXPR, bitsize_zero_node, - size_binop (PLUS_EXPR, gnu_size, - bitsize_one_node)); - adjust = true; - } - - temp = build1 (NEGATE_EXPR, bitsizetype, negative_size); - if (adjust) - temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node); - - return annotate_value (temp); - } - - if (!host_integerp (gnu_size, 1)) - return No_Uint; - - size = tree_low_cst (gnu_size, 1); - - /* This peculiar test is to make sure that the size fits in an int - on machines where HOST_WIDE_INT is not "int". */ - if (tree_low_cst (gnu_size, 1) == size) - return UI_From_Int (size); - else - return No_Uint; - - case COMPONENT_REF: - /* The only case we handle here is a simple discriminant reference. */ - if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR - && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL - && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1))) - return Create_Node (Discrim_Val, - annotate_value (DECL_DISCRIMINANT_NUMBER - (TREE_OPERAND (gnu_size, 1))), - No_Uint, No_Uint); - else - return No_Uint; - - case NOP_EXPR: case CONVERT_EXPR: case NON_LVALUE_EXPR: - return annotate_value (TREE_OPERAND (gnu_size, 0)); - - /* Now just list the operations we handle. */ - case COND_EXPR: tcode = Cond_Expr; break; - case PLUS_EXPR: tcode = Plus_Expr; break; - case MINUS_EXPR: tcode = Minus_Expr; break; - case MULT_EXPR: tcode = Mult_Expr; break; - case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break; - case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break; - case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break; - case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break; - case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break; - case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break; - case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break; - case NEGATE_EXPR: tcode = Negate_Expr; break; - case MIN_EXPR: tcode = Min_Expr; break; - case MAX_EXPR: tcode = Max_Expr; break; - case ABS_EXPR: tcode = Abs_Expr; break; - case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break; - case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break; - case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break; - case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break; - case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break; - case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break; - case BIT_AND_EXPR: tcode = Bit_And_Expr; break; - case LT_EXPR: tcode = Lt_Expr; break; - case LE_EXPR: tcode = Le_Expr; break; - case GT_EXPR: tcode = Gt_Expr; break; - case GE_EXPR: tcode = Ge_Expr; break; - case EQ_EXPR: tcode = Eq_Expr; break; - case NE_EXPR: tcode = Ne_Expr; break; - - default: - return No_Uint; - } - - /* Now get each of the operands that's relevant for this code. If any - cannot be expressed as a repinfo node, say we can't. */ - for (i = 0; i < 3; i++) - ops[i] = No_Uint; - - for (i = 0; i < len; i++) - { - ops[i] = annotate_value (TREE_OPERAND (gnu_size, i)); - if (ops[i] == No_Uint) - return No_Uint; - } - - ret = Create_Node (tcode, ops[0], ops[1], ops[2]); - - /* Save the result in the cache. */ - if (h) - { - *h = ggc_alloc (sizeof (struct tree_int_map)); - (*h)->base.from = gnu_size; - (*h)->to = ret; - } - - return ret; - } - - /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding - GCC type, set Component_Bit_Offset and Esize to the position and size - used by Gigi. */ - - static void - annotate_rep (Entity_Id gnat_entity, tree gnu_type) - { - tree gnu_list; - tree gnu_entry; - Entity_Id gnat_field; - - /* We operate by first making a list of all fields and their positions - (we can get the sizes easily at any time) by a recursive call - and then update all the sizes into the tree. */ - gnu_list = compute_field_positions (gnu_type, NULL_TREE, - size_zero_node, bitsize_zero_node, - BIGGEST_ALIGNMENT); - - for (gnat_field = First_Entity (gnat_entity); Present (gnat_field); - gnat_field = Next_Entity (gnat_field)) - if ((Ekind (gnat_field) == E_Component - || (Ekind (gnat_field) == E_Discriminant - && !Is_Unchecked_Union (Scope (gnat_field))))) - { - tree parent_offset = bitsize_zero_node; - - gnu_entry = purpose_member (gnat_to_gnu_field_decl (gnat_field), - gnu_list); - - if (gnu_entry) - { - if (type_annotate_only && Is_Tagged_Type (gnat_entity)) - { - /* In this mode the tag and parent components have not been - generated, so we add the appropriate offset to each - component. For a component appearing in the current - extension, the offset is the size of the parent. */ - if (Is_Derived_Type (gnat_entity) - && Original_Record_Component (gnat_field) == gnat_field) - parent_offset - = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))), - bitsizetype); - else - parent_offset = bitsize_int (POINTER_SIZE); - } - - Set_Component_Bit_Offset - (gnat_field, - annotate_value - (size_binop (PLUS_EXPR, - bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)), - TREE_VALUE (TREE_VALUE - (TREE_VALUE (gnu_entry)))), - parent_offset))); - - Set_Esize (gnat_field, - annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry)))); - } - else if (Is_Tagged_Type (gnat_entity) - && Is_Derived_Type (gnat_entity)) - { - /* If there is no gnu_entry, this is an inherited component whose - position is the same as in the parent type. */ - Set_Component_Bit_Offset - (gnat_field, - Component_Bit_Offset (Original_Record_Component (gnat_field))); - Set_Esize (gnat_field, - Esize (Original_Record_Component (gnat_field))); - } - } - } - - /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the - FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte - position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be - placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is - to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is - the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries - so far. */ - - static tree - compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos, - tree gnu_bitpos, unsigned int offset_align) - { - tree gnu_field; - tree gnu_result = gnu_list; - - for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field; - gnu_field = TREE_CHAIN (gnu_field)) - { - tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos, - DECL_FIELD_BIT_OFFSET (gnu_field)); - tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos, - DECL_FIELD_OFFSET (gnu_field)); - unsigned int our_offset_align - = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field)); - - gnu_result - = tree_cons (gnu_field, - tree_cons (gnu_our_offset, - tree_cons (size_int (our_offset_align), - gnu_our_bitpos, NULL_TREE), - NULL_TREE), - gnu_result); - - if (DECL_INTERNAL_P (gnu_field)) - gnu_result - = compute_field_positions (TREE_TYPE (gnu_field), gnu_result, - gnu_our_offset, gnu_our_bitpos, - our_offset_align); - } - - return gnu_result; - } - - /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE - corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding - to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying - the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL - for the size of a field. COMPONENT_P is true if we are being called - to process the Component_Size of GNAT_OBJECT. This is used for error - message handling and to indicate to use the object size of GNU_TYPE. - ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false, - it means that a size of zero should be treated as an unspecified size. */ - - static tree - validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object, - enum tree_code kind, bool component_p, bool zero_ok) - { - Node_Id gnat_error_node; - tree type_size, size; - - if (kind == VAR_DECL - /* If a type needs strict alignment, a component of this type in - a packed record cannot be packed and thus uses the type size. */ - || (kind == TYPE_DECL && Strict_Alignment (gnat_object))) - type_size = TYPE_SIZE (gnu_type); - else - type_size = rm_size (gnu_type); - - /* Find the node to use for errors. */ - if ((Ekind (gnat_object) == E_Component - || Ekind (gnat_object) == E_Discriminant) - && Present (Component_Clause (gnat_object))) - gnat_error_node = Last_Bit (Component_Clause (gnat_object)); - else if (Present (Size_Clause (gnat_object))) - gnat_error_node = Expression (Size_Clause (gnat_object)); - else - gnat_error_node = gnat_object; - - /* Return 0 if no size was specified, either because Esize was not Present or - the specified size was zero. */ - if (No (uint_size) || uint_size == No_Uint) - return NULL_TREE; - - /* Get the size as a tree. Give an error if a size was specified, but cannot - be represented as in sizetype. */ - size = UI_To_gnu (uint_size, bitsizetype); - if (TREE_OVERFLOW (size)) - { - post_error_ne (component_p ? "component size of & is too large" - : "size of & is too large", - gnat_error_node, gnat_object); - return NULL_TREE; - } - - /* Ignore a negative size since that corresponds to our back-annotation. - Also ignore a zero size unless a size clause exists. */ - else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok)) - return NULL_TREE; - - /* The size of objects is always a multiple of a byte. */ - if (kind == VAR_DECL - && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node))) - { - if (component_p) - post_error_ne ("component size for& is not a multiple of Storage_Unit", - gnat_error_node, gnat_object); - else - post_error_ne ("size for& is not a multiple of Storage_Unit", - gnat_error_node, gnat_object); - return NULL_TREE; - } - - /* If this is an integral type or a packed array type, the front-end has - verified the size, so we need not do it here (which would entail - checking against the bounds). However, if this is an aliased object, it - may not be smaller than the type of the object. */ - if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type)) - && !(kind == VAR_DECL && Is_Aliased (gnat_object))) - return size; - - /* If the object is a record that contains a template, add the size of - the template to the specified size. */ - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) - size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size); - - /* Modify the size of the type to be that of the maximum size if it has a - discriminant or the size of a thin pointer if this is a fat pointer. */ - if (type_size && CONTAINS_PLACEHOLDER_P (type_size)) - type_size = max_size (type_size, true); - else if (TYPE_FAT_POINTER_P (gnu_type)) - type_size = bitsize_int (POINTER_SIZE); - - /* If this is an access type, the minimum size is that given by the smallest - integral mode that's valid for pointers. */ - if (TREE_CODE (gnu_type) == POINTER_TYPE) - { - enum machine_mode p_mode; - - for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT); - !targetm.valid_pointer_mode (p_mode); - p_mode = GET_MODE_WIDER_MODE (p_mode)) - ; - - type_size = bitsize_int (GET_MODE_BITSIZE (p_mode)); - } - - /* If the size of the object is a constant, the new size must not be - smaller. */ - if (TREE_CODE (type_size) != INTEGER_CST - || TREE_OVERFLOW (type_size) - || tree_int_cst_lt (size, type_size)) - { - if (component_p) - post_error_ne_tree - ("component size for& too small{, minimum allowed is ^}", - gnat_error_node, gnat_object, type_size); - else - post_error_ne_tree ("size for& too small{, minimum allowed is ^}", - gnat_error_node, gnat_object, type_size); - - if (kind == VAR_DECL && !component_p - && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST - && !tree_int_cst_lt (size, rm_size (gnu_type))) - post_error_ne_tree_2 - ("\\size of ^ is not a multiple of alignment (^ bits)", - gnat_error_node, gnat_object, rm_size (gnu_type), - TYPE_ALIGN (gnu_type)); - - else if (INTEGRAL_TYPE_P (gnu_type)) - post_error_ne ("\\size would be legal if & were not aliased!", - gnat_error_node, gnat_object); - - return NULL_TREE; - } - - return size; - } - - /* Similarly, but both validate and process a value of RM_Size. This - routine is only called for types. */ - - static void - set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity) - { - /* Only give an error if a Value_Size clause was explicitly given. - Otherwise, we'd be duplicating an error on the Size clause. */ - Node_Id gnat_attr_node - = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size); - tree old_size = rm_size (gnu_type); - tree size; - - /* Get the size as a tree. Do nothing if none was specified, either - because RM_Size was not Present or if the specified size was zero. - Give an error if a size was specified, but cannot be represented as - in sizetype. */ - if (No (uint_size) || uint_size == No_Uint) - return; - - size = UI_To_gnu (uint_size, bitsizetype); - if (TREE_OVERFLOW (size)) - { - if (Present (gnat_attr_node)) - post_error_ne ("Value_Size of & is too large", gnat_attr_node, - gnat_entity); - - return; - } - - /* Ignore a negative size since that corresponds to our back-annotation. - Also ignore a zero size unless a size clause exists, a Value_Size - clause exists, or this is an integer type, in which case the - front end will have always set it. */ - else if (tree_int_cst_sgn (size) < 0 - || (integer_zerop (size) && No (gnat_attr_node) - && !Has_Size_Clause (gnat_entity) - && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity))) - return; - - /* If the old size is self-referential, get the maximum size. */ - if (CONTAINS_PLACEHOLDER_P (old_size)) - old_size = max_size (old_size, true); - - /* If the size of the object is a constant, the new size must not be - smaller (the front end checks this for scalar types). */ - if (TREE_CODE (old_size) != INTEGER_CST - || TREE_OVERFLOW (old_size) - || (AGGREGATE_TYPE_P (gnu_type) - && tree_int_cst_lt (size, old_size))) - { - if (Present (gnat_attr_node)) - post_error_ne_tree - ("Value_Size for& too small{, minimum allowed is ^}", - gnat_attr_node, gnat_entity, old_size); - - return; - } - - /* Otherwise, set the RM_Size. */ - if (TREE_CODE (gnu_type) == INTEGER_TYPE - && Is_Discrete_Or_Fixed_Point_Type (gnat_entity)) - TYPE_RM_SIZE_NUM (gnu_type) = size; - else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE) - TYPE_RM_SIZE_NUM (gnu_type) = size; - else if ((TREE_CODE (gnu_type) == RECORD_TYPE - || TREE_CODE (gnu_type) == UNION_TYPE - || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) - && !TYPE_IS_FAT_POINTER_P (gnu_type)) - SET_TYPE_ADA_SIZE (gnu_type, size); - } - - /* Given a type TYPE, return a new type whose size is appropriate for SIZE. - If TYPE is the best type, return it. Otherwise, make a new type. We - only support new integral and pointer types. BIASED_P is nonzero if - we are making a biased type. */ - - static tree - make_type_from_size (tree type, tree size_tree, bool biased_p) - { - tree new_type; - unsigned HOST_WIDE_INT size; - bool unsigned_p; - - /* If size indicates an error, just return TYPE to avoid propagating the - error. Likewise if it's too large to represent. */ - if (!size_tree || !host_integerp (size_tree, 1)) - return type; - - size = tree_low_cst (size_tree, 1); - switch (TREE_CODE (type)) - { - case INTEGER_TYPE: - case ENUMERAL_TYPE: - /* Only do something if the type is not already the proper size and is - not a packed array type. */ - if (TYPE_PACKED_ARRAY_TYPE_P (type) - || (TYPE_PRECISION (type) == size - && biased_p == (TREE_CODE (type) == INTEGER_CST - && TYPE_BIASED_REPRESENTATION_P (type)))) - break; - - biased_p |= (TREE_CODE (type) == INTEGER_TYPE - && TYPE_BIASED_REPRESENTATION_P (type)); - unsigned_p = TYPE_UNSIGNED (type) || biased_p; - - size = MIN (size, LONG_LONG_TYPE_SIZE); - new_type - = unsigned_p ? make_unsigned_type (size) : make_signed_type (size); - TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type; - TYPE_MIN_VALUE (new_type) - = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type)); - TYPE_MAX_VALUE (new_type) - = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type)); - TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p; - TYPE_RM_SIZE_NUM (new_type) = bitsize_int (size); - return new_type; - - case RECORD_TYPE: - /* Do something if this is a fat pointer, in which case we - may need to return the thin pointer. */ - if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2) - return - build_pointer_type - (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type))); - break; - - case POINTER_TYPE: - /* Only do something if this is a thin pointer, in which case we - may need to return the fat pointer. */ - if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2) - return - build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))); - - break; - - default: - break; - } - - return type; - } - - /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY, - a type or object whose present alignment is ALIGN. If this alignment is - valid, return it. Otherwise, give an error and return ALIGN. */ - - static unsigned int - validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align) - { - Node_Id gnat_error_node = gnat_entity; - unsigned int new_align; - - unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment (); - - if (Present (Alignment_Clause (gnat_entity))) - gnat_error_node = Expression (Alignment_Clause (gnat_entity)); - - /* Don't worry about checking alignment if alignment was not specified - by the source program and we already posted an error for this entity. */ - - if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity)) - return align; - - /* Within GCC, an alignment is an integer, so we must make sure a value is - specified that fits in that range. Also, there is an upper bound to - alignments we can support/allow. */ - - if (! UI_Is_In_Int_Range (alignment) - || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment)) - post_error_ne_num ("largest supported alignment for& is ^", - gnat_error_node, gnat_entity, max_allowed_alignment); - else if (!(Present (Alignment_Clause (gnat_entity)) - && From_At_Mod (Alignment_Clause (gnat_entity))) - && new_align * BITS_PER_UNIT < align) - post_error_ne_num ("alignment for& must be at least ^", - gnat_error_node, gnat_entity, - align / BITS_PER_UNIT); - else - align = MAX (align, new_align == 0 ? 1 : new_align * BITS_PER_UNIT); - - return align; - } - - /* Return the smallest alignment not less than SIZE. */ - - static unsigned int - ceil_alignment (unsigned HOST_WIDE_INT size) - { - return (unsigned int) 1 << (floor_log2 (size - 1) + 1); - } - - /* Verify that OBJECT, a type or decl, is something we can implement - atomically. If not, give an error for GNAT_ENTITY. COMP_P is true - if we require atomic components. */ - - static void - check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p) - { - Node_Id gnat_error_point = gnat_entity; - Node_Id gnat_node; - enum machine_mode mode; - unsigned int align; - tree size; - - /* There are three case of what OBJECT can be. It can be a type, in which - case we take the size, alignment and mode from the type. It can be a - declaration that was indirect, in which case the relevant values are - that of the type being pointed to, or it can be a normal declaration, - in which case the values are of the decl. The code below assumes that - OBJECT is either a type or a decl. */ - if (TYPE_P (object)) - { - mode = TYPE_MODE (object); - align = TYPE_ALIGN (object); - size = TYPE_SIZE (object); - } - else if (DECL_BY_REF_P (object)) - { - mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object))); - align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object))); - size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object))); - } - else - { - mode = DECL_MODE (object); - align = DECL_ALIGN (object); - size = DECL_SIZE (object); - } - - /* Consider all floating-point types atomic and any types that that are - represented by integers no wider than a machine word. */ - if (GET_MODE_CLASS (mode) == MODE_FLOAT - || ((GET_MODE_CLASS (mode) == MODE_INT - || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT) - && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD)) - return; - - /* For the moment, also allow anything that has an alignment equal - to its size and which is smaller than a word. */ - if (size && TREE_CODE (size) == INTEGER_CST - && compare_tree_int (size, align) == 0 - && align <= BITS_PER_WORD) - return; - - for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node); - gnat_node = Next_Rep_Item (gnat_node)) - { - if (!comp_p && Nkind (gnat_node) == N_Pragma - && Get_Pragma_Id (Chars (gnat_node)) == Pragma_Atomic) - gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); - else if (comp_p && Nkind (gnat_node) == N_Pragma - && (Get_Pragma_Id (Chars (gnat_node)) - == Pragma_Atomic_Components)) - gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); - } - - if (comp_p) - post_error_ne ("atomic access to component of & cannot be guaranteed", - gnat_error_point, gnat_entity); - else - post_error_ne ("atomic access to & cannot be guaranteed", - gnat_error_point, gnat_entity); - } - - /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes, - have compatible signatures so that a call using one type may be safely - issued if the actual target function type is the other. Return 1 if it is - the case, 0 otherwise, and post errors on the incompatibilities. - - This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure - that calls to the subprogram will have arguments suitable for the later - underlying builtin expansion. */ - - static int - compatible_signatures_p (tree ftype1, tree ftype2) - { - /* As of now, we only perform very trivial tests and consider it's the - programmer's responsibility to ensure the type correctness in the Ada - declaration, as in the regular Import cases. - - Mismatches typically result in either error messages from the builtin - expander, internal compiler errors, or in a real call sequence. This - should be refined to issue diagnostics helping error detection and - correction. */ - - /* Almost fake test, ensuring a use of each argument. */ - if (ftype1 == ftype2) - return 1; - - return 1; - } - - /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new - type with all size expressions that contain F updated by replacing F - with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if - nothing has changed. */ - - tree - substitute_in_type (tree t, tree f, tree r) - { - tree new = t; - tree tem; - - switch (TREE_CODE (t)) - { - case INTEGER_TYPE: - case ENUMERAL_TYPE: - case BOOLEAN_TYPE: - if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t)) - || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t))) - { - tree low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r); - tree high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r); - - if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t)) - return t; - - new = build_range_type (TREE_TYPE (t), low, high); - if (TYPE_INDEX_TYPE (t)) - SET_TYPE_INDEX_TYPE - (new, substitute_in_type (TYPE_INDEX_TYPE (t), f, r)); - return new; - } - - return t; - - case REAL_TYPE: - if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t)) - || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t))) - { - tree low = NULL_TREE, high = NULL_TREE; - - if (TYPE_MIN_VALUE (t)) - low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r); - if (TYPE_MAX_VALUE (t)) - high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r); - - if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t)) - return t; - - t = copy_type (t); - TYPE_MIN_VALUE (t) = low; - TYPE_MAX_VALUE (t) = high; - } - return t; - - case COMPLEX_TYPE: - tem = substitute_in_type (TREE_TYPE (t), f, r); - if (tem == TREE_TYPE (t)) - return t; - - return build_complex_type (tem); - - case OFFSET_TYPE: - case METHOD_TYPE: - case FUNCTION_TYPE: - case LANG_TYPE: - /* Don't know how to do these yet. */ - gcc_unreachable (); - - case ARRAY_TYPE: - { - tree component = substitute_in_type (TREE_TYPE (t), f, r); - tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r); - - if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t)) - return t; - - new = build_array_type (component, domain); - TYPE_SIZE (new) = 0; - TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t); - TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t); - layout_type (new); - TYPE_ALIGN (new) = TYPE_ALIGN (t); - TYPE_USER_ALIGN (new) = TYPE_USER_ALIGN (t); - - /* If we had bounded the sizes of T by a constant, bound the sizes of - NEW by the same constant. */ - if (TREE_CODE (TYPE_SIZE (t)) == MIN_EXPR) - TYPE_SIZE (new) - = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE (t), 1), - TYPE_SIZE (new)); - if (TREE_CODE (TYPE_SIZE_UNIT (t)) == MIN_EXPR) - TYPE_SIZE_UNIT (new) - = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE_UNIT (t), 1), - TYPE_SIZE_UNIT (new)); - return new; - } - - case RECORD_TYPE: - case UNION_TYPE: - case QUAL_UNION_TYPE: - { - tree field; - bool changed_field - = (f == NULL_TREE && !TREE_CONSTANT (TYPE_SIZE (t))); - bool field_has_rep = false; - tree last_field = NULL_TREE; - - tree new = copy_type (t); - - /* Start out with no fields, make new fields, and chain them - in. If we haven't actually changed the type of any field, - discard everything we've done and return the old type. */ - - TYPE_FIELDS (new) = NULL_TREE; - TYPE_SIZE (new) = NULL_TREE; - - for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field)) - { - tree new_field = copy_node (field); - - TREE_TYPE (new_field) - = substitute_in_type (TREE_TYPE (new_field), f, r); - - if (DECL_HAS_REP_P (field) && !DECL_INTERNAL_P (field)) - field_has_rep = true; - else if (TREE_TYPE (new_field) != TREE_TYPE (field)) - changed_field = true; - - /* If this is an internal field and the type of this field is - a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If - the type just has one element, treat that as the field. - But don't do this if we are processing a QUAL_UNION_TYPE. */ - if (TREE_CODE (t) != QUAL_UNION_TYPE - && DECL_INTERNAL_P (new_field) - && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE - || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE)) - { - if (!TYPE_FIELDS (TREE_TYPE (new_field))) - continue; - - if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field)))) - { - tree next_new_field - = copy_node (TYPE_FIELDS (TREE_TYPE (new_field))); - - /* Make sure omitting the union doesn't change - the layout. */ - DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field); - new_field = next_new_field; - } - } - - DECL_CONTEXT (new_field) = new; - SET_DECL_ORIGINAL_FIELD (new_field, - (DECL_ORIGINAL_FIELD (field) - ? DECL_ORIGINAL_FIELD (field) : field)); - - /* If the size of the old field was set at a constant, - propagate the size in case the type's size was variable. - (This occurs in the case of a variant or discriminated - record with a default size used as a field of another - record.) */ - DECL_SIZE (new_field) - = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST - ? DECL_SIZE (field) : NULL_TREE; - DECL_SIZE_UNIT (new_field) - = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST - ? DECL_SIZE_UNIT (field) : NULL_TREE; - - if (TREE_CODE (t) == QUAL_UNION_TYPE) - { - tree new_q = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r); - - if (new_q != DECL_QUALIFIER (new_field)) - changed_field = true; - - /* Do the substitution inside the qualifier and if we find - that this field will not be present, omit it. */ - DECL_QUALIFIER (new_field) = new_q; - - if (integer_zerop (DECL_QUALIFIER (new_field))) - continue; - } - - if (!last_field) - TYPE_FIELDS (new) = new_field; - else - TREE_CHAIN (last_field) = new_field; - - last_field = new_field; - - /* If this is a qualified type and this field will always be - present, we are done. */ - if (TREE_CODE (t) == QUAL_UNION_TYPE - && integer_onep (DECL_QUALIFIER (new_field))) - break; - } - - /* If this used to be a qualified union type, but we now know what - field will be present, make this a normal union. */ - if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE - && (!TYPE_FIELDS (new) - || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new))))) - TREE_SET_CODE (new, UNION_TYPE); - else if (!changed_field) - return t; - - gcc_assert (!field_has_rep); - layout_type (new); - - /* If the size was originally a constant use it. */ - if (TYPE_SIZE (t) && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST - && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST) - { - TYPE_SIZE (new) = TYPE_SIZE (t); - TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t); - SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t)); - } - - return new; - } - - default: - return t; - } - } - - /* Return the "RM size" of GNU_TYPE. This is the actual number of bits - needed to represent the object. */ - - tree - rm_size (tree gnu_type) - { - /* For integer types, this is the precision. For record types, we store - the size explicitly. For other types, this is just the size. */ - - if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type)) - return TYPE_RM_SIZE (gnu_type); - else if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) - /* Return the rm_size of the actual data plus the size of the template. */ - return - size_binop (PLUS_EXPR, - rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))), - DECL_SIZE (TYPE_FIELDS (gnu_type))); - else if ((TREE_CODE (gnu_type) == RECORD_TYPE - || TREE_CODE (gnu_type) == UNION_TYPE - || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) - && !TYPE_IS_FAT_POINTER_P (gnu_type) - && TYPE_ADA_SIZE (gnu_type)) - return TYPE_ADA_SIZE (gnu_type); - else - return TYPE_SIZE (gnu_type); - } - - /* Return an identifier representing the external name to be used for - GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___" - and the specified suffix. */ - - tree - create_concat_name (Entity_Id gnat_entity, const char *suffix) - { - Entity_Kind kind = Ekind (gnat_entity); - - const char *str = (!suffix ? "" : suffix); - String_Template temp = {1, strlen (str)}; - Fat_Pointer fp = {str, &temp}; - - Get_External_Name_With_Suffix (gnat_entity, fp); - - /* A variable using the Stdcall convention (meaning we are running - on a Windows box) live in a DLL. Here we adjust its name to use - the jump-table, the _imp__NAME contains the address for the NAME - variable. */ - if ((kind == E_Variable || kind == E_Constant) - && Has_Stdcall_Convention (gnat_entity)) - { - const char *prefix = "_imp__"; - int k, plen = strlen (prefix); - - for (k = 0; k <= Name_Len; k++) - Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k]; - strncpy (Name_Buffer, prefix, plen); - } - - return get_identifier (Name_Buffer); - } - - /* Return the name to be used for GNAT_ENTITY. If a type, create a - fully-qualified name, possibly with type information encoding. - Otherwise, return the name. */ - - tree - get_entity_name (Entity_Id gnat_entity) - { - Get_Encoded_Name (gnat_entity); - return get_identifier (Name_Buffer); - } - - /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a - string, return a new IDENTIFIER_NODE that is the concatenation of - the name in GNU_ID and SUFFIX. */ - - tree - concat_id_with_name (tree gnu_id, const char *suffix) - { - int len = IDENTIFIER_LENGTH (gnu_id); - - strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id), - IDENTIFIER_LENGTH (gnu_id)); - strncpy (Name_Buffer + len, "___", 3); - len += 3; - strcpy (Name_Buffer + len, suffix); - return get_identifier (Name_Buffer); - } - - #include "gt-ada-decl.h" --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/deftarg.c gcc-4.4.0/gcc/ada/deftarg.c *** gcc-4.3.3/gcc/ada/deftarg.c Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/deftarg.c Thu Jan 1 00:00:00 1970 *************** *** 1,40 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * D E F T A R G * - * * - * Body * - * * - * Copyright (C) 1992-2003 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- * - * ware Foundation; either version 2, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License distributed with GNAT; see file COPYING. If not, write * - * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * - * Boston, MA 02110-1301, USA. * - * * - * As a special exception, if you link this file with other files to * - * produce an executable, this file does not by itself cause the resulting * - * executable to be covered by the GNU General Public License. This except- * - * ion does not however invalidate any other reasons why the executable * - * file might be covered by the GNU Public License. * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - /* Include a default definition for TARGET_FLAGS for gnatpsta. */ - - #include "config.h" - #include "system.h" - #include "coretypes.h" - #include "tm.h" - - int target_flags = TARGET_DEFAULT; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/directio.ads gcc-4.4.0/gcc/ada/directio.ads *** gcc-4.3.3/gcc/ada/directio.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/directio.ads Fri Aug 1 10:33:45 2008 *************** *** 15,23 **** pragma Ada_2005; -- Explicit setting of Ada 2005 mode is required here, since we want to with a ! -- child unit (not possible in Ada 83 mode), and Text_IO is not considered to ! -- be an internal unit that is automatically compiled in Ada 2005 mode (since ! -- a user is allowed to redeclare Direct_IO). with Ada.Direct_IO; --- 15,23 ---- pragma Ada_2005; -- Explicit setting of Ada 2005 mode is required here, since we want to with a ! -- child unit (not possible in Ada 83 mode), and Direct_IO is not considered ! -- to be an internal unit that is automatically compiled in Ada 2005 mode ! -- (since a user is allowed to redeclare Direct_IO). with Ada.Direct_IO; diff -Nrcpad gcc-4.3.3/gcc/ada/einfo.adb gcc-4.4.0/gcc/ada/einfo.adb *** gcc-4.3.3/gcc/ada/einfo.adb Wed Dec 19 16:22:02 2007 --- gcc-4.4.0/gcc/ada/einfo.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Einfo is *** 70,76 **** -- Homonym Node4 -- First_Rep_Item Node6 -- Freeze_Node Node7 - -- Obsolescent_Warning Node24 -- The usage of other fields (and the entity kinds to which it applies) -- depends on the particular field (see Einfo spec for details). --- 68,73 ---- *************** package body Einfo is *** 127,133 **** -- Scale_Value Uint15 -- Storage_Size_Variable Node15 -- String_Literal_Low_Bound Node15 - -- Shared_Var_Read_Proc Node15 -- Access_Disp_Table Elist16 -- Cloned_Subtype Node16 --- 124,129 ---- *************** package body Einfo is *** 147,153 **** -- Master_Id Node17 -- Modulus Uint17 -- Non_Limited_View Node17 - -- Object_Ref Node17 -- Prival Node17 -- Alias Node18 --- 143,148 ---- *************** package body Einfo is *** 175,180 **** --- 170,176 ---- -- Discriminant_Checking_Func Node20 -- Discriminant_Default_Value Node20 -- Last_Entity Node20 + -- Prival_Link Node20 -- Register_Exception_Call Node20 -- Scalar_Range Node20 *************** package body Einfo is *** 194,219 **** -- Private_View Node22 -- Protected_Formal Node22 -- Scope_Depth_Value Uint22 ! -- Shared_Var_Assign_Proc Node22 -- Associated_Final_Chain Node23 -- CR_Discriminant Node23 - -- Stored_Constraint Elist23 -- Entry_Cancel_Parameter Node23 -- Extra_Constrained Node23 -- Generic_Renamings Elist23 -- Inner_Instances Elist23 - -- Enum_Pos_To_Rep Node23 - -- Packed_Array_Type Node23 -- Limited_View Node23 ! -- Privals_Chain Elist23 ! -- Protected_Operation Node23 ! -- Obsolescent_Warning Node24 ! -- Abstract_Interface_Alias Node25 ! -- Abstract_Interfaces Elist25 ! -- Current_Use_Clause Node25 -- Debug_Renaming_Link Node25 -- DT_Offset_To_Top_Func Node25 -- Task_Body_Procedure Node25 --- 190,213 ---- -- Private_View Node22 -- Protected_Formal Node22 -- Scope_Depth_Value Uint22 ! -- Shared_Var_Procs_Instance Node22 -- Associated_Final_Chain Node23 -- CR_Discriminant Node23 -- Entry_Cancel_Parameter Node23 + -- Enum_Pos_To_Rep Node23 -- Extra_Constrained Node23 -- Generic_Renamings Elist23 -- Inner_Instances Elist23 -- Limited_View Node23 ! -- Packed_Array_Type Node23 ! -- Protection_Object Node23 ! -- Stored_Constraint Elist23 ! -- Spec_PPC_List Node24 ! -- Interface_Alias Node25 ! -- Interfaces Elist25 -- Debug_Renaming_Link Node25 -- DT_Offset_To_Top_Func Node25 -- Task_Body_Procedure Node25 *************** package body Einfo is *** 223,230 **** --- 217,226 ---- -- Overridden_Operation Node26 -- Package_Instantiation Node26 -- Related_Type Node26 + -- Relative_Deadline_Variable Node26 -- Static_Initialization Node26 + -- Current_Use_Clause Node27 -- Wrapped_Entity Node27 -- Extra_Formals Node28 *************** package body Einfo is *** 423,429 **** -- Debug_Info_Off Flag166 -- Sec_Stack_Needed_For_Return Flag167 -- Materialize_Entity Flag168 - -- Function_Returns_With_DSP Flag169 -- Is_Known_Valid Flag170 -- Is_Hidden_Open_Scope Flag171 --- 419,424 ---- *************** package body Einfo is *** 495,514 **** -- Renamed_In_Spec Flag231 -- Implemented_By_Entry Flag232 -- Has_Pragma_Unmodified Flag233 ! -- (unused) Flag234 ! -- (unused) Flag235 ! -- (unused) Flag236 ! -- (unused) Flag237 ! -- (unused) Flag238 ! -- (unused) Flag239 - -- (unused) Flag240 - -- (unused) Flag241 - -- (unused) Flag242 - -- (unused) Flag243 - -- (unused) Flag244 - -- (unused) Flag245 -- (unused) Flag246 -- (unused) Flag247 --- 490,509 ---- -- Renamed_In_Spec Flag231 -- Implemented_By_Entry Flag232 -- Has_Pragma_Unmodified Flag233 + -- Is_Dispatch_Table_Entity Flag234 + -- Is_Trivial_Subprogram Flag235 + -- Warnings_Off_Used Flag236 + -- Warnings_Off_Used_Unmodified Flag237 + -- Warnings_Off_Used_Unreferenced Flag238 + -- OK_To_Reorder_Components Flag239 + -- Has_Postconditions Flag240 ! -- Optimize_Alignment_Space Flag241 ! -- Optimize_Alignment_Time Flag242 ! -- Overlays_Constant Flag243 ! -- Is_RACW_Stub_Type Flag244 ! -- Is_Private_Primitive Flag245 -- (unused) Flag246 -- (unused) Flag247 *************** package body Einfo is *** 546,563 **** -- Attribute Access Functions -- -------------------------------- - function Abstract_Interfaces (Id : E) return L is - begin - pragma Assert (Is_Record_Type (Id)); - return Elist25 (Id); - end Abstract_Interfaces; - - function Abstract_Interface_Alias (Id : E) return E is - begin - pragma Assert (Is_Subprogram (Id)); - return Node25 (Id); - end Abstract_Interface_Alias; - function Accept_Address (Id : E) return L is begin return Elist21 (Id); --- 541,546 ---- *************** package body Einfo is *** 742,749 **** function Current_Use_Clause (Id : E) return E is begin ! pragma Assert (Ekind (Id) = E_Package); ! return Node25 (Id); end Current_Use_Clause; function Current_Value (Id : E) return N is --- 725,732 ---- function Current_Use_Clause (Id : E) return E is begin ! pragma Assert (Ekind (Id) = E_Package or else Is_Type (Id)); ! return Node27 (Id); end Current_Use_Clause; function Current_Value (Id : E) return N is *************** package body Einfo is *** 1044,1051 **** function Can_Use_Internal_Rep (Id : E) return B is begin ! pragma Assert (Ekind (Id) in Access_Subprogram_Type_Kind); ! return Flag229 (Id); end Can_Use_Internal_Rep; function Finalization_Chain_Entity (Id : E) return E is --- 1027,1034 ---- function Can_Use_Internal_Rep (Id : E) return B is begin ! pragma Assert (Is_Access_Subprogram_Type (Base_Type (Id))); ! return Flag229 (Base_Type (Id)); end Can_Use_Internal_Rep; function Finalization_Chain_Entity (Id : E) return E is *************** package body Einfo is *** 1112,1124 **** return Node11 (Id); end Full_View; - function Function_Returns_With_DSP (Id : E) return B is - begin - pragma Assert - (Is_Subprogram (Id) or else Ekind (Id) = E_Subprogram_Type); - return Flag169 (Id); - end Function_Returns_With_DSP; - function Generic_Homonym (Id : E) return E is begin pragma Assert (Ekind (Id) = E_Generic_Package); --- 1095,1100 ---- *************** package body Einfo is *** 1320,1325 **** --- 1296,1307 ---- return Flag188 (Id); end Has_Persistent_BSS; + function Has_Postconditions (Id : E) return B is + begin + pragma Assert (Is_Subprogram (Id)); + return Flag240 (Id); + end Has_Postconditions; + function Has_Pragma_Controlled (Id : E) return B is begin pragma Assert (Is_Access_Type (Id)); *************** package body Einfo is *** 1534,1539 **** --- 1516,1533 ---- return Flag232 (Id); end Implemented_By_Entry; + function Interfaces (Id : E) return L is + begin + pragma Assert (Is_Record_Type (Id)); + return Elist25 (Id); + end Interfaces; + + function Interface_Alias (Id : E) return E is + begin + pragma Assert (Is_Subprogram (Id)); + return Node25 (Id); + end Interface_Alias; + function In_Package_Body (Id : E) return B is begin return Flag48 (Id); *************** package body Einfo is *** 1688,1703 **** return Flag74 (Id); end Is_CPP_Class; function Is_Discrim_SO_Function (Id : E) return B is begin return Flag176 (Id); end Is_Discrim_SO_Function; ! function Is_Descendent_Of_Address (Id : E) return B is begin ! pragma Assert (Is_Type (Id)); ! return Flag223 (Id); ! end Is_Descendent_Of_Address; function Is_Dispatching_Operation (Id : E) return B is begin --- 1682,1702 ---- return Flag74 (Id); end Is_CPP_Class; + function Is_Descendent_Of_Address (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag223 (Id); + end Is_Descendent_Of_Address; + function Is_Discrim_SO_Function (Id : E) return B is begin return Flag176 (Id); end Is_Discrim_SO_Function; ! function Is_Dispatch_Table_Entity (Id : E) return B is begin ! return Flag234 (Id); ! end Is_Dispatch_Table_Entity; function Is_Dispatching_Operation (Id : E) return B is begin *************** package body Einfo is *** 1927,1933 **** function Is_Primitive_Wrapper (Id : E) return B is begin ! pragma Assert (Ekind (Id) = E_Procedure); return Flag195 (Id); end Is_Primitive_Wrapper; --- 1926,1933 ---- function Is_Primitive_Wrapper (Id : E) return B is begin ! pragma Assert (Ekind (Id) = E_Function ! or else Ekind (Id) = E_Procedure); return Flag195 (Id); end Is_Primitive_Wrapper; *************** package body Einfo is *** 1942,1947 **** --- 1942,1954 ---- return Flag53 (Id); end Is_Private_Descendant; + function Is_Private_Primitive (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Function + or else Ekind (Id) = E_Procedure); + return Flag245 (Id); + end Is_Private_Primitive; + function Is_Protected_Interface (Id : E) return B is begin pragma Assert (Is_Interface (Id)); *************** package body Einfo is *** 1965,1970 **** --- 1972,1983 ---- return Flag189 (Id); end Is_Pure_Unit_Access_Type; + function Is_RACW_Stub_Type (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag244 (Id); + end Is_RACW_Stub_Type; + function Is_Raised (Id : E) return B is begin pragma Assert (Ekind (Id) = E_Exception); *************** package body Einfo is *** 2030,2035 **** --- 2043,2053 ---- return Flag225 (Id); end Is_Thunk; + function Is_Trivial_Subprogram (Id : E) return B is + begin + return Flag235 (Id); + end Is_Trivial_Subprogram; + function Is_True_Constant (Id : E) return B is begin return Flag163 (Id); *************** package body Einfo is *** 2224,2230 **** function Non_Binary_Modulus (Id : E) return B is begin ! pragma Assert (Is_Modular_Integer_Type (Id)); return Flag58 (Base_Type (Id)); end Non_Binary_Modulus; --- 2242,2248 ---- function Non_Binary_Modulus (Id : E) return B is begin ! pragma Assert (Is_Type (Id)); return Flag58 (Base_Type (Id)); end Non_Binary_Modulus; *************** package body Einfo is *** 2261,2276 **** return Uint10 (Id); end Normalized_Position_Max; ! function Object_Ref (Id : E) return E is begin ! pragma Assert (Ekind (Id) = E_Protected_Body); ! return Node17 (Id); ! end Object_Ref; ! function Obsolescent_Warning (Id : E) return N is begin ! return Node24 (Id); ! end Obsolescent_Warning; function Original_Array_Type (Id : E) return E is begin --- 2279,2307 ---- return Uint10 (Id); end Normalized_Position_Max; ! function OK_To_Reorder_Components (Id : E) return B is begin ! pragma Assert (Is_Record_Type (Id)); ! return Flag239 (Base_Type (Id)); ! end OK_To_Reorder_Components; ! function Optimize_Alignment_Space (Id : E) return B is begin ! pragma Assert ! (Is_Type (Id) ! or else Ekind (Id) = E_Constant ! or else Ekind (Id) = E_Variable); ! return Flag241 (Id); ! end Optimize_Alignment_Space; ! ! function Optimize_Alignment_Time (Id : E) return B is ! begin ! pragma Assert ! (Is_Type (Id) ! or else Ekind (Id) = E_Constant ! or else Ekind (Id) = E_Variable); ! return Flag242 (Id); ! end Optimize_Alignment_Time; function Original_Array_Type (Id : E) return E is begin *************** package body Einfo is *** 2287,2292 **** --- 2318,2328 ---- return Node22 (Id); end Original_Record_Component; + function Overlays_Constant (Id : E) return B is + begin + return Flag243 (Id); + end Overlays_Constant; + function Overridden_Operation (Id : E) return E is begin return Node26 (Id); *************** package body Einfo is *** 2321,2336 **** function Prival (Id : E) return E is begin ! pragma Assert (Is_Protected_Private (Id)); return Node17 (Id); end Prival; ! function Privals_Chain (Id : E) return L is begin ! pragma Assert (Is_Overloadable (Id) ! or else Ekind (Id) = E_Entry_Family); ! return Elist23 (Id); ! end Privals_Chain; function Private_Dependents (Id : E) return L is begin --- 2357,2372 ---- function Prival (Id : E) return E is begin ! pragma Assert (Is_Protected_Component (Id)); return Node17 (Id); end Prival; ! function Prival_Link (Id : E) return E is begin ! pragma Assert (Ekind (Id) = E_Constant ! or else Ekind (Id) = E_Variable); ! return Node20 (Id); ! end Prival_Link; function Private_Dependents (Id : E) return L is begin *************** package body Einfo is *** 2356,2366 **** return Node22 (Id); end Protected_Formal; ! function Protected_Operation (Id : E) return N is begin ! pragma Assert (Is_Protected_Private (Id)); return Node23 (Id); ! end Protected_Operation; function Reachable (Id : E) return B is begin --- 2392,2405 ---- return Node22 (Id); end Protected_Formal; ! function Protection_Object (Id : E) return E is begin ! pragma Assert (Ekind (Id) = E_Entry ! or else Ekind (Id) = E_Entry_Family ! or else Ekind (Id) = E_Function ! or else Ekind (Id) = E_Procedure); return Node23 (Id); ! end Protection_Object; function Reachable (Id : E) return B is begin *************** package body Einfo is *** 2414,2419 **** --- 2453,2464 ---- return Node26 (Id); end Related_Type; + function Relative_Deadline_Variable (Id : E) return E is + begin + pragma Assert (Is_Task_Type (Id)); + return Node26 (Implementation_Base_Type (Id)); + end Relative_Deadline_Variable; + function Renamed_Entity (Id : E) return N is begin return Node18 (Id); *************** package body Einfo is *** 2495,2511 **** return List14 (Id); end Shadow_Entities; ! function Shared_Var_Assign_Proc (Id : E) return E is begin pragma Assert (Ekind (Id) = E_Variable); return Node22 (Id); ! end Shared_Var_Assign_Proc; ! ! function Shared_Var_Read_Proc (Id : E) return E is ! begin ! pragma Assert (Ekind (Id) = E_Variable); ! return Node15 (Id); ! end Shared_Var_Read_Proc; function Size_Check_Code (Id : E) return N is begin --- 2540,2550 ---- return List14 (Id); end Shadow_Entities; ! function Shared_Var_Procs_Instance (Id : E) return E is begin pragma Assert (Ekind (Id) = E_Variable); return Node22 (Id); ! end Shared_Var_Procs_Instance; function Size_Check_Code (Id : E) return N is begin *************** package body Einfo is *** 2536,2541 **** --- 2575,2586 ---- return Node19 (Id); end Spec_Entity; + function Spec_PPC_List (Id : E) return N is + begin + pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id)); + return Node24 (Id); + end Spec_PPC_List; + function Storage_Size_Variable (Id : E) return E is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); *************** package body Einfo is *** 2645,2654 **** return Flag96 (Id); end Warnings_Off; function Wrapped_Entity (Id : E) return E is begin ! pragma Assert (Ekind (Id) = E_Procedure ! and then Is_Primitive_Wrapper (Id)); return Node27 (Id); end Wrapped_Entity; --- 2690,2715 ---- return Flag96 (Id); end Warnings_Off; + function Warnings_Off_Used (Id : E) return B is + begin + return Flag236 (Id); + end Warnings_Off_Used; + + function Warnings_Off_Used_Unmodified (Id : E) return B is + begin + return Flag237 (Id); + end Warnings_Off_Used_Unmodified; + + function Warnings_Off_Used_Unreferenced (Id : E) return B is + begin + return Flag238 (Id); + end Warnings_Off_Used_Unreferenced; + function Wrapped_Entity (Id : E) return E is begin ! pragma Assert ((Ekind (Id) = E_Function ! or else Ekind (Id) = E_Procedure) ! and then Is_Primitive_Wrapper (Id)); return Node27 (Id); end Wrapped_Entity; *************** package body Einfo is *** 2671,2676 **** --- 2732,2742 ---- return Ekind (Id) in Access_Protected_Kind; end Is_Access_Protected_Subprogram_Type; + function Is_Access_Subprogram_Type (Id : E) return B is + begin + return Ekind (Id) in Access_Subprogram_Kind; + end Is_Access_Subprogram_Type; + function Is_Array_Type (Id : E) return B is begin return Ekind (Id) in Array_Kind; *************** package body Einfo is *** 2874,2894 **** -- Attribute Set Procedures -- ------------------------------ - procedure Set_Abstract_Interfaces (Id : E; V : L) is - begin - pragma Assert (Is_Record_Type (Id)); - Set_Elist25 (Id, V); - end Set_Abstract_Interfaces; - - procedure Set_Abstract_Interface_Alias (Id : E; V : E) is - begin - pragma Assert - (Is_Hidden (Id) - and then - (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function)); - Set_Node25 (Id, V); - end Set_Abstract_Interface_Alias; - procedure Set_Accept_Address (Id : E; V : L) is begin Set_Elist21 (Id, V); --- 2940,2945 ---- *************** package body Einfo is *** 3074,3081 **** procedure Set_Current_Use_Clause (Id : E; V : E) is begin ! pragma Assert (Ekind (Id) = E_Package); ! Set_Node25 (Id, V); end Set_Current_Use_Clause; procedure Set_Current_Value (Id : E; V : N) is --- 3125,3132 ---- procedure Set_Current_Use_Clause (Id : E; V : E) is begin ! pragma Assert (Ekind (Id) = E_Package or else Is_Type (Id)); ! Set_Node27 (Id, V); end Set_Current_Use_Clause; procedure Set_Current_Value (Id : E; V : N) is *************** package body Einfo is *** 3380,3386 **** procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True) is begin ! pragma Assert (Ekind (Id) in Access_Subprogram_Type_Kind); Set_Flag229 (Id, V); end Set_Can_Use_Internal_Rep; --- 3431,3439 ---- procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True) is begin ! pragma Assert ! (Is_Access_Subprogram_Type (Id) ! and then Id = Base_Type (Id)); Set_Flag229 (Id, V); end Set_Can_Use_Internal_Rep; *************** package body Einfo is *** 3451,3463 **** Set_Node11 (Id, V); end Set_Full_View; - procedure Set_Function_Returns_With_DSP (Id : E; V : B := True) is - begin - pragma Assert - (Is_Subprogram (Id) or else Ekind (Id) = E_Subprogram_Type); - Set_Flag169 (Id, V); - end Set_Function_Returns_With_DSP; - procedure Set_Generic_Homonym (Id : E; V : E) is begin Set_Node11 (Id, V); --- 3504,3509 ---- *************** package body Einfo is *** 3475,3481 **** procedure Set_Has_Aliased_Components (Id : E; V : B := True) is begin ! pragma Assert (Base_Type (Id) = Id); Set_Flag135 (Id, V); end Set_Has_Aliased_Components; --- 3521,3527 ---- procedure Set_Has_Aliased_Components (Id : E; V : B := True) is begin ! pragma Assert (Id = Base_Type (Id)); Set_Flag135 (Id, V); end Set_Has_Aliased_Components; *************** package body Einfo is *** 3496,3509 **** procedure Set_Has_Atomic_Components (Id : E; V : B := True) is begin ! pragma Assert (not Is_Type (Id) or else Base_Type (Id) = Id); Set_Flag86 (Id, V); end Set_Has_Atomic_Components; procedure Set_Has_Biased_Representation (Id : E; V : B := True) is begin pragma Assert ! ((V = False) or else (Is_Discrete_Type (Id) or Is_Object (Id))); Set_Flag139 (Id, V); end Set_Has_Biased_Representation; --- 3542,3555 ---- procedure Set_Has_Atomic_Components (Id : E; V : B := True) is begin ! pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id)); Set_Flag86 (Id, V); end Set_Has_Atomic_Components; procedure Set_Has_Biased_Representation (Id : E; V : B := True) is begin pragma Assert ! ((V = False) or else (Is_Discrete_Type (Id) or else Is_Object (Id))); Set_Flag139 (Id, V); end Set_Has_Biased_Representation; *************** package body Einfo is *** 3543,3549 **** procedure Set_Has_Controlled_Component (Id : E; V : B := True) is begin ! pragma Assert (Base_Type (Id) = Id); Set_Flag43 (Id, V); end Set_Has_Controlled_Component; --- 3589,3595 ---- procedure Set_Has_Controlled_Component (Id : E; V : B := True) is begin ! pragma Assert (Id = Base_Type (Id)); Set_Flag43 (Id, V); end Set_Has_Controlled_Component; *************** package body Einfo is *** 3654,3660 **** procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True) is begin ! pragma Assert (Base_Type (Id) = Id); Set_Flag75 (Id, V); end Set_Has_Non_Standard_Rep; --- 3700,3706 ---- procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True) is begin ! pragma Assert (Id = Base_Type (Id)); Set_Flag75 (Id, V); end Set_Has_Non_Standard_Rep; *************** package body Einfo is *** 3674,3679 **** --- 3720,3731 ---- Set_Flag188 (Id, V); end Set_Has_Persistent_BSS; + procedure Set_Has_Postconditions (Id : E; V : B := True) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_Flag240 (Id, V); + end Set_Has_Postconditions; + procedure Set_Has_Pragma_Controlled (Id : E; V : B := True) is begin pragma Assert (Is_Access_Type (Id)); *************** package body Einfo is *** 3815,3821 **** procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True) is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); ! pragma Assert (Base_Type (Id) = Id); Set_Flag23 (Id, V); end Set_Has_Storage_Size_Clause; --- 3867,3873 ---- procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True) is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); ! pragma Assert (Id = Base_Type (Id)); Set_Flag23 (Id, V); end Set_Has_Storage_Size_Clause; *************** package body Einfo is *** 3832,3838 **** procedure Set_Has_Task (Id : E; V : B := True) is begin ! pragma Assert (Base_Type (Id) = Id); Set_Flag30 (Id, V); end Set_Has_Task; --- 3884,3890 ---- procedure Set_Has_Task (Id : E; V : B := True) is begin ! pragma Assert (Id = Base_Type (Id)); Set_Flag30 (Id, V); end Set_Has_Task; *************** package body Einfo is *** 3845,3851 **** procedure Set_Has_Unchecked_Union (Id : E; V : B := True) is begin ! pragma Assert (Base_Type (Id) = Id); Set_Flag123 (Id, V); end Set_Has_Unchecked_Union; --- 3897,3903 ---- procedure Set_Has_Unchecked_Union (Id : E; V : B := True) is begin ! pragma Assert (Id = Base_Type (Id)); Set_Flag123 (Id, V); end Set_Has_Unchecked_Union; *************** package body Einfo is *** 3857,3863 **** procedure Set_Has_Volatile_Components (Id : E; V : B := True) is begin ! pragma Assert (not Is_Type (Id) or else Base_Type (Id) = Id); Set_Flag87 (Id, V); end Set_Has_Volatile_Components; --- 3909,3915 ---- procedure Set_Has_Volatile_Components (Id : E; V : B := True) is begin ! pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id)); Set_Flag87 (Id, V); end Set_Has_Volatile_Components; *************** package body Einfo is *** 3886,3891 **** --- 3938,3959 ---- Set_Flag232 (Id, V); end Set_Implemented_By_Entry; + procedure Set_Interfaces (Id : E; V : L) is + begin + pragma Assert (Is_Record_Type (Id)); + Set_Elist25 (Id, V); + end Set_Interfaces; + + procedure Set_Interface_Alias (Id : E; V : E) is + begin + pragma Assert + (Is_Internal (Id) + and then Is_Hidden (Id) + and then (Ekind (Id) = E_Procedure + or else Ekind (Id) = E_Function)); + Set_Node25 (Id, V); + end Set_Interface_Alias; + procedure Set_In_Package_Body (Id : E; V : B := True) is begin Set_Flag48 (Id, V); *************** package body Einfo is *** 4060,4065 **** --- 4128,4138 ---- Set_Flag176 (Id, V); end Set_Is_Discrim_SO_Function; + procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True) is + begin + Set_Flag234 (Id, V); + end Set_Is_Dispatch_Table_Entity; + procedure Set_Is_Dispatching_Operation (Id : E; V : B := True) is begin pragma Assert *************** package body Einfo is *** 4274,4280 **** procedure Set_Is_Packed (Id : E; V : B := True) is begin ! pragma Assert (Base_Type (Id) = Id); Set_Flag51 (Id, V); end Set_Is_Packed; --- 4347,4353 ---- procedure Set_Is_Packed (Id : E; V : B := True) is begin ! pragma Assert (Id = Base_Type (Id)); Set_Flag51 (Id, V); end Set_Is_Packed; *************** package body Einfo is *** 4305,4311 **** procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is begin ! pragma Assert (Ekind (Id) = E_Procedure); Set_Flag195 (Id, V); end Set_Is_Primitive_Wrapper; --- 4378,4385 ---- procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is begin ! pragma Assert (Ekind (Id) = E_Function ! or else Ekind (Id) = E_Procedure); Set_Flag195 (Id, V); end Set_Is_Primitive_Wrapper; *************** package body Einfo is *** 4320,4325 **** --- 4394,4406 ---- Set_Flag53 (Id, V); end Set_Is_Private_Descendant; + procedure Set_Is_Private_Primitive (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Function + or else Ekind (Id) = E_Procedure); + Set_Flag245 (Id, V); + end Set_Is_Private_Primitive; + procedure Set_Is_Protected_Interface (Id : E; V : B := True) is begin pragma Assert (Is_Interface (Id)); *************** package body Einfo is *** 4343,4348 **** --- 4424,4435 ---- Set_Flag189 (Id, V); end Set_Is_Pure_Unit_Access_Type; + procedure Set_Is_RACW_Stub_Type (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag244 (Id, V); + end Set_Is_RACW_Stub_Type; + procedure Set_Is_Raised (Id : E; V : B := True) is begin pragma Assert (Ekind (Id) = E_Exception); *************** package body Einfo is *** 4415,4420 **** --- 4502,4512 ---- Set_Flag225 (Id, V); end Set_Is_Thunk; + procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True) is + begin + Set_Flag235 (Id, V); + end Set_Is_Trivial_Subprogram; + procedure Set_Is_True_Constant (Id : E; V : B := True) is begin Set_Flag163 (Id, V); *************** package body Einfo is *** 4422,4428 **** procedure Set_Is_Unchecked_Union (Id : E; V : B := True) is begin ! pragma Assert (Base_Type (Id) = Id); Set_Flag117 (Id, V); end Set_Is_Unchecked_Union; --- 4514,4520 ---- procedure Set_Is_Unchecked_Union (Id : E; V : B := True) is begin ! pragma Assert (Id = Base_Type (Id)); Set_Flag117 (Id, V); end Set_Is_Unchecked_Union; *************** package body Einfo is *** 4590,4596 **** procedure Set_No_Pool_Assigned (Id : E; V : B := True) is begin ! pragma Assert (Is_Access_Type (Id) and then Base_Type (Id) = Id); Set_Flag131 (Id, V); end Set_No_Pool_Assigned; --- 4682,4688 ---- procedure Set_No_Pool_Assigned (Id : E; V : B := True) is begin ! pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id)); Set_Flag131 (Id, V); end Set_No_Pool_Assigned; *************** package body Einfo is *** 4605,4617 **** procedure Set_No_Strict_Aliasing (Id : E; V : B := True) is begin ! pragma Assert (Is_Access_Type (Id) and then Base_Type (Id) = Id); Set_Flag136 (Id, V); end Set_No_Strict_Aliasing; procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is begin ! pragma Assert (Ekind (Id) = E_Modular_Integer_Type); Set_Flag58 (Id, V); end Set_Non_Binary_Modulus; --- 4697,4709 ---- procedure Set_No_Strict_Aliasing (Id : E; V : B := True) is begin ! pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id)); Set_Flag136 (Id, V); end Set_No_Strict_Aliasing; procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is begin ! pragma Assert (Is_Type (Id) and then Id = Base_Type (Id)); Set_Flag58 (Id, V); end Set_Non_Binary_Modulus; *************** package body Einfo is *** 4650,4665 **** Set_Uint10 (Id, V); end Set_Normalized_Position_Max; ! procedure Set_Object_Ref (Id : E; V : E) is begin ! pragma Assert (Ekind (Id) = E_Protected_Body); ! Set_Node17 (Id, V); ! end Set_Object_Ref; ! procedure Set_Obsolescent_Warning (Id : E; V : N) is begin ! Set_Node24 (Id, V); ! end Set_Obsolescent_Warning; procedure Set_Original_Array_Type (Id : E; V : E) is begin --- 4742,4771 ---- Set_Uint10 (Id, V); end Set_Normalized_Position_Max; ! procedure Set_OK_To_Reorder_Components (Id : E; V : B := True) is begin ! pragma Assert ! (Is_Record_Type (Id) and then Id = Base_Type (Id)); ! Set_Flag239 (Id, V); ! end Set_OK_To_Reorder_Components; ! procedure Set_Optimize_Alignment_Space (Id : E; V : B := True) is begin ! pragma Assert ! (Is_Type (Id) ! or else Ekind (Id) = E_Constant ! or else Ekind (Id) = E_Variable); ! Set_Flag241 (Id, V); ! end Set_Optimize_Alignment_Space; ! ! procedure Set_Optimize_Alignment_Time (Id : E; V : B := True) is ! begin ! pragma Assert ! (Is_Type (Id) ! or else Ekind (Id) = E_Constant ! or else Ekind (Id) = E_Variable); ! Set_Flag242 (Id, V); ! end Set_Optimize_Alignment_Time; procedure Set_Original_Array_Type (Id : E; V : E) is begin *************** package body Einfo is *** 4676,4681 **** --- 4782,4792 ---- Set_Node22 (Id, V); end Set_Original_Record_Component; + procedure Set_Overlays_Constant (Id : E; V : B := True) is + begin + Set_Flag243 (Id, V); + end Set_Overlays_Constant; + procedure Set_Overridden_Operation (Id : E; V : E) is begin Set_Node26 (Id, V); *************** package body Einfo is *** 4710,4725 **** procedure Set_Prival (Id : E; V : E) is begin ! pragma Assert (Is_Protected_Private (Id)); Set_Node17 (Id, V); end Set_Prival; ! procedure Set_Privals_Chain (Id : E; V : L) is begin ! pragma Assert (Is_Overloadable (Id) ! or else Ekind (Id) = E_Entry_Family); ! Set_Elist23 (Id, V); ! end Set_Privals_Chain; procedure Set_Private_Dependents (Id : E; V : L) is begin --- 4821,4836 ---- procedure Set_Prival (Id : E; V : E) is begin ! pragma Assert (Is_Protected_Component (Id)); Set_Node17 (Id, V); end Set_Prival; ! procedure Set_Prival_Link (Id : E; V : E) is begin ! pragma Assert (Ekind (Id) = E_Constant ! or else Ekind (Id) = E_Variable); ! Set_Node20 (Id, V); ! end Set_Prival_Link; procedure Set_Private_Dependents (Id : E; V : L) is begin *************** package body Einfo is *** 4745,4755 **** Set_Node22 (Id, V); end Set_Protected_Formal; ! procedure Set_Protected_Operation (Id : E; V : N) is begin ! pragma Assert (Is_Protected_Private (Id)); Set_Node23 (Id, V); ! end Set_Protected_Operation; procedure Set_Reachable (Id : E; V : B := True) is begin --- 4856,4869 ---- Set_Node22 (Id, V); end Set_Protected_Formal; ! procedure Set_Protection_Object (Id : E; V : E) is begin ! pragma Assert (Ekind (Id) = E_Entry ! or else Ekind (Id) = E_Entry_Family ! or else Ekind (Id) = E_Function ! or else Ekind (Id) = E_Procedure); Set_Node23 (Id, V); ! end Set_Protection_Object; procedure Set_Reachable (Id : E; V : B := True) is begin *************** package body Einfo is *** 4803,4808 **** --- 4917,4928 ---- Set_Node26 (Id, V); end Set_Related_Type; + procedure Set_Relative_Deadline_Variable (Id : E; V : E) is + begin + pragma Assert (Is_Task_Type (Id) and then Id = Base_Type (Id)); + Set_Node26 (Id, V); + end Set_Relative_Deadline_Variable; + procedure Set_Renamed_Entity (Id : E; V : N) is begin Set_Node18 (Id, V); *************** package body Einfo is *** 4886,4902 **** Set_List14 (Id, V); end Set_Shadow_Entities; ! procedure Set_Shared_Var_Assign_Proc (Id : E; V : E) is begin pragma Assert (Ekind (Id) = E_Variable); Set_Node22 (Id, V); ! end Set_Shared_Var_Assign_Proc; ! ! procedure Set_Shared_Var_Read_Proc (Id : E; V : E) is ! begin ! pragma Assert (Ekind (Id) = E_Variable); ! Set_Node15 (Id, V); ! end Set_Shared_Var_Read_Proc; procedure Set_Size_Check_Code (Id : E; V : N) is begin --- 5006,5016 ---- Set_List14 (Id, V); end Set_Shadow_Entities; ! procedure Set_Shared_Var_Procs_Instance (Id : E; V : E) is begin pragma Assert (Ekind (Id) = E_Variable); Set_Node22 (Id, V); ! end Set_Shared_Var_Procs_Instance; procedure Set_Size_Check_Code (Id : E; V : N) is begin *************** package body Einfo is *** 4926,4935 **** Set_Node19 (Id, V); end Set_Spec_Entity; procedure Set_Storage_Size_Variable (Id : E; V : E) is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); ! pragma Assert (Base_Type (Id) = Id); Set_Node15 (Id, V); end Set_Storage_Size_Variable; --- 5040,5055 ---- Set_Node19 (Id, V); end Set_Spec_Entity; + procedure Set_Spec_PPC_List (Id : E; V : N) is + begin + pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id)); + Set_Node24 (Id, V); + end Set_Spec_PPC_List; + procedure Set_Storage_Size_Variable (Id : E; V : E) is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); ! pragma Assert (Id = Base_Type (Id)); Set_Node15 (Id, V); end Set_Storage_Size_Variable; *************** package body Einfo is *** 4954,4960 **** procedure Set_Strict_Alignment (Id : E; V : B := True) is begin ! pragma Assert (Base_Type (Id) = Id); Set_Flag145 (Id, V); end Set_Strict_Alignment; --- 5074,5080 ---- procedure Set_Strict_Alignment (Id : E; V : B := True) is begin ! pragma Assert (Id = Base_Type (Id)); Set_Flag145 (Id, V); end Set_Strict_Alignment; *************** package body Einfo is *** 5010,5016 **** procedure Set_Universal_Aliasing (Id : E; V : B := True) is begin ! pragma Assert (Is_Type (Id) and then Base_Type (Id) = Id); Set_Flag216 (Id, V); end Set_Universal_Aliasing; --- 5130,5136 ---- procedure Set_Universal_Aliasing (Id : E; V : B := True) is begin ! pragma Assert (Is_Type (Id) and then Id = Base_Type (Id)); Set_Flag216 (Id, V); end Set_Universal_Aliasing; *************** package body Einfo is *** 5040,5045 **** --- 5160,5180 ---- Set_Flag96 (Id, V); end Set_Warnings_Off; + procedure Set_Warnings_Off_Used (Id : E; V : B := True) is + begin + Set_Flag236 (Id, V); + end Set_Warnings_Off_Used; + + procedure Set_Warnings_Off_Used_Unmodified (Id : E; V : B := True) is + begin + Set_Flag237 (Id, V); + end Set_Warnings_Off_Used_Unmodified; + + procedure Set_Warnings_Off_Used_Unreferenced (Id : E; V : B := True) is + begin + Set_Flag238 (Id, V); + end Set_Warnings_Off_Used_Unreferenced; + procedure Set_Was_Hidden (Id : E; V : B := True) is begin Set_Flag196 (Id, V); *************** package body Einfo is *** 5047,5054 **** procedure Set_Wrapped_Entity (Id : E; V : E) is begin ! pragma Assert (Ekind (Id) = E_Procedure ! and then Is_Primitive_Wrapper (Id)); Set_Node27 (Id, V); end Set_Wrapped_Entity; --- 5182,5190 ---- procedure Set_Wrapped_Entity (Id : E; V : E) is begin ! pragma Assert ((Ekind (Id) = E_Function ! or else Ekind (Id) = E_Procedure) ! and then Is_Primitive_Wrapper (Id)); Set_Node27 (Id, V); end Set_Wrapped_Entity; *************** package body Einfo is *** 5378,5391 **** procedure Append_Entity (Id : Entity_Id; V : Entity_Id) is begin if Last_Entity (V) = Empty then ! Set_First_Entity (V, Id); else Set_Next_Entity (Last_Entity (V), Id); end if; Set_Next_Entity (Id, Empty); Set_Scope (Id, V); ! Set_Last_Entity (V, Id); end Append_Entity; -------------------- --- 5514,5527 ---- procedure Append_Entity (Id : Entity_Id; V : Entity_Id) is begin if Last_Entity (V) = Empty then ! Set_First_Entity (Id => V, V => Id); else Set_Next_Entity (Last_Entity (V), Id); end if; Set_Next_Entity (Id, Empty); Set_Scope (Id, V); ! Set_Last_Entity (Id => V, V => Id); end Append_Entity; -------------------- *************** package body Einfo is *** 5636,5643 **** S := Scope (S); end if; end loop; - - return S; end Enclosing_Dynamic_Scope; ---------------------- --- 5772,5777 ---- *************** package body Einfo is *** 5969,5975 **** begin N := First_Rep_Item (E); while Present (N) loop ! if Nkind (N) = N_Pragma and then Chars (N) = Nam then return N; end if; --- 6103,6109 ---- begin N := First_Rep_Item (E); while Present (N) loop ! if Nkind (N) = N_Pragma and then Pragma_Name (N) = Nam then return N; end if; *************** package body Einfo is *** 5992,5998 **** Ritem := First_Rep_Item (Id); while Present (Ritem) loop if Nkind (Ritem) = N_Pragma ! and then Chars (Ritem) = Name_Attach_Handler then return True; else --- 6126,6132 ---- Ritem := First_Rep_Item (Id); while Present (Ritem) loop if Nkind (Ritem) = N_Pragma ! and then Pragma_Name (Ritem) = Name_Attach_Handler then return True; else *************** package body Einfo is *** 6020,6027 **** ----------------- function Has_Entries (Id : E) return B is ! Result : Boolean := False; ! Ent : Entity_Id; begin pragma Assert (Is_Concurrent_Type (Id)); --- 6154,6160 ---- ----------------- function Has_Entries (Id : E) return B is ! Ent : Entity_Id; begin pragma Assert (Is_Concurrent_Type (Id)); *************** package body Einfo is *** 6029,6042 **** Ent := First_Entity (Id); while Present (Ent) loop if Is_Entry (Ent) then ! Result := True; ! exit; end if; Ent := Next_Entity (Ent); end loop; ! return Result; end Has_Entries; ---------------------------- --- 6162,6174 ---- Ent := First_Entity (Id); while Present (Ent) loop if Is_Entry (Ent) then ! return True; end if; Ent := Next_Entity (Ent); end loop; ! return False; end Has_Entries; ---------------------------- *************** package body Einfo is *** 6061,6067 **** Ritem := First_Rep_Item (Id); while Present (Ritem) loop if Nkind (Ritem) = N_Pragma ! and then Chars (Ritem) = Name_Interrupt_Handler then return True; else --- 6193,6199 ---- Ritem := First_Rep_Item (Id); while Present (Ritem) loop if Nkind (Ritem) = N_Pragma ! and then Pragma_Name (Ritem) = Name_Interrupt_Handler then return True; else *************** package body Einfo is *** 6079,6093 **** function Has_Private_Ancestor (Id : E) return B is R : constant Entity_Id := Root_Type (Id); T1 : Entity_Id := Id; - begin loop if Is_Private_Type (T1) then return True; - elsif T1 = R then return False; - else T1 := Etype (T1); end if; --- 6211,6222 ---- *************** package body Einfo is *** 6103,6108 **** --- 6232,6283 ---- return Present (Get_Rep_Pragma (E, Nam)); end Has_Rep_Pragma; + -------------------- + -- Has_Unmodified -- + -------------------- + + function Has_Unmodified (E : Entity_Id) return Boolean is + begin + if Has_Pragma_Unmodified (E) then + return True; + elsif Warnings_Off (E) then + Set_Warnings_Off_Used_Unmodified (E); + return True; + else + return False; + end if; + end Has_Unmodified; + + --------------------- + -- Has_Unreferenced -- + --------------------- + + function Has_Unreferenced (E : Entity_Id) return Boolean is + begin + if Has_Pragma_Unreferenced (E) then + return True; + elsif Warnings_Off (E) then + Set_Warnings_Off_Used_Unreferenced (E); + return True; + else + return False; + end if; + end Has_Unreferenced; + + ---------------------- + -- Has_Warnings_Off -- + ---------------------- + + function Has_Warnings_Off (E : Entity_Id) return Boolean is + begin + if Warnings_Off (E) then + Set_Warnings_Off_Used (E); + return True; + else + return False; + end if; + end Has_Warnings_Off; + ------------------------------ -- Implementation_Base_Type -- ------------------------------ *************** package body Einfo is *** 6239,6244 **** --- 6414,6430 ---- end if; end Is_By_Reference_Type; + ------------------------ + -- Is_Constant_Object -- + ------------------------ + + function Is_Constant_Object (Id : E) return B is + K : constant Entity_Kind := Ekind (Id); + begin + return + K = E_Constant or else K = E_In_Parameter or else K = E_Loop_Parameter; + end Is_Constant_Object; + --------------------- -- Is_Derived_Type -- --------------------- *************** package body Einfo is *** 6259,6266 **** return Present (Par) and then Nkind (Par) = N_Full_Type_Declaration ! and then Nkind (Type_Definition (Par)) ! = N_Derived_Type_Definition; end if; else --- 6445,6452 ---- return Present (Par) and then Nkind (Par) = N_Full_Type_Declaration ! and then Nkind (Type_Definition (Par)) = ! N_Derived_Type_Definition; end if; else *************** package body Einfo is *** 6268,6273 **** --- 6454,6471 ---- end if; end Is_Derived_Type; + -------------------- + -- Is_Discriminal -- + -------------------- + + function Is_Discriminal (Id : E) return B is + begin + return + (Ekind (Id) = E_Constant + or else Ekind (Id) = E_In_Parameter) + and then Present (Discriminal_Link (Id)); + end Is_Discriminal; + ---------------------- -- Is_Dynamic_Scope -- ---------------------- *************** package body Einfo is *** 6346,6351 **** --- 6544,6607 ---- end if; end Is_Indefinite_Subtype; + -------------------------------- + -- Is_Inherently_Limited_Type -- + -------------------------------- + + function Is_Inherently_Limited_Type (Id : E) return B is + Btype : constant Entity_Id := Base_Type (Id); + + begin + if Is_Private_Type (Btype) then + declare + Utyp : constant Entity_Id := Underlying_Type (Btype); + begin + if No (Utyp) then + return False; + else + return Is_Inherently_Limited_Type (Utyp); + end if; + end; + + elsif Is_Concurrent_Type (Btype) then + return True; + + elsif Is_Record_Type (Btype) then + if Is_Limited_Record (Btype) then + return not Is_Interface (Btype) + or else Is_Protected_Interface (Btype) + or else Is_Synchronized_Interface (Btype) + or else Is_Task_Interface (Btype); + + elsif Is_Class_Wide_Type (Btype) then + return Is_Inherently_Limited_Type (Root_Type (Btype)); + + else + declare + C : Entity_Id; + + begin + C := First_Component (Btype); + while Present (C) loop + if Is_Inherently_Limited_Type (Etype (C)) then + return True; + end if; + + C := Next_Component (C); + end loop; + end; + + return False; + end if; + + elsif Is_Array_Type (Btype) then + return Is_Inherently_Limited_Type (Component_Type (Btype)); + + else + return False; + end if; + end Is_Inherently_Limited_Type; + --------------------- -- Is_Limited_Type -- --------------------- *************** package body Einfo is *** 6438,6452 **** Ekind (Id) = E_Generic_Package; end Is_Package_Or_Generic_Package; ! -------------------------- ! -- Is_Protected_Private -- ! -------------------------- ! function Is_Protected_Private (Id : E) return B is begin ! pragma Assert (Ekind (Id) = E_Component); ! return Is_Protected_Type (Scope (Id)); ! end Is_Protected_Private; ------------------------------ -- Is_Protected_Record_Type -- --- 6694,6720 ---- Ekind (Id) = E_Generic_Package; end Is_Package_Or_Generic_Package; ! --------------- ! -- Is_Prival -- ! --------------- ! function Is_Prival (Id : E) return B is begin ! return ! (Ekind (Id) = E_Constant ! or else Ekind (Id) = E_Variable) ! and then Present (Prival_Link (Id)); ! end Is_Prival; ! ! ---------------------------- ! -- Is_Protected_Component -- ! ---------------------------- ! ! function Is_Protected_Component (Id : E) return B is ! begin ! return Ekind (Id) = E_Component ! and then Is_Protected_Type (Scope (Id)); ! end Is_Protected_Component; ------------------------------ -- Is_Protected_Record_Type -- *************** package body Einfo is *** 6460,6521 **** end Is_Protected_Record_Type; -------------------------------- ! -- Is_Inherently_Limited_Type -- -------------------------------- ! function Is_Inherently_Limited_Type (Id : E) return B is ! Btype : constant Entity_Id := Base_Type (Id); ! begin ! if Is_Private_Type (Btype) then declare ! Utyp : constant Entity_Id := Underlying_Type (Btype); begin ! if No (Utyp) then ! return False; ! else ! return Is_Inherently_Limited_Type (Utyp); ! end if; end; - elsif Is_Concurrent_Type (Btype) then - return True; - - elsif Is_Record_Type (Btype) then - if Is_Limited_Record (Btype) then - return not Is_Interface (Btype) - or else Is_Protected_Interface (Btype) - or else Is_Synchronized_Interface (Btype) - or else Is_Task_Interface (Btype); - - elsif Is_Class_Wide_Type (Btype) then - return Is_Inherently_Limited_Type (Root_Type (Btype)); - - else - declare - C : Entity_Id; - - begin - C := First_Component (Btype); - while Present (C) loop - if Is_Inherently_Limited_Type (Etype (C)) then - return True; - end if; - - C := Next_Component (C); - end loop; - end; - - return False; - end if; - - elsif Is_Array_Type (Btype) then - return Is_Inherently_Limited_Type (Component_Type (Btype)); - else return False; end if; ! end Is_Inherently_Limited_Type; -------------------- -- Is_String_Type -- --- 6728,6754 ---- end Is_Protected_Record_Type; -------------------------------- ! -- Is_Standard_Character_Type -- -------------------------------- ! function Is_Standard_Character_Type (Id : E) return B is begin ! if Is_Type (Id) then declare ! R : constant Entity_Id := Root_Type (Id); begin ! return ! R = Standard_Character ! or else ! R = Standard_Wide_Character ! or else ! R = Standard_Wide_Wide_Character; end; else return False; end if; ! end Is_Standard_Character_Type; -------------------- -- Is_String_Type -- *************** package body Einfo is *** 6849,6865 **** T := Etyp; ! -- Return if there is a circularity in the inheritance chain. ! -- This happens in some error situations and we do not want ! -- to get stuck in this loop. if T = Base_Type (Id) then return T; end if; end loop; end if; - - raise Program_Error; end Root_Type; ----------------- --- 7082,7096 ---- T := Etyp; ! -- Return if there is a circularity in the inheritance chain. This ! -- happens in some error situations and we do not want to get ! -- stuck in this loop. if T = Base_Type (Id) then return T; end if; end loop; end if; end Root_Type; ----------------- *************** package body Einfo is *** 7067,7077 **** function Next_Tag_Component (Id : E) return E is Comp : Entity_Id; - Typ : constant Entity_Id := Scope (Id); begin ! pragma Assert (Ekind (Id) = E_Component ! and then Is_Tagged_Type (Typ)); Comp := Next_Entity (Id); while Present (Comp) loop --- 7298,7306 ---- function Next_Tag_Component (Id : E) return E is Comp : Entity_Id; begin ! pragma Assert (Is_Tag (Id)); Comp := Next_Entity (Id); while Present (Comp) loop *************** package body Einfo is *** 7205,7211 **** begin if (Is_Array_Type (Id) or else Is_Record_Type (Id)) ! and then Base_Type (Id) = Id then Write_Str (Prefix); Write_Str ("Component_Alignment = "); --- 7434,7440 ---- begin if (Is_Array_Type (Id) or else Is_Record_Type (Id)) ! and then Id = Base_Type (Id) then Write_Str (Prefix); Write_Str ("Component_Alignment = "); *************** package body Einfo is *** 7244,7250 **** W ("Can_Use_Internal_Rep", Flag229 (Id)); W ("Finalize_Storage_Only", Flag158 (Id)); W ("From_With_Type", Flag159 (Id)); - W ("Function_Returns_With_DSP", Flag169 (Id)); W ("Has_Aliased_Components", Flag135 (Id)); W ("Has_Alignment_Clause", Flag46 (Id)); W ("Has_All_Calls_Remote", Flag79 (Id)); --- 7473,7478 ---- *************** package body Einfo is *** 7277,7282 **** --- 7505,7511 ---- W ("Has_Object_Size_Clause", Flag172 (Id)); W ("Has_Per_Object_Constraint", Flag154 (Id)); W ("Has_Persistent_BSS", Flag188 (Id)); + W ("Has_Postconditions", Flag240 (Id)); W ("Has_Pragma_Controlled", Flag27 (Id)); W ("Has_Pragma_Elaborate_Body", Flag150 (Id)); W ("Has_Pragma_Inline", Flag157 (Id)); *************** package body Einfo is *** 7342,7347 **** --- 7571,7577 ---- W ("Is_Controlling_Formal", Flag97 (Id)); W ("Is_Descendent_Of_Address", Flag223 (Id)); W ("Is_Discrim_SO_Function", Flag176 (Id)); + W ("Is_Dispatch_Table_Entity", Flag234 (Id)); W ("Is_Dispatching_Operation", Flag6 (Id)); W ("Is_Eliminated", Flag124 (Id)); W ("Is_Entry_Formal", Flag52 (Id)); *************** package body Einfo is *** 7382,7394 **** --- 7612,7627 ---- W ("Is_Packed_Array_Type", Flag138 (Id)); W ("Is_Potentially_Use_Visible", Flag9 (Id)); W ("Is_Preelaborated", Flag59 (Id)); + W ("Is_Primitive", Flag218 (Id)); W ("Is_Primitive_Wrapper", Flag195 (Id)); W ("Is_Private_Composite", Flag107 (Id)); W ("Is_Private_Descendant", Flag53 (Id)); + W ("Is_Private_Primitive", Flag245 (Id)); W ("Is_Protected_Interface", Flag198 (Id)); W ("Is_Public", Flag10 (Id)); W ("Is_Pure", Flag44 (Id)); W ("Is_Pure_Unit_Access_Type", Flag189 (Id)); + W ("Is_RACW_Stub_Type", Flag244 (Id)); W ("Is_Raised", Flag224 (Id)); W ("Is_Remote_Call_Interface", Flag62 (Id)); W ("Is_Remote_Types", Flag61 (Id)); *************** package body Einfo is *** 7401,7406 **** --- 7634,7640 ---- W ("Is_Tagged_Type", Flag55 (Id)); W ("Is_Task_Interface", Flag200 (Id)); W ("Is_Thunk", Flag225 (Id)); + W ("Is_Trivial_Subprogram", Flag235 (Id)); W ("Is_True_Constant", Flag163 (Id)); W ("Is_Unchecked_Union", Flag117 (Id)); W ("Is_Unsigned_Type", Flag144 (Id)); *************** package body Einfo is *** 7427,7432 **** --- 7661,7670 ---- W ("No_Strict_Aliasing", Flag136 (Id)); W ("Non_Binary_Modulus", Flag58 (Id)); W ("Nonzero_Is_True", Flag162 (Id)); + W ("OK_To_Reorder_Components", Flag239 (Id)); + W ("Optimize_Alignment_Space", Flag241 (Id)); + W ("Optimize_Alignment_Time", Flag242 (Id)); + W ("Overlays_Constant", Flag243 (Id)); W ("Reachable", Flag49 (Id)); W ("Referenced", Flag156 (Id)); W ("Referenced_As_LHS", Flag36 (Id)); *************** package body Einfo is *** 7445,7457 **** W ("Suppress_Init_Proc", Flag105 (Id)); W ("Suppress_Style_Checks", Flag165 (Id)); W ("Suppress_Value_Tracking_On_Call", Flag217 (Id)); - W ("Is_Primitive", Flag218 (Id)); W ("Treat_As_Volatile", Flag41 (Id)); W ("Universal_Aliasing", Flag216 (Id)); W ("Used_As_Generic_Actual", Flag222 (Id)); W ("Uses_Sec_Stack", Flag95 (Id)); W ("Vax_Float", Flag151 (Id)); W ("Warnings_Off", Flag96 (Id)); W ("Was_Hidden", Flag196 (Id)); end Write_Entity_Flags; --- 7683,7697 ---- W ("Suppress_Init_Proc", Flag105 (Id)); W ("Suppress_Style_Checks", Flag165 (Id)); W ("Suppress_Value_Tracking_On_Call", Flag217 (Id)); W ("Treat_As_Volatile", Flag41 (Id)); W ("Universal_Aliasing", Flag216 (Id)); W ("Used_As_Generic_Actual", Flag222 (Id)); W ("Uses_Sec_Stack", Flag95 (Id)); W ("Vax_Float", Flag151 (Id)); W ("Warnings_Off", Flag96 (Id)); + W ("Warnings_Off_Used", Flag236 (Id)); + W ("Warnings_Off_Used_Unmodified", Flag237 (Id)); + W ("Warnings_Off_Used_Unreferenced", Flag238 (Id)); W ("Was_Hidden", Flag196 (Id)); end Write_Entity_Flags; *************** package body Einfo is *** 7891,7899 **** when E_String_Literal_Subtype => Write_Str ("String_Literal_Low_Bound"); - when E_Variable => - Write_Str ("Shared_Var_Read_Proc"); - when others => Write_Str ("Field15??"); end case; --- 8131,8136 ---- *************** package body Einfo is *** 7982,7990 **** when Array_Kind => Write_Str ("First_Index"); - when E_Protected_Body => - Write_Str ("Object_Ref"); - when Enumeration_Kind => Write_Str ("First_Literal"); --- 8219,8224 ---- *************** package body Einfo is *** 8132,8137 **** --- 8366,8375 ---- when E_Component => Write_Str ("Discriminant_Checking_Func"); + when E_Constant | + E_Variable => + Write_Str ("Prival_Link"); + when E_Discriminant => Write_Str ("Discriminant_Default_Value"); *************** package body Einfo is *** 8265,8271 **** Write_Str ("Private_View"); when E_Variable => ! Write_Str ("Shared_Var_Assign_Proc"); when others => Write_Str ("Field22??"); --- 8503,8509 ---- Write_Str ("Private_View"); when E_Variable => ! Write_Str ("Shared_Var_Procs_Instance"); when others => Write_Str ("Field22??"); *************** package body Einfo is *** 8288,8296 **** when E_Block => Write_Str ("Entry_Cancel_Parameter"); - when E_Component => - Write_Str ("Protected_Operation"); - when E_Discriminant => Write_Str ("CR_Discriminant"); --- 8526,8531 ---- *************** package body Einfo is *** 8315,8321 **** when E_Function | E_Procedure => ! Write_Str ("Generic_Renamings"); when E_Package => if Is_Generic_Instance (Id) then --- 8550,8562 ---- when E_Function | E_Procedure => ! if Present (Scope (Id)) ! and then Is_Protected_Type (Scope (Id)) ! then ! Write_Str ("Protection_Object"); ! else ! Write_Str ("Generic_Renamings"); ! end if; when E_Package => if Is_Generic_Instance (Id) then *************** package body Einfo is *** 8324,8333 **** Write_Str ("Limited_View"); end if; - -- What about Privals_Chain for protected operations ??? - when Entry_Kind => ! Write_Str ("Privals_Chain"); when others => Write_Str ("Field23??"); --- 8565,8572 ---- Write_Str ("Limited_View"); end if; when Entry_Kind => ! Write_Str ("Protection_Object"); when others => Write_Str ("Field23??"); *************** package body Einfo is *** 8339,8347 **** ------------------------ procedure Write_Field24_Name (Id : Entity_Id) is - pragma Warnings (Off, Id); begin ! Write_Str ("Obsolescent_Warning"); end Write_Field24_Name; ------------------------ --- 8578,8591 ---- ------------------------ procedure Write_Field24_Name (Id : Entity_Id) is begin ! case Ekind (Id) is ! when Subprogram_Kind => ! Write_Str ("Spec_PPC_List"); ! ! when others => ! Write_Str ("???"); ! end case; end Write_Field24_Name; ------------------------ *************** package body Einfo is *** 8356,8371 **** when E_Procedure | E_Function => ! Write_Str ("Abstract_Interface_Alias"); ! ! when E_Package => ! Write_Str ("Current_Use_Clause"); when E_Record_Type | E_Record_Subtype | E_Record_Type_With_Private | E_Record_Subtype_With_Private => ! Write_Str ("Abstract_Interfaces"); when Task_Kind => Write_Str ("Task_Body_Procedure"); --- 8600,8612 ---- when E_Procedure | E_Function => ! Write_Str ("Interface_Alias"); when E_Record_Type | E_Record_Subtype | E_Record_Type_With_Private | E_Record_Subtype_With_Private => ! Write_Str ("Interfaces"); when Task_Kind => Write_Str ("Task_Body_Procedure"); *************** package body Einfo is *** 8411,8416 **** --- 8652,8660 ---- E_Variable => Write_Str ("Last_Assignment"); + when Task_Kind => + Write_Str ("Relative_Deadline_Variable"); + when others => Write_Str ("Field26??"); end case; *************** package body Einfo is *** 8426,8431 **** --- 8670,8678 ---- when E_Procedure => Write_Str ("Wrapped_Entity"); + when E_Package | Type_Kind => + Write_Str ("Current_Use_Clause"); + when others => Write_Str ("Field27??"); end case; diff -Nrcpad gcc-4.3.3/gcc/ada/einfo.ads gcc-4.4.0/gcc/ada/einfo.ads *** gcc-4.3.3/gcc/ada/einfo.ads Wed Dec 19 16:22:02 2007 --- gcc-4.4.0/gcc/ada/einfo.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Einfo is *** 284,310 **** -- attribute on other than the base type, and if assertions are enabled, -- an attempt to set the attribute on a subtype will raise an assert error. ! -- Other attributes are noted as applying the implementation base type only. ! -- These are representation attributes which must always apply to a full ! -- non-private type, and where the attributes are always on the full type. ! -- The attribute can be referenced on a subtype (and automatically retries ! -- the value from the implementation base type). However, it is an error ! -- to try to set the attribute on other than the implementation base type, ! -- and if assertions are enabled, an attempt to set the attribute on a -- subtype will raise an assert error. - -- Abstract_Interfaces (Elist25) - -- Present in record types and subtypes. List of abstract interfaces - -- implemented by a tagged type that are not already implemented by the - -- ancestors (Ada 2005: AI-251). - - -- Abstract_Interface_Alias (Node25) - -- Present in subprograms that cover a primitive operation of an abstract - -- interface type. Can be set only if the Is_Hidden flag is also set, - -- since such entities are always hidden. Points to its associated - -- interface subprogram. It is used to register the subprogram in - -- secondary dispatch table of the interface (Ada 2005: AI-251). - -- Accept_Address (Elist21) -- Present in entries. If an accept has a statement sequence, then an -- address variable is created, which is used to hold the address of the --- 282,296 ---- -- attribute on other than the base type, and if assertions are enabled, -- an attempt to set the attribute on a subtype will raise an assert error. ! -- Other attributes are noted as applying to the [implementation base type ! -- only]. These are representation attributes which must always apply to a ! -- full non-private type, and where the attributes are always on the full ! -- type. The attribute can be referenced on a subtype (and automatically ! -- retries the value from the implementation base type). However, it is an ! -- error to try to set the attribute on other than the implementation base ! -- type, and if assertions are enabled, an attempt to set the attribute on a -- subtype will raise an assert error. -- Accept_Address (Elist21) -- Present in entries. If an accept has a statement sequence, then an -- address variable is created, which is used to hold the address of the *************** package Einfo is *** 334,343 **** -- Access_Disp_Table (Elist16) [implementation base type only] -- Present in record type entities. For a tagged type, points to the ! -- dispatch tables associated with the tagged type; the last entity of ! -- this list is an access type declaration used to expand dispatching ! -- calls through the primary dispatch table. For a non-tagged record, ! -- contains Empty. -- Address_Clause (synthesized) -- Applies to entries, objects and subprograms. Set if an address clause --- 320,336 ---- -- Access_Disp_Table (Elist16) [implementation base type only] -- Present in record type entities. For a tagged type, points to the ! -- dispatch tables associated with the tagged type. The first two ! -- entities correspond with the primary dispatch table: 1) primary ! -- dispatch table with user-defined primitives, 2) primary dispatch table ! -- with predefined primitives. For each interface type covered by the ! -- tagged type we also have: 3) secondary dispatch table with thunks of ! -- primitives covering user-defined interface primitives, 4) secondary ! -- dispatch table with thunks of predefined primitives, 5) secondary ! -- dispatch table with user-defined primitives, and 6) secondary dispatch ! -- table with predefined primitives. The last entity of this list is an ! -- access type declaration used to expand dispatching calls through the ! -- primary dispatch table. For a non-tagged record, contains Empty. -- Address_Clause (synthesized) -- Applies to entries, objects and subprograms. Set if an address clause *************** package Einfo is *** 357,368 **** -- Alias (Node18) -- Present in overloaded entities (literals, subprograms, entries) and -- subprograms that cover a primitive operation of an abstract interface ! -- (that is, subprograms with the Abstract_Interface_Alias attribute). ! -- In case of overloaded entities it points to the parent subprogram of ! -- a derived subprogram. In case of abstract interface subprograms it ! -- points to the subprogram that covers the abstract interface primitive. ! -- Also used for a subprogram renaming, where it points to the renamed ! -- subprogram. Always empty for entries. -- Alignment (Uint14) -- Present in entities for types and also in constants, variables --- 350,361 ---- -- Alias (Node18) -- Present in overloaded entities (literals, subprograms, entries) and -- subprograms that cover a primitive operation of an abstract interface ! -- (that is, subprograms with the Interface_Alias attribute). In case of ! -- overloaded entities it points to the parent subprogram of a derived ! -- subprogram. In case of abstract interface subprograms it points to the ! -- subprogram that covers the abstract interface primitive. Also used for ! -- a subprogram renaming, where it points to the renamed subprogram. ! -- Always empty for entries. -- Alignment (Uint14) -- Present in entities for types and also in constants, variables *************** package Einfo is *** 450,456 **** -- for finalization purposes, The block entity has an implicit label -- declaration in the enclosing declarative part, and has otherwise -- no direct connection in the tree with the block statement. The ! -- link is to the identifier (which is an occurence of the entity) -- and not to the block_statement itself, because the statement may -- be rewritten, e.g. in the process of removing dead code. --- 443,449 ---- -- for finalization purposes, The block entity has an implicit label -- declaration in the enclosing declarative part, and has otherwise -- no direct connection in the tree with the block statement. The ! -- link is to the identifier (which is an occurrence of the entity) -- and not to the block_statement itself, because the statement may -- be rewritten, e.g. in the process of removing dead code. *************** package Einfo is *** 502,508 **** -- Checks_May_Be_Suppressed (Flag31) -- Present in all entities. Set if a pragma Suppress or Unsuppress -- mentions the entity specifically in the second argument. If this ! -- flag is set the the Global_Entity_Suppress and Local_Entity_Suppress -- tables must be consulted to determine if the is actually an active -- Suppress or Unsuppress pragma that applies to the entity. --- 495,501 ---- -- Checks_May_Be_Suppressed (Flag31) -- Present in all entities. Set if a pragma Suppress or Unsuppress -- mentions the entity specifically in the second argument. If this ! -- flag is set the Global_Entity_Suppress and Local_Entity_Suppress -- tables must be consulted to determine if the is actually an active -- Suppress or Unsuppress pragma that applies to the entity. *************** package Einfo is *** 552,558 **** -- component clause applies to the component. First bit position of -- given component, computed from the first bit and position values -- given in the component clause. A value of No_Uint means that the ! -- value is not yet known. The value can be set by the appearence of -- an explicit component clause in a record representation clause, -- or it can be set by the front-end in package Layout, or it can be -- set by the backend. By the time backend processing is completed, --- 545,551 ---- -- component clause applies to the component. First bit position of -- given component, computed from the first bit and position values -- given in the component clause. A value of No_Uint means that the ! -- value is not yet known. The value can be set by the appearance of -- an explicit component clause in a record representation clause, -- or it can be set by the front-end in package Layout, or it can be -- set by the backend. By the time backend processing is completed, *************** package Einfo is *** 593,599 **** -- Constant_Value (synthesized) -- Applies to variables, constants, named integers, and named reals. -- Obtains the initialization expression for the entity. Will return ! -- Empty for for a deferred constant whose full view is not available -- or in some other cases of internal entities, which cannot be treated -- as constants from the point of view of constant folding. Empty is -- also returned for variables with no initialization expression. --- 586,592 ---- -- Constant_Value (synthesized) -- Applies to variables, constants, named integers, and named reals. -- Obtains the initialization expression for the entity. Will return ! -- Empty for a deferred constant whose full view is not available -- or in some other cases of internal entities, which cannot be treated -- as constants from the point of view of constant folding. Empty is -- also returned for variables with no initialization expression. *************** package Einfo is *** 631,640 **** -- created at the same time as the discriminal, and used to replace -- occurrences of the discriminant within the type declaration. ! -- Current_Use_Clause (Node25) ! -- Present in packages. Indicates the use clause currently in scope ! -- that makes the package use_visible. Used to detect redundant use ! -- clauses for the same package. -- Current_Value (Node9) -- Present in all object entities. Set in E_Variable, E_Constant, formal --- 624,635 ---- -- created at the same time as the discriminal, and used to replace -- occurrences of the discriminant within the type declaration. ! -- Current_Use_Clause (Node27) ! -- Present in packages and in types. For packages, denotes the use ! -- package clause currently in scope that makes the package use_visible. ! -- For types, it denotes the use_type clause that makes the operators of ! -- the type visible. Used for more precise warning messages on redundant ! -- use clauses. -- Current_Value (Node9) -- Present in all object entities. Set in E_Variable, E_Constant, formal *************** package Einfo is *** 864,870 **** -- Elaboration_Entity (Node13) -- Present in generic and non-generic package and subprogram -- entities. This is a boolean entity associated with the unit that ! -- is initiallly set to False, and is set True when the unit is -- elaborated. This is used for two purposes. First, it is used to -- implement required access before elaboration checks (the flag -- must be true to call a subprogram at elaboration time). Second, --- 859,865 ---- -- Elaboration_Entity (Node13) -- Present in generic and non-generic package and subprogram -- entities. This is a boolean entity associated with the unit that ! -- is initially set to False, and is set True when the unit is -- elaborated. This is used for two purposes. First, it is used to -- implement required access before elaboration checks (the flag -- must be true to call a subprogram at elaboration time). Second, *************** package Einfo is *** 985,996 **** -- Equivalent_Type (Node18) -- Present in class wide types and subtypes, access to protected ! -- subprogram types, and in exception_types. For a classwide type, it -- is always Empty. For a class wide subtype, it points to an entity -- created by the expander which gives Gigi an easily understandable -- equivalent of the class subtype with a known size (given by an -- initial value). See Exp_Util.Expand_Class_Wide_Subtype for further ! -- details. For E_exception_type, this points to the record containing -- the data necessary to represent exceptions (for further details, see -- System.Standard_Library. For access_to_protected subprograms, it -- denotes a record that holds pointers to the operation and to the --- 980,991 ---- -- Equivalent_Type (Node18) -- Present in class wide types and subtypes, access to protected ! -- subprogram types, and in exception types. For a classwide type, it -- is always Empty. For a class wide subtype, it points to an entity -- created by the expander which gives Gigi an easily understandable -- equivalent of the class subtype with a known size (given by an -- initial value). See Exp_Util.Expand_Class_Wide_Subtype for further ! -- details. For E_Exception_Type, this points to the record containing -- the data necessary to represent exceptions (for further details, see -- System.Standard_Library. For access_to_protected subprograms, it -- denotes a record that holds pointers to the operation and to the *************** package Einfo is *** 1071,1082 **** -- must be retrieved through the entity designed by this field instead of -- being computed. ! -- Can_Use_Internal_Rep (Flag229) ! -- Present in Access_Subprogram_Type_Kind nodes. This flag is set by ! -- the front end and used by the back end. False means that the back end -- must represent the type in the same way as Convention-C types (and ! -- other foreign-convention types). On many targets, this means that the ! -- back end will use dynamically generated trampolines for nested -- subprograms. True means that the back end can represent the type in -- some internal way. On the aforementioned targets, this means that the -- back end will not use dynamically generated trampolines. This flag --- 1066,1077 ---- -- must be retrieved through the entity designed by this field instead of -- being computed. ! -- Can_Use_Internal_Rep (Flag229) [base type only] ! -- Present in Access_Subprogram_Kind nodes. This flag is set by the ! -- front end and used by the back end. False means that the back end -- must represent the type in the same way as Convention-C types (and ! -- other foreign-convention types). On many targets, this means that ! -- the back end will use dynamically generated trampolines for nested -- subprograms. True means that the back end can represent the type in -- some internal way. On the aforementioned targets, this means that the -- back end will not use dynamically generated trampolines. This flag *************** package Einfo is *** 1292,1308 **** -- For all types other than private and incomplete types, this field -- always contains Empty. See also Underlying_Type. - -- Function_Returns_With_DSP (Flag169) - -- Present in all subprogram entities, and type entities for access - -- to subprogram values. Set True if the function (or referenced - -- function in the case of an access value) returns with using the - -- DSP (depressed stack pointer) approach. This can only be set - -- True if Targparm.Functions_Return_By_DSP_On_Target is True and - -- the function returns a value of a type whose size is not known - -- at compile time. - -- - -- Note: this flag is obsolete, it is always False ??? - -- Generic_Homonym (Node11) -- Present in generic packages. The generic homonym is the entity of -- a renaming declaration inserted in every generic unit. It is used --- 1287,1292 ---- *************** package Einfo is *** 1529,1539 **** -- error exeption is correctly raised in this case at runtime. -- Has_Up_Level_Access (Flag215) ! -- Present in E_Variable and E_Constant entities. Set if the entity is ! -- declared in a local procedure p and is accessed in a procedure nested ! -- inside p. Only set when VM_Target /= No_VM currently. ! -- Why only set it under those conditions, sounds reasonable to always ! -- set this flag when appropriate ??? -- Has_Nested_Block_With_Handler (Flag101) -- Present in scope entities. Set if there is a nested block within the --- 1513,1523 ---- -- error exeption is correctly raised in this case at runtime. -- Has_Up_Level_Access (Flag215) ! -- Present in E_Variable and E_Constant entities. Set if the entity ! -- is a local variable declared in a subprogram p and is accessed in ! -- a subprogram nested inside p. Currently this flag is only set when ! -- VM_Target /= No_VM, for efficiency, since only the .NET back-end ! -- makes use of it to generate proper code for up-level references. -- Has_Nested_Block_With_Handler (Flag101) -- Present in scope entities. Set if there is a nested block within the *************** package Einfo is *** 1580,1585 **** --- 1564,1573 ---- -- to which the pragma applies, as well as the unit entity itself, for -- convenience in propagating the flag to contained entities. + -- Has_Postconditions (Flag240) + -- Present in subprogram entities. Set if postconditions are active for + -- the procedure, and a _postconditions procedure has been generated. + -- Has_Pragma_Controlled (Flag27) [implementation base type only] -- Present in access type entities. It is set if a pragma Controlled -- applies to the access type. *************** package Einfo is *** 1604,1610 **** -- Has_Pragma_Pack (Flag121) [implementation base type only] -- Present in all entities. If set, indicates that a valid pragma Pack ! -- was was given for the type. Note that this flag is not inherited by -- derived type. See also the Is_Packed flag. -- Has_Pragma_Pure (Flag203) --- 1592,1598 ---- -- Has_Pragma_Pack (Flag121) [implementation base type only] -- Present in all entities. If set, indicates that a valid pragma Pack ! -- was given for the type. Note that this flag is not inherited by -- derived type. See also the Is_Packed flag. -- Has_Pragma_Pure (Flag203) *************** package Einfo is *** 1625,1638 **** -- Present in all entities. Can only be set for variables (E_Variable, -- E_Out_Parameter, E_In_Out_Parameter). Set if a valid pragma Unmodified -- applies to the variable, indicating that no warning should be given ! -- if the entity is never modified. -- Has_Pragma_Unreferenced (Flag180) -- Present in all entities. Set if a valid pragma Unreferenced applies -- to the entity, indicating that no warning should be given if the -- entity has no references, but a warning should be given if it is -- in fact referenced. For private types, this flag is set in both the ! -- private entity and full entity if the pragma applies to either. -- Has_Pragma_Unreferenced_Objects (Flag212) -- Present in type and subtype entities. Set if a valid pragma --- 1613,1629 ---- -- Present in all entities. Can only be set for variables (E_Variable, -- E_Out_Parameter, E_In_Out_Parameter). Set if a valid pragma Unmodified -- applies to the variable, indicating that no warning should be given ! -- if the entity is never modified. Note that clients should generally ! -- not test this flag directly, but instead use function Has_Unmodified. -- Has_Pragma_Unreferenced (Flag180) -- Present in all entities. Set if a valid pragma Unreferenced applies -- to the entity, indicating that no warning should be given if the -- entity has no references, but a warning should be given if it is -- in fact referenced. For private types, this flag is set in both the ! -- private entity and full entity if the pragma applies to either. Note ! -- that clients should generally not test this flag directly, but instead ! -- use function Has_Unreferenced. -- Has_Pragma_Unreferenced_Objects (Flag212) -- Present in type and subtype entities. Set if a valid pragma *************** package Einfo is *** 1821,1826 **** --- 1812,1829 ---- -- Applies to functions and procedures. Set if pragma Implemented_By_ -- Entry is applied on the subprogram entity. + -- Interfaces (Elist25) + -- Present in record types and subtypes. List of abstract interfaces + -- implemented by a tagged type that are not already implemented by the + -- ancestors (Ada 2005: AI-251). + + -- Interface_Alias (Node25) + -- Present in subprograms that cover a primitive operation of an abstract + -- interface type. Can be set only if the Is_Hidden flag is also set, + -- since such entities are always hidden. Points to its associated + -- interface subprogram. It is used to register the subprogram in + -- secondary dispatch table of the interface (Ada 2005: AI-251). + -- In_Package_Body (Flag48) -- Present in package entities. Set on the entity that denotes the -- package (the defining occurrence of the package declaration) while *************** package Einfo is *** 1992,1997 **** --- 1995,2004 ---- -- Applies to all entities, true for task types and subtypes and for -- protected types and subtypes. + -- Is_Constant_Object (synthesized) + -- Applies to all entities, true for E_Constant, E_Loop_Parameter, and + -- E_In_Parameter entities. + -- Is_Constrained (Flag12) -- Present in types or subtypes which may have index, discriminant -- or range constraint (i.e. array types and subtypes, record types *************** package Einfo is *** 2051,2056 **** --- 2058,2071 ---- -- Present in all entities. Set only in E_Function entities that Layout -- creates to compute discriminant-dependent dynamic size/offset values. + -- Is_Discriminal (synthesized) + -- Applies to all entities, true for renamings of discriminants. Such + -- entities appear as constants or in parameters. + + -- Is_Dispatch_Table_Entity (Flag234) + -- Applies to all entities. Set to indicate to the backend that this + -- entity is associated with a dispatch table. + -- Is_Dispatching_Operation (Flag6) -- Present in all entities. Set true for procedures, functions, -- generic procedures and generic functions if the corresponding *************** package Einfo is *** 2231,2236 **** --- 2246,2255 ---- -- 3) Object declarations generated by the expander that are implicitly -- imported or exported so that they can be marked in Sprint output. -- + -- 4) Internal entities in the list of primitives of tagged types that + -- are used to handle secondary dispatch tables. These entities have + -- also the attribute Interface_Alias. + -- -- Is_Interrupt_Handler (Flag89) -- Present in procedures. Set if a pragma Interrupt_Handler applies -- to the procedure. The procedure must be parameterless, and on all *************** package Einfo is *** 2492,2500 **** -- indicators in bodies. -- Is_Primitive_Wrapper (Flag195) ! -- Present in all entities. Set for procedure entries that are used as ! -- primitive wrappers. which are generated by the expander to wrap ! -- entries of protected or task types implementing a limited interface. -- Is_Private_Composite (Flag107) -- Present in composite types that have a private component. Used to --- 2511,2523 ---- -- indicators in bodies. -- Is_Primitive_Wrapper (Flag195) ! -- Present in functions and procedures created by the expander to serve ! -- as an indirection mechanism to overriding primitives of concurrent ! -- types, entries and protected procedures. ! ! -- Is_Prival (synthesized) ! -- Applies to all entities, true for renamings of private protected ! -- components. Such entities appear as constants or variables. -- Is_Private_Composite (Flag107) -- Present in composite types that have a private component. Used to *************** package Einfo is *** 2508,2517 **** --- 2531,2548 ---- -- functions, procedures). Set if the library unit is itself a private -- child unit, or if it is the descendent of a private child unit. + -- Is_Private_Primitive (Flag245) + -- Present in subprograms. Set if the first parameter of the subprogram + -- is of concurrent tagged type with a private view. + -- Is_Private_Type (synthesized) -- Applies to all entities, true for private types and subtypes, -- as well as for record with private types as subtypes + -- Is_Protected_Component (synthesized) + -- Applicable to all entities, true if the entity denotes a private + -- component of a protected type. + -- Is_Protected_Interface (Flag198) -- Present in types that are interfaces. True if interface is declared -- protected, or is derived from protected interfaces. *************** package Einfo is *** 2526,2535 **** -- example in the case of a variable name, then Gigi will generate an -- appropriate external name for use by the linker. - -- Is_Protected_Private (synthesized) - -- Applies to a record component. Returns true if this component - -- is used to represent a private declaration of a protected type. - -- Is_Protected_Record_Type (synthesized) -- Applies to all entities, true if Is_Concurrent_Record_Type -- Corresponding_Concurrent_Type is a protected type. --- 2557,2562 ---- *************** package Einfo is *** 2549,2557 **** -- subtype appears in a pure unit. Used to give an error message at -- freeze time if the access type has a storage pool. -- Is_Raised (Flag224) ! -- Present in entities which denote exceptions. Set if the exception is ! -- thrown by a raise statement. -- Is_Real_Type (synthesized) -- Applies to all entities, true for real types and subtypes --- 2576,2588 ---- -- subtype appears in a pure unit. Used to give an error message at -- freeze time if the access type has a storage pool. + -- Is_RACW_Stub_Type (Flag244) + -- Present in all types, true for the stub types generated for remote + -- access-to-class-wide types. + -- Is_Raised (Flag224) ! -- Present in exception entities. Set if the entity is referenced by a ! -- a raise statement. -- Is_Real_Type (synthesized) -- Applies to all entities, true for real types and subtypes *************** package Einfo is *** 2562,2574 **** -- Is_Remote_Call_Interface (Flag62) -- Present in all entities. Set in E_Package and E_Generic_Package ! -- entities to which a pragma Remote_Call_Interace is applied, and ! -- also in all entities within such packages. -- Is_Remote_Types (Flag61) -- Present in all entities. Set in E_Package and E_Generic_Package ! -- entities to which a pragma Remote_Types is applied, and also in ! -- all entities within such packages. -- Is_Renaming_Of_Object (Flag112) -- Present in all entities, set only for a variable or constant for --- 2593,2605 ---- -- Is_Remote_Call_Interface (Flag62) -- Present in all entities. Set in E_Package and E_Generic_Package ! -- entities to which a pragma Remote_Call_Interface is applied, and ! -- also on entities declared in the visible part of such a package. -- Is_Remote_Types (Flag61) -- Present in all entities. Set in E_Package and E_Generic_Package ! -- entities to which a pragma Remote_Types is applied, and also on ! -- entities declared in the visible part of the spec of such a package. -- Is_Renaming_Of_Object (Flag112) -- Present in all entities, set only for a variable or constant for *************** package Einfo is *** 2597,2602 **** --- 2628,2638 ---- -- entities to which a pragma Shared_Passive is applied, and also in -- all entities within such packages. + -- Is_Standard_Character_Type (synthesized) + -- Applies to all entities, true for types and subtypes whose root type + -- is one of the standard character types (Character, Wide_Character, + -- Wide_Wide_Character). + -- Is_Statically_Allocated (Flag28) -- Present in all entities. This can only be set True for exception, -- variable, constant, and type/subtype entities. If the flag is set, *************** package Einfo is *** 2610,2628 **** -- which does not also have this flag set to True. For a variable or -- or constant, if the flag is set, then the type of the object must -- either be declared at the library level, or it must also have the ! -- flag set (since to allocate the oject statically, its type must -- also be elaborated globally). - -- Is_Subprogram (synthesized) - -- Applies to all entities, true for bodies of functions, procedures - -- and operators. - -- Is_String_Type (synthesized) -- Applies to all type entities. Determines if the given type is a -- string type, i.e. it is directly a string type or string subtype, -- or a string slice type, or an array type with one dimension and a -- component type that is a character type. -- Is_Synchronized_Interface (Flag199) -- Present in types that are interfaces. True if interface is declared -- synchronized, task, or protected, or is derived from a synchronized --- 2646,2664 ---- -- which does not also have this flag set to True. For a variable or -- or constant, if the flag is set, then the type of the object must -- either be declared at the library level, or it must also have the ! -- flag set (since to allocate the object statically, its type must -- also be elaborated globally). -- Is_String_Type (synthesized) -- Applies to all type entities. Determines if the given type is a -- string type, i.e. it is directly a string type or string subtype, -- or a string slice type, or an array type with one dimension and a -- component type that is a character type. + -- Is_Subprogram (synthesized) + -- Applies to all entities, true for function, procedure and operator + -- entities. + -- Is_Synchronized_Interface (Flag199) -- Present in types that are interfaces. True if interface is declared -- synchronized, task, or protected, or is derived from a synchronized *************** package Einfo is *** 2630,2645 **** -- Is_Tag (Flag78) -- Present in E_Component and E_Constant entities. For regular tagged ! -- type this flag is set on the tag component (whose name is Name_uTag) ! -- and for CPP_Class tagged types, this flag marks the pointer to the ! -- main vtable (i.e. the one to be extended by derivation). -- Is_Tagged_Type (Flag55) -- Present in all entities. Set for an entity for a tagged type. -- Is_Task_Interface (Flag200) ! -- Present in types that are interfaces. True is interface is declared ! -- as such, or if it is derived from task interfaces. -- Is_Task_Record_Type (synthesized) -- Applies to all entities. True if Is_Concurrent_Record_Type --- 2666,2681 ---- -- Is_Tag (Flag78) -- Present in E_Component and E_Constant entities. For regular tagged ! -- type this flag is set on the tag component (whose name is Name_uTag). ! -- For CPP_Class tagged types, this flag marks the pointer to the main ! -- vtable (i.e. the one to be extended by derivation). -- Is_Tagged_Type (Flag55) -- Present in all entities. Set for an entity for a tagged type. -- Is_Task_Interface (Flag200) ! -- Present in types that are interfaces. True if interface is declared as ! -- a task interface, or if it is derived from task interfaces. -- Is_Task_Record_Type (synthesized) -- Applies to all entities. True if Is_Concurrent_Record_Type *************** package Einfo is *** 2649,2661 **** -- Applies to all entities. True for task types and subtypes -- Is_Thunk (Flag225) ! -- True for subprograms that are thunks. Thunks are small subprograms ! -- built by the expander for tagged types that cover interface types; ! -- at run-time thunks displace the pointer to the object (pointer named ! -- "this" in the C++ terminology) from a secondary dispatch table to the ! -- primary dispatch table associated with a given tagged type. Set by ! -- Expand_Interface Thunk and used by Expand_Call to handle extra actuals ! -- associated with accessibility level. -- Is_True_Constant (Flag163) -- Present in all entities for constants and variables. Set in constants --- 2685,2704 ---- -- Applies to all entities. True for task types and subtypes -- Is_Thunk (Flag225) ! -- Present in all entities for subprograms (functions, procedures, and ! -- operators). True for subprograms that are thunks, that is small ! -- subprograms built by the expander for tagged types that cover ! -- interface types. At run-time thunks displace the pointer to the object ! -- (pointer named "this" in the C++ terminology) from a secondary ! -- dispatch table to the primary dispatch table associated with a given ! -- tagged type. Set by Expand_Interface Thunk and used by Expand_Call to ! -- handle extra actuals associated with accessibility level. ! ! -- Is_Trivial_Subprogram (Flag235) ! -- Present in all entities. Set in subprograms where either the body ! -- consists of a single null statement, or the first or only statement ! -- of the body raises an exception. This is used for suppressing certain ! -- warnings, see Sem_Ch6.Analyze_Subprogram_Body discussion for details. -- Is_True_Constant (Flag163) -- Present in all entities for constants and variables. Set in constants *************** package Einfo is *** 2711,2717 **** -- package. Indicates that the entity must be made visible in the body -- of the instance, to reproduce the visibility of the generic. This -- simplifies visibility settings in instance bodies. ! -- ??? confusion in abovecomments between being present and being set -- Is_VMS_Exception (Flag133) -- Present in all entities. Set only for exception entities where the --- 2754,2760 ---- -- package. Indicates that the entity must be made visible in the body -- of the instance, to reproduce the visibility of the generic. This -- simplifies visibility settings in instance bodies. ! -- ??? confusion in above comments between being present and being set -- Is_VMS_Exception (Flag133) -- Present in all entities. Set only for exception entities where the *************** package Einfo is *** 2745,2757 **** -- Kill_Elaboration_Checks (Flag32) -- Present in all entities. Set by the expander to kill elaboration -- checks which are known not to be needed. Equivalent in effect to ! -- the use of pragma Supress (Elaboration_Checks) for that entity -- except that the effect is permanent and cannot be undone by a -- subsequent pragma Unsuppress. -- Kill_Range_Checks (Flag33) -- Present in all entities. Equivalent in effect to the use of pragma ! -- Supress (Range_Checks) for that entity except that the result is -- permanent and cannot be undone by a subsequent pragma Unsuppress. -- This is currently only used in one odd situation in Sem_Ch3 for -- record types, and it would be good to get rid of it??? --- 2788,2800 ---- -- Kill_Elaboration_Checks (Flag32) -- Present in all entities. Set by the expander to kill elaboration -- checks which are known not to be needed. Equivalent in effect to ! -- the use of pragma Suppress (Elaboration_Checks) for that entity -- except that the effect is permanent and cannot be undone by a -- subsequent pragma Unsuppress. -- Kill_Range_Checks (Flag33) -- Present in all entities. Equivalent in effect to the use of pragma ! -- Suppress (Range_Checks) for that entity except that the result is -- permanent and cannot be undone by a subsequent pragma Unsuppress. -- This is currently only used in one odd situation in Sem_Ch3 for -- record types, and it would be good to get rid of it??? *************** package Einfo is *** 2759,2765 **** -- Kill_Tag_Checks (Flag34) -- Present in all entities. Set by the expander to kill elaboration -- checks which are known not to be needed. Equivalent in effect to ! -- the use of pragma Supress (Tag_Checks) for that entity except -- that the result is permanent and cannot be undone by a subsequent -- pragma Unsuppress. --- 2802,2808 ---- -- Kill_Tag_Checks (Flag34) -- Present in all entities. Set by the expander to kill elaboration -- checks which are known not to be needed. Equivalent in effect to ! -- the use of pragma Suppress (Tag_Checks) for that entity except -- that the result is permanent and cannot be undone by a subsequent -- pragma Unsuppress. *************** package Einfo is *** 2784,2790 **** -- associated entities is attached (blocks, class subtypes and types, -- entries, functions, loops, packages, procedures, protected objects, -- record types and subtypes, private types, task types and subtypes). ! -- Points to a the last entry in the list of associated entities chained -- through the Next_Entity field. Empty if no entities are chained. -- Limited_View (Node23) --- 2827,2833 ---- -- associated entities is attached (blocks, class subtypes and types, -- entries, functions, loops, packages, procedures, protected objects, -- record types and subtypes, private types, task types and subtypes). ! -- Points to the last entry in the list of associated entities chained -- through the Next_Entity field. Empty if no entities are chained. -- Limited_View (Node23) *************** package Einfo is *** 2798,2804 **** -- Present in enumeration types and subtypes. Non-empty only for the -- case of an enumeration root type, where it contains the entity for -- the generated indexes entity. See unit Exp_Imgv for full details of ! -- the nature and use of this entity for implkementing the Image and -- Value attributes for the enumeration type in question. -- -- Lit_Strings (Node16) --- 2841,2847 ---- -- Present in enumeration types and subtypes. Non-empty only for the -- case of an enumeration root type, where it contains the entity for -- the generated indexes entity. See unit Exp_Imgv for full details of ! -- the nature and use of this entity for implementing the Image and -- Value attributes for the enumeration type in question. -- -- Lit_Strings (Node16) *************** package Einfo is *** 2869,2881 **** -- to the freeze point because of the rule about overriding Initialize). -- Needs_Debug_Info (Flag147) ! -- Present in all entities. Set if the entity requires debugging ! -- information to be generated. This is true of all entities that ! -- have Comes_From_Source set, and also transitively for entities ! -- associated with such components (e.g. their types). It is true ! -- for all entities in Debug_Generated_Code mode (-gnatD switch). ! -- This is the flag that the back end should check to determine ! -- whether or not to generate debugging information for an entity. -- Needs_No_Actuals (Flag22) -- Present in callable entities (subprograms, entries, access to --- 2912,2926 ---- -- to the freeze point because of the rule about overriding Initialize). -- Needs_Debug_Info (Flag147) ! -- Present in all entities. Set if the entity requires normal debugging ! -- information to be generated. This is true of all entities that have ! -- Comes_From_Source set, and also transitively for entities associated ! -- with such components (e.g. their types). It is true for all entities ! -- in Debug_Generated_Code mode (-gnatD switch). This is the flag that ! -- the back end should check to determine whether or not to generate ! -- debugging information for an entity. Note that callers should always ! -- use Sem_Util.Set_Debug_Info_Needed, rather than Set_Needs_Debug_Info, ! -- so that the flag is set properly on subsidiary entities. -- Needs_No_Actuals (Flag22) -- Present in callable entities (subprograms, entries, access to *************** package Einfo is *** 2998,3005 **** -- of a record, returns the next _Tag field in this record. -- Non_Binary_Modulus (Flag58) [base type only] ! -- Present in modular integer types. Set if the modulus for the type ! -- is other than a power of 2. -- Non_Limited_View (Node17) -- Present in incomplete types that are the shadow entities created --- 3043,3050 ---- -- of a record, returns the next _Tag field in this record. -- Non_Binary_Modulus (Flag58) [base type only] ! -- Present in all subtype and type entities. Set for modular integer ! -- types if the modulus value is other than a power of 2. -- Non_Limited_View (Node17) -- Present in incomplete types that are the shadow entities created *************** package Einfo is *** 3071,3081 **** -- Applies to subprograms and subprogram types. Yields the number of -- formals as a value of type Pos. ! -- Obsolescent_Warning (Node24) ! -- Present in all entities. Set non-empty only if a pragma Obsolescent ! -- applying to the entity had a string argument, in which case it records ! -- the contents of the corresponding string literal node. This field is ! -- only accessed if the flag Is_Obsolescent is set. -- Original_Array_Type (Node21) -- Present in modular types and array types and subtypes. Set only --- 3116,3136 ---- -- Applies to subprograms and subprogram types. Yields the number of -- formals as a value of type Pos. ! -- Optimize_Alignment_Space (Flag241) ! -- A flag present in type, subtype, variable, and constant entities. This ! -- flag records that the type or object is to be layed out in a manner ! -- consistent with Optimize_Alignment (Space) mode. The compiler and ! -- binder ensure a consistent view of any given type or object. If pragma ! -- Optimize_Alignment (Off) mode applies to the type/object, then neither ! -- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set. ! ! -- Optimize_Alignment_Time (Flag242) ! -- A flag present in type, subtype, variable, and constant entities. This ! -- flag records that the type or object is to be layed out in a manner ! -- consistent with Optimize_Alignment (Time) mode. The compiler and ! -- binder ensure a consistent view of any given type or object. If pragma ! -- Optimize_Alignment (Off) mode applies to the type/object, then neither ! -- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set. -- Original_Array_Type (Node21) -- Present in modular types and array types and subtypes. Set only *************** package Einfo is *** 3084,3093 **** -- points to the original array type for which this is the packed -- array implementation type. ! -- Object_Ref (Node17) ! -- Present in protected bodies. This is an implicit prival for the ! -- Protection object associated with a protected object. See Prival ! -- for further details on the use of privals. -- Original_Record_Component (Node22) -- Present in components, including discriminants. The usage depends --- 3139,3149 ---- -- points to the original array type for which this is the packed -- array implementation type. ! -- OK_To_Reorder_Components (Flag239) [base type only] ! -- Present in record types. Set if the back end is permitted to reorder ! -- the components. If not set, the record must be layed out in the order ! -- in which the components are declared textually. Currently this flag ! -- can only be set by debug switches. -- Original_Record_Component (Node22) -- Present in components, including discriminants. The usage depends *************** package Einfo is *** 3109,3114 **** --- 3165,3174 ---- -- In subtypes (tagged and untagged): -- Points to the component in the base type. + -- Overlays_Constant (Flag243) + -- Present in all entities. Set only for a variable for which there is + -- an address clause which causes the variable to overlay a constant. + -- Overridden_Operation (Node26) -- Present in subprograms. For overriding operations, points to the -- user-defined parent subprogram that is being overridden. *************** package Einfo is *** 3140,3146 **** -- Parameter_Mode (synthesized) -- Applies to formal parameter entities. This is a synonym for Ekind, -- used when obtaining the formal kind of a formal parameter (the result ! -- is one of E_[In/Out/In_Out]_Paramter) -- Parent_Subtype (Node19) -- Present in E_Record_Type. Points to the subtype to use for a --- 3200,3206 ---- -- Parameter_Mode (synthesized) -- Applies to formal parameter entities. This is a synonym for Ekind, -- used when obtaining the formal kind of a formal parameter (the result ! -- is one of E_[In/Out/In_Out]_Parameter) -- Parent_Subtype (Node19) -- Present in E_Record_Type. Points to the subtype to use for a *************** package Einfo is *** 3153,3158 **** --- 3213,3227 ---- -- is an error to reference the primitive operations field of a type -- that is not tagged). + -- Prival (Node17) + -- Present in private components of protected types. Refers to the entity + -- of the component renaming declaration generated inside protected + -- subprograms, entries or barrier functions. + + -- Prival_Link (Node20) + -- Present in constants and variables which rename private components of + -- protected types. Set to the original private component. + -- Private_Dependents (Elist18) -- Present in private (sub)types. Records the subtypes of the -- private type, derivations from it, and records and arrays *************** package Einfo is *** 3173,3192 **** -- declaration of the type is seen. Subprograms that have such an -- access parameter are also placed in the list of private_dependents. - -- Prival (Node17) - -- Present in components. Used for representing private declarations - -- of protected objects (private formal: by analogy to Discriminal_Link). - -- Empty unless the synthesized Is_Protected_Private attribute is - -- true. The entity used as a formal parameter that corresponds to - -- the to the private declaration in protected operations. See - -- "Private data in protected objects" for details. - - -- Privals_Chain (Elist23) - -- Present in protected operations (subprograms and entries). Links - -- all occurrences of the Privals in the body of the operation, in - -- order to patch their types at the end of their expansion. See - -- "Private data in protected objects" for details. - -- Private_View (Node22) -- For each private type, three entities are allocated, the private view, -- the full view, and the shadow entity. The shadow entity contains a --- 3242,3247 ---- *************** package Einfo is *** 3208,3223 **** -- Present in protected operations. References the entity for the -- subprogram which implements the body of the operation. ! -- Protected_Operation (Node23) ! -- Present in components. Used for representing private declarations ! -- of protected objects. Empty unless the synthesized attribute ! -- Is_Protected_Private is True. This is the entity corresponding ! -- to the body of the protected operation currently being analyzed, ! -- and which will eventually use the current Prival associated with ! -- this component to refer to the renaming of a private object ! -- component. As soon as the expander generates this renaming, this ! -- attribute is changed to refer to the next protected subprogram. ! -- See "Private data in protected objects" for details. -- Reachable (Flag49) -- Present in labels. The flag is set over the range of statements in --- 3263,3272 ---- -- Present in protected operations. References the entity for the -- subprogram which implements the body of the operation. ! -- Protection_Object (Node23) ! -- Applies to protected entries, entry families and subprograms. Denotes ! -- the entity which is used to rename the _object component of protected ! -- types. -- Reachable (Flag49) -- Present in labels. The flag is set over the range of statements in *************** package Einfo is *** 3225,3233 **** -- Referenced (Flag156) -- Present in all entities. Set if the entity is referenced, except for ! -- the case of an appearence of a simple variable that is not a renaming -- as the left side of an assignment in which case Referenced_As_LHS is ! -- set instead, or a similar appearence as an out parameter actual, in -- which case As_Out_Parameter_Parameter is set. -- Referenced_As_LHS (Flag36): --- 3274,3282 ---- -- Referenced (Flag156) -- Present in all entities. Set if the entity is referenced, except for ! -- the case of an appearance of a simple variable that is not a renaming -- as the left side of an assignment in which case Referenced_As_LHS is ! -- set instead, or a similar appearance as an out parameter actual, in -- which case As_Out_Parameter_Parameter is set. -- Referenced_As_LHS (Flag36): *************** package Einfo is *** 3275,3284 **** -- Set to point to the entity of the associated tagged type or interface -- type. -- Renamed_Entity (Node18) -- Present in exceptions, packages, subprograms and generic units. Set -- for entities that are defined by a renaming declaration. Denotes the ! -- renamed entity, or transititively the ultimate renamed entity if -- there is a chain of renaming declarations. Empty if no renaming. -- Renamed_In_Spec (Flag231) --- 3324,3339 ---- -- Set to point to the entity of the associated tagged type or interface -- type. + -- Relative_Deadline_Variable (Node26) [implementation base type only] + -- Present in task type entities. This flag is set if a valid and + -- effective pragma Relative_Deadline applies to the base type. Points + -- to the entity for a variable that is created to hold the value given + -- in a Relative_Deadline pragma for a task type. + -- Renamed_Entity (Node18) -- Present in exceptions, packages, subprograms and generic units. Set -- for entities that are defined by a renaming declaration. Denotes the ! -- renamed entity, or transitively the ultimate renamed entity if -- there is a chain of renaming declarations. Empty if no renaming. -- Renamed_In_Spec (Flag231) *************** package Einfo is *** 3338,3348 **** -- Reverse_Bit_Order (Flag164) [base type only] -- Present in all record type entities. Set if a valid pragma an ! -- attribute represention clause for Bit_Order has reversed the order of ! -- bits from the default value. When this flag is set, a component clause ! -- must specify a set of bits entirely contained in a single storage unit ! -- (Ada 95) or a single machine scalar (see Ada 2005 AI-133), or must ! -- occupy in integral number of storage units. -- RM_Size (Uint13) -- Present in all type and subtype entities. Contains the value of --- 3393,3403 ---- -- Reverse_Bit_Order (Flag164) [base type only] -- Present in all record type entities. Set if a valid pragma an ! -- attribute representation clause for Bit_Order has reversed the order ! -- of bits from the default value. When this flag is set, a component ! -- clause must specify a set of bits entirely contained in a single ! -- storage unit (Ada 95) or a single machine scalar (see Ada 2005 ! -- AI-133), or must occupy in integral number of storage units. -- RM_Size (Uint13) -- Present in all type and subtype entities. Contains the value of *************** package Einfo is *** 3358,3364 **** -- type of the class covered by the CW type, otherwise returns the -- ultimate derivation ancestor of the given type. This function -- preserves the view, i.e. the Root_Type of a partial view is the ! -- partial view of the ulimate ancestor, the Root_Type of a full view -- is the full view of the ultimate ancestor. Note that this function -- does not correspond exactly to the use of root type in the RM, since -- in the RM root type applies to a class of types, not to a type. --- 3413,3419 ---- -- type of the class covered by the CW type, otherwise returns the -- ultimate derivation ancestor of the given type. This function -- preserves the view, i.e. the Root_Type of a partial view is the ! -- partial view of the ultimate ancestor, the Root_Type of a full view -- is the full view of the ultimate ancestor. Note that this function -- does not correspond exactly to the use of root type in the RM, since -- in the RM root type applies to a class of types, not to a type. *************** package Einfo is *** 3423,3437 **** -- standard format list (i.e. First (Shadow_Entities) is the first -- entry and subsequent entries are obtained using Next. ! -- Shared_Var_Assign_Proc (Node22) ! -- Present in variables. Set non-Empty only if Is_Shared_Passive is ! -- set, in which case this is the entity for the shared memory assign ! -- routine. See Exp_Smem for full details. ! ! -- Shared_Var_Read_Proc (Node15) -- Present in variables. Set non-Empty only if Is_Shared_Passive is ! -- set, in which case this is the entity for the shared memory read ! -- routine. See Exp_Smem for full details. -- Size_Check_Code (Node19) -- Present in constants and variables. Normally Empty. Set if code is --- 3478,3487 ---- -- standard format list (i.e. First (Shadow_Entities) is the first -- entry and subsequent entries are obtained using Next. ! -- Shared_Var_Procs_Instance (Node22) -- Present in variables. Set non-Empty only if Is_Shared_Passive is ! -- set, in which case this is the entity for the associated instance of ! -- System.Shared_Storage.Shared_Var_Procs. See Exp_Smem for full details. -- Size_Check_Code (Node19) -- Present in constants and variables. Normally Empty. Set if code is *************** package Einfo is *** 3458,3464 **** -- size of objects of the type is known at compile time. This flag is -- used to optimize some generated code sequences, and also to enable -- some error checks (e.g. disallowing component clauses on variable ! -- length objects. It is set conservatively (i.e. if it is True, the -- size is certainly known at compile time, if it is False, then the -- size may or may not be known at compile time, but the code will -- assume that it is not known). --- 3508,3514 ---- -- size of objects of the type is known at compile time. This flag is -- used to optimize some generated code sequences, and also to enable -- some error checks (e.g. disallowing component clauses on variable ! -- length objects). It is set conservatively (i.e. if it is True, the -- size is certainly known at compile time, if it is False, then the -- size may or may not be known at compile time, but the code will -- assume that it is not known). *************** package Einfo is *** 3474,3479 **** --- 3524,3536 ---- -- case where there is a separate spec, where this field references -- the corresponding parameter entities in the spec. + -- Spec_PPC_List (Node24) + -- Present in subprogram and generic subprogram entities. Points to a + -- list of Precondition and Postcondition pragma nodes for preconditions + -- and postconditions declared in the spec. The last pragma encountered + -- is at the head of this list, so it is in reverse order of textual + -- appearance. + -- Storage_Size_Variable (Node15) [implementation base type only] -- Present in access types and task type entities. This flag is set -- if a valid and effective pragma Storage_Size applies to the base *************** package Einfo is *** 3566,3571 **** --- 3623,3632 ---- -- checks associated with declared volatile variables, but if the test -- is for the purposes of suppressing optimizations, then the front -- end should test Treat_As_Volatile rather than Is_Volatile. + -- + -- Note: before testing Treat_As_Volatile, consider whether it would + -- be more appropriate to use Exp_Util.Is_Volatile_Reference instead, + -- which catches more cases of volatile references. -- Type_High_Bound (synthesized) -- Applies to scalar types. Returns the tree node (Node_Id) that contains *************** package Einfo is *** 3639,3653 **** -- Warnings_Off (Flag96) -- Present in all entities. Set if a pragma Warnings (Off, entity-name) -- is used to suppress warnings for a given entity. It is also used by ! -- the compiler in some situations to kill spurious warnings. -- Was_Hidden (Flag196) -- Present in all entities. Used to save the value of the Is_Hidden -- attribute when the limited-view is installed (Ada 2005: AI-217). -- Wrapped_Entity (Node27) ! -- Present in an E_Procedure classified as an Is_Primitive_Wrapper. Set ! -- to the entity that is being wrapped. ------------------ -- Access Kinds -- --- 3700,3733 ---- -- Warnings_Off (Flag96) -- Present in all entities. Set if a pragma Warnings (Off, entity-name) -- is used to suppress warnings for a given entity. It is also used by ! -- the compiler in some situations to kill spurious warnings. Note that ! -- clients should generally not test this flag directly, but instead ! -- use function Has_Warnings_Off. ! ! -- Warnings_Off_Used (Flag236) ! -- Present in all entities. Can only be set if Warnings_Off is set. If ! -- set indicates that a warning was suppressed by the Warnings_Off flag, ! -- and Unmodified/Unreferenced would not have suppressed the warning. ! ! -- Warnings_Off_Used_Unmodified (Flag237) ! -- Present in all entities. Can only be set if Warnings_Off is set and ! -- Has_Pragma_Unmodified is not set. If set indicates that a warning was ! -- suppressed by the Warnings_Off status but that pragma Unmodified ! -- would also have suppressed the warning. ! ! -- Warnings_Off_Used_Unreferenced (Flag238) ! -- Present in all entities. Can only be set if Warnings_Off is set and ! -- Has_Pragma_Unreferenced is not set. If set indicates that a warning ! -- was suppressed by the Warnings_Off status but that pragma Unreferenced ! -- would also have suppressed the warning. -- Was_Hidden (Flag196) -- Present in all entities. Used to save the value of the Is_Hidden -- attribute when the limited-view is installed (Ada 2005: AI-217). -- Wrapped_Entity (Node27) ! -- Present in functions and procedures which have been classified as ! -- Is_Primitive_Wrapper. Set to the entity being wrapper. ------------------ -- Access Kinds -- *************** package Einfo is *** 4121,4127 **** -- E_Anonymous_Access_Protected_Subprogram_Type E_Anonymous_Access_Type; ! subtype Access_Subprogram_Type_Kind is Entity_Kind range E_Access_Subprogram_Type .. -- E_Anonymous_Access_Subprogram_Type -- E_Access_Protected_Subprogram_Type --- 4201,4207 ---- -- E_Anonymous_Access_Protected_Subprogram_Type E_Anonymous_Access_Type; ! subtype Access_Subprogram_Kind is Entity_Kind range E_Access_Subprogram_Type .. -- E_Anonymous_Access_Subprogram_Type -- E_Access_Protected_Subprogram_Type *************** package Einfo is *** 4447,4453 **** -- For each enumeration value defined in Entity_Kind we list all the -- attributes defined in Einfo which can legally be applied to an entity -- of that kind. The implementation of the attribute functions (and for ! -- non-synthetized attributes, of the corresponding set procedures) are -- in the Einfo body. -- The following attributes apply to all entities --- 4527,4533 ---- -- For each enumeration value defined in Entity_Kind we list all the -- attributes defined in Einfo which can legally be applied to an entity -- of that kind. The implementation of the attribute functions (and for ! -- non-synthesized attributes, of the corresponding set procedures) are -- in the Einfo body. -- The following attributes apply to all entities *************** package Einfo is *** 4461,4467 **** -- Etype (Node5) -- First_Rep_Item (Node6) -- Freeze_Node (Node7) - -- Obsolescent_Warning (Node24) -- Address_Taken (Flag104) -- Can_Never_Be_Null (Flag38) --- 4541,4546 ---- *************** package Einfo is *** 4496,4501 **** --- 4575,4581 ---- -- Is_Compilation_Unit (Flag149) -- Is_Completely_Hidden (Flag103) -- Is_Discrim_SO_Function (Flag176) + -- Is_Dispatch_Table_Entity (Flag234) -- Is_Dispatching_Operation (Flag6) -- Is_Entry_Formal (Flag52) -- Is_Exported (Flag99) *************** package Einfo is *** 4528,4533 **** --- 4608,4614 ---- -- Is_Shared_Passive (Flag60) -- Is_Statically_Allocated (Flag28) -- Is_Tagged_Type (Flag55) + -- Is_Trivial_Subprogram (Flag235) -- Is_Unchecked_Union (Flag117) -- Is_Visible_Formal (Flag206) -- Is_VMS_Exception (Flag133) *************** package Einfo is *** 4539,4544 **** --- 4620,4626 ---- -- Needs_Debug_Info (Flag147) -- Never_Set_In_Source (Flag115) -- No_Return (Flag113) + -- Overlays_Constant (Flag243) -- Referenced (Flag156) -- Referenced_As_LHS (Flag36) -- Referenced_As_Out_Parameter (Flag227) *************** package Einfo is *** 4547,4552 **** --- 4629,4637 ---- -- Suppress_Value_Tracking_On_Call (Flag217) -- Used_As_Generic_Actual (Flag222) -- Warnings_Off (Flag96) + -- Warnings_Off_Used (Flag236) + -- Warnings_Off_Used_Unmodified (Flag237) + -- Warnings_Off_Used_Unreferenced (Flag238) -- Was_Hidden (Flag196) -- Declaration_Node (synth) *************** package Einfo is *** 4555,4560 **** --- 4640,4646 ---- -- Is_Derived_Type (synth) -- Is_Dynamic_Scope (synth) -- Is_Limited_Type (synth) + -- Is_Standard_Character_Type (synth) -- Underlying_Type (synth) -- all classification attributes (synth) *************** package Einfo is *** 4607,4612 **** --- 4693,4699 ---- -- Is_Generic_Actual_Type (Flag94) -- Is_Generic_Type (Flag13) -- Is_Protected_Interface (Flag198) + -- Is_RACW_Stub_Type (Flag244) -- Is_Synchronized_Interface (Flag199) -- Is_Task_Interface (Flag200) -- Is_Non_Static_Subtype (Flag109) *************** package Einfo is *** 4618,4623 **** --- 4705,4712 ---- -- Known_To_Have_Preelab_Init (Flag207) -- Must_Be_On_Byte_Boundary (Flag183) -- Must_Have_Preelab_Init (Flag208) + -- Optimize_Alignment_Space (Flag241) + -- Optimize_Alignment_Time (Flag242) -- Size_Depends_On_Discriminant (Flag177) -- Size_Known_At_Compile_Time (Flag92) -- Strict_Alignment (Flag145) (base type only) *************** package Einfo is *** 4647,4660 **** -- Directly_Designated_Type (Node20) -- Needs_No_Actuals (Flag22) -- Can_Use_Internal_Rep (Flag229) ! -- (plus type attributes) -- E_Access_Subprogram_Type -- Equivalent_Type (Node18) (remote types only) -- Directly_Designated_Type (Node20) -- Needs_No_Actuals (Flag22) -- Can_Use_Internal_Rep (Flag229) ! -- (plus type attributes) -- E_Access_Type -- E_Access_Subtype --- 4736,4749 ---- -- Directly_Designated_Type (Node20) -- Needs_No_Actuals (Flag22) -- Can_Use_Internal_Rep (Flag229) ! -- (plus type attributes) -- E_Access_Subprogram_Type -- Equivalent_Type (Node18) (remote types only) -- Directly_Designated_Type (Node20) -- Needs_No_Actuals (Flag22) -- Can_Use_Internal_Rep (Flag229) ! -- (plus type attributes) -- E_Access_Type -- E_Access_Subtype *************** package Einfo is *** 4749,4755 **** -- Discriminant_Checking_Func (Node20) -- Interface_Name (Node21) (JGNAT usage only) -- Original_Record_Component (Node22) - -- Protected_Operation (Node23) -- DT_Offset_To_Top_Func (Node25) -- Related_Type (Node26) -- Has_Biased_Representation (Flag139) --- 4838,4843 ---- *************** package Einfo is *** 4759,4765 **** -- Is_Volatile (Flag16) -- Treat_As_Volatile (Flag41) -- Is_Return_Object (Flag209) - -- Is_Protected_Private (synth) -- Next_Component (synth) -- Next_Component_Or_Discriminant (synth) -- Next_Tag_Component (synth) --- 4847,4852 ---- *************** package Einfo is *** 4774,4779 **** --- 4861,4867 ---- -- Actual_Subtype (Node17) -- Renamed_Object (Node18) -- Size_Check_Code (Node19) (constants only) + -- Prival_Link (Node20) (privals only) -- Interface_Name (Node21) -- Related_Type (Node26) (constants only) -- Has_Alignment_Clause (Flag46) *************** package Einfo is *** 4786,4795 **** -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) -- Is_True_Constant (Flag163) -- Is_Volatile (Flag16) -- Treat_As_Volatile (Flag41) - -- Is_Return_Object (Flag209) -- Address_Clause (synth) -- Alignment_Clause (synth) -- Constant_Value (synth) --- 4874,4885 ---- -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) + -- Is_Return_Object (Flag209) -- Is_True_Constant (Flag163) -- Is_Volatile (Flag16) + -- Optimize_Alignment_Space (Flag241) (constants only) + -- Optimize_Alignment_Time (Flag242) (constants only) -- Treat_As_Volatile (Flag41) -- Address_Clause (synth) -- Alignment_Clause (synth) -- Constant_Value (synth) *************** package Einfo is *** 4840,4846 **** -- Last_Entity (Node20) -- Accept_Address (Elist21) -- Scope_Depth_Value (Uint22) ! -- Privals_Chain (Elist23) (for a protected entry) -- Default_Expressions_Processed (Flag108) -- Entry_Accepted (Flag152) -- Is_AST_Entry (Flag132) (for entry only) --- 4930,4936 ---- -- Last_Entity (Node20) -- Accept_Address (Elist21) -- Scope_Depth_Value (Uint22) ! -- Protection_Object (Node23) (protected kind) -- Default_Expressions_Processed (Flag108) -- Entry_Accepted (Flag152) -- Is_AST_Entry (Flag132) (for entry only) *************** package Einfo is *** 4923,4935 **** -- Scope_Depth_Value (Uint22) -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic function only) ! -- Privals_Chain (Elist23) (protected func only) ! -- Abstract_Interface_Alias (Node25) -- Overridden_Operation (Node26) -- Extra_Formals (Node28) -- Body_Needed_For_SAL (Flag40) -- Elaboration_Entity_Required (Flag174) - -- Function_Returns_With_DSP (Flag169) -- Default_Expressions_Processed (Flag108) -- Delay_Cleanups (Flag114) -- Delay_Subprogram_Descriptors (Flag50) --- 5013,5026 ---- -- Scope_Depth_Value (Uint22) -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic function only) ! -- Protection_Object (Node23) (for concurrent kind) ! -- Spec_PPC_List (Node24) ! -- Interface_Alias (Node25) -- Overridden_Operation (Node26) + -- Wrapped_Entity (Node27) (non-generic case only) -- Extra_Formals (Node28) -- Body_Needed_For_SAL (Flag40) -- Elaboration_Entity_Required (Flag174) -- Default_Expressions_Processed (Flag108) -- Delay_Cleanups (Flag114) -- Delay_Subprogram_Descriptors (Flag50) *************** package Einfo is *** 4939,4944 **** --- 5030,5036 ---- -- Has_Master_Entity (Flag21) -- Has_Missing_Return (Flag142) -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Postconditions (Flag240) -- Has_Recursive_Call (Flag143) -- Has_Subprogram_Descriptor (Flag93) -- Implemented_By_Entry (Flag232) (non-generic case only) *************** package Einfo is *** 4952,4958 **** --- 5044,5052 ---- -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) -- Is_Overriding_Operation (Flag39) (non-generic case only) -- Is_Primitive (Flag218) + -- Is_Primitive_Wrapper (Flag195) (non-generic case only) -- Is_Private_Descendant (Flag53) + -- Is_Private_Primitive (Flag245) (non-generic case only) -- Is_Pure (Flag44) -- Is_Thunk (Flag225) -- Is_Visible_Child_Unit (Flag116) *************** package Einfo is *** 5011,5017 **** -- Extra_Formal (Node15) -- Unset_Reference (Node16) -- Actual_Subtype (Node17) - -- Renamed_Object (Node18) -- Spec_Entity (Node19) -- Default_Value (Node20) --- 5105,5110 ---- *************** package Einfo is *** 5071,5076 **** --- 5164,5170 ---- -- First_Entity (Node17) -- Alias (Node18) -- Last_Entity (Node20) + -- Has_Postconditions (Flag240) -- Is_Machine_Code_Subprogram (Flag137) -- Is_Pure (Flag44) -- Is_Intrinsic_Subprogram (Flag64) *************** package Einfo is *** 5078,5083 **** --- 5172,5179 ---- -- Is_Primitive (Flag218) -- Is_Thunk (Flag225) -- Default_Expressions_Processed (Flag108) + -- Aren't there more flags and fields? seems like this list should be + -- more similar to the E_Function list, which is much longer ??? -- E_Ordinary_Fixed_Point_Type -- E_Ordinary_Fixed_Point_Subtype *************** package Einfo is *** 5109,5115 **** -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic case only) -- Limited_View (Node23) (non-generic/instance) ! -- Current_Use_Clause (Node25) -- Package_Instantiation (Node26) -- Delay_Subprogram_Descriptors (Flag50) -- Body_Needed_For_SAL (Flag40) --- 5205,5211 ---- -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic case only) -- Limited_View (Node23) (non-generic/instance) ! -- Current_Use_Clause (Node27) -- Package_Instantiation (Node26) -- Delay_Subprogram_Descriptors (Flag50) -- Body_Needed_For_SAL (Flag40) *************** package Einfo is *** 5180,5187 **** -- Scope_Depth_Value (Uint22) -- Generic_Renamings (Elist23) (for instance) -- Inner_Instances (Elist23) (for generic proc) ! -- Privals_Chain (Elist23) (for protected proc) ! -- Abstract_Interface_Alias (Node25) -- Static_Initialization (Node26) (init_proc only) -- Overridden_Operation (Node26) -- Wrapped_Entity (Node27) (non-generic case only) --- 5276,5284 ---- -- Scope_Depth_Value (Uint22) -- Generic_Renamings (Elist23) (for instance) -- Inner_Instances (Elist23) (for generic proc) ! -- Protection_Object (Node23) (for concurrent kind) ! -- Spec_PPC_List (Node24) ! -- Interface_Alias (Node25) -- Static_Initialization (Node26) (init_proc only) -- Overridden_Operation (Node26) -- Wrapped_Entity (Node27) (non-generic case only) *************** package Einfo is *** 5190,5196 **** -- Delay_Cleanups (Flag114) -- Discard_Names (Flag88) -- Elaboration_Entity_Required (Flag174) - -- Function_Returns_With_DSP (Flag169) (false for procedure) -- Default_Expressions_Processed (Flag108) -- Delay_Cleanups (Flag114) -- Delay_Subprogram_Descriptors (Flag50) --- 5287,5292 ---- *************** package Einfo is *** 5198,5203 **** --- 5294,5300 ---- -- Has_Completion (Flag26) -- Has_Master_Entity (Flag21) -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Postconditions (Flag240) -- Has_Subprogram_Descriptor (Flag93) -- Implemented_By_Entry (Flag232) (non-generic case only) -- Is_Visible_Child_Unit (Flag116) *************** package Einfo is *** 5215,5220 **** --- 5312,5318 ---- -- Is_Primitive (Flag218) -- Is_Primitive_Wrapper (Flag195) (non-generic case only) -- Is_Private_Descendant (Flag53) + -- Is_Private_Primitive (Flag245) (non-generic case only) -- Is_Pure (Flag44) -- Is_Thunk (Flag225) -- Is_Valued_Procedure (Flag127) *************** package Einfo is *** 5227,5237 **** -- First_Formal (synth) -- First_Formal_With_Extras (synth) -- Number_Formals (synth) - -- Delay_Cleanups (Flag114) - -- Discard_Names (Flag88) -- E_Protected_Body - -- Object_Ref (Node17) -- (any others??? First/Last Entity, Scope_Depth???) -- E_Protected_Object --- 5325,5332 ---- *************** package Einfo is *** 5267,5273 **** -- Discriminant_Constraint (Elist21) -- Corresponding_Remote_Type (Node22) -- Stored_Constraint (Elist23) ! -- Abstract_Interfaces (Elist25) -- Component_Alignment (special) (base type only) -- C_Pass_By_Copy (Flag125) (base type only) -- Has_Dispatch_Table (Flag220) (base tagged type only) --- 5362,5368 ---- -- Discriminant_Constraint (Elist21) -- Corresponding_Remote_Type (Node22) -- Stored_Constraint (Elist23) ! -- Interfaces (Elist25) -- Component_Alignment (special) (base type only) -- C_Pass_By_Copy (Flag125) (base type only) -- Has_Dispatch_Table (Flag220) (base tagged type only) *************** package Einfo is *** 5280,5285 **** --- 5375,5381 ---- -- Is_Controlled (Flag42) (base type only) -- Is_Interface (Flag186) -- Is_Limited_Interface (Flag197) + -- OK_To_Reorder_Components (Flag239) (base type only) -- Reverse_Bit_Order (Flag164) (base type only) -- First_Component (synth) -- First_Component_Or_Discriminant (synth) *************** package Einfo is *** 5300,5306 **** -- Discriminant_Constraint (Elist21) -- Private_View (Node22) -- Stored_Constraint (Elist23) ! -- Abstract_Interfaces (Elist25) -- Has_Completion (Flag26) -- Has_Record_Rep_Clause (Flag65) (base type only) -- Has_External_Tag_Rep_Clause (Flag110) --- 5396,5402 ---- -- Discriminant_Constraint (Elist21) -- Private_View (Node22) -- Stored_Constraint (Elist23) ! -- Interfaces (Elist25) -- Has_Completion (Flag26) -- Has_Record_Rep_Clause (Flag65) (base type only) -- Has_External_Tag_Rep_Clause (Flag110) *************** package Einfo is *** 5309,5314 **** --- 5405,5411 ---- -- Is_Controlled (Flag42) (base type only) -- Is_Interface (Flag186) -- Is_Limited_Interface (Flag197) + -- OK_To_Reorder_Components (Flag239) (base type only) -- Reverse_Bit_Order (Flag164) (base type only) -- First_Component (synth) -- First_Component_Or_Discriminant (synth) *************** package Einfo is *** 5357,5363 **** -- First_Formal (synth) -- First_Formal_With_Extras (synth) -- Number_Formals (synth) - -- Function_Returns_With_DSP (Flag169) -- (plus type attributes) -- E_Task_Body --- 5454,5459 ---- *************** package Einfo is *** 5383,5388 **** --- 5479,5485 ---- -- Sec_Stack_Needed_For_Return (Flag167) ??? -- Has_Entries (synth) -- Number_Entries (synth) + -- Relative_Deadline_Variable (Node26) (base type only) -- (plus type attributes) -- E_Variable *************** package Einfo is *** 5391,5403 **** -- Esize (Uint12) -- Extra_Accessibility (Node13) -- Alignment (Uint14) - -- Shared_Var_Read_Proc (Node15) -- Unset_Reference (Node16) -- Actual_Subtype (Node17) -- Renamed_Object (Node18) -- Size_Check_Code (Node19) -- Interface_Name (Node21) ! -- Shared_Var_Assign_Proc (Node22) -- Extra_Constrained (Node23) -- Debug_Renaming_Link (Node25) -- Last_Assignment (Node26) --- 5488,5500 ---- -- Esize (Uint12) -- Extra_Accessibility (Node13) -- Alignment (Uint14) -- Unset_Reference (Node16) -- Actual_Subtype (Node17) -- Renamed_Object (Node18) -- Size_Check_Code (Node19) + -- Prival_Link (Node20) -- Interface_Name (Node21) ! -- Shared_Var_Procs_Instance (Node22) -- Extra_Constrained (Node23) -- Debug_Renaming_Link (Node25) -- Last_Assignment (Node26) *************** package Einfo is *** 5406,5420 **** -- Has_Biased_Representation (Flag139) -- Has_Initial_Value (Flag219) -- Has_Size_Clause (Flag29) -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) -- Is_Shared_Passive (Flag60) -- Is_True_Constant (Flag163) -- Is_Volatile (Flag16) - -- Treat_As_Volatile (Flag41) -- Is_Return_Object (Flag209) ! -- Has_Up_Level_Access (Flag215) -- Address_Clause (synth) -- Alignment_Clause (synth) -- Constant_Value (synth) --- 5503,5519 ---- -- Has_Biased_Representation (Flag139) -- Has_Initial_Value (Flag219) -- Has_Size_Clause (Flag29) + -- Has_Up_Level_Access (Flag215) -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) -- Is_Shared_Passive (Flag60) -- Is_True_Constant (Flag163) -- Is_Volatile (Flag16) -- Is_Return_Object (Flag209) ! -- Optimize_Alignment_Space (Flag241) ! -- Optimize_Alignment_Time (Flag242) ! -- Treat_As_Volatile (Flag41) -- Address_Clause (synth) -- Alignment_Clause (synth) -- Constant_Value (synth) *************** package Einfo is *** 5442,5448 **** -- There are four types of alignment possible for array and record -- types, and a field in the type entities contains a value of the -- following type indicating which alignment choice applies. For full ! -- details of the meaning of these aligment types, see description -- of the Component_Alignment pragma type Component_Alignment_Kind is ( --- 5541,5547 ---- -- There are four types of alignment possible for array and record -- types, and a field in the type entities contains a value of the -- following type indicating which alignment choice applies. For full ! -- details of the meaning of these alignment types, see description -- of the Component_Alignment pragma type Component_Alignment_Kind is ( *************** package Einfo is *** 5507,5515 **** -- general manner, like any other variables: -- In initialization expressions for records. Note that the expressions ! -- used in Priority, Storage_Size, and Task_Info pragmas are effectively ! -- in this category, since these pragmas are converted to initialized ! -- record fields in the Corresponding_Record_Type. -- In task and protected bodies, where the discriminant values may be -- referenced freely within these bodies. Discriminants can also appear --- 5606,5615 ---- -- general manner, like any other variables: -- In initialization expressions for records. Note that the expressions ! -- used in Priority, Storage_Size, Task_Info and Relative_Deadline ! -- pragmas are effectively in this category, since these pragmas are ! -- converted to initialized record fields in the Corresponding_Record_ ! -- Type. -- In task and protected bodies, where the discriminant values may be -- referenced freely within these bodies. Discriminants can also appear *************** package Einfo is *** 5519,5530 **** -- objects. The following approach is used to simplify and minimize the -- special processing that is required. ! -- When a record type with discriminants is processed, the semantic ! -- processing creates the entities for the discriminants. It also creates ! -- an additional set of entities, called discriminals, one for each of ! -- the discriminants, and the Discriminal field of the discriminant entity ! -- points to this additional entity, which is initially created as an ! -- uninitialized (E_Void) entity. -- During expansion of expressions, any discriminant reference is replaced -- by a reference to the corresponding discriminal. When the initialization --- 5619,5630 ---- -- objects. The following approach is used to simplify and minimize the -- special processing that is required. ! -- When a record type with discriminants is analyzed, semantic processing ! -- creates the entities for the discriminants. It also creates additional ! -- sets of entities called discriminals, one for each of the discriminants, ! -- and the Discriminal field of the discriminant entity points to this ! -- additional entity, which is initially created as an uninitialized ! -- (E_Void) entity. -- During expansion of expressions, any discriminant reference is replaced -- by a reference to the corresponding discriminal. When the initialization *************** package Einfo is *** 5535,5551 **** -- have already been replaced by references to these discriminals, which -- are now the formal parameters corresponding to the required objects. ! -- In the case of a task or protected body, the semantics similarly ! -- creates a set of discriminals for the discriminants of the task or ! -- protected type. When the procedure is created for the task body, ! -- the parameter passed in is a reference to the task value type, which ! -- contains the required discriminant values. The expander creates a ! -- set of declarations of the form: ! -- discriminal : constant dtype renames _Task.discriminant; ! -- where discriminal is the discriminal entity referenced by the task ! -- discriminant, and _Task is the task value passed in as the parameter. -- Again, any references to discriminants in the task body have been -- replaced by the discriminal reference, which is now an object that -- contains the required value. --- 5635,5651 ---- -- have already been replaced by references to these discriminals, which -- are now the formal parameters corresponding to the required objects. ! -- In the case of a task or protected body, the semantics similarly creates ! -- a set of discriminals for the discriminants of the task or protected ! -- type. When the procedure is created for the task body, the parameter ! -- passed in is a reference to the task value type, which contains the ! -- required discriminant values. The expander creates a set of declarations ! -- of the form: ! -- discr_nameD : constant discr_type renames _task.discr_name; ! -- where discr_nameD is the discriminal entity referenced by the task ! -- discriminant, and _task is the task value passed in as the parameter. -- Again, any references to discriminants in the task body have been -- replaced by the discriminal reference, which is now an object that -- contains the required value. *************** package Einfo is *** 5558,5572 **** -- The one bit of trickiness arises in making sure that the right set of -- discriminals is used at the right time. First the task definition is -- processed. Any references to discriminants here are replaced by the ! -- the corresponding *task* discriminals (the record type doesn't even ! -- exist yet, since it is constructed as part of the expansion of the ! -- task declaration, which happens after the semantic processing of the ! -- task definition). The discriminants to be used for the corresponding ! -- record are created at the same time as the other discriminals, and ! -- held in the CR_Discriminant field of the discriminant. A use of the ! -- discriminant in a bound for an entry family is replaced with the CR_ ! -- discriminant because it controls the bound of the entry queue array ! -- which is a component of the corresponding record. -- Just before the record initialization routine is constructed, the -- expander exchanges the task and record discriminals. This has two --- 5658,5672 ---- -- The one bit of trickiness arises in making sure that the right set of -- discriminals is used at the right time. First the task definition is -- processed. Any references to discriminants here are replaced by the ! -- corresponding *task* discriminals (the record type doesn't even exist ! -- yet, since it is constructed as part of the expansion of the task ! -- declaration, which happens after the semantic processing of the task ! -- definition). The discriminants to be used for the corresponding record ! -- are created at the same time as the other discriminals, and held in the ! -- CR_Discriminant field of the discriminant. A use of the discriminant in ! -- a bound for an entry family is replaced with the CR_Discriminant because ! -- it controls the bound of the entry queue array which is a component of ! -- the corresponding record. -- Just before the record initialization routine is constructed, the -- expander exchanges the task and record discriminals. This has two *************** package Einfo is *** 5579,5635 **** -- task body, and also for the discriminal declarations at the start of -- the task body. ! --------------------------------------- ! -- Private data in protected objects -- ! --------------------------------------- ! -- Private object declarations in protected types pose problems ! -- similar to those of discriminants. They are expanded to components ! -- of a record which is passed as the parameter "_object" to expanded ! -- forms of all protected operations. As with discriminants, timing ! -- of this expansion is a problem. The sequence of statements for a ! -- protected operation is expanded before the operation itself, so the ! -- formal parameter for the record object containing the private data ! -- does not exist when the references to that data are expanded. ! -- For this reason, private data is handled in the same way as ! -- discriminants, expanding references to private data in protected ! -- operations (which appear as components) to placeholders which will ! -- eventually become renamings of the private selected components ! -- of the "_object" formal parameter. These placeholders are called ! -- "privals", by analogy to the "discriminals" used to implement ! -- discriminants. They are attached to the component declaration nodes ! -- representing the private object declarations of the protected type. ! -- As with discriminals, each protected subprogram needs a unique set ! -- of privals, since they must refer to renamings of components of a ! -- formal parameter of that operation. Entry bodies need another set, ! -- which they all share and which is associated with renamings in the ! -- Service_Entries procedure for the protected type (this is not yet ! -- implemented???). This means that we must associate a new set of ! -- privals (and discriminals) with the private declarations after ! -- the body of a protected subprogram is processed. ! -- The last complication is the presence of discriminants and discriminated ! -- components. In the corresponding record, the components are constrained ! -- by the discriminants of the record, but within each protected operation ! -- they are constrained by the discriminants of the actual. The actual ! -- subtypes of those components are constructed as for other unconstrained ! -- formals, but the privals are created before the formal object is added ! -- to the parameter list of the protected operation, so they carry the ! -- nominal subtype of the original component. After the protected operation ! -- is actually created (in the expansion of the protected body) we must ! -- patch the types of each prival occurrence with the proper actual subtype ! -- which is by now set. The Privals_Chain is used for this patching. ------------------- -- Type Synonyms -- ------------------- -- The following type synonyms are used to tidy up the function and ! -- procedure declarations that follow, and also to make it possible ! -- to meet the requirement for the XEINFO utility that all function ! -- specs must fit on a single source line. subtype B is Boolean; subtype C is Component_Alignment_Kind; --- 5679,5730 ---- -- task body, and also for the discriminal declarations at the start of -- the task body. ! --------------------------------------------------- ! -- Handling of private data in protected objects -- ! --------------------------------------------------- ! -- Private components in protected types pose problems similar to those ! -- of discriminants. Private data is visible and can be directly referenced ! -- from protected bodies. However, when protected entries and subprograms ! -- are expanded into corresponding bodies and barrier functions, private ! -- components lose their original context and visibility. ! -- To remedy this side effect of expansion, private components are expanded ! -- into renamings called "privals", by analogy with "discriminals". ! -- private_comp : comp_type renames _object.private_comp; ! -- Prival declarations are inserted during the analysis of subprogram and ! -- entry bodies to ensure proper visibility for any subsequent expansion. ! -- _Object is the formal parameter of the generated corresponding body or ! -- a local renaming which denotes the protected object obtained from entry ! -- parameter _O. Privals receive minimal decoration upon creation and are ! -- categorized as either E_Variable for the general case or E_Constant when ! -- they appear in functions. ! ! -- Along with the local declarations, each private component carries a ! -- placeholder which references the prival entity in the current body. This ! -- form of indirection is used to resolve name clashes of privals and other ! -- locally visible entities such as parameters, local objects, entry family ! -- indexes or identifiers used in the barrier condition. ! ! -- When analyzing the statements of a protected subprogram or entry, any ! -- reference to a private component must resolve to the locally declared ! -- prival through normal visibility. In case of name conflicts (the cases ! -- above), the prival is marked as hidden and acts as a weakly declared ! -- entity. As a result, the reference points to the correct entity. When a ! -- private component is denoted by an expanded name (prot_type.comp for ! -- example), the expansion mechanism uses the placeholder of the component ! -- to correct the Entity and Etype of the reference. ------------------- -- Type Synonyms -- ------------------- -- The following type synonyms are used to tidy up the function and ! -- procedure declarations that follow, and also to make it possible to meet ! -- the requirement for the XEINFO utility that all function specs must fit ! -- on a single source line. subtype B is Boolean; subtype C is Component_Alignment_Kind; *************** package Einfo is *** 5649,5661 **** -- section contains the functions used to obtain attribute values which -- correspond to values in fields or flags in the entity itself. - function Abstract_Interfaces (Id : E) return L; function Accept_Address (Id : E) return L; function Access_Disp_Table (Id : E) return L; function Actual_Subtype (Id : E) return E; function Address_Taken (Id : E) return B; function Alias (Id : E) return E; - function Abstract_Interface_Alias (Id : E) return E; function Alignment (Id : E) return U; function Associated_Final_Chain (Id : E) return E; function Associated_Formal_Package (Id : E) return E; --- 5744,5754 ---- *************** package Einfo is *** 5742,5748 **** function Freeze_Node (Id : E) return N; function From_With_Type (Id : E) return B; function Full_View (Id : E) return E; - function Function_Returns_With_DSP (Id : E) return B; function Generic_Homonym (Id : E) return E; function Generic_Renamings (Id : E) return L; function Handler_Records (Id : E) return S; --- 5835,5840 ---- *************** package Einfo is *** 5782,5787 **** --- 5874,5880 ---- function Has_Object_Size_Clause (Id : E) return B; function Has_Per_Object_Constraint (Id : E) return B; function Has_Persistent_BSS (Id : E) return B; + function Has_Postconditions (Id : E) return B; function Has_Pragma_Controlled (Id : E) return B; function Has_Pragma_Elaborate_Body (Id : E) return B; function Has_Pragma_Inline (Id : E) return B; *************** package Einfo is *** 5822,5827 **** --- 5915,5922 ---- function In_Private_Part (Id : E) return B; function In_Use (Id : E) return B; function Inner_Instances (Id : E) return L; + function Interfaces (Id : E) return L; + function Interface_Alias (Id : E) return E; function Interface_Name (Id : E) return N; function Is_AST_Entry (Id : E) return B; function Is_Abstract_Subprogram (Id : E) return B; *************** package Einfo is *** 5846,5851 **** --- 5941,5947 ---- function Is_Controlled (Id : E) return B; function Is_Controlling_Formal (Id : E) return B; function Is_Discrim_SO_Function (Id : E) return B; + function Is_Dispatch_Table_Entity (Id : E) return B; function Is_Dispatching_Operation (Id : E) return B; function Is_Eliminated (Id : E) return B; function Is_Entry_Formal (Id : E) return B; *************** package Einfo is *** 5886,5895 **** --- 5982,5993 ---- function Is_Primitive_Wrapper (Id : E) return B; function Is_Private_Composite (Id : E) return B; function Is_Private_Descendant (Id : E) return B; + function Is_Private_Primitive (Id : E) return B; function Is_Protected_Interface (Id : E) return B; function Is_Public (Id : E) return B; function Is_Pure (Id : E) return B; function Is_Pure_Unit_Access_Type (Id : E) return B; + function Is_RACW_Stub_Type (Id : E) return B; function Is_Raised (Id : E) return B; function Is_Remote_Call_Interface (Id : E) return B; function Is_Remote_Types (Id : E) return B; *************** package Einfo is *** 5902,5907 **** --- 6000,6006 ---- function Is_Tagged_Type (Id : E) return B; function Is_Task_Interface (Id : E) return B; function Is_Thunk (Id : E) return B; + function Is_Trivial_Subprogram (Id : E) return B; function Is_True_Constant (Id : E) return B; function Is_Unchecked_Union (Id : E) return B; function Is_Unsigned_Type (Id : E) return B; *************** package Einfo is *** 5941,5962 **** function Normalized_First_Bit (Id : E) return U; function Normalized_Position (Id : E) return U; function Normalized_Position_Max (Id : E) return U; ! function Object_Ref (Id : E) return E; ! function Obsolescent_Warning (Id : E) return N; function Original_Array_Type (Id : E) return E; function Original_Record_Component (Id : E) return E; function Overridden_Operation (Id : E) return E; function Package_Instantiation (Id : E) return N; function Packed_Array_Type (Id : E) return E; function Parent_Subtype (Id : E) return E; function Primitive_Operations (Id : E) return L; function Prival (Id : E) return E; ! function Privals_Chain (Id : E) return L; function Private_Dependents (Id : E) return L; function Private_View (Id : E) return N; function Protected_Body_Subprogram (Id : E) return E; function Protected_Formal (Id : E) return E; ! function Protected_Operation (Id : E) return E; function RM_Size (Id : E) return U; function Reachable (Id : E) return B; function Referenced (Id : E) return B; --- 6040,6063 ---- function Normalized_First_Bit (Id : E) return U; function Normalized_Position (Id : E) return U; function Normalized_Position_Max (Id : E) return U; ! function OK_To_Reorder_Components (Id : E) return B; ! function Optimize_Alignment_Space (Id : E) return B; ! function Optimize_Alignment_Time (Id : E) return B; function Original_Array_Type (Id : E) return E; function Original_Record_Component (Id : E) return E; + function Overlays_Constant (Id : E) return B; function Overridden_Operation (Id : E) return E; function Package_Instantiation (Id : E) return N; function Packed_Array_Type (Id : E) return E; function Parent_Subtype (Id : E) return E; function Primitive_Operations (Id : E) return L; function Prival (Id : E) return E; ! function Prival_Link (Id : E) return E; function Private_Dependents (Id : E) return L; function Private_View (Id : E) return N; function Protected_Body_Subprogram (Id : E) return E; function Protected_Formal (Id : E) return E; ! function Protection_Object (Id : E) return E; function RM_Size (Id : E) return U; function Reachable (Id : E) return B; function Referenced (Id : E) return B; *************** package Einfo is *** 5967,5972 **** --- 6068,6074 ---- function Related_Array_Object (Id : E) return E; function Related_Instance (Id : E) return E; function Related_Type (Id : E) return E; + function Relative_Deadline_Variable (Id : E) return E; function Renamed_Entity (Id : E) return N; function Renamed_In_Spec (Id : E) return B; function Renamed_Object (Id : E) return N; *************** package Einfo is *** 5981,5993 **** function Scope_Depth_Value (Id : E) return U; function Sec_Stack_Needed_For_Return (Id : E) return B; function Shadow_Entities (Id : E) return S; ! function Shared_Var_Assign_Proc (Id : E) return E; ! function Shared_Var_Read_Proc (Id : E) return E; function Size_Check_Code (Id : E) return N; function Size_Known_At_Compile_Time (Id : E) return B; function Size_Depends_On_Discriminant (Id : E) return B; function Small_Value (Id : E) return R; function Spec_Entity (Id : E) return E; function Storage_Size_Variable (Id : E) return E; function Static_Elaboration_Desired (Id : E) return B; function Static_Initialization (Id : E) return N; --- 6083,6095 ---- function Scope_Depth_Value (Id : E) return U; function Sec_Stack_Needed_For_Return (Id : E) return B; function Shadow_Entities (Id : E) return S; ! function Shared_Var_Procs_Instance (Id : E) return E; function Size_Check_Code (Id : E) return N; function Size_Known_At_Compile_Time (Id : E) return B; function Size_Depends_On_Discriminant (Id : E) return B; function Small_Value (Id : E) return R; function Spec_Entity (Id : E) return E; + function Spec_PPC_List (Id : E) return N; function Storage_Size_Variable (Id : E) return E; function Static_Elaboration_Desired (Id : E) return B; function Static_Initialization (Id : E) return N; *************** package Einfo is *** 6008,6013 **** --- 6110,6118 ---- function Uses_Sec_Stack (Id : E) return B; function Vax_Float (Id : E) return B; function Warnings_Off (Id : E) return B; + function Warnings_Off_Used (Id : E) return B; + function Warnings_Off_Used_Unmodified (Id : E) return B; + function Warnings_Off_Used_Unreferenced (Id : E) return B; function Was_Hidden (Id : E) return B; function Wrapped_Entity (Id : E) return E; *************** package Einfo is *** 6023,6028 **** --- 6128,6134 ---- function Is_Access_Type (Id : E) return B; function Is_Access_Protected_Subprogram_Type (Id : E) return B; + function Is_Access_Subprogram_Type (Id : E) return B; function Is_Array_Type (Id : E) return B; function Is_Assignable (Id : E) return B; function Is_Class_Wide_Type (Id : E) return B; *************** package Einfo is *** 6100,6113 **** function Is_Boolean_Type (Id : E) return B; function Is_By_Copy_Type (Id : E) return B; function Is_By_Reference_Type (Id : E) return B; function Is_Derived_Type (Id : E) return B; function Is_Dynamic_Scope (Id : E) return B; function Is_Indefinite_Subtype (Id : E) return B; function Is_Limited_Type (Id : E) return B; function Is_Package_Or_Generic_Package (Id : E) return B; ! function Is_Protected_Private (Id : E) return B; function Is_Protected_Record_Type (Id : E) return B; function Is_Inherently_Limited_Type (Id : E) return B; function Is_String_Type (Id : E) return B; function Is_Task_Record_Type (Id : E) return B; function Is_Wrapper_Package (Id : E) return B; --- 6206,6223 ---- function Is_Boolean_Type (Id : E) return B; function Is_By_Copy_Type (Id : E) return B; function Is_By_Reference_Type (Id : E) return B; + function Is_Constant_Object (Id : E) return B; function Is_Derived_Type (Id : E) return B; + function Is_Discriminal (Id : E) return B; function Is_Dynamic_Scope (Id : E) return B; function Is_Indefinite_Subtype (Id : E) return B; function Is_Limited_Type (Id : E) return B; function Is_Package_Or_Generic_Package (Id : E) return B; ! function Is_Prival (Id : E) return B; ! function Is_Protected_Component (Id : E) return B; function Is_Protected_Record_Type (Id : E) return B; function Is_Inherently_Limited_Type (Id : E) return B; + function Is_Standard_Character_Type (Id : E) return B; function Is_String_Type (Id : E) return B; function Is_Task_Record_Type (Id : E) return B; function Is_Wrapper_Package (Id : E) return B; *************** package Einfo is *** 6193,6206 **** -- Attribute Set Procedures -- ------------------------------ - procedure Set_Abstract_Interfaces (Id : E; V : L); procedure Set_Accept_Address (Id : E; V : L); procedure Set_Access_Disp_Table (Id : E; V : L); procedure Set_Dispatch_Table_Wrapper (Id : E; V : E); procedure Set_Actual_Subtype (Id : E; V : E); procedure Set_Address_Taken (Id : E; V : B := True); procedure Set_Alias (Id : E; V : E); - procedure Set_Abstract_Interface_Alias (Id : E; V : E); procedure Set_Alignment (Id : E; V : U); procedure Set_Associated_Final_Chain (Id : E; V : E); procedure Set_Associated_Formal_Package (Id : E; V : E); --- 6303,6314 ---- *************** package Einfo is *** 6285,6291 **** procedure Set_Freeze_Node (Id : E; V : N); procedure Set_From_With_Type (Id : E; V : B := True); procedure Set_Full_View (Id : E; V : E); - procedure Set_Function_Returns_With_DSP (Id : E; V : B := True); procedure Set_Generic_Homonym (Id : E; V : E); procedure Set_Generic_Renamings (Id : E; V : L); procedure Set_Handler_Records (Id : E; V : S); --- 6393,6398 ---- *************** package Einfo is *** 6324,6329 **** --- 6431,6437 ---- procedure Set_Has_Object_Size_Clause (Id : E; V : B := True); procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True); procedure Set_Has_Persistent_BSS (Id : E; V : B := True); + procedure Set_Has_Postconditions (Id : E; V : B := True); procedure Set_Has_Pragma_Controlled (Id : E; V : B := True); procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True); procedure Set_Has_Pragma_Inline (Id : E; V : B := True); *************** package Einfo is *** 6361,6370 **** --- 6469,6480 ---- procedure Set_Hiding_Loop_Variable (Id : E; V : E); procedure Set_Homonym (Id : E; V : E); procedure Set_Implemented_By_Entry (Id : E; V : B := True); + procedure Set_Interfaces (Id : E; V : L); procedure Set_In_Package_Body (Id : E; V : B := True); procedure Set_In_Private_Part (Id : E; V : B := True); procedure Set_In_Use (Id : E; V : B := True); procedure Set_Inner_Instances (Id : E; V : L); + procedure Set_Interface_Alias (Id : E; V : E); procedure Set_Interface_Name (Id : E; V : N); procedure Set_Is_AST_Entry (Id : E; V : B := True); procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True); *************** package Einfo is *** 6391,6396 **** --- 6501,6507 ---- procedure Set_Is_Controlling_Formal (Id : E; V : B := True); procedure Set_Is_Descendent_Of_Address (Id : E; V : B := True); procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True); + procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True); procedure Set_Is_Dispatching_Operation (Id : E; V : B := True); procedure Set_Is_Eliminated (Id : E; V : B := True); procedure Set_Is_Entry_Formal (Id : E; V : B := True); *************** package Einfo is *** 6436,6445 **** --- 6547,6558 ---- procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True); procedure Set_Is_Private_Composite (Id : E; V : B := True); procedure Set_Is_Private_Descendant (Id : E; V : B := True); + procedure Set_Is_Private_Primitive (Id : E; V : B := True); procedure Set_Is_Protected_Interface (Id : E; V : B := True); procedure Set_Is_Public (Id : E; V : B := True); procedure Set_Is_Pure (Id : E; V : B := True); procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True); + procedure Set_Is_RACW_Stub_Type (Id : E; V : B := True); procedure Set_Is_Raised (Id : E; V : B := True); procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True); procedure Set_Is_Remote_Types (Id : E; V : B := True); *************** package Einfo is *** 6452,6457 **** --- 6565,6571 ---- procedure Set_Is_Tagged_Type (Id : E; V : B := True); procedure Set_Is_Task_Interface (Id : E; V : B := True); procedure Set_Is_Thunk (Id : E; V : B := True); + procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True); procedure Set_Is_True_Constant (Id : E; V : B := True); procedure Set_Is_Unchecked_Union (Id : E; V : B := True); procedure Set_Is_Unsigned_Type (Id : E; V : B := True); *************** package Einfo is *** 6491,6512 **** procedure Set_Normalized_First_Bit (Id : E; V : U); procedure Set_Normalized_Position (Id : E; V : U); procedure Set_Normalized_Position_Max (Id : E; V : U); ! procedure Set_Object_Ref (Id : E; V : E); ! procedure Set_Obsolescent_Warning (Id : E; V : N); procedure Set_Original_Array_Type (Id : E; V : E); procedure Set_Original_Record_Component (Id : E; V : E); procedure Set_Overridden_Operation (Id : E; V : E); procedure Set_Package_Instantiation (Id : E; V : N); procedure Set_Packed_Array_Type (Id : E; V : E); procedure Set_Parent_Subtype (Id : E; V : E); procedure Set_Primitive_Operations (Id : E; V : L); procedure Set_Prival (Id : E; V : E); ! procedure Set_Privals_Chain (Id : E; V : L); procedure Set_Private_Dependents (Id : E; V : L); procedure Set_Private_View (Id : E; V : N); procedure Set_Protected_Body_Subprogram (Id : E; V : E); procedure Set_Protected_Formal (Id : E; V : E); ! procedure Set_Protected_Operation (Id : E; V : N); procedure Set_RM_Size (Id : E; V : U); procedure Set_Reachable (Id : E; V : B := True); procedure Set_Referenced (Id : E; V : B := True); --- 6605,6628 ---- procedure Set_Normalized_First_Bit (Id : E; V : U); procedure Set_Normalized_Position (Id : E; V : U); procedure Set_Normalized_Position_Max (Id : E; V : U); ! procedure Set_OK_To_Reorder_Components (Id : E; V : B := True); ! procedure Set_Optimize_Alignment_Space (Id : E; V : B := True); ! procedure Set_Optimize_Alignment_Time (Id : E; V : B := True); procedure Set_Original_Array_Type (Id : E; V : E); procedure Set_Original_Record_Component (Id : E; V : E); + procedure Set_Overlays_Constant (Id : E; V : B := True); procedure Set_Overridden_Operation (Id : E; V : E); procedure Set_Package_Instantiation (Id : E; V : N); procedure Set_Packed_Array_Type (Id : E; V : E); procedure Set_Parent_Subtype (Id : E; V : E); procedure Set_Primitive_Operations (Id : E; V : L); procedure Set_Prival (Id : E; V : E); ! procedure Set_Prival_Link (Id : E; V : E); procedure Set_Private_Dependents (Id : E; V : L); procedure Set_Private_View (Id : E; V : N); procedure Set_Protected_Body_Subprogram (Id : E; V : E); procedure Set_Protected_Formal (Id : E; V : E); ! procedure Set_Protection_Object (Id : E; V : E); procedure Set_RM_Size (Id : E; V : U); procedure Set_Reachable (Id : E; V : B := True); procedure Set_Referenced (Id : E; V : B := True); *************** package Einfo is *** 6517,6522 **** --- 6633,6639 ---- procedure Set_Related_Array_Object (Id : E; V : E); procedure Set_Related_Instance (Id : E; V : E); procedure Set_Related_Type (Id : E; V : E); + procedure Set_Relative_Deadline_Variable (Id : E; V : E); procedure Set_Renamed_Entity (Id : E; V : N); procedure Set_Renamed_In_Spec (Id : E; V : B := True); procedure Set_Renamed_Object (Id : E; V : N); *************** package Einfo is *** 6531,6543 **** procedure Set_Scope_Depth_Value (Id : E; V : U); procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True); procedure Set_Shadow_Entities (Id : E; V : S); ! procedure Set_Shared_Var_Assign_Proc (Id : E; V : E); ! procedure Set_Shared_Var_Read_Proc (Id : E; V : E); procedure Set_Size_Check_Code (Id : E; V : N); procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True); procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True); procedure Set_Small_Value (Id : E; V : R); procedure Set_Spec_Entity (Id : E; V : E); procedure Set_Storage_Size_Variable (Id : E; V : E); procedure Set_Static_Elaboration_Desired (Id : E; V : B); procedure Set_Static_Initialization (Id : E; V : N); --- 6648,6660 ---- procedure Set_Scope_Depth_Value (Id : E; V : U); procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True); procedure Set_Shadow_Entities (Id : E; V : S); ! procedure Set_Shared_Var_Procs_Instance (Id : E; V : E); procedure Set_Size_Check_Code (Id : E; V : N); procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True); procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True); procedure Set_Small_Value (Id : E; V : R); procedure Set_Spec_Entity (Id : E; V : E); + procedure Set_Spec_PPC_List (Id : E; V : N); procedure Set_Storage_Size_Variable (Id : E; V : E); procedure Set_Static_Elaboration_Desired (Id : E; V : B); procedure Set_Static_Initialization (Id : E; V : N); *************** package Einfo is *** 6558,6563 **** --- 6675,6683 ---- procedure Set_Uses_Sec_Stack (Id : E; V : B := True); procedure Set_Vax_Float (Id : E; V : B := True); procedure Set_Warnings_Off (Id : E; V : B := True); + procedure Set_Warnings_Off_Used (Id : E; V : B := True); + procedure Set_Warnings_Off_Used_Unmodified (Id : E; V : B := True); + procedure Set_Warnings_Off_Used_Unreferenced (Id : E; V : B := True); procedure Set_Was_Hidden (Id : E; V : B := True); procedure Set_Wrapped_Entity (Id : E; V : E); *************** package Einfo is *** 6678,6683 **** --- 6798,6830 ---- procedure Next_Stored_Discriminant (N : in out Node_Id) renames Proc_Next_Stored_Discriminant; + --------------------------- + -- Testing Warning Flags -- + --------------------------- + + -- These routines are to be used rather than testing flags Warnings_Off, + -- Has_Pragma_Unmodified, Has_Pragma_Unreferenced. They deal with setting + -- the flags Warnings_Off_Used[_Unmodified|Unreferenced] for later access. + + function Has_Warnings_Off (E : Entity_Id) return Boolean; + -- If Warnings_Off is set on E, then returns True and also sets the flag + -- Warnings_Off_Used on E. If Warnings_Off is not set on E, returns False + -- and has no side effect. + + function Has_Unmodified (E : Entity_Id) return Boolean; + -- If flag Has_Pragma_Unmodified is set on E, returns True with no side + -- effects. Otherwise if Warnings_Off is set on E, returns True and also + -- sets the flag Warnings_Off_Used_Unmodified on E. If neither of the flags + -- Warnings_Off nor Has_Pragma_Unmodified is set, returns False with no + -- side effects. + + function Has_Unreferenced (E : Entity_Id) return Boolean; + -- If flag Has_Pragma_Unreferenced is set on E, returns True with no side + -- effects. Otherwise if Warnings_Off is set on E, returns True and also + -- sets the flag Warnings_Off_Used_Unreferenced on E. If neither of the + -- flags Warnings_Off nor Has_Pragma_Unreferenced is set, returns False + -- with no side effects. + ---------------------------------------------- -- Subprograms for Accessing Rep Item Chain -- ---------------------------------------------- *************** package Einfo is *** 6805,6816 **** -- subprograms meeting the requirements documented in the section on -- XEINFO may be referenced in this section. - pragma Inline (Abstract_Interfaces); pragma Inline (Accept_Address); pragma Inline (Access_Disp_Table); pragma Inline (Actual_Subtype); pragma Inline (Address_Taken); - pragma Inline (Abstract_Interface_Alias); pragma Inline (Alias); pragma Inline (Alignment); pragma Inline (Associated_Final_Chain); --- 6952,6961 ---- *************** package Einfo is *** 6896,6902 **** pragma Inline (Freeze_Node); pragma Inline (From_With_Type); pragma Inline (Full_View); - pragma Inline (Function_Returns_With_DSP); pragma Inline (Generic_Homonym); pragma Inline (Generic_Renamings); pragma Inline (Handler_Records); --- 7041,7046 ---- *************** package Einfo is *** 6934,6939 **** --- 7078,7084 ---- pragma Inline (Has_Object_Size_Clause); pragma Inline (Has_Per_Object_Constraint); pragma Inline (Has_Persistent_BSS); + pragma Inline (Has_Postconditions); pragma Inline (Has_Pragma_Controlled); pragma Inline (Has_Pragma_Elaborate_Body); pragma Inline (Has_Pragma_Inline); *************** package Einfo is *** 6972,6981 **** --- 7117,7128 ---- pragma Inline (Hiding_Loop_Variable); pragma Inline (Homonym); pragma Inline (Implemented_By_Entry); + pragma Inline (Interfaces); pragma Inline (In_Package_Body); pragma Inline (In_Private_Part); pragma Inline (In_Use); pragma Inline (Inner_Instances); + pragma Inline (Interface_Alias); pragma Inline (Interface_Name); pragma Inline (Is_AST_Entry); pragma Inline (Is_Abstract_Subprogram); *************** package Einfo is *** 6984,6989 **** --- 7131,7137 ---- pragma Inline (Is_Ada_2005_Only); pragma Inline (Is_Access_Type); pragma Inline (Is_Access_Protected_Subprogram_Type); + pragma Inline (Is_Access_Subprogram_Type); pragma Inline (Is_Aliased); pragma Inline (Is_Array_Type); pragma Inline (Is_Assignable); *************** package Einfo is *** 7014,7019 **** --- 7162,7168 ---- pragma Inline (Is_Descendent_Of_Address); pragma Inline (Is_Discrete_Or_Fixed_Point_Type); pragma Inline (Is_Discrete_Type); + pragma Inline (Is_Dispatch_Table_Entity); pragma Inline (Is_Dispatching_Operation); pragma Inline (Is_Elementary_Type); pragma Inline (Is_Eliminated); *************** package Einfo is *** 7077,7088 **** --- 7226,7239 ---- pragma Inline (Is_Primitive_Wrapper); pragma Inline (Is_Private_Composite); pragma Inline (Is_Private_Descendant); + pragma Inline (Is_Private_Primitive); pragma Inline (Is_Private_Type); pragma Inline (Is_Protected_Interface); pragma Inline (Is_Protected_Type); pragma Inline (Is_Public); pragma Inline (Is_Pure); pragma Inline (Is_Pure_Unit_Access_Type); + pragma Inline (Is_RACW_Stub_Type); pragma Inline (Is_Raised); pragma Inline (Is_Real_Type); pragma Inline (Is_Record_Type); *************** package Einfo is *** 7102,7107 **** --- 7253,7259 ---- pragma Inline (Is_True_Constant); pragma Inline (Is_Task_Type); pragma Inline (Is_Thunk); + pragma Inline (Is_Trivial_Subprogram); pragma Inline (Is_Type); pragma Inline (Is_Unchecked_Union); pragma Inline (Is_Unsigned_Type); *************** package Einfo is *** 7142,7151 **** pragma Inline (Normalized_First_Bit); pragma Inline (Normalized_Position); pragma Inline (Normalized_Position_Max); ! pragma Inline (Object_Ref); ! pragma Inline (Obsolescent_Warning); pragma Inline (Original_Array_Type); pragma Inline (Original_Record_Component); pragma Inline (Overridden_Operation); pragma Inline (Package_Instantiation); pragma Inline (Packed_Array_Type); --- 7294,7305 ---- pragma Inline (Normalized_First_Bit); pragma Inline (Normalized_Position); pragma Inline (Normalized_Position_Max); ! pragma Inline (OK_To_Reorder_Components); ! pragma Inline (Optimize_Alignment_Space); ! pragma Inline (Optimize_Alignment_Time); pragma Inline (Original_Array_Type); pragma Inline (Original_Record_Component); + pragma Inline (Overlays_Constant); pragma Inline (Overridden_Operation); pragma Inline (Package_Instantiation); pragma Inline (Packed_Array_Type); *************** package Einfo is *** 7153,7164 **** pragma Inline (Parent_Subtype); pragma Inline (Primitive_Operations); pragma Inline (Prival); ! pragma Inline (Privals_Chain); pragma Inline (Private_Dependents); pragma Inline (Private_View); pragma Inline (Protected_Body_Subprogram); pragma Inline (Protected_Formal); ! pragma Inline (Protected_Operation); pragma Inline (RM_Size); pragma Inline (Reachable); pragma Inline (Referenced); --- 7307,7318 ---- pragma Inline (Parent_Subtype); pragma Inline (Primitive_Operations); pragma Inline (Prival); ! pragma Inline (Prival_Link); pragma Inline (Private_Dependents); pragma Inline (Private_View); pragma Inline (Protected_Body_Subprogram); pragma Inline (Protected_Formal); ! pragma Inline (Protection_Object); pragma Inline (RM_Size); pragma Inline (Reachable); pragma Inline (Referenced); *************** package Einfo is *** 7169,7174 **** --- 7323,7329 ---- pragma Inline (Related_Array_Object); pragma Inline (Related_Instance); pragma Inline (Related_Type); + pragma Inline (Relative_Deadline_Variable); pragma Inline (Renamed_Entity); pragma Inline (Renamed_In_Spec); pragma Inline (Renamed_Object); *************** package Einfo is *** 7183,7195 **** pragma Inline (Scope_Depth_Value); pragma Inline (Sec_Stack_Needed_For_Return); pragma Inline (Shadow_Entities); ! pragma Inline (Shared_Var_Assign_Proc); ! pragma Inline (Shared_Var_Read_Proc); pragma Inline (Size_Check_Code); pragma Inline (Size_Depends_On_Discriminant); pragma Inline (Size_Known_At_Compile_Time); pragma Inline (Small_Value); pragma Inline (Spec_Entity); pragma Inline (Storage_Size_Variable); pragma Inline (Static_Elaboration_Desired); pragma Inline (Static_Initialization); --- 7338,7350 ---- pragma Inline (Scope_Depth_Value); pragma Inline (Sec_Stack_Needed_For_Return); pragma Inline (Shadow_Entities); ! pragma Inline (Shared_Var_Procs_Instance); pragma Inline (Size_Check_Code); pragma Inline (Size_Depends_On_Discriminant); pragma Inline (Size_Known_At_Compile_Time); pragma Inline (Small_Value); pragma Inline (Spec_Entity); + pragma Inline (Spec_PPC_List); pragma Inline (Storage_Size_Variable); pragma Inline (Static_Elaboration_Desired); pragma Inline (Static_Initialization); *************** package Einfo is *** 7210,7215 **** --- 7365,7373 ---- pragma Inline (Uses_Sec_Stack); pragma Inline (Vax_Float); pragma Inline (Warnings_Off); + pragma Inline (Warnings_Off_Used); + pragma Inline (Warnings_Off_Used_Unmodified); + pragma Inline (Warnings_Off_Used_Unreferenced); pragma Inline (Was_Hidden); pragma Inline (Wrapped_Entity); *************** package Einfo is *** 7220,7231 **** pragma Inline (Init_Esize); pragma Inline (Init_RM_Size); - pragma Inline (Set_Abstract_Interfaces); pragma Inline (Set_Accept_Address); pragma Inline (Set_Access_Disp_Table); pragma Inline (Set_Actual_Subtype); pragma Inline (Set_Address_Taken); - pragma Inline (Set_Abstract_Interface_Alias); pragma Inline (Set_Alias); pragma Inline (Set_Alignment); pragma Inline (Set_Associated_Final_Chain); --- 7378,7387 ---- *************** package Einfo is *** 7260,7265 **** --- 7416,7422 ---- pragma Inline (Set_DT_Entry_Count); pragma Inline (Set_DT_Offset_To_Top_Func); pragma Inline (Set_DT_Position); + pragma Inline (Set_Relative_Deadline_Variable); pragma Inline (Set_Default_Expr_Function); pragma Inline (Set_Default_Expressions_Processed); pragma Inline (Set_Default_Value); *************** package Einfo is *** 7309,7315 **** pragma Inline (Set_Freeze_Node); pragma Inline (Set_From_With_Type); pragma Inline (Set_Full_View); - pragma Inline (Set_Function_Returns_With_DSP); pragma Inline (Set_Generic_Homonym); pragma Inline (Set_Generic_Renamings); pragma Inline (Set_Handler_Records); --- 7466,7471 ---- *************** package Einfo is *** 7347,7352 **** --- 7503,7509 ---- pragma Inline (Set_Has_Object_Size_Clause); pragma Inline (Set_Has_Per_Object_Constraint); pragma Inline (Set_Has_Persistent_BSS); + pragma Inline (Set_Has_Postconditions); pragma Inline (Set_Has_Pragma_Controlled); pragma Inline (Set_Has_Pragma_Elaborate_Body); pragma Inline (Set_Has_Pragma_Inline); *************** package Einfo is *** 7385,7394 **** --- 7542,7553 ---- pragma Inline (Set_Hiding_Loop_Variable); pragma Inline (Set_Homonym); pragma Inline (Set_Implemented_By_Entry); + pragma Inline (Set_Interfaces); pragma Inline (Set_In_Package_Body); pragma Inline (Set_In_Private_Part); pragma Inline (Set_In_Use); pragma Inline (Set_Inner_Instances); + pragma Inline (Set_Interface_Alias); pragma Inline (Set_Interface_Name); pragma Inline (Set_Is_AST_Entry); pragma Inline (Set_Is_Abstract_Subprogram); *************** package Einfo is *** 7415,7420 **** --- 7574,7580 ---- pragma Inline (Set_Is_Controlling_Formal); pragma Inline (Set_Is_Descendent_Of_Address); pragma Inline (Set_Is_Discrim_SO_Function); + pragma Inline (Set_Is_Dispatch_Table_Entity); pragma Inline (Set_Is_Dispatching_Operation); pragma Inline (Set_Is_Eliminated); pragma Inline (Set_Is_Entry_Formal); *************** package Einfo is *** 7460,7469 **** --- 7620,7631 ---- pragma Inline (Set_Is_Primitive_Wrapper); pragma Inline (Set_Is_Private_Composite); pragma Inline (Set_Is_Private_Descendant); + pragma Inline (Set_Is_Private_Primitive); pragma Inline (Set_Is_Protected_Interface); pragma Inline (Set_Is_Public); pragma Inline (Set_Is_Pure); pragma Inline (Set_Is_Pure_Unit_Access_Type); + pragma Inline (Set_Is_RACW_Stub_Type); pragma Inline (Set_Is_Raised); pragma Inline (Set_Is_Remote_Call_Interface); pragma Inline (Set_Is_Remote_Types); *************** package Einfo is *** 7476,7481 **** --- 7638,7644 ---- pragma Inline (Set_Is_Tagged_Type); pragma Inline (Set_Is_Task_Interface); pragma Inline (Set_Is_Thunk); + pragma Inline (Set_Is_Trivial_Subprogram); pragma Inline (Set_Is_True_Constant); pragma Inline (Set_Is_Unchecked_Union); pragma Inline (Set_Is_Unsigned_Type); *************** package Einfo is *** 7515,7536 **** pragma Inline (Set_Normalized_First_Bit); pragma Inline (Set_Normalized_Position); pragma Inline (Set_Normalized_Position_Max); ! pragma Inline (Set_Object_Ref); ! pragma Inline (Set_Obsolescent_Warning); pragma Inline (Set_Original_Array_Type); pragma Inline (Set_Original_Record_Component); pragma Inline (Set_Overridden_Operation); pragma Inline (Set_Package_Instantiation); pragma Inline (Set_Packed_Array_Type); pragma Inline (Set_Parent_Subtype); pragma Inline (Set_Primitive_Operations); pragma Inline (Set_Prival); ! pragma Inline (Set_Privals_Chain); pragma Inline (Set_Private_Dependents); pragma Inline (Set_Private_View); pragma Inline (Set_Protected_Body_Subprogram); pragma Inline (Set_Protected_Formal); ! pragma Inline (Set_Protected_Operation); pragma Inline (Set_RM_Size); pragma Inline (Set_Reachable); pragma Inline (Set_Referenced); --- 7678,7701 ---- pragma Inline (Set_Normalized_First_Bit); pragma Inline (Set_Normalized_Position); pragma Inline (Set_Normalized_Position_Max); ! pragma Inline (Set_OK_To_Reorder_Components); ! pragma Inline (Set_Optimize_Alignment_Space); ! pragma Inline (Set_Optimize_Alignment_Time); pragma Inline (Set_Original_Array_Type); pragma Inline (Set_Original_Record_Component); + pragma Inline (Set_Overlays_Constant); pragma Inline (Set_Overridden_Operation); pragma Inline (Set_Package_Instantiation); pragma Inline (Set_Packed_Array_Type); pragma Inline (Set_Parent_Subtype); pragma Inline (Set_Primitive_Operations); pragma Inline (Set_Prival); ! pragma Inline (Set_Prival_Link); pragma Inline (Set_Private_Dependents); pragma Inline (Set_Private_View); pragma Inline (Set_Protected_Body_Subprogram); pragma Inline (Set_Protected_Formal); ! pragma Inline (Set_Protection_Object); pragma Inline (Set_RM_Size); pragma Inline (Set_Reachable); pragma Inline (Set_Referenced); *************** package Einfo is *** 7555,7567 **** pragma Inline (Set_Scope_Depth_Value); pragma Inline (Set_Sec_Stack_Needed_For_Return); pragma Inline (Set_Shadow_Entities); ! pragma Inline (Set_Shared_Var_Assign_Proc); ! pragma Inline (Set_Shared_Var_Read_Proc); pragma Inline (Set_Size_Check_Code); pragma Inline (Set_Size_Depends_On_Discriminant); pragma Inline (Set_Size_Known_At_Compile_Time); pragma Inline (Set_Small_Value); pragma Inline (Set_Spec_Entity); pragma Inline (Set_Storage_Size_Variable); pragma Inline (Set_Static_Elaboration_Desired); pragma Inline (Set_Static_Initialization); --- 7720,7732 ---- pragma Inline (Set_Scope_Depth_Value); pragma Inline (Set_Sec_Stack_Needed_For_Return); pragma Inline (Set_Shadow_Entities); ! pragma Inline (Set_Shared_Var_Procs_Instance); pragma Inline (Set_Size_Check_Code); pragma Inline (Set_Size_Depends_On_Discriminant); pragma Inline (Set_Size_Known_At_Compile_Time); pragma Inline (Set_Small_Value); pragma Inline (Set_Spec_Entity); + pragma Inline (Set_Spec_PPC_List); pragma Inline (Set_Storage_Size_Variable); pragma Inline (Set_Static_Elaboration_Desired); pragma Inline (Set_Static_Initialization); *************** package Einfo is *** 7582,7587 **** --- 7747,7755 ---- pragma Inline (Set_Uses_Sec_Stack); pragma Inline (Set_Vax_Float); pragma Inline (Set_Warnings_Off); + pragma Inline (Set_Warnings_Off_Used); + pragma Inline (Set_Warnings_Off_Used_Unmodified); + pragma Inline (Set_Warnings_Off_Used_Unreferenced); pragma Inline (Set_Was_Hidden); pragma Inline (Set_Wrapped_Entity); diff -Nrcpad gcc-4.3.3/gcc/ada/elists.adb gcc-4.4.0/gcc/ada/elists.adb *** gcc-4.3.3/gcc/ada/elists.adb Wed Jun 6 10:23:26 2007 --- gcc-4.4.0/gcc/ada/elists.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/elists.ads gcc-4.4.0/gcc/ada/elists.ads *** gcc-4.3.3/gcc/ada/elists.ads Wed Jun 6 10:23:26 2007 --- gcc-4.4.0/gcc/ada/elists.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/env.c gcc-4.4.0/gcc/ada/env.c *** gcc-4.3.3/gcc/ada/env.c Tue Apr 1 22:25:02 2008 --- gcc-4.4.0/gcc/ada/env.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 2005-2008, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 2005-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * diff -Nrcpad gcc-4.3.3/gcc/ada/env.h gcc-4.4.0/gcc/ada/env.h *** gcc-4.3.3/gcc/ada/env.h Wed Feb 15 09:30:39 2006 --- gcc-4.4.0/gcc/ada/env.h Thu Apr 9 23:23:07 2009 *************** *** 1,3 **** --- 1,34 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * FE * + * * + * C Header File * + * * + * Copyright (C) 2009, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + extern void __gnat_getenv (char *name, int *len, char **value); extern void __gnat_setenv (char *name, char *value); extern char **__gnat_environ (void); diff -Nrcpad gcc-4.3.3/gcc/ada/errno.c gcc-4.4.0/gcc/ada/errno.c *** gcc-4.3.3/gcc/ada/errno.c Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/errno.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2005, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** *** 41,46 **** --- 40,57 ---- #define _THREAD_SAFE #define _SGI_MP_SOURCE + #ifdef MaRTE + + /* MaRTE OS provides its own implementation of errno related functionality. We + want to ensure the use of the MaRTE version for tasking programs (the MaRTE + library will not be linked if no tasking constructs are used), so we use the + weak symbols mechanism to use the MaRTE version whenever is available. */ + + #pragma weak __get_errno + #pragma weak __set_errno + + #endif + #include int __get_errno(void) diff -Nrcpad gcc-4.3.3/gcc/ada/errout.adb gcc-4.4.0/gcc/ada/errout.adb *** gcc-4.3.3/gcc/ada/errout.adb Wed Dec 19 16:22:40 2007 --- gcc-4.4.0/gcc/ada/errout.adb Mon Apr 14 21:07:59 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Stand; use Stand; *** 50,57 **** with Style; with Uname; use Uname; - with Unchecked_Conversion; - package body Errout is Errors_Must_Be_Ignored : Boolean := False; --- 50,55 ---- *************** package body Errout is *** 193,200 **** procedure VMS_Convert; -- This procedure has no effect if called when the host is not OpenVMS. -- If the host is indeed OpenVMS, then the error message stored in ! -- Msg_Buffer is scanned for appearences of switch names which need ! -- converting to corresponding VMS qualifer names. See Gnames/Vnames -- table in Errout spec for precise definition of the conversion that -- is performed by this routine in OpenVMS mode. --- 191,198 ---- procedure VMS_Convert; -- This procedure has no effect if called when the host is not OpenVMS. -- If the host is indeed OpenVMS, then the error message stored in ! -- Msg_Buffer is scanned for appearances of switch names which need ! -- converting to corresponding VMS qualifier names. See Gnames/Vnames -- table in Errout spec for precise definition of the conversion that -- is performed by this routine in OpenVMS mode. *************** package body Errout is *** 766,771 **** --- 764,774 ---- elsif Debug_Flag_GG then null; + -- Keep warning if message text ends in !! + + elsif Msg (Msg'Last) = '!' and then Msg (Msg'Last - 1) = '!' then + null; + -- Here is where we delete a warning from a with'ed unit else *************** package body Errout is *** 792,798 **** -- If error message line length set, and this is a continuation message -- then all we do is to append the text to the text of the last message ! -- with a comma space separator. if Error_Msg_Line_Length /= 0 and then Continuation --- 795,802 ---- -- If error message line length set, and this is a continuation message -- then all we do is to append the text to the text of the last message ! -- with a comma space separator (eliminating a possible (style) or ! -- info prefix). if Error_Msg_Line_Length /= 0 and then Continuation *************** package body Errout is *** 803,808 **** --- 807,813 ---- Oldm : String_Ptr := Errors.Table (Cur_Msg).Text; Newm : String (1 .. Oldm'Last + 2 + Msglen); Newl : Natural; + M : Natural; begin -- First copy old message to new one and free it *************** package body Errout is *** 811,816 **** --- 816,831 ---- Newl := Oldm'Length; Free (Oldm); + -- Remove (style) or info: at start of message + + if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then + M := 9; + elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then + M := 7; + else + M := 1; + end if; + -- Now deal with separation between messages. Normally this -- is simply comma space, but there are some special cases. *************** package body Errout is *** 825,840 **** -- successive parenthetical remarks into a single one with -- separating commas). ! elsif Msg_Buffer (1) = '(' and then Msg_Buffer (Msglen) = ')' then -- Case where existing message ends in right paren, remove -- and separate parenthetical remarks with a comma. if Newm (Newl) = ')' then Newm (Newl) := ','; ! Msg_Buffer (1) := ' '; ! -- Case where we are adding new parenthetical comment else Newl := Newl + 1; --- 840,855 ---- -- successive parenthetical remarks into a single one with -- separating commas). ! elsif Msg_Buffer (M) = '(' and then Msg_Buffer (Msglen) = ')' then -- Case where existing message ends in right paren, remove -- and separate parenthetical remarks with a comma. if Newm (Newl) = ')' then Newm (Newl) := ','; ! Msg_Buffer (M) := ' '; ! -- Case where we are adding new parenthetical comment else Newl := Newl + 1; *************** package body Errout is *** 850,857 **** -- Append new message ! Newm (Newl + 1 .. Newl + Msglen) := Msg_Buffer (1 .. Msglen); ! Newl := Newl + Msglen; Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl)); end; --- 865,873 ---- -- Append new message ! Newm (Newl + 1 .. Newl + Msglen - M + 1) := ! Msg_Buffer (M .. Msglen); ! Newl := Newl + Msglen - M + 1; Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl)); end; *************** package body Errout is *** 951,959 **** and then Compiler_State = Parsing and then not All_Errors_Mode then ! -- Don't delete unconditional messages and at this stage, ! -- don't delete continuation lines (we attempted to delete ! -- those earlier if the parent message was deleted. if not Errors.Table (Cur_Msg).Uncond and then not Continuation --- 967,975 ---- and then Compiler_State = Parsing and then not All_Errors_Mode then ! -- Don't delete unconditional messages and at this stage, don't ! -- delete continuation lines (we attempted to delete those earlier ! -- if the parent message was deleted. if not Errors.Table (Cur_Msg).Uncond and then not Continuation *************** package body Errout is *** 1006,1015 **** -- Bump appropriate statistics count ! if Errors.Table (Cur_Msg).Warn ! or else Errors.Table (Cur_Msg).Style ! then Warnings_Detected := Warnings_Detected + 1; else Total_Errors_Detected := Total_Errors_Detected + 1; --- 1022,1030 ---- -- Bump appropriate statistics count ! if Errors.Table (Cur_Msg).Warn or Errors.Table (Cur_Msg).Style then Warnings_Detected := Warnings_Detected + 1; + else Total_Errors_Detected := Total_Errors_Detected + 1; *************** package body Errout is *** 1108,1114 **** Last_Killed := True; end if; ! if not Is_Warning_Msg and then not Is_Style_Msg then Set_Posted (N); end if; end Error_Msg_NEL; --- 1123,1129 ---- Last_Killed := True; end if; ! if not (Is_Warning_Msg or Is_Style_Msg) then Set_Posted (N); end if; end Error_Msg_NEL; *************** package body Errout is *** 1364,1375 **** if Error_Posted (N) then return True; ! elsif Nkind (N) in N_Entity and then Warnings_Off (N) then return True; elsif Is_Entity_Name (N) and then Present (Entity (N)) ! and then Warnings_Off (Entity (N)) then return True; --- 1379,1390 ---- if Error_Posted (N) then return True; ! elsif Nkind (N) in N_Entity and then Has_Warnings_Off (N) then return True; elsif Is_Entity_Name (N) and then Present (Entity (N)) ! and then Has_Warnings_Off (Entity (N)) then return True; *************** package body Errout is *** 1922,1930 **** and then Errors.Table (E).Optr = Loc ! -- Don't remove if not warning message. Note that we do not ! -- remove style messages here. They are warning messages but ! -- not ones we want removed in this context. and then Errors.Table (E).Warn --- 1937,1945 ---- and then Errors.Table (E).Optr = Loc ! -- Don't remove if not warning/info message. Note that we do ! -- not remove style messages here. They are warning messages ! -- but not ones we want removed in this context. and then Errors.Table (E).Warn *************** package body Errout is *** 1971,1982 **** and then Original_Node (N) /= N and then No (Condition (N)) then ! -- Warnings may have been posted on subexpressions of ! -- the original tree. We place the original node back ! -- on the tree to remove those warnings, whose sloc ! -- do not match those of any node in the current tree. ! -- Given that we are in unreachable code, this modification ! -- to the tree is harmless. declare Status : Traverse_Final_Result; --- 1986,1996 ---- and then Original_Node (N) /= N and then No (Condition (N)) then ! -- Warnings may have been posted on subexpressions of the original ! -- tree. We place the original node back on the tree to remove ! -- those warnings, whose sloc do not match those of any node in ! -- the current tree. Given that we are in unreachable code, this ! -- modification to the tree is harmless. declare Status : Traverse_Final_Result; *************** package body Errout is *** 2017,2023 **** begin if Is_Non_Empty_List (L) then Stat := First (L); - while Present (Stat) loop Remove_Warning_Messages (Stat); Next (Stat); --- 2031,2036 ---- *************** package body Errout is *** 2033,2044 **** (Identifier_Name : System.Address; File_Name : System.Address) is - type Big_String is array (Positive) of Character; - type Big_String_Ptr is access all Big_String; - - function To_Big_String_Ptr is new Unchecked_Conversion - (System.Address, Big_String_Ptr); - Ident : constant Big_String_Ptr := To_Big_String_Ptr (Identifier_Name); File : constant Big_String_Ptr := To_Big_String_Ptr (File_Name); Flen : Natural; --- 2046,2051 ---- *************** package body Errout is *** 2078,2084 **** for J in Name_Buffer'Range loop Name_Buffer (J) := Ident (J); ! if Name_Buffer (J) = ASCII.Nul then Name_Len := J - 1; exit; end if; --- 2085,2091 ---- for J in Name_Buffer'Range loop Name_Buffer (J) := Ident (J); ! if Name_Buffer (J) = ASCII.NUL then Name_Len := J - 1; exit; end if; *************** package body Errout is *** 2392,2405 **** end if; -- The only remaining possibilities are identifiers, defining ! -- identifiers, pragmas, and pragma argument associations, i.e. ! -- nodes that have a Chars field. ! -- Internal names generally represent something gone wrong. An exception ! -- is the case of internal type names, where we try to find a reasonable ! -- external representation for the external name ! if Is_Internal_Name (Chars (Node)) and then ((Is_Entity_Name (Node) and then Present (Entity (Node)) --- 2399,2415 ---- end if; -- The only remaining possibilities are identifiers, defining ! -- identifiers, pragmas, and pragma argument associations. ! if Nkind (Node) = N_Pragma then ! Nam := Pragma_Name (Node); ! -- The other cases have Chars fields, and we want to test for possible ! -- internal names, which generally represent something gone wrong. An ! -- exception is the case of internal type names, where we try to find a ! -- reasonable external representation for the external name ! ! elsif Is_Internal_Name (Chars (Node)) and then ((Is_Entity_Name (Node) and then Present (Entity (Node)) *************** package body Errout is *** 2423,2428 **** --- 2433,2440 ---- Nam := Chars (Ent); end if; + -- If not internal name, just use name in Chars field + else Nam := Chars (Node); end if; diff -Nrcpad gcc-4.3.3/gcc/ada/errout.ads gcc-4.4.0/gcc/ada/errout.ads *** gcc-4.3.3/gcc/ada/errout.ads Mon Oct 15 13:58:20 2007 --- gcc-4.4.0/gcc/ada/errout.ads Thu Apr 9 23:23:07 2009 *************** *** 6,23 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,23 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- ! -- -- ! -- You should have received a copy of the GNU General Public License along -- ! -- with this program; see file COPYING3. If not see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Errout is *** 120,126 **** -- reference to the Any_Type node, then the message is suppressed. -- 6. Note that cases 2-5 only apply to error messages, not warning ! -- messages. Warning messages are only suppressed for case 1. -- This normal suppression action may be overridden in cases 2-5 (but not -- in case 1) by setting All_Errors mode, or by setting the special --- 120,127 ---- -- reference to the Any_Type node, then the message is suppressed. -- 6. Note that cases 2-5 only apply to error messages, not warning ! -- messages. Warning messages are only suppressed for case 1, and ! -- when they come from other than the main extended unit. -- This normal suppression action may be overridden in cases 2-5 (but not -- in case 1) by setting All_Errors mode, or by setting the special *************** package Errout is *** 264,280 **** -- it, since it makes it clear that the continuation is part of an -- unconditional message. -- Insertion character ? (Question: warning message) -- The character ? appearing anywhere in a message makes the message -- warning instead of a normal error message, and the text of the ! -- message will be preceded by "Warning:" instead of "Error:" in the ! -- normal case. The handling of warnings if further controlled by the ! -- Warning_Mode option (-w switch), see package Opt for further ! -- details, and also by the current setting from pragma Warnings. This ! -- pragma applies only to warnings issued from the semantic phase (not ! -- the parser), but currently all relevant warnings are posted by the ! -- semantic phase anyway. Messages starting with (style) are also ! -- treated as warning messages. -- -- Note: the presence of ? is ignored in continuation messages (i.e. -- messages starting with the \ insertion character). The warning --- 265,295 ---- -- it, since it makes it clear that the continuation is part of an -- unconditional message. + -- Insertion character !! (unconditional warning) + + -- Normally warning messages issued in other than the main unit are + -- suppressed. If the message ends with !! then this suppression is + -- avoided. This is currently only used by the Compile_Time_Warning + -- pragma to ensure the message for a with'ed unit is output. + -- Insertion character ? (Question: warning message) -- The character ? appearing anywhere in a message makes the message -- warning instead of a normal error message, and the text of the ! -- message will be preceded by "warning:" in the normal case. The ! -- handling of warnings if further controlled by the Warning_Mode ! -- option (-w switch), see package Opt for further details, and also by ! -- the current setting from pragma Warnings. This pragma applies only ! -- to warnings issued from the semantic phase (not the parser), but ! -- currently all relevant warnings are posted by the semantic phase ! -- anyway. Messages starting with (style) are also treated as warning ! -- messages. ! -- ! -- Note: when a warning message is output, the text of the message is ! -- preceded by "warning: " in the normal case. An exception to this ! -- rule occurs when the text of the message starts with "info: " in ! -- which case this string is not prepended. This allows callers to ! -- label certain warnings as informational messages, rather than as ! -- warning messages requiring some action. -- -- Note: the presence of ? is ignored in continuation messages (i.e. -- messages starting with the \ insertion character). The warning diff -Nrcpad gcc-4.3.3/gcc/ada/erroutc.adb gcc-4.4.0/gcc/ada/erroutc.adb *** gcc-4.3.3/gcc/ada/erroutc.adb Tue Aug 14 08:37:51 2007 --- gcc-4.4.0/gcc/ada/erroutc.adb Thu Apr 9 23:23:07 2009 *************** *** 6,23 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,23 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- ! -- -- ! -- You should have received a copy of the GNU General Public License along -- ! -- with this program; see file COPYING3. If not see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Erroutc is *** 117,122 **** --- 117,123 ---- if Errors.Table (D).Warn or Errors.Table (D).Style then Warnings_Detected := Warnings_Detected - 1; + else Total_Errors_Detected := Total_Errors_Detected - 1; *************** package body Erroutc is *** 176,182 **** Delete_Msg (M1, M2); return; ! -- If M2 continuatins have run out, we delete M2 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then Delete_Msg (M2, M1); --- 177,183 ---- Delete_Msg (M1, M2); return; ! -- If M2 continuations have run out, we delete M2 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then Delete_Msg (M2, M1); *************** package body Erroutc is *** 441,446 **** --- 442,453 ---- Length : Nat; -- Maximum total length of lines + Txt : constant String_Ptr := Errors.Table (E).Text; + Len : constant Natural := Txt'Length; + Ptr : Natural; + Split : Natural; + Start : Natural; + begin if Error_Msg_Line_Length = 0 then Length := Nat'Last; *************** package body Erroutc is *** 450,462 **** Max := Integer (Length - Column + 1); if Errors.Table (E).Warn then ! Write_Str ("warning: "); ! Max := Max - 9; elsif Errors.Table (E).Style then null; elsif Opt.Unique_Error_Tag then Write_Str ("error: "); Max := Max - 7; --- 457,477 ---- Max := Integer (Length - Column + 1); + -- For warning message, add "warning: " unless msg starts with "info: " + if Errors.Table (E).Warn then ! if Len < 6 or else Txt (Txt'First .. Txt'First + 5) /= "info: " then ! Write_Str ("warning: "); ! Max := Max - 9; ! end if; ! ! -- No prefix needed for style message, since "(style)" is there already elsif Errors.Table (E).Style then null; + -- All other cases, add "error: " + elsif Opt.Unique_Error_Tag then Write_Str ("error: "); Max := Max - 7; *************** package body Erroutc is *** 464,537 **** -- Here we have to split the message up into multiple lines ! declare ! Txt : constant String_Ptr := Errors.Table (E).Text; ! Len : constant Natural := Txt'Length; ! Ptr : Natural; ! Split : Natural; ! Start : Natural; ! ! begin ! Ptr := 1; ! loop ! -- Make sure we do not have ludicrously small line ! Max := Integer'Max (Max, 20); ! -- If remaining text fits, output it respecting LF and we are done ! if Len - Ptr < Max then ! for J in Ptr .. Len loop ! if Txt (J) = ASCII.LF then ! Write_Eol; ! Write_Spaces (Offs); ! else ! Write_Char (Txt (J)); ! end if; ! end loop; ! return; -- Line does not fit ! else ! Start := Ptr; ! -- First scan forward looing for a hard end of line ! for Scan in Ptr .. Ptr + Max - 1 loop ! if Txt (Scan) = ASCII.LF then ! Split := Scan - 1; ! Ptr := Scan + 1; ! goto Continue; ! end if; ! end loop; ! -- Otherwise scan backwards looking for a space ! for Scan in reverse Ptr .. Ptr + Max - 1 loop ! if Txt (Scan) = ' ' then ! Split := Scan - 1; ! Ptr := Scan + 1; ! goto Continue; ! end if; ! end loop; ! -- If we fall through, no space, so split line arbitrarily ! Split := Ptr + Max - 1; ! Ptr := Split + 1; ! end if; <> ! if Start <= Split then ! Write_Line (Txt (Start .. Split)); ! Write_Spaces (Offs); ! end if; ! Max := Integer (Length - Column + 1); ! end loop; ! end; end Output_Msg_Text; -------------------- --- 479,543 ---- -- Here we have to split the message up into multiple lines ! Ptr := 1; ! loop ! -- Make sure we do not have ludicrously small line ! Max := Integer'Max (Max, 20); ! -- If remaining text fits, output it respecting LF and we are done ! if Len - Ptr < Max then ! for J in Ptr .. Len loop ! if Txt (J) = ASCII.LF then ! Write_Eol; ! Write_Spaces (Offs); ! else ! Write_Char (Txt (J)); ! end if; ! end loop; ! return; -- Line does not fit ! else ! Start := Ptr; ! -- First scan forward looking for a hard end of line ! for Scan in Ptr .. Ptr + Max - 1 loop ! if Txt (Scan) = ASCII.LF then ! Split := Scan - 1; ! Ptr := Scan + 1; ! goto Continue; ! end if; ! end loop; ! -- Otherwise scan backwards looking for a space ! for Scan in reverse Ptr .. Ptr + Max - 1 loop ! if Txt (Scan) = ' ' then ! Split := Scan - 1; ! Ptr := Scan + 1; ! goto Continue; ! end if; ! end loop; ! -- If we fall through, no space, so split line arbitrarily ! Split := Ptr + Max - 1; ! Ptr := Split + 1; ! end if; <> ! if Start <= Split then ! Write_Line (Txt (Start .. Split)); ! Write_Spaces (Offs); ! end if; ! Max := Integer (Length - Column + 1); ! end loop; end Output_Msg_Text; -------------------- *************** package body Erroutc is *** 557,562 **** --- 563,569 ---- then if Errors.Table (E).Warn or Errors.Table (E).Style then Warnings_Detected := Warnings_Detected - 1; + else Total_Errors_Detected := Total_Errors_Detected - 1; *************** package body Erroutc is *** 968,974 **** Set_Msg_Char (UI_Image_Buffer (J)); end loop; ! -- The following assignment ensures that a second carret insertion -- character will correspond to the Error_Msg_Uint_2 parameter. We -- suppress possible validity checks in case operating in -gnatVa mode, -- and Error_Msg_Uint_2 is not needed and has not been set. --- 975,981 ---- Set_Msg_Char (UI_Image_Buffer (J)); end loop; ! -- The following assignment ensures that a second caret insertion -- character will correspond to the Error_Msg_Uint_2 parameter. We -- suppress possible validity checks in case operating in -gnatVa mode, -- and Error_Msg_Uint_2 is not needed and has not been set. *************** package body Erroutc is *** 1052,1091 **** Msg : String; Config : Boolean) is - pragma Assert (Msg'First = 1); - - Pattern : String := Msg; - Patlen : Natural := Msg'Length; - - Star_Start : Boolean; - Star_End : Boolean; - begin - if Pattern (1) = '*' then - Star_Start := True; - Pattern (1 .. Patlen - 1) := Pattern (2 .. Patlen); - Patlen := Patlen - 1; - else - Star_Start := False; - end if; - - if Pattern (Patlen) = '*' then - Star_End := True; - Patlen := Patlen - 1; - else - Star_End := False; - end if; - Specific_Warnings.Append ((Start => Loc, Msg => new String'(Msg), - Pattern => new String'(Pattern (1 .. Patlen)), - Patlen => Patlen, Stop => Source_Last (Current_Source_File), Open => True, Used => False, - Star_Start => Star_Start, - Star_End => Star_End, Config => Config)); end Set_Specific_Warning_Off; --- 1059,1071 ---- *************** package body Erroutc is *** 1200,1207 **** Is_Warning_Msg := False; Is_Style_Msg := ! (Msg'Length > 7 ! and then Msg (Msg'First .. Msg'First + 6) = "(style)"); for J in Msg'Range loop if Msg (J) = '?' --- 1180,1190 ---- Is_Warning_Msg := False; Is_Style_Msg := ! (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)"); ! ! if Is_Style_Msg then ! Is_Serious_Error := False; ! end if; for J in Msg'Range loop if Msg (J) = '?' *************** package body Erroutc is *** 1221,1227 **** end if; end loop; ! if Is_Warning_Msg or else Is_Style_Msg then Is_Serious_Error := False; end if; end Test_Style_Warning_Serious_Msg; --- 1204,1210 ---- end if; end loop; ! if Is_Warning_Msg or Is_Style_Msg then Is_Serious_Error := False; end if; end Test_Style_Warning_Serious_Msg; *************** package body Erroutc is *** 1258,1367 **** (Loc : Source_Ptr; Msg : String_Ptr) return Boolean is ! pragma Assert (Msg'First = 1); ! ! Msglen : constant Natural := Msg'Length; ! Patlen : Natural; ! -- Length of message ! ! Pattern : String_Ptr; ! -- Pattern itself, excluding initial and final * ! ! Star_Start : Boolean; ! Star_End : Boolean; ! -- Indications of * at start and end of original pattern ! ! Msgp : Natural; ! Patp : Natural; ! -- Scan pointers for message and pattern ! begin ! -- Loop through specific warning suppression entries ! for J in Specific_Warnings.First .. Specific_Warnings.Last loop ! declare ! SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); ! begin ! -- Pragma applies if it is a configuration pragma, or if the ! -- location is in range of a specific non-configuration pragma. ! if SWE.Config ! or else (SWE.Start <= Loc and then Loc <= SWE.Stop) ! then ! -- Check if message matches, dealing with * patterns ! Patlen := SWE.Patlen; ! Pattern := SWE.Pattern; ! Star_Start := SWE.Star_Start; ! Star_End := SWE.Star_End; ! -- Loop through possible starting positions in Msg ! Outer : for M in 1 .. 1 + (Msglen - Patlen) loop ! -- See if pattern matches string starting at Msg (J) ! Msgp := M; ! Patp := 1; ! Inner : loop ! -- If pattern exhausted, then match if we are at end ! -- of message, or if pattern ended with an asterisk, ! -- otherwise match failure at this position. ! if Patp > Patlen then ! if Msgp > Msglen or else Star_End then ! SWE.Used := True; ! return True; ! else ! exit Inner; ! end if; ! -- Otherwise if message exhausted (and we still have ! -- pattern characters left), then match failure here. ! elsif Msgp > Msglen then ! exit Inner; ! end if; ! -- Here we have pattern and message characters left ! -- Handle "*" pattern match ! if Patp < Patlen - 1 and then ! Pattern (Patp .. Patp + 2) = """*""" ! then ! Patp := Patp + 3; ! -- Must have " and at least three chars in msg or we ! -- have no match at this position. ! exit Inner when Msg (Msgp) /= '"'; ! Msgp := Msgp + 1; ! -- Scan out " string " in message ! Scan : loop ! exit Inner when Msgp = Msglen; ! Msgp := Msgp + 1; ! exit Scan when Msg (Msgp - 1) = '"'; ! end loop Scan; ! -- If not "*" case, just compare character ! else ! exit Inner when Pattern (Patp) /= Msg (Msgp); ! Patp := Patp + 1; ! Msgp := Msgp + 1; ! end if; ! end loop Inner; ! -- Advance to next position if star at end of original ! -- pattern, otherwise no more match attempts are possible ! exit Outer when not Star_Start; ! end loop Outer; end if; end; end loop; --- 1241,1332 ---- (Loc : Source_Ptr; Msg : String_Ptr) return Boolean is ! function Matches (S : String; P : String) return Boolean; ! -- Returns true if the String S patches the pattern P, which can contain ! -- wild card chars (*). The entire pattern must match the entire string. ! ------------- ! -- Matches -- ! ------------- ! function Matches (S : String; P : String) return Boolean is ! Slast : constant Natural := S'Last; ! PLast : constant Natural := P'Last; ! SPtr : Natural := S'First; ! PPtr : Natural := P'First; ! begin ! -- Loop advancing through characters of string and pattern ! SPtr := S'First; ! PPtr := P'First; ! loop ! -- Return True if pattern is a single asterisk ! if PPtr = PLast and then P (PPtr) = '*' then ! return True; ! -- Return True if both pattern and string exhausted ! elsif PPtr > PLast and then SPtr > Slast then ! return True; ! -- Return False, if one exhausted and not the other ! elsif PPtr > PLast or else SPtr > Slast then ! return False; ! -- Case where pattern starts with asterisk ! elsif P (PPtr) = '*' then ! -- Try all possible starting positions in S for match with ! -- the remaining characters of the pattern. This is the ! -- recursive call that implements the scanner backup. ! for J in SPtr .. Slast loop ! if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then ! return True; ! end if; ! end loop; ! return False; ! -- Dealt with end of string and *, advance if we have a match ! elsif S (SPtr) = P (PPtr) then ! SPtr := SPtr + 1; ! PPtr := PPtr + 1; ! -- If first characters do not match, that's decisive ! else ! return False; ! end if; ! end loop; ! end Matches; ! -- Start of processing for Warning_Specifically_Suppressed ! begin ! -- Loop through specific warning suppression entries ! for J in Specific_Warnings.First .. Specific_Warnings.Last loop ! declare ! SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); ! begin ! -- Pragma applies if it is a configuration pragma, or if the ! -- location is in range of a specific non-configuration pragma. ! if SWE.Config ! or else (SWE.Start <= Loc and then Loc <= SWE.Stop) ! then ! if Matches (Msg.all, SWE.Msg.all) then ! SWE.Used := True; ! return True; ! end if; end if; end; end loop; diff -Nrcpad gcc-4.3.3/gcc/ada/erroutc.ads gcc-4.4.0/gcc/ada/erroutc.ads *** gcc-4.3.3/gcc/ada/erroutc.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/erroutc.ads Mon Apr 14 21:07:59 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Erroutc is *** 36,42 **** -- type, and is used by Add_Class to insert 'Class at the proper point Continuation : Boolean := False; ! -- Indicates if current message is a continuation. Intialized from the -- Msg_Cont parameter in Error_Msg_Internal and then set True if a \ -- insertion character is encountered. --- 36,42 ---- -- type, and is used by Add_Class to insert 'Class at the proper point Continuation : Boolean := False; ! -- Indicates if current message is a continuation. Initialized from the -- Msg_Cont parameter in Error_Msg_Internal and then set True if a \ -- insertion character is encountered. *************** package Erroutc is *** 52,57 **** --- 52,58 ---- Is_Style_Msg : Boolean := False; -- Set True to indicate if the current message is a style message + -- (i.e. a message whose text starts with the characters "(style)"). Is_Serious_Error : Boolean := False; -- Set by Set_Msg_Text to indicate if current message is serious error *************** package Erroutc is *** 81,89 **** Max_Msg_Length : constant := 1024 + 2 * Int (Column_Number'Last); -- Maximum length of error message. The addition of 2 * Column_Number'Last ! -- ensures that two insertion tokens of maximum length can be accomodated. -- The value of 1024 is an arbitrary value that should be more than long ! -- enough to accomodate any reasonable message (and for that matter, some -- pretty unreasonable messages!) Msg_Buffer : String (1 .. Max_Msg_Length); --- 82,90 ---- Max_Msg_Length : constant := 1024 + 2 * Int (Column_Number'Last); -- Maximum length of error message. The addition of 2 * Column_Number'Last ! -- ensures that two insertion tokens of maximum length can be accommodated. -- The value of 1024 is an arbitrary value that should be more than long ! -- enough to accommodate any reasonable message (and for that matter, some -- pretty unreasonable messages!) Msg_Buffer : String (1 .. Max_Msg_Length); *************** package Erroutc is *** 115,121 **** No_Error_Msg : constant Error_Msg_Id := 0; -- A constant which is different from any value returned by Get_Error_Id. ! -- Typically used by a client to indicate absense of a saved Id value. Cur_Msg : Error_Msg_Id := No_Error_Msg; -- Id of most recently posted error message --- 116,122 ---- No_Error_Msg : constant Error_Msg_Id := 0; -- A constant which is different from any value returned by Get_Error_Id. ! -- Typically used by a client to indicate absence of a saved Id value. Cur_Msg : Error_Msg_Id := No_Error_Msg; -- Id of most recently posted error message *************** package Erroutc is *** 235,241 **** -- end of the current source file. A subsequent pragma Warnings (On) -- adjusts the end point of this entry appropriately. ! -- If all warnings are suppressed by comamnd switch, then there is a -- dummy entry (put there by Errout.Initialize) at the start of the -- table which covers all possible Source_Ptr values. Note that the -- source pointer values in this table always reference the original --- 236,242 ---- -- end of the current source file. A subsequent pragma Warnings (On) -- adjusts the end point of this entry appropriately. ! -- If all warnings are suppressed by command switch, then there is a -- dummy entry (put there by Errout.Initialize) at the start of the -- table which covers all possible Source_Ptr values. Note that the -- source pointer values in this table always reference the original *************** package Erroutc is *** 267,291 **** Msg : String_Ptr; -- Message from pragma Warnings (Off, string) - Pattern : String_Ptr; - -- Same as Msg, excluding initial and final asterisks if present. The - -- lower bound of this string is always one. - - Patlen : Natural; - -- Length of pattern string (excluding initial/final asterisks) - Open : Boolean; -- Set to True if OFF has been encountered with no matching ON Used : Boolean; -- Set to True if entry has been used to suppress a warning - Star_Start : Boolean; - -- True if given pattern had * at start - - Star_End : Boolean; - -- True if given pattern had * at end - Config : Boolean; -- True if pragma is configuration pragma (in which case no matching -- Off pragma is required, and it is not required that a specific --- 268,279 ---- *************** package Erroutc is *** 482,493 **** procedure Test_Style_Warning_Serious_Msg (Msg : String); -- Sets Is_Warning_Msg true if Msg is a warning message (contains a ! -- question mark character), and False otherwise. Sets Is_Style_Msg ! -- true if Msg is a style message (starts with "(style)"). Sets ! -- Is_Serious_Error True unless the message is a warning or style ! -- message or contains the character | indicating a non-serious ! -- error message. Note that the call has no effect for continuation ! -- messages (those whose first character is \). function Warnings_Suppressed (Loc : Source_Ptr) return Boolean; -- Determines if given location is covered by a warnings off suppression --- 470,481 ---- procedure Test_Style_Warning_Serious_Msg (Msg : String); -- Sets Is_Warning_Msg true if Msg is a warning message (contains a ! -- question mark character), and False otherwise. Is_Style_Msg is set true ! -- if Msg is a style message (starts with "(style)". Sets Is_Serious_Error ! -- True unless the message is a warning or style/info message or contains ! -- the character | indicating a non-serious error message. Note that the ! -- call has no effect for continuation messages (those whose first ! -- character is '\'). function Warnings_Suppressed (Loc : Source_Ptr) return Boolean; -- Determines if given location is covered by a warnings off suppression diff -Nrcpad gcc-4.3.3/gcc/ada/errutil.adb gcc-4.4.0/gcc/ada/errutil.adb *** gcc-4.3.3/gcc/ada/errutil.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/errutil.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1991-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1991-2008, 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- -- diff -Nrcpad gcc-4.3.3/gcc/ada/exit.c gcc-4.4.0/gcc/ada/exit.c *** gcc-4.3.3/gcc/ada/exit.c Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/exit.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2003 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * diff -Nrcpad gcc-4.3.3/gcc/ada/exp_aggr.adb gcc-4.4.0/gcc/ada/exp_aggr.adb *** gcc-4.3.3/gcc/ada/exp_aggr.adb Wed Dec 19 16:22:56 2007 --- gcc-4.4.0/gcc/ada/exp_aggr.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Checks; use Checks; *** 28,33 **** --- 28,34 ---- with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; + with Errout; use Errout; with Expander; use Expander; with Exp_Util; use Exp_Util; with Exp_Ch3; use Exp_Ch3; *************** package body Exp_Aggr is *** 169,180 **** -- Local Subprograms for Array Aggregate Expansion -- ----------------------------------------------------- ! function Aggr_Size_OK (Typ : Entity_Id) return Boolean; -- Very large static aggregates present problems to the back-end, and -- are transformed into assignments and loops. This function verifies -- that the total number of components of an aggregate is acceptable -- for transformation into a purely positional static form. It is called -- prior to calling Flatten. procedure Convert_Array_Aggr_In_Allocator (Decl : Node_Id; --- 170,184 ---- -- Local Subprograms for Array Aggregate Expansion -- ----------------------------------------------------- ! function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean; -- Very large static aggregates present problems to the back-end, and -- are transformed into assignments and loops. This function verifies -- that the total number of components of an aggregate is acceptable -- for transformation into a purely positional static form. It is called -- prior to calling Flatten. + -- This function also detects and warns about one-component aggregates + -- that appear in a non-static context. Even if the component value is + -- static, such an aggregate must be expanded into an assignment. procedure Convert_Array_Aggr_In_Allocator (Decl : Node_Id; *************** package body Exp_Aggr is *** 291,297 **** -- Aggr_Size_OK -- ------------------ ! function Aggr_Size_OK (Typ : Entity_Id) return Boolean is Lo : Node_Id; Hi : Node_Id; Indx : Node_Id; --- 295,301 ---- -- Aggr_Size_OK -- ------------------ ! function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean is Lo : Node_Id; Hi : Node_Id; Indx : Node_Id; *************** package body Exp_Aggr is *** 300,306 **** Hiv : Uint; -- The following constant determines the maximum size of an ! -- aggregate produced by converting named to positional -- notation (e.g. from others clauses). This avoids running -- away with attempts to convert huge aggregates, which hit -- memory limits in the backend. --- 304,310 ---- Hiv : Uint; -- The following constant determines the maximum size of an ! -- array aggregate produced by converting named to positional -- notation (e.g. from others clauses). This avoids running -- away with attempts to convert huge aggregates, which hit -- memory limits in the backend. *************** package body Exp_Aggr is *** 322,328 **** -- The limit is applied to the total number of components that the -- aggregate will have, which is the number of static expressions -- that will appear in the flattened array. This requires a recursive ! -- computation of the the number of scalar components of the structure. --------------------- -- Component_Count -- --- 326,332 ---- -- The limit is applied to the total number of components that the -- aggregate will have, which is the number of static expressions -- that will appear in the flattened array. This requires a recursive ! -- computation of the number of scalar components of the structure. --------------------- -- Component_Count -- *************** package body Exp_Aggr is *** 399,404 **** --- 403,445 ---- return True; end if; + -- One-component aggregates are suspicious, and if the context type + -- is an object declaration with non-static bounds it will trip gcc; + -- such an aggregate must be expanded into a single assignment. + + if Hiv = Lov + and then Nkind (Parent (N)) = N_Object_Declaration + then + declare + Index_Type : constant Entity_Id := + Etype + (First_Index + (Etype (Defining_Identifier (Parent (N))))); + Indx : Node_Id; + + begin + if not Compile_Time_Known_Value (Type_Low_Bound (Index_Type)) + or else not Compile_Time_Known_Value + (Type_High_Bound (Index_Type)) + then + if Present (Component_Associations (N)) then + Indx := + First (Choices (First (Component_Associations (N)))); + if Is_Entity_Name (Indx) + and then not Is_Type (Entity (Indx)) + then + Error_Msg_N + ("single component aggregate in non-static context?", + Indx); + Error_Msg_N ("\maybe subtype name was meant?", Indx); + end if; + end if; + + return False; + end if; + end; + end if; + declare Rng : constant Uint := Hiv - Lov + 1; *************** package body Exp_Aggr is *** 544,549 **** --- 585,597 ---- return False; end if; + -- If component is limited, aggregate must be expanded because each + -- component assignment must be built in place. + + if Is_Inherently_Limited_Type (Component_Type (Typ)) then + return False; + end if; + -- Checks 4 (array must not be multi-dimensional Fortran case) if Convention (Typ) = Convention_Fortran *************** package body Exp_Aggr is *** 925,931 **** if Present (Flist) then F := New_Copy_Tree (Flist); ! elsif Present (Etype (N)) and then Controlled_Type (Etype (N)) then if Is_Entity_Name (Into) and then Present (Scope (Entity (Into))) then --- 973,979 ---- if Present (Flist) then F := New_Copy_Tree (Flist); ! elsif Present (Etype (N)) and then Needs_Finalization (Etype (N)) then if Is_Entity_Name (Into) and then Present (Scope (Entity (Into))) then *************** package body Exp_Aggr is *** 1089,1095 **** Expression => Make_Null (Loc))); end if; ! if Controlled_Type (Ctype) then Append_List_To (L, Make_Init_Call ( Ref => New_Copy_Tree (Indexed_Comp), --- 1137,1143 ---- Expression => Make_Null (Loc))); end if; ! if Needs_Finalization (Ctype) then Append_List_To (L, Make_Init_Call ( Ref => New_Copy_Tree (Indexed_Comp), *************** package body Exp_Aggr is *** 1111,1117 **** Name => Indexed_Comp, Expression => New_Copy_Tree (Expr)); ! if Present (Comp_Type) and then Controlled_Type (Comp_Type) then Set_No_Ctrl_Actions (A); -- If this is an aggregate for an array of arrays, each --- 1159,1165 ---- Name => Indexed_Comp, Expression => New_Copy_Tree (Expr)); ! if Present (Comp_Type) and then Needs_Finalization (Comp_Type) then Set_No_Ctrl_Actions (A); -- If this is an aggregate for an array of arrays, each *************** package body Exp_Aggr is *** 1170,1181 **** -- If the component is itself an array of controlled types, whose -- value is given by a sub-aggregate, then the attach calls have -- been generated when individual subcomponent are assigned, and ! -- and must not be done again to prevent malformed finalization ! -- chains (see comments above, concerning the creation of a block ! -- to hold inner finalization actions). if Present (Comp_Type) ! and then Controlled_Type (Comp_Type) and then not Is_Limited_Type (Comp_Type) and then (not Is_Array_Type (Comp_Type) --- 1218,1229 ---- -- If the component is itself an array of controlled types, whose -- value is given by a sub-aggregate, then the attach calls have -- been generated when individual subcomponent are assigned, and ! -- must not be done again to prevent malformed finalization chains ! -- (see comments above, concerning the creation of a block to hold ! -- inner finalization actions). if Present (Comp_Type) ! and then Needs_Finalization (Comp_Type) and then not Is_Limited_Type (Comp_Type) and then (not Is_Array_Type (Comp_Type) *************** package body Exp_Aggr is *** 1514,1519 **** --- 1562,1577 ---- Make_Integer_Literal (Loc, Uint_0)))); end if; + -- If the component type contains tasks, we need to build a Master + -- entity in the current scope, because it will be needed if build- + -- in-place functions are called in the expanded code. + + if Nkind (Parent (N)) = N_Object_Declaration + and then Has_Task (Typ) + then + Build_Master_Entity (Defining_Identifier (Parent (N))); + end if; + -- STEP 1: Process component associations -- For those associations that may generate a loop, initialize *************** package body Exp_Aggr is *** 1677,1686 **** -- Build_Record_Aggr_Code -- ---------------------------- - ---------------------------- - -- Build_Record_Aggr_Code -- - ---------------------------- - function Build_Record_Aggr_Code (N : Node_Id; Typ : Entity_Id; --- 1735,1740 ---- *************** package body Exp_Aggr is *** 1990,2001 **** Selector_Name => Make_Identifier (Loc, Name_uController)); Set_Assignment_OK (Ref); ! -- Ada 2005 (AI-287): Give support to aggregates of limited ! -- types. If the type is intrinsically_limited the controller ! -- is limited as well. If it is tagged and limited then so is ! -- the controller. Otherwise an untagged type may have limited ! -- components without its full view being limited, so the ! -- controller is not limited. if Nkind (Target) = N_Identifier then Target_Type := Etype (Target); --- 2044,2054 ---- Selector_Name => Make_Identifier (Loc, Name_uController)); Set_Assignment_OK (Ref); ! -- Ada 2005 (AI-287): Give support to aggregates of limited types. ! -- If the type is intrinsically limited the controller is limited as ! -- well. If it is tagged and limited then so is the controller. ! -- Otherwise an untagged type may have limited components without its ! -- full view being limited, so the controller is not limited. if Nkind (Target) = N_Identifier then Target_Type := Etype (Target); *************** package body Exp_Aggr is *** 2016,2023 **** end if; -- If the target has not been analyzed yet, as will happen with ! -- delayed expansion, use the given type (either the aggregate ! -- type or an ancestor) to determine limitedness. if No (Target_Type) then Target_Type := Typ; --- 2069,2076 ---- end if; -- If the target has not been analyzed yet, as will happen with ! -- delayed expansion, use the given type (either the aggregate type ! -- or an ancestor) to determine limitedness. if No (Target_Type) then Target_Type := Typ; *************** package body Exp_Aggr is *** 2114,2120 **** -- proper scope is the scope of the target rather than the -- potentially transient current scope. ! if Controlled_Type (Typ) then -- The current aggregate belongs to an allocator which creates -- an object through an anonymous access type or acts as the root --- 2167,2173 ---- -- proper scope is the scope of the target rather than the -- potentially transient current scope. ! if Needs_Finalization (Typ) then -- The current aggregate belongs to an allocator which creates -- an object through an anonymous access type or acts as the root *************** package body Exp_Aggr is *** 2214,2221 **** Outer_Typ := Etype (Outer_Typ); end loop; ! -- Attach it to the outer record controller to the ! -- external final list if Outer_Typ = Init_Typ then Append_List_To (L, --- 2267,2274 ---- Outer_Typ := Etype (Outer_Typ); end loop; ! -- Attach it to the outer record controller to the external ! -- final list. if Outer_Typ = Init_Typ then Append_List_To (L, *************** package body Exp_Aggr is *** 2322,2330 **** end Gen_Ctrl_Actions_For_Aggr; function Replace_Type (Expr : Node_Id) return Traverse_Result; ! -- If the aggregate contains a self-reference, traverse each ! -- expression to replace a possible self-reference with a reference ! -- to the proper component of the target of the assignment. ------------------ -- Replace_Type -- --- 2375,2383 ---- end Gen_Ctrl_Actions_For_Aggr; function Replace_Type (Expr : Node_Id) return Traverse_Result; ! -- If the aggregate contains a self-reference, traverse each expression ! -- to replace a possible self-reference with a reference to the proper ! -- component of the target of the assignment. ------------------ -- Replace_Type -- *************** package body Exp_Aggr is *** 2332,2340 **** function Replace_Type (Expr : Node_Id) return Traverse_Result is begin if Nkind (Expr) = N_Attribute_Reference ! and then Is_Entity_Name (Prefix (Expr)) and then Is_Type (Entity (Prefix (Expr))) then if Is_Entity_Name (Lhs) then Rewrite (Prefix (Expr), --- 2385,2403 ---- function Replace_Type (Expr : Node_Id) return Traverse_Result is begin + -- Note regarding the Root_Type test below: Aggregate components for + -- self-referential types include attribute references to the current + -- instance, of the form: Typ'access, etc.. These references are + -- rewritten as references to the target of the aggregate: the + -- left-hand side of an assignment, the entity in a declaration, + -- or a temporary. Without this test, we would improperly extended + -- this rewriting to attribute references whose prefix was not the + -- type of the aggregate. + if Nkind (Expr) = N_Attribute_Reference ! and then Is_Entity_Name (Prefix (Expr)) and then Is_Type (Entity (Prefix (Expr))) + and then Root_Type (Etype (N)) = Root_Type (Entity (Prefix (Expr))) then if Is_Entity_Name (Lhs) then Rewrite (Prefix (Expr), *************** package body Exp_Aggr is *** 2373,2380 **** -- to the actual type of the aggregate, so that the proper components -- are visible. We know already that the types are compatible. if Present (Etype (Lhs)) ! and then Is_Interface (Etype (Lhs)) then Target := Unchecked_Convert_To (Typ, Lhs); else --- 2436,2447 ---- -- to the actual type of the aggregate, so that the proper components -- are visible. We know already that the types are compatible. + -- There should also be a comment here explaining why the conversion + -- is needed in the case of interfaces.??? + if Present (Etype (Lhs)) ! and then (Is_Interface (Etype (Lhs)) ! or else Is_Class_Wide_Type (Etype (Lhs))) then Target := Unchecked_Convert_To (Typ, Lhs); else *************** package body Exp_Aggr is *** 2394,2400 **** -- init-proc (T(tmp)); if T is constrained and -- init-proc (S(tmp)); where S applies an appropriate ! -- constraint if T is unconstrained if Is_Entity_Name (A) and then Is_Type (Entity (A)) then Ancestor_Is_Subtype_Mark := True; --- 2461,2467 ---- -- init-proc (T(tmp)); if T is constrained and -- init-proc (S(tmp)); where S applies an appropriate ! -- constraint if T is unconstrained if Is_Entity_Name (A) and then Is_Type (Entity (A)) then Ancestor_Is_Subtype_Mark := True; *************** package body Exp_Aggr is *** 2533,2539 **** -- Make the assignment without usual controlled actions since -- we only want the post adjust but not the pre finalize here ! -- Add manual adjust when necessary Assign := New_List ( Make_OK_Assignment_Statement (Loc, --- 2600,2606 ---- -- Make the assignment without usual controlled actions since -- we only want the post adjust but not the pre finalize here ! -- Add manual adjust when necessary. Assign := New_List ( Make_OK_Assignment_Statement (Loc, *************** package body Exp_Aggr is *** 2568,2578 **** -- Ada 2005 (AI-251): If tagged type has progenitors we must -- also initialize tags of the secondary dispatch tables. ! if Present (Abstract_Interfaces (Base_Type (Typ))) ! and then not ! Is_Empty_Elmt_List ! (Abstract_Interfaces (Base_Type (Typ))) ! then Init_Secondary_Tags (Typ => Base_Type (Typ), Target => Target, --- 2635,2641 ---- -- Ada 2005 (AI-251): If tagged type has progenitors we must -- also initialize tags of the secondary dispatch tables. ! if Has_Interfaces (Base_Type (Typ)) then Init_Secondary_Tags (Typ => Base_Type (Typ), Target => Target, *************** package body Exp_Aggr is *** 2582,2588 **** -- Call Adjust manually ! if Controlled_Type (Etype (A)) and then not Is_Limited_Type (Etype (A)) then Append_List_To (Assign, --- 2645,2651 ---- -- Call Adjust manually ! if Needs_Finalization (Etype (A)) and then not Is_Limited_Type (Etype (A)) then Append_List_To (Assign, *************** package body Exp_Aggr is *** 2791,2797 **** -- The controller is the one of the parent type defining the -- component (in case of inherited components). ! if Controlled_Type (Comp_Type) then Internal_Final_List := Make_Selected_Component (Loc, Prefix => Convert_To ( --- 2854,2860 ---- -- The controller is the one of the parent type defining the -- component (in case of inherited components). ! if Needs_Finalization (Comp_Type) then Internal_Final_List := Make_Selected_Component (Loc, Prefix => Convert_To ( *************** package body Exp_Aggr is *** 2964,2970 **** -- Attach_To_Final_List (tmp.comp, -- comp_typ (tmp)._record_controller.f) ! if Controlled_Type (Comp_Type) and then not Is_Limited_Type (Comp_Type) then Append_List_To (L, --- 3027,3033 ---- -- Attach_To_Final_List (tmp.comp, -- comp_typ (tmp)._record_controller.f) ! if Needs_Finalization (Comp_Type) and then not Is_Limited_Type (Comp_Type) then Append_List_To (L, *************** package body Exp_Aggr is *** 3079,3088 **** -- abstract interfaces we must also initialize the tags of the -- secondary dispatch tables. ! if Present (Abstract_Interfaces (Base_Type (Typ))) ! and then not ! Is_Empty_Elmt_List (Abstract_Interfaces (Base_Type (Typ))) ! then Init_Secondary_Tags (Typ => Base_Type (Typ), Target => Target, --- 3142,3148 ---- -- abstract interfaces we must also initialize the tags of the -- secondary dispatch tables. ! if Has_Interfaces (Base_Type (Typ)) then Init_Secondary_Tags (Typ => Base_Type (Typ), Target => Target, *************** package body Exp_Aggr is *** 3312,3319 **** and then Ekind (Current_Scope) /= E_Return_Statement and then not Is_Limited_Type (Typ) then ! Establish_Transient_Scope (Aggr, Sec_Stack => ! Is_Controlled (Typ) or else Has_Controlled_Component (Typ)); end if; Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj)); --- 3372,3381 ---- and then Ekind (Current_Scope) /= E_Return_Statement and then not Is_Limited_Type (Typ) then ! Establish_Transient_Scope ! (Aggr, ! Sec_Stack => ! Is_Controlled (Typ) or else Has_Controlled_Component (Typ)); end if; Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj)); *************** package body Exp_Aggr is *** 3830,3836 **** -- assignments to the target anyway, but it is conceivable that -- it will eventually be able to treat such aggregates statically??? ! if Aggr_Size_OK (Typ) and then Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ))) then if Static_Components then --- 3892,3898 ---- -- assignments to the target anyway, but it is conceivable that -- it will eventually be able to treat such aggregates statically??? ! if Aggr_Size_OK (N, Typ) and then Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ))) then if Static_Components then *************** package body Exp_Aggr is *** 4041,4047 **** -- Aggr_Lo <= Aggr_Hi and then -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)] ! -- As an optimization try to see if some tests are trivially vacuos -- because we are comparing an expression against itself. if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then --- 4103,4109 ---- -- Aggr_Lo <= Aggr_Hi and then -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)] ! -- As an optimization try to see if some tests are trivially vacuous -- because we are comparing an expression against itself. if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then *************** package body Exp_Aggr is *** 4672,4677 **** --- 4734,4741 ---- Make_Raise_Constraint_Error (Loc, Condition => Cond, Reason => CE_Length_Check_Failed)); + -- Questionable reason code, shouldn't that be a + -- CE_Range_Check_Failed ??? end if; -- Now look inside the sub-aggregate to see if there is more work *************** package body Exp_Aggr is *** 4897,4903 **** or else Parent_Kind = N_Extension_Aggregate or else Parent_Kind = N_Component_Association or else (Parent_Kind = N_Object_Declaration ! and then Controlled_Type (Typ)) or else (Parent_Kind = N_Assignment_Statement and then Inside_Init_Proc) then --- 4961,4967 ---- or else Parent_Kind = N_Extension_Aggregate or else Parent_Kind = N_Component_Association or else (Parent_Kind = N_Object_Declaration ! and then Needs_Finalization (Typ)) or else (Parent_Kind = N_Assignment_Statement and then Inside_Init_Proc) then *************** package body Exp_Aggr is *** 4953,4958 **** --- 5017,5029 ---- and then In_Place_Assign_OK); end if; + -- If this is an array of tasks, it will be expanded into build-in- + -- -place assignments. Build an activation chain for the tasks now + + if Has_Task (Etype (N)) then + Build_Activation_Chain_Entity (N); + end if; + if not Has_Default_Init_Comps (N) and then Comes_From_Source (Parent (N)) and then Nkind (Parent (N)) = N_Object_Declaration *************** package body Exp_Aggr is *** 5369,5375 **** -- If the tagged types covers interface types we need to initialize all -- hidden components containing pointers to secondary dispatch tables. ! elsif Is_Tagged_Type (Typ) and then Has_Abstract_Interfaces (Typ) then Convert_To_Assignments (N, Typ); -- If some components are mutable, the size of the aggregate component --- 5440,5446 ---- -- If the tagged types covers interface types we need to initialize all -- hidden components containing pointers to secondary dispatch tables. ! elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then Convert_To_Assignments (N, Typ); -- If some components are mutable, the size of the aggregate component *************** package body Exp_Aggr is *** 6341,6347 **** else -- The aggregate is static if all components are literals, or -- else all its components are static aggregates for the ! -- component type. if Is_Array_Type (Comp_Type) or else Is_Record_Type (Comp_Type) --- 6412,6419 ---- else -- The aggregate is static if all components are literals, or -- else all its components are static aggregates for the ! -- component type. We also limit the size of a static aggregate ! -- to prevent runaway static expressions. if Is_Array_Type (Comp_Type) or else Is_Record_Type (Comp_Type) *************** package body Exp_Aggr is *** 6355,6360 **** --- 6427,6435 ---- elsif Nkind (Expression (Expr)) /= N_Integer_Literal then return False; + + elsif not Aggr_Size_OK (N, Typ) then + return False; end if; -- Create a positional aggregate with the right number of *************** package body Exp_Aggr is *** 6366,6372 **** loop Append_To (Expressions (Agg), New_Copy (Expression (Expr))); ! Set_Etype (Last (Expressions (Agg)), Component_Type (Typ)); end loop; Set_Aggregate_Bounds (Agg, Bounds); --- 6441,6453 ---- loop Append_To (Expressions (Agg), New_Copy (Expression (Expr))); ! ! -- The copied expression must be analyzed and resolved. ! -- Besides setting the type, this ensures that static ! -- expressions are appropriately marked as such. ! ! Analyze_And_Resolve ! (Last (Expressions (Agg)), Component_Type (Typ)); end loop; Set_Aggregate_Bounds (Agg, Bounds); *************** package body Exp_Aggr is *** 6383,6386 **** --- 6464,6468 ---- return False; end if; end Static_Array_Aggregate; + end Exp_Aggr; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_atag.adb gcc-4.4.0/gcc/ada/exp_atag.adb *** gcc-4.3.3/gcc/ada/exp_atag.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_atag.adb Tue Apr 8 06:47:55 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2008, 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- -- *************** *** 26,34 **** --- 26,36 ---- with Einfo; use Einfo; with Elists; use Elists; with Exp_Util; use Exp_Util; + with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Rtsfind; use Rtsfind; + with Sinfo; use Sinfo; with Sem_Util; use Sem_Util; with Stand; use Stand; with Snames; use Snames; *************** package body Exp_Atag is *** 57,71 **** -- Generate: To_Type_Specific_Data_Ptr -- (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all); - function Build_Predef_Prims - (Loc : Source_Ptr; - Tag_Node : Node_Id) return Node_Id; - -- Build code that retrieves the address of the dispatch table containing - -- the predefined Ada primitives: - -- - -- Generate: To_Predef_Prims_Table_Ptr - -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all); - ------------------------------------------------ -- Build_Common_Dispatching_Select_Statements -- ------------------------------------------------ --- 59,64 ---- *************** package body Exp_Atag is *** 239,248 **** Position : Uint) return Node_Id is begin return Make_Indexed_Component (Loc, Prefix => ! Build_Predef_Prims (Loc, Tag_Node), Expressions => New_List (Make_Integer_Literal (Loc, Position))); end Build_Get_Predefined_Prim_Op_Address; --- 232,264 ---- Position : Uint) return Node_Id is begin + -- Build code that retrieves the address of the dispatch table + -- containing the predefined Ada primitives: + -- + -- Generate: + -- To_Predef_Prims_Table_Ptr + -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all); + return Make_Indexed_Component (Loc, Prefix => ! Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), ! Make_Explicit_Dereference (Loc, ! Unchecked_Convert_To (RTE (RE_Addr_Ptr), ! Make_Function_Call (Loc, ! Name => ! Make_Expanded_Name (Loc, ! Chars => Name_Op_Subtract, ! Prefix => ! New_Reference_To ! (RTU_Entity (System_Storage_Elements), Loc), ! Selector_Name => ! Make_Identifier (Loc, ! Chars => Name_Op_Subtract)), ! Parameter_Associations => New_List ( ! Unchecked_Convert_To (RTE (RE_Address), Tag_Node), ! New_Reference_To (RTE (RE_DT_Predef_Prims_Offset), ! Loc)))))), Expressions => New_List (Make_Integer_Literal (Loc, Position))); end Build_Get_Predefined_Prim_Op_Address; *************** package body Exp_Atag is *** 369,463 **** New_Tag_Node : Node_Id) return Node_Id is begin ! if RTE_Available (RE_DT) then ! return ! Make_Assignment_Statement (Loc, ! Name => ! Make_Slice (Loc, ! Prefix => ! Make_Explicit_Dereference (Loc, ! Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), ! Make_Selected_Component (Loc, ! Prefix => ! Build_DT (Loc, New_Tag_Node), ! Selector_Name => ! New_Reference_To ! (RTE_Record_Component (RE_Predef_Prims), Loc)))), ! Discrete_Range => Make_Range (Loc, ! Make_Integer_Literal (Loc, Uint_1), ! New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))), ! ! Expression => ! Make_Slice (Loc, ! Prefix => ! Make_Explicit_Dereference (Loc, ! Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), ! Make_Selected_Component (Loc, ! Prefix => ! Build_DT (Loc, Old_Tag_Node), ! Selector_Name => ! New_Reference_To ! (RTE_Record_Component (RE_Predef_Prims), Loc)))), ! ! Discrete_Range => ! Make_Range (Loc, ! Low_Bound => Make_Integer_Literal (Loc, 1), ! High_Bound => ! New_Reference_To (RTE (RE_Max_Predef_Prims), Loc)))); ! else ! return ! Make_Assignment_Statement (Loc, ! Name => ! Make_Slice (Loc, ! Prefix => ! Make_Explicit_Dereference (Loc, ! Build_Predef_Prims (Loc, New_Tag_Node)), ! Discrete_Range => Make_Range (Loc, ! Make_Integer_Literal (Loc, Uint_1), ! New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))), ! Expression => ! Make_Slice (Loc, ! Prefix => ! Make_Explicit_Dereference (Loc, ! Build_Predef_Prims (Loc, Old_Tag_Node)), ! Discrete_Range => ! Make_Range (Loc, ! Low_Bound => Make_Integer_Literal (Loc, 1), ! High_Bound => ! New_Reference_To (RTE (RE_Max_Predef_Prims), Loc)))); ! end if; end Build_Inherit_Predefined_Prims; ! ------------------------ ! -- Build_Predef_Prims -- ! ------------------------ ! function Build_Predef_Prims ! (Loc : Source_Ptr; ! Tag_Node : Node_Id) return Node_Id is begin ! return ! Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), ! Make_Explicit_Dereference (Loc, ! Unchecked_Convert_To (RTE (RE_Addr_Ptr), ! Make_Function_Call (Loc, ! Name => ! Make_Expanded_Name (Loc, ! Chars => Name_Op_Subtract, ! Prefix => ! New_Reference_To ! (RTU_Entity (System_Storage_Elements), Loc), ! Selector_Name => ! Make_Identifier (Loc, ! Chars => Name_Op_Subtract)), ! Parameter_Associations => New_List ( ! Unchecked_Convert_To (RTE (RE_Address), Tag_Node), ! New_Reference_To (RTE (RE_DT_Predef_Prims_Offset), ! Loc)))))); ! end Build_Predef_Prims; ------------------------------------------ -- Build_Set_Predefined_Prim_Op_Address -- --- 385,449 ---- New_Tag_Node : Node_Id) return Node_Id is begin ! return ! Make_Assignment_Statement (Loc, ! Name => ! Make_Slice (Loc, ! Prefix => ! Make_Explicit_Dereference (Loc, ! Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), ! Make_Explicit_Dereference (Loc, ! Unchecked_Convert_To (RTE (RE_Addr_Ptr), ! New_Tag_Node)))), ! Discrete_Range => Make_Range (Loc, ! Make_Integer_Literal (Loc, Uint_1), ! New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))), ! Expression => ! Make_Slice (Loc, ! Prefix => ! Make_Explicit_Dereference (Loc, ! Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), ! Make_Explicit_Dereference (Loc, ! Unchecked_Convert_To (RTE (RE_Addr_Ptr), ! Old_Tag_Node)))), ! Discrete_Range => ! Make_Range (Loc, ! Make_Integer_Literal (Loc, 1), ! New_Reference_To (RTE (RE_Max_Predef_Prims), Loc)))); end Build_Inherit_Predefined_Prims; ! ------------------------- ! -- Build_Offset_To_Top -- ! ------------------------- ! function Build_Offset_To_Top ! (Loc : Source_Ptr; ! This_Node : Node_Id) return Node_Id is + Tag_Node : Node_Id; + begin ! Tag_Node := ! Make_Explicit_Dereference (Loc, ! Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node)); ! return ! Make_Explicit_Dereference (Loc, ! Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr), ! Make_Function_Call (Loc, ! Name => ! Make_Expanded_Name (Loc, ! Chars => Name_Op_Subtract, ! Prefix => New_Reference_To ! (RTU_Entity (System_Storage_Elements), Loc), ! Selector_Name => Make_Identifier (Loc, ! Chars => Name_Op_Subtract)), ! Parameter_Associations => New_List ( ! Unchecked_Convert_To (RTE (RE_Address), Tag_Node), ! New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset), ! Loc))))); ! end Build_Offset_To_Top; ------------------------------------------ -- Build_Set_Predefined_Prim_Op_Address -- *************** package body Exp_Atag is *** 472,479 **** begin return Make_Assignment_Statement (Loc, ! Name => Build_Get_Predefined_Prim_Op_Address (Loc, ! Tag_Node, Position), Expression => Address_Node); end Build_Set_Predefined_Prim_Op_Address; --- 458,472 ---- begin return Make_Assignment_Statement (Loc, ! Name => ! Make_Indexed_Component (Loc, ! Prefix => ! Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), ! Make_Explicit_Dereference (Loc, ! Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))), ! Expressions => ! New_List (Make_Integer_Literal (Loc, Position))), ! Expression => Address_Node); end Build_Set_Predefined_Prim_Op_Address; *************** package body Exp_Atag is *** 496,501 **** --- 489,548 ---- Expression => Address_Node); end Build_Set_Prim_Op_Address; + ----------------------------- + -- Build_Set_Size_Function -- + ----------------------------- + + function Build_Set_Size_Function + (Loc : Source_Ptr; + Tag_Node : Node_Id; + Size_Func : Entity_Id) return Node_Id is + begin + pragma Assert (Chars (Size_Func) = Name_uSize + and then RTE_Record_Component_Available (RE_Size_Func)); + return + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Build_TSD (Loc, Tag_Node), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Size_Func), Loc)), + Expression => + Unchecked_Convert_To (RTE (RE_Size_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Size_Func, Loc), + Attribute_Name => Name_Unrestricted_Access))); + end Build_Set_Size_Function; + + ------------------------------------ + -- Build_Set_Static_Offset_To_Top -- + ------------------------------------ + + function Build_Set_Static_Offset_To_Top + (Loc : Source_Ptr; + Iface_Tag : Node_Id; + Offset_Value : Node_Id) return Node_Id is + begin + return + Make_Assignment_Statement (Loc, + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr), + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Subtract, + Prefix => New_Reference_To + (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => Make_Identifier (Loc, + Chars => Name_Op_Subtract)), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), Iface_Tag), + New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset), + Loc))))), + Offset_Value); + end Build_Set_Static_Offset_To_Top; + --------------- -- Build_TSD -- --------------- diff -Nrcpad gcc-4.3.3/gcc/ada/exp_atag.ads gcc-4.4.0/gcc/ada/exp_atag.ads *** gcc-4.3.3/gcc/ada/exp_atag.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_atag.ads Tue Apr 8 06:47:55 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2008, 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- -- *************** package Exp_Atag is *** 90,104 **** -- Generates: TSD (Tag).Transportable; function Build_Inherit_Predefined_Prims ! (Loc : Source_Ptr; ! Old_Tag_Node : Node_Id; ! New_Tag_Node : Node_Id) return Node_Id; -- Build code that inherits the predefined primitives of the parent. -- -- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) := -- Predefined_DT (Old_T).D (All_Predefined_Prims); -- ! -- Required to build the dispatch tables with the 3.4 backend. function Build_Inherit_Prims (Loc : Source_Ptr; --- 90,105 ---- -- Generates: TSD (Tag).Transportable; function Build_Inherit_Predefined_Prims ! (Loc : Source_Ptr; ! Old_Tag_Node : Node_Id; ! New_Tag_Node : Node_Id) return Node_Id; -- Build code that inherits the predefined primitives of the parent. -- -- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) := -- Predefined_DT (Old_T).D (All_Predefined_Prims); -- ! -- Required to build non-library level dispatch tables. Also required ! -- when compiling without static dispatch tables support. function Build_Inherit_Prims (Loc : Source_Ptr; *************** package Exp_Atag is *** 116,121 **** --- 117,135 ---- -- New_Tag.Prims_Ptr (1 .. Num_Prims) := -- Old_Tag.Prims_Ptr (1 .. Num_Prims); + function Build_Offset_To_Top + (Loc : Source_Ptr; + This_Node : Node_Id) return Node_Id; + -- Build code that references the Offset_To_Top component of the primary + -- or secondary dispatch table associated with This_Node. This subprogram + -- provides a subset of the functionality provided by the function + -- Offset_To_Top of package Ada.Tags, and is only called by the frontend + -- when such routine is not available in a configurable runtime. + -- + -- Generates: + -- Offset_To_Top_Ptr + -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset) + function Build_Set_Predefined_Prim_Op_Address (Loc : Source_Ptr; Tag_Node : Node_Id; *************** package Exp_Atag is *** 144,147 **** --- 158,180 ---- -- -- Generates: Tag.D (Position) := Value + function Build_Set_Size_Function + (Loc : Source_Ptr; + Tag_Node : Node_Id; + Size_Func : Entity_Id) return Node_Id; + -- Build code that saves in the TSD the address of the function + -- calculating _size of the object. + + function Build_Set_Static_Offset_To_Top + (Loc : Source_Ptr; + Iface_Tag : Node_Id; + Offset_Value : Node_Id) return Node_Id; + -- Build code that initialize the Offset_To_Top component of the + -- secondary dispatch table referenced by Iface_Tag. + -- + -- Generates: + -- Offset_To_Top_Ptr + -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset).all + -- := Offset_Value + end Exp_Atag; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_attr.adb gcc-4.4.0/gcc/ada/exp_attr.adb *** gcc-4.3.3/gcc/ada/exp_attr.adb Wed Dec 19 16:23:09 2007 --- gcc-4.4.0/gcc/ada/exp_attr.adb Thu Apr 9 23:23:07 2009 *************** *** 6,23 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,23 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- ! -- -- ! -- You should have received a copy of the GNU General Public License along -- ! -- with this program; see file COPYING3. If not see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** with Einfo; use Einfo; *** 30,42 **** --- 30,46 ---- with Elists; use Elists; with Exp_Atag; use Exp_Atag; with Exp_Ch2; use Exp_Ch2; + with Exp_Ch3; use Exp_Ch3; + with Exp_Ch6; use Exp_Ch6; with Exp_Ch9; use Exp_Ch9; + with Exp_Dist; use Exp_Dist; with Exp_Imgv; use Exp_Imgv; with Exp_Pakd; use Exp_Pakd; with Exp_Strm; use Exp_Strm; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Exp_VFpt; use Exp_VFpt; + with Fname; use Fname; with Freeze; use Freeze; with Gnatvsn; use Gnatvsn; with Itypes; use Itypes; *************** with Restrict; use Restrict; *** 49,54 **** --- 53,59 ---- with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; + with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; *************** package body Exp_Attr is *** 250,261 **** function May_Be_External_Call return Boolean is Subp : Entity_Id; begin ! if (Nkind (Parent (N)) = N_Procedure_Call_Statement ! or else Nkind (Parent (N)) = N_Function_Call) ! and then Is_Entity_Name (Name (Parent (N))) then ! Subp := Entity (Name (Parent (N))); return not In_Open_Scopes (Scope (Subp)); else return False; --- 255,274 ---- function May_Be_External_Call return Boolean is Subp : Entity_Id; + Par : Node_Id := Parent (N); + begin ! -- Account for the case where the Access attribute is part of a ! -- named parameter association. ! ! if Nkind (Par) = N_Parameter_Association then ! Par := Parent (Par); ! end if; ! ! if Nkind_In (Par, N_Procedure_Call_Statement, N_Function_Call) ! and then Is_Entity_Name (Name (Par)) then ! Subp := Entity (Name (Par)); return not In_Open_Scopes (Scope (Subp)); else return False; *************** package body Exp_Attr is *** 271,278 **** -- current enclosing operation. if Is_Entity_Name (Pref) then - pragma Assert (In_Open_Scopes (Scope (Entity (Pref)))); - if May_Be_External_Call then Sub := New_Occurrence_Of --- 284,289 ---- *************** package body Exp_Attr is *** 283,292 **** (Protected_Body_Subprogram (Entity (Pref)), Loc); end if; Curr := Current_Scope; ! while Scope (Curr) /= Scope (Entity (Pref)) loop ! Curr := Scope (Curr); ! end loop; -- In case of protected entries the first formal of its Protected_ -- Body_Subprogram is the address of the object. --- 294,311 ---- (Protected_Body_Subprogram (Entity (Pref)), Loc); end if; + -- Don't traverse the scopes when the attribute occurs within an init + -- proc, because we directly use the _init formal of the init proc in + -- that case. + Curr := Current_Scope; ! if not Is_Init_Proc (Curr) then ! pragma Assert (In_Open_Scopes (Scope (Entity (Pref)))); ! ! while Scope (Curr) /= Scope (Entity (Pref)) loop ! Curr := Scope (Curr); ! end loop; ! end if; -- In case of protected entries the first formal of its Protected_ -- Body_Subprogram is the address of the object. *************** package body Exp_Attr is *** 297,302 **** --- 316,330 ---- (First_Formal (Protected_Body_Subprogram (Curr)), Loc); + -- If the current scope is an init proc, then use the address of the + -- _init formal as the object reference. + + elsif Is_Init_Proc (Curr) then + Obj_Ref := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (First_Formal (Curr), Loc), + Attribute_Name => Name_Address); + -- In case of protected subprograms the first formal of its -- Protected_Body_Subprogram is the object and we get its address. *************** package body Exp_Attr is *** 463,468 **** --- 491,497 ---- Typ : constant Entity_Id := Etype (N); Btyp : constant Entity_Id := Base_Type (Typ); Pref : constant Node_Id := Prefix (N); + Ptyp : constant Entity_Id := Etype (Pref); Exprs : constant List_Id := Expressions (N); Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); *************** package body Exp_Attr is *** 578,587 **** begin -- Do required validity checking, if enabled. Do not apply check to -- output parameters of an Asm instruction, since the value of this ! -- is not set till after the attribute has been elaborated. if Validity_Checks_On and then Validity_Check_Operands and then Id /= Attribute_Asm_Output then declare Expr : Node_Id; --- 607,620 ---- begin -- Do required validity checking, if enabled. Do not apply check to -- output parameters of an Asm instruction, since the value of this ! -- is not set till after the attribute has been elaborated, and do ! -- not apply the check to the arguments of a 'Read or 'Input attribute ! -- reference since the scalar argument is an OUT scalar. if Validity_Checks_On and then Validity_Check_Operands and then Id /= Attribute_Asm_Output + and then Id /= Attribute_Read + and then Id /= Attribute_Input then declare Expr : Node_Id; *************** package body Exp_Attr is *** 594,599 **** --- 627,653 ---- end; end if; + -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in- + -- place function, then a temporary return object needs to be created + -- and access to it must be passed to the function. Currently we limit + -- such functions to those with inherently limited result subtypes, but + -- eventually we plan to expand the functions that are treated as + -- build-in-place to include other composite result types. + + if Ada_Version >= Ada_05 + and then Is_Build_In_Place_Function_Call (Pref) + then + Make_Build_In_Place_Call_In_Anonymous_Context (Pref); + end if; + + -- If prefix is a protected type name, this is a reference to + -- the current instance of the type. + + if Is_Protected_Self_Reference (Pref) then + Rewrite (Pref, Concurrent_Ref (Pref)); + Analyze (Pref); + end if; + -- Remaining processing depends on specific attribute case Id is *************** package body Exp_Attr is *** 607,616 **** Attribute_Unrestricted_Access => Access_Cases : declare - Btyp_DDT : constant Entity_Id := Directly_Designated_Type (Btyp); Ref_Object : constant Node_Id := Get_Referenced_Object (Pref); begin if Is_Access_Protected_Subprogram_Type (Btyp) then Expand_Access_To_Protected_Op (N, Pref, Typ); --- 661,805 ---- Attribute_Unrestricted_Access => Access_Cases : declare Ref_Object : constant Node_Id := Get_Referenced_Object (Pref); + Btyp_DDT : Entity_Id; + + function Enclosing_Object (N : Node_Id) return Node_Id; + -- If N denotes a compound name (selected component, indexed + -- component, or slice), returns the name of the outermost + -- such enclosing object. Otherwise returns N. If the object + -- is a renaming, then the renamed object is returned. + + ---------------------- + -- Enclosing_Object -- + ---------------------- + + function Enclosing_Object (N : Node_Id) return Node_Id is + Obj_Name : Node_Id; + + begin + Obj_Name := N; + while Nkind_In (Obj_Name, N_Selected_Component, + N_Indexed_Component, + N_Slice) + loop + Obj_Name := Prefix (Obj_Name); + end loop; + + return Get_Referenced_Object (Obj_Name); + end Enclosing_Object; + + -- Local declarations + + Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object); + + -- Start of processing for Access_Cases begin + Btyp_DDT := Designated_Type (Btyp); + + -- Handle designated types that come from the limited view + + if Ekind (Btyp_DDT) = E_Incomplete_Type + and then From_With_Type (Btyp_DDT) + and then Present (Non_Limited_View (Btyp_DDT)) + then + Btyp_DDT := Non_Limited_View (Btyp_DDT); + + elsif Is_Class_Wide_Type (Btyp_DDT) + and then Ekind (Etype (Btyp_DDT)) = E_Incomplete_Type + and then From_With_Type (Etype (Btyp_DDT)) + and then Present (Non_Limited_View (Etype (Btyp_DDT))) + and then Present (Class_Wide_Type + (Non_Limited_View (Etype (Btyp_DDT)))) + then + Btyp_DDT := + Class_Wide_Type (Non_Limited_View (Etype (Btyp_DDT))); + end if; + + -- In order to improve the text of error messages, the designated + -- type of access-to-subprogram itypes is set by the semantics as + -- the associated subprogram entity (see sem_attr). Now we replace + -- such node with the proper E_Subprogram_Type itype. + + if Id = Attribute_Unrestricted_Access + and then Is_Subprogram (Directly_Designated_Type (Typ)) + then + -- The following conditions ensure that this special management + -- is done only for "Address!(Prim'Unrestricted_Access)" nodes. + -- At this stage other cases in which the designated type is + -- still a subprogram (instead of an E_Subprogram_Type) are + -- wrong because the semantics must have overridden the type of + -- the node with the type imposed by the context. + + if Nkind (Parent (N)) = N_Unchecked_Type_Conversion + and then Etype (Parent (N)) = RTE (RE_Prim_Ptr) + then + Set_Etype (N, RTE (RE_Prim_Ptr)); + + else + declare + Subp : constant Entity_Id := + Directly_Designated_Type (Typ); + Etyp : Entity_Id; + Extra : Entity_Id := Empty; + New_Formal : Entity_Id; + Old_Formal : Entity_Id := First_Formal (Subp); + Subp_Typ : Entity_Id; + + begin + Subp_Typ := Create_Itype (E_Subprogram_Type, N); + Set_Etype (Subp_Typ, Etype (Subp)); + Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); + + if Present (Old_Formal) then + New_Formal := New_Copy (Old_Formal); + Set_First_Entity (Subp_Typ, New_Formal); + + loop + Set_Scope (New_Formal, Subp_Typ); + Etyp := Etype (New_Formal); + + -- Handle itypes. There is no need to duplicate + -- here the itypes associated with record types + -- (i.e the implicit full view of private types). + + if Is_Itype (Etyp) + and then Ekind (Base_Type (Etyp)) /= E_Record_Type + then + Extra := New_Copy (Etyp); + Set_Parent (Extra, New_Formal); + Set_Etype (New_Formal, Extra); + Set_Scope (Extra, Subp_Typ); + end if; + + Extra := New_Formal; + Next_Formal (Old_Formal); + exit when No (Old_Formal); + + Set_Next_Entity (New_Formal, + New_Copy (Old_Formal)); + Next_Entity (New_Formal); + end loop; + + Set_Next_Entity (New_Formal, Empty); + Set_Last_Entity (Subp_Typ, Extra); + end if; + + -- Now that the explicit formals have been duplicated, + -- any extra formals needed by the subprogram must be + -- created. + + if Present (Extra) then + Set_Extra_Formal (Extra, Empty); + end if; + + Create_Extra_Formals (Subp_Typ); + Set_Directly_Designated_Type (Typ, Subp_Typ); + end; + end if; + end if; + if Is_Access_Protected_Subprogram_Type (Btyp) then Expand_Access_To_Protected_Op (N, Pref, Typ); *************** package body Exp_Attr is *** 676,710 **** end; -- If the prefix of an Access attribute is a dereference of an ! -- access parameter (or a renaming of such a dereference) and ! -- the context is a general access type (but not an anonymous ! -- access type), then rewrite the attribute as a conversion of ! -- the access parameter to the context access type. This will ! -- result in an accessibility check being performed, if needed. ! ! -- (X.all'Access => Acc_Type (X)) ! ! -- Note: Limit the expansion of an attribute applied to a ! -- dereference of an access parameter so that it's only done ! -- for 'Access. This fixes a problem with 'Unrestricted_Access ! -- that leads to errors in the case where the attribute type ! -- is access-to-variable and the access parameter is ! -- access-to-constant. The conversion is only done to get ! -- accessibility checks, so it makes sense to limit it to ! -- 'Access. ! elsif Nkind (Ref_Object) = N_Explicit_Dereference ! and then Is_Entity_Name (Prefix (Ref_Object)) and then Ekind (Btyp) = E_General_Access_Type ! and then Ekind (Entity (Prefix (Ref_Object))) in Formal_Kind ! and then Ekind (Etype (Entity (Prefix (Ref_Object)))) = E_Anonymous_Access_Type and then Present (Extra_Accessibility ! (Entity (Prefix (Ref_Object)))) then ! Rewrite (N, ! Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)))); ! Analyze_And_Resolve (N, Typ); -- Ada 2005 (AI-251): If the designated type is an interface we -- add an implicit conversion to force the displacement of the --- 865,895 ---- end; -- If the prefix of an Access attribute is a dereference of an ! -- access parameter (or a renaming of such a dereference, or a ! -- subcomponent of such a dereference) and the context is a ! -- general access type (but not an anonymous access type), then ! -- apply an accessibility check to the access parameter. We used ! -- to rewrite the access parameter as a type conversion, but that ! -- could only be done if the immediate prefix of the Access ! -- attribute was the dereference, and didn't handle cases where ! -- the attribute is applied to a subcomponent of the dereference, ! -- since there's generally no available, appropriate access type ! -- to convert to in that case. The attribute is passed as the ! -- point to insert the check, because the access parameter may ! -- come from a renaming, possibly in a different scope, and the ! -- check must be associated with the attribute itself. ! elsif Id = Attribute_Access ! and then Nkind (Enc_Object) = N_Explicit_Dereference ! and then Is_Entity_Name (Prefix (Enc_Object)) and then Ekind (Btyp) = E_General_Access_Type ! and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind ! and then Ekind (Etype (Entity (Prefix (Enc_Object)))) = E_Anonymous_Access_Type and then Present (Extra_Accessibility ! (Entity (Prefix (Enc_Object)))) then ! Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N); -- Ada 2005 (AI-251): If the designated type is an interface we -- add an implicit conversion to force the displacement of the *************** package body Exp_Attr is *** 722,732 **** if Btyp_DDT /= Etype (Ref_Object) then Rewrite (Prefix (N), ! Convert_To (Directly_Designated_Type (Typ), New_Copy_Tree (Prefix (N)))); ! Analyze_And_Resolve (Prefix (N), ! Directly_Designated_Type (Typ)); end if; -- When the object is an explicit dereference, convert the --- 907,916 ---- if Btyp_DDT /= Etype (Ref_Object) then Rewrite (Prefix (N), ! Convert_To (Btyp_DDT, New_Copy_Tree (Prefix (N)))); ! Analyze_And_Resolve (Prefix (N), Btyp_DDT); end if; -- When the object is an explicit dereference, convert the *************** package body Exp_Attr is *** 781,792 **** if Is_Entity_Name (Pref) and then Is_Task_Type (Entity (Pref)) then ! Task_Proc := Next_Entity (Root_Type (Etype (Pref))); while Present (Task_Proc) loop exit when Ekind (Task_Proc) = E_Procedure and then Etype (First_Formal (Task_Proc)) = ! Corresponding_Record_Type (Etype (Pref)); Next_Entity (Task_Proc); end loop; --- 965,976 ---- if Is_Entity_Name (Pref) and then Is_Task_Type (Entity (Pref)) then ! Task_Proc := Next_Entity (Root_Type (Ptyp)); while Present (Task_Proc) loop exit when Ekind (Task_Proc) = E_Procedure and then Etype (First_Formal (Task_Proc)) = ! Corresponding_Record_Type (Ptyp); Next_Entity (Task_Proc); end loop; *************** package body Exp_Attr is *** 808,815 **** External_Subprogram (Entity (Selector_Name (Pref))), Loc)); elsif Nkind (Pref) = N_Explicit_Dereference ! and then Ekind (Etype (Pref)) = E_Subprogram_Type ! and then Convention (Etype (Pref)) = Convention_Protected then -- The prefix is be a dereference of an access_to_protected_ -- subprogram. The desired address is the second component of --- 992,999 ---- External_Subprogram (Entity (Selector_Name (Pref))), Loc)); elsif Nkind (Pref) = N_Explicit_Dereference ! and then Ekind (Ptyp) = E_Subprogram_Type ! and then Convention (Ptyp) = Convention_Protected then -- The prefix is be a dereference of an access_to_protected_ -- subprogram. The desired address is the second component of *************** package body Exp_Attr is *** 841,848 **** -- This processing is not needed in the VM case, where dispatching -- issues are taken care of by the virtual machine. ! elsif Is_Class_Wide_Type (Etype (Pref)) ! and then Is_Interface (Etype (Pref)) and then VM_Target = No_VM and then not (Nkind (Pref) in N_Has_Entity and then Is_Subprogram (Entity (Pref))) --- 1025,1032 ---- -- This processing is not needed in the VM case, where dispatching -- issues are taken care of by the virtual machine. ! elsif Is_Class_Wide_Type (Ptyp) ! and then Is_Interface (Ptyp) and then VM_Target = No_VM and then not (Nkind (Pref) in N_Has_Entity and then Is_Subprogram (Entity (Pref))) *************** package body Exp_Attr is *** 856,862 **** return; end if; ! -- Deal with packed array reference, other cases are handled by gigi if Involves_Packed_Array_Reference (Pref) then Expand_Packed_Address_Reference (N); --- 1040,1047 ---- return; end if; ! -- Deal with packed array reference, other cases are handled by ! -- the back end. if Involves_Packed_Array_Reference (Pref) then Expand_Packed_Address_Reference (N); *************** package body Exp_Attr is *** 868,874 **** --------------- when Attribute_Alignment => Alignment : declare - Ptyp : constant Entity_Id := Etype (Pref); New_Node : Node_Id; begin --- 1053,1058 ---- *************** package body Exp_Attr is *** 993,1001 **** -- Bit_Position -- ------------------ ! -- We compute this if a component clause was present, otherwise ! -- we leave the computation up to Gigi, since we don't know what ! -- layout will be chosen. -- Note that the attribute can apply to a naked record component -- in generated code (i.e. the prefix is an identifier that --- 1177,1185 ---- -- Bit_Position -- ------------------ ! -- We compute this if a component clause was present, otherwise we leave ! -- the computation up to the back end, since we don't know what layout ! -- will be chosen. -- Note that the attribute can apply to a naked record component -- in generated code (i.e. the prefix is an identifier that *************** package body Exp_Attr is *** 1162,1170 **** -- callable (Task_Id (Pref._disp_get_task_id)); if Ada_Version >= Ada_05 ! and then Ekind (Etype (Pref)) = E_Class_Wide_Type ! and then Is_Interface (Etype (Pref)) ! and then Is_Task_Interface (Etype (Pref)) then Rewrite (N, Make_Function_Call (Loc, --- 1346,1354 ---- -- callable (Task_Id (Pref._disp_get_task_id)); if Ada_Version >= Ada_05 ! and then Ekind (Ptyp) = E_Class_Wide_Type ! and then Is_Interface (Ptyp) ! and then Is_Task_Interface (Ptyp) then Rewrite (N, Make_Function_Call (Loc, *************** package body Exp_Attr is *** 1208,1234 **** -- Protected case if Is_Protected_Type (Conctype) then ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Number_Entries (Conctype) > 1 ! then ! Name := ! New_Reference_To ! (RTE (RE_Protected_Entry_Caller), Loc); ! else ! Name := ! New_Reference_To ! (RTE (RE_Protected_Single_Entry_Caller), Loc); ! end if; Rewrite (N, Unchecked_Convert_To (Id_Kind, Make_Function_Call (Loc, Name => Name, ! Parameter_Associations => New_List ! (New_Reference_To ( ! Object_Ref ! (Corresponding_Body (Parent (Conctype))), Loc))))); -- Task case --- 1392,1419 ---- -- Protected case if Is_Protected_Type (Conctype) then ! case Corresponding_Runtime_Package (Conctype) is ! when System_Tasking_Protected_Objects_Entries => ! Name := ! New_Reference_To ! (RTE (RE_Protected_Entry_Caller), Loc); ! ! when System_Tasking_Protected_Objects_Single_Entry => ! Name := ! New_Reference_To ! (RTE (RE_Protected_Single_Entry_Caller), Loc); ! ! when others => ! raise Program_Error; ! end case; Rewrite (N, Unchecked_Convert_To (Id_Kind, Make_Function_Call (Loc, Name => Name, ! Parameter_Associations => New_List ( ! New_Reference_To ! (Find_Protection_Object (Current_Scope), Loc))))); -- Task case *************** package body Exp_Attr is *** 1258,1265 **** Rewrite (N, Unchecked_Convert_To (Id_Kind, Make_Function_Call (Loc, ! Name => New_Reference_To ( ! RTE (RE_Task_Entry_Caller), Loc), Parameter_Associations => New_List ( Make_Integer_Literal (Loc, Intval => Int (Nest_Depth)))))); --- 1443,1450 ---- Rewrite (N, Unchecked_Convert_To (Id_Kind, Make_Function_Call (Loc, ! Name => ! New_Reference_To (RTE (RE_Task_Entry_Caller), Loc), Parameter_Associations => New_List ( Make_Integer_Literal (Loc, Intval => Int (Nest_Depth)))))); *************** package body Exp_Attr is *** 1290,1296 **** when Attribute_Constrained => Constrained : declare Formal_Ent : constant Entity_Id := Param_Entity (Pref); - Typ : constant Entity_Id := Etype (Pref); function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean; -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a --- 1475,1480 ---- *************** package body Exp_Attr is *** 1309,1315 **** if Present (Renamed_Object (E)) then return Is_Constrained_Aliased_View (Renamed_Object (E)); - else return Is_Aliased (E) and then Is_Constrained (Etype (E)); end if; --- 1493,1498 ---- *************** package body Exp_Attr is *** 1385,1392 **** end if; -- If the prefix is not a variable or is aliased, then ! -- definitely true; if it's a formal parameter without ! -- an associated extra formal, then treat it as constrained. -- Ada 2005 (AI-363): An aliased prefix must be known to be -- constrained in order to set the attribute to True. --- 1568,1575 ---- end if; -- If the prefix is not a variable or is aliased, then ! -- definitely true; if it's a formal parameter without an ! -- associated extra formal, then treat it as constrained. -- Ada 2005 (AI-363): An aliased prefix must be known to be -- constrained in order to set the attribute to True. *************** package body Exp_Attr is *** 1400,1409 **** then Res := True; ! -- Variable case, just look at type to see if it is ! -- constrained. Note that the one case where this is ! -- not accurate (the procedure formal case), has been ! -- handled above. -- We use the Underlying_Type here (and below) in case the -- type is private without discriminants, but the full type --- 1583,1591 ---- then Res := True; ! -- Variable case, look at type to see if it is constrained. ! -- Note that the one case where this is not accurate (the ! -- procedure formal case), has been handled above. -- We use the Underlying_Type here (and below) in case the -- type is private without discriminants, but the full type *************** package body Exp_Attr is *** 1418,1428 **** New_Reference_To (Boolean_Literals (Res), Loc)); end; ! -- Prefix is not an entity name. These are also cases where ! -- we can always tell at compile time by looking at the form ! -- and type of the prefix. If an explicit dereference of an ! -- object with constrained partial view, this is unconstrained ! -- (Ada 2005 AI-363). else Rewrite (N, --- 1600,1609 ---- New_Reference_To (Boolean_Literals (Res), Loc)); end; ! -- Prefix is not an entity name. These are also cases where we can ! -- always tell at compile time by looking at the form and type of the ! -- prefix. If an explicit dereference of an object with constrained ! -- partial view, this is unconstrained (Ada 2005 AI-363). else Rewrite (N, *************** package body Exp_Attr is *** 1432,1439 **** or else (Nkind (Pref) = N_Explicit_Dereference and then ! not Has_Constrained_Partial_View (Base_Type (Typ))) ! or else Is_Constrained (Underlying_Type (Typ))), Loc)); end if; --- 1613,1620 ---- or else (Nkind (Pref) = N_Explicit_Dereference and then ! not Has_Constrained_Partial_View (Base_Type (Ptyp))) ! or else Is_Constrained (Underlying_Type (Ptyp))), Loc)); end if; *************** package body Exp_Attr is *** 1456,1468 **** -- Transforms 'Count attribute into a call to the Count function ! when Attribute_Count => Count : ! declare ! Entnam : Node_Id; ! Index : Node_Id; ! Name : Node_Id; ! Call : Node_Id; ! Conctyp : Entity_Id; begin -- If the prefix is a member of an entry family, retrieve both --- 1637,1649 ---- -- Transforms 'Count attribute into a call to the Count function ! when Attribute_Count => Count : declare ! Call : Node_Id; ! Conctyp : Entity_Id; ! Entnam : Node_Id; ! Entry_Id : Entity_Id; ! Index : Node_Id; ! Name : Node_Id; begin -- If the prefix is a member of an entry family, retrieve both *************** package body Exp_Attr is *** 1476,1481 **** --- 1657,1664 ---- Index := Empty; end if; + Entry_Id := Entity (Entnam); + -- Find the concurrent type in which this attribute is referenced -- (there had better be one). *************** package body Exp_Attr is *** 1487,1518 **** -- Protected case if Is_Protected_Type (Conctyp) then ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Number_Entries (Conctyp) > 1 ! then ! Name := New_Reference_To (RTE (RE_Protected_Count), Loc); ! Call := ! Make_Function_Call (Loc, ! Name => Name, ! Parameter_Associations => New_List ( ! New_Reference_To ( ! Object_Ref ( ! Corresponding_Body (Parent (Conctyp))), Loc), ! Entry_Index_Expression ( ! Loc, Entity (Entnam), Index, Scope (Entity (Entnam))))); ! else ! Name := New_Reference_To (RTE (RE_Protected_Count_Entry), Loc); ! Call := Make_Function_Call (Loc, ! Name => Name, ! Parameter_Associations => New_List ( ! New_Reference_To ( ! Object_Ref ( ! Corresponding_Body (Parent (Conctyp))), Loc))); ! end if; -- Task case --- 1670,1702 ---- -- Protected case if Is_Protected_Type (Conctyp) then + case Corresponding_Runtime_Package (Conctyp) is + when System_Tasking_Protected_Objects_Entries => + Name := New_Reference_To (RTE (RE_Protected_Count), Loc); ! Call := ! Make_Function_Call (Loc, ! Name => Name, ! Parameter_Associations => New_List ( ! New_Reference_To ! (Find_Protection_Object (Current_Scope), Loc), ! Entry_Index_Expression ! (Loc, Entry_Id, Index, Scope (Entry_Id)))); ! when System_Tasking_Protected_Objects_Single_Entry => ! Name := ! New_Reference_To (RTE (RE_Protected_Count_Entry), Loc); ! Call := ! Make_Function_Call (Loc, ! Name => Name, ! Parameter_Associations => New_List ( ! New_Reference_To ! (Find_Protection_Object (Current_Scope), Loc))); ! ! when others => ! raise Program_Error; ! end case; -- Task case *************** package body Exp_Attr is *** 1521,1528 **** Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Task_Count), Loc), Parameter_Associations => New_List ( ! Entry_Index_Expression ! (Loc, Entity (Entnam), Index, Scope (Entity (Entnam))))); end if; -- The call returns type Natural but the context is universal integer --- 1705,1712 ---- Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Task_Count), Loc), Parameter_Associations => New_List ( ! Entry_Index_Expression (Loc, ! Entry_Id, Index, Scope (Entry_Id)))); end if; -- The call returns type Natural but the context is universal integer *************** package body Exp_Attr is *** 1652,1662 **** -- Elaborated -- ---------------- ! -- Elaborated is always True for preelaborated units, predefined ! -- units, pure units and units which have Elaborate_Body pragmas. ! -- These units have no elaboration entity. ! -- Note: The Elaborated attribute is never passed through to Gigi when Attribute_Elaborated => Elaborated : declare Ent : constant Entity_Id := Entity (Pref); --- 1836,1846 ---- -- Elaborated -- ---------------- ! -- Elaborated is always True for preelaborated units, predefined units, ! -- pure units and units which have Elaborate_Body pragmas. These units ! -- have no elaboration entity. ! -- Note: The Elaborated attribute is never passed to the back end when Attribute_Elaborated => Elaborated : declare Ent : constant Entity_Id := Entity (Pref); *************** package body Exp_Attr is *** 1680,1691 **** -- target-type (Y) ! -- This is simply a direct conversion from the enumeration type ! -- to the target integer type, which is treated by Gigi as a normal ! -- integer conversion, treating the enumeration type as an integer, ! -- which is exactly what we want! We set Conversion_OK to make sure ! -- that the analyzer does not complain about what otherwise might ! -- be an illegal conversion. if Is_Non_Empty_List (Exprs) then Rewrite (N, --- 1864,1875 ---- -- target-type (Y) ! -- This is simply a direct conversion from the enumeration type to ! -- the target integer type, which is treated by the back end as a ! -- normal integer conversion, treating the enumeration type as an ! -- integer, which is exactly what we want! We set Conversion_OK to ! -- make sure that the analyzer does not complain about what otherwise ! -- might be an illegal conversion. if Is_Non_Empty_List (Exprs) then Rewrite (N, *************** package body Exp_Attr is *** 1721,1730 **** Set_Etype (N, Typ); Analyze_And_Resolve (N, Typ); - end Enum_Rep; -------------- -- Exponent -- -------------- --- 1905,1948 ---- Set_Etype (N, Typ); Analyze_And_Resolve (N, Typ); end Enum_Rep; -------------- + -- Enum_Val -- + -------------- + + when Attribute_Enum_Val => Enum_Val : declare + Expr : Node_Id; + Btyp : constant Entity_Id := Base_Type (Ptyp); + + begin + -- X'Enum_Val (Y) expands to + + -- [constraint_error when _rep_to_pos (Y, False) = -1, msg] + -- X!(Y); + + Expr := Unchecked_Convert_To (Ptyp, First (Exprs)); + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (TSS (Btyp, TSS_Rep_To_Pos), Loc), + Parameter_Associations => New_List ( + Relocate_Node (Duplicate_Subexpr (Expr)), + New_Occurrence_Of (Standard_False, Loc))), + + Right_Opnd => Make_Integer_Literal (Loc, -1)), + Reason => CE_Range_Check_Failed)); + + Rewrite (N, Expr); + Analyze_And_Resolve (N, Ptyp); + end Enum_Val; + + -------------- -- Exponent -- -------------- *************** package body Exp_Attr is *** 1757,1771 **** -- First -- ----------- ! when Attribute_First => declare ! Ptyp : constant Entity_Id := Etype (Pref); - begin -- If the prefix type is a constrained packed array type which -- already has a Packed_Array_Type representation defined, then -- replace this attribute with a direct reference to 'First of the ! -- appropriate index subtype (since otherwise Gigi will try to give ! -- us the value of 'First for this implementation type). if Is_Constrained_Packed_Array (Ptyp) then Rewrite (N, --- 1975,1987 ---- -- First -- ----------- ! when Attribute_First => -- If the prefix type is a constrained packed array type which -- already has a Packed_Array_Type representation defined, then -- replace this attribute with a direct reference to 'First of the ! -- appropriate index subtype (since otherwise the back end will try ! -- to give us the value of 'First for this implementation type). if Is_Constrained_Packed_Array (Ptyp) then Rewrite (N, *************** package body Exp_Attr is *** 1777,1794 **** elsif Is_Access_Type (Ptyp) then Apply_Access_Check (N); end if; - end; --------------- -- First_Bit -- --------------- ! -- We compute this if a component clause was present, otherwise ! -- we leave the computation up to Gigi, since we don't know what -- layout will be chosen. ! when Attribute_First_Bit => First_Bit : ! declare CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin --- 1993,2008 ---- elsif Is_Access_Type (Ptyp) then Apply_Access_Check (N); end if; --------------- -- First_Bit -- --------------- ! -- Compute this if component clause was present, otherwise we leave the ! -- computation to be completed in the back-end, since we don't know what -- layout will be chosen. ! when Attribute_First_Bit => First_Bit : declare CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin *************** package body Exp_Attr is *** 1816,1825 **** -- fixtype(integer-value) ! -- we do all the required analysis of the conversion here, because ! -- we do not want this to go through the fixed-point conversion ! -- circuits. Note that gigi always treats fixed-point as equivalent ! -- to the corresponding integer type anyway. when Attribute_Fixed_Value => Fixed_Value : begin --- 2030,2039 ---- -- fixtype(integer-value) ! -- We do all the required analysis of the conversion here, because we do ! -- not want this to go through the fixed-point conversion circuits. Note ! -- that the back end always treats fixed-point as equivalent to the ! -- corresponding integer type anyway. when Attribute_Fixed_Value => Fixed_Value : begin *************** package body Exp_Attr is *** 1863,1873 **** -- Note that we know that the type is a non-static subtype, or Fore -- would have itself been computed dynamically in Eval_Attribute. ! when Attribute_Fore => Fore : ! declare ! Ptyp : constant Entity_Id := Etype (Pref); ! ! begin Rewrite (N, Convert_To (Typ, Make_Function_Call (Loc, --- 2077,2083 ---- -- Note that we know that the type is a non-static subtype, or Fore -- would have itself been computed dynamically in Eval_Attribute. ! when Attribute_Fore => Fore : begin Rewrite (N, Convert_To (Typ, Make_Function_Call (Loc, *************** package body Exp_Attr is *** 1898,1903 **** --- 2108,2129 ---- Expand_Fpt_Attribute_R (N); -------------- + -- From_Any -- + -------------- + + when Attribute_From_Any => From_Any : declare + P_Type : constant Entity_Id := Etype (Pref); + Decls : constant List_Id := New_List; + begin + Rewrite (N, + Build_From_Any_Call (P_Type, + Relocate_Node (First (Exprs)), + Decls)); + Insert_Actions (N, Decls); + Analyze_And_Resolve (N, P_Type); + end From_Any; + + -------------- -- Identity -- -------------- *************** package body Exp_Attr is *** 1915,1921 **** Id_Kind : Entity_Id; begin ! if Etype (Pref) = Standard_Exception_Type then Id_Kind := RTE (RE_Exception_Id); if Present (Renamed_Object (Entity (Pref))) then --- 2141,2147 ---- Id_Kind : Entity_Id; begin ! if Ptyp = Standard_Exception_Type then Id_Kind := RTE (RE_Exception_Id); if Present (Renamed_Object (Entity (Pref))) then *************** package body Exp_Attr is *** 1932,1940 **** -- attributes applied to interfaces. if Ada_Version >= Ada_05 ! and then Ekind (Etype (Pref)) = E_Class_Wide_Type ! and then Is_Interface (Etype (Pref)) ! and then Is_Task_Interface (Etype (Pref)) then Rewrite (N, Unchecked_Convert_To (Id_Kind, --- 2158,2166 ---- -- attributes applied to interfaces. if Ada_Version >= Ada_05 ! and then Ekind (Ptyp) = E_Class_Wide_Type ! and then Is_Interface (Ptyp) ! and then Is_Task_Interface (Ptyp) then Rewrite (N, Unchecked_Convert_To (Id_Kind, *************** package body Exp_Attr is *** 1972,1978 **** begin Rewrite (N, Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Etype (Pref), Loc), Attribute_Name => Name_Image, Expressions => New_List (Relocate_Node (Pref)))); --- 2198,2204 ---- begin Rewrite (N, Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Image, Expressions => New_List (Relocate_Node (Pref)))); *************** package body Exp_Attr is *** 2062,2071 **** -- sourcetyp (streamread (strmtyp'Input (stream))); ! -- where stmrearead is the given Read function that converts ! -- an argument of type strmtyp to type sourcetyp or a type ! -- from which it is derived. The extra conversion is required ! -- for the derived case. Prag := Get_Stream_Convert_Pragma (P_Type); --- 2288,2296 ---- -- sourcetyp (streamread (strmtyp'Input (stream))); ! -- where streamread is the given Read function that converts an ! -- argument of type strmtyp to type sourcetyp or a type from which ! -- it is derived (extra conversion required for the derived case). Prag := Get_Stream_Convert_Pragma (P_Type); *************** package body Exp_Attr is *** 2200,2209 **** pragma Assert (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); ! -- Ada 2005 (AI-216): Program_Error is raised when executing ! -- the default implementation of the Input attribute of an ! -- unchecked union type if the type lacks default discriminant ! -- values. if Is_Unchecked_Union (Base_Type (U_Type)) and then No (Discriminant_Constraint (U_Type)) --- 2425,2433 ---- pragma Assert (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); ! -- Ada 2005 (AI-216): Program_Error is raised executing default ! -- implementation of the Input attribute of an unchecked union ! -- type if the type lacks default discriminant values. if Is_Unchecked_Union (Base_Type (U_Type)) and then No (Discriminant_Constraint (U_Type)) *************** package body Exp_Attr is *** 2278,2287 **** -- inttype(integer-value)) ! -- we do all the required analysis of the conversion here, because ! -- we do not want this to go through the fixed-point conversion ! -- circuits. Note that gigi always treats fixed-point as equivalent ! -- to the corresponding integer type anyway. when Attribute_Integer_Value => Integer_Value : begin --- 2502,2511 ---- -- inttype(integer-value)) ! -- we do all the required analysis of the conversion here, because we do ! -- not want this to go through the fixed-point conversion circuits. Note ! -- that the back end always treats fixed-point as equivalent to the ! -- corresponding integer type anyway. when Attribute_Integer_Value => Integer_Value : begin *************** package body Exp_Attr is *** 2299,2317 **** Apply_Type_Conversion_Checks (N); end Integer_Value; ---------- -- Last -- ---------- ! when Attribute_Last => declare ! Ptyp : constant Entity_Id := Etype (Pref); - begin -- If the prefix type is a constrained packed array type which -- already has a Packed_Array_Type representation defined, then -- replace this attribute with a direct reference to 'Last of the ! -- appropriate index subtype (since otherwise Gigi will try to give ! -- us the value of 'Last for this implementation type). if Is_Constrained_Packed_Array (Ptyp) then Rewrite (N, --- 2523,2546 ---- Apply_Type_Conversion_Checks (N); end Integer_Value; + ------------------- + -- Invalid_Value -- + ------------------- + + when Attribute_Invalid_Value => + Rewrite (N, Get_Simple_Init_Val (Ptyp, N)); + ---------- -- Last -- ---------- ! when Attribute_Last => -- If the prefix type is a constrained packed array type which -- already has a Packed_Array_Type representation defined, then -- replace this attribute with a direct reference to 'Last of the ! -- appropriate index subtype (since otherwise the back end will try ! -- to give us the value of 'Last for this implementation type). if Is_Constrained_Packed_Array (Ptyp) then Rewrite (N, *************** package body Exp_Attr is *** 2323,2340 **** elsif Is_Access_Type (Ptyp) then Apply_Access_Check (N); end if; - end; -------------- -- Last_Bit -- -------------- ! -- We compute this if a component clause was present, otherwise ! -- we leave the computation up to Gigi, since we don't know what ! -- layout will be chosen. ! when Attribute_Last_Bit => Last_Bit : ! declare CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin --- 2552,2567 ---- elsif Is_Access_Type (Ptyp) then Apply_Access_Check (N); end if; -------------- -- Last_Bit -- -------------- ! -- We compute this if a component clause was present, otherwise we leave ! -- the computation up to the back end, since we don't know what layout ! -- will be chosen. ! when Attribute_Last_Bit => Last_Bit : declare CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin *************** package body Exp_Attr is *** 2360,2366 **** -- Transforms 'Leading_Part into a call to the floating-point attribute -- function Leading_Part in Fat_xxx (where xxx is the root type) ! -- Note: strictly, we should have special case code to deal with -- absurdly large positive arguments (greater than Integer'Last), which -- result in returning the first argument unchanged, but it hardly seems -- worth the effort. We raise constraint error for absurdly negative --- 2587,2593 ---- -- Transforms 'Leading_Part into a call to the floating-point attribute -- function Leading_Part in Fat_xxx (where xxx is the root type) ! -- Note: strictly, we should generate special case code to deal with -- absurdly large positive arguments (greater than Integer'Last), which -- result in returning the first argument unchanged, but it hardly seems -- worth the effort. We raise constraint error for absurdly negative *************** package body Exp_Attr is *** 2374,2380 **** ------------ when Attribute_Length => declare - Ptyp : constant Entity_Id := Etype (Pref); Ityp : Entity_Id; Xnum : Uint; --- 2601,2606 ---- *************** package body Exp_Attr is *** 2384,2398 **** if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then Ityp := Get_Index_Subtype (N); ! -- If the index type, Ityp, is an enumeration type with ! -- holes, then we calculate X'Length explicitly using -- Typ'Max -- (0, Ityp'Pos (X'Last (N)) - -- Ityp'Pos (X'First (N)) + 1); ! -- Since the bounds in the template are the representation ! -- values and gigi would get the wrong value. if Is_Enumeration_Type (Ityp) and then Present (Enum_Pos_To_Rep (Base_Type (Ityp))) --- 2610,2624 ---- if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then Ityp := Get_Index_Subtype (N); ! -- If the index type, Ityp, is an enumeration type with holes, ! -- then we calculate X'Length explicitly using -- Typ'Max -- (0, Ityp'Pos (X'Last (N)) - -- Ityp'Pos (X'First (N)) + 1); ! -- Since the bounds in the template are the representation values ! -- and the back end would get the wrong value. if Is_Enumeration_Type (Ityp) and then Present (Enum_Pos_To_Rep (Base_Type (Ityp))) *************** package body Exp_Attr is *** 2446,2453 **** -- If the prefix type is a constrained packed array type which -- already has a Packed_Array_Type representation defined, then -- replace this attribute with a direct reference to 'Range_Length ! -- of the appropriate index subtype (since otherwise Gigi will try ! -- to give us the value of 'Length for this implementation type). elsif Is_Constrained (Ptyp) then Rewrite (N, --- 2672,2680 ---- -- If the prefix type is a constrained packed array type which -- already has a Packed_Array_Type representation defined, then -- replace this attribute with a direct reference to 'Range_Length ! -- of the appropriate index subtype (since otherwise the back end ! -- will try to give us the value of 'Length for this ! -- implementation type). elsif Is_Constrained (Ptyp) then Rewrite (N, *************** package body Exp_Attr is *** 2457,2479 **** Analyze_And_Resolve (N, Typ); end if; - -- If we have a packed array that is not bit packed, which was - -- Access type case elsif Is_Access_Type (Ptyp) then Apply_Access_Check (N); ! -- If the designated type is a packed array type, then we ! -- convert the reference to: -- typ'Max (0, 1 + -- xtyp'Pos (Pref'Last (Expr)) - -- xtyp'Pos (Pref'First (Expr))); ! -- This is a bit complex, but it is the easiest thing to do ! -- that works in all cases including enum types with holes ! -- xtyp here is the appropriate index type. declare Dtyp : constant Entity_Id := Designated_Type (Ptyp); --- 2684,2704 ---- Analyze_And_Resolve (N, Typ); end if; -- Access type case elsif Is_Access_Type (Ptyp) then Apply_Access_Check (N); ! -- If the designated type is a packed array type, then we convert ! -- the reference to: -- typ'Max (0, 1 + -- xtyp'Pos (Pref'Last (Expr)) - -- xtyp'Pos (Pref'First (Expr))); ! -- This is a bit complex, but it is the easiest thing to do that ! -- works in all cases including enum types with holes xtyp here ! -- is the appropriate index type. declare Dtyp : constant Entity_Id := Designated_Type (Ptyp); *************** package body Exp_Attr is *** 2520,2526 **** end if; end; ! -- Otherwise leave it to gigi else Apply_Universal_Integer_Attribute_Checks (N); --- 2745,2751 ---- end if; end; ! -- Otherwise leave it to the back end else Apply_Universal_Integer_Attribute_Checks (N); *************** package body Exp_Attr is *** 2556,2562 **** ------------------ -- Machine_Size is equivalent to Object_Size, so transform it into ! -- Object_Size and that way Gigi never sees Machine_Size. when Attribute_Machine_Size => Rewrite (N, --- 2781,2787 ---- ------------------ -- Machine_Size is equivalent to Object_Size, so transform it into ! -- Object_Size and that way the back end never sees Machine_Size. when Attribute_Machine_Size => Rewrite (N, *************** package body Exp_Attr is *** 2571,2578 **** -------------- -- The only case that can get this far is the dynamic case of the old ! -- Ada 83 Mantissa attribute for the fixed-point case. For this case, we ! -- expand: -- typ'Mantissa --- 2796,2803 ---- -------------- -- The only case that can get this far is the dynamic case of the old ! -- Ada 83 Mantissa attribute for the fixed-point case. For this case, ! -- we expand: -- typ'Mantissa *************** package body Exp_Attr is *** 2582,2591 **** -- (Integer'Integer_Value (typ'First), -- Integer'Integer_Value (typ'Last))); ! when Attribute_Mantissa => Mantissa : declare ! Ptyp : constant Entity_Id := Etype (Pref); ! ! begin Rewrite (N, Convert_To (Typ, Make_Function_Call (Loc, --- 2807,2813 ---- -- (Integer'Integer_Value (typ'First), -- Integer'Integer_Value (typ'Last))); ! when Attribute_Mantissa => Mantissa : begin Rewrite (N, Convert_To (Typ, Make_Function_Call (Loc, *************** package body Exp_Attr is *** 2664,2670 **** -- result is modulus + value, where the value might be as small as -- -modulus. The trouble is what type do we use to do the subtract. -- No type will do, since modulus can be as big as 2**64, and no ! -- integer type accomodates this value. Let's do bit of algebra -- modulus + value -- = modulus - (-value) --- 2886,2892 ---- -- result is modulus + value, where the value might be as small as -- -modulus. The trouble is what type do we use to do the subtract. -- No type will do, since modulus can be as big as 2**64, and no ! -- integer type accommodates this value. Let's do bit of algebra -- modulus + value -- = modulus - (-value) *************** package body Exp_Attr is *** 2726,2731 **** --- 2948,2993 ---- -- The processing for Object_Size shares the processing for Size + --------- + -- Old -- + --------- + + when Attribute_Old => Old : declare + Tnn : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + Subp : Node_Id; + Asn_Stm : Node_Id; + + begin + -- Find the nearest subprogram body, ignoring _Preconditions + + Subp := N; + loop + Subp := Parent (Subp); + exit when Nkind (Subp) = N_Subprogram_Body + and then Chars (Defining_Entity (Subp)) /= Name_uPostconditions; + end loop; + + -- Insert the assignment at the start of the declarations + + Asn_Stm := + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etype (N), Loc), + Expression => Pref); + + if Is_Empty_List (Declarations (Subp)) then + Set_Declarations (Subp, New_List (Asn_Stm)); + Analyze (Asn_Stm); + else + Insert_Action (First (Declarations (Subp)), Asn_Stm); + end if; + + Rewrite (N, New_Occurrence_Of (Tnn, Loc)); + end Old; + ------------ -- Output -- ------------ *************** package body Exp_Attr is *** 2941,2947 **** --------- -- For enumeration types with a standard representation, Pos is ! -- handled by Gigi. -- For enumeration types, with a non-standard representation we -- generate a call to the _Rep_To_Pos function created when the --- 3203,3209 ---- --------- -- For enumeration types with a standard representation, Pos is ! -- handled by the back end. -- For enumeration types, with a non-standard representation we -- generate a call to the _Rep_To_Pos function created when the *************** package body Exp_Attr is *** 3005,3013 **** -- Position -- -------------- ! -- We compute this if a component clause was present, otherwise ! -- we leave the computation up to Gigi, since we don't know what ! -- layout will be chosen. when Attribute_Position => Position : declare --- 3267,3275 ---- -- Position -- -------------- ! -- We compute this if a component clause was present, otherwise we leave ! -- the computation up to the back end, since we don't know what layout ! -- will be chosen. when Attribute_Position => Position : declare *************** package body Exp_Attr is *** 3035,3043 **** when Attribute_Pred => Pred : declare ! Ptyp : constant Entity_Id := Base_Type (Etype (Pref)); begin -- For enumeration types with non-standard representations, we -- expand typ'Pred (x) into --- 3297,3306 ---- when Attribute_Pred => Pred : declare ! Etyp : constant Entity_Id := Base_Type (Ptyp); begin + -- For enumeration types with non-standard representations, we -- expand typ'Pred (x) into *************** package body Exp_Attr is *** 3045,3055 **** -- If the representation is contiguous, we compute instead -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations. if Is_Enumeration_Type (Ptyp) ! and then Present (Enum_Pos_To_Rep (Ptyp)) then ! if Has_Contiguous_Rep (Ptyp) then Rewrite (N, Unchecked_Convert_To (Ptyp, Make_Op_Add (Loc, --- 3308,3321 ---- -- If the representation is contiguous, we compute instead -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations. + -- The conversion function Enum_Pos_To_Rep is defined on the + -- base type, not the subtype, so we have to use the base type + -- explicitly for this and other enumeration attributes. if Is_Enumeration_Type (Ptyp) ! and then Present (Enum_Pos_To_Rep (Etyp)) then ! if Has_Contiguous_Rep (Etyp) then Rewrite (N, Unchecked_Convert_To (Ptyp, Make_Op_Add (Loc, *************** package body Exp_Attr is *** 3060,3066 **** Make_Function_Call (Loc, Name => New_Reference_To ! (TSS (Ptyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => New_List ( --- 3326,3332 ---- Make_Function_Call (Loc, Name => New_Reference_To ! (TSS (Etyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => New_List ( *************** package body Exp_Attr is *** 3081,3093 **** Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); Rewrite (N, Make_Indexed_Component (Loc, ! Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc), Expressions => New_List ( Make_Op_Subtract (Loc, Left_Opnd => Make_Function_Call (Loc, Name => ! New_Reference_To (TSS (Ptyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => Exprs), Right_Opnd => Make_Integer_Literal (Loc, 1))))); end if; --- 3347,3362 ---- Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); Rewrite (N, Make_Indexed_Component (Loc, ! Prefix => ! New_Reference_To ! (Enum_Pos_To_Rep (Etyp), Loc), Expressions => New_List ( Make_Op_Subtract (Loc, Left_Opnd => Make_Function_Call (Loc, Name => ! New_Reference_To ! (TSS (Etyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => Exprs), Right_Opnd => Make_Integer_Literal (Loc, 1))))); end if; *************** package body Exp_Attr is *** 3176,3183 **** New_Itype := Create_Itype (E_Access_Type, N); Set_Etype (New_Itype, New_Itype); - Init_Esize (New_Itype); - Init_Size_Align (New_Itype); Set_Directly_Designated_Type (New_Itype, Corresponding_Record_Type (Conctyp)); Freeze_Itype (New_Itype, N); --- 3445,3450 ---- *************** package body Exp_Attr is *** 3243,3252 **** -- Range_Length -- ------------------ ! when Attribute_Range_Length => Range_Length : declare ! P_Type : constant Entity_Id := Etype (Pref); ! ! begin -- The only special processing required is for the case where -- Range_Length is applied to an enumeration type with holes. -- In this case we transform --- 3510,3516 ---- -- Range_Length -- ------------------ ! when Attribute_Range_Length => Range_Length : begin -- The only special processing required is for the case where -- Range_Length is applied to an enumeration type with holes. -- In this case we transform *************** package body Exp_Attr is *** 3260,3267 **** -- So that the result reflects the proper Pos values instead -- of the underlying representations. ! if Is_Enumeration_Type (P_Type) ! and then Has_Non_Standard_Rep (P_Type) then Rewrite (N, Make_Op_Add (Loc, --- 3524,3531 ---- -- So that the result reflects the proper Pos values instead -- of the underlying representations. ! if Is_Enumeration_Type (Ptyp) ! and then Has_Non_Standard_Rep (Ptyp) then Rewrite (N, Make_Op_Add (Loc, *************** package body Exp_Attr is *** 3270,3297 **** Left_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Pos, ! Prefix => New_Occurrence_Of (P_Type, Loc), Expressions => New_List ( Make_Attribute_Reference (Loc, Attribute_Name => Name_Last, ! Prefix => New_Occurrence_Of (P_Type, Loc)))), Right_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Pos, ! Prefix => New_Occurrence_Of (P_Type, Loc), Expressions => New_List ( Make_Attribute_Reference (Loc, Attribute_Name => Name_First, ! Prefix => New_Occurrence_Of (P_Type, Loc))))), Right_Opnd => Make_Integer_Literal (Loc, 1))); Analyze_And_Resolve (N, Typ); ! -- For all other cases, attribute is handled by Gigi, but we need ! -- to deal with the case of the range check on a universal integer. else Apply_Universal_Integer_Attribute_Checks (N); --- 3534,3562 ---- Left_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Pos, ! Prefix => New_Occurrence_Of (Ptyp, Loc), Expressions => New_List ( Make_Attribute_Reference (Loc, Attribute_Name => Name_Last, ! Prefix => New_Occurrence_Of (Ptyp, Loc)))), Right_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Pos, ! Prefix => New_Occurrence_Of (Ptyp, Loc), Expressions => New_List ( Make_Attribute_Reference (Loc, Attribute_Name => Name_First, ! Prefix => New_Occurrence_Of (Ptyp, Loc))))), Right_Opnd => Make_Integer_Literal (Loc, 1))); Analyze_And_Resolve (N, Typ); ! -- For all other cases, the attribute is handled by the back end, but ! -- we need to deal with the case of the range check on a universal ! -- integer. else Apply_Universal_Integer_Attribute_Checks (N); *************** package body Exp_Attr is *** 3474,3479 **** --- 3739,3758 ---- when Attribute_Remainder => Expand_Fpt_Attribute_RR (N); + ------------ + -- Result -- + ------------ + + -- Transform 'Result into reference to _Result formal. At the point + -- where a legal 'Result attribute is expanded, we know that we are in + -- the context of a _Postcondition function with a _Result parameter. + + when Attribute_Result => + Rewrite (N, + Make_Identifier (Loc, + Chars => Name_uResult)); + Analyze_And_Resolve (N, Typ); + ----------- -- Round -- ----------- *************** package body Exp_Attr is *** 3548,3554 **** Attribute_VADS_Size => Size : declare - Ptyp : constant Entity_Id := Etype (Pref); Siz : Uint; New_Node : Node_Id; --- 3827,3832 ---- *************** package body Exp_Attr is *** 3594,3612 **** else if (not Is_Entity_Name (Pref) or else not Is_Type (Entity (Pref))) ! and then (Is_Scalar_Type (Etype (Pref)) ! or else Is_Constrained (Etype (Pref))) then ! Rewrite (Pref, New_Occurrence_Of (Etype (Pref), Loc)); end if; -- For a scalar type for which no size was explicitly given, -- VADS_Size means Object_Size. This is the other respect in -- which VADS_Size differs from Size. ! if Is_Scalar_Type (Etype (Pref)) ! and then No (Size_Clause (Etype (Pref))) ! then Set_Attribute_Name (N, Name_Object_Size); -- In all other cases, Size and VADS_Size are the sane --- 3872,3887 ---- else if (not Is_Entity_Name (Pref) or else not Is_Type (Entity (Pref))) ! and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp)) then ! Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc)); end if; -- For a scalar type for which no size was explicitly given, -- VADS_Size means Object_Size. This is the other respect in -- which VADS_Size differs from Size. ! if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then Set_Attribute_Name (N, Name_Object_Size); -- In all other cases, Size and VADS_Size are the sane *************** package body Exp_Attr is *** 3617,3625 **** end if; end if; ! -- For class-wide types, X'Class'Size is transformed into a ! -- direct reference to the Size of the class type, so that gigi ! -- does not have to deal with the X'Class'Size reference. if Is_Entity_Name (Pref) and then Is_Class_Wide_Type (Entity (Pref)) --- 3892,3900 ---- end if; end if; ! -- For class-wide types, X'Class'Size is transformed into a direct ! -- reference to the Size of the class type, so that the back end does ! -- not have to deal with the X'Class'Size reference. if Is_Entity_Name (Pref) and then Is_Class_Wide_Type (Entity (Pref)) *************** package body Exp_Attr is *** 3716,3722 **** end if; end; ! -- All other cases are handled by Gigi else Apply_Universal_Integer_Attribute_Checks (N); --- 3991,3997 ---- end if; end; ! -- All other cases are handled by the back end else Apply_Universal_Integer_Attribute_Checks (N); *************** package body Exp_Attr is *** 3726,3733 **** if Is_Entity_Name (Pref) and then Is_Formal (Entity (Pref)) ! and then Is_Array_Type (Etype (Pref)) ! and then Is_Packed (Etype (Pref)) then Rewrite (N, Make_Attribute_Reference (Loc, --- 4001,4008 ---- if Is_Entity_Name (Pref) and then Is_Formal (Entity (Pref)) ! and then Is_Array_Type (Ptyp) ! and then Is_Packed (Ptyp) then Rewrite (N, Make_Attribute_Reference (Loc, *************** package body Exp_Attr is *** 3738,3750 **** end if; -- If Size applies to a dereference of an access to unconstrained ! -- packed array, GIGI needs to see its unconstrained nominal type, ! -- but also a hint to the actual constrained type. if Nkind (Pref) = N_Explicit_Dereference ! and then Is_Array_Type (Etype (Pref)) ! and then not Is_Constrained (Etype (Pref)) ! and then Is_Packed (Etype (Pref)) then Set_Actual_Designated_Subtype (Pref, Get_Actual_Subtype (Pref)); --- 4013,4025 ---- end if; -- If Size applies to a dereference of an access to unconstrained ! -- packed array, the back end needs to see its unconstrained ! -- nominal type, but also a hint to the actual constrained type. if Nkind (Pref) = N_Explicit_Dereference ! and then Is_Array_Type (Ptyp) ! and then not Is_Constrained (Ptyp) ! and then Is_Packed (Ptyp) then Set_Actual_Designated_Subtype (Pref, Get_Actual_Subtype (Pref)); *************** package body Exp_Attr is *** 3797,3807 **** -- Storage_Size -- ------------------ ! when Attribute_Storage_Size => Storage_Size : ! declare ! Ptyp : constant Entity_Id := Etype (Pref); - begin -- Access type case, always go to the root type -- The case of access types results in a value of zero for the case --- 4072,4079 ---- -- Storage_Size -- ------------------ ! when Attribute_Storage_Size => Storage_Size : begin -- Access type case, always go to the root type -- The case of access types results in a value of zero for the case *************** package body Exp_Attr is *** 3929,3935 **** ----------------- when Attribute_Stream_Size => Stream_Size : declare - Ptyp : constant Entity_Id := Etype (Pref); Size : Int; begin --- 4201,4206 ---- *************** package body Exp_Attr is *** 3958,3966 **** when Attribute_Succ => Succ : declare ! Ptyp : constant Entity_Id := Base_Type (Etype (Pref)); begin -- For enumeration types with non-standard representations, we -- expand typ'Succ (x) into --- 4229,4238 ---- when Attribute_Succ => Succ : declare ! Etyp : constant Entity_Id := Base_Type (Ptyp); begin + -- For enumeration types with non-standard representations, we -- expand typ'Succ (x) into *************** package body Exp_Attr is *** 3970,3978 **** -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations. if Is_Enumeration_Type (Ptyp) ! and then Present (Enum_Pos_To_Rep (Ptyp)) then ! if Has_Contiguous_Rep (Ptyp) then Rewrite (N, Unchecked_Convert_To (Ptyp, Make_Op_Add (Loc, --- 4242,4250 ---- -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations. if Is_Enumeration_Type (Ptyp) ! and then Present (Enum_Pos_To_Rep (Etyp)) then ! if Has_Contiguous_Rep (Etyp) then Rewrite (N, Unchecked_Convert_To (Ptyp, Make_Op_Add (Loc, *************** package body Exp_Attr is *** 3983,3989 **** Make_Function_Call (Loc, Name => New_Reference_To ! (TSS (Ptyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => New_List ( --- 4255,4261 ---- Make_Function_Call (Loc, Name => New_Reference_To ! (TSS (Etyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => New_List ( *************** package body Exp_Attr is *** 4003,4016 **** Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); Rewrite (N, Make_Indexed_Component (Loc, ! Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc), Expressions => New_List ( Make_Op_Add (Loc, Left_Opnd => Make_Function_Call (Loc, Name => New_Reference_To ! (TSS (Ptyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => Exprs), Right_Opnd => Make_Integer_Literal (Loc, 1))))); end if; --- 4275,4290 ---- Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); Rewrite (N, Make_Indexed_Component (Loc, ! Prefix => ! New_Reference_To ! (Enum_Pos_To_Rep (Etyp), Loc), Expressions => New_List ( Make_Op_Add (Loc, Left_Opnd => Make_Function_Call (Loc, Name => New_Reference_To ! (TSS (Etyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => Exprs), Right_Opnd => Make_Integer_Literal (Loc, 1))))); end if; *************** package body Exp_Attr is *** 4053,4059 **** Ttyp := Entity (Pref); Prefix_Is_Type := True; else ! Ttyp := Etype (Pref); Prefix_Is_Type := False; end if; --- 4327,4333 ---- Ttyp := Entity (Pref); Prefix_Is_Type := True; else ! Ttyp := Ptyp; Prefix_Is_Type := False; end if; *************** package body Exp_Attr is *** 4127,4135 **** -- terminated (Task_Id (Pref._disp_get_task_id)); if Ada_Version >= Ada_05 ! and then Ekind (Etype (Pref)) = E_Class_Wide_Type ! and then Is_Interface (Etype (Pref)) ! and then Is_Task_Interface (Etype (Pref)) then Rewrite (N, Make_Function_Call (Loc, --- 4401,4409 ---- -- terminated (Task_Id (Pref._disp_get_task_id)); if Ada_Version >= Ada_05 ! and then Ekind (Ptyp) = E_Class_Wide_Type ! and then Is_Interface (Ptyp) ! and then Is_Task_Interface (Ptyp) then Rewrite (N, Make_Function_Call (Loc, *************** package body Exp_Attr is *** 4171,4176 **** --- 4445,4466 ---- Relocate_Node (First (Exprs)))); Analyze_And_Resolve (N, RTE (RE_Address)); + ------------ + -- To_Any -- + ------------ + + when Attribute_To_Any => To_Any : declare + P_Type : constant Entity_Id := Etype (Pref); + Decls : constant List_Id := New_List; + begin + Rewrite (N, + Build_To_Any_Call + (Convert_To (P_Type, + Relocate_Node (First (Exprs))), Decls)); + Insert_Actions (N, Decls); + Analyze_And_Resolve (N, RTE (RE_Any)); + end To_Any; + ---------------- -- Truncation -- ---------------- *************** package body Exp_Attr is *** 4184,4189 **** --- 4474,4492 ---- Expand_Fpt_Attribute_R (N); end if; + -------------- + -- TypeCode -- + -------------- + + when Attribute_TypeCode => TypeCode : declare + P_Type : constant Entity_Id := Etype (Pref); + Decls : constant List_Id := New_List; + begin + Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls)); + Insert_Actions (N, Decls); + Analyze_And_Resolve (N, RTE (RE_TypeCode)); + end TypeCode; + ----------------------- -- Unbiased_Rounding -- ----------------------- *************** package body Exp_Attr is *** 4253,4260 **** --------- -- For enumeration types with a standard representation, and for all ! -- other types, Val is handled by Gigi. For enumeration types with ! -- a non-standard representation we use the _Pos_To_Rep array that -- was created when the type was frozen. when Attribute_Val => Val : --- 4556,4563 ---- --------- -- For enumeration types with a standard representation, and for all ! -- other types, Val is handled by the back end. For enumeration types ! -- with a non-standard representation we use the _Pos_To_Rep array that -- was created when the type was frozen. when Attribute_Val => Val : *************** package body Exp_Attr is *** 4316,4323 **** when Attribute_Valid => Valid : declare ! Ptyp : constant Entity_Id := Etype (Pref); ! Btyp : Entity_Id := Base_Type (Ptyp); Tst : Node_Id; Save_Validity_Checks_On : constant Boolean := Validity_Checks_On; --- 4619,4625 ---- when Attribute_Valid => Valid : declare ! Btyp : Entity_Id := Base_Type (Ptyp); Tst : Node_Id; Save_Validity_Checks_On : constant Boolean := Validity_Checks_On; *************** package body Exp_Attr is *** 4398,4404 **** -- Non VAX float case else ! Find_Fat_Info (Etype (Pref), Ftp, Pkg); -- If the floating-point object might be unaligned, we need -- to call the special routine Unaligned_Valid, which makes --- 4700,4706 ---- -- Non VAX float case else ! Find_Fat_Info (Ptyp, Ftp, Pkg); -- If the floating-point object might be unaligned, we need -- to call the special routine Unaligned_Valid, which makes *************** package body Exp_Attr is *** 4872,4882 **** Rewrite_Stream_Proc_Call (Pname); end Write; ! -- Component_Size is handled by Gigi, unless the component size is known ! -- at compile time, which is always true in the packed array case. It is ! -- important that the packed array case is handled in the front end (see ! -- Eval_Attribute) since Gigi would otherwise get confused by the ! -- equivalent packed array type. when Attribute_Component_Size => null; --- 5174,5184 ---- Rewrite_Stream_Proc_Call (Pname); end Write; ! -- Component_Size is handled by the back end, unless the component size ! -- is known at compile time, which is always true in the packed array ! -- case. It is important that the packed array case is handled in the ! -- front end (see Eval_Attribute) since the back end would otherwise get ! -- confused by the equivalent packed array type. when Attribute_Component_Size => null; *************** package body Exp_Attr is *** 4896,4902 **** -- static cases have already been evaluated during semantic processing, -- but in any case the back end should not count on this). ! -- Gigi also handles the non-class-wide cases of Size when Attribute_Bit_Order | Attribute_Code_Address | --- 5198,5204 ---- -- static cases have already been evaluated during semantic processing, -- but in any case the back end should not count on this). ! -- The back end also handles the non-class-wide cases of Size when Attribute_Bit_Order | Attribute_Code_Address | *************** package body Exp_Attr is *** 4906,4913 **** Attribute_Pool_Address => null; ! -- The following attributes are also handled by Gigi, but return a ! -- universal integer result, so may need a conversion for checking -- that the result is in range. when Attribute_Aft | --- 5208,5215 ---- Attribute_Pool_Address => null; ! -- The following attributes are also handled by the back end, but return ! -- a universal integer result, so may need a conversion for checking -- that the result is in range. when Attribute_Aft | *************** package body Exp_Attr is *** 4934,4939 **** --- 5236,5242 ---- Attribute_Fast_Math | Attribute_Has_Access_Values | Attribute_Has_Discriminants | + Attribute_Has_Tagged_Values | Attribute_Large | Attribute_Machine_Emax | Attribute_Machine_Emin | *************** package body Exp_Attr is *** 4969,4976 **** raise Program_Error; -- The Asm_Input and Asm_Output attributes are not expanded at this ! -- stage, but will be eliminated in the expansion of the Asm call, ! -- see Exp_Intr for details. So Gigi will never see these either. when Attribute_Asm_Input | Attribute_Asm_Output => --- 5272,5279 ---- raise Program_Error; -- The Asm_Input and Asm_Output attributes are not expanded at this ! -- stage, but will be eliminated in the expansion of the Asm call, see ! -- Exp_Intr for details. So the back end will never see these either. when Attribute_Asm_Input | Attribute_Asm_Output => *************** package body Exp_Attr is *** 5116,5127 **** (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is ! Ent : constant Entity_Id := TSS (Typ, Nam); begin if Present (Ent) then return Ent; end if; if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then --- 5419,5546 ---- (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is ! Base_Typ : constant Entity_Id := Base_Type (Typ); ! Ent : constant Entity_Id := TSS (Typ, Nam); ! begin if Present (Ent) then return Ent; end if; + -- Stream attributes for strings are expanded into library calls. The + -- following checks are disabled when the run-time is not available or + -- when compiling predefined types due to bootstrap issues. As a result, + -- the compiler will generate in-place stream routines for string types + -- that appear in GNAT's library, but will generate calls via rtsfind + -- to library routines for user code. + -- ??? For now, disable this code for JVM, since this generates a + -- VerifyError exception at run-time on e.g. c330001. + -- This is disabled for AAMP, to avoid making dependences on files not + -- supported in the AAMP library (such as s-fileio.adb). + + if VM_Target /= JVM_Target + and then not AAMP_On_Target + and then + not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) + then + -- String as defined in package Ada + + if Base_Typ = Standard_String then + if Restriction_Active (No_Stream_Optimizations) then + if Nam = TSS_Stream_Input then + return RTE (RE_String_Input); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_String_Output); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_String_Read); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_String_Write); + end if; + + else + if Nam = TSS_Stream_Input then + return RTE (RE_String_Input_Blk_IO); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_String_Output_Blk_IO); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_String_Read_Blk_IO); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_String_Write_Blk_IO); + end if; + end if; + + -- Wide_String as defined in package Ada + + elsif Base_Typ = Standard_Wide_String then + if Restriction_Active (No_Stream_Optimizations) then + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_String_Input); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_String_Output); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_String_Read); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_String_Write); + end if; + + else + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_String_Input_Blk_IO); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_String_Output_Blk_IO); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_String_Read_Blk_IO); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_String_Write_Blk_IO); + end if; + end if; + + -- Wide_Wide_String as defined in package Ada + + elsif Base_Typ = Standard_Wide_Wide_String then + if Restriction_Active (No_Stream_Optimizations) then + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_Wide_String_Input); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_Wide_String_Output); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_Wide_String_Read); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_Wide_String_Write); + end if; + + else + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_Wide_String_Input_Blk_IO); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_Wide_String_Output_Blk_IO); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_Wide_String_Read_Blk_IO); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_Wide_String_Write_Blk_IO); + end if; + end if; + end if; + end if; + if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then *************** package body Exp_Attr is *** 5177,5184 **** N := First_Rep_Item (Implementation_Base_Type (T)); while Present (N) loop ! if Nkind (N) = N_Pragma and then Chars (N) = Name_Stream_Convert then ! -- For tagged types this pragma is not inherited, so we -- must verify that it is defined for the given type and -- not an ancestor. --- 5596,5604 ---- N := First_Rep_Item (Implementation_Base_Type (T)); while Present (N) loop ! if Nkind (N) = N_Pragma ! and then Pragma_Name (N) = Name_Stream_Convert ! then -- For tagged types this pragma is not inherited, so we -- must verify that it is defined for the given type and -- not an ancestor. diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch11.adb gcc-4.4.0/gcc/ada/exp_ch11.adb *** gcc-4.3.3/gcc/ada/exp_ch11.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_ch11.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Exp_Ch11 is *** 143,154 **** Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Clean, Loc))); ! -- Avoid generation of raise stmt if compiling with no exceptions ! -- propagation if not Restriction_Active (No_Exception_Propagation) then ! Append_To (Stmnts, ! Make_Raise_Statement (Loc)); end if; Set_Exception_Handlers (HSS, New_List ( --- 143,163 ---- Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Clean, Loc))); ! -- Generate reraise statement as last statement of AT-END handler, ! -- unless we are under control of No_Exception_Propagation, in which ! -- case no exception propagation is possible anyway, so we do not need ! -- a reraise (the AT END handler in this case is only for normal exits ! -- not for exceptional exits). Also, we flag the Reraise statement as ! -- being part of an AT END handler to prevent signalling this reraise ! -- as a violation of the restriction when it is not set. if not Restriction_Active (No_Exception_Propagation) then ! declare ! Rstm : constant Node_Id := Make_Raise_Statement (Loc); ! begin ! Set_From_At_End (Rstm); ! Append_To (Stmnts, Rstm); ! end; end if; Set_Exception_Handlers (HSS, New_List ( *************** package body Exp_Ch11 is *** 840,846 **** begin -- If we have no Entity, then we are probably in no run time mode ! -- or some weird error has occured. In either case do do nothing! if Present (Ent) then declare --- 849,855 ---- begin -- If we have no Entity, then we are probably in no run time mode ! -- or some weird error has occurred. In either case do nothing! if Present (Ent) then declare *************** package body Exp_Ch11 is *** 963,969 **** Handler_Loop : while Present (Handler) loop Next_Handler := Next_Non_Pragma (Handler); ! -- Remove source handler if gnat debug flag N is set if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then Remove (Handler); --- 972,978 ---- Handler_Loop : while Present (Handler) loop Next_Handler := Next_Non_Pragma (Handler); ! -- Remove source handler if gnat debug flag .x is set if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then Remove (Handler); *************** package body Exp_Ch11 is *** 971,978 **** -- Remove handler if no exception propagation, generating a warning -- if a source generated handler was not the target of a local raise. ! elsif Restriction_Active (No_Exception_Propagation) then ! if not Has_Local_Raise (Handler) and then Comes_From_Source (Handler) and then Warn_On_Non_Local_Exception then --- 980,988 ---- -- Remove handler if no exception propagation, generating a warning -- if a source generated handler was not the target of a local raise. ! else ! if Restriction_Active (No_Exception_Propagation) ! and then not Has_Local_Raise (Handler) and then Comes_From_Source (Handler) and then Warn_On_Non_Local_Exception then *************** package body Exp_Ch11 is *** 982,1099 **** Handler); end if; ! Remove (Handler); ! -- Exception handler is active and retained and must be processed ! else ! -- If an exception occurrence is present, then we must declare it ! -- and initialize it from the value stored in the TSD ! -- declare ! -- name : Exception_Occurrence; ! -- begin ! -- Save_Occurrence (name, Get_Current_Excep.all) ! -- ... ! -- end; ! if Present (Choice_Parameter (Handler)) then ! declare ! Cparm : constant Entity_Id := Choice_Parameter (Handler); ! Clc : constant Source_Ptr := Sloc (Cparm); ! Save : Node_Id; ! begin ! Save := ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc), ! Parameter_Associations => New_List ( ! New_Occurrence_Of (Cparm, Clc), ! Make_Explicit_Dereference (Loc, ! Make_Function_Call (Loc, ! Name => Make_Explicit_Dereference (Loc, ! New_Occurrence_Of ! (RTE (RE_Get_Current_Excep), Loc)))))); ! Mark_Rewrite_Insertion (Save); ! Prepend (Save, Statements (Handler)); ! Obj_Decl := ! Make_Object_Declaration ! (Clc, ! Defining_Identifier => Cparm, ! Object_Definition => ! New_Occurrence_Of ! (RTE (RE_Exception_Occurrence), Clc)); ! Set_No_Initialization (Obj_Decl, True); ! Rewrite (Handler, ! Make_Implicit_Exception_Handler (Loc, ! Exception_Choices => Exception_Choices (Handler), ! Statements => New_List ( ! Make_Block_Statement (Loc, ! Declarations => New_List (Obj_Decl), ! Handled_Statement_Sequence => ! Make_Handled_Sequence_Of_Statements (Loc, ! Statements => Statements (Handler)))))); ! Analyze_List (Statements (Handler), Suppress => All_Checks); ! end; ! end if; ! -- The processing at this point is rather different for the JVM ! -- case, so we completely separate the processing. ! -- For the JVM case, we unconditionally call Update_Exception, ! -- passing a call to the intrinsic Current_Target_Exception (see ! -- JVM version of Ada.Exceptions in 4jexcept.adb for details). ! if VM_Target /= No_VM then ! declare ! Arg : constant Node_Id := ! Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of ! (RTE (RE_Current_Target_Exception), Loc)); ! begin ! Prepend_Call_To_Handler ! (RE_Update_Exception, New_List (Arg)); ! end; ! -- For the normal case, we have to worry about the state of ! -- abort deferral. Generally, we defer abort during runtime ! -- handling of exceptions. When control is passed to the ! -- handler, then in the normal case we undefer aborts. In any ! -- case this entire handling is relevant only if aborts are ! -- allowed! ! elsif Abort_Allowed then ! -- There are some special cases in which we do not do the ! -- undefer. In particular a finalization (AT END) handler ! -- wants to operate with aborts still deferred. ! -- We also suppress the call if this is the special handler ! -- for Abort_Signal, since if we are aborting, we want to keep ! -- aborts deferred (one abort is enough). ! -- If abort really needs to be deferred the expander must add ! -- this call explicitly, see Expand_N_Asynchronous_Select. ! Others_Choice := ! Nkind (First (Exception_Choices (Handler))) = N_Others_Choice; ! if (Others_Choice ! or else Entity (First (Exception_Choices (Handler))) /= ! Stand.Abort_Signal) ! and then not ! (Others_Choice ! and then All_Others (First (Exception_Choices (Handler)))) ! and then Abort_Allowed ! then ! Prepend_Call_To_Handler (RE_Abort_Undefer); end if; end if; end if; --- 992,1125 ---- Handler); end if; ! if No_Exception_Propagation_Active then ! Remove (Handler); ! -- Exception handler is active and retained and must be processed ! else ! -- If an exception occurrence is present, then we must declare ! -- it and initialize it from the value stored in the TSD ! -- declare ! -- name : Exception_Occurrence; ! -- begin ! -- Save_Occurrence (name, Get_Current_Excep.all) ! -- ... ! -- end; ! if Present (Choice_Parameter (Handler)) then ! declare ! Cparm : constant Entity_Id := Choice_Parameter (Handler); ! Cloc : constant Source_Ptr := Sloc (Cparm); ! Hloc : constant Source_Ptr := Sloc (Handler); ! Save : Node_Id; ! begin ! Save := ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc), ! Parameter_Associations => New_List ( ! New_Occurrence_Of (Cparm, Cloc), ! Make_Explicit_Dereference (Loc, ! Make_Function_Call (Loc, ! Name => Make_Explicit_Dereference (Loc, ! New_Occurrence_Of ! (RTE (RE_Get_Current_Excep), Loc)))))); ! Mark_Rewrite_Insertion (Save); ! Prepend (Save, Statements (Handler)); ! Obj_Decl := ! Make_Object_Declaration ! (Cloc, ! Defining_Identifier => Cparm, ! Object_Definition => ! New_Occurrence_Of ! (RTE (RE_Exception_Occurrence), Cloc)); ! Set_No_Initialization (Obj_Decl, True); ! Rewrite (Handler, ! Make_Exception_Handler (Hloc, ! Choice_Parameter => Empty, ! Exception_Choices => Exception_Choices (Handler), ! Statements => New_List ( ! Make_Block_Statement (Hloc, ! Declarations => New_List (Obj_Decl), ! Handled_Statement_Sequence => ! Make_Handled_Sequence_Of_Statements (Hloc, ! Statements => Statements (Handler)))))); ! -- Local raise statements can't occur, since exception ! -- handlers with choice parameters are not allowed when ! -- No_Exception_Propagation applies, so set attributes ! -- accordingly. ! Set_Local_Raise_Statements (Handler, No_Elist); ! Set_Local_Raise_Not_OK (Handler); ! Analyze_List ! (Statements (Handler), Suppress => All_Checks); ! end; ! end if; ! -- The processing at this point is rather different for the JVM ! -- case, so we completely separate the processing. ! -- For the VM case, we unconditionally call Update_Exception, ! -- passing a call to the intrinsic Current_Target_Exception ! -- (see JVM/.NET versions of Ada.Exceptions for details). ! if VM_Target /= No_VM then ! declare ! Arg : constant Node_Id := ! Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of ! (RTE (RE_Current_Target_Exception), Loc)); ! begin ! Prepend_Call_To_Handler ! (RE_Update_Exception, New_List (Arg)); ! end; ! -- For the normal case, we have to worry about the state of ! -- abort deferral. Generally, we defer abort during runtime ! -- handling of exceptions. When control is passed to the ! -- handler, then in the normal case we undefer aborts. In ! -- any case this entire handling is relevant only if aborts ! -- are allowed! ! elsif Abort_Allowed then ! -- There are some special cases in which we do not do the ! -- undefer. In particular a finalization (AT END) handler ! -- wants to operate with aborts still deferred. ! -- We also suppress the call if this is the special handler ! -- for Abort_Signal, since if we are aborting, we want to ! -- keep aborts deferred (one abort is enough). ! -- If abort really needs to be deferred the expander must ! -- add this call explicitly, see ! -- Expand_N_Asynchronous_Select. ! ! Others_Choice := ! Nkind (First (Exception_Choices (Handler))) = ! N_Others_Choice; ! ! if (Others_Choice ! or else Entity (First (Exception_Choices (Handler))) /= ! Stand.Abort_Signal) ! and then not ! (Others_Choice ! and then ! All_Others (First (Exception_Choices (Handler)))) ! and then Abort_Allowed ! then ! Prepend_Call_To_Handler (RE_Abort_Undefer); ! end if; end if; end if; end if; *************** package body Exp_Ch11 is *** 1248,1254 **** Insert_List_After_And_Analyze (N, L); end if; end if; - end Expand_N_Exception_Declaration; --------------------------------------------- --- 1274,1279 ---- *************** package body Exp_Ch11 is *** 1334,1341 **** H : Node_Id; begin - -- Debug_Flag_Dot_G := True; - -- Processing for locally handled exception (exclude reraise case) if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then --- 1359,1364 ---- *************** package body Exp_Ch11 is *** 1373,1379 **** -- Raise_Exception (exception-name'Identity, string); ! -- and there is nothing else to do if Present (Expression (N)) then Rewrite (N, --- 1396,1402 ---- -- Raise_Exception (exception-name'Identity, string); ! -- and there is nothing else to do. if Present (Expression (N)) then Rewrite (N, *************** package body Exp_Ch11 is *** 1381,1387 **** Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, ! Prefix => Name (N), Attribute_Name => Name_Identity), Expression (N)))); Analyze (N); --- 1404,1410 ---- Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, ! Prefix => Name (N), Attribute_Name => Name_Identity), Expression (N)))); Analyze (N); *************** package body Exp_Ch11 is *** 1450,1455 **** --- 1473,1479 ---- Id : Entity_Id := Entity (Name (N)); begin + Name_Len := 0; Build_Location_String (Loc); -- If the exception is a renaming, use the exception that it diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch11.ads gcc-4.4.0/gcc/ada/exp_ch11.ads *** gcc-4.3.3/gcc/ada/exp_ch11.ads Wed Jun 6 10:18:34 2007 --- gcc-4.4.0/gcc/ada/exp_ch11.ads Thu Apr 9 23:23:07 2009 *************** *** 6,23 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,23 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- ! -- -- ! -- You should have received a copy of the GNU General Public License along -- ! -- with this program; see file COPYING3. If not see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch13.adb gcc-4.4.0/gcc/ada/exp_ch13.adb *** gcc-4.3.3/gcc/ada/exp_ch13.adb Wed Sep 26 10:46:59 2007 --- gcc-4.4.0/gcc/ada/exp_ch13.adb Mon Aug 18 08:59:47 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Exp_Ch13 is *** 145,165 **** -- For Storage_Size for an access type, create a variable to hold -- the value of the specified size with name typeV and expand an ! -- assignment statement to initialze this value. elsif Is_Access_Type (Ent) then - V := Make_Defining_Identifier (Loc, - New_External_Name (Chars (Ent), 'V')); ! Insert_Action (N, ! Make_Object_Declaration (Loc, ! Defining_Identifier => V, ! Object_Definition => ! New_Reference_To (RTE (RE_Storage_Offset), Loc), ! Expression => ! Convert_To (RTE (RE_Storage_Offset), Expression (N)))); ! Set_Storage_Size_Variable (Ent, Entity_Id (V)); end if; -- Other attributes require no expansion --- 145,173 ---- -- For Storage_Size for an access type, create a variable to hold -- the value of the specified size with name typeV and expand an ! -- assignment statement to initialize this value. elsif Is_Access_Type (Ent) then ! -- We don't need the variable for a storage size of zero ! if not No_Pool_Assigned (Ent) then ! V := ! Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Chars (Ent), 'V')); ! ! -- Insert the declaration of the object ! ! Insert_Action (N, ! Make_Object_Declaration (Loc, ! Defining_Identifier => V, ! Object_Definition => ! New_Reference_To (RTE (RE_Storage_Offset), Loc), ! Expression => ! Convert_To (RTE (RE_Storage_Offset), Expression (N)))); ! ! Set_Storage_Size_Variable (Ent, Entity_Id (V)); ! end if; end if; -- Other attributes require no expansion *************** package body Exp_Ch13 is *** 207,224 **** return; end if; -- If we are freezing entities defined in protected types, they belong -- in the enclosing scope, given that the original type has been -- expanded away. The same is true for entities in task types, in -- particular the parameter records of entries (Entities in bodies are -- all frozen within the body). If we are in the task body, this is a ! -- proper scope. if Ekind (E_Scope) = E_Protected_Type or else (Ekind (E_Scope) = E_Task_Type and then not Has_Completion (E_Scope)) then E_Scope := Scope (E_Scope); end if; S := Current_Scope; --- 215,246 ---- return; end if; + -- Remember that we are processing a freezing entity and its freezing + -- nodes. This flag (non-zero = set) is used to avoid the need of + -- climbing through the tree while processing the freezing actions (ie. + -- to avoid generating spurious warnings or to avoid killing constant + -- indications while processing the code associated with freezing + -- actions). We use a counter to deal with nesting. + + Inside_Freezing_Actions := Inside_Freezing_Actions + 1; + -- If we are freezing entities defined in protected types, they belong -- in the enclosing scope, given that the original type has been -- expanded away. The same is true for entities in task types, in -- particular the parameter records of entries (Entities in bodies are -- all frozen within the body). If we are in the task body, this is a ! -- proper scope. If we are within a subprogram body, the proper scope ! -- is the corresponding spec. This may happen for itypes generated in ! -- the bodies of protected operations. if Ekind (E_Scope) = E_Protected_Type or else (Ekind (E_Scope) = E_Task_Type and then not Has_Completion (E_Scope)) then E_Scope := Scope (E_Scope); + + elsif Ekind (E_Scope) = E_Subprogram_Body then + E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope)); end if; S := Current_Scope; *************** package body Exp_Ch13 is *** 237,245 **** Push_Scope (E_Scope); Install_Visible_Declarations (E_Scope); ! if Ekind (E_Scope) = E_Package or else ! Ekind (E_Scope) = E_Generic_Package or else ! Is_Protected_Type (E_Scope) or else Is_Task_Type (E_Scope) then Install_Private_Declarations (E_Scope); --- 259,266 ---- Push_Scope (E_Scope); Install_Visible_Declarations (E_Scope); ! if Is_Package_Or_Generic_Package (E_Scope) or else ! Is_Protected_Type (E_Scope) or else Is_Task_Type (E_Scope) then Install_Private_Declarations (E_Scope); *************** package body Exp_Ch13 is *** 277,283 **** -- its secondary dispatch table and therefore the code generator -- has nothing else to do with this freezing node. ! Delete := Present (Abstract_Interface_Alias (E)); end if; -- Analyze actions generated by freezing. The init_proc contains source --- 298,304 ---- -- its secondary dispatch table and therefore the code generator -- has nothing else to do with this freezing node. ! Delete := Present (Interface_Alias (E)); end if; -- Analyze actions generated by freezing. The init_proc contains source *************** package body Exp_Ch13 is *** 333,338 **** --- 354,364 ---- elsif In_Outer_Scope then Pop_Scope; end if; + + -- Restore previous value of the nesting-level counter that records + -- whether we are inside a (possibly nested) call to this procedure. + + Inside_Freezing_Actions := Inside_Freezing_Actions - 1; end Expand_N_Freeze_Entity; ------------------------------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch2.adb gcc-4.4.0/gcc/ada/exp_ch2.adb *** gcc-4.3.3/gcc/ada/exp_ch2.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/exp_ch2.adb Mon May 26 09:41:03 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Exp_Ch2 is *** 80,91 **** -- Dispatches to specific expansion procedures. procedure Expand_Entry_Index_Parameter (N : Node_Id); ! -- A reference to the identifier in the entry index specification of ! -- protected entry body is modified to a reference to a constant definition ! -- equal to the index of the entry family member being called. This ! -- constant is calculated as part of the elaboration of the expanded code ! -- for the body, and is calculated from the object-wide entry index ! -- returned by Next_Entry_Call. procedure Expand_Entry_Parameter (N : Node_Id); -- A reference to an entry parameter is modified to be a reference to the --- 80,91 ---- -- Dispatches to specific expansion procedures. procedure Expand_Entry_Index_Parameter (N : Node_Id); ! -- A reference to the identifier in the entry index specification of an ! -- entry body is modified to a reference to a constant definition equal to ! -- the index of the entry family member being called. This constant is ! -- calculated as part of the elaboration of the expanded code for the body, ! -- and is calculated from the object-wide entry index returned by Next_ ! -- Entry_Call. procedure Expand_Entry_Parameter (N : Node_Id); -- A reference to an entry parameter is modified to be a reference to the *************** package body Exp_Ch2 is *** 98,109 **** -- represent the operation within the protected object. In other cases -- Expand_Formal is a no-op. ! procedure Expand_Protected_Private (N : Node_Id); ! -- A reference to a private component of a protected type is expanded to a ! -- component selected from the record used to implement the protected ! -- object. Such a record is passed to all operations on a protected object ! -- in a parameter named _object. This object is a constant in the body of a ! -- function, and a variable within a procedure or entry body. procedure Expand_Renaming (N : Node_Id); -- For renamings, just replace the identifier by the corresponding --- 98,107 ---- -- represent the operation within the protected object. In other cases -- Expand_Formal is a no-op. ! procedure Expand_Protected_Component (N : Node_Id); ! -- A reference to a private component of a protected type is expanded into ! -- a reference to the corresponding prival in the current protected entry ! -- or subprogram. procedure Expand_Renaming (N : Node_Id); -- For renamings, just replace the identifier by the corresponding *************** package body Exp_Ch2 is *** 186,192 **** end if; -- If constant value is an occurrence of an enumeration literal, ! -- then we just make another occurence of the same literal. if Is_Entity_Name (Val) and then Ekind (Entity (Val)) = E_Enumeration_Literal --- 184,190 ---- end if; -- If constant value is an occurrence of an enumeration literal, ! -- then we just make another occurrence of the same literal. if Is_Entity_Name (Val) and then Ekind (Entity (Val)) = E_Enumeration_Literal *************** package body Exp_Ch2 is *** 195,207 **** Unchecked_Convert_To (T, New_Occurrence_Of (Entity (Val), Loc))); ! -- Otherwise get the value, and convert to appropriate type else Rewrite (N, Unchecked_Convert_To (T, ! Make_Integer_Literal (Loc, ! Intval => Expr_Rep_Value (Val)))); end if; Analyze_And_Resolve (N, T); --- 193,213 ---- Unchecked_Convert_To (T, New_Occurrence_Of (Entity (Val), Loc))); ! -- If constant is of an integer type, just make an appropriately ! -- integer literal, which will get the proper type. ! ! elsif Is_Integer_Type (T) then ! Rewrite (N, ! Make_Integer_Literal (Loc, ! Intval => Expr_Rep_Value (Val))); ! ! -- Otherwise do unchecked conversion of value to right type else Rewrite (N, Unchecked_Convert_To (T, ! Make_Integer_Literal (Loc, ! Intval => Expr_Rep_Value (Val)))); end if; Analyze_And_Resolve (N, T); *************** package body Exp_Ch2 is *** 332,347 **** elsif Is_Entry_Formal (E) then Expand_Entry_Parameter (N); ! elsif Ekind (E) = E_Component ! and then Is_Protected_Private (E) ! then ! -- Protect against junk use of tasking in no run time mode ! if No_Run_Time_Mode then return; end if; ! Expand_Protected_Private (N); elsif Ekind (E) = E_Entry_Index_Parameter then Expand_Entry_Index_Parameter (N); --- 338,349 ---- elsif Is_Entry_Formal (E) then Expand_Entry_Parameter (N); ! elsif Is_Protected_Component (E) then if No_Run_Time_Mode then return; end if; ! Expand_Protected_Component (N); elsif Ekind (E) = E_Entry_Index_Parameter then Expand_Entry_Index_Parameter (N); *************** package body Exp_Ch2 is *** 385,395 **** -- Interpret possible Current_Value for constant case ! elsif (Ekind (E) = E_Constant ! or else ! Ekind (E) = E_In_Parameter ! or else ! Ekind (E) = E_Loop_Parameter) and then Present (Current_Value (E)) then Expand_Current_Value (N); --- 387,393 ---- -- Interpret possible Current_Value for constant case ! elsif Is_Constant_Object (E) and then Present (Current_Value (E)) then Expand_Current_Value (N); *************** package body Exp_Ch2 is *** 401,408 **** ---------------------------------- procedure Expand_Entry_Index_Parameter (N : Node_Id) is begin ! Set_Entity (N, Entry_Index_Constant (Entity (N))); end Expand_Entry_Index_Parameter; ---------------------------- --- 399,408 ---- ---------------------------------- procedure Expand_Entry_Index_Parameter (N : Node_Id) is + Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N)); begin ! Set_Entity (N, Index_Con); ! Set_Etype (N, Etype (Index_Con)); end Expand_Entry_Index_Parameter; ---------------------------- *************** package body Exp_Ch2 is *** 477,486 **** -- we also generate an extra parameter to hold the Constrained -- attribute of the actual. No renaming is generated for this flag. if Ekind (Entity (N)) /= E_In_Parameter and then In_Assignment_Context (N) then ! Note_Possible_Modification (N); end if; Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc)); --- 477,490 ---- -- we also generate an extra parameter to hold the Constrained -- attribute of the actual. No renaming is generated for this flag. + -- Calling Note_Possible_Modification in the expander is dubious, + -- because this generates a cross-reference entry, and should be + -- done during semantic processing so it is called in -gnatc mode??? + if Ekind (Entity (N)) /= E_In_Parameter and then In_Assignment_Context (N) then ! Note_Possible_Modification (N, Sure => True); end if; Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc)); *************** package body Exp_Ch2 is *** 564,656 **** end if; end Expand_N_Real_Literal; ! ------------------------------ ! -- Expand_Protected_Private -- ! ------------------------------ ! ! procedure Expand_Protected_Private (N : Node_Id) is ! Loc : constant Source_Ptr := Sloc (N); ! E : constant Entity_Id := Entity (N); ! Op : constant Node_Id := Protected_Operation (E); ! Scop : Entity_Id; ! Lo : Node_Id; ! Hi : Node_Id; ! D_Range : Node_Id; ! ! begin ! if Nkind (Op) /= N_Subprogram_Body ! or else Nkind (Specification (Op)) /= N_Function_Specification ! then ! Set_Ekind (Prival (E), E_Variable); ! else ! Set_Ekind (Prival (E), E_Constant); ! end if; ! -- If the private component appears in an assignment (either lhs or ! -- rhs) and is a one-dimensional array constrained by a discriminant, ! -- rewrite as P (Lo .. Hi) with an explicit range, so that discriminal ! -- is directly visible. This solves delicate visibility problems. ! if Comes_From_Source (N) ! and then Is_Array_Type (Etype (E)) ! and then Number_Dimensions (Etype (E)) = 1 ! and then not Within_Init_Proc ! then ! Lo := Type_Low_Bound (Etype (First_Index (Etype (E)))); ! Hi := Type_High_Bound (Etype (First_Index (Etype (E)))); ! if Nkind (Parent (N)) = N_Assignment_Statement ! and then ((Is_Entity_Name (Lo) ! and then Ekind (Entity (Lo)) = E_In_Parameter) ! or else (Is_Entity_Name (Hi) ! and then ! Ekind (Entity (Hi)) = E_In_Parameter)) ! then ! D_Range := New_Node (N_Range, Loc); ! if Is_Entity_Name (Lo) ! and then Ekind (Entity (Lo)) = E_In_Parameter ! then ! Set_Low_Bound (D_Range, ! Make_Identifier (Loc, Chars (Entity (Lo)))); ! else ! Set_Low_Bound (D_Range, Duplicate_Subexpr (Lo)); ! end if; ! if Is_Entity_Name (Hi) ! and then Ekind (Entity (Hi)) = E_In_Parameter then ! Set_High_Bound (D_Range, ! Make_Identifier (Loc, Chars (Entity (Hi)))); ! else ! Set_High_Bound (D_Range, Duplicate_Subexpr (Hi)); end if; ! Rewrite (N, ! Make_Slice (Loc, ! Prefix => New_Occurrence_Of (E, Loc), ! Discrete_Range => D_Range)); ! ! Analyze_And_Resolve (N, Etype (E)); ! return; ! end if; ! end if; ! ! -- The type of the reference is the type of the prival, which may differ ! -- from that of the original component if it is an itype. ! Set_Entity (N, Prival (E)); ! Set_Etype (N, Etype (Prival (E))); ! Scop := Current_Scope; ! -- Find entity for protected operation, which must be on scope stack ! while not Is_Protected_Type (Scope (Scop)) loop ! Scop := Scope (Scop); ! end loop; ! Append_Elmt (N, Privals_Chain (Scop)); ! end Expand_Protected_Private; --------------------- -- Expand_Renaming -- --- 568,621 ---- end if; end Expand_N_Real_Literal; ! -------------------------------- ! -- Expand_Protected_Component -- ! -------------------------------- ! procedure Expand_Protected_Component (N : Node_Id) is ! function Inside_Eliminated_Body return Boolean; ! -- Determine whether the current entity is inside a subprogram or an ! -- entry which has been marked as eliminated. ! ---------------------------- ! -- Inside_Eliminated_Body -- ! ---------------------------- ! function Inside_Eliminated_Body return Boolean is ! S : Entity_Id := Current_Scope; ! begin ! while Present (S) loop ! if (Ekind (S) = E_Entry ! or else Ekind (S) = E_Entry_Family ! or else Ekind (S) = E_Function ! or else Ekind (S) = E_Procedure) ! and then Is_Eliminated (S) then ! return True; end if; ! S := Scope (S); ! end loop; ! return False; ! end Inside_Eliminated_Body; ! -- Start of processing for Expand_Protected_Component ! begin ! -- Eliminated bodies are not expanded and thus do not need privals ! if not Inside_Eliminated_Body then ! declare ! Priv : constant Entity_Id := Prival (Entity (N)); ! begin ! Set_Entity (N, Priv); ! Set_Etype (N, Etype (Priv)); ! end; ! end if; ! end Expand_Protected_Component; --------------------- -- Expand_Renaming -- diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch3.adb gcc-4.4.0/gcc/ada/exp_ch3.adb *** gcc-4.3.3/gcc/ada/exp_ch3.adb Wed Dec 19 16:23:21 2007 --- gcc-4.4.0/gcc/ada/exp_ch3.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Sem_Disp; use Sem_Disp; *** 57,62 **** --- 57,63 ---- with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; + with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; *************** package body Exp_Ch3 is *** 532,542 **** --------------------------- procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is ! Loc : constant Source_Ptr := Sloc (Nod); ! Comp_Type : constant Entity_Id := Component_Type (A_Type); ! Index_List : List_Id; ! Proc_Id : Entity_Id; ! Body_Stmts : List_Id; function Init_Component return List_Id; -- Create one statement to initialize one array component, designated --- 533,544 ---- --------------------------- procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is ! Loc : constant Source_Ptr := Sloc (Nod); ! Comp_Type : constant Entity_Id := Component_Type (A_Type); ! Index_List : List_Id; ! Proc_Id : Entity_Id; ! Body_Stmts : List_Id; ! Has_Default_Init : Boolean; function Init_Component return List_Id; -- Create one statement to initialize one array component, designated *************** package body Exp_Ch3 is *** 570,576 **** Name => Comp, Expression => Get_Simple_Init_Val ! (Comp_Type, Loc, Component_Size (A_Type)))); else Clean_Task_Names (Comp_Type, Proc_Id); --- 572,578 ---- Name => Comp, Expression => Get_Simple_Init_Val ! (Comp_Type, Nod, Component_Size (A_Type)))); else Clean_Task_Names (Comp_Type, Proc_Id); *************** package body Exp_Ch3 is *** 670,686 **** -- the issue arises) in a special manner anyway which does not need an -- init_proc. ! if Has_Non_Null_Base_Init_Proc (Comp_Type) ! or else Needs_Simple_Initialization (Comp_Type) ! or else Has_Task (Comp_Type) or else (not Restriction_Active (No_Initialize_Scalars) ! and then Is_Public (A_Type) ! and then Root_Type (A_Type) /= Standard_String ! and then Root_Type (A_Type) /= Standard_Wide_String ! and then Root_Type (A_Type) /= Standard_Wide_Wide_String) then Proc_Id := ! Make_Defining_Identifier (Loc, Make_Init_Proc_Name (A_Type)); Body_Stmts := Init_One_Dimension (1); --- 672,708 ---- -- the issue arises) in a special manner anyway which does not need an -- init_proc. ! Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type) ! or else Needs_Simple_Initialization (Comp_Type) ! or else Has_Task (Comp_Type); ! ! if Has_Default_Init or else (not Restriction_Active (No_Initialize_Scalars) ! and then Is_Public (A_Type) ! and then Root_Type (A_Type) /= Standard_String ! and then Root_Type (A_Type) /= Standard_Wide_String ! and then Root_Type (A_Type) /= Standard_Wide_Wide_String) then Proc_Id := ! Make_Defining_Identifier (Loc, ! Chars => Make_Init_Proc_Name (A_Type)); ! ! -- If No_Default_Initialization restriction is active, then we don't ! -- want to build an init_proc, but we need to mark that an init_proc ! -- would be needed if this restriction was not active (so that we can ! -- detect attempts to call it), so set a dummy init_proc in place. ! -- This is only done though when actual default initialization is ! -- needed (and not done when only Is_Public is True), since otherwise ! -- objects such as arrays of scalars could be wrongly flagged as ! -- violating the restriction. ! ! if Restriction_Active (No_Default_Initialization) then ! if Has_Default_Init then ! Set_Init_Proc (A_Type, Proc_Id); ! end if; ! ! return; ! end if; Body_Stmts := Init_One_Dimension (1); *************** package body Exp_Ch3 is *** 710,716 **** -- in any case no point in inlining such complex init procs. if not Has_Task (Proc_Id) ! and then not Controlled_Type (Proc_Id) then Set_Is_Inlined (Proc_Id); end if; --- 732,738 ---- -- in any case no point in inlining such complex init procs. if not Has_Task (Proc_Id) ! and then not Needs_Finalization (Proc_Id) then Set_Is_Inlined (Proc_Id); end if; *************** package body Exp_Ch3 is *** 1016,1032 **** Saved_Enclosing_Func_Id : Entity_Id; begin ! -- Build the discriminant checking function for each variant, label ! -- all components of that variant with the function's name. Discr_Name := Entity (Name (Variant_Part_Node)); Variant := First_Non_Pragma (Variants (Variant_Part_Node)); while Present (Variant) loop - Func_Id := Build_Dcheck_Function (Discr_Name, Variant); Component_List_Node := Component_List (Variant); ! if not Null_Present (Component_List_Node) then Decl := First_Non_Pragma (Component_Items (Component_List_Node)); --- 1038,1062 ---- Saved_Enclosing_Func_Id : Entity_Id; begin ! -- Build the discriminant-checking function for each variant, and ! -- label all components of that variant with the function's name. ! -- We only Generate a discriminant-checking function when the ! -- variant is not empty, to prevent the creation of dead code. ! -- The exception to that is when Frontend_Layout_On_Target is set, ! -- because the variant record size function generated in package ! -- Layout needs to generate calls to all discriminant-checking ! -- functions, including those for empty variants. Discr_Name := Entity (Name (Variant_Part_Node)); Variant := First_Non_Pragma (Variants (Variant_Part_Node)); while Present (Variant) loop Component_List_Node := Component_List (Variant); ! if not Null_Present (Component_List_Node) ! or else Frontend_Layout_On_Target ! then ! Func_Id := Build_Dcheck_Function (Discr_Name, Variant); Decl := First_Non_Pragma (Component_Items (Component_List_Node)); *************** package body Exp_Ch3 is *** 1513,1519 **** end if; end if; ! -- Ada 2005 (AI-287) In case of default initialized components, -- we need to generate the corresponding selected component node -- to access the discriminant value. In other cases this is not -- required because we are inside the init proc and we use the --- 1543,1549 ---- end if; end if; ! -- Ada 2005 (AI-287): In case of default initialized components, -- we need to generate the corresponding selected component node -- to access the discriminant value. In other cases this is not -- required because we are inside the init proc and we use the *************** package body Exp_Ch3 is *** 1551,1557 **** Name => New_Occurrence_Of (Proc, Loc), Parameter_Associations => Args)); ! if Controlled_Type (Typ) and then Nkind (Id_Ref) = N_Selected_Component then if Chars (Selector_Name (Id_Ref)) /= Name_uParent then --- 1581,1587 ---- Name => New_Occurrence_Of (Proc, Loc), Parameter_Associations => Args)); ! if Needs_Finalization (Typ) and then Nkind (Id_Ref) = N_Selected_Component then if Chars (Selector_Name (Id_Ref)) /= Name_uParent then *************** package body Exp_Ch3 is *** 1664,1674 **** ---------------------------- procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is ! Loc : Source_Ptr := Sloc (N); ! Discr_Map : constant Elist_Id := New_Elmt_List; ! Proc_Id : Entity_Id; ! Rec_Type : Entity_Id; ! Set_Tag : Entity_Id := Empty; function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; -- Build a assignment statement node which assigns to record component --- 1694,1704 ---- ---------------------------- procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is ! Loc : Source_Ptr := Sloc (N); ! Discr_Map : constant Elist_Id := New_Elmt_List; ! Proc_Id : Entity_Id; ! Rec_Type : Entity_Id; ! Set_Tag : Entity_Id := Empty; function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; -- Build a assignment statement node which assigns to record component *************** package body Exp_Ch3 is *** 1796,1818 **** Attribute_Name => Name_Unrestricted_Access); end if; - -- Ada 2005 (AI-231): Add the run-time check if required - - if Ada_Version >= Ada_05 - and then Can_Never_Be_Null (Etype (Id)) -- Lhs - then - if Known_Null (Exp) then - return New_List ( - Make_Raise_Constraint_Error (Sloc (Exp), - Reason => CE_Null_Not_Allowed)); - - elsif Present (Etype (Exp)) - and then not Can_Never_Be_Null (Etype (Exp)) - then - Install_Null_Excluding_Check (Exp); - end if; - end if; - -- Take a copy of Exp to ensure that later copies of this component -- declaration in derived types see the original tree, not a node -- rewritten during expansion of the init_proc. --- 1826,1831 ---- *************** package body Exp_Ch3 is *** 1852,1858 **** Kind := Nkind (Expression (N)); end if; ! if Controlled_Type (Typ) and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate) and then not Is_Inherently_Limited_Type (Typ) then --- 1865,1871 ---- Kind := Nkind (Expression (N)); end if; ! if Needs_Finalization (Typ) and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate) and then not Is_Inherently_Limited_Type (Typ) then *************** package body Exp_Ch3 is *** 2109,2121 **** -- Local variables - Ifaces_List : Elist_Id; Ifaces_Comp_List : Elist_Id; ! Ifaces_Tag_List : Elist_Id; ! Iface_Elmt : Elmt_Id; ! Comp_Elmt : Elmt_Id; ! ! pragma Warnings (Off, Ifaces_Tag_List); -- Start of processing for Build_Offset_To_Top_Functions --- 2122,2130 ---- -- Local variables Ifaces_Comp_List : Elist_Id; ! Iface_Comp_Elmt : Elmt_Id; ! Iface_Comp : Node_Id; -- Start of processing for Build_Offset_To_Top_Functions *************** package body Exp_Ch3 is *** 2133,2158 **** return; end if; ! Collect_Interfaces_Info ! (Rec_Type, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List); -- For each interface type with secondary dispatch table we generate -- the Offset_To_Top_Functions (required to displace the pointer in -- interface conversions) ! Iface_Elmt := First_Elmt (Ifaces_List); ! Comp_Elmt := First_Elmt (Ifaces_Comp_List); ! while Present (Iface_Elmt) loop -- If the interface is a parent of Rec_Type it shares the primary -- dispatch table and hence there is no need to build the function ! if not Is_Parent (Node (Iface_Elmt), Rec_Type) then ! Build_Offset_To_Top_Function (Iface_Comp => Node (Comp_Elmt)); end if; ! Next_Elmt (Iface_Elmt); ! Next_Elmt (Comp_Elmt); end loop; end Build_Offset_To_Top_Functions; --- 2142,2166 ---- return; end if; ! Collect_Interface_Components (Rec_Type, Ifaces_Comp_List); -- For each interface type with secondary dispatch table we generate -- the Offset_To_Top_Functions (required to displace the pointer in -- interface conversions) ! Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); ! while Present (Iface_Comp_Elmt) loop ! Iface_Comp := Node (Iface_Comp_Elmt); ! pragma Assert (Is_Interface (Related_Type (Iface_Comp))); -- If the interface is a parent of Rec_Type it shares the primary -- dispatch table and hence there is no need to build the function ! if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type) then ! Build_Offset_To_Top_Function (Iface_Comp); end if; ! Next_Elmt (Iface_Comp_Elmt); end loop; end Build_Offset_To_Top_Functions; *************** package body Exp_Ch3 is *** 2172,2181 **** begin Body_Stmts := New_List; Body_Node := New_Node (N_Subprogram_Body, Loc); - - Proc_Id := - Make_Defining_Identifier (Loc, - Chars => Make_Init_Proc_Name (Rec_Type)); Set_Ekind (Proc_Id, E_Procedure); Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); --- 2180,2185 ---- *************** package body Exp_Ch3 is *** 2289,2295 **** if Ada_Version >= Ada_05 and then not Is_Interface (Rec_Type) ! and then Has_Abstract_Interfaces (Rec_Type) then Init_Secondary_Tags (Typ => Rec_Type, --- 2293,2299 ---- if Ada_Version >= Ada_05 and then not Is_Interface (Rec_Type) ! and then Has_Interfaces (Rec_Type) then Init_Secondary_Tags (Typ => Rec_Type, *************** package body Exp_Ch3 is *** 2383,2390 **** if not Is_Imported (Prim) and then Convention (Prim) = Convention_CPP ! and then not Present (Abstract_Interface_Alias ! (Prim)) then Register_Primitive (Loc, Prim => Prim, --- 2387,2393 ---- if not Is_Imported (Prim) and then Convention (Prim) = Convention_CPP ! and then not Present (Interface_Alias (Prim)) then Register_Primitive (Loc, Prim => Prim, *************** package body Exp_Ch3 is *** 2406,2412 **** if Ada_Version >= Ada_05 and then not Is_Interface (Rec_Type) ! and then Has_Abstract_Interfaces (Rec_Type) and then Has_Discriminants (Etype (Rec_Type)) and then Is_Variable_Size_Record (Etype (Rec_Type)) then --- 2409,2415 ---- if Ada_Version >= Ada_05 and then not Is_Interface (Rec_Type) ! and then Has_Interfaces (Rec_Type) and then Has_Discriminants (Etype (Rec_Type)) and then Is_Variable_Size_Record (Etype (Rec_Type)) then *************** package body Exp_Ch3 is *** 2462,2478 **** function Build_Init_Statements (Comp_List : Node_Id) return List_Id is Check_List : constant List_Id := New_List; Alt_List : List_Id; Statement_List : List_Id; Stmts : List_Id; Per_Object_Constraint_Components : Boolean; - Decl : Node_Id; - Variant : Node_Id; - - Id : Entity_Id; - Typ : Entity_Id; - function Has_Access_Constraint (E : Entity_Id) return Boolean; -- Components with access discriminants that depend on the current -- instance must be initialized after all other components. --- 2465,2480 ---- function Build_Init_Statements (Comp_List : Node_Id) return List_Id is Check_List : constant List_Id := New_List; Alt_List : List_Id; + Decl : Node_Id; + Id : Entity_Id; + Names : Node_Id; Statement_List : List_Id; Stmts : List_Id; + Typ : Entity_Id; + Variant : Node_Id; Per_Object_Constraint_Components : Boolean; function Has_Access_Constraint (E : Entity_Id) return Boolean; -- Components with access discriminants that depend on the current -- instance must be initialized after all other components. *************** package body Exp_Ch3 is *** 2513,2518 **** --- 2515,2561 ---- Statement_List := New_List; + -- Loop through visible declarations of task types and protected + -- types moving any expanded code from the spec to the body of the + -- init procedure + + if Is_Task_Record_Type (Rec_Type) + or else Is_Protected_Record_Type (Rec_Type) + then + declare + Decl : constant Node_Id := + Parent (Corresponding_Concurrent_Type (Rec_Type)); + Def : Node_Id; + N1 : Node_Id; + N2 : Node_Id; + + begin + if Is_Task_Record_Type (Rec_Type) then + Def := Task_Definition (Decl); + else + Def := Protected_Definition (Decl); + end if; + + if Present (Def) then + N1 := First (Visible_Declarations (Def)); + while Present (N1) loop + N2 := N1; + N1 := Next (N1); + + if Nkind (N2) in N_Statement_Other_Than_Procedure_Call + or else Nkind (N2) in N_Raise_xxx_Error + or else Nkind (N2) = N_Procedure_Call_Statement + then + Append_To (Statement_List, + New_Copy_Tree (N2, New_Scope => Proc_Id)); + Rewrite (N2, Make_Null_Statement (Sloc (N2))); + Analyze (N2); + end if; + end loop; + end if; + end; + end if; + -- Loop through components, skipping pragmas, in 2 steps. The first -- step deals with regular components. The second step deals with -- components have per object constraints, and no explicit initia- *************** package body Exp_Ch3 is *** 2567,2573 **** elsif Component_Needs_Simple_Initialization (Typ) then Stmts := Build_Assignment ! (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id))); -- Nothing needed for this case --- 2610,2616 ---- elsif Component_Needs_Simple_Initialization (Typ) then Stmts := Build_Assignment ! (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))); -- Nothing needed for this case *************** package body Exp_Ch3 is *** 2635,2641 **** elsif Component_Needs_Simple_Initialization (Typ) then Append_List_To (Statement_List, Build_Assignment ! (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id)))); end if; end if; --- 2678,2684 ---- elsif Component_Needs_Simple_Initialization (Typ) then Append_List_To (Statement_List, Build_Assignment ! (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)))); end if; end if; *************** package body Exp_Ch3 is *** 2696,2701 **** --- 2739,2755 ---- Append_To (Statement_List, Make_Task_Create_Call (Rec_Type)); + -- Generate the statements which map a string entry name to a + -- task entry index. Note that the task may not have entries. + + if Entry_Names_OK then + Names := Build_Entry_Names (Rec_Type); + + if Present (Names) then + Append_To (Statement_List, Names); + end if; + end if; + declare Task_Type : constant Entity_Id := Corresponding_Concurrent_Type (Rec_Type); *************** package body Exp_Ch3 is *** 2746,2751 **** --- 2800,2817 ---- if Is_Protected_Record_Type (Rec_Type) then Append_List_To (Statement_List, Make_Initialize_Protection (Rec_Type)); + + -- Generate the statements which map a string entry name to a + -- protected entry index. Note that the protected type may not + -- have entries. + + if Entry_Names_OK then + Names := Build_Entry_Names (Rec_Type); + + if Present (Names) then + Append_To (Statement_List, Names); + end if; + end if; end if; -- If no initializations when generated for component declarations *************** package body Exp_Ch3 is *** 2988,2998 **** elsif Is_Interface (Rec_Id) then return False; - elsif not Restriction_Active (No_Initialize_Scalars) - and then Is_Public (Rec_Id) - then - return True; - elsif (Has_Discriminants (Rec_Id) and then not Is_Unchecked_Union (Rec_Id)) or else Is_Tagged_Type (Rec_Id) --- 3054,3059 ---- *************** package body Exp_Ch3 is *** 3003,3009 **** end if; Id := First_Component (Rec_Id); - while Present (Id) loop Comp_Decl := Parent (Id); Typ := Etype (Id); --- 3064,3069 ---- *************** package body Exp_Ch3 is *** 3018,3029 **** --- 3078,3107 ---- Next_Component (Id); end loop; + -- As explained above, a record initialization procedure is needed + -- for public types in case Initialize_Scalars applies to a client. + -- However, such a procedure is not needed in the case where either + -- of restrictions No_Initialize_Scalars or No_Default_Initialization + -- apply. No_Initialize_Scalars excludes the possibility of using + -- Initialize_Scalars in any partition, and No_Default_Initialization + -- implies that no initialization should ever be done for objects of + -- the type, so is incompatible with Initialize_Scalars. + + if not Restriction_Active (No_Initialize_Scalars) + and then not Restriction_Active (No_Default_Initialization) + and then Is_Public (Rec_Id) + then + return True; + end if; + return False; end Requires_Init_Proc; -- Start of processing for Build_Record_Init_Proc begin + -- Check for value type, which means no initialization required + Rec_Type := Defining_Identifier (N); if Is_Value_Type (Rec_Type) then *************** package body Exp_Ch3 is *** 3042,3048 **** -- If there are discriminants, build the discriminant map to replace -- discriminants by their discriminals in complex bound expressions. ! -- These only arise for the corresponding records of protected types. if Is_Concurrent_Record_Type (Rec_Type) and then Has_Discriminants (Rec_Type) --- 3120,3126 ---- -- If there are discriminants, build the discriminant map to replace -- discriminants by their discriminals in complex bound expressions. ! -- These only arise for the corresponding records of synchronized types. if Is_Concurrent_Record_Type (Rec_Type) and then Has_Discriminants (Rec_Type) *************** package body Exp_Ch3 is *** 3080,3085 **** --- 3158,3177 ---- elsif Requires_Init_Proc (Rec_Type) or else Is_Unchecked_Union (Rec_Type) then + Proc_Id := + Make_Defining_Identifier (Loc, + Chars => Make_Init_Proc_Name (Rec_Type)); + + -- If No_Default_Initialization restriction is active, then we don't + -- want to build an init_proc, but we need to mark that an init_proc + -- would be needed if this restriction was not active (so that we can + -- detect attempts to call it), so set a dummy init_proc in place. + + if Restriction_Active (No_Default_Initialization) then + Set_Init_Proc (Rec_Type, Proc_Id); + return; + end if; + Build_Offset_To_Top_Functions; Build_Init_Procedure; Set_Is_Public (Proc_Id, Is_Public (Pe)); *************** package body Exp_Ch3 is *** 3094,3100 **** if not Is_Concurrent_Type (Rec_Type) and then not Has_Task (Rec_Type) ! and then not Controlled_Type (Rec_Type) then Set_Is_Inlined (Proc_Id); end if; --- 3186,3192 ---- if not Is_Concurrent_Type (Rec_Type) and then not Has_Task (Rec_Type) ! and then not Needs_Finalization (Rec_Type) then Set_Is_Inlined (Proc_Id); end if; *************** package body Exp_Ch3 is *** 3121,3133 **** procedure Collect_Itypes (Comp : Node_Id) is Ref : Node_Id; Sub_Aggr : Node_Id; ! Typ : Entity_Id; begin ! if Is_Array_Type (Etype (Comp)) ! and then Is_Itype (Etype (Comp)) then - Typ := Etype (Comp); Ref := Make_Itype_Reference (Loc); Set_Itype (Ref, Typ); Append_Freeze_Action (Rec_Type, Ref); --- 3213,3224 ---- procedure Collect_Itypes (Comp : Node_Id) is Ref : Node_Id; Sub_Aggr : Node_Id; ! Typ : constant Entity_Id := Etype (Comp); begin ! if Is_Array_Type (Typ) ! and then Is_Itype (Typ) then Ref := Make_Itype_Reference (Loc); Set_Itype (Ref, Typ); Append_Freeze_Action (Rec_Type, Ref); *************** package body Exp_Ch3 is *** 3189,3194 **** --- 3280,3290 ---- -- Ri1 : Index; -- begin + + -- if Left_Hi < Left_Lo then + -- return; + -- end if; + -- if Rev then -- Li1 := Left_Hi; -- Ri1 := Right_Hi; *************** package body Exp_Ch3 is *** 3198,3215 **** -- end if; -- loop - -- if Rev then - -- exit when Li1 < Left_Lo; - -- else - -- exit when Li1 > Left_Hi; - -- end if; - -- Target (Li1) := Source (Ri1); -- if Rev then -- Li1 := Index'pred (Li1); -- Ri1 := Index'pred (Ri1); -- else -- Li1 := Index'succ (Li1); -- Ri1 := Index'succ (Ri1); -- end if; --- 3294,3307 ---- -- end if; -- loop -- Target (Li1) := Source (Ri1); -- if Rev then + -- exit when Li1 = Left_Lo; -- Li1 := Index'pred (Li1); -- Ri1 := Index'pred (Ri1); -- else + -- exit when Li1 = Left_Hi; -- Li1 := Index'succ (Li1); -- Ri1 := Index'succ (Ri1); -- end if; *************** package body Exp_Ch3 is *** 3276,3281 **** --- 3368,3383 ---- Stats := New_List; + -- Build test for empty slice case + + Append_To (Stats, + Make_If_Statement (Loc, + Condition => + Make_Op_Lt (Loc, + Left_Opnd => New_Occurrence_Of (Left_Hi, Loc), + Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)), + Then_Statements => New_List (Make_Simple_Return_Statement (Loc)))); + -- Build initializations for indices declare *************** package body Exp_Ch3 is *** 3326,3332 **** Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), End_Label => Empty); ! -- Build exit condition declare F_Ass : constant List_Id := New_List; --- 3428,3434 ---- Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), End_Label => Empty); ! -- Build the exit condition and increment/decrement statements declare F_Ass : constant List_Id := New_List; *************** package body Exp_Ch3 is *** 3336,3366 **** Append_To (F_Ass, Make_Exit_Statement (Loc, Condition => ! Make_Op_Gt (Loc, Left_Opnd => New_Occurrence_Of (Lnn, Loc), Right_Opnd => New_Occurrence_Of (Left_Hi, Loc)))); - Append_To (B_Ass, - Make_Exit_Statement (Loc, - Condition => - Make_Op_Lt (Loc, - Left_Opnd => New_Occurrence_Of (Lnn, Loc), - Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); - - Prepend_To (Statements (Loops), - Make_If_Statement (Loc, - Condition => New_Occurrence_Of (Rev, Loc), - Then_Statements => B_Ass, - Else_Statements => F_Ass)); - end; - - -- Build the increment/decrement statements - - declare - F_Ass : constant List_Id := New_List; - B_Ass : constant List_Id := New_List; - - begin Append_To (F_Ass, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Lnn, Loc), --- 3438,3447 ---- Append_To (F_Ass, Make_Exit_Statement (Loc, Condition => ! Make_Op_Eq (Loc, Left_Opnd => New_Occurrence_Of (Lnn, Loc), Right_Opnd => New_Occurrence_Of (Left_Hi, Loc)))); Append_To (F_Ass, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Lnn, Loc), *************** package body Exp_Ch3 is *** 3384,3389 **** --- 3465,3477 ---- New_Occurrence_Of (Rnn, Loc))))); Append_To (B_Ass, + Make_Exit_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Lnn, Loc), + Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); + + Append_To (B_Ass, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Lnn, Loc), Expression => *************** package body Exp_Ch3 is *** 4141,4147 **** -- Initialize call as it is required but one for each ancestor of -- its type. This processing is suppressed if No_Initialization set. ! if not Controlled_Type (Typ) or else No_Initialization (N) then null; --- 4229,4235 ---- -- Initialize call as it is required but one for each ancestor of -- its type. This processing is suppressed if No_Initialization set. ! if not Needs_Finalization (Typ) or else No_Initialization (N) then null; *************** package body Exp_Ch3 is *** 4220,4225 **** --- 4308,4323 ---- and then not Suppress_Init_Proc (Typ) then + -- Return without initializing when No_Default_Initialization + -- applies. Note that the actual restriction check occurs later, + -- when the object is frozen, because we don't know yet whether + -- the object is imported, which is a case where the check does + -- not apply. + + if Restriction_Active (No_Default_Initialization) then + return; + end if; + -- The call to the initialization procedure does NOT freeze the -- object being initialized. This is because the call is not a -- source level call. This works fine, because the only possible *************** package body Exp_Ch3 is *** 4261,4267 **** and then not Has_Init_Expression (N) then Set_No_Initialization (N, False); ! Set_Expression (N, Get_Simple_Init_Val (Typ, Loc, Esize (Def_Id))); Analyze_And_Resolve (Expression (N), Typ); end if; --- 4359,4365 ---- and then not Has_Init_Expression (N) then Set_No_Initialization (N, False); ! Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id))); Analyze_And_Resolve (Expression (N), Typ); end if; *************** package body Exp_Ch3 is *** 4330,4337 **** -- unconstrained nominal subtype, then it acquired its constraints -- from the expression in the first place, and not only does this -- mean that the constraint check is not needed, but an attempt to ! -- perform the constraint check can cause order order of ! -- elaboration problems. if not Is_Constr_Subt_For_U_Nominal (Typ) then --- 4428,4435 ---- -- unconstrained nominal subtype, then it acquired its constraints -- from the expression in the first place, and not only does this -- mean that the constraint check is not needed, but an attempt to ! -- perform the constraint check can cause order of elaboration ! -- problems. if not Is_Constr_Subt_For_U_Nominal (Typ) then *************** package body Exp_Ch3 is *** 4350,4366 **** -- Ada 2005 (AI-251): Rewrite the expression that initializes a -- class-wide object to ensure that we copy the full object, ! -- unless we're targetting a VM where interfaces are handled by ! -- VM itself. -- Replace ! -- CW : I'Class := Obj; -- by ! -- CW__1 : I'Class := I'Class (Base_Address (Obj'Address)); ! -- CW : I'Class renames Displace (CW__1, I'Tag); if Is_Interface (Typ) ! and then Is_Class_Wide_Type (Etype (Expr)) and then Comes_From_Source (Def_Id) and then VM_Target = No_VM then --- 4448,4470 ---- -- Ada 2005 (AI-251): Rewrite the expression that initializes a -- class-wide object to ensure that we copy the full object, ! -- unless we are targetting a VM where interfaces are handled by ! -- VM itself. Note that if the root type of Typ is an ancestor ! -- of Expr's type, both types share the same dispatch table and ! -- there is no need to displace the pointer. -- Replace ! -- CW : I'Class := Obj; -- by ! -- Temp : I'Class := I'Class (Base_Address (Obj'Address)); ! -- CW : I'Class renames Displace (Temp, I'Tag); if Is_Interface (Typ) ! and then Is_Class_Wide_Type (Typ) ! and then ! (Is_Class_Wide_Type (Etype (Expr)) ! or else ! not Is_Ancestor (Root_Type (Typ), Etype (Expr))) and then Comes_From_Source (Def_Id) and then VM_Target = No_VM then *************** package body Exp_Ch3 is *** 4455,4469 **** end; end if; ! -- If the type is controlled and not limited then the target is ! -- adjusted after the copy and attached to the finalization list. ! -- However, no adjustment is done in the case where the object was ! -- initialized by a call to a function whose result is built in ! -- place, since no copy occurred. (We eventually plan to support ! -- in-place function results for some nonlimited types. ???) ! if Controlled_Type (Typ) ! and then not Is_Limited_Type (Typ) and then not BIP_Call then Insert_Actions_After (Init_After, --- 4559,4574 ---- end; end if; ! -- If the type is controlled and not inherently limited, then ! -- the target is adjusted after the copy and attached to the ! -- finalization list. However, no adjustment is done in the case ! -- where the object was initialized by a call to a function whose ! -- result is built in place, since no copy occurred. (Eventually ! -- we plan to support in-place function results for some cases ! -- of nonlimited types. ???) ! if Needs_Finalization (Typ) ! and then not Is_Inherently_Limited_Type (Typ) and then not BIP_Call then Insert_Actions_After (Init_After, *************** package body Exp_Ch3 is *** 4733,4739 **** or else Is_Tag (Defining_Identifier (First_Comp)) -- Ada 2005 (AI-251): The following condition covers secondary ! -- tags but also the adjacent component contanining the offset -- to the base of the object (component generated if the parent -- has discriminants --- see Add_Interface_Tag_Components). -- This is required to avoid the addition of the controller --- 4838,4844 ---- or else Is_Tag (Defining_Identifier (First_Comp)) -- Ada 2005 (AI-251): The following condition covers secondary ! -- tags but also the adjacent component containing the offset -- to the base of the object (component generated if the parent -- has discriminants --- see Add_Interface_Tag_Components). -- This is required to avoid the addition of the controller *************** package body Exp_Ch3 is *** 4937,4943 **** end if; elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type ! and then Controlled_Type (Directly_Designated_Type (Comp_Typ)) then Set_Associated_Final_Chain (Comp_Typ, Add_Final_Chain (Typ)); end if; --- 5042,5048 ---- end if; elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type ! and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) then Set_Associated_Final_Chain (Comp_Typ, Add_Final_Chain (Typ)); end if; *************** package body Exp_Ch3 is *** 5259,5264 **** --- 5364,5468 ---- ------------------------ procedure Freeze_Record_Type (N : Node_Id) is + + procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id); + -- Add to the list of primitives of Tagged_Types the internal entities + -- associated with interface primitives that are located in secondary + -- dispatch tables. + + ------------------------------------- + -- Add_Internal_Interface_Entities -- + ------------------------------------- + + procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is + Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Prim : Entity_Id; + Ifaces_List : Elist_Id; + New_Subp : Entity_Id := Empty; + Prim : Entity_Id; + + begin + pragma Assert (Ada_Version >= Ada_05 + and then Is_Record_Type (Tagged_Type) + and then Is_Tagged_Type (Tagged_Type) + and then Has_Interfaces (Tagged_Type) + and then not Is_Interface (Tagged_Type)); + + Collect_Interfaces (Tagged_Type, Ifaces_List); + + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + -- Exclude from this processing interfaces that are parents + -- of Tagged_Type because their primitives are located in the + -- primary dispatch table (and hence no auxiliary internal + -- entities are required to handle secondary dispatch tables + -- in such case). + + if not Is_Ancestor (Iface, Tagged_Type) then + Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Elmt) loop + Iface_Prim := Node (Elmt); + + if not Is_Predefined_Dispatching_Operation (Iface_Prim) then + Prim := + Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Iface_Prim); + + pragma Assert (Present (Prim)); + + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Iface_Prim, + Derived_Type => Tagged_Type, + Parent_Type => Iface); + + -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp + -- associated with interface types. These entities are + -- only registered in the list of primitives of its + -- corresponding tagged type because they are only used + -- to fill the contents of the secondary dispatch tables. + -- Therefore they are removed from the homonym chains. + + Set_Is_Hidden (New_Subp); + Set_Is_Internal (New_Subp); + Set_Alias (New_Subp, Prim); + Set_Is_Abstract_Subprogram (New_Subp, + Is_Abstract_Subprogram (Prim)); + Set_Interface_Alias (New_Subp, Iface_Prim); + + -- Internal entities associated with interface types are + -- only registered in the list of primitives of the + -- tagged type. They are only used to fill the contents + -- of the secondary dispatch tables. Therefore they are + -- not needed in the homonym chains. + + Remove_Homonym (New_Subp); + + -- Hidden entities associated with interfaces must have + -- set the Has_Delay_Freeze attribute to ensure that, in + -- case of locally defined tagged types (or compiling + -- with static dispatch tables generation disabled) the + -- corresponding entry of the secondary dispatch table is + -- filled when such entity is frozen. + + Set_Has_Delayed_Freeze (New_Subp); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + end Add_Internal_Interface_Entities; + + -- Local variables + Def_Id : constant Node_Id := Entity (N); Type_Decl : constant Node_Id := Parent (Def_Id); Comp : Entity_Id; *************** package body Exp_Ch3 is *** 5281,5286 **** --- 5485,5492 ---- Wrapper_Body_List : List_Id := No_List; Null_Proc_Decl_List : List_Id := No_List; + -- Start of processing for Freeze_Record_Type + begin -- Build discriminant checking functions if not a derived type (for -- derived types that are not tagged types, always use the discriminant *************** package body Exp_Ch3 is *** 5317,5323 **** and then Chars (Comp) = Chars (Old_Comp) then Set_Discriminant_Checking_Func (Comp, ! Discriminant_Checking_Func (Old_Comp)); end if; Next_Component (Old_Comp); --- 5523,5529 ---- and then Chars (Comp) = Chars (Old_Comp) then Set_Discriminant_Checking_Func (Comp, ! Discriminant_Checking_Func (Old_Comp)); end if; Next_Component (Old_Comp); *************** package body Exp_Ch3 is *** 5352,5358 **** Set_Has_Controlled_Component (Def_Id); elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type ! and then Controlled_Type (Directly_Designated_Type (Comp_Typ)) then if No (Flist) then Flist := Add_Final_Chain (Def_Id); --- 5558,5564 ---- Set_Has_Controlled_Component (Def_Id); elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type ! and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) then if No (Flist) then Flist := Add_Final_Chain (Def_Id); *************** package body Exp_Ch3 is *** 5437,5446 **** Set_Is_Frozen (Def_Id, False); -- Do not add the spec of the predefined primitives if we are -- compiling under restriction No_Dispatching_Calls ! if not Restriction_Active (No_Dispatching_Calls) then Make_Predefined_Primitive_Specs (Def_Id, Predef_List, Renamed_Eq); Insert_List_Before_And_Analyze (N, Predef_List); --- 5643,5660 ---- Set_Is_Frozen (Def_Id, False); + -- Do not add the spec of predefined primitives in case of + -- CPP tagged type derivations that have convention CPP. + + if Is_CPP_Class (Root_Type (Def_Id)) + and then Convention (Def_Id) = Convention_CPP + then + null; + -- Do not add the spec of the predefined primitives if we are -- compiling under restriction No_Dispatching_Calls ! elsif not Restriction_Active (No_Dispatching_Calls) then Make_Predefined_Primitive_Specs (Def_Id, Predef_List, Renamed_Eq); Insert_List_Before_And_Analyze (N, Predef_List); *************** package body Exp_Ch3 is *** 5475,5480 **** --- 5689,5705 ---- Insert_Actions (N, Null_Proc_Decl_List); end if; + -- Ada 2005 (AI-251): Add internal entities associated with + -- secondary dispatch tables to the list of primitives of tagged + -- types that are not interfaces + + if Ada_Version >= Ada_05 + and then not Is_Interface (Def_Id) + and then Has_Interfaces (Def_Id) + then + Add_Internal_Interface_Entities (Def_Id); + end if; + Set_Is_Frozen (Def_Id); Set_All_DT_Position (Def_Id); *************** package body Exp_Ch3 is *** 5614,5624 **** if Is_Tagged_Type (Def_Id) and then not Is_Interface (Def_Id) then -- Do not add the body of the predefined primitives if we are ! -- compiling under restriction No_Dispatching_Calls ! if not Restriction_Active (No_Dispatching_Calls) then Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); Append_Freeze_Actions (Def_Id, Predef_List); end if; --- 5839,5857 ---- if Is_Tagged_Type (Def_Id) and then not Is_Interface (Def_Id) then + -- Do not add the body of predefined primitives in case of + -- CPP tagged type derivations that have convention CPP. + + if Is_CPP_Class (Root_Type (Def_Id)) + and then Convention (Def_Id) = Convention_CPP + then + null; -- Do not add the body of the predefined primitives if we are ! -- compiling under restriction No_Dispatching_Calls or if we are ! -- compiling a CPP tagged type. ! elsif not Restriction_Active (No_Dispatching_Calls) then Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); Append_Freeze_Actions (Def_Id, Predef_List); end if; *************** package body Exp_Ch3 is *** 5814,5841 **** then declare Loc : constant Source_Ptr := Sloc (N); ! Desig_Type : constant Entity_Id := Designated_Type (Def_Id); Pool_Object : Entity_Id; - Siz_Exp : Node_Id; Freeze_Action_Typ : Entity_Id; begin - if Has_Storage_Size_Clause (Def_Id) then - Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id))); - else - Siz_Exp := Empty; - end if; - -- Case 1 -- Rep Clause "for Def_Id'Storage_Size use 0;" -- ---> don't use any storage pool ! if Has_Storage_Size_Clause (Def_Id) ! and then Compile_Time_Known_Value (Siz_Exp) ! and then Expr_Value (Siz_Exp) = 0 ! then null; -- Case 2 --- 6047,6064 ---- then declare Loc : constant Source_Ptr := Sloc (N); ! Desig_Type : constant Entity_Id := Designated_Type (Def_Id); Pool_Object : Entity_Id; Freeze_Action_Typ : Entity_Id; begin -- Case 1 -- Rep Clause "for Def_Id'Storage_Size use 0;" -- ---> don't use any storage pool ! if No_Pool_Assigned (Def_Id) then null; -- Case 2 *************** package body Exp_Ch3 is *** 5962,5968 **** then null; ! elsif (Controlled_Type (Desig_Type) and then Convention (Desig_Type) /= Convention_Java and then Convention (Desig_Type) /= Convention_CIL) or else --- 6185,6191 ---- then null; ! elsif (Needs_Finalization (Desig_Type) and then Convention (Desig_Type) /= Convention_Java and then Convention (Desig_Type) /= Convention_CIL) or else *************** package body Exp_Ch3 is *** 5986,5992 **** or else (Is_Array_Type (Desig_Type) and then not Is_Frozen (Desig_Type) ! and then Controlled_Type (Component_Type (Desig_Type))) -- The designated type has controlled anonymous access -- discriminants. --- 6209,6215 ---- or else (Is_Array_Type (Desig_Type) and then not Is_Frozen (Desig_Type) ! and then Needs_Finalization (Component_Type (Desig_Type))) -- The designated type has controlled anonymous access -- discriminants. *************** package body Exp_Ch3 is *** 6046,6054 **** function Get_Simple_Init_Val (T : Entity_Id; ! Loc : Source_Ptr; Size : Uint := No_Uint) return Node_Id is Val : Node_Id; Result : Node_Id; Val_RE : RE_Id; --- 6269,6278 ---- function Get_Simple_Init_Val (T : Entity_Id; ! N : Node_Id; Size : Uint := No_Uint) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); Val : Node_Id; Result : Node_Id; Val_RE : RE_Id; *************** package body Exp_Ch3 is *** 6057,6062 **** --- 6281,6290 ---- -- This is the size to be used for computation of the appropriate -- initial value for the Normalize_Scalars and Initialize_Scalars case. + IV_Attribute : constant Boolean := + Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Invalid_Value; + Lo_Bound : Uint; Hi_Bound : Uint; -- These are the values computed by the procedure Check_Subtype_Bounds *************** package body Exp_Ch3 is *** 6133,6139 **** -- an Unchecked_Convert to the private type. if Is_Private_Type (T) then ! Val := Get_Simple_Init_Val (Underlying_Type (T), Loc, Size); -- A special case, if the underlying value is null, then qualify it -- with the underlying type, so that the null is properly typed --- 6361,6367 ---- -- an Unchecked_Convert to the private type. if Is_Private_Type (T) then ! Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size); -- A special case, if the underlying value is null, then qualify it -- with the underlying type, so that the null is properly typed *************** package body Exp_Ch3 is *** 6160,6169 **** return Result; ! -- For scalars, we must have normalize/initialize scalars case elsif Is_Scalar_Type (T) then ! pragma Assert (Init_Or_Norm_Scalars); -- Compute size of object. If it is given by the caller, we can use -- it directly, otherwise we use Esize (T) as an estimate. As far as --- 6388,6398 ---- return Result; ! -- For scalars, we must have normalize/initialize scalars case, or ! -- if the node N is an 'Invalid_Value attribute node. elsif Is_Scalar_Type (T) then ! pragma Assert (Init_Or_Norm_Scalars or IV_Attribute); -- Compute size of object. If it is given by the caller, we can use -- it directly, otherwise we use Esize (T) as an estimate. As far as *************** package body Exp_Ch3 is *** 6188,6194 **** -- Processing for Normalize_Scalars case ! if Normalize_Scalars then -- If zero is invalid, it is a convenient value to use that is -- for sure an appropriate invalid value in all situations. --- 6417,6423 ---- -- Processing for Normalize_Scalars case ! if Normalize_Scalars and then not IV_Attribute then -- If zero is invalid, it is a convenient value to use that is -- for sure an appropriate invalid value in all situations. *************** package body Exp_Ch3 is *** 6252,6258 **** end; end if; ! -- Here for Initialize_Scalars case else -- For float types, use float values from System.Scalar_Values --- 6481,6487 ---- end; end if; ! -- Here for Initialize_Scalars case (or Invalid_Value attribute used) else -- For float types, use float values from System.Scalar_Values *************** package body Exp_Ch3 is *** 6347,6353 **** Make_Others_Choice (Loc)), Expression => Get_Simple_Init_Val ! (Component_Type (T), Loc, Esize (Root_Type (T)))))); -- Access type is initialized to null --- 6576,6582 ---- Make_Others_Choice (Loc)), Expression => Get_Simple_Init_Val ! (Component_Type (T), N, Esize (Root_Type (T)))))); -- Access type is initialized to null *************** package body Exp_Ch3 is *** 6431,6437 **** Warning_Needed := True; else ! -- Verify that at least one component has an initializtion -- expression. No need for a warning on a type if all its -- components have no initialization. --- 6660,6666 ---- Warning_Needed := True; else ! -- Verify that at least one component has an initialization -- expression. No need for a warning on a type if all its -- components have no initialization. *************** package body Exp_Ch3 is *** 6604,6610 **** -- Initialize the pointer to the secondary DT associated with the -- interface. ! if not Is_Parent (Iface, Typ) then Append_To (Stmts_List, Make_Assignment_Statement (Loc, Name => --- 6833,6839 ---- -- Initialize the pointer to the secondary DT associated with the -- interface. ! if not Is_Ancestor (Iface, Typ) then Append_To (Stmts_List, Make_Assignment_Statement (Loc, Name => *************** package body Exp_Ch3 is *** 6615,6628 **** New_Reference_To (Iface_Tag, Loc))); end if; - -- Issue error if Set_Offset_To_Top is not available in a - -- configurable run-time environment. - - if not RTE_Available (RE_Set_Offset_To_Top) then - Error_Msg_CRT ("abstract interface types", Typ); - return; - end if; - Comp_Typ := Scope (Tag_Comp); -- Initialize the entries of the table of interfaces. We generate a --- 6844,6849 ---- *************** package body Exp_Ch3 is *** 6636,6652 **** pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp))); -- Generate: ! -- Set_Offset_To_Top -- (This => Init, -- Interface_T => Iface'Tag, - -- Is_Constant => False, -- Offset_Value => n, -- Offset_Func => Fn'Address) Append_To (Stmts_List, Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Copy_Tree (Target), --- 6857,6882 ---- pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp))); + -- Issue error if Set_Dynamic_Offset_To_Top is not available in a + -- configurable run-time environment. + + if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then + Error_Msg_CRT + ("variable size record with interface types", Typ); + return; + end if; + -- Generate: ! -- Set_Dynamic_Offset_To_Top -- (This => Init, -- Interface_T => Iface'Tag, -- Offset_Value => n, -- Offset_Func => Fn'Address) Append_To (Stmts_List, Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To ! (RTE (RE_Set_Dynamic_Offset_To_Top), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Copy_Tree (Target), *************** package body Exp_Ch3 is *** 6657,6664 **** (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)), - New_Occurrence_Of (Standard_False, Loc), - Unchecked_Convert_To (RTE (RE_Storage_Offset), Make_Attribute_Reference (Loc, --- 6887,6892 ---- *************** package body Exp_Ch3 is *** 6700,6741 **** -- Normal case: No discriminants in the parent type else -- Generate: ! -- Set_Offset_To_Top -- (This => Init, -- Interface_T => Iface'Tag, -- Is_Constant => True, -- Offset_Value => n, -- Offset_Func => null); ! Append_To (Stmts_List, ! Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To ! (RTE (RE_Set_Offset_To_Top), Loc), ! Parameter_Associations => New_List ( ! Make_Attribute_Reference (Loc, ! Prefix => New_Copy_Tree (Target), ! Attribute_Name => Name_Address), ! Unchecked_Convert_To (RTE (RE_Tag), ! New_Reference_To ! (Node (First_Elmt ! (Access_Disp_Table (Iface))), ! Loc)), ! New_Occurrence_Of (Standard_True, Loc), ! Unchecked_Convert_To ! (RTE (RE_Storage_Offset), ! Make_Attribute_Reference (Loc, ! Prefix => ! Make_Selected_Component (Loc, ! Prefix => New_Copy_Tree (Target), ! Selector_Name => ! New_Reference_To (Tag_Comp, Loc)), ! Attribute_Name => Name_Position)), ! Make_Null (Loc)))); end if; end Initialize_Tag; --- 6928,6987 ---- -- Normal case: No discriminants in the parent type else + -- Don't need to set any value if this interface shares + -- the primary dispatch table. + + if not Is_Ancestor (Iface, Typ) then + Append_To (Stmts_List, + Build_Set_Static_Offset_To_Top (Loc, + Iface_Tag => New_Reference_To (Iface_Tag, Loc), + Offset_Value => + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position)))); + end if; + -- Generate: ! -- Register_Interface_Offset -- (This => Init, -- Interface_T => Iface'Tag, -- Is_Constant => True, -- Offset_Value => n, -- Offset_Func => null); ! if RTE_Available (RE_Register_Interface_Offset) then ! Append_To (Stmts_List, ! Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To ! (RTE (RE_Register_Interface_Offset), Loc), ! Parameter_Associations => New_List ( ! Make_Attribute_Reference (Loc, ! Prefix => New_Copy_Tree (Target), ! Attribute_Name => Name_Address), ! Unchecked_Convert_To (RTE (RE_Tag), ! New_Reference_To ! (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)), ! New_Occurrence_Of (Standard_True, Loc), ! Unchecked_Convert_To ! (RTE (RE_Storage_Offset), ! Make_Attribute_Reference (Loc, ! Prefix => ! Make_Selected_Component (Loc, ! Prefix => New_Copy_Tree (Target), ! Selector_Name => ! New_Reference_To (Tag_Comp, Loc)), ! Attribute_Name => Name_Position)), ! Make_Null (Loc)))); ! end if; end if; end Initialize_Tag; *************** package body Exp_Ch3 is *** 6782,6788 **** Tag_Comp => Tag_Comp, Iface_Tag => Node (Iface_Tag_Elmt)); ! -- Otherwise we generate code to initialize the tag else -- Check if the parent of the record type has variable size --- 7028,7034 ---- Tag_Comp => Tag_Comp, Iface_Tag => Node (Iface_Tag_Elmt)); ! -- Otherwise generate code to initialize the tag else -- Check if the parent of the record type has variable size *************** package body Exp_Ch3 is *** 6816,6821 **** --- 7062,7093 ---- Comp_Typ : Entity_Id; Idx : Node_Id; + function Is_Constant_Bound (Exp : Node_Id) return Boolean; + -- To simplify handling of array components. Determines whether the + -- given bound is constant (a constant or enumeration literal, or an + -- integer literal) as opposed to per-object, through an expression + -- or a discriminant. + + ----------------------- + -- Is_Constant_Bound -- + ----------------------- + + function Is_Constant_Bound (Exp : Node_Id) return Boolean is + begin + if Nkind (Exp) = N_Integer_Literal then + return True; + else + return + Is_Entity_Name (Exp) + and then Present (Entity (Exp)) + and then + (Ekind (Entity (Exp)) = E_Constant + or else Ekind (Entity (Exp)) = E_Enumeration_Literal); + end if; + end Is_Constant_Bound; + + -- Start of processing for Is_Variable_Sized_Record + begin pragma Assert (Is_Record_Type (E)); *************** package body Exp_Ch3 is *** 6840,6854 **** Idx := First_Index (Comp_Typ); while Present (Idx) loop if Nkind (Idx) = N_Range then ! if (Nkind (Low_Bound (Idx)) = N_Identifier ! and then Present (Entity (Low_Bound (Idx))) ! and then ! Ekind (Entity (Low_Bound (Idx))) /= E_Constant) ! or else ! (Nkind (High_Bound (Idx)) = N_Identifier ! and then Present (Entity (High_Bound (Idx))) ! and then ! Ekind (Entity (High_Bound (Idx))) /= E_Constant) then return True; end if; --- 7112,7120 ---- Idx := First_Index (Comp_Typ); while Present (Idx) loop if Nkind (Idx) = N_Range then ! if not Is_Constant_Bound (Low_Bound (Idx)) ! or else ! not Is_Constant_Bound (High_Bound (Idx)) then return True; end if; *************** package body Exp_Ch3 is *** 7046,7052 **** -- Make_Eq_Case -- ------------------ ! -- -- case X.D1 is -- when V1 => on subcomponents -- ... --- 7312,7318 ---- -- Make_Eq_Case -- ------------------ ! -- -- case X.D1 is -- when V1 => on subcomponents -- ... *************** package body Exp_Ch3 is *** 7388,7414 **** -- User-defined equality elsif Chars (Node (Prim)) = Name_Op_Eq - and then (No (Alias (Node (Prim))) - or else Nkind (Unit_Declaration_Node (Node (Prim))) = - N_Subprogram_Renaming_Declaration) and then Etype (First_Formal (Node (Prim))) = Etype (Next_Formal (First_Formal (Node (Prim)))) and then Base_Type (Etype (Node (Prim))) = Standard_Boolean then ! Eq_Needed := False; ! exit; ! -- If the parent is not an interface type and has an abstract ! -- equality function, the inherited equality is abstract as well, ! -- and no body can be created for it. ! elsif Chars (Node (Prim)) = Name_Op_Eq ! and then not Is_Interface (Etype (Tag_Typ)) ! and then Present (Alias (Node (Prim))) ! and then Is_Abstract_Subprogram (Alias (Node (Prim))) ! then ! Eq_Needed := False; ! exit; end if; Next_Elmt (Prim); --- 7654,7695 ---- -- User-defined equality elsif Chars (Node (Prim)) = Name_Op_Eq and then Etype (First_Formal (Node (Prim))) = Etype (Next_Formal (First_Formal (Node (Prim)))) and then Base_Type (Etype (Node (Prim))) = Standard_Boolean then ! if No (Alias (Node (Prim))) ! or else Nkind (Unit_Declaration_Node (Node (Prim))) = ! N_Subprogram_Renaming_Declaration ! then ! Eq_Needed := False; ! exit; ! -- If the parent is not an interface type and has an abstract ! -- equality function, the inherited equality is abstract as ! -- well, and no body can be created for it. ! elsif not Is_Interface (Etype (Tag_Typ)) ! and then Present (Alias (Node (Prim))) ! and then Is_Abstract_Subprogram (Alias (Node (Prim))) ! then ! Eq_Needed := False; ! exit; ! ! -- If the type has an equality function corresponding with ! -- a primitive defined in an interface type, the inherited ! -- equality is abstract as well, and no body can be created ! -- for it. ! ! elsif Present (Alias (Node (Prim))) ! and then Comes_From_Source (Ultimate_Alias (Node (Prim))) ! and then ! Is_Interface ! (Find_Dispatching_Type (Ultimate_Alias (Node (Prim)))) ! then ! Eq_Needed := False; ! exit; ! end if; end if; Next_Elmt (Prim); *************** package body Exp_Ch3 is *** 7506,7511 **** --- 7787,7793 ---- if Ada_Version >= Ada_05 and then VM_Target = No_VM + and then RTE_Available (RE_Select_Specific_Data) then -- These primitives are defined abstract in interface types *************** package body Exp_Ch3 is *** 7551,7557 **** and then Is_Limited_Record (Etype (Tag_Typ))) or else (Is_Concurrent_Record_Type (Tag_Typ) ! and then Has_Abstract_Interfaces (Tag_Typ)) then Append_To (Res, Make_Subprogram_Declaration (Loc, --- 7833,7839 ---- and then Is_Limited_Record (Etype (Tag_Typ))) or else (Is_Concurrent_Record_Type (Tag_Typ) ! and then Has_Interfaces (Tag_Typ)) then Append_To (Res, Make_Subprogram_Declaration (Loc, *************** package body Exp_Ch3 is *** 7601,7615 **** null; elsif Etype (Tag_Typ) = Tag_Typ ! or else Controlled_Type (Tag_Typ) -- Ada 2005 (AI-251): We must also generate these subprograms if -- the immediate ancestor is an interface to ensure the correct -- initialization of its dispatch table. or else (not Is_Interface (Tag_Typ) ! and then ! Is_Interface (Etype (Tag_Typ))) then if not Is_Limited_Type (Tag_Typ) then Append_To (Res, --- 7883,7903 ---- null; elsif Etype (Tag_Typ) = Tag_Typ ! or else Needs_Finalization (Tag_Typ) -- Ada 2005 (AI-251): We must also generate these subprograms if -- the immediate ancestor is an interface to ensure the correct -- initialization of its dispatch table. or else (not Is_Interface (Tag_Typ) ! and then Is_Interface (Etype (Tag_Typ))) ! ! -- Ada 205 (AI-251): We must also generate these subprograms if ! -- the parent of an nonlimited interface is a limited interface ! ! or else (Is_Interface (Tag_Typ) ! and then not Is_Limited_Interface (Tag_Typ) ! and then Is_Limited_Interface (Etype (Tag_Typ))) then if not Is_Limited_Type (Tag_Typ) then Append_To (Res, *************** package body Exp_Ch3 is *** 7998,8004 **** ((Is_Interface (Etype (Tag_Typ)) and then Is_Limited_Record (Etype (Tag_Typ))) or else (Is_Concurrent_Record_Type (Tag_Typ) ! and then Has_Abstract_Interfaces (Tag_Typ))) then Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); --- 8286,8293 ---- ((Is_Interface (Etype (Tag_Typ)) and then Is_Limited_Record (Etype (Tag_Typ))) or else (Is_Concurrent_Record_Type (Tag_Typ) ! and then Has_Interfaces (Tag_Typ))) ! and then RTE_Available (RE_Select_Specific_Data) then Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch3.ads gcc-4.4.0/gcc/ada/exp_ch3.ads *** gcc-4.3.3/gcc/ada/exp_ch3.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_ch3.ads Tue Apr 8 06:47:55 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Exp_Ch3 is *** 133,148 **** function Get_Simple_Init_Val (T : Entity_Id; ! Loc : Source_Ptr; Size : Uint := No_Uint) return Node_Id; -- For a type which Needs_Simple_Initialization (see above), prepares the ! -- tree for an expression representing the required initial value. Loc is ! -- the source location used in constructing this tree which is returned as ! -- the result of the call. The Size parameter indicates the target size of ! -- the object if it is known (indicated by a value that is not No_Uint and ! -- is greater than zero). If Size is not given (Size set to No_Uint, or ! -- non-positive), then the Esize of T is used as an estimate of the Size. ! -- The object size is needed to prepare a known invalid value for use by ! -- Normalize_Scalars. end Exp_Ch3; --- 133,150 ---- function Get_Simple_Init_Val (T : Entity_Id; ! N : Node_Id; Size : Uint := No_Uint) return Node_Id; -- For a type which Needs_Simple_Initialization (see above), prepares the ! -- tree for an expression representing the required initial value. N is a ! -- node whose source location used in constructing this tree which is ! -- returned as the result of the call. The Size parameter indicates the ! -- target size of the object if it is known (indicated by a value that is ! -- not No_Uint and is greater than zero). If Size is not given (Size set to ! -- No_Uint, or non-positive), then the Esize of T is used as an estimate of ! -- the Size. The object size is needed to prepare a known invalid value for ! -- use by Normalize_Scalars. A call to this routine where T is a scalar ! -- type is only valid if we are in Normalize_Scalars or Initialize_Scalars ! -- mode, or if N is the node for a 'Invalid_Value attribute node. end Exp_Ch3; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch4.adb gcc-4.4.0/gcc/ada/exp_ch4.adb *** gcc-4.3.3/gcc/ada/exp_ch4.adb Thu Dec 13 10:25:14 2007 --- gcc-4.4.0/gcc/ada/exp_ch4.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Exp_Ch4 is *** 110,129 **** Bodies : List_Id; Typ : Entity_Id) return Node_Id; -- Expand an array equality into a call to a function implementing this ! -- equality, and a call to it. Loc is the location for the generated ! -- nodes. Lhs and Rhs are the array expressions to be compared. ! -- Bodies is a list on which to attach bodies of local functions that ! -- are created in the process. It is the responsibility of the ! -- caller to insert those bodies at the right place. Nod provides ! -- the Sloc value for the generated code. Normally the types used ! -- for the generated equality routine are taken from Lhs and Rhs. ! -- However, in some situations of generated code, the Etype fields ! -- of Lhs and Rhs are not set yet. In such cases, Typ supplies the ! -- type to be used for the formal parameters. procedure Expand_Boolean_Operator (N : Node_Id); ! -- Common expansion processing for Boolean operators (And, Or, Xor) ! -- for the case of array type arguments. function Expand_Composite_Equality (Nod : Node_Id; --- 110,128 ---- Bodies : List_Id; Typ : Entity_Id) return Node_Id; -- Expand an array equality into a call to a function implementing this ! -- equality, and a call to it. Loc is the location for the generated nodes. ! -- Lhs and Rhs are the array expressions to be compared. Bodies is a list ! -- on which to attach bodies of local functions that are created in the ! -- process. It is the responsibility of the caller to insert those bodies ! -- at the right place. Nod provides the Sloc value for the generated code. ! -- Normally the types used for the generated equality routine are taken ! -- from Lhs and Rhs. However, in some situations of generated code, the ! -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies ! -- the type to be used for the formal parameters. procedure Expand_Boolean_Operator (N : Node_Id); ! -- Common expansion processing for Boolean operators (And, Or, Xor) for the ! -- case of array type arguments. function Expand_Composite_Equality (Nod : Node_Id; *************** package body Exp_Ch4 is *** 131,170 **** Lhs : Node_Id; Rhs : Node_Id; Bodies : List_Id) return Node_Id; ! -- Local recursive function used to expand equality for nested ! -- composite types. Used by Expand_Record/Array_Equality, Bodies ! -- is a list on which to attach bodies of local functions that are ! -- created in the process. This is the responsability of the caller ! -- to insert those bodies at the right place. Nod provides the Sloc ! -- value for generated code. Lhs and Rhs are the left and right sides ! -- for the comparison, and Typ is the type of the arrays to compare. procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id); ! -- This routine handles expansion of concatenation operations, where ! -- N is the N_Op_Concat node being expanded and Operands is the list ! -- of operands (at least two are present). The caller has dealt with ! -- converting any singleton operands into singleton aggregates. procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id); -- Routine to expand concatenation of 2-5 operands (in the list Operands) ! -- and replace node Cnode with the result of the contatenation. If there -- are two operands, they can be string or character. If there are more -- than two operands, then are always of type string (i.e. the caller has -- already converted character operands to strings in this case). procedure Fixup_Universal_Fixed_Operation (N : Node_Id); ! -- N is either an N_Op_Divide or N_Op_Multiply node whose result is ! -- universal fixed. We do not have such a type at runtime, so the ! -- purpose of this routine is to find the real type by looking up ! -- the tree. We also determine if the operation must be rounded. function Get_Allocator_Final_List (N : Node_Id; T : Entity_Id; PtrT : Entity_Id) return Entity_Id; ! -- If the designated type is controlled, build final_list expression ! -- for created object. If context is an access parameter, create a ! -- local access type to have a usable finalization list. function Has_Inferable_Discriminants (N : Node_Id) return Boolean; -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable --- 130,169 ---- Lhs : Node_Id; Rhs : Node_Id; Bodies : List_Id) return Node_Id; ! -- Local recursive function used to expand equality for nested composite ! -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which ! -- to attach bodies of local functions that are created in the process. ! -- This is the responsibility of the caller to insert those bodies at the ! -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs ! -- are the left and right sides for the comparison, and Typ is the type of ! -- the arrays to compare. procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id); ! -- This routine handles expansion of concatenation operations, where N is ! -- the N_Op_Concat node being expanded and Operands is the list of operands ! -- (at least two are present). The caller has dealt with converting any ! -- singleton operands into singleton aggregates. procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id); -- Routine to expand concatenation of 2-5 operands (in the list Operands) ! -- and replace node Cnode with the result of the concatenation. If there -- are two operands, they can be string or character. If there are more -- than two operands, then are always of type string (i.e. the caller has -- already converted character operands to strings in this case). procedure Fixup_Universal_Fixed_Operation (N : Node_Id); ! -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal ! -- fixed. We do not have such a type at runtime, so the purpose of this ! -- routine is to find the real type by looking up the tree. We also ! -- determine if the operation must be rounded. function Get_Allocator_Final_List (N : Node_Id; T : Entity_Id; PtrT : Entity_Id) return Entity_Id; ! -- If the designated type is controlled, build final_list expression for ! -- created object. If context is an access parameter, create a local access ! -- type to have a usable finalization list. function Has_Inferable_Discriminants (N : Node_Id) return Boolean; -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable *************** package body Exp_Ch4 is *** 185,206 **** function Make_Array_Comparison_Op (Typ : Entity_Id; Nod : Node_Id) return Node_Id; ! -- Comparisons between arrays are expanded in line. This function ! -- produces the body of the implementation of (a > b), where a and b ! -- are one-dimensional arrays of some discrete type. The original ! -- node is then expanded into the appropriate call to this function. ! -- Nod provides the Sloc value for the generated code. function Make_Boolean_Array_Op (Typ : Entity_Id; N : Node_Id) return Node_Id; ! -- Boolean operations on boolean arrays are expanded in line. This ! -- function produce the body for the node N, which is (a and b), ! -- (a or b), or (a xor b). It is used only the normal case and not ! -- the packed case. The type involved, Typ, is the Boolean array type, ! -- and the logical operations in the body are simple boolean operations. ! -- Note that Typ is always a constrained type (the caller has ensured ! -- this by using Convert_To_Actual_Subtype if necessary). procedure Rewrite_Comparison (N : Node_Id); -- If N is the node for a comparison whose outcome can be determined at --- 184,205 ---- function Make_Array_Comparison_Op (Typ : Entity_Id; Nod : Node_Id) return Node_Id; ! -- Comparisons between arrays are expanded in line. This function produces ! -- the body of the implementation of (a > b), where a and b are one- ! -- dimensional arrays of some discrete type. The original node is then ! -- expanded into the appropriate call to this function. Nod provides the ! -- Sloc value for the generated code. function Make_Boolean_Array_Op (Typ : Entity_Id; N : Node_Id) return Node_Id; ! -- Boolean operations on boolean arrays are expanded in line. This function ! -- produce the body for the node N, which is (a and b), (a or b), or (a xor ! -- b). It is used only the normal case and not the packed case. The type ! -- involved, Typ, is the Boolean array type, and the logical operations in ! -- the body are simple boolean operations. Note that Typ is always a ! -- constrained type (the caller has ensured this by using ! -- Convert_To_Actual_Subtype if necessary). procedure Rewrite_Comparison (N : Node_Id); -- If N is the node for a comparison whose outcome can be determined at *************** package body Exp_Ch4 is *** 218,226 **** (Lhs : Node_Id; Op1 : Node_Id; Op2 : Node_Id) return Boolean; ! -- In the context of an assignment, where the right-hand side is a ! -- boolean operation on arrays, check whether operation can be performed ! -- in place. procedure Unary_Op_Validity_Checks (N : Node_Id); pragma Inline (Unary_Op_Validity_Checks); --- 217,224 ---- (Lhs : Node_Id; Op1 : Node_Id; Op2 : Node_Id) return Boolean; ! -- In the context of an assignment, where the right-hand side is a boolean ! -- operation on arrays, check whether operation can be performed in place. procedure Unary_Op_Validity_Checks (N : Node_Id); pragma Inline (Unary_Op_Validity_Checks); *************** package body Exp_Ch4 is *** 440,446 **** -- implement the target interface. This case corresponds with the -- following example: ! -- function Op (Obj : Iface_1'Class) return access Ifac_2e'Class is -- begin -- return new Iface_2'Class'(Obj); -- end Op; --- 438,444 ---- -- implement the target interface. This case corresponds with the -- following example: ! -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is -- begin -- return new Iface_2'Class'(Obj); -- end Op; *************** package body Exp_Ch4 is *** 478,505 **** (Ref : Node_Id; Built_In_Place : Boolean := False); -- Ada 2005 (AI-344): For an allocator with a class-wide designated ! -- type, generate an accessibility check to verify that the level of ! -- the type of the created object is not deeper than the level of the ! -- access type. If the type of the qualified expression is class- ! -- wide, then always generate the check (except in the case where it ! -- is known to be unnecessary, see comment below). Otherwise, only ! -- generate the check if the level of the qualified expression type ! -- is statically deeper than the access type. Although the static ! -- accessibility will generally have been performed as a legality ! -- check, it won't have been done in cases where the allocator ! -- appears in generic body, so a run-time check is needed in general. ! -- One special case is when the access type is declared in the same ! -- scope as the class-wide allocator, in which case the check can ! -- never fail, so it need not be generated. As an open issue, there ! -- seem to be cases where the static level associated with the ! -- class-wide object's underlying type is not sufficient to perform ! -- the proper accessibility check, such as for allocators in nested ! -- subprograms or accept statements initialized by class-wide formals ! -- when the actual originates outside at a deeper static level. The ! -- nested subprogram case might require passing accessibility levels ! -- along with class-wide parameters, and the task case seems to be ! -- an actual gap in the language rules that needs to be fixed by the ! -- ARG. ??? ------------------------------- -- Apply_Accessibility_Check -- --- 476,505 ---- (Ref : Node_Id; Built_In_Place : Boolean := False); -- Ada 2005 (AI-344): For an allocator with a class-wide designated ! -- type, generate an accessibility check to verify that the level of the ! -- type of the created object is not deeper than the level of the access ! -- type. If the type of the qualified expression is class- wide, then ! -- always generate the check (except in the case where it is known to be ! -- unnecessary, see comment below). Otherwise, only generate the check ! -- if the level of the qualified expression type is statically deeper ! -- than the access type. ! -- ! -- Although the static accessibility will generally have been performed ! -- as a legality check, it won't have been done in cases where the ! -- allocator appears in generic body, so a run-time check is needed in ! -- general. One special case is when the access type is declared in the ! -- same scope as the class-wide allocator, in which case the check can ! -- never fail, so it need not be generated. ! -- ! -- As an open issue, there seem to be cases where the static level ! -- associated with the class-wide object's underlying type is not ! -- sufficient to perform the proper accessibility check, such as for ! -- allocators in nested subprograms or accept statements initialized by ! -- class-wide formals when the actual originates outside at a deeper ! -- static level. The nested subprogram case might require passing ! -- accessibility levels along with class-wide parameters, and the task ! -- case seems to be an actual gap in the language rules that needs to ! -- be fixed by the ARG. ??? ------------------------------- -- Apply_Accessibility_Check -- *************** package body Exp_Ch4 is *** 575,588 **** -- Start of processing for Expand_Allocator_Expression begin ! if Is_Tagged_Type (T) or else Controlled_Type (T) then ! -- Ada 2005 (AI-318-02): If the initialization expression is a ! -- call to a build-in-place function, then access to the allocated ! -- object must be passed to the function. Currently we limit such ! -- functions to those with constrained limited result subtypes, ! -- but eventually we plan to expand the allowed forms of funtions ! -- that are treated as build-in-place. if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function_Call (Exp) --- 575,588 ---- -- Start of processing for Expand_Allocator_Expression begin ! if Is_Tagged_Type (T) or else Needs_Finalization (T) then ! -- Ada 2005 (AI-318-02): If the initialization expression is a call ! -- to a build-in-place function, then access to the allocated object ! -- must be passed to the function. Currently we limit such functions ! -- to those with constrained limited result subtypes, but eventually ! -- we plan to expand the allowed forms of functions that are treated ! -- as build-in-place. if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function_Call (Exp) *************** package body Exp_Ch4 is *** 669,675 **** Set_No_Initialization (Expression (Tmp_Node)); Insert_Action (N, Tmp_Node); ! if Controlled_Type (T) and then Ekind (PtrT) = E_Anonymous_Access_Type then -- Create local finalization list for access parameter --- 669,675 ---- Set_No_Initialization (Expression (Tmp_Node)); Insert_Action (N, Tmp_Node); ! if Needs_Finalization (T) and then Ekind (PtrT) = E_Anonymous_Access_Type then -- Create local finalization list for access parameter *************** package body Exp_Ch4 is *** 717,723 **** -- Inherit the final chain to ensure that the expansion of the -- aggregate is correct in case of controlled types ! if Controlled_Type (Directly_Designated_Type (PtrT)) then Set_Associated_Final_Chain (Def_Id, Associated_Final_Chain (PtrT)); end if; --- 717,723 ---- -- Inherit the final chain to ensure that the expansion of the -- aggregate is correct in case of controlled types ! if Needs_Finalization (Directly_Designated_Type (PtrT)) then Set_Associated_Final_Chain (Def_Id, Associated_Final_Chain (PtrT)); end if; *************** package body Exp_Ch4 is *** 739,745 **** Set_No_Initialization (Expression (Tmp_Node)); Insert_Action (N, Tmp_Node); ! if Controlled_Type (T) and then Ekind (PtrT) = E_Anonymous_Access_Type then -- Create local finalization list for access parameter --- 739,745 ---- Set_No_Initialization (Expression (Tmp_Node)); Insert_Action (N, Tmp_Node); ! if Needs_Finalization (T) and then Ekind (PtrT) = E_Anonymous_Access_Type then -- Create local finalization list for access parameter *************** package body Exp_Ch4 is *** 762,772 **** -- Generate an additional object containing the address of the -- returned object. The type of this second object declaration ! -- is the correct type required for the common proceessing ! -- that is still performed by this subprogram. The displacement ! -- of this pointer to reference the component associated with ! -- the interface type will be done at the end of the common ! -- processing. New_Decl := Make_Object_Declaration (Loc, --- 762,771 ---- -- Generate an additional object containing the address of the -- returned object. The type of this second object declaration ! -- is the correct type required for the common processing that ! -- is still performed by this subprogram. The displacement of ! -- this pointer to reference the component associated with the ! -- interface type will be done at the end of common processing. New_Decl := Make_Object_Declaration (Loc, *************** package body Exp_Ch4 is *** 836,843 **** Insert_Action (N, Tag_Assign); end if; ! if Controlled_Type (DesigT) ! and then Controlled_Type (T) then declare Attach : Node_Id; --- 835,842 ---- Insert_Action (N, Tag_Assign); end if; ! if Needs_Finalization (DesigT) ! and then Needs_Finalization (T) then declare Attach : Node_Id; *************** package body Exp_Ch4 is *** 845,854 **** Associated_Storage_Pool (PtrT); begin ! -- If it is an allocation on the secondary stack ! -- (i.e. a value returned from a function), the object ! -- is attached on the caller side as soon as the call ! -- is completed (see Expand_Ctrl_Function_Call) if Is_RTE (Apool, RE_SS_Pool) then declare --- 844,853 ---- Associated_Storage_Pool (PtrT); begin ! -- If it is an allocation on the secondary stack (i.e. a value ! -- returned from a function), the object is attached on the ! -- caller side as soon as the call is completed (see ! -- Expand_Ctrl_Function_Call) if Is_RTE (Apool, RE_SS_Pool) then declare *************** package body Exp_Ch4 is *** 869,875 **** -- Normal case, not a secondary stack allocation else ! if Controlled_Type (T) and then Ekind (PtrT) = E_Anonymous_Access_Type then -- Create local finalization list for access parameter --- 868,874 ---- -- Normal case, not a secondary stack allocation else ! if Needs_Finalization (T) and then Ekind (PtrT) = E_Anonymous_Access_Type then -- Create local finalization list for access parameter *************** package body Exp_Ch4 is *** 899,908 **** Make_Adjust_Call ( Ref => ! -- An unchecked conversion is needed in the ! -- classwide case because the designated type ! -- can be an ancestor of the subtype mark of ! -- the allocator. Unchecked_Convert_To (T, Make_Explicit_Dereference (Loc, --- 898,906 ---- Make_Adjust_Call ( Ref => ! -- An unchecked conversion is needed in the classwide ! -- case because the designated type can be an ancestor of ! -- the subtype mark of the allocator. Unchecked_Convert_To (T, Make_Explicit_Dereference (Loc, *************** package body Exp_Ch4 is *** 919,927 **** Rewrite (N, New_Reference_To (Temp, Loc)); Analyze_And_Resolve (N, PtrT); ! -- Ada 2005 (AI-251): Displace the pointer to reference the ! -- record component containing the secondary dispatch table ! -- of the interface type. if Is_Interface (Directly_Designated_Type (PtrT)) then Displace_Allocator_Pointer (N); --- 917,925 ---- Rewrite (N, New_Reference_To (Temp, Loc)); Analyze_And_Resolve (N, PtrT); ! -- Ada 2005 (AI-251): Displace the pointer to reference the record ! -- component containing the secondary dispatch table of the interface ! -- type. if Is_Interface (Directly_Designated_Type (PtrT)) then Displace_Allocator_Pointer (N); *************** package body Exp_Ch4 is *** 946,951 **** --- 944,954 ---- Rewrite (N, New_Reference_To (Temp, Loc)); Analyze_And_Resolve (N, PtrT); + elsif Is_Access_Type (T) + and then Can_Never_Be_Null (T) + then + Install_Null_Excluding_Check (Exp); + elsif Is_Access_Type (DesigT) and then Nkind (Exp) = N_Allocator and then Nkind (Expression (Exp)) /= N_Qualified_Expression *************** package body Exp_Ch4 is *** 965,1005 **** else -- First check against the type of the qualified expression -- ! -- NOTE: The commented call should be correct, but for ! -- some reason causes the compiler to bomb (sigsegv) on ! -- ACVC test c34007g, so for now we just perform the old ! -- (incorrect) test against the designated subtype with ! -- no sliding in the else part of the if statement below. ! -- ??? -- -- Apply_Constraint_Check (Exp, T, No_Sliding => True); ! -- A check is also needed in cases where the designated ! -- subtype is constrained and differs from the subtype ! -- given in the qualified expression. Note that the check ! -- on the qualified expression does not allow sliding, ! -- but this check does (a relaxation from Ada 83). if Is_Constrained (DesigT) ! and then not Subtypes_Statically_Match ! (T, DesigT) then Apply_Constraint_Check (Exp, DesigT, No_Sliding => False); ! -- The nonsliding check should really be performed ! -- (unconditionally) against the subtype of the ! -- qualified expression, but that causes a problem ! -- with c34007g (see above), so for now we retain this. else Apply_Constraint_Check (Exp, DesigT, No_Sliding => True); end if; ! -- For an access to unconstrained packed array, GIGI needs ! -- to see an expression with a constrained subtype in order ! -- to compute the proper size for the allocator. if Is_Array_Type (T) and then not Is_Constrained (T) --- 968,1004 ---- else -- First check against the type of the qualified expression -- ! -- NOTE: The commented call should be correct, but for some reason ! -- causes the compiler to bomb (sigsegv) on ACVC test c34007g, so for ! -- now we just perform the old (incorrect) test against the ! -- designated subtype with no sliding in the else part of the if ! -- statement below. ??? -- -- Apply_Constraint_Check (Exp, T, No_Sliding => True); ! -- A check is also needed in cases where the designated subtype is ! -- constrained and differs from the subtype given in the qualified ! -- expression. Note that the check on the qualified expression does ! -- not allow sliding, but this check does (a relaxation from Ada 83). if Is_Constrained (DesigT) ! and then not Subtypes_Statically_Match (T, DesigT) then Apply_Constraint_Check (Exp, DesigT, No_Sliding => False); ! -- The nonsliding check should really be performed (unconditionally) ! -- against the subtype of the qualified expression, but that causes a ! -- problem with c34007g (see above), so for now we retain this. else Apply_Constraint_Check (Exp, DesigT, No_Sliding => True); end if; ! -- For an access to unconstrained packed array, GIGI needs to see an ! -- expression with a constrained subtype in order to compute the ! -- proper size for the allocator. if Is_Array_Type (T) and then not Is_Constrained (T) *************** package body Exp_Ch4 is *** 1021,1032 **** end; end if; ! -- Ada 2005 (AI-318-02): If the initialization expression is a ! -- call to a build-in-place function, then access to the allocated ! -- object must be passed to the function. Currently we limit such ! -- functions to those with constrained limited result subtypes, ! -- but eventually we plan to expand the allowed forms of funtions ! -- that are treated as build-in-place. if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function_Call (Exp) --- 1020,1031 ---- end; end if; ! -- Ada 2005 (AI-318-02): If the initialization expression is a call ! -- to a build-in-place function, then access to the allocated object ! -- must be passed to the function. Currently we limit such functions ! -- to those with constrained limited result subtypes, but eventually ! -- we plan to expand the allowed forms of functions that are treated ! -- as build-in-place. if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function_Call (Exp) *************** package body Exp_Ch4 is *** 1044,1053 **** -- Expand_Array_Comparison -- ----------------------------- ! -- Expansion is only required in the case of array types. For the ! -- unpacked case, an appropriate runtime routine is called. For ! -- packed cases, and also in some other cases where a runtime ! -- routine cannot be called, the form of the expansion is: -- [body for greater_nn; boolean_expression] --- 1043,1052 ---- -- Expand_Array_Comparison -- ----------------------------- ! -- Expansion is only required in the case of array types. For the unpacked ! -- case, an appropriate runtime routine is called. For packed cases, and ! -- also in some other cases where a runtime routine cannot be called, the ! -- form of the expansion is: -- [body for greater_nn; boolean_expression] *************** package body Exp_Ch4 is *** 1071,1079 **** -- True for byte addressable target function Length_Less_Than_4 (Opnd : Node_Id) return Boolean; ! -- Returns True if the length of the given operand is known to be ! -- less than 4. Returns False if this length is known to be four ! -- or greater or is not known at compile time. ------------------------ -- Length_Less_Than_4 -- --- 1070,1078 ---- -- True for byte addressable target function Length_Less_Than_4 (Opnd : Node_Id) return Boolean; ! -- Returns True if the length of the given operand is known to be less ! -- than 4. Returns False if this length is known to be four or greater ! -- or is not known at compile time. ------------------------ -- Length_Less_Than_4 -- *************** package body Exp_Ch4 is *** 1272,1279 **** -- Expand_Array_Equality -- --------------------------- ! -- Expand an equality function for multi-dimensional arrays. Here is ! -- an example of such a function for Nb_Dimension = 2 -- function Enn (A : atyp; B : btyp) return boolean is -- begin --- 1271,1278 ---- -- Expand_Array_Equality -- --------------------------- ! -- Expand an equality function for multi-dimensional arrays. Here is an ! -- example of such a function for Nb_Dimension = 2 -- function Enn (A : atyp; B : btyp) return boolean is -- begin *************** package body Exp_Ch4 is *** 1320,1334 **** -- return true; -- end Enn; ! -- Note on the formal types used (atyp and btyp). If either of the ! -- arrays is of a private type, we use the underlying type, and ! -- do an unchecked conversion of the actual. If either of the arrays ! -- has a bound depending on a discriminant, then we use the base type ! -- since otherwise we have an escaped discriminant in the function. ! -- If both arrays are constrained and have the same bounds, we can ! -- generate a loop with an explicit iteration scheme using a 'Range ! -- attribute over the first array. function Expand_Array_Equality (Nod : Node_Id; --- 1319,1333 ---- -- return true; -- end Enn; ! -- Note on the formal types used (atyp and btyp). If either of the arrays ! -- is of a private type, we use the underlying type, and do an unchecked ! -- conversion of the actual. If either of the arrays has a bound depending ! -- on a discriminant, then we use the base type since otherwise we have an ! -- escaped discriminant in the function. ! -- If both arrays are constrained and have the same bounds, we can generate ! -- a loop with an explicit iteration scheme using a 'Range attribute over ! -- the first array. function Expand_Array_Equality (Nod : Node_Id; *************** package body Exp_Ch4 is *** 1361,1372 **** -- This builds the attribute reference Arr'Nam (Expr) function Component_Equality (Typ : Entity_Id) return Node_Id; ! -- Create one statement to compare corresponding components, ! -- designated by a full set of indices. function Get_Arg_Type (N : Node_Id) return Entity_Id; ! -- Given one of the arguments, computes the appropriate type to ! -- be used for that argument in the corresponding function formal function Handle_One_Dimension (N : Int; --- 1360,1371 ---- -- This builds the attribute reference Arr'Nam (Expr) function Component_Equality (Typ : Entity_Id) return Node_Id; ! -- Create one statement to compare corresponding components, designated ! -- by a full set of indices. function Get_Arg_Type (N : Node_Id) return Entity_Id; ! -- Given one of the arguments, computes the appropriate type to be used ! -- for that argument in the corresponding function formal function Handle_One_Dimension (N : Int; *************** package body Exp_Ch4 is *** 1392,1404 **** -- end loop -- -- N is the dimension for which we are generating a loop. Index is the ! -- N'th index node, whose Etype is Index_Type_n in the above code. ! -- The xxx statement is either the loop or declare for the next ! -- dimension or if this is the last dimension the comparison ! -- of corresponding components of the arrays. -- ! -- The actual way the code works is to return the comparison ! -- of corresponding components for the N+1 call. That's neater! function Test_Empty_Arrays return Node_Id; -- This function constructs the test for both arrays being empty --- 1391,1403 ---- -- end loop -- -- N is the dimension for which we are generating a loop. Index is the ! -- N'th index node, whose Etype is Index_Type_n in the above code. The ! -- xxx statement is either the loop or declare for the next dimension ! -- or if this is the last dimension the comparison of corresponding ! -- components of the arrays. -- ! -- The actual way the code works is to return the comparison of ! -- corresponding components for the N+1 call. That's neater! function Test_Empty_Arrays return Node_Id; -- This function constructs the test for both arrays being empty *************** package body Exp_Ch4 is *** 1407,1414 **** -- (B'length (1) = 0 or else B'length (2) = 0 or else ...) function Test_Lengths_Correspond return Node_Id; ! -- This function constructs the test for arrays having different ! -- lengths in at least one index position, in which case resull -- A'length (1) /= B'length (1) -- or else --- 1406,1413 ---- -- (B'length (1) = 0 or else B'length (2) = 0 or else ...) function Test_Lengths_Correspond return Node_Id; ! -- This function constructs the test for arrays having different lengths ! -- in at least one index position, in which case the resulting code is: -- A'length (1) /= B'length (1) -- or else *************** package body Exp_Ch4 is *** 1463,1470 **** if Nkind (Test) = N_Raise_Program_Error then -- This node is going to be inserted at a location where a ! -- statement is expected: clear its Etype so analysis will ! -- set it to the expected Standard_Void_Type. Set_Etype (Test, Empty); return Test; --- 1462,1469 ---- if Nkind (Test) = N_Raise_Program_Error then -- This node is going to be inserted at a location where a ! -- statement is expected: clear its Etype so analysis will set ! -- it to the expected Standard_Void_Type. Set_Etype (Test, Empty); return Test; *************** package body Exp_Ch4 is *** 1525,1532 **** Ltyp /= Rtyp or else not Is_Constrained (Ltyp); -- If the index types are identical, and we are working with ! -- constrained types, then we can use the same index for both of ! -- the arrays. An : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('A')); --- 1524,1531 ---- Ltyp /= Rtyp or else not Is_Constrained (Ltyp); -- If the index types are identical, and we are working with ! -- constrained types, then we can use the same index for both ! -- of the arrays. An : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('A')); *************** package body Exp_Ch4 is *** 1714,1722 **** Ltyp := Get_Arg_Type (Lhs); Rtyp := Get_Arg_Type (Rhs); ! -- For now, if the argument types are not the same, go to the ! -- base type, since the code assumes that the formals have the ! -- same type. This is fixable in future ??? if Ltyp /= Rtyp then Ltyp := Base_Type (Ltyp); --- 1713,1721 ---- Ltyp := Get_Arg_Type (Lhs); Rtyp := Get_Arg_Type (Rhs); ! -- For now, if the argument types are not the same, go to the base type, ! -- since the code assumes that the formals have the same type. This is ! -- fixable in future ??? if Ltyp /= Rtyp then Ltyp := Base_Type (Ltyp); *************** package body Exp_Ch4 is *** 1775,1783 **** Set_Has_Completion (Func_Name, True); Set_Is_Inlined (Func_Name); ! -- If the array type is distinct from the type of the arguments, ! -- it is the full view of a private type. Apply an unchecked ! -- conversion to insure that analysis of the call succeeds. declare L, R : Node_Id; --- 1774,1782 ---- Set_Has_Completion (Func_Name, True); Set_Is_Inlined (Func_Name); ! -- If the array type is distinct from the type of the arguments, it ! -- is the full view of a private type. Apply an unchecked conversion ! -- to insure that analysis of the call succeeds. declare L, R : Node_Id; *************** package body Exp_Ch4 is *** 1813,1828 **** -- Expand_Boolean_Operator -- ----------------------------- ! -- Note that we first get the actual subtypes of the operands, ! -- since we always want to deal with types that have bounds. procedure Expand_Boolean_Operator (N : Node_Id) is Typ : constant Entity_Id := Etype (N); begin ! -- Special case of bit packed array where both operands are known ! -- to be properly aligned. In this case we use an efficient run time ! -- routine to carry out the operation (see System.Bit_Ops). if Is_Bit_Packed_Array (Typ) and then not Is_Possibly_Unaligned_Object (Left_Opnd (N)) --- 1812,1827 ---- -- Expand_Boolean_Operator -- ----------------------------- ! -- Note that we first get the actual subtypes of the operands, since we ! -- always want to deal with types that have bounds. procedure Expand_Boolean_Operator (N : Node_Id) is Typ : constant Entity_Id := Etype (N); begin ! -- Special case of bit packed array where both operands are known to be ! -- properly aligned. In this case we use an efficient run time routine ! -- to carry out the operation (see System.Bit_Ops). if Is_Bit_Packed_Array (Typ) and then not Is_Possibly_Unaligned_Object (Left_Opnd (N)) *************** package body Exp_Ch4 is *** 1852,1857 **** --- 1851,1860 ---- Ensure_Defined (Etype (R), N); Apply_Length_Check (R, Etype (L)); + if Nkind (N) = N_Op_Xor then + Silly_Boolean_Array_Xor_Test (N, Etype (L)); + end if; + if Nkind (Parent (N)) = N_Assignment_Statement and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R) then *************** package body Exp_Ch4 is *** 1860,1866 **** elsif Nkind (Parent (N)) = N_Op_Not and then Nkind (N) = N_Op_And and then ! Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R) then return; else --- 1863,1869 ---- elsif Nkind (Parent (N)) = N_Op_Not and then Nkind (N) = N_Op_And and then ! Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R) then return; else *************** package body Exp_Ch4 is *** 1912,1919 **** Full_Type := Typ; end if; ! -- Defense against malformed private types with no completion ! -- the error will be diagnosed later by check_completion if No (Full_Type) then return New_Reference_To (Standard_False, Loc); --- 1915,1922 ---- Full_Type := Typ; end if; ! -- Defense against malformed private types with no completion the error ! -- will be diagnosed later by check_completion if No (Full_Type) then return New_Reference_To (Standard_False, Loc); *************** package body Exp_Ch4 is *** 1933,1943 **** then return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); ! -- For composite component types, and floating-point types, use ! -- the expansion. This deals with tagged component types (where ! -- we use the applicable equality routine) and floating-point, ! -- (where we need to worry about negative zeroes), and also the ! -- case of any composite type recursively containing such fields. else return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type); --- 1936,1946 ---- then return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); ! -- For composite component types, and floating-point types, use the ! -- expansion. This deals with tagged component types (where we use ! -- the applicable equality routine) and floating-point, (where we ! -- need to worry about negative zeroes), and also the case of any ! -- composite type recursively containing such fields. else return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type); *************** package body Exp_Ch4 is *** 1951,1961 **** Full_Type := Root_Type (Full_Type); end if; ! -- If this is derived from an untagged private type completed ! -- with a tagged type, it does not have a full view, so we ! -- use the primitive operations of the private type. ! -- This check should no longer be necessary when these ! -- types receive their full views ??? if Is_Private_Type (Typ) and then not Is_Tagged_Type (Typ) --- 1954,1963 ---- Full_Type := Root_Type (Full_Type); end if; ! -- If this is derived from an untagged private type completed with a ! -- tagged type, it does not have a full view, so we use the primitive ! -- operations of the private type. This check should no longer be ! -- necessary when these types receive their full views ??? if Is_Private_Type (Typ) and then not Is_Tagged_Type (Typ) *************** package body Exp_Ch4 is *** 1994,2001 **** if Present (Eq_Op) then if Etype (First_Formal (Eq_Op)) /= Full_Type then ! -- Inherited equality from parent type. Convert the actuals ! -- to match signature of operation. declare T : constant Entity_Id := Etype (First_Formal (Eq_Op)); --- 1996,2003 ---- if Present (Eq_Op) then if Etype (First_Formal (Eq_Op)) /= Full_Type then ! -- Inherited equality from parent type. Convert the actuals to ! -- match signature of operation. declare T : constant Entity_Id := Etype (First_Formal (Eq_Op)); *************** package body Exp_Ch4 is *** 2036,2042 **** if Is_Constrained (Lhs_Type) then ! -- Since the enclosing record can never be an -- Unchecked_Union (this code is executed for records -- that do not have variants), we may reference its -- discriminant(s). --- 2038,2044 ---- if Is_Constrained (Lhs_Type) then ! -- Since the enclosing record type can never be an -- Unchecked_Union (this code is executed for records -- that do not have variants), we may reference its -- discriminant(s). *************** package body Exp_Ch4 is *** 2117,2124 **** end; end if; ! -- Shouldn't this be an else, we can't fall through ! -- the above IF, right??? return Make_Function_Call (Loc, --- 2119,2126 ---- end; end if; ! -- Shouldn't this be an else, we can't fall through the above ! -- IF, right??? return Make_Function_Call (Loc, *************** package body Exp_Ch4 is *** 2141,2150 **** -- Expand_Concatenate_Other -- ------------------------------ ! -- Let n be the number of array operands to be concatenated, Base_Typ ! -- their base type, Ind_Typ their index type, and Arr_Typ the original ! -- array type to which the concatenantion operator applies, then the ! -- following subprogram is constructed: -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is -- L : Ind_Typ; --- 2143,2152 ---- -- Expand_Concatenate_Other -- ------------------------------ ! -- Let n be the number of array operands to be concatenated, Base_Typ their ! -- base type, Ind_Typ their index type, and Arr_Typ the original array type ! -- to which the concatenation operator applies, then the following ! -- subprogram is constructed: -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is -- L : Ind_Typ; *************** package body Exp_Ch4 is *** 2232,2237 **** --- 2234,2240 ---- Declare_Stmts : List_Id; H_Decl : Node_Id; + I_Decl : Node_Id; H_Init : Node_Id; P_Decl : Node_Id; R_Decl : Node_Id; *************** package body Exp_Ch4 is *** 2421,2434 **** Target_Type : Entity_Id; begin ! -- If the index type is an enumeration type, the computation ! -- can be done in standard integer. Otherwise, choose a large ! -- enough integer type. if Is_Enumeration_Type (Ind_Typ) or else Root_Type (Ind_Typ) = Standard_Integer or else Root_Type (Ind_Typ) = Standard_Short_Integer or else Root_Type (Ind_Typ) = Standard_Short_Short_Integer then Target_Type := Standard_Integer; else --- 2424,2438 ---- Target_Type : Entity_Id; begin ! -- If the index type is an enumeration type, the computation can be ! -- done in standard integer. Otherwise, choose a large enough integer ! -- type to accommodate the index type computation. if Is_Enumeration_Type (Ind_Typ) or else Root_Type (Ind_Typ) = Standard_Integer or else Root_Type (Ind_Typ) = Standard_Short_Integer or else Root_Type (Ind_Typ) = Standard_Short_Short_Integer + or else Is_Modular_Integer_Type (Ind_Typ) then Target_Type := Standard_Integer; else *************** package body Exp_Ch4 is *** 2611,2617 **** for I in 2 .. Nb_Opnds loop H_Init := Make_Op_Add (Loc, H_Init, S_Length (I)); end loop; ! H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos)); H_Decl := Make_Object_Declaration (Loc, --- 2615,2651 ---- for I in 2 .. Nb_Opnds loop H_Init := Make_Op_Add (Loc, H_Init, S_Length (I)); end loop; ! ! -- If the index type is small modular type, we need to perform an ! -- additional check that the upper bound fits in the index type. ! -- Otherwise the computation of the upper bound can wrap around ! -- and yield meaningless results. The constraint check has to be ! -- explicit in the code, because the generated function is compiled ! -- with checks disabled, for efficiency. ! ! if Is_Modular_Integer_Type (Ind_Typ) ! and then Esize (Ind_Typ) < Esize (Standard_Integer) ! then ! I_Decl := ! Make_Object_Declaration (Loc, ! Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI), ! Object_Definition => New_Reference_To (Standard_Integer, Loc), ! Expression => ! Make_Type_Conversion (Loc, ! New_Reference_To (Standard_Integer, Loc), ! Make_Op_Add (Loc, H_Init, L_Pos))); ! ! H_Init := ! Ind_Val ( ! Make_Type_Conversion (Loc, ! New_Reference_To (Ind_Typ, Loc), ! New_Reference_To (Defining_Identifier (I_Decl), Loc))); ! ! -- For other index types, computation is safe ! ! else ! H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos)); ! end if; H_Decl := Make_Object_Declaration (Loc, *************** package body Exp_Ch4 is *** 2638,2643 **** --- 2672,2699 ---- Declare_Decls := New_List (P_Decl, H_Decl, R_Decl); + -- Add constraint check for the modular index case + + if Is_Modular_Integer_Type (Ind_Typ) + and then Esize (Ind_Typ) < Esize (Standard_Integer) + then + Insert_After (P_Decl, I_Decl); + + Insert_After (I_Decl, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + New_Reference_To (Defining_Identifier (I_Decl), Loc), + Right_Opnd => + Make_Type_Conversion (Loc, + New_Reference_To (Standard_Integer, Loc), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ind_Typ, Loc), + Attribute_Name => Name_Last))), + Reason => CE_Range_Check_Failed)); + end if; + -- Construct list of statements for the declare block Declare_Stmts := New_List; *************** package body Exp_Ch4 is *** 2676,2682 **** -- Note that this does *not* fix the array concatenation bug when the -- low bound is Integer'first sibce that bug comes from the pointer ! -- dereferencing an unconstrained array. An there we need a constraint -- check to make sure the length of the concatenated array is ok. ??? Insert_Action (Cnode, Func_Body, Suppress => All_Checks); --- 2732,2738 ---- -- Note that this does *not* fix the array concatenation bug when the -- low bound is Integer'first sibce that bug comes from the pointer ! -- dereferencing an unconstrained array. And there we need a constraint -- check to make sure the length of the concatenated array is ok. ??? Insert_Action (Cnode, Func_Body, Suppress => All_Checks); *************** package body Exp_Ch4 is *** 2794,2800 **** procedure Rewrite_Coextension (N : Node_Id); -- Static coextensions have the same lifetime as the entity they ! -- constrain. Such occurences can be rewritten as aliased objects -- and their unrestricted access used instead of the coextension. --------------------------------------- --- 2850,2856 ---- procedure Rewrite_Coextension (N : Node_Id); -- Static coextensions have the same lifetime as the entity they ! -- constrain. Such occurrences can be rewritten as aliased objects -- and their unrestricted access used instead of the coextension. --------------------------------------- *************** package body Exp_Ch4 is *** 2812,2818 **** function Needs_Initialization_Call (N : Node_Id) return Boolean; -- Determine whether node N is a subtype indicator allocator which ! -- asts a coextension. Such coextensions need initialization. ------------------------------- -- Inside_A_Return_Statement -- --- 2868,2874 ---- function Needs_Initialization_Call (N : Node_Id) return Boolean; -- Determine whether node N is a subtype indicator allocator which ! -- acts a coextension. Such coextensions need initialization. ------------------------------- -- Inside_A_Return_Statement -- *************** package body Exp_Ch4 is *** 2933,2969 **** -- typ! (coext.all) if Nkind (Coext) = N_Identifier then ! Ref := Make_Unchecked_Type_Conversion (Loc, ! Subtype_Mark => ! New_Reference_To (Etype (Coext), Loc), ! Expression => ! Make_Explicit_Dereference (Loc, ! New_Copy_Tree (Coext))); else Ref := New_Copy_Tree (Coext); end if; ! -- Generate: ! -- initialize (Ref) ! -- attach_to_final_list (Ref, Flist, 2) ! if Needs_Initialization_Call (Coext) then ! Insert_Actions (N, ! Make_Init_Call ( ! Ref => Ref, ! Typ => Etype (Coext), ! Flist_Ref => Flist, ! With_Attach => Make_Integer_Literal (Loc, Uint_2))); ! -- Generate: ! -- attach_to_final_list (Ref, Flist, 2) ! else ! Insert_Action (N, ! Make_Attach_Call ( ! Obj_Ref => Ref, ! Flist_Ref => New_Copy_Tree (Flist), ! With_Attach => Make_Integer_Literal (Loc, Uint_2))); end if; Next_Elmt (Coext_Elmt); --- 2989,3032 ---- -- typ! (coext.all) if Nkind (Coext) = N_Identifier then ! Ref := ! Make_Unchecked_Type_Conversion (Loc, ! Subtype_Mark => New_Reference_To (Etype (Coext), Loc), ! Expression => ! Make_Explicit_Dereference (Loc, ! Prefix => New_Copy_Tree (Coext))); else Ref := New_Copy_Tree (Coext); end if; ! -- No initialization call if not allowed ! Check_Restriction (No_Default_Initialization, N); ! if not Restriction_Active (No_Default_Initialization) then ! -- Generate: ! -- initialize (Ref) ! -- attach_to_final_list (Ref, Flist, 2) ! ! if Needs_Initialization_Call (Coext) then ! Insert_Actions (N, ! Make_Init_Call ( ! Ref => Ref, ! Typ => Etype (Coext), ! Flist_Ref => Flist, ! With_Attach => Make_Integer_Literal (Loc, Uint_2))); ! ! -- Generate: ! -- attach_to_final_list (Ref, Flist, 2) ! ! else ! Insert_Action (N, ! Make_Attach_Call ( ! Obj_Ref => Ref, ! Flist_Ref => New_Copy_Tree (Flist), ! With_Attach => Make_Integer_Literal (Loc, Uint_2))); ! end if; end if; Next_Elmt (Coext_Elmt); *************** package body Exp_Ch4 is *** 3045,3053 **** end if; end if; ! -- Under certain circumstances we can replace an allocator by an ! -- access to statically allocated storage. The conditions, as noted ! -- in AARM 3.10 (10c) are as follows: -- Size and initial value is known at compile time -- Access type is access-to-constant --- 3108,3116 ---- end if; end if; ! -- Under certain circumstances we can replace an allocator by an access ! -- to statically allocated storage. The conditions, as noted in AARM ! -- 3.10 (10c) are as follows: -- Size and initial value is known at compile time -- Access type is access-to-constant *************** package body Exp_Ch4 is *** 3072,3079 **** -- Tnn : aliased x := y; ! -- and replace the allocator by Tnn'Unrestricted_Access. ! -- Tnn is marked as requiring static allocation. Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); --- 3135,3142 ---- -- Tnn : aliased x := y; ! -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is ! -- marked as requiring static allocation. Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); *************** package body Exp_Ch4 is *** 3081,3087 **** Desig := Subtype_Mark (Expression (N)); -- If context is constrained, use constrained subtype directly, ! -- so that the constant is not labelled as having a nomimally -- unconstrained subtype. if Entity (Desig) = Base_Type (Dtyp) then --- 3144,3150 ---- Desig := Subtype_Mark (Expression (N)); -- If context is constrained, use constrained subtype directly, ! -- so that the constant is not labelled as having a nominally -- unconstrained subtype. if Entity (Desig) = Base_Type (Dtyp) then *************** package body Exp_Ch4 is *** 3103,3110 **** Analyze_And_Resolve (N, PtrT); ! -- We set the variable as statically allocated, since we don't ! -- want it going on the stack of the current procedure! Set_Is_Statically_Allocated (Temp); return; --- 3166,3173 ---- Analyze_And_Resolve (N, PtrT); ! -- We set the variable as statically allocated, since we don't want ! -- it going on the stack of the current procedure! Set_Is_Statically_Allocated (Temp); return; *************** package body Exp_Ch4 is *** 3136,3144 **** -- If the allocator is for a type which requires initialization, and -- there is no initial value (i.e. operand is a subtype indication ! -- rather than a qualifed expression), then we must generate a call ! -- to the initialization routine. This is done using an expression ! -- actions node: -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn] --- 3199,3206 ---- -- If the allocator is for a type which requires initialization, and -- there is no initial value (i.e. operand is a subtype indication ! -- rather than a qualified expression), then we must generate a call to ! -- the initialization routine using an expressions action node: -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn] *************** package body Exp_Ch4 is *** 3174,3183 **** -- Case of simple initialization required if Needs_Simple_Initialization (T) then Rewrite (Expression (N), Make_Qualified_Expression (Loc, Subtype_Mark => New_Occurrence_Of (T, Loc), ! Expression => Get_Simple_Init_Val (T, Loc))); Analyze_And_Resolve (Expression (Expression (N)), T); Analyze_And_Resolve (Expression (N), T); --- 3236,3246 ---- -- Case of simple initialization required if Needs_Simple_Initialization (T) then + Check_Restriction (No_Default_Initialization, N); Rewrite (Expression (N), Make_Qualified_Expression (Loc, Subtype_Mark => New_Occurrence_Of (T, Loc), ! Expression => Get_Simple_Init_Val (T, N))); Analyze_And_Resolve (Expression (Expression (N)), T); Analyze_And_Resolve (Expression (N), T); *************** package body Exp_Ch4 is *** 3193,3484 **** -- Case of initialization procedure present, must be called else ! Init := Base_Init_Proc (T); ! Nod := N; ! Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); ! ! -- Construct argument list for the initialization routine call ! ! Arg1 := ! Make_Explicit_Dereference (Loc, ! Prefix => New_Reference_To (Temp, Loc)); ! Set_Assignment_OK (Arg1); ! Temp_Type := PtrT; ! ! -- The initialization procedure expects a specific type. if the ! -- context is access to class wide, indicate that the object being ! -- allocated has the right specific type. ! ! if Is_Class_Wide_Type (Dtyp) then ! Arg1 := Unchecked_Convert_To (T, Arg1); ! end if; ! -- If designated type is a concurrent type or if it is private ! -- type whose definition is a concurrent type, the first argument ! -- in the Init routine has to be unchecked conversion to the ! -- corresponding record type. If the designated type is a derived ! -- type, we also convert the argument to its root type. ! if Is_Concurrent_Type (T) then ! Arg1 := ! Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1); - elsif Is_Private_Type (T) - and then Present (Full_View (T)) - and then Is_Concurrent_Type (Full_View (T)) - then Arg1 := ! Unchecked_Convert_To ! (Corresponding_Record_Type (Full_View (T)), Arg1); ! ! elsif Etype (First_Formal (Init)) /= Base_Type (T) then ! declare ! Ftyp : constant Entity_Id := Etype (First_Formal (Init)); ! ! begin ! Arg1 := OK_Convert_To (Etype (Ftyp), Arg1); ! Set_Etype (Arg1, Ftyp); ! end; ! end if; ! Args := New_List (Arg1); ! -- For the task case, pass the Master_Id of the access type as ! -- the value of the _Master parameter, and _Chain as the value ! -- of the _Chain parameter (_Chain will be defined as part of ! -- the generated code for the allocator). ! -- In Ada 2005, the context may be a function that returns an ! -- anonymous access type. In that case the Master_Id has been ! -- created when expanding the function declaration. ! if Has_Task (T) then ! if No (Master_Id (Base_Type (PtrT))) then ! -- If we have a non-library level task with the restriction ! -- No_Task_Hierarchy set, then no point in expanding. ! if not Is_Library_Level_Entity (T) ! and then Restriction_Active (No_Task_Hierarchy) ! then ! return; ! end if; ! -- The designated type was an incomplete type, and the ! -- access type did not get expanded. Salvage it now. ! pragma Assert (Present (Parent (Base_Type (PtrT)))); ! Expand_N_Full_Type_Declaration (Parent (Base_Type (PtrT))); ! end if; ! -- If the context of the allocator is a declaration or an ! -- assignment, we can generate a meaningful image for it, ! -- even though subsequent assignments might remove the ! -- connection between task and entity. We build this image ! -- when the left-hand side is a simple variable, a simple ! -- indexed assignment or a simple selected component. ! if Nkind (Parent (N)) = N_Assignment_Statement then ! declare ! Nam : constant Node_Id := Name (Parent (N)); ! begin ! if Is_Entity_Name (Nam) then ! Decls := ! Build_Task_Image_Decls ( ! Loc, ! New_Occurrence_Of ! (Entity (Nam), Sloc (Nam)), T); ! elsif Nkind_In ! (Nam, N_Indexed_Component, N_Selected_Component) ! and then Is_Entity_Name (Prefix (Nam)) then ! Decls := ! Build_Task_Image_Decls ! (Loc, Nam, Etype (Prefix (Nam))); ! else ! Decls := Build_Task_Image_Decls (Loc, T, T); end if; - end; ! elsif Nkind (Parent (N)) = N_Object_Declaration then ! Decls := ! Build_Task_Image_Decls ( ! Loc, Defining_Identifier (Parent (N)), T); ! else ! Decls := Build_Task_Image_Decls (Loc, T, T); ! end if; ! Append_To (Args, ! New_Reference_To ! (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); ! Append_To (Args, Make_Identifier (Loc, Name_uChain)); ! Decl := Last (Decls); ! Append_To (Args, ! New_Occurrence_Of (Defining_Identifier (Decl), Loc)); ! -- Has_Task is false, Decls not used ! else ! Decls := No_List; ! end if; ! -- Add discriminants if discriminated type ! declare ! Dis : Boolean := False; ! Typ : Entity_Id; ! begin ! if Has_Discriminants (T) then ! Dis := True; ! Typ := T; ! elsif Is_Private_Type (T) ! and then Present (Full_View (T)) ! and then Has_Discriminants (Full_View (T)) ! then ! Dis := True; ! Typ := Full_View (T); end if; ! if Dis then ! -- If the allocated object will be constrained by the ! -- default values for discriminants, then build a ! -- subtype with those defaults, and change the allocated ! -- subtype to that. Note that this happens in fewer ! -- cases in Ada 2005 (AI-363). ! if not Is_Constrained (Typ) ! and then Present (Discriminant_Default_Value ! (First_Discriminant (Typ))) ! and then (Ada_Version < Ada_05 ! or else not Has_Constrained_Partial_View (Typ)) then ! Typ := Build_Default_Subtype (Typ, N); ! Set_Expression (N, New_Reference_To (Typ, Loc)); end if; ! Discr := First_Elmt (Discriminant_Constraint (Typ)); ! while Present (Discr) loop ! Nod := Node (Discr); ! Append (New_Copy_Tree (Node (Discr)), Args); ! -- AI-416: when the discriminant constraint is an ! -- anonymous access type make sure an accessibility ! -- check is inserted if necessary (3.10.2(22.q/2)) ! if Ada_Version >= Ada_05 ! and then Ekind (Etype (Nod)) = E_Anonymous_Access_Type then ! Apply_Accessibility_Check (Nod, Typ); end if; ! Next_Elmt (Discr); ! end loop; ! end if; ! end; ! -- We set the allocator as analyzed so that when we analyze the ! -- expression actions node, we do not get an unwanted recursive ! -- expansion of the allocator expression. ! Set_Analyzed (N, True); ! Nod := Relocate_Node (N); ! -- Here is the transformation: ! -- input: new T ! -- output: Temp : constant ptr_T := new T; ! -- Init (Temp.all, ...); ! -- Attach_To_Final_List (Finalizable (Temp.all)); ! -- Initialize (Finalizable (Temp.all)); ! -- Here ptr_T is the pointer type for the allocator, and is the ! -- subtype of the allocator. ! Temp_Decl := ! Make_Object_Declaration (Loc, ! Defining_Identifier => Temp, ! Constant_Present => True, ! Object_Definition => New_Reference_To (Temp_Type, Loc), ! Expression => Nod); ! Set_Assignment_OK (Temp_Decl); ! Insert_Action (N, Temp_Decl, Suppress => All_Checks); ! -- If the designated type is a task type or contains tasks, ! -- create block to activate created tasks, and insert ! -- declaration for Task_Image variable ahead of call. ! if Has_Task (T) then ! declare ! L : constant List_Id := New_List; ! Blk : Node_Id; ! begin ! Build_Task_Allocate_Block (L, Nod, Args); ! Blk := Last (L); ! Insert_List_Before (First (Declarations (Blk)), Decls); ! Insert_Actions (N, L); ! end; ! else ! Insert_Action (N, ! Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To (Init, Loc), ! Parameter_Associations => Args)); ! end if; ! if Controlled_Type (T) then ! -- Postpone the generation of a finalization call for the ! -- current allocator if it acts as a coextension. ! if Is_Dynamic_Coextension (N) then ! if No (Coextensions (N)) then ! Set_Coextensions (N, New_Elmt_List); ! end if; ! Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N)); ! else ! Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT); ! -- Anonymous access types created for access parameters ! -- are attached to an explicitly constructed controller, ! -- which ensures that they can be finalized properly, even ! -- if their deallocation might not happen. The list ! -- associated with the controller is doubly-linked. For ! -- other anonymous access types, the object may end up ! -- on the global final list which is singly-linked. ! -- Work needed for access discriminants in Ada 2005 ??? ! if Ekind (PtrT) = E_Anonymous_Access_Type and then Nkind (Associated_Node_For_Itype (PtrT)) ! not in N_Subprogram_Specification ! then ! Attach_Level := Uint_1; ! else ! Attach_Level := Uint_2; ! end if; ! Insert_Actions (N, ! Make_Init_Call ( ! Ref => New_Copy_Tree (Arg1), ! Typ => T, ! Flist_Ref => Flist, ! With_Attach => Make_Integer_Literal ! (Loc, Attach_Level))); end if; - end if; ! Rewrite (N, New_Reference_To (Temp, Loc)); ! Analyze_And_Resolve (N, PtrT); end if; end; --- 3256,3555 ---- -- Case of initialization procedure present, must be called else ! Check_Restriction (No_Default_Initialization, N); ! if not Restriction_Active (No_Default_Initialization) then ! Init := Base_Init_Proc (T); ! Nod := N; ! Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); ! -- Construct argument list for the initialization routine call Arg1 := ! Make_Explicit_Dereference (Loc, ! Prefix => New_Reference_To (Temp, Loc)); ! Set_Assignment_OK (Arg1); ! Temp_Type := PtrT; ! -- The initialization procedure expects a specific type. if the ! -- context is access to class wide, indicate that the object ! -- being allocated has the right specific type. ! if Is_Class_Wide_Type (Dtyp) then ! Arg1 := Unchecked_Convert_To (T, Arg1); ! end if; ! -- If designated type is a concurrent type or if it is private ! -- type whose definition is a concurrent type, the first ! -- argument in the Init routine has to be unchecked conversion ! -- to the corresponding record type. If the designated type is ! -- a derived type, we also convert the argument to its root ! -- type. ! if Is_Concurrent_Type (T) then ! Arg1 := ! Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1); ! elsif Is_Private_Type (T) ! and then Present (Full_View (T)) ! and then Is_Concurrent_Type (Full_View (T)) ! then ! Arg1 := ! Unchecked_Convert_To ! (Corresponding_Record_Type (Full_View (T)), Arg1); ! elsif Etype (First_Formal (Init)) /= Base_Type (T) then ! declare ! Ftyp : constant Entity_Id := Etype (First_Formal (Init)); ! begin ! Arg1 := OK_Convert_To (Etype (Ftyp), Arg1); ! Set_Etype (Arg1, Ftyp); ! end; ! end if; ! Args := New_List (Arg1); ! -- For the task case, pass the Master_Id of the access type as ! -- the value of the _Master parameter, and _Chain as the value ! -- of the _Chain parameter (_Chain will be defined as part of ! -- the generated code for the allocator). ! -- In Ada 2005, the context may be a function that returns an ! -- anonymous access type. In that case the Master_Id has been ! -- created when expanding the function declaration. ! if Has_Task (T) then ! if No (Master_Id (Base_Type (PtrT))) then ! -- If we have a non-library level task with restriction ! -- No_Task_Hierarchy set, then no point in expanding. ! if not Is_Library_Level_Entity (T) ! and then Restriction_Active (No_Task_Hierarchy) then ! return; end if; ! -- The designated type was an incomplete type, and the ! -- access type did not get expanded. Salvage it now. ! pragma Assert (Present (Parent (Base_Type (PtrT)))); ! Expand_N_Full_Type_Declaration ! (Parent (Base_Type (PtrT))); ! end if; ! -- If the context of the allocator is a declaration or an ! -- assignment, we can generate a meaningful image for it, ! -- even though subsequent assignments might remove the ! -- connection between task and entity. We build this image ! -- when the left-hand side is a simple variable, a simple ! -- indexed assignment or a simple selected component. ! if Nkind (Parent (N)) = N_Assignment_Statement then ! declare ! Nam : constant Node_Id := Name (Parent (N)); ! begin ! if Is_Entity_Name (Nam) then ! Decls := ! Build_Task_Image_Decls ! (Loc, ! New_Occurrence_Of ! (Entity (Nam), Sloc (Nam)), T); ! elsif Nkind_In ! (Nam, N_Indexed_Component, N_Selected_Component) ! and then Is_Entity_Name (Prefix (Nam)) ! then ! Decls := ! Build_Task_Image_Decls ! (Loc, Nam, Etype (Prefix (Nam))); ! else ! Decls := Build_Task_Image_Decls (Loc, T, T); ! end if; ! end; ! elsif Nkind (Parent (N)) = N_Object_Declaration then ! Decls := ! Build_Task_Image_Decls ! (Loc, Defining_Identifier (Parent (N)), T); ! else ! Decls := Build_Task_Image_Decls (Loc, T, T); ! end if; ! Append_To (Args, ! New_Reference_To ! (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); ! Append_To (Args, Make_Identifier (Loc, Name_uChain)); ! Decl := Last (Decls); ! Append_To (Args, ! New_Occurrence_Of (Defining_Identifier (Decl), Loc)); ! ! -- Has_Task is false, Decls not used ! ! else ! Decls := No_List; end if; ! -- Add discriminants if discriminated type ! declare ! Dis : Boolean := False; ! Typ : Entity_Id; ! ! begin ! if Has_Discriminants (T) then ! Dis := True; ! Typ := T; ! ! elsif Is_Private_Type (T) ! and then Present (Full_View (T)) ! and then Has_Discriminants (Full_View (T)) then ! Dis := True; ! Typ := Full_View (T); end if; ! if Dis then ! -- If the allocated object will be constrained by the ! -- default values for discriminants, then build a subtype ! -- with those defaults, and change the allocated subtype ! -- to that. Note that this happens in fewer cases in Ada ! -- 2005 (AI-363). ! if not Is_Constrained (Typ) ! and then Present (Discriminant_Default_Value ! (First_Discriminant (Typ))) ! and then (Ada_Version < Ada_05 ! or else ! not Has_Constrained_Partial_View (Typ)) then ! Typ := Build_Default_Subtype (Typ, N); ! Set_Expression (N, New_Reference_To (Typ, Loc)); end if; ! Discr := First_Elmt (Discriminant_Constraint (Typ)); ! while Present (Discr) loop ! Nod := Node (Discr); ! Append (New_Copy_Tree (Node (Discr)), Args); ! -- AI-416: when the discriminant constraint is an ! -- anonymous access type make sure an accessibility ! -- check is inserted if necessary (3.10.2(22.q/2)) ! if Ada_Version >= Ada_05 ! and then ! Ekind (Etype (Nod)) = E_Anonymous_Access_Type ! then ! Apply_Accessibility_Check ! (Nod, Typ, Insert_Node => Nod); ! end if; ! Next_Elmt (Discr); ! end loop; ! end if; ! end; ! -- We set the allocator as analyzed so that when we analyze the ! -- expression actions node, we do not get an unwanted recursive ! -- expansion of the allocator expression. ! Set_Analyzed (N, True); ! Nod := Relocate_Node (N); ! -- Here is the transformation: ! -- input: new T ! -- output: Temp : constant ptr_T := new T; ! -- Init (Temp.all, ...); ! -- Attach_To_Final_List (Finalizable (Temp.all)); ! -- Initialize (Finalizable (Temp.all)); ! -- Here ptr_T is the pointer type for the allocator, and is the ! -- subtype of the allocator. ! Temp_Decl := ! Make_Object_Declaration (Loc, ! Defining_Identifier => Temp, ! Constant_Present => True, ! Object_Definition => New_Reference_To (Temp_Type, Loc), ! Expression => Nod); ! Set_Assignment_OK (Temp_Decl); ! Insert_Action (N, Temp_Decl, Suppress => All_Checks); ! -- If the designated type is a task type or contains tasks, ! -- create block to activate created tasks, and insert ! -- declaration for Task_Image variable ahead of call. ! if Has_Task (T) then ! declare ! L : constant List_Id := New_List; ! Blk : Node_Id; ! begin ! Build_Task_Allocate_Block (L, Nod, Args); ! Blk := Last (L); ! Insert_List_Before (First (Declarations (Blk)), Decls); ! Insert_Actions (N, L); ! end; ! else ! Insert_Action (N, ! Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To (Init, Loc), ! Parameter_Associations => Args)); ! end if; ! if Needs_Finalization (T) then ! -- Postpone the generation of a finalization call for the ! -- current allocator if it acts as a coextension. ! if Is_Dynamic_Coextension (N) then ! if No (Coextensions (N)) then ! Set_Coextensions (N, New_Elmt_List); ! end if; ! Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N)); ! else ! Flist := ! Get_Allocator_Final_List (N, Base_Type (T), PtrT); ! -- Anonymous access types created for access parameters ! -- are attached to an explicitly constructed controller, ! -- which ensures that they can be finalized properly, ! -- even if their deallocation might not happen. The list ! -- associated with the controller is doubly-linked. For ! -- other anonymous access types, the object may end up ! -- on the global final list which is singly-linked. ! -- Work needed for access discriminants in Ada 2005 ??? ! ! if Ekind (PtrT) = E_Anonymous_Access_Type and then Nkind (Associated_Node_For_Itype (PtrT)) ! not in N_Subprogram_Specification ! then ! Attach_Level := Uint_1; ! else ! Attach_Level := Uint_2; ! end if; ! Insert_Actions (N, ! Make_Init_Call ( ! Ref => New_Copy_Tree (Arg1), ! Typ => T, ! Flist_Ref => Flist, ! With_Attach => Make_Integer_Literal (Loc, ! Intval => Attach_Level))); ! end if; end if; ! Rewrite (N, New_Reference_To (Temp, Loc)); ! Analyze_And_Resolve (N, PtrT); ! end if; end if; end; *************** package body Exp_Ch4 is *** 3520,3553 **** Set_Etype (N, Standard_Boolean); end if; ! -- Check for cases of left argument is True or False ! if Nkind (Left) = N_Identifier then -- If left argument is True, change (True and then Right) to Right. -- Any actions associated with Right will be executed unconditionally -- and can thus be inserted into the tree unconditionally. ! if Entity (Left) = Standard_True then if Present (Actions (N)) then Insert_Actions (N, Actions (N)); end if; Rewrite (N, Right); - Adjust_Result_Type (N, Typ); - return; -- If left argument is False, change (False and then Right) to False. -- In this case we can forget the actions associated with Right, -- since they will never be executed. ! elsif Entity (Left) = Standard_False then Kill_Dead_Code (Right); Kill_Dead_Code (Actions (N)); Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - Adjust_Result_Type (N, Typ); - return; end if; end if; -- If Actions are present, we expand --- 3591,3623 ---- Set_Etype (N, Standard_Boolean); end if; ! -- Check for cases where left argument is known to be True or False ! if Compile_Time_Known_Value (Left) then -- If left argument is True, change (True and then Right) to Right. -- Any actions associated with Right will be executed unconditionally -- and can thus be inserted into the tree unconditionally. ! if Expr_Value_E (Left) = Standard_True then if Present (Actions (N)) then Insert_Actions (N, Actions (N)); end if; Rewrite (N, Right); -- If left argument is False, change (False and then Right) to False. -- In this case we can forget the actions associated with Right, -- since they will never be executed. ! else pragma Assert (Expr_Value_E (Left) = Standard_False); Kill_Dead_Code (Right); Kill_Dead_Code (Actions (N)); Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); end if; + + Adjust_Result_Type (N, Typ); + return; end if; -- If Actions are present, we expand *************** package body Exp_Ch4 is *** 3579,3597 **** -- No actions present, check for cases of right argument True/False ! if Nkind (Right) = N_Identifier then ! -- Change (Left and then True) to Left. Note that we know there ! -- are no actions associated with the True operand, since we ! -- just checked for this case above. ! if Entity (Right) = Standard_True then Rewrite (N, Left); ! -- Change (Left and then False) to False, making sure to preserve ! -- any side effects associated with the Left operand. ! elsif Entity (Right) = Standard_False then Remove_Side_Effects (Left); Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); --- 3649,3667 ---- -- No actions present, check for cases of right argument True/False ! if Compile_Time_Known_Value (Right) then ! -- Change (Left and then True) to Left. Note that we know there are ! -- no actions associated with the True operand, since we just checked ! -- for this case above. ! if Expr_Value_E (Right) = Standard_True then Rewrite (N, Left); ! -- Change (Left and then False) to False, making sure to preserve any ! -- side effects associated with the Left operand. ! else pragma Assert (Expr_Value_E (Right) = Standard_False); Remove_Side_Effects (Left); Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); *************** package body Exp_Ch4 is *** 3756,3763 **** Lo_Orig : constant Node_Id := Original_Node (Lo); Hi_Orig : constant Node_Id := Original_Node (Hi); ! Lcheck : constant Compare_Result := Compile_Time_Compare (Lop, Lo); ! Ucheck : constant Compare_Result := Compile_Time_Compare (Lop, Hi); Warn1 : constant Boolean := Constant_Condition_Warnings --- 3826,3835 ---- Lo_Orig : constant Node_Id := Original_Node (Lo); Hi_Orig : constant Node_Id := Original_Node (Hi); ! Lcheck : constant Compare_Result := ! Compile_Time_Compare (Lop, Lo, Assume_Valid => True); ! Ucheck : constant Compare_Result := ! Compile_Time_Compare (Lop, Hi, Assume_Valid => True); Warn1 : constant Boolean := Constant_Condition_Warnings *************** package body Exp_Ch4 is *** 3807,3812 **** --- 3879,3890 ---- and then Compile_Time_Known_Value (Hi) and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi) and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo) + + -- Kill warnings in instances, since they may be cases where we + -- have a test in the generic that makes sense with some types + -- and not with other types. + + and then not In_Instance then Substitute_Valid_Check; return; *************** package body Exp_Ch4 is *** 3820,3826 **** -- legality checks, because we are constant-folding beyond RM 4.9. if Lcheck = LT or else Ucheck = GT then ! if Warn1 then Error_Msg_N ("?range test optimized away", N); Error_Msg_N ("\?value is known to be out of range", N); end if; --- 3898,3904 ---- -- legality checks, because we are constant-folding beyond RM 4.9. if Lcheck = LT or else Ucheck = GT then ! if Warn1 and then not In_Instance then Error_Msg_N ("?range test optimized away", N); Error_Msg_N ("\?value is known to be out of range", N); end if; *************** package body Exp_Ch4 is *** 3832,3842 **** return; ! -- If both checks are known to succeed, replace result ! -- by True, since we know we are in range. elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then ! if Warn1 then Error_Msg_N ("?range test optimized away", N); Error_Msg_N ("\?value is known to be in range", N); end if; --- 3910,3920 ---- return; ! -- If both checks are known to succeed, replace result by True, ! -- since we know we are in range. elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then ! if Warn1 and then not In_Instance then Error_Msg_N ("?range test optimized away", N); Error_Msg_N ("\?value is known to be in range", N); end if; *************** package body Exp_Ch4 is *** 3853,3859 **** -- a comparison against the upper bound. elsif Lcheck in Compare_GE then ! if Warn2 then Error_Msg_N ("?lower bound test optimized away", Lo); Error_Msg_N ("\?value is known to be in range", Lo); end if; --- 3931,3937 ---- -- a comparison against the upper bound. elsif Lcheck in Compare_GE then ! if Warn2 and then not In_Instance then Error_Msg_N ("?lower bound test optimized away", Lo); Error_Msg_N ("\?value is known to be in range", Lo); end if; *************** package body Exp_Ch4 is *** 3871,3877 **** -- a comparison against the lower bound. elsif Ucheck in Compare_LE then ! if Warn2 then Error_Msg_N ("?upper bound test optimized away", Hi); Error_Msg_N ("\?value is known to be in range", Hi); end if; --- 3949,3955 ---- -- a comparison against the lower bound. elsif Ucheck in Compare_LE then ! if Warn2 and then not In_Instance then Error_Msg_N ("?upper bound test optimized away", Hi); Error_Msg_N ("\?value is known to be in range", Hi); end if; *************** package body Exp_Ch4 is *** 3970,3978 **** New_Reference_To (Standard_True, Loc)); Analyze_And_Resolve (N, Rtyp); ! -- For the constrained array case, we have to check the ! -- subscripts for an exact match if the lengths are ! -- non-zero (the lengths must match in any case). elsif Is_Array_Type (Typ) then --- 4048,4056 ---- New_Reference_To (Standard_True, Loc)); Analyze_And_Resolve (N, Rtyp); ! -- For the constrained array case, we have to check the subscripts ! -- for an exact match if the lengths are non-zero (the lengths ! -- must match in any case). elsif Is_Array_Type (Typ) then *************** package body Exp_Ch4 is *** 4040,4052 **** Analyze_And_Resolve (N, Rtyp); end Check_Subscripts; ! -- These are the cases where constraint checks may be ! -- required, e.g. records with possible discriminants else -- Expand the test into a series of discriminant comparisons. ! -- The expression that is built is the negation of the one ! -- that is used for checking discriminant constraints. Obj := Relocate_Node (Left_Opnd (N)); --- 4118,4130 ---- Analyze_And_Resolve (N, Rtyp); end Check_Subscripts; ! -- These are the cases where constraint checks may be required, ! -- e.g. records with possible discriminants else -- Expand the test into a series of discriminant comparisons. ! -- The expression that is built is the negation of the one that ! -- is used for checking discriminant constraints. Obj := Relocate_Node (Left_Opnd (N)); *************** package body Exp_Ch4 is *** 4085,4102 **** T : constant Entity_Id := Etype (P); begin ! -- A special optimization, if we have an indexed component that ! -- is selecting from a slice, then we can eliminate the slice, ! -- since, for example, x (i .. j)(k) is identical to x(k). The ! -- only difference is the range check required by the slice. The ! -- range check for the slice itself has already been generated. ! -- The range check for the subscripting operation is ensured ! -- by converting the subject to the subtype of the slice. ! -- This optimization not only generates better code, avoiding ! -- slice messing especially in the packed case, but more importantly ! -- bypasses some problems in handling this peculiar case, for ! -- example, the issue of dealing specially with object renamings. if Nkind (P) = N_Slice then Rewrite (N, --- 4163,4180 ---- T : constant Entity_Id := Etype (P); begin ! -- A special optimization, if we have an indexed component that is ! -- selecting from a slice, then we can eliminate the slice, since, for ! -- example, x (i .. j)(k) is identical to x(k). The only difference is ! -- the range check required by the slice. The range check for the slice ! -- itself has already been generated. The range check for the ! -- subscripting operation is ensured by converting the subject to ! -- the subtype of the slice. ! -- This optimization not only generates better code, avoiding slice ! -- messing especially in the packed case, but more importantly bypasses ! -- some problems in handling this peculiar case, for example, the issue ! -- of dealing specially with object renamings. if Nkind (P) = N_Slice then Rewrite (N, *************** package body Exp_Ch4 is *** 4110,4120 **** return; end if; ! -- If the prefix is an access type, then we unconditionally rewrite ! -- if as an explicit deference. This simplifies processing for several ! -- cases, including packed array cases and certain cases in which ! -- checks must be generated. We used to try to do this only when it ! -- was necessary, but it cleans up the code to do it all the time. if Is_Access_Type (T) then Insert_Explicit_Dereference (P); --- 4188,4207 ---- return; end if; ! -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place ! -- function, then additional actuals must be passed. ! ! if Ada_Version >= Ada_05 ! and then Is_Build_In_Place_Function_Call (P) ! then ! Make_Build_In_Place_Call_In_Anonymous_Context (P); ! end if; ! ! -- If the prefix is an access type, then we unconditionally rewrite if ! -- as an explicit deference. This simplifies processing for several ! -- cases, including packed array cases and certain cases in which checks ! -- must be generated. We used to try to do this only when it was ! -- necessary, but it cleans up the code to do it all the time. if Is_Access_Type (T) then Insert_Explicit_Dereference (P); *************** package body Exp_Ch4 is *** 4136,4142 **** end if; -- For packed arrays that are not bit-packed (i.e. the case of an array ! -- with one or more index types with a non-coniguous enumeration type), -- we can always use the normal packed element get circuit. if not Is_Bit_Packed_Array (Etype (Prefix (N))) then --- 4223,4229 ---- end if; -- For packed arrays that are not bit-packed (i.e. the case of an array ! -- with one or more index types with a non-contiguous enumeration type), -- we can always use the normal packed element get circuit. if not Is_Bit_Packed_Array (Etype (Prefix (N))) then *************** package body Exp_Ch4 is *** 4148,4155 **** -- convert it to a reference to the corresponding Packed_Array_Type. -- We only want to do this for simple references, and not for: ! -- Left side of assignment, or prefix of left side of assignment, ! -- or prefix of the prefix, to handle packed arrays of packed arrays, -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement -- Renaming objects in renaming associations --- 4235,4242 ---- -- convert it to a reference to the corresponding Packed_Array_Type. -- We only want to do this for simple references, and not for: ! -- Left side of assignment, or prefix of left side of assignment, or ! -- prefix of the prefix, to handle packed arrays of packed arrays, -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement -- Renaming objects in renaming associations *************** package body Exp_Ch4 is *** 4194,4201 **** then return; ! -- If the expression is an index of an indexed component, ! -- it must be expanded regardless of context. elsif Nkind (Parnt) = N_Indexed_Component and then Child /= Prefix (Parnt) --- 4281,4288 ---- then return; ! -- If the expression is an index of an indexed component, it must ! -- be expanded regardless of context. elsif Nkind (Parnt) = N_Indexed_Component and then Child /= Prefix (Parnt) *************** package body Exp_Ch4 is *** 4224,4231 **** return; end if; ! -- Keep looking up tree for unchecked expression, or if we are ! -- the prefix of a possible assignment left side. Child := Parnt; Parnt := Parent (Child); --- 4311,4318 ---- return; end if; ! -- Keep looking up tree for unchecked expression, or if we are the ! -- prefix of a possible assignment left side. Child := Parnt; Parnt := Parent (Child); *************** package body Exp_Ch4 is *** 4254,4265 **** Right_Opnd => Right_Opnd (N)))); -- We want this to appear as coming from source if original does (see ! -- tranformations in Expand_N_In). Set_Comes_From_Source (N, Cfs); Set_Comes_From_Source (Right_Opnd (N), Cfs); ! -- Now analyze tranformed node Analyze_And_Resolve (N, Typ); end Expand_N_Not_In; --- 4341,4352 ---- Right_Opnd => Right_Opnd (N)))); -- We want this to appear as coming from source if original does (see ! -- transformations in Expand_N_In). Set_Comes_From_Source (N, Cfs); Set_Comes_From_Source (Right_Opnd (N), Cfs); ! -- Now analyze transformed node Analyze_And_Resolve (N, Typ); end Expand_N_Not_In; *************** package body Exp_Ch4 is *** 4268,4278 **** -- Expand_N_Null -- ------------------- ! -- The only replacement required is for the case of a null of type ! -- that is an access to protected subprogram. We represent such ! -- access values as a record, and so we must replace the occurrence ! -- of null by the equivalent record (with a null address and a null ! -- pointer in it), so that the backend creates the proper value. procedure Expand_N_Null (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); --- 4355,4365 ---- -- Expand_N_Null -- ------------------- ! -- The only replacement required is for the case of a null of type that is ! -- an access to protected subprogram. We represent such access values as a ! -- record, and so we must replace the occurrence of null by the equivalent ! -- record (with a null address and a null pointer in it), so that the ! -- backend creates the proper value. procedure Expand_N_Null (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); *************** package body Exp_Ch4 is *** 4290,4298 **** Rewrite (N, Agg); Analyze_And_Resolve (N, Equivalent_Type (Typ)); ! -- For subsequent semantic analysis, the node must retain its ! -- type. Gigi in any case replaces this type by the corresponding ! -- record type before processing the node. Set_Etype (N, Typ); end if; --- 4377,4385 ---- Rewrite (N, Agg); Analyze_And_Resolve (N, Equivalent_Type (Typ)); ! -- For subsequent semantic analysis, the node must retain its type. ! -- Gigi in any case replaces this type by the corresponding record ! -- type before processing the node. Set_Etype (N, Typ); end if; *************** package body Exp_Ch4 is *** 4319,4327 **** and then Is_Signed_Integer_Type (Etype (N)) and then Do_Overflow_Check (N) then ! -- The only case to worry about is when the argument is ! -- equal to the largest negative number, so what we do is ! -- to insert the check: -- [constraint_error when Expr = typ'Base'First] --- 4406,4413 ---- and then Is_Signed_Integer_Type (Etype (N)) and then Do_Overflow_Check (N) then ! -- The only case to worry about is when the argument is equal to the ! -- largest negative number, so what we do is to insert the check: -- [constraint_error when Expr = typ'Base'First] *************** package body Exp_Ch4 is *** 4437,4444 **** -- Single operand for concatenation Cnode : Node_Id; ! -- Node which is to be replaced by the result of concatenating ! -- the nodes in the list Opnds. Atyp : Entity_Id; -- Array type of concatenation result type --- 4523,4530 ---- -- Single operand for concatenation Cnode : Node_Id; ! -- Node which is to be replaced by the result of concatenating the nodes ! -- in the list Opnds. Atyp : Entity_Id; -- Array type of concatenation result type *************** package body Exp_Ch4 is *** 4451,4468 **** if Max_Available_String_Operands < 1 then ! -- In No_Run_Time mode, consider that no entities are available ! ! -- This seems wrong, RTE_Available should return False for any entity ! -- that is not in the special No_Run_Time list of allowed entities??? ! ! if No_Run_Time_Mode then ! Max_Available_String_Operands := 0; ! ! -- Otherwise see what routines are available and set max operand ! -- count according to the highest count available in the run-time. ! elsif not RTE_Available (RE_Str_Concat) then Max_Available_String_Operands := 0; elsif not RTE_Available (RE_Str_Concat_3) then --- 4537,4546 ---- if Max_Available_String_Operands < 1 then ! -- See what routines are available and set max operand count ! -- according to the highest count available in the run-time. ! if not RTE_Available (RE_Str_Concat) then Max_Available_String_Operands := 0; elsif not RTE_Available (RE_Str_Concat_3) then *************** package body Exp_Ch4 is *** 4479,4486 **** end if; Char_Concat_Available := - not No_Run_Time_Mode - and then RTE_Available (RE_Str_Concat_CC) and then RTE_Available (RE_Str_Concat_CS) --- 4557,4562 ---- *************** package body Exp_Ch4 is *** 4492,4500 **** Binary_Op_Validity_Checks (N); ! -- If we are the left operand of a concatenation higher up the ! -- tree, then do nothing for now, since we want to deal with a ! -- series of concatenations as a unit. if Nkind (Parent (N)) = N_Op_Concat and then N = Left_Opnd (Parent (N)) --- 4568,4576 ---- Binary_Op_Validity_Checks (N); ! -- If we are the left operand of a concatenation higher up the tree, ! -- then do nothing for now, since we want to deal with a series of ! -- concatenations as a unit. if Nkind (Parent (N)) = N_Op_Concat and then N = Left_Opnd (Parent (N)) *************** package body Exp_Ch4 is *** 4546,4555 **** Append (Right_Opnd (Cnode), Opnds); end loop Inner; ! -- Here we process the collected operands. First we convert ! -- singleton operands to singleton aggregates. This is skipped ! -- however for the case of two operands of type String, since ! -- we have special routines for these cases. Atyp := Base_Type (Etype (Cnode)); Ctyp := Base_Type (Component_Type (Etype (Cnode))); --- 4622,4631 ---- Append (Right_Opnd (Cnode), Opnds); end loop Inner; ! -- Here we process the collected operands. First we convert singleton ! -- operands to singleton aggregates. This is skipped however for the ! -- case of two operands of type String since we have special routines ! -- for these cases. Atyp := Base_Type (Etype (Cnode)); Ctyp := Base_Type (Component_Type (Etype (Cnode))); *************** package body Exp_Ch4 is *** 4650,4658 **** if Is_Fixed_Point_Type (Typ) then ! -- No special processing if Treat_Fixed_As_Integer is set, ! -- since from a semantic point of view such operations are ! -- simply integer operations and will be treated that way. if not Treat_Fixed_As_Integer (N) then if Is_Integer_Type (Rtyp) then --- 4726,4734 ---- if Is_Fixed_Point_Type (Typ) then ! -- No special processing if Treat_Fixed_As_Integer is set, since ! -- from a semantic point of view such operations are simply integer ! -- operations and will be treated that way. if not Treat_Fixed_As_Integer (N) then if Is_Integer_Type (Rtyp) then *************** package body Exp_Ch4 is *** 4662,4669 **** end if; end if; ! -- Other cases of division of fixed-point operands. Again we ! -- exclude the case where Treat_Fixed_As_Integer is set. elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) --- 4738,4745 ---- end if; end if; ! -- Other cases of division of fixed-point operands. Again we exclude the ! -- case where Treat_Fixed_As_Integer is set. elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) *************** package body Exp_Ch4 is *** 4676,4684 **** Expand_Divide_Fixed_By_Fixed_Giving_Float (N); end if; ! -- Mixed-mode operations can appear in a non-static universal ! -- context, in which case the integer argument must be converted ! -- explicitly. elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) --- 4752,4759 ---- Expand_Divide_Fixed_By_Fixed_Giving_Float (N); end if; ! -- Mixed-mode operations can appear in a non-static universal context, ! -- in which case the integer argument must be converted explicitly. elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) *************** package body Exp_Ch4 is *** 4750,4756 **** -- inherited. function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean; ! -- Determines whether a type has a subcompoment of an unconstrained -- Unchecked_Union subtype. Typ is a record type. ------------------------- --- 4825,4831 ---- -- inherited. function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean; ! -- Determines whether a type has a subcomponent of an unconstrained -- Unchecked_Union subtype. Typ is a record type. ------------------------- *************** package body Exp_Ch4 is *** 5041,5047 **** begin while Present (Comp) loop ! -- One component is sufficent if Component_Is_Unconstrained_UU (Comp) then return True; --- 5116,5122 ---- begin while Present (Comp) loop ! -- One component is sufficient if Component_Is_Unconstrained_UU (Comp) then return True; *************** package body Exp_Ch4 is *** 5061,5067 **** begin while Present (Variant) loop ! -- One component within a variant is sufficent if Variant_Is_Unconstrained_UU (Variant) then return True; --- 5136,5142 ---- begin while Present (Variant) loop ! -- One component within a variant is sufficient if Variant_Is_Unconstrained_UU (Variant) then return True; *************** package body Exp_Ch4 is *** 5160,5168 **** then null; ! -- For composite and floating-point cases, expand equality loop ! -- to make sure of using proper comparisons for tagged types, ! -- and correctly handling the floating-point case. else Rewrite (N, --- 5235,5243 ---- then null; ! -- For composite and floating-point cases, expand equality loop to ! -- make sure of using proper comparisons for tagged types, and ! -- correctly handling the floating-point case. else Rewrite (N, *************** package body Exp_Ch4 is *** 5192,5211 **** return; end if; ! -- If this is derived from an untagged private type completed ! -- with a tagged type, it does not have a full view, so we ! -- use the primitive operations of the private type. ! -- This check should no longer be necessary when these ! -- types receive their full views ??? if Is_Private_Type (A_Typ) and then not Is_Tagged_Type (A_Typ) and then Is_Derived_Type (A_Typ) and then No (Full_View (A_Typ)) then ! -- Search for equality operation, checking that the ! -- operands have the same type. Note that we must find ! -- a matching entry, or something is very wrong! Prim := First_Elmt (Collect_Primitive_Operations (A_Typ)); --- 5267,5285 ---- return; end if; ! -- If this is derived from an untagged private type completed with ! -- a tagged type, it does not have a full view, so we use the ! -- primitive operations of the private type. This check should no ! -- longer be necessary when these types get their full views??? if Is_Private_Type (A_Typ) and then not Is_Tagged_Type (A_Typ) and then Is_Derived_Type (A_Typ) and then No (Full_View (A_Typ)) then ! -- Search for equality operation, checking that the operands ! -- have the same type. Note that we must find a matching entry, ! -- or something is very wrong! Prim := First_Elmt (Collect_Primitive_Operations (A_Typ)); *************** package body Exp_Ch4 is *** 5223,5233 **** Op_Name := Node (Prim); -- Find the type's predefined equality or an overriding ! -- user-defined equality. The reason for not simply calling -- Find_Prim_Op here is that there may be a user-defined ! -- overloaded equality op that precedes the equality that ! -- we want, so we have to explicitly search (e.g., there ! -- could be an equality with two different parameter types). else if Is_Class_Wide_Type (Typl) then --- 5297,5307 ---- Op_Name := Node (Prim); -- Find the type's predefined equality or an overriding ! -- user- defined equality. The reason for not simply calling -- Find_Prim_Op here is that there may be a user-defined ! -- overloaded equality op that precedes the equality that we want, ! -- so we have to explicitly search (e.g., there could be an ! -- equality with two different parameter types). else if Is_Class_Wide_Type (Typl) then *************** package body Exp_Ch4 is *** 5302,5308 **** (TSS (Root_Type (Typl), TSS_Composite_Equality)); -- Otherwise expand the component by component equality. Note that ! -- we never use block-bit coparisons for records, because of the -- problems with gaps. The backend will often be able to recombine -- the separate comparisons that we generate here. --- 5376,5382 ---- (TSS (Root_Type (Typl), TSS_Composite_Equality)); -- Otherwise expand the component by component equality. Note that ! -- we never use block-bit comparisons for records, because of the -- problems with gaps. The backend will often be able to recombine -- the separate comparisons that we generate here. *************** package body Exp_Ch4 is *** 5352,5363 **** begin Binary_Op_Validity_Checks (N); ! -- If either operand is of a private type, then we have the use of ! -- an intrinsic operator, and we get rid of the privateness, by using ! -- root types of underlying types for the actual operation. Otherwise ! -- the private types will cause trouble if we expand multiplications ! -- or shifts etc. We also do this transformation if the result type ! -- is different from the base type. if Is_Private_Type (Etype (Base)) or else --- 5426,5437 ---- begin Binary_Op_Validity_Checks (N); ! -- If either operand is of a private type, then we have the use of an ! -- intrinsic operator, and we get rid of the privateness, by using root ! -- types of underlying types for the actual operation. Otherwise the ! -- private types will cause trouble if we expand multiplications or ! -- shifts etc. We also do this transformation if the result type is ! -- different from the base type. if Is_Private_Type (Etype (Base)) or else *************** package body Exp_Ch4 is *** 5398,5403 **** --- 5472,5484 ---- -- X ** 0 = 1 (or 1.0) if Expv = 0 then + + -- Call Remove_Side_Effects to ensure that any side effects + -- in the ignored left operand (in particular function calls + -- to user defined functions) are properly executed. + + Remove_Side_Effects (Base); + if Ekind (Typ) in Integer_Kind then Xnode := Make_Integer_Literal (Loc, Intval => 1); else *************** package body Exp_Ch4 is *** 5465,5470 **** --- 5546,5555 ---- -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion -- of the higher level node converts it into a shift. + -- Note: this transformation is not applicable for a modular type with + -- a non-binary modulus in the multiplication case, since we get a wrong + -- result if the shift causes an overflow before the modular reduction. + if Nkind (Base) = N_Integer_Literal and then Intval (Base) = 2 and then Is_Integer_Type (Root_Type (Exptyp)) *************** package body Exp_Ch4 is *** 5480,5485 **** --- 5565,5571 ---- begin if (Nkind (P) = N_Op_Multiply + and then not Non_Binary_Modulus (Typ) and then ((Is_Integer_Type (Etype (L)) and then R = N) or else *************** package body Exp_Ch4 is *** 5520,5528 **** Make_Integer_Literal (Loc, Modulus (Rtyp)), Exp)))); ! -- Binary case, in this case, we call one of two routines, either ! -- the unsigned integer case, or the unsigned long long integer ! -- case, with a final "and" operation to do the required mod. else if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then --- 5606,5614 ---- Make_Integer_Literal (Loc, Modulus (Rtyp)), Exp)))); ! -- Binary case, in this case, we call one of two routines, either the ! -- unsigned integer case, or the unsigned long long integer case, ! -- with a final "and" operation to do the required mod. else if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then *************** package body Exp_Ch4 is *** 5841,5849 **** Left_Opnd => Left_Opnd (N), Right_Opnd => Right_Opnd (N))); ! -- Instead of reanalyzing the node we do the analysis manually. ! -- This avoids anomalies when the replacement is done in an ! -- instance and is epsilon more efficient. Set_Entity (N, Standard_Entity (S_Op_Rem)); Set_Etype (N, Typ); --- 5927,5935 ---- Left_Opnd => Left_Opnd (N), Right_Opnd => Right_Opnd (N))); ! -- Instead of reanalyzing the node we do the analysis manually. This ! -- avoids anomalies when the replacement is done in an instance and ! -- is epsilon more efficient. Set_Entity (N, Standard_Entity (S_Op_Rem)); Set_Etype (N, Typ); *************** package body Exp_Ch4 is *** 5867,5872 **** --- 5953,5964 ---- and then Compile_Time_Known_Value (Right) and then Expr_Value (Right) = Uint_1 then + -- Call Remove_Side_Effects to ensure that any side effects in + -- the ignored left operand (in particular function calls to + -- user defined functions) are properly executed. + + Remove_Side_Effects (Left); + Rewrite (N, Make_Integer_Literal (Loc, 0)); Analyze_And_Resolve (N, Typ); return; *************** package body Exp_Ch4 is *** 5876,5888 **** -- minus one. Gigi does not handle this case correctly, because -- it generates a divide instruction which may trap in this case. ! -- In fact the check is quite easy, if the right operand is -1, ! -- then the mod value is always 0, and we can just ignore the ! -- left operand completely in this case. -- The operand type may be private (e.g. in the expansion of an ! -- an intrinsic operation) so we must use the underlying type to ! -- get the bounds, and convert the literals explicitly. LLB := Expr_Value --- 5968,5980 ---- -- minus one. Gigi does not handle this case correctly, because -- it generates a divide instruction which may trap in this case. ! -- In fact the check is quite easy, if the right operand is -1, then ! -- the mod value is always 0, and we can just ignore the left operand ! -- completely in this case. -- The operand type may be private (e.g. in the expansion of an ! -- intrinsic operation) so we must use the underlying type to get the ! -- bounds, and convert the literals explicitly. LLB := Expr_Value *************** package body Exp_Ch4 is *** 5915,5931 **** -------------------------- procedure Expand_N_Op_Multiply (N : Node_Id) is ! Loc : constant Source_Ptr := Sloc (N); ! Lop : constant Node_Id := Left_Opnd (N); ! Rop : constant Node_Id := Right_Opnd (N); ! Lp2 : constant Boolean := ! Nkind (Lop) = N_Op_Expon ! and then Is_Power_Of_2_For_Shift (Lop); ! Rp2 : constant Boolean := ! Nkind (Rop) = N_Op_Expon ! and then Is_Power_Of_2_For_Shift (Rop); Ltyp : constant Entity_Id := Etype (Lop); Rtyp : constant Entity_Id := Etype (Rop); --- 6007,6023 ---- -------------------------- procedure Expand_N_Op_Multiply (N : Node_Id) is ! Loc : constant Source_Ptr := Sloc (N); ! Lop : constant Node_Id := Left_Opnd (N); ! Rop : constant Node_Id := Right_Opnd (N); ! Lp2 : constant Boolean := ! Nkind (Lop) = N_Op_Expon ! and then Is_Power_Of_2_For_Shift (Lop); ! Rp2 : constant Boolean := ! Nkind (Rop) = N_Op_Expon ! and then Is_Power_Of_2_For_Shift (Rop); Ltyp : constant Entity_Id := Etype (Lop); Rtyp : constant Entity_Id := Etype (Rop); *************** package body Exp_Ch4 is *** 5938,5951 **** if Is_Integer_Type (Typ) then ! -- N * 0 = 0 * N = 0 for integer types ! if (Compile_Time_Known_Value (Rop) ! and then Expr_Value (Rop) = Uint_0) ! or else ! (Compile_Time_Known_Value (Lop) ! and then Expr_Value (Lop) = Uint_0) then Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); Analyze_And_Resolve (N, Typ); return; --- 6030,6057 ---- if Is_Integer_Type (Typ) then ! -- N * 0 = 0 for integer types ! if Compile_Time_Known_Value (Rop) ! and then Expr_Value (Rop) = Uint_0 ! then ! -- Call Remove_Side_Effects to ensure that any side effects in ! -- the ignored left operand (in particular function calls to ! -- user defined functions) are properly executed. ! ! Remove_Side_Effects (Lop); ! ! Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); ! Analyze_And_Resolve (N, Typ); ! return; ! end if; ! ! -- Similar handling for 0 * N = 0 ! ! if Compile_Time_Known_Value (Lop) ! and then Expr_Value (Lop) = Uint_0 then + Remove_Side_Effects (Rop); Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); Analyze_And_Resolve (N, Typ); return; *************** package body Exp_Ch4 is *** 6024,6032 **** if Is_Fixed_Point_Type (Typ) then ! -- No special processing if Treat_Fixed_As_Integer is set, ! -- since from a semantic point of view such operations are ! -- simply integer operations and will be treated that way. if not Treat_Fixed_As_Integer (N) then --- 6130,6138 ---- if Is_Fixed_Point_Type (Typ) then ! -- No special processing if Treat_Fixed_As_Integer is set, since from ! -- a semantic point of view such operations are simply integer ! -- operations and will be treated that way. if not Treat_Fixed_As_Integer (N) then *************** package body Exp_Ch4 is *** 6047,6054 **** end if; end if; ! -- Other cases of multiplication of fixed-point operands. Again ! -- we exclude the cases where Treat_Fixed_As_Integer flag is set. elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) and then not Treat_Fixed_As_Integer (N) --- 6153,6160 ---- end if; end if; ! -- Other cases of multiplication of fixed-point operands. Again we ! -- exclude the cases where Treat_Fixed_As_Integer flag is set. elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) and then not Treat_Fixed_As_Integer (N) *************** package body Exp_Ch4 is *** 6060,6068 **** Expand_Multiply_Fixed_By_Fixed_Giving_Float (N); end if; ! -- Mixed-mode operations can appear in a non-static universal ! -- context, in which case the integer argument must be converted ! -- explicitly. elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) --- 6166,6173 ---- Expand_Multiply_Fixed_By_Fixed_Giving_Float (N); end if; ! -- Mixed-mode operations can appear in a non-static universal context, ! -- in which case the integer argument must be converted explicitly. elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) *************** package body Exp_Ch4 is *** 6169,6186 **** -- Expand_N_Op_Not -- --------------------- ! -- If the argument is other than a Boolean array type, there is no ! -- special expansion required. -- For the packed case, we call the special routine in Exp_Pakd, except -- that if the component size is greater than one, we use the standard -- routine generating a gruesome loop (it is so peculiar to have packed ! -- arrays with non-standard Boolean representations anyway, so it does ! -- not matter that we do not handle this case efficiently). ! -- For the unpacked case (and for the special packed case where we have ! -- non standard Booleans, as discussed above), we generate and insert ! -- into the tree the following function definition: -- function Nnnn (A : arr) is -- B : arr; --- 6274,6291 ---- -- Expand_N_Op_Not -- --------------------- ! -- If the argument is other than a Boolean array type, there is no special ! -- expansion required. -- For the packed case, we call the special routine in Exp_Pakd, except -- that if the component size is greater than one, we use the standard -- routine generating a gruesome loop (it is so peculiar to have packed ! -- arrays with non-standard Boolean representations anyway, so it does not ! -- matter that we do not handle this case efficiently). ! -- For the unpacked case (and for the special packed case where we have non ! -- standard Booleans, as discussed above), we generate and insert into the ! -- tree the following function definition: -- function Nnnn (A : arr) is -- B : arr; *************** package body Exp_Ch4 is *** 6246,6251 **** --- 6351,6357 ---- Convert_To_Actual_Subtype (Opnd); Arr := Etype (Opnd); Ensure_Defined (Arr, N); + Silly_Boolean_Array_Not_Test (N, Arr); if Nkind (Parent (N)) = N_Assignment_Statement then if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then *************** package body Exp_Ch4 is *** 6416,6448 **** Apply_Divide_Check (N); end if; ! -- Apply optimization x rem 1 = 0. We don't really need that with ! -- gcc, but it is useful with other back ends (e.g. AAMP), and is ! -- certainly harmless. if Is_Integer_Type (Etype (N)) and then Compile_Time_Known_Value (Right) and then Expr_Value (Right) = Uint_1 then Rewrite (N, Make_Integer_Literal (Loc, 0)); Analyze_And_Resolve (N, Typ); return; end if; ! -- Deal with annoying case of largest negative number remainder ! -- minus one. Gigi does not handle this case correctly, because ! -- it generates a divide instruction which may trap in this case. ! -- In fact the check is quite easy, if the right operand is -1, ! -- then the remainder is always 0, and we can just ignore the ! -- left operand completely in this case. Determine_Range (Right, ROK, Rlo, Rhi); Determine_Range (Left, LOK, Llo, Lhi); -- The operand type may be private (e.g. in the expansion of an ! -- an intrinsic operation) so we must use the underlying type to ! -- get the bounds, and convert the literals explicitly. LLB := Expr_Value --- 6522,6560 ---- Apply_Divide_Check (N); end if; ! -- Apply optimization x rem 1 = 0. We don't really need that with gcc, ! -- but it is useful with other back ends (e.g. AAMP), and is certainly ! -- harmless. if Is_Integer_Type (Etype (N)) and then Compile_Time_Known_Value (Right) and then Expr_Value (Right) = Uint_1 then + -- Call Remove_Side_Effects to ensure that any side effects in the + -- ignored left operand (in particular function calls to user defined + -- functions) are properly executed. + + Remove_Side_Effects (Left); + Rewrite (N, Make_Integer_Literal (Loc, 0)); Analyze_And_Resolve (N, Typ); return; end if; ! -- Deal with annoying case of largest negative number remainder minus ! -- one. Gigi does not handle this case correctly, because it generates ! -- a divide instruction which may trap in this case. ! -- In fact the check is quite easy, if the right operand is -1, then ! -- the remainder is always 0, and we can just ignore the left operand ! -- completely in this case. Determine_Range (Right, ROK, Rlo, Rhi); Determine_Range (Left, LOK, Llo, Lhi); -- The operand type may be private (e.g. in the expansion of an ! -- intrinsic operation) so we must use the underlying type to get the ! -- bounds, and convert the literals explicitly. LLB := Expr_Value *************** package body Exp_Ch4 is *** 6538,6544 **** return; end if; ! -- Arithemtic overflow checks for signed integer/fixed point types if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) --- 6650,6656 ---- return; end if; ! -- Arithmetic overflow checks for signed integer/fixed point types if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) *************** package body Exp_Ch4 is *** 6596,6629 **** Set_Etype (N, Standard_Boolean); end if; ! -- Check for cases of left argument is True or False ! if Nkind (Left) = N_Identifier then -- If left argument is False, change (False or else Right) to Right. -- Any actions associated with Right will be executed unconditionally -- and can thus be inserted into the tree unconditionally. ! if Entity (Left) = Standard_False then if Present (Actions (N)) then Insert_Actions (N, Actions (N)); end if; Rewrite (N, Right); - Adjust_Result_Type (N, Typ); - return; ! -- If left argument is True, change (True and then Right) to ! -- True. In this case we can forget the actions associated with ! -- Right, since they will never be executed. ! elsif Entity (Left) = Standard_True then Kill_Dead_Code (Right); Kill_Dead_Code (Actions (N)); Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); - Adjust_Result_Type (N, Typ); - return; end if; end if; -- If Actions are present, we expand --- 6708,6740 ---- Set_Etype (N, Standard_Boolean); end if; ! -- Check for cases where left argument is known to be True or False ! if Compile_Time_Known_Value (Left) then -- If left argument is False, change (False or else Right) to Right. -- Any actions associated with Right will be executed unconditionally -- and can thus be inserted into the tree unconditionally. ! if Expr_Value_E (Left) = Standard_False then if Present (Actions (N)) then Insert_Actions (N, Actions (N)); end if; Rewrite (N, Right); ! -- If left argument is True, change (True and then Right) to True. In ! -- this case we can forget the actions associated with Right, since ! -- they will never be executed. ! else pragma Assert (Expr_Value_E (Left) = Standard_True); Kill_Dead_Code (Right); Kill_Dead_Code (Actions (N)); Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); end if; + + Adjust_Result_Type (N, Typ); + return; end if; -- If Actions are present, we expand *************** package body Exp_Ch4 is *** 6655,6673 **** -- No actions present, check for cases of right argument True/False ! if Nkind (Right) = N_Identifier then ! -- Change (Left or else False) to Left. Note that we know there ! -- are no actions associated with the True operand, since we ! -- just checked for this case above. ! if Entity (Right) = Standard_False then Rewrite (N, Left); ! -- Change (Left or else True) to True, making sure to preserve ! -- any side effects associated with the Left operand. ! elsif Entity (Right) = Standard_True then Remove_Side_Effects (Left); Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); --- 6766,6784 ---- -- No actions present, check for cases of right argument True/False ! if Compile_Time_Known_Value (Right) then ! -- Change (Left or else False) to Left. Note that we know there are ! -- no actions associated with the True operand, since we just checked ! -- for this case above. ! if Expr_Value_E (Right) = Standard_False then Rewrite (N, Left); ! -- Change (Left or else True) to True, making sure to preserve any ! -- side effects associated with the Left operand. ! else pragma Assert (Expr_Value_E (Right) = Standard_True); Remove_Side_Effects (Left); Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); *************** package body Exp_Ch4 is *** 6755,6762 **** if Do_Discriminant_Check (N) then ! -- Present the discrminant checking function to the backend, ! -- so that it can inline the call to the function. Add_Inlined_Body (Discriminant_Checking_Func --- 6866,6873 ---- if Do_Discriminant_Check (N) then ! -- Present the discriminant checking function to the backend, so that ! -- it can inline the call to the function. Add_Inlined_Body (Discriminant_Checking_Func *************** package body Exp_Ch4 is *** 6768,6773 **** --- 6879,6893 ---- Generate_Discriminant_Check (N); end if; + -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place + -- function, then additional actuals must be passed. + + if Ada_Version >= Ada_05 + and then Is_Build_In_Place_Function_Call (P) + then + Make_Build_In_Place_Call_In_Anonymous_Context (P); + end if; + -- Gigi cannot handle unchecked conversions that are the prefix of a -- selected component with discriminants. This must be checked during -- expansion, because during analysis the type of the selector is not *************** package body Exp_Ch4 is *** 6809,6817 **** then null; ! -- Don't do this optimization for the prefix of an attribute ! -- or the operand of an object renaming declaration since these ! -- are contexts where we do not want the value anyway. elsif (Nkind (Par) = N_Attribute_Reference and then Prefix (Par) = N) --- 6929,6937 ---- then null; ! -- Don't do this optimization for the prefix of an attribute or ! -- the operand of an object renaming declaration since these are ! -- contexts where we do not want the value anyway. elsif (Nkind (Par) = N_Attribute_Reference and then Prefix (Par) = N) *************** package body Exp_Ch4 is *** 6827,6838 **** null; -- Green light to see if we can do the optimization. There is ! -- still one condition that inhibits the optimization below ! -- but now is the time to check the particular discriminant. else ! -- Loop through discriminants to find the matching ! -- discriminant constraint to see if we can copy it. Disc := First_Discriminant (Ptyp); Dcon := First_Elmt (Discriminant_Constraint (Ptyp)); --- 6947,6958 ---- null; -- Green light to see if we can do the optimization. There is ! -- still one condition that inhibits the optimization below but ! -- now is the time to check the particular discriminant. else ! -- Loop through discriminants to find the matching discriminant ! -- constraint to see if we can copy it. Disc := First_Discriminant (Ptyp); Dcon := First_Elmt (Discriminant_Constraint (Ptyp)); *************** package body Exp_Ch4 is *** 6853,6862 **** then exit Discr_Loop; ! -- In the context of a case statement, the expression ! -- may have the base type of the discriminant, and we ! -- need to preserve the constraint to avoid spurious ! -- errors on missing cases. elsif Nkind (Parent (N)) = N_Case_Statement and then Etype (Node (Dcon)) /= Etype (Disc) --- 6973,6982 ---- then exit Discr_Loop; ! -- In the context of a case statement, the expression may ! -- have the base type of the discriminant, and we need to ! -- preserve the constraint to avoid spurious errors on ! -- missing cases. elsif Nkind (Parent (N)) = N_Case_Statement and then Etype (Node (Dcon)) /= Etype (Disc) *************** package body Exp_Ch4 is *** 6896,6903 **** -- Note: the above loop should always find a matching -- discriminant, but if it does not, we just missed an ! -- optimization due to some glitch (perhaps a previous ! -- error), so ignore. end if; end if; --- 7016,7023 ---- -- Note: the above loop should always find a matching -- discriminant, but if it does not, we just missed an ! -- optimization due to some glitch (perhaps a previous error), ! -- so ignore. end if; end if; *************** package body Exp_Ch4 is *** 6943,6963 **** Ptp : Entity_Id := Etype (Pfx); function Is_Procedure_Actual (N : Node_Id) return Boolean; ! -- Check whether the argument is an actual for a procedure call, ! -- in which case the expansion of a bit-packed slice is deferred ! -- until the call itself is expanded. The reason this is required ! -- is that we might have an IN OUT or OUT parameter, and the copy out ! -- is essential, and that copy out would be missed if we created a ! -- temporary here in Expand_N_Slice. Note that we don't bother ! -- to test specifically for an IN OUT or OUT mode parameter, since it ! -- is a bit tricky to do, and it is harmless to defer expansion ! -- in the IN case, since the call processing will still generate the ! -- appropriate copy in operation, which will take care of the slice. procedure Make_Temporary; ! -- Create a named variable for the value of the slice, in ! -- cases where the back-end cannot handle it properly, e.g. ! -- when packed types or unaligned slices are involved. ------------------------- -- Is_Procedure_Actual -- --- 7063,7083 ---- Ptp : Entity_Id := Etype (Pfx); function Is_Procedure_Actual (N : Node_Id) return Boolean; ! -- Check whether the argument is an actual for a procedure call, in ! -- which case the expansion of a bit-packed slice is deferred until the ! -- call itself is expanded. The reason this is required is that we might ! -- have an IN OUT or OUT parameter, and the copy out is essential, and ! -- that copy out would be missed if we created a temporary here in ! -- Expand_N_Slice. Note that we don't bother to test specifically for an ! -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it ! -- is harmless to defer expansion in the IN case, since the call ! -- processing will still generate the appropriate copy in operation, ! -- which will take care of the slice. procedure Make_Temporary; ! -- Create a named variable for the value of the slice, in cases where ! -- the back-end cannot handle it properly, e.g. when packed types or ! -- unaligned slices are involved. ------------------------- -- Is_Procedure_Actual -- *************** package body Exp_Ch4 is *** 6973,6983 **** if Nkind (Par) = N_Procedure_Call_Statement then return True; ! -- If our parent is a type conversion, keep climbing the ! -- tree, since a type conversion can be a procedure actual. ! -- Also keep climbing if parameter association or a qualified ! -- expression, since these are additional cases that do can ! -- appear on procedure actuals. elsif Nkind_In (Par, N_Type_Conversion, N_Parameter_Association, --- 7093,7103 ---- if Nkind (Par) = N_Procedure_Call_Statement then return True; ! -- If our parent is a type conversion, keep climbing the tree, ! -- since a type conversion can be a procedure actual. Also keep ! -- climbing if parameter association or a qualified expression, ! -- since these are additional cases that do can appear on ! -- procedure actuals. elsif Nkind_In (Par, N_Type_Conversion, N_Parameter_Association, *************** package body Exp_Ch4 is *** 7035,7043 **** Analyze_And_Resolve (Pfx, Ptp); end if; ! -- Range checks are potentially also needed for cases involving ! -- a slice indexed by a subtype indication, but Do_Range_Check ! -- can currently only be set for expressions ??? if not Index_Checks_Suppressed (Ptp) and then (not Is_Entity_Name (Pfx) --- 7155,7172 ---- Analyze_And_Resolve (Pfx, Ptp); end if; ! -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place ! -- function, then additional actuals must be passed. ! ! if Ada_Version >= Ada_05 ! and then Is_Build_In_Place_Function_Call (Pfx) ! then ! Make_Build_In_Place_Call_In_Anonymous_Context (Pfx); ! end if; ! ! -- Range checks are potentially also needed for cases involving a slice ! -- indexed by a subtype indication, but Do_Range_Check can currently ! -- only be set for expressions ??? if not Index_Checks_Suppressed (Ptp) and then (not Is_Entity_Name (Pfx) *************** package body Exp_Ch4 is *** 7067,7090 **** -- 1. Right or left side of an assignment (we can handle this -- situation correctly in the assignment statement expansion). ! -- 2. Prefix of indexed component (the slide is optimized away ! -- in this case, see the start of Expand_N_Slice.) ! -- 3. Object renaming declaration, since we want the name of ! -- the slice, not the value. ! -- 4. Argument to procedure call, since copy-in/copy-out handling ! -- may be required, and this is handled in the expansion of ! -- call itself. ! -- 5. Prefix of an address attribute (this is an error which ! -- is caught elsewhere, and the expansion would intefere ! -- with generating the error message). if not Is_Packed (Typ) then ! -- Apply transformation for actuals of a function call, ! -- where Expand_Actuals is not used. if Nkind (Parent (N)) = N_Function_Call and then Is_Possibly_Unaligned_Slice (N) --- 7196,7219 ---- -- 1. Right or left side of an assignment (we can handle this -- situation correctly in the assignment statement expansion). ! -- 2. Prefix of indexed component (the slide is optimized away in this ! -- case, see the start of Expand_N_Slice.) ! -- 3. Object renaming declaration, since we want the name of the ! -- slice, not the value. ! -- 4. Argument to procedure call, since copy-in/copy-out handling may ! -- be required, and this is handled in the expansion of call ! -- itself. ! -- 5. Prefix of an address attribute (this is an error which is caught ! -- elsewhere, and the expansion would interfere with generating the ! -- error message). if not Is_Packed (Typ) then ! -- Apply transformation for actuals of a function call, where ! -- Expand_Actuals is not used. if Nkind (Parent (N)) = N_Function_Call and then Is_Possibly_Unaligned_Slice (N) *************** package body Exp_Ch4 is *** 7125,7136 **** Operand_Type : Entity_Id := Etype (Operand); procedure Handle_Changed_Representation; ! -- This is called in the case of record and array type conversions ! -- to see if there is a change of representation to be handled. ! -- Change of representation is actually handled at the assignment ! -- statement level, and what this procedure does is rewrite node N ! -- conversion as an assignment to temporary. If there is no change ! -- of representation, then the conversion node is unchanged. procedure Real_Range_Check; -- Handles generation of range check for real target value --- 7254,7265 ---- Operand_Type : Entity_Id := Etype (Operand); procedure Handle_Changed_Representation; ! -- This is called in the case of record and array type conversions to ! -- see if there is a change of representation to be handled. Change of ! -- representation is actually handled at the assignment statement level, ! -- and what this procedure does is rewrite node N conversion as an ! -- assignment to temporary. If there is no change of representation, ! -- then the conversion node is unchanged. procedure Real_Range_Check; -- Handles generation of range check for real target value *************** package body Exp_Ch4 is *** 7168,7175 **** else Cons := No_List; ! -- If type is unconstrained we have to add a constraint, ! -- copied from the actual value of the left hand side. if not Is_Constrained (Target_Type) then if Has_Discriminants (Operand_Type) then --- 7297,7304 ---- else Cons := No_List; ! -- If type is unconstrained we have to add a constraint, copied ! -- from the actual value of the left hand side. if not Is_Constrained (Target_Type) then if Has_Discriminants (Operand_Type) then *************** package body Exp_Ch4 is *** 7265,7273 **** -- Real_Range_Check -- ---------------------- ! -- Case of conversions to floating-point or fixed-point. If range ! -- checks are enabled and the target type has a range constraint, ! -- we convert: -- typ (x) --- 7394,7401 ---- -- Real_Range_Check -- ---------------------- ! -- Case of conversions to floating-point or fixed-point. If range checks ! -- are enabled and the target type has a range constraint, we convert: -- typ (x) *************** package body Exp_Ch4 is *** 7277,7286 **** -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last] -- Tnn ! -- This is necessary when there is a conversion of integer to float ! -- or to fixed-point to ensure that the correct checks are made. It ! -- is not necessary for float to float where it is enough to simply ! -- set the Do_Range_Check flag. procedure Real_Range_Check is Btyp : constant Entity_Id := Base_Type (Target_Type); --- 7405,7414 ---- -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last] -- Tnn ! -- This is necessary when there is a conversion of integer to float or ! -- to fixed-point to ensure that the correct checks are made. It is not ! -- necessary for float to float where it is enough to simply set the ! -- Do_Range_Check flag. procedure Real_Range_Check is Btyp : constant Entity_Id := Base_Type (Target_Type); *************** package body Exp_Ch4 is *** 7297,7304 **** return; end if; ! -- Nothing to do if range checks suppressed, or target has the ! -- same range as the base type (or is the base type). if Range_Checks_Suppressed (Target_Type) or else (Lo = Type_Low_Bound (Btyp) --- 7425,7432 ---- return; end if; ! -- Nothing to do if range checks suppressed, or target has the same ! -- range as the base type (or is the base type). if Range_Checks_Suppressed (Target_Type) or else (Lo = Type_Low_Bound (Btyp) *************** package body Exp_Ch4 is *** 7308,7315 **** return; end if; ! -- Nothing to do if expression is an entity on which checks ! -- have been suppressed. if Is_Entity_Name (Operand) and then Range_Checks_Suppressed (Entity (Operand)) --- 7436,7443 ---- return; end if; ! -- Nothing to do if expression is an entity on which checks have been ! -- suppressed. if Is_Entity_Name (Operand) and then Range_Checks_Suppressed (Entity (Operand)) *************** package body Exp_Ch4 is *** 7317,7326 **** return; end if; ! -- Nothing to do if bounds are all static and we can tell that ! -- the expression is within the bounds of the target. Note that ! -- if the operand is of an unconstrained floating-point type, ! -- then we do not trust it to be in range (might be infinite) declare S_Lo : constant Node_Id := Type_Low_Bound (Xtyp); --- 7445,7454 ---- return; end if; ! -- Nothing to do if bounds are all static and we can tell that the ! -- expression is within the bounds of the target. Note that if the ! -- operand is of an unconstrained floating-point type, then we do ! -- not trust it to be in range (might be infinite) declare S_Lo : constant Node_Id := Type_Low_Bound (Xtyp); *************** package body Exp_Ch4 is *** 7423,7439 **** -- Start of processing for Expand_N_Type_Conversion begin ! -- Nothing at all to do if conversion is to the identical type ! -- so remove the conversion completely, it is useless. if Operand_Type = Target_Type then Rewrite (N, Relocate_Node (Operand)); return; end if; ! -- Nothing to do if this is the second argument of read. This ! -- is a "backwards" conversion that will be handled by the ! -- specialized code in attribute processing. if Nkind (Parent (N)) = N_Attribute_Reference and then Attribute_Name (Parent (N)) = Name_Read --- 7551,7567 ---- -- Start of processing for Expand_N_Type_Conversion begin ! -- Nothing at all to do if conversion is to the identical type so remove ! -- the conversion completely, it is useless. if Operand_Type = Target_Type then Rewrite (N, Relocate_Node (Operand)); return; end if; ! -- Nothing to do if this is the second argument of read. This is a ! -- "backwards" conversion that will be handled by the specialized code ! -- in attribute processing. if Nkind (Parent (N)) = N_Attribute_Reference and then Attribute_Name (Parent (N)) = Name_Read *************** package body Exp_Ch4 is *** 7468,7476 **** -- Apply an accessibility check when the conversion operand is an -- access parameter (or a renaming thereof), unless conversion was ! -- expanded from an unchecked or unrestricted access attribute. Note ! -- that other checks may still need to be applied below (such as ! -- tagged type checks). if Is_Entity_Name (Operand) and then --- 7596,7604 ---- -- Apply an accessibility check when the conversion operand is an -- access parameter (or a renaming thereof), unless conversion was ! -- expanded from an Unchecked_ or Unrestricted_Access attribute. ! -- Note that other checks may still need to be applied below (such ! -- as tagged type checks). if Is_Entity_Name (Operand) and then *************** package body Exp_Ch4 is *** 7484,7498 **** and then (Nkind (Original_Node (N)) /= N_Attribute_Reference or else Attribute_Name (Original_Node (N)) = Name_Access) then ! Apply_Accessibility_Check (Operand, Target_Type); ! -- If the level of the operand type is statically deeper ! -- then the level of the target type, then force Program_Error. ! -- Note that this can only occur for cases where the attribute ! -- is within the body of an instantiation (otherwise the ! -- conversion will already have been rejected as illegal). ! -- Note: warnings are issued by the analyzer for the instance ! -- cases. elsif In_Instance_Body and then Type_Access_Level (Operand_Type) > --- 7612,7626 ---- and then (Nkind (Original_Node (N)) /= N_Attribute_Reference or else Attribute_Name (Original_Node (N)) = Name_Access) then ! Apply_Accessibility_Check ! (Operand, Target_Type, Insert_Node => Operand); ! -- If the level of the operand type is statically deeper than the ! -- level of the target type, then force Program_Error. Note that this ! -- can only occur for cases where the attribute is within the body of ! -- an instantiation (otherwise the conversion will already have been ! -- rejected as illegal). Note: warnings are issued by the analyzer ! -- for the instance cases. elsif In_Instance_Body and then Type_Access_Level (Operand_Type) > *************** package body Exp_Ch4 is *** 7503,7514 **** Reason => PE_Accessibility_Check_Failed)); Set_Etype (N, Target_Type); ! -- When the operand is a selected access discriminant ! -- the check needs to be made against the level of the ! -- object denoted by the prefix of the selected name. ! -- Force Program_Error for this case as well (this ! -- accessibility violation can only happen if within ! -- the body of an instantiation). elsif In_Instance_Body and then Ekind (Operand_Type) = E_Anonymous_Access_Type --- 7631,7641 ---- Reason => PE_Accessibility_Check_Failed)); Set_Etype (N, Target_Type); ! -- When the operand is a selected access discriminant the check needs ! -- to be made against the level of the object denoted by the prefix ! -- of the selected name. Force Program_Error for this case as well ! -- (this accessibility violation can only happen if within the body ! -- of an instantiation). elsif In_Instance_Body and then Ekind (Operand_Type) = E_Anonymous_Access_Type *************** package body Exp_Ch4 is *** 7525,7533 **** -- Case of conversions of tagged types and access to tagged types ! -- When needed, that is to say when the expression is class-wide, ! -- Add runtime a tag check for (strict) downward conversion by using ! -- the membership test, generating: -- [constraint_error when Operand not in Target_Type'Class] --- 7652,7660 ---- -- Case of conversions of tagged types and access to tagged types ! -- When needed, that is to say when the expression is class-wide, Add ! -- runtime a tag check for (strict) downward conversion by using the ! -- membership test, generating: -- [constraint_error when Operand not in Target_Type'Class] *************** package body Exp_Ch4 is *** 7542,7551 **** and then Is_Tagged_Type (Designated_Type (Target_Type))) or else Is_Tagged_Type (Target_Type) then ! -- Do not do any expansion in the access type case if the ! -- parent is a renaming, since this is an error situation ! -- which will be caught by Sem_Ch8, and the expansion can ! -- intefere with this error check. if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) --- 7669,7677 ---- and then Is_Tagged_Type (Designated_Type (Target_Type))) or else Is_Tagged_Type (Target_Type) then ! -- Do not do any expansion in the access type case if the parent is a ! -- renaming, since this is an error situation which will be caught by ! -- Sem_Ch8, and the expansion can interfere with this error check. if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) *************** package body Exp_Ch4 is *** 7556,7635 **** -- Otherwise, proceed with processing tagged conversion declare ! Actual_Operand_Type : Entity_Id; ! Actual_Target_Type : Entity_Id; ! Cond : Node_Id; begin if Is_Access_Type (Target_Type) then ! Actual_Operand_Type := Designated_Type (Operand_Type); ! Actual_Target_Type := Designated_Type (Target_Type); else ! Actual_Operand_Type := Operand_Type; ! Actual_Target_Type := Target_Type; end if; -- Ada 2005 (AI-251): Handle interface type conversion ! if Is_Interface (Actual_Operand_Type) then Expand_Interface_Conversion (N, Is_Static => False); return; end if; ! if Is_Class_Wide_Type (Actual_Operand_Type) ! and then Root_Type (Actual_Operand_Type) /= Actual_Target_Type ! and then Is_Ancestor ! (Root_Type (Actual_Operand_Type), ! Actual_Target_Type) ! and then not Tag_Checks_Suppressed (Actual_Target_Type) ! then ! -- The conversion is valid for any descendant of the ! -- target type ! Actual_Target_Type := Class_Wide_Type (Actual_Target_Type); ! if Is_Access_Type (Target_Type) then ! Cond := ! Make_And_Then (Loc, ! Left_Opnd => ! Make_Op_Ne (Loc, ! Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), ! Right_Opnd => Make_Null (Loc)), ! Right_Opnd => ! Make_Not_In (Loc, ! Left_Opnd => ! Make_Explicit_Dereference (Loc, ! Prefix => ! Duplicate_Subexpr_No_Checks (Operand)), ! Right_Opnd => ! New_Reference_To (Actual_Target_Type, Loc))); ! else ! Cond := ! Make_Not_In (Loc, ! Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), ! Right_Opnd => ! New_Reference_To (Actual_Target_Type, Loc)); end if; ! Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, ! Condition => Cond, ! Reason => CE_Tag_Check_Failed)); ! declare ! Conv : Node_Id; ! begin ! Conv := ! Make_Unchecked_Type_Conversion (Loc, ! Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), ! Expression => Relocate_Node (Expression (N))); ! Rewrite (N, Conv); ! Analyze_And_Resolve (N, Target_Type); ! end; end if; end; --- 7682,7832 ---- -- Otherwise, proceed with processing tagged conversion declare ! Actual_Op_Typ : Entity_Id; ! Actual_Targ_Typ : Entity_Id; ! Make_Conversion : Boolean := False; ! Root_Op_Typ : Entity_Id; ! procedure Make_Tag_Check (Targ_Typ : Entity_Id); ! -- Create a membership check to test whether Operand is a member ! -- of Targ_Typ. If the original Target_Type is an access, include ! -- a test for null value. The check is inserted at N. ! ! -------------------- ! -- Make_Tag_Check -- ! -------------------- ! ! procedure Make_Tag_Check (Targ_Typ : Entity_Id) is ! Cond : Node_Id; ! ! begin ! -- Generate: ! -- [Constraint_Error ! -- when Operand /= null ! -- and then Operand.all not in Targ_Typ] ! ! if Is_Access_Type (Target_Type) then ! Cond := ! Make_And_Then (Loc, ! Left_Opnd => ! Make_Op_Ne (Loc, ! Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), ! Right_Opnd => Make_Null (Loc)), ! ! Right_Opnd => ! Make_Not_In (Loc, ! Left_Opnd => ! Make_Explicit_Dereference (Loc, ! Prefix => Duplicate_Subexpr_No_Checks (Operand)), ! Right_Opnd => New_Reference_To (Targ_Typ, Loc))); ! ! -- Generate: ! -- [Constraint_Error when Operand not in Targ_Typ] ! ! else ! Cond := ! Make_Not_In (Loc, ! Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), ! Right_Opnd => New_Reference_To (Targ_Typ, Loc)); ! end if; ! ! Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, ! Condition => Cond, ! Reason => CE_Tag_Check_Failed)); ! end Make_Tag_Check; ! ! -- Start of processing begin if Is_Access_Type (Target_Type) then ! Actual_Op_Typ := Designated_Type (Operand_Type); ! Actual_Targ_Typ := Designated_Type (Target_Type); else ! Actual_Op_Typ := Operand_Type; ! Actual_Targ_Typ := Target_Type; end if; + Root_Op_Typ := Root_Type (Actual_Op_Typ); + -- Ada 2005 (AI-251): Handle interface type conversion ! if Is_Interface (Actual_Op_Typ) then Expand_Interface_Conversion (N, Is_Static => False); return; end if; ! if not Tag_Checks_Suppressed (Actual_Targ_Typ) then ! -- Create a runtime tag check for a downward class-wide type ! -- conversion. ! if Is_Class_Wide_Type (Actual_Op_Typ) ! and then Root_Op_Typ /= Actual_Targ_Typ ! and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ) ! then ! Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ)); ! Make_Conversion := True; ! end if; ! -- AI05-0073: If the result subtype of the function is defined ! -- by an access_definition designating a specific tagged type ! -- T, a check is made that the result value is null or the tag ! -- of the object designated by the result value identifies T. ! -- Constraint_Error is raised if this check fails. ! if Nkind (Parent (N)) = Sinfo.N_Return_Statement then ! declare ! Func : Entity_Id; ! Func_Typ : Entity_Id; ! ! begin ! -- Climb scope stack looking for the enclosing function ! ! Func := Current_Scope; ! while Present (Func) ! and then Ekind (Func) /= E_Function ! loop ! Func := Scope (Func); ! end loop; ! ! -- The function's return subtype must be defined using ! -- an access definition. ! ! if Nkind (Result_Definition (Parent (Func))) = ! N_Access_Definition ! then ! Func_Typ := Directly_Designated_Type (Etype (Func)); ! ! -- The return subtype denotes a specific tagged type, ! -- in other words, a non class-wide type. ! ! if Is_Tagged_Type (Func_Typ) ! and then not Is_Class_Wide_Type (Func_Typ) ! then ! Make_Tag_Check (Actual_Targ_Typ); ! Make_Conversion := True; ! end if; ! end if; ! end; end if; ! -- We have generated a tag check for either a class-wide type ! -- conversion or for AI05-0073. ! if Make_Conversion then ! declare ! Conv : Node_Id; ! begin ! Conv := ! Make_Unchecked_Type_Conversion (Loc, ! Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), ! Expression => Relocate_Node (Expression (N))); ! Rewrite (N, Conv); ! Analyze_And_Resolve (N, Target_Type); ! end; ! end if; end if; end; *************** package body Exp_Ch4 is *** 7640,7648 **** -- Case of conversions from a fixed-point type ! -- These conversions require special expansion and processing, found ! -- in the Exp_Fixd package. We ignore cases where Conversion_OK is ! -- set, since from a semantic point of view, these are simple integer -- conversions, which do not need further processing. elsif Is_Fixed_Point_Type (Operand_Type) --- 7837,7845 ---- -- Case of conversions from a fixed-point type ! -- These conversions require special expansion and processing, found in ! -- the Exp_Fixd package. We ignore cases where Conversion_OK is set, ! -- since from a semantic point of view, these are simple integer -- conversions, which do not need further processing. elsif Is_Fixed_Point_Type (Operand_Type) *************** package body Exp_Ch4 is *** 7654,7664 **** pragma Assert (Operand_Type /= Universal_Fixed); ! -- Check for special case of the conversion to universal real ! -- that occurs as a result of the use of a round attribute. ! -- In this case, the real type for the conversion is taken ! -- from the target type of the Round attribute and the ! -- result must be marked as rounded. if Target_Type = Universal_Real and then Nkind (Parent (N)) = N_Attribute_Reference --- 7851,7860 ---- pragma Assert (Operand_Type /= Universal_Fixed); ! -- Check for special case of the conversion to universal real that ! -- occurs as a result of the use of a round attribute. In this case, ! -- the real type for the conversion is taken from the target type of ! -- the Round attribute and the result must be marked as rounded. if Target_Type = Universal_Real and then Nkind (Parent (N)) = N_Attribute_Reference *************** package body Exp_Ch4 is *** 7690,7699 **** -- Case of conversions to a fixed-point type ! -- These conversions require special expansion and processing, found ! -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK ! -- is set, since from a semantic point of view, these are simple ! -- integer conversions, which do not need further processing. elsif Is_Fixed_Point_Type (Target_Type) and then not Conversion_OK (N) --- 7886,7895 ---- -- Case of conversions to a fixed-point type ! -- These conversions require special expansion and processing, found in ! -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set, ! -- since from a semantic point of view, these are simple integer ! -- conversions, which do not need further processing. elsif Is_Fixed_Point_Type (Target_Type) and then not Conversion_OK (N) *************** package body Exp_Ch4 is *** 7745,7753 **** -- Case of array conversions ! -- Expansion of array conversions, add required length/range checks ! -- but only do this if there is no change of representation. For ! -- handling of this case, see Handle_Changed_Representation. elsif Is_Array_Type (Target_Type) then --- 7941,7949 ---- -- Case of array conversions ! -- Expansion of array conversions, add required length/range checks but ! -- only do this if there is no change of representation. For handling of ! -- this case, see Handle_Changed_Representation. elsif Is_Array_Type (Target_Type) then *************** package body Exp_Ch4 is *** 7761,7768 **** -- Case of conversions of discriminated types ! -- Add required discriminant checks if target is constrained. Again ! -- this change is skipped if we have a change of representation. elsif Has_Discriminants (Target_Type) and then Is_Constrained (Target_Type) --- 7957,7964 ---- -- Case of conversions of discriminated types ! -- Add required discriminant checks if target is constrained. Again this ! -- change is skipped if we have a change of representation. elsif Has_Discriminants (Target_Type) and then Is_Constrained (Target_Type) *************** package body Exp_Ch4 is *** 7777,7784 **** elsif Is_Record_Type (Target_Type) then -- Ada 2005 (AI-216): Program_Error is raised when converting from ! -- a derived Unchecked_Union type to an unconstrained non-Unchecked_ ! -- Union type if the operand lacks inferable discriminants. if Is_Derived_Type (Operand_Type) and then Is_Unchecked_Union (Base_Type (Operand_Type)) --- 7973,7980 ---- elsif Is_Record_Type (Target_Type) then -- Ada 2005 (AI-216): Program_Error is raised when converting from ! -- a derived Unchecked_Union type to an unconstrained type that is ! -- not Unchecked_Union if the operand lacks inferable discriminants. if Is_Derived_Type (Operand_Type) and then Is_Unchecked_Union (Base_Type (Operand_Type)) *************** package body Exp_Ch4 is *** 7786,7792 **** and then not Is_Unchecked_Union (Base_Type (Target_Type)) and then not Has_Inferable_Discriminants (Operand) then ! -- To prevent Gigi from generating illegal code, we make a -- Program_Error node, but we give it the target type of the -- conversion. --- 7982,7988 ---- and then not Is_Unchecked_Union (Base_Type (Target_Type)) and then not Has_Inferable_Discriminants (Operand) then ! -- To prevent Gigi from generating illegal code, we generate a -- Program_Error node, but we give it the target type of the -- conversion. *************** package body Exp_Ch4 is *** 7833,7857 **** Real_Range_Check; end if; ! -- At this stage, either the conversion node has been transformed ! -- into some other equivalent expression, or left as a conversion ! -- that can be handled by Gigi. The conversions that Gigi can handle ! -- are the following: -- Conversions with no change of representation or type ! -- Numeric conversions involving integer values, floating-point ! -- values, and fixed-point values. Fixed-point values are allowed ! -- only if Conversion_OK is set, i.e. if the fixed-point values ! -- are to be treated as integers. -- No other conversions should be passed to Gigi -- Check: are these rules stated in sinfo??? if so, why restate here??? ! -- The only remaining step is to generate a range check if we still ! -- have a type conversion at this stage and Do_Range_Check is set. ! -- For now we do this only for conversions of discrete types. if Nkind (N) = N_Type_Conversion and then Is_Discrete_Type (Etype (N)) --- 8029,8052 ---- Real_Range_Check; end if; ! -- At this stage, either the conversion node has been transformed into ! -- some other equivalent expression, or left as a conversion that can ! -- be handled by Gigi. The conversions that Gigi can handle are the ! -- following: -- Conversions with no change of representation or type ! -- Numeric conversions involving integer, floating- and fixed-point ! -- values. Fixed-point values are allowed only if Conversion_OK is ! -- set, i.e. if the fixed-point values are to be treated as integers. -- No other conversions should be passed to Gigi -- Check: are these rules stated in sinfo??? if so, why restate here??? ! -- The only remaining step is to generate a range check if we still have ! -- a type conversion at this stage and Do_Range_Check is set. For now we ! -- do this only for conversions of discrete types. if Nkind (N) = N_Type_Conversion and then Is_Discrete_Type (Etype (N)) *************** package body Exp_Ch4 is *** 7867,7875 **** then Set_Do_Range_Check (Expr, False); ! -- Before we do a range check, we have to deal with treating ! -- a fixed-point operand as an integer. The way we do this ! -- is simply to do an unchecked conversion to an appropriate -- integer type large enough to hold the result. -- This code is not active yet, because we are only dealing --- 8062,8070 ---- then Set_Do_Range_Check (Expr, False); ! -- Before we do a range check, we have to deal with treating a ! -- fixed-point operand as an integer. The way we do this is ! -- simply to do an unchecked conversion to an appropriate -- integer type large enough to hold the result. -- This code is not active yet, because we are only dealing *************** package body Exp_Ch4 is *** 7890,7897 **** end if; -- Reset overflow flag, since the range check will include ! -- dealing with possible overflow, and generate the check ! -- If Address is either source or target type, suppress -- range check to avoid typing anomalies when it is a visible -- integer type. --- 8085,8092 ---- end if; -- Reset overflow flag, since the range check will include ! -- dealing with possible overflow, and generate the check If ! -- Address is either a source type or target type, suppress -- range check to avoid typing anomalies when it is a visible -- integer type. *************** package body Exp_Ch4 is *** 7938,7945 **** -- Expand_N_Unchecked_Type_Conversion -- ---------------------------------------- ! -- If this cannot be handled by Gigi and we haven't already made ! -- a temporary for it, do it now. procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is Target_Type : constant Entity_Id := Etype (N); --- 8133,8140 ---- -- Expand_N_Unchecked_Type_Conversion -- ---------------------------------------- ! -- If this cannot be handled by Gigi and we haven't already made a ! -- temporary for it, do it now. procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is Target_Type : constant Entity_Id := Etype (N); *************** package body Exp_Ch4 is *** 7982,7990 **** then Rewrite (N, Make_Integer_Literal (Sloc (N), Val)); ! -- If Address is the target type, just set the type ! -- to avoid a spurious type error on the literal when ! -- Address is a visible integer type. if Is_Descendent_Of_Address (Target_Type) then Set_Etype (N, Target_Type); --- 8177,8185 ---- then Rewrite (N, Make_Integer_Literal (Sloc (N), Val)); ! -- If Address is the target type, just set the type to avoid a ! -- spurious type error on the literal when Address is a visible ! -- integer type. if Is_Descendent_Of_Address (Target_Type) then Set_Etype (N, Target_Type); *************** package body Exp_Ch4 is *** 8202,8208 **** -- chain. The Final_Chain that is thus created is shared by the -- access parameter. The access type is tested against the result -- type of the function to exclude allocators whose type is an ! -- anonymous access result type. if Nkind (Associated_Node_For_Itype (PtrT)) in N_Subprogram_Specification --- 8397,8405 ---- -- chain. The Final_Chain that is thus created is shared by the -- access parameter. The access type is tested against the result -- type of the function to exclude allocators whose type is an ! -- anonymous access result type. We freeze the type at once to ! -- ensure that it is properly decorated for the back-end, even ! -- if the context and current scope is a loop. if Nkind (Associated_Node_For_Itype (PtrT)) in N_Subprogram_Specification *************** package body Exp_Ch4 is *** 8219,8224 **** --- 8416,8422 ---- Subtype_Indication => New_Occurrence_Of (T, Loc)))); + Freeze_Before (N, Owner); Build_Final_List (N, Owner); Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner)); *************** package body Exp_Ch4 is *** 8280,8286 **** -- Start of processing for Has_Inferable_Discriminants begin ! -- For identifiers and indexed components, it is sufficent to have a -- constrained Unchecked_Union nominal subtype. if Nkind_In (N, N_Identifier, N_Indexed_Component) then --- 8478,8484 ---- -- Start of processing for Has_Inferable_Discriminants begin ! -- For identifiers and indexed components, it is sufficient to have a -- constrained Unchecked_Union nominal subtype. if Nkind_In (N, N_Identifier, N_Indexed_Component) then *************** package body Exp_Ch4 is *** 8388,8398 **** New_Reference_To (Pool, Loc), ! -- Storage_Address. We use the attribute Pool_Address, ! -- which uses the pointer itself to find the address of ! -- the object, and which handles unconstrained arrays ! -- properly by computing the address of the template. ! -- i.e. the correct address of the corresponding allocation. Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr_Move_Checks (N), --- 8586,8596 ---- New_Reference_To (Pool, Loc), ! -- Storage_Address. We use the attribute Pool_Address, which uses ! -- the pointer itself to find the address of the object, and which ! -- handles unconstrained arrays properly by computing the address ! -- of the template. i.e. the correct address of the corresponding ! -- allocation. Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr_Move_Checks (N), *************** package body Exp_Ch4 is *** 8685,8692 **** -- Make_Boolean_Array_Op -- --------------------------- ! -- For logical operations on boolean arrays, expand in line the ! -- following, replacing 'and' with 'or' or 'xor' where needed: -- function Annn (A : typ; B: typ) return typ is -- C : typ; --- 8883,8890 ---- -- Make_Boolean_Array_Op -- --------------------------- ! -- For logical operations on boolean arrays, expand in line the following, ! -- replacing 'and' with 'or' or 'xor' where needed: -- function Annn (A : typ; B: typ) return typ is -- C : typ; *************** package body Exp_Ch4 is *** 8829,8835 **** Op1 : constant Node_Id := Left_Opnd (N); Op2 : constant Node_Id := Right_Opnd (N); ! Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2); -- Res indicates if compare outcome can be compile time determined True_Result : Boolean; --- 9027,9034 ---- Op1 : constant Node_Id := Left_Opnd (N); Op2 : constant Node_Id := Right_Opnd (N); ! Res : constant Compare_Result := ! Compile_Time_Compare (Op1, Op2, Assume_Valid => True); -- Res indicates if compare outcome can be compile time determined True_Result : Boolean; *************** package body Exp_Ch4 is *** 8850,8857 **** and then Comes_From_Source (Original_Node (N)) and then Nkind (Original_Node (N)) = N_Op_Ge and then not In_Instance - and then not Warnings_Off (Etype (Left_Opnd (N))) and then Is_Integer_Type (Etype (Left_Opnd (N))) then Error_Msg_N ("can never be greater than, could replace by ""'=""?", N); --- 9049,9056 ---- and then Comes_From_Source (Original_Node (N)) and then Nkind (Original_Node (N)) = N_Op_Ge and then not In_Instance and then Is_Integer_Type (Etype (Left_Opnd (N))) + and then not Has_Warnings_Off (Etype (Left_Opnd (N))) then Error_Msg_N ("can never be greater than, could replace by ""'=""?", N); *************** package body Exp_Ch4 is *** 8874,8881 **** and then Comes_From_Source (Original_Node (N)) and then Nkind (Original_Node (N)) = N_Op_Le and then not In_Instance - and then not Warnings_Off (Etype (Left_Opnd (N))) and then Is_Integer_Type (Etype (Left_Opnd (N))) then Error_Msg_N ("can never be less than, could replace by ""'=""?", N); --- 9073,9080 ---- and then Comes_From_Source (Original_Node (N)) and then Nkind (Original_Node (N)) = N_Op_Le and then not In_Instance and then Is_Integer_Type (Etype (Left_Opnd (N))) + and then not Has_Warnings_Off (Etype (Left_Opnd (N))) then Error_Msg_N ("can never be less than, could replace by ""'=""?", N); *************** package body Exp_Ch4 is *** 8965,8973 **** -- Start of processing for Is_Safe_In_Place_Array_Op begin ! -- We skip this processing if the component size is not the ! -- same as a system storage unit (since at least for NOT ! -- this would cause problems). if Component_Size (Etype (Lhs)) /= System_Storage_Unit then return False; --- 9164,9171 ---- -- Start of processing for Is_Safe_In_Place_Array_Op begin ! -- Skip this processing if the component size is different from system ! -- storage unit (since at least for NOT this would cause problems). if Component_Size (Etype (Lhs)) /= System_Storage_Unit then return False; *************** package body Exp_Ch4 is *** 8997,9011 **** -- Tagged_Membership -- ----------------------- ! -- There are two different cases to consider depending on whether ! -- the right operand is a class-wide type or not. If not we just ! -- compare the actual tag of the left expr to the target type tag: -- -- Left_Expr.Tag = Right_Type'Tag; -- ! -- If it is a class-wide type we use the RT function CW_Membership which ! -- is usually implemented by looking in the ancestor tables contained in ! -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT -- function IW_Membership which is usually implemented by looking in the --- 9195,9209 ---- -- Tagged_Membership -- ----------------------- ! -- There are two different cases to consider depending on whether the right ! -- operand is a class-wide type or not. If not we just compare the actual ! -- tag of the left expr to the target type tag: -- -- Left_Expr.Tag = Right_Type'Tag; -- ! -- If it is a class-wide type we use the RT function CW_Membership which is ! -- usually implemented by looking in the ancestor tables contained in the ! -- dispatch table pointed by Left_Expr.Tag for Typ'Tag -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT -- function IW_Membership which is usually implemented by looking in the *************** package body Exp_Ch4 is *** 9061,9067 **** -- Obj1 in Iface'Class; -- Compile time error if not Is_Class_Wide_Type (Left_Type) ! and then (Is_Parent (Etype (Right_Type), Left_Type) or else (Is_Interface (Etype (Right_Type)) and then Interface_Present_In_Ancestor (Typ => Left_Type, --- 9259,9265 ---- -- Obj1 in Iface'Class; -- Compile time error if not Is_Class_Wide_Type (Left_Type) ! and then (Is_Ancestor (Etype (Right_Type), Left_Type) or else (Is_Interface (Etype (Right_Type)) and then Interface_Present_In_Ancestor (Typ => Left_Type, *************** package body Exp_Ch4 is *** 9082,9088 **** -- configurable run time setting. if not RTE_Available (RE_IW_Membership) then ! Error_Msg_CRT ("abstract interface types", N); return Empty; end if; --- 9280,9287 ---- -- configurable run time setting. if not RTE_Available (RE_IW_Membership) then ! Error_Msg_CRT ! ("dynamic membership test on interface types", N); return Empty; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch4.ads gcc-4.4.0/gcc/ada/exp_ch4.ads *** gcc-4.3.3/gcc/ada/exp_ch4.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_ch4.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Exp_Ch4 is *** 84,91 **** -- Lhs, Rhs are the record expressions to be compared, these -- expressions need not to be analyzed but have to be side-effect free. -- Bodies is a list on which to attach bodies of local functions that ! -- are created in the process. This is the responsability of the caller ! -- to insert those bodies at the right place. Nod provdies the Sloc -- value for generated code. end Exp_Ch4; --- 84,91 ---- -- Lhs, Rhs are the record expressions to be compared, these -- expressions need not to be analyzed but have to be side-effect free. -- Bodies is a list on which to attach bodies of local functions that ! -- are created in the process. This is the responsibility of the caller ! -- to insert those bodies at the right place. Nod provides the Sloc -- value for generated code. end Exp_Ch4; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch5.adb gcc-4.4.0/gcc/ada/exp_ch5.adb *** gcc-4.3.3/gcc/ada/exp_ch5.adb Thu Dec 13 10:25:14 2007 --- gcc-4.4.0/gcc/ada/exp_ch5.adb Fri Aug 22 13:27:35 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Exp_Ch5 is *** 109,121 **** -- statements. procedure Expand_Simple_Function_Return (N : Node_Id); ! -- Expand simple return from function. Called by ! -- Expand_N_Simple_Return_Statement in case we're returning from a function ! -- body. function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id; -- Generate the necessary code for controlled and tagged assignment, ! -- that is to say, finalization of the target before, adjustement of -- the target after and save and restore of the tag and finalization -- pointers which are not 'part of the value' and must not be changed -- upon assignment. N is the original Assignment node. --- 109,120 ---- -- statements. procedure Expand_Simple_Function_Return (N : Node_Id); ! -- Expand simple return from function. In the case where we are returning ! -- from a function body this is called by Expand_N_Simple_Return_Statement. function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id; -- Generate the necessary code for controlled and tagged assignment, ! -- that is to say, finalization of the target before, adjustment of -- the target after and save and restore of the tag and finalization -- pointers which are not 'part of the value' and must not be changed -- upon assignment. N is the original Assignment node. *************** package body Exp_Ch5 is *** 615,624 **** -- or upper bounds at compile time and compare them. else ! Cresult := Compile_Time_Compare (Left_Lo, Right_Lo); if Cresult = Unknown then ! Cresult := Compile_Time_Compare (Left_Hi, Right_Hi); end if; case Cresult is --- 614,627 ---- -- or upper bounds at compile time and compare them. else ! Cresult := ! Compile_Time_Compare ! (Left_Lo, Right_Lo, Assume_Valid => True); if Cresult = Unknown then ! Cresult := ! Compile_Time_Compare ! (Left_Hi, Right_Hi, Assume_Valid => True); end if; case Cresult is *************** package body Exp_Ch5 is *** 729,742 **** -- Cases where either Forwards_OK or Backwards_OK is true if Forwards_OK (N) or else Backwards_OK (N) then ! if Controlled_Type (Component_Type (L_Type)) and then Base_Type (L_Type) = Base_Type (R_Type) and then Ndim = 1 and then not No_Ctrl_Actions (N) then declare ! Proc : constant Entity_Id := ! TSS (Base_Type (L_Type), TSS_Slice_Assign); Actuals : List_Id; begin --- 732,745 ---- -- Cases where either Forwards_OK or Backwards_OK is true if Forwards_OK (N) or else Backwards_OK (N) then ! if Needs_Finalization (Component_Type (L_Type)) and then Base_Type (L_Type) = Base_Type (R_Type) and then Ndim = 1 and then not No_Ctrl_Actions (N) then declare ! Proc : constant Entity_Id := ! TSS (Base_Type (L_Type), TSS_Slice_Assign); Actuals : List_Id; begin *************** package body Exp_Ch5 is *** 805,811 **** Ensure_Defined (R_Type, N); -- We normally compare addresses to find out which way round to ! -- do the loop, since this is realiable, and handles the cases of -- parameters, conversions etc. But we can't do that in the bit -- packed case or the VM case, because addresses don't work there. --- 808,814 ---- Ensure_Defined (R_Type, N); -- We normally compare addresses to find out which way round to ! -- do the loop, since this is reliable, and handles the cases of -- parameters, conversions etc. But we can't do that in the bit -- packed case or the VM case, because addresses don't work there. *************** package body Exp_Ch5 is *** 863,879 **** Right_Opnd => Cright_Lo); end if; ! if Controlled_Type (Component_Type (L_Type)) and then Base_Type (L_Type) = Base_Type (R_Type) and then Ndim = 1 and then not No_Ctrl_Actions (N) then ! -- Call TSS procedure for array assignment, passing the the -- explicit bounds of right and left hand sides. declare ! Proc : constant Node_Id := TSS (Base_Type (L_Type), TSS_Slice_Assign); Actuals : List_Id; --- 866,882 ---- Right_Opnd => Cright_Lo); end if; ! if Needs_Finalization (Component_Type (L_Type)) and then Base_Type (L_Type) = Base_Type (R_Type) and then Ndim = 1 and then not No_Ctrl_Actions (N) then ! -- Call TSS procedure for array assignment, passing the -- explicit bounds of right and left hand sides. declare ! Proc : constant Entity_Id := TSS (Base_Type (L_Type), TSS_Slice_Assign); Actuals : List_Id; *************** package body Exp_Ch5 is *** 1346,1358 **** F := First_Discriminant (R_Typ); while Present (F) loop ! if Is_Unchecked_Union (Base_Type (R_Typ)) then ! Insert_Action (N, Make_Field_Assign (F, True)); ! else ! Insert_Action (N, Make_Field_Assign (F)); ! end if; ! Next_Discriminant (F); end loop; end if; --- 1349,1378 ---- F := First_Discriminant (R_Typ); while Present (F) loop ! -- If we are expanding the initialization of a derived record ! -- that constrains or renames discriminants of the parent, we ! -- must use the corresponding discriminant in the parent. ! declare ! CF : Entity_Id; ! ! begin ! if Inside_Init_Proc ! and then Present (Corresponding_Discriminant (F)) ! then ! CF := Corresponding_Discriminant (F); ! else ! CF := F; ! end if; ! ! if Is_Unchecked_Union (Base_Type (R_Typ)) then ! Insert_Action (N, Make_Field_Assign (CF, True)); ! else ! Insert_Action (N, Make_Field_Assign (CF)); ! end if; ! ! Next_Discriminant (F); ! end; end loop; end if; *************** package body Exp_Ch5 is *** 1759,1765 **** return; elsif Is_Tagged_Type (Typ) ! or else (Controlled_Type (Typ) and then not Is_Array_Type (Typ)) then Tagged_Case : declare L : List_Id := No_List; --- 1779,1785 ---- return; elsif Is_Tagged_Type (Typ) ! or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ)) then Tagged_Case : declare L : List_Id := No_List; *************** package body Exp_Ch5 is *** 1789,1797 **** -- discriminant checks are locally suppressed (as in extension -- aggregate expansions) because otherwise the discriminant -- check will be performed within the _assign call. It is also ! -- suppressed for assignmments created by the expander that -- correspond to initializations, where we do want to copy the ! -- tag (No_Ctrl_Actions flag set True). by the expander and we -- do not need to mess with tags ever (Expand_Ctrl_Actions flag -- is set True in this case). --- 1809,1817 ---- -- discriminant checks are locally suppressed (as in extension -- aggregate expansions) because otherwise the discriminant -- check will be performed within the _assign call. It is also ! -- suppressed for assignments created by the expander that -- correspond to initializations, where we do want to copy the ! -- tag (No_Ctrl_Actions flag set True) by the expander and we -- do not need to mess with tags ever (Expand_Ctrl_Actions flag -- is set True in this case). *************** package body Exp_Ch5 is *** 1802,1808 **** and then not Discriminant_Checks_Suppressed (Empty)) then -- Fetch the primitive op _assign and proper type to call it. ! -- Because of possible conflits between private and full view -- the proper type is fetched directly from the operation -- profile. --- 1822,1828 ---- and then not Discriminant_Checks_Suppressed (Empty)) then -- Fetch the primitive op _assign and proper type to call it. ! -- Because of possible conflicts between private and full view -- the proper type is fetched directly from the operation -- profile. *************** package body Exp_Ch5 is *** 1870,1877 **** --- 1890,1900 ---- -- -- end if; + -- Skip this if Restriction (No_Finalization) is active + if not Statically_Different (Lhs, Rhs) and then Expand_Ctrl_Actions + and then not Restriction_Active (No_Finalization) then L := New_List ( Make_Implicit_If_Statement (N, *************** package body Exp_Ch5 is *** 1915,1924 **** Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => L))); ! -- If no restrictions on aborts, protect the whole assignement -- for controlled objects as per 9.8(11). ! if Controlled_Type (Typ) and then Expand_Ctrl_Actions and then Abort_Allowed then --- 1938,1947 ---- Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => L))); ! -- If no restrictions on aborts, protect the whole assignment -- for controlled objects as per 9.8(11). ! if Needs_Finalization (Typ) and then Expand_Ctrl_Actions and then Abort_Allowed then *************** package body Exp_Ch5 is *** 2201,2207 **** -- An optimization. If there are only two alternatives, and only -- a single choice, then rewrite the whole case statement as an ! -- if statement, since this can result in susbequent optimizations. -- This helps not only with case statements in the source of a -- simple form, but also with generated code (discriminant check -- functions in particular) --- 2224,2230 ---- -- An optimization. If there are only two alternatives, and only -- a single choice, then rewrite the whole case statement as an ! -- if statement, since this can result in subsequent optimizations. -- This helps not only with case statements in the source of a -- simple form, but also with generated code (discriminant check -- functions in particular) *************** package body Exp_Ch5 is *** 2352,2357 **** --- 2375,2381 ---- Parent (Return_Object_Entity); Parent_Function : constant Entity_Id := Return_Applies_To (Return_Statement_Entity (N)); + Parent_Function_Typ : constant Entity_Id := Etype (Parent_Function); Is_Build_In_Place : constant Boolean := Is_Build_In_Place_Function (Parent_Function); *************** package body Exp_Ch5 is *** 2361,2366 **** --- 2385,2394 ---- Result : Node_Id; Exp : Node_Id; + function Has_Controlled_Parts (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ is controlled or contains a controlled + -- subcomponent. + function Move_Activation_Chain return Node_Id; -- Construct a call to System.Tasking.Stages.Move_Activation_Chain -- with parameters: *************** package body Exp_Ch5 is *** 2375,2380 **** --- 2403,2419 ---- -- From finalization list of the return statement -- To finalization list passed in by the caller + -------------------------- + -- Has_Controlled_Parts -- + -------------------------- + + function Has_Controlled_Parts (Typ : Entity_Id) return Boolean is + begin + return + Is_Controlled (Typ) + or else Has_Controlled_Component (Typ); + end Has_Controlled_Parts; + --------------------------- -- Move_Activation_Chain -- --------------------------- *************** package body Exp_Ch5 is *** 2499,2521 **** -- in the rather obscure case of a select-then-abort statement whose -- abortable part contains the return statement. ! -- We test the type of the expression as well as the return type ! -- of the function, because the latter may be a class-wide type ! -- which is always treated as controlled, while the expression itself ! -- has to have a definite type. The expression may be absent if a ! -- constrained aggregate has been expanded into component assignments ! -- so we have to check for this as well. if Is_Build_In_Place ! and then Controlled_Type (Etype (Parent_Function)) then ! if not Is_Class_Wide_Type (Etype (Parent_Function)) ! or else ! (Present (Exp) ! and then Controlled_Type (Etype (Exp))) ! then ! Append_To (Statements, Move_Final_List); ! end if; end if; -- Similarly to the above Move_Final_List, if the result type --- 2538,2560 ---- -- in the rather obscure case of a select-then-abort statement whose -- abortable part contains the return statement. ! -- Check the type of the function to determine whether to move the ! -- finalization list. A special case arises when processing a simple ! -- return statement which has been rewritten as an extended return. ! -- In that case check the type of the returned object or the original ! -- expression. if Is_Build_In_Place ! and then ! (Has_Controlled_Parts (Parent_Function_Typ) ! or else (Is_Class_Wide_Type (Parent_Function_Typ) ! and then ! Has_Controlled_Parts (Root_Type (Parent_Function_Typ))) ! or else Has_Controlled_Parts (Etype (Return_Object_Entity)) ! or else (Present (Exp) ! and then Has_Controlled_Parts (Etype (Exp)))) then ! Append_To (Statements, Move_Final_List); end if; -- Similarly to the above Move_Final_List, if the result type *************** package body Exp_Ch5 is *** 2792,2797 **** --- 2831,2860 ---- SS_Allocator := New_Copy_Tree (Heap_Allocator); end if; + -- If the No_Allocators restriction is active, then only + -- an allocator for secondary stack allocation is needed. + + if Restriction_Active (No_Allocators) then + SS_Allocator := Heap_Allocator; + Heap_Allocator := Make_Null (Loc); + + -- Otherwise the heap allocator may be needed, so we + -- make another allocator for secondary stack allocation. + + else + SS_Allocator := New_Copy_Tree (Heap_Allocator); + + -- The heap allocator is marked Comes_From_Source + -- since it corresponds to an explicit user-written + -- allocator (that is, it will only be executed on + -- behalf of callers that call the function as + -- initialization for such an allocator). This + -- prevents errors when No_Implicit_Heap_Allocation + -- is in force. + + Set_Comes_From_Source (Heap_Allocator, True); + end if; + -- The allocator is returned on the secondary stack. We -- don't do this on VM targets, since the SS is not used. *************** package body Exp_Ch5 is *** 2887,2893 **** -- implicit access formal to the access object, to ensure -- that the return object is initialized in that case. -- In this situation, the target of the assignment must ! -- be rewritten to denote a derference of the access to -- the return object passed in by the caller. if Present (Init_Assignment) then --- 2950,2956 ---- -- implicit access formal to the access object, to ensure -- that the return object is initialized in that case. -- In this situation, the target of the assignment must ! -- be rewritten to denote a dereference of the access to -- the return object passed in by the caller. if Present (Init_Assignment) then *************** package body Exp_Ch5 is *** 3183,3236 **** -- return not (expression); ! if Nkind (N) = N_If_Statement ! and then No (Elsif_Parts (N)) ! and then Present (Else_Statements (N)) ! and then List_Length (Then_Statements (N)) = 1 ! and then List_Length (Else_Statements (N)) = 1 ! then ! declare ! Then_Stm : constant Node_Id := First (Then_Statements (N)); ! Else_Stm : constant Node_Id := First (Else_Statements (N)); ! begin ! if Nkind (Then_Stm) = N_Simple_Return_Statement ! and then ! Nkind (Else_Stm) = N_Simple_Return_Statement ! then ! declare ! Then_Expr : constant Node_Id := Expression (Then_Stm); ! Else_Expr : constant Node_Id := Expression (Else_Stm); ! begin ! if Nkind (Then_Expr) = N_Identifier ! and then ! Nkind (Else_Expr) = N_Identifier ! then ! if Entity (Then_Expr) = Standard_True ! and then Entity (Else_Expr) = Standard_False ! then ! Rewrite (N, ! Make_Simple_Return_Statement (Loc, ! Expression => Relocate_Node (Condition (N)))); ! Analyze (N); ! return; ! elsif Entity (Then_Expr) = Standard_False ! and then Entity (Else_Expr) = Standard_True then ! Rewrite (N, ! Make_Simple_Return_Statement (Loc, ! Expression => ! Make_Op_Not (Loc, ! Right_Opnd => Relocate_Node (Condition (N))))); ! Analyze (N); ! return; end if; ! end if; ! end; ! end if; ! end; end if; end Expand_N_If_Statement; --- 3246,3304 ---- -- return not (expression); ! -- Only do these optimizations if we are at least at -O1 level ! if Optimization_Level > 0 then ! if Nkind (N) = N_If_Statement ! and then No (Elsif_Parts (N)) ! and then Present (Else_Statements (N)) ! and then List_Length (Then_Statements (N)) = 1 ! and then List_Length (Else_Statements (N)) = 1 ! then ! declare ! Then_Stm : constant Node_Id := First (Then_Statements (N)); ! Else_Stm : constant Node_Id := First (Else_Statements (N)); ! begin ! if Nkind (Then_Stm) = N_Simple_Return_Statement ! and then ! Nkind (Else_Stm) = N_Simple_Return_Statement ! then ! declare ! Then_Expr : constant Node_Id := Expression (Then_Stm); ! Else_Expr : constant Node_Id := Expression (Else_Stm); ! begin ! if Nkind (Then_Expr) = N_Identifier ! and then ! Nkind (Else_Expr) = N_Identifier then ! if Entity (Then_Expr) = Standard_True ! and then Entity (Else_Expr) = Standard_False ! then ! Rewrite (N, ! Make_Simple_Return_Statement (Loc, ! Expression => Relocate_Node (Condition (N)))); ! Analyze (N); ! return; ! ! elsif Entity (Then_Expr) = Standard_False ! and then Entity (Else_Expr) = Standard_True ! then ! Rewrite (N, ! Make_Simple_Return_Statement (Loc, ! Expression => ! Make_Op_Not (Loc, ! Right_Opnd => ! Relocate_Node (Condition (N))))); ! Analyze (N); ! return; ! end if; end if; ! end; ! end if; ! end; ! end if; end if; end Expand_N_If_Statement; *************** package body Exp_Ch5 is *** 3262,3268 **** return; end if; ! -- Note: we do not have to worry about validity chekcing of the for loop -- range bounds here, since they were frozen with constant declarations -- and it is during that process that the validity checking is done. --- 3330,3336 ---- return; end if; ! -- Note: we do not have to worry about validity checking of the for loop -- range bounds here, since they were frozen with constant declarations -- and it is during that process that the validity checking is done. *************** package body Exp_Ch5 is *** 3439,3444 **** --- 3507,3521 ---- procedure Expand_N_Simple_Return_Statement (N : Node_Id) is begin + -- Defend against previous errors (i.e. the return statement calls a + -- function that is not available in configurable runtime). + + if Present (Expression (N)) + and then Nkind (Expression (N)) = N_Empty + then + return; + end if; + -- Distinguish the function and non-function cases: case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is *************** package body Exp_Ch5 is *** 3480,3485 **** --- 3557,3572 ---- Lab_Node : Node_Id; begin + -- Call postconditions procedure if procedure with active postconditions + + if Ekind (Scope_Id) = E_Procedure + and then Has_Postconditions (Scope_Id) + then + Insert_Action (N, + Make_Procedure_Call_Statement (Loc, + Name => Make_Identifier (Loc, Name_uPostconditions))); + end if; + -- If it is a return from a procedure do no extra steps if Kind = E_Procedure or else Kind = E_Generic_Procedure then *************** package body Exp_Ch5 is *** 3548,3563 **** elsif Is_Protected_Type (Scope_Id) then Call := Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To ! (RTE (RE_Complete_Entry_Body), Loc), ! Parameter_Associations => New_List ! (Make_Attribute_Reference (Loc, Prefix => New_Reference_To ! (Object_Ref ! (Corresponding_Body (Parent (Scope_Id))), ! Loc), ! Attribute_Name => Name_Unchecked_Access))); Insert_Before (N, Call); Analyze (Call); --- 3635,3649 ---- elsif Is_Protected_Type (Scope_Id) then Call := Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To (RTE (RE_Complete_Entry_Body), Loc), ! Parameter_Associations => New_List ( ! Make_Attribute_Reference (Loc, Prefix => New_Reference_To ! (Find_Protection_Object (Current_Scope), Loc), ! Attribute_Name => ! Name_Unchecked_Access))); Insert_Before (N, Call); Analyze (Call); *************** package body Exp_Ch5 is *** 3589,3617 **** Exptyp : constant Entity_Id := Etype (Exp); -- The type of the expression (not necessarily the same as R_Type) begin ! -- We rewrite "return ;" to be: -- return _anon_ : := -- The expansion produced by Expand_N_Extended_Return_Statement will -- contain simple return statements (for example, a block containing -- simple return of the return object), which brings us back here with ! -- Comes_From_Extended_Return_Statement set. To avoid infinite ! -- recursion, we do not transform into an extended return if ! -- Comes_From_Extended_Return_Statement is True. -- The reason for this design is that for Ada 2005 limited returns, we -- need to reify the return object, so we can build it "in place", and -- we need a block statement to hang finalization and tasking stuff. -- ??? In order to avoid disruption, we avoid translating to extended ! -- return except in the cases where we really need to (Ada 2005 ! -- inherently limited). We would prefer eventually to do this ! -- translation in all cases except perhaps for the case of Ada 95 ! -- inherently limited, in order to fully exercise the code in ! -- Expand_N_Extended_Return_Statement, and in order to do ! -- build-in-place for efficiency when it is not required. -- As before, we check the type of the return expression rather than the -- return type of the function, because the latter may be a limited --- 3675,3721 ---- Exptyp : constant Entity_Id := Etype (Exp); -- The type of the expression (not necessarily the same as R_Type) + Subtype_Ind : Node_Id; + -- If the result type of the function is class-wide and the + -- expression has a specific type, then we use the expression's + -- type as the type of the return object. In cases where the + -- expression is an aggregate that is built in place, this avoids + -- the need for an expensive conversion of the return object to + -- the specific type on assignments to the individual components. + begin ! if Is_Class_Wide_Type (R_Type) ! and then not Is_Class_Wide_Type (Etype (Exp)) ! then ! Subtype_Ind := New_Occurrence_Of (Etype (Exp), Loc); ! else ! Subtype_Ind := New_Occurrence_Of (R_Type, Loc); ! end if; ! ! -- For the case of a simple return that does not come from an extended ! -- return, in the case of Ada 2005 where we are returning a limited ! -- type, we rewrite "return ;" to be: -- return _anon_ : := -- The expansion produced by Expand_N_Extended_Return_Statement will -- contain simple return statements (for example, a block containing -- simple return of the return object), which brings us back here with ! -- Comes_From_Extended_Return_Statement set. The reason for the barrier ! -- checking for a simple return that does not come from an extended ! -- return is to avoid this infinite recursion. -- The reason for this design is that for Ada 2005 limited returns, we -- need to reify the return object, so we can build it "in place", and -- we need a block statement to hang finalization and tasking stuff. -- ??? In order to avoid disruption, we avoid translating to extended ! -- return except in the cases where we really need to (Ada 2005 for ! -- inherently limited). We might prefer to do this translation in all ! -- cases (except perhaps for the case of Ada 95 inherently limited), ! -- in order to fully exercise the Expand_N_Extended_Return_Statement ! -- code. This would also allow us to do the build-in-place optimization ! -- for efficiency even in cases where it is semantically not required. -- As before, we check the type of the return expression rather than the -- return type of the function, because the latter may be a limited *************** package body Exp_Ch5 is *** 3620,3635 **** if not Comes_From_Extended_Return_Statement (N) and then Is_Inherently_Limited_Type (Etype (Expression (N))) ! and then Ada_Version >= Ada_05 -- ??? and then not Debug_Flag_Dot_L then declare Return_Object_Entity : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - - Subtype_Ind : constant Node_Id := New_Occurrence_Of (R_Type, Loc); - Obj_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Return_Object_Entity, --- 3724,3736 ---- if not Comes_From_Extended_Return_Statement (N) and then Is_Inherently_Limited_Type (Etype (Expression (N))) ! and then Ada_Version >= Ada_05 and then not Debug_Flag_Dot_L then declare Return_Object_Entity : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); Obj_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Return_Object_Entity, *************** package body Exp_Ch5 is *** 3638,3643 **** --- 3739,3746 ---- Ext : constant Node_Id := Make_Extended_Return_Statement (Loc, Return_Object_Declarations => New_List (Obj_Decl)); + -- Do not perform this high-level optimization if the result type + -- is an interface because the "this" pointer must be displaced. begin Rewrite (N, Ext); *************** package body Exp_Ch5 is *** 3751,3757 **** and then (not Is_Array_Type (Exptyp) or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) ! or else CW_Or_Controlled_Type (Utyp)) and then Nkind (Exp) = N_Function_Call then Set_By_Ref (N); --- 3854,3860 ---- and then (not Is_Array_Type (Exptyp) or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) ! or else CW_Or_Has_Controlled_Part (Utyp)) and then Nkind (Exp) = N_Function_Call then Set_By_Ref (N); *************** package body Exp_Ch5 is *** 3774,3780 **** -- controlled (by the virtue of restriction No_Finalization) because -- gigi is not able to properly allocate class-wide types. ! elsif CW_Or_Controlled_Type (Utyp) then declare Loc : constant Source_Ptr := Sloc (N); Temp : constant Entity_Id := --- 3877,3883 ---- -- controlled (by the virtue of restriction No_Finalization) because -- gigi is not able to properly allocate class-wide types. ! elsif CW_Or_Has_Controlled_Part (Utyp) then declare Loc : constant Source_Ptr := Sloc (N); Temp : constant Entity_Id := *************** package body Exp_Ch5 is *** 3797,3809 **** Subtype_Mark => New_Reference_To (Etype (Exp), Loc), Expression => Relocate_Node (Exp))); Insert_List_Before_And_Analyze (N, New_List ( Make_Full_Type_Declaration (Loc, Defining_Identifier => Acc_Typ, Type_Definition => Make_Access_To_Object_Definition (Loc, ! Subtype_Indication => ! New_Reference_To (R_Type, Loc))), Make_Object_Declaration (Loc, Defining_Identifier => Temp, --- 3900,3916 ---- Subtype_Mark => New_Reference_To (Etype (Exp), Loc), Expression => Relocate_Node (Exp))); + -- We do not want discriminant checks on the declaration, + -- given that it gets its value from the allocator. + + Set_No_Initialization (Alloc_Node); + Insert_List_Before_And_Analyze (N, New_List ( Make_Full_Type_Declaration (Loc, Defining_Identifier => Acc_Typ, Type_Definition => Make_Access_To_Object_Definition (Loc, ! Subtype_Indication => Subtype_Ind)), Make_Object_Declaration (Loc, Defining_Identifier => Temp, *************** package body Exp_Ch5 is *** 3821,3827 **** -- secondary stack. else ! Set_Storage_Pool (N, RTE (RE_SS_Pool)); -- If we are generating code for the VM do not use -- SS_Allocate since everything is heap-allocated anyway. --- 3928,3935 ---- -- secondary stack. else ! Check_Restriction (No_Secondary_Stack, N); ! Set_Storage_Pool (N, RTE (RE_SS_Pool)); -- If we are generating code for the VM do not use -- SS_Allocate since everything is heap-allocated anyway. *************** package body Exp_Ch5 is *** 3963,3968 **** --- 4071,4219 ---- Reason => PE_Accessibility_Check_Failed)); end; end if; + + -- If we are returning an object that may not be bit-aligned, then + -- copy the value into a temporary first. This copy may need to expand + -- to a loop of component operations.. + + if Is_Possibly_Unaligned_Slice (Exp) + or else Is_Possibly_Unaligned_Object (Exp) + then + declare + Tnn : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + begin + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (R_Type, Loc), + Expression => Relocate_Node (Exp)), + Suppress => All_Checks); + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + end; + end if; + + -- Generate call to postcondition checks if they are present + + if Ekind (Scope_Id) = E_Function + and then Has_Postconditions (Scope_Id) + then + -- We are going to reference the returned value twice in this case, + -- once in the call to _Postconditions, and once in the actual return + -- statement, but we can't have side effects happening twice, and in + -- any case for efficiency we don't want to do the computation twice. + + -- If the returned expression is an entity name, we don't need to + -- worry since it is efficient and safe to reference it twice, that's + -- also true for literals other than string literals, and for the + -- case of X.all where X is an entity name. + + if Is_Entity_Name (Exp) + or else Nkind_In (Exp, N_Character_Literal, + N_Integer_Literal, + N_Real_Literal) + or else (Nkind (Exp) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Exp))) + then + null; + + -- Otherwise we are going to need a temporary to capture the value + + else + declare + Tnn : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + + begin + -- For a complex expression of an elementary type, capture + -- value in the temporary and use it as the reference. + + if Is_Elementary_Type (R_Type) then + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (R_Type, Loc), + Expression => Relocate_Node (Exp)), + Suppress => All_Checks); + + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + + -- If we have something we can rename, generate a renaming of + -- the object and replace the expression with a reference + + elsif Is_Object_Reference (Exp) then + Insert_Action (Exp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Tnn, + Subtype_Mark => New_Occurrence_Of (R_Type, Loc), + Name => Relocate_Node (Exp)), + Suppress => All_Checks); + + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + + -- Otherwise we have something like a string literal or an + -- aggregate. We could copy the value, but that would be + -- inefficient. Instead we make a reference to the value and + -- capture this reference with a renaming, the expression is + -- then replaced by a dereference of this renaming. + + else + -- For now, copy the value, since the code below does not + -- seem to work correctly ??? + + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (R_Type, Loc), + Expression => Relocate_Node (Exp)), + Suppress => All_Checks); + + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + + -- Insert_Action (Exp, + -- Make_Object_Renaming_Declaration (Loc, + -- Defining_Identifier => Tnn, + -- Access_Definition => + -- Make_Access_Definition (Loc, + -- All_Present => True, + -- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)), + -- Name => + -- Make_Reference (Loc, + -- Prefix => Relocate_Node (Exp))), + -- Suppress => All_Checks); + + -- Rewrite (Exp, + -- Make_Explicit_Dereference (Loc, + -- Prefix => New_Occurrence_Of (Tnn, Loc))); + end if; + end; + end if; + + -- Generate call to _postconditions + + Insert_Action (Exp, + Make_Procedure_Call_Statement (Loc, + Name => Make_Identifier (Loc, Name_uPostconditions), + Parameter_Associations => New_List (Duplicate_Subexpr (Exp)))); + end if; + + -- Ada 2005 (AI-251): If this return statement corresponds with an + -- simple return statement associated with an extended return statement + -- and the type of the returned object is an interface then generate an + -- implicit conversion to force displacement of the "this" pointer. + + if Ada_Version >= Ada_05 + and then Comes_From_Extended_Return_Statement (N) + and then Nkind (Expression (N)) = N_Identifier + and then Is_Interface (Utyp) + and then Utyp /= Underlying_Type (Exptyp) + then + Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp); + end if; end Expand_Simple_Function_Return; ------------------------------ *************** package body Exp_Ch5 is *** 3974,3980 **** L : constant Node_Id := Name (N); T : constant Entity_Id := Underlying_Type (Etype (L)); ! Ctrl_Act : constant Boolean := Controlled_Type (T) and then not No_Ctrl_Actions (N); Save_Tag : constant Boolean := Is_Tagged_Type (T) --- 4225,4231 ---- L : constant Node_Id := Name (N); T : constant Entity_Id := Underlying_Type (Etype (L)); ! Ctrl_Act : constant Boolean := Needs_Finalization (T) and then not No_Ctrl_Actions (N); Save_Tag : constant Boolean := Is_Tagged_Type (T) *************** package body Exp_Ch5 is *** 4011,4023 **** if not Ctrl_Act then null; ! -- The left hand side is an uninitialized temporary elsif Nkind (L) = N_Type_Conversion and then Is_Entity_Name (Expression (L)) and then No_Initialization (Parent (Entity (Expression (L)))) then null; else Append_List_To (Res, Make_Final_Call ( --- 4262,4277 ---- if not Ctrl_Act then null; ! -- The left hand side is an uninitialized temporary object elsif Nkind (L) = N_Type_Conversion and then Is_Entity_Name (Expression (L)) + and then Nkind (Parent (Entity (Expression (L)))) + = N_Object_Declaration and then No_Initialization (Parent (Entity (Expression (L)))) then null; + else Append_List_To (Res, Make_Final_Call ( diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch6.adb gcc-4.4.0/gcc/ada/exp_ch6.adb *** gcc-4.3.3/gcc/ada/exp_ch6.adb Thu Dec 13 10:22:06 2007 --- gcc-4.4.0/gcc/ada/exp_ch6.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Exp_Intr; use Exp_Intr; *** 41,46 **** --- 41,47 ---- with Exp_Pakd; use Exp_Pakd; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; + with Exp_VFpt; use Exp_VFpt; with Fname; use Fname; with Freeze; use Freeze; with Inline; use Inline; *************** package body Exp_Ch6 is *** 110,122 **** procedure Add_Final_List_Actual_To_Build_In_Place_Call (Function_Call : Node_Id; Function_Id : Entity_Id; ! Acc_Type : Entity_Id); -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has -- controlled parts, add an actual parameter that is a pointer to -- appropriate finalization list. The finalization list is that of the -- current scope, except for "new Acc'(F(...))" in which case it's the -- finalization list of the access type returned by the allocator. Acc_Type ! -- is that type in the allocator case; Empty otherwise. procedure Add_Task_Actuals_To_Build_In_Place_Call (Function_Call : Node_Id; --- 111,126 ---- procedure Add_Final_List_Actual_To_Build_In_Place_Call (Function_Call : Node_Id; Function_Id : Entity_Id; ! Acc_Type : Entity_Id; ! Sel_Comp : Node_Id := Empty); -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has -- controlled parts, add an actual parameter that is a pointer to -- appropriate finalization list. The finalization list is that of the -- current scope, except for "new Acc'(F(...))" in which case it's the -- finalization list of the access type returned by the allocator. Acc_Type ! -- is that type in the allocator case; Empty otherwise. If Sel_Comp is ! -- not Empty, then it denotes a selected component and the finalization ! -- list is obtained from the _controller list of the prefix object. procedure Add_Task_Actuals_To_Build_In_Place_Call (Function_Call : Node_Id; *************** package body Exp_Ch6 is *** 379,403 **** procedure Add_Final_List_Actual_To_Build_In_Place_Call (Function_Call : Node_Id; Function_Id : Entity_Id; ! Acc_Type : Entity_Id) is Loc : constant Source_Ptr := Sloc (Function_Call); Final_List : Node_Id; Final_List_Actual : Node_Id; Final_List_Formal : Node_Id; begin -- No such extra parameter is needed if there are no controlled parts. ! -- The test for Controlled_Type accounts for class-wide results (which ! -- potentially have controlled parts, even if the root type doesn't), ! -- and the test for a tagged result type is needed because calls to ! -- such a function can in general occur in dispatching contexts, which ! -- must be treated the same as a call to class-wide functions. Both of ! -- these situations require that a finalization list be passed. ! if not Controlled_Type (Underlying_Type (Etype (Function_Id))) ! and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id))) ! then return; end if; --- 383,410 ---- procedure Add_Final_List_Actual_To_Build_In_Place_Call (Function_Call : Node_Id; Function_Id : Entity_Id; ! Acc_Type : Entity_Id; ! Sel_Comp : Node_Id := Empty) is Loc : constant Source_Ptr := Sloc (Function_Call); Final_List : Node_Id; Final_List_Actual : Node_Id; Final_List_Formal : Node_Id; + Is_Ctrl_Result : constant Boolean := + Needs_Finalization + (Underlying_Type (Etype (Function_Id))); begin -- No such extra parameter is needed if there are no controlled parts. ! -- The test for Needs_Finalization accounts for class-wide results ! -- (which potentially have controlled parts, even if the root type ! -- doesn't), and the test for a tagged result type is needed because ! -- calls to such a function can in general occur in dispatching ! -- contexts, which must be treated the same as a call to class-wide ! -- functions. Both of these situations require that a finalization list ! -- be passed. ! if not Needs_BIP_Final_List (Function_Id) then return; end if; *************** package body Exp_Ch6 is *** 416,421 **** --- 423,436 ---- Present (Associated_Final_Chain (Base_Type (Acc_Type)))) then Final_List := Find_Final_List (Acc_Type); + + -- If Sel_Comp is present and the function result is controlled, then + -- the finalization list will be obtained from the _controller list of + -- the selected component's prefix object. + + elsif Present (Sel_Comp) and then Is_Ctrl_Result then + Final_List := Find_Final_List (Current_Scope, Sel_Comp); + else Final_List := Find_Final_List (Current_Scope); end if; *************** package body Exp_Ch6 is *** 1016,1022 **** Low_Bound => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Var, Loc), ! Attribute_name => Name_First), High_Bound => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Var, Loc), --- 1031,1037 ---- Low_Bound => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Var, Loc), ! Attribute_Name => Name_First), High_Bound => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Var, Loc), *************** package body Exp_Ch6 is *** 1541,1548 **** -- formal subtype are not the same, requiring a check. -- It is necessary to exclude tagged types because of "downward ! -- conversion" errors and a strange assertion error in namet ! -- from gnatf in bug 1215-001 ??? elsif Is_Access_Type (E_Formal) and then not Same_Type (E_Formal, Etype (Actual)) --- 1556,1562 ---- -- formal subtype are not the same, requiring a check. -- It is necessary to exclude tagged types because of "downward ! -- conversion" errors. elsif Is_Access_Type (E_Formal) and then not Same_Type (E_Formal, Etype (Actual)) *************** package body Exp_Ch6 is *** 1662,1670 **** -- This procedure handles expansion of function calls and procedure call -- statements (i.e. it serves as the body for Expand_N_Function_Call and ! -- Expand_N_Procedure_Call_Statement. Processing for calls includes: ! -- Replace call to Raise_Exception by Raise_Exception always if possible -- Provide values of actuals for all formals in Extra_Formals list -- Replace "call" to enumeration literal function by literal itself -- Rewrite call to predefined operator as operator --- 1676,1684 ---- -- This procedure handles expansion of function calls and procedure call -- statements (i.e. it serves as the body for Expand_N_Function_Call and ! -- Expand_N_Procedure_Call_Statement). Processing for calls includes: ! -- Replace call to Raise_Exception by Raise_Exception_Always if possible -- Provide values of actuals for all formals in Extra_Formals list -- Replace "call" to enumeration literal function by literal itself -- Rewrite call to predefined operator as operator *************** package body Exp_Ch6 is *** 1694,1705 **** function Inherited_From_Formal (S : Entity_Id) return Entity_Id; -- Within an instance, a type derived from a non-tagged formal derived ! -- type inherits from the original parent, not from the actual. This is ! -- tested in 4723-003. The current derivation mechanism has the derived ! -- type inherit from the actual, which is only correct outside of the ! -- instance. If the subprogram is inherited, we test for this particular ! -- case through a convoluted tree traversal before setting the proper ! -- subprogram to be called. -------------------------- -- Add_Actual_Parameter -- --- 1708,1719 ---- function Inherited_From_Formal (S : Entity_Id) return Entity_Id; -- Within an instance, a type derived from a non-tagged formal derived ! -- type inherits from the original parent, not from the actual. The ! -- current derivation mechanism has the derived type inherit from the ! -- actual, which is only correct outside of the instance. If the ! -- subprogram is inherited, we test for this particular case through a ! -- convoluted tree traversal before setting the proper subprogram to be ! -- called. -------------------------- -- Add_Actual_Parameter -- *************** package body Exp_Ch6 is *** 1919,1929 **** -- Replace call to Raise_Exception by call to Raise_Exception_Always -- if we can tell that the first parameter cannot possibly be null. ! -- This helps optimization and also generation of warnings. -- We do not do this if Raise_Exception_Always does not exist, which -- can happen in configurable run time profiles which provide only a ! -- Raise_Exception, which is in fact an unconditional raise anyway. if Is_RTE (Subp, RE_Raise_Exception) and then RTE_Available (RE_Raise_Exception_Always) --- 1933,1943 ---- -- Replace call to Raise_Exception by call to Raise_Exception_Always -- if we can tell that the first parameter cannot possibly be null. ! -- This improves efficiency by avoiding a run-time test. -- We do not do this if Raise_Exception_Always does not exist, which -- can happen in configurable run time profiles which provide only a ! -- Raise_Exception. if Is_RTE (Subp, RE_Raise_Exception) and then RTE_Available (RE_Raise_Exception_Always) *************** package body Exp_Ch6 is *** 2019,2033 **** Prev := Actual; Prev_Orig := Original_Node (Prev); - -- The original actual may have been a call written in prefix - -- form, and rewritten before analysis. - - if not Analyzed (Prev_Orig) - and then Nkind_In (Actual, N_Function_Call, N_Identifier) - then - Prev_Orig := Prev; - end if; - -- Ada 2005 (AI-251): Check if any formal is a class-wide interface -- to expand it in a further round. --- 2033,2038 ---- *************** package body Exp_Ch6 is *** 2055,2070 **** if Ekind (Etype (Prev)) in Private_Kind and then not Has_Discriminants (Base_Type (Etype (Prev))) then ! Add_Extra_Actual ( ! New_Occurrence_Of (Standard_False, Loc), ! Extra_Constrained (Formal)); elsif Is_Constrained (Etype (Formal)) or else not Has_Discriminants (Etype (Prev)) then ! Add_Extra_Actual ( ! New_Occurrence_Of (Standard_True, Loc), ! Extra_Constrained (Formal)); -- Do not produce extra actuals for Unchecked_Union parameters. -- Jump directly to the end of the loop. --- 2060,2075 ---- if Ekind (Etype (Prev)) in Private_Kind and then not Has_Discriminants (Base_Type (Etype (Prev))) then ! Add_Extra_Actual ! (New_Occurrence_Of (Standard_False, Loc), ! Extra_Constrained (Formal)); elsif Is_Constrained (Etype (Formal)) or else not Has_Discriminants (Etype (Prev)) then ! Add_Extra_Actual ! (New_Occurrence_Of (Standard_True, Loc), ! Extra_Constrained (Formal)); -- Do not produce extra actuals for Unchecked_Union parameters. -- Jump directly to the end of the loop. *************** package body Exp_Ch6 is *** 2205,2211 **** else Add_Extra_Actual (Make_Integer_Literal (Loc, ! Intval => Scope_Depth (Standard_Standard)), Extra_Accessibility (Formal)); end if; end; --- 2210,2216 ---- else Add_Extra_Actual (Make_Integer_Literal (Loc, ! Intval => Scope_Depth (Standard_Standard)), Extra_Accessibility (Formal)); end if; end; *************** package body Exp_Ch6 is *** 2216,2226 **** else Add_Extra_Actual (Make_Integer_Literal (Loc, ! Intval => Type_Access_Level (Etype (Prev_Orig))), Extra_Accessibility (Formal)); end if; ! -- All cases other than thunks else case Nkind (Prev_Orig) is --- 2221,2245 ---- else Add_Extra_Actual (Make_Integer_Literal (Loc, ! Intval => Type_Access_Level (Etype (Prev_Orig))), Extra_Accessibility (Formal)); end if; ! -- If the actual is an access discriminant, then pass the level ! -- of the enclosing object (RM05-3.10.2(12.4/2)). ! ! elsif Nkind (Prev_Orig) = N_Selected_Component ! and then Ekind (Entity (Selector_Name (Prev_Orig))) = ! E_Discriminant ! and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) = ! E_Anonymous_Access_Type ! then ! Add_Extra_Actual ! (Make_Integer_Literal (Loc, ! Intval => Object_Access_Level (Prefix (Prev_Orig))), ! Extra_Accessibility (Formal)); ! ! -- All other cases else case Nkind (Prev_Orig) is *************** package body Exp_Ch6 is *** 2231,2250 **** -- For X'Access, pass on the level of the prefix X when Attribute_Access => ! Add_Extra_Actual ( ! Make_Integer_Literal (Loc, ! Intval => ! Object_Access_Level (Prefix (Prev_Orig))), ! Extra_Accessibility (Formal)); -- Treat the unchecked attributes as library-level when Attribute_Unchecked_Access | Attribute_Unrestricted_Access => ! Add_Extra_Actual ( ! Make_Integer_Literal (Loc, ! Intval => Scope_Depth (Standard_Standard)), ! Extra_Accessibility (Formal)); -- No other cases of attributes returning access -- values that can be passed to access parameters --- 2250,2269 ---- -- For X'Access, pass on the level of the prefix X when Attribute_Access => ! Add_Extra_Actual ! (Make_Integer_Literal (Loc, ! Intval => ! Object_Access_Level (Prefix (Prev_Orig))), ! Extra_Accessibility (Formal)); -- Treat the unchecked attributes as library-level when Attribute_Unchecked_Access | Attribute_Unrestricted_Access => ! Add_Extra_Actual ! (Make_Integer_Literal (Loc, ! Intval => Scope_Depth (Standard_Standard)), ! Extra_Accessibility (Formal)); -- No other cases of attributes returning access -- values that can be passed to access parameters *************** package body Exp_Ch6 is *** 2259,2277 **** -- current scope level. when N_Allocator => ! Add_Extra_Actual ( ! Make_Integer_Literal (Loc, ! Scope_Depth (Current_Scope) + 1), ! Extra_Accessibility (Formal)); ! -- For other cases we simply pass the level of the ! -- actual's access type. when others => ! Add_Extra_Actual ( ! Make_Integer_Literal (Loc, ! Intval => Type_Access_Level (Etype (Prev_Orig))), ! Extra_Accessibility (Formal)); end case; end if; --- 2278,2298 ---- -- current scope level. when N_Allocator => ! Add_Extra_Actual ! (Make_Integer_Literal (Loc, ! Intval => Scope_Depth (Current_Scope) + 1), ! Extra_Accessibility (Formal)); ! -- For other cases we simply pass the level of the actual's ! -- access type. The type is retrieved from Prev rather than ! -- Prev_Orig, because in some cases Prev_Orig denotes an ! -- original expression that has not been analyzed. when others => ! Add_Extra_Actual ! (Make_Integer_Literal (Loc, ! Intval => Type_Access_Level (Etype (Prev))), ! Extra_Accessibility (Formal)); end case; end if; *************** package body Exp_Ch6 is *** 2547,2567 **** if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) and then Present (Controlling_Argument (N)) - and then VM_Target = No_VM then ! Expand_Dispatching_Call (N); ! -- The following return is worrisome. Is it really OK to ! -- skip all remaining processing in this procedure ??? ! return; -- Similarly, expand calls to RCI subprograms on which pragma -- All_Calls_Remote applies. The rewriting will be reanalyzed -- later. Do this only when the call comes from source since we do ! -- not want such a rewritting to occur in expanded code. ! elsif Is_All_Remote_Call (N) then Expand_All_Calls_Remote_Subprogram_Call (N); -- Similarly, do not add extra actuals for an entry call whose entity --- 2568,2598 ---- if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) and then Present (Controlling_Argument (N)) then ! if VM_Target = No_VM then ! Expand_Dispatching_Call (N); ! -- The following return is worrisome. Is it really OK to ! -- skip all remaining processing in this procedure ??? ! return; ! ! -- Expansion of a dispatching call results in an indirect call, which ! -- in turn causes current values to be killed (see Resolve_Call), so ! -- on VM targets we do the call here to ensure consistent warnings ! -- between VM and non-VM targets. ! ! else ! Kill_Current_Values; ! end if; ! end if; -- Similarly, expand calls to RCI subprograms on which pragma -- All_Calls_Remote applies. The rewriting will be reanalyzed -- later. Do this only when the call comes from source since we do ! -- not want such a rewriting to occur in expanded code. ! if Is_All_Remote_Call (N) then Expand_All_Calls_Remote_Subprogram_Call (N); -- Similarly, do not add extra actuals for an entry call whose entity *************** package body Exp_Ch6 is *** 2617,2693 **** ("cannot call abstract subprogram &!", Name (N), Parent_Subp); end if; ! -- Add an explicit conversion for parameter of the derived type. ! -- This is only done for scalar and access in-parameters. Others ! -- have been expanded in expand_actuals. ! ! Formal := First_Formal (Subp); ! Parent_Formal := First_Formal (Parent_Subp); ! Actual := First_Actual (N); ! -- It is not clear that conversion is needed for intrinsic ! -- subprograms, but it certainly is for those that are user- ! -- defined, and that can be inherited on derivation, namely ! -- unchecked conversion and deallocation. ! -- General case needs study ??? if not Is_Intrinsic_Subprogram (Parent_Subp) or else Is_Generic_Instance (Parent_Subp) then ! while Present (Formal) loop ! if Etype (Formal) /= Etype (Parent_Formal) ! and then Is_Scalar_Type (Etype (Formal)) ! and then Ekind (Formal) = E_In_Parameter ! and then ! not Subtypes_Statically_Match ! (Etype (Parent_Formal), Etype (Actual)) ! and then not Raises_Constraint_Error (Actual) ! then ! Rewrite (Actual, ! OK_Convert_To (Etype (Parent_Formal), ! Relocate_Node (Actual))); ! Analyze (Actual); ! Resolve (Actual, Etype (Parent_Formal)); ! Enable_Range_Check (Actual); ! elsif Is_Access_Type (Etype (Formal)) ! and then Base_Type (Etype (Parent_Formal)) /= ! Base_Type (Etype (Actual)) ! then ! if Ekind (Formal) /= E_In_Parameter then ! Rewrite (Actual, ! Convert_To (Etype (Parent_Formal), ! Relocate_Node (Actual))); ! Analyze (Actual); ! Resolve (Actual, Etype (Parent_Formal)); ! elsif ! Ekind (Etype (Parent_Formal)) = E_Anonymous_Access_Type ! and then Designated_Type (Etype (Parent_Formal)) ! /= ! Designated_Type (Etype (Actual)) ! and then not Is_Controlling_Formal (Formal) then ! -- This unchecked conversion is not necessary unless ! -- inlining is enabled, because in that case the type ! -- mismatch may become visible in the body about to be ! -- inlined. ! Rewrite (Actual, ! Unchecked_Convert_To (Etype (Parent_Formal), ! Relocate_Node (Actual))); ! Analyze (Actual); ! Resolve (Actual, Etype (Parent_Formal)); end if; - end if; ! Next_Formal (Formal); ! Next_Formal (Parent_Formal); ! Next_Actual (Actual); ! end loop; end if; Orig_Subp := Subp; --- 2648,2757 ---- ("cannot call abstract subprogram &!", Name (N), Parent_Subp); end if; ! -- Inspect all formals of derived subprogram Subp. Compare parameter ! -- types with the parent subprogram and check whether an actual may ! -- need a type conversion to the corresponding formal of the parent ! -- subprogram. ! -- Not clear whether intrinsic subprograms need such conversions. ??? if not Is_Intrinsic_Subprogram (Parent_Subp) or else Is_Generic_Instance (Parent_Subp) then ! declare ! procedure Convert (Act : Node_Id; Typ : Entity_Id); ! -- Rewrite node Act as a type conversion of Act to Typ. Analyze ! -- and resolve the newly generated construct. ! ------------- ! -- Convert -- ! ------------- ! procedure Convert (Act : Node_Id; Typ : Entity_Id) is ! begin ! Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act))); ! Analyze (Act); ! Resolve (Act, Typ); ! end Convert; ! -- Local variables ! Actual_Typ : Entity_Id; ! Formal_Typ : Entity_Id; ! Parent_Typ : Entity_Id; ! ! begin ! Actual := First_Actual (N); ! Formal := First_Formal (Subp); ! Parent_Formal := First_Formal (Parent_Subp); ! while Present (Formal) loop ! Actual_Typ := Etype (Actual); ! Formal_Typ := Etype (Formal); ! Parent_Typ := Etype (Parent_Formal); ! ! -- For an IN parameter of a scalar type, the parent formal ! -- type and derived formal type differ or the parent formal ! -- type and actual type do not match statically. ! ! if Is_Scalar_Type (Formal_Typ) ! and then Ekind (Formal) = E_In_Parameter ! and then Formal_Typ /= Parent_Typ ! and then ! not Subtypes_Statically_Match (Parent_Typ, Actual_Typ) ! and then not Raises_Constraint_Error (Actual) then ! Convert (Actual, Parent_Typ); ! Enable_Range_Check (Actual); ! -- For access types, the parent formal type and actual type ! -- differ. ! elsif Is_Access_Type (Formal_Typ) ! and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ) ! then ! if Ekind (Formal) /= E_In_Parameter then ! Convert (Actual, Parent_Typ); ! ! elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type ! and then Designated_Type (Parent_Typ) /= ! Designated_Type (Actual_Typ) ! and then not Is_Controlling_Formal (Formal) ! then ! -- This unchecked conversion is not necessary unless ! -- inlining is enabled, because in that case the type ! -- mismatch may become visible in the body about to be ! -- inlined. ! ! Rewrite (Actual, ! Unchecked_Convert_To (Parent_Typ, ! Relocate_Node (Actual))); ! ! Analyze (Actual); ! Resolve (Actual, Parent_Typ); ! end if; ! ! -- For array and record types, the parent formal type and ! -- derived formal type have different sizes or pragma Pack ! -- status. ! ! elsif ((Is_Array_Type (Formal_Typ) ! and then Is_Array_Type (Parent_Typ)) ! or else ! (Is_Record_Type (Formal_Typ) ! and then Is_Record_Type (Parent_Typ))) ! and then ! (Esize (Formal_Typ) /= Esize (Parent_Typ) ! or else Has_Pragma_Pack (Formal_Typ) /= ! Has_Pragma_Pack (Parent_Typ)) ! then ! Convert (Actual, Parent_Typ); end if; ! Next_Actual (Actual); ! Next_Formal (Formal); ! Next_Formal (Parent_Formal); ! end loop; ! end; end if; Orig_Subp := Subp; *************** package body Exp_Ch6 is *** 2720,2726 **** -- Handle case of access to protected subprogram type if Is_Access_Protected_Subprogram_Type ! (Base_Type (Etype (Prefix (Name (N))))) then -- If this is a call through an access to protected operation, -- the prefix has the form (object'address, operation'access). --- 2784,2790 ---- -- Handle case of access to protected subprogram type if Is_Access_Protected_Subprogram_Type ! (Base_Type (Etype (Prefix (Name (N))))) then -- If this is a call through an access to protected operation, -- the prefix has the form (object'address, operation'access). *************** package body Exp_Ch6 is *** 2969,2975 **** -- If the return type is limited the context is an initialization -- and different processing applies. ! if Controlled_Type (Etype (Subp)) and then not Is_Inherently_Limited_Type (Etype (Subp)) and then not Is_Limited_Interface (Etype (Subp)) then --- 3033,3039 ---- -- If the return type is limited the context is an initialization -- and different processing applies. ! if Needs_Finalization (Etype (Subp)) and then not Is_Inherently_Limited_Type (Etype (Subp)) and then not Is_Limited_Interface (Etype (Subp)) then *************** package body Exp_Ch6 is *** 3110,3143 **** end if; end; end if; - - -- Special processing for Ada 2005 AI-329, which requires a call to - -- Raise_Exception to raise Constraint_Error if the Exception_Id is - -- null. Note that we never need to do this in GNAT mode, or if the - -- parameter to Raise_Exception is a use of Identity, since in these - -- cases we know that the parameter is never null. - - -- Note: We must check that the node has not been inlined. This is - -- required because under zfp the Raise_Exception subprogram has the - -- pragma inline_always (and hence the call has been expanded above - -- into a block containing the code of the subprogram). - - if Ada_Version >= Ada_05 - and then not GNAT_Mode - and then Is_RTE (Subp, RE_Raise_Exception) - and then Nkind (N) = N_Procedure_Call_Statement - and then (Nkind (First_Actual (N)) /= N_Attribute_Reference - or else Attribute_Name (First_Actual (N)) /= Name_Identity) - then - declare - RCE : constant Node_Id := - Make_Raise_Constraint_Error (Loc, - Reason => CE_Null_Exception_Id); - begin - Insert_After (N, RCE); - Analyze (RCE); - end; - end if; end Expand_Call; -------------------------- --- 3174,3179 ---- *************** package body Exp_Ch6 is *** 3344,3350 **** -- Because of the presence of private types, the views of the -- expression and the context may be different, so place an -- unchecked conversion to the context type to avoid spurious ! -- errors, eg. when the expression is a numeric literal and -- the context is private. If the expression is an aggregate, -- use a qualified expression, because an aggregate is not a -- legal argument of a conversion. --- 3380,3386 ---- -- Because of the presence of private types, the views of the -- expression and the context may be different, so place an -- unchecked conversion to the context type to avoid spurious ! -- errors, e.g. when the expression is a numeric literal and -- the context is private. If the expression is an aggregate, -- use a qualified expression, because an aggregate is not a -- legal argument of a conversion. *************** package body Exp_Ch6 is *** 3388,3394 **** -- not be posting warnings on the inlined body so it is unneeded. elsif Nkind (N) = N_Pragma ! and then Chars (N) = Name_Unreferenced then Rewrite (N, Make_Null_Statement (Sloc (N))); return OK; --- 3424,3430 ---- -- not be posting warnings on the inlined body so it is unneeded. elsif Nkind (N) = N_Pragma ! and then Pragma_Name (N) = Name_Unreferenced then Rewrite (N, Make_Null_Statement (Sloc (N))); return OK; *************** package body Exp_Ch6 is *** 3809,3815 **** Make_Defining_Identifier (Loc, New_Internal_Name ('C')); Set_Is_Internal (Temp); ! -- For the unconstrained case. the generated temporary has the -- same constrained declaration as the result variable. -- It may eventually be possible to remove that temporary and -- use the result variable directly. --- 3845,3851 ---- Make_Defining_Identifier (Loc, New_Internal_Name ('C')); Set_Is_Internal (Temp); ! -- For the unconstrained case, the generated temporary has the -- same constrained declaration as the result variable. -- It may eventually be possible to remove that temporary and -- use the result variable directly. *************** package body Exp_Ch6 is *** 3934,3939 **** --- 3970,3990 ---- procedure Expand_N_Function_Call (N : Node_Id) is begin Expand_Call (N); + + -- If the return value of a foreign compiled function is + -- VAX Float then expand the return (adjusts the location + -- of the return value on Alpha/VMS, noop everywhere else). + -- Comes_From_Source intercepts recursive expansion. + + if Vax_Float (Etype (N)) + and then Nkind (N) = N_Function_Call + and then Present (Name (N)) + and then Present (Entity (Name (N))) + and then Has_Foreign_Convention (Entity (Name (N))) + and then Comes_From_Source (Parent (N)) + then + Expand_Vax_Foreign_Return (N); + end if; end Expand_N_Function_Call; --------------------------------------- *************** package body Exp_Ch6 is *** 3978,3989 **** Loc : constant Source_Ptr := Sloc (N); H : constant Node_Id := Handled_Statement_Sequence (N); Body_Id : Entity_Id; - Spec_Id : Entity_Id; Except_H : Node_Id; - Scop : Entity_Id; - Dec : Node_Id; - Next_Op : Node_Id; L : List_Id; procedure Add_Return (S : List_Id); -- Append a return statement to the statement sequence S if the last --- 4029,4037 ---- Loc : constant Source_Ptr := Sloc (N); H : constant Node_Id := Handled_Statement_Sequence (N); Body_Id : Entity_Id; Except_H : Node_Id; L : List_Id; + Spec_Id : Entity_Id; procedure Add_Return (S : List_Id); -- Append a return statement to the statement sequence S if the last *************** package body Exp_Ch6 is *** 4165,4170 **** --- 4213,4220 ---- if Is_Scalar_Type (Etype (F)) and then Ekind (F) = E_Out_Parameter then + Check_Restriction (No_Default_Initialization, F); + -- Insert the initialization. We turn off validity checks -- for this assignment, since we do not want any check on -- the initial value itself (which may well be invalid). *************** package body Exp_Ch6 is *** 4172,4178 **** Insert_Before_And_Analyze (First (L), Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (F, Loc), ! Expression => Get_Simple_Init_Val (Etype (F), Loc)), Suppress => Validity_Check); end if; --- 4222,4228 ---- Insert_Before_And_Analyze (First (L), Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (F, Loc), ! Expression => Get_Simple_Init_Val (Etype (F), N)), Suppress => Validity_Check); end if; *************** package body Exp_Ch6 is *** 4181,4214 **** end; end if; - Scop := Scope (Spec_Id); - - -- Add discriminal renamings to protected subprograms. Install new - -- discriminals for expansion of the next subprogram of this protected - -- type, if any. - - if Is_List_Member (N) - and then Present (Parent (List_Containing (N))) - and then Nkind (Parent (List_Containing (N))) = N_Protected_Body - then - Add_Discriminal_Declarations - (Declarations (N), Scop, Name_uObject, Loc); - Add_Private_Declarations - (Declarations (N), Scop, Name_uObject, Loc); - - -- Associate privals and discriminals with the next protected - -- operation body to be expanded. These are used to expand references - -- to private data objects and discriminants, respectively. - - Next_Op := Next_Protected_Operation (N); - - if Present (Next_Op) then - Dec := Parent (Base_Type (Scop)); - Set_Privals (Dec, Next_Op, Loc); - Set_Discriminals (Dec); - end if; - end if; - -- Clear out statement list for stubbed procedure if Present (Corresponding_Spec (N)) then --- 4231,4236 ---- *************** package body Exp_Ch6 is *** 4226,4231 **** --- 4248,4263 ---- end if; end if; + -- Create a set of discriminals for the next protected subprogram body + + if Is_List_Member (N) + and then Present (Parent (List_Containing (N))) + and then Nkind (Parent (List_Containing (N))) = N_Protected_Body + and then Present (Next_Protected_Operation (N)) + then + Set_Discriminals (Parent (Base_Type (Scope (Spec_Id)))); + end if; + -- Returns_By_Ref flag is normally set when the subprogram is frozen -- but subprograms with no specs are not frozen. *************** package body Exp_Ch6 is *** 4243,4249 **** elsif Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Spec_Id); ! elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then Set_Returns_By_Ref (Spec_Id); end if; end; --- 4275,4281 ---- elsif Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Spec_Id); ! elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Spec_Id); end if; end; *************** package body Exp_Ch6 is *** 4324,4360 **** Detect_Infinite_Recursion (N, Spec_Id); end if; - -- Finally, if we are in Normalize_Scalars mode, then any scalar out - -- parameters must be initialized to the appropriate default value. - - if Ekind (Spec_Id) = E_Procedure and then Normalize_Scalars then - declare - Floc : Source_Ptr; - Formal : Entity_Id; - Stm : Node_Id; - - begin - Formal := First_Formal (Spec_Id); - while Present (Formal) loop - Floc := Sloc (Formal); - - if Ekind (Formal) = E_Out_Parameter - and then Is_Scalar_Type (Etype (Formal)) - then - Stm := - Make_Assignment_Statement (Floc, - Name => New_Occurrence_Of (Formal, Floc), - Expression => - Get_Simple_Init_Val (Etype (Formal), Floc)); - Prepend (Stm, Declarations (N)); - Analyze (Stm); - end if; - - Next_Formal (Formal); - end loop; - end; - end if; - -- Set to encode entity names in package body before gigi is called Qualify_Entity_Names (N); --- 4356,4361 ---- *************** package body Exp_Ch6 is *** 4491,4497 **** -- which denotes the enclosing protected object. If the enclosing -- operation is an entry, we are immediately within the protected body, -- and we can retrieve the object from the service entries procedure. A ! -- barrier function has has the same signature as an entry. A barrier -- function is compiled within the protected object, but unlike -- protected operations its never needs locks, so that its protected -- body subprogram points to itself. --- 4492,4498 ---- -- which denotes the enclosing protected object. If the enclosing -- operation is an entry, we are immediately within the protected body, -- and we can retrieve the object from the service entries procedure. A ! -- barrier function has the same signature as an entry. A barrier -- function is compiled within the protected object, but unlike -- protected operations its never needs locks, so that its protected -- body subprogram points to itself. *************** package body Exp_Ch6 is *** 4749,4769 **** Tagged_Typ := Find_Dispatching_Type (Prim); if No (Access_Disp_Table (Tagged_Typ)) ! or else not Has_Abstract_Interfaces (Tagged_Typ) or else not RTE_Available (RE_Interface_Tag) or else Restriction_Active (No_Dispatching_Calls) then return; end if; ! -- Skip the first access-to-dispatch-table pointer since it leads ! -- to the primary dispatch table. We are only concerned with the ! -- secondary dispatch table pointers. Note that the access-to- ! -- dispatch-table pointer corresponds to the first implemented ! -- interface retrieved below. Iface_DT_Ptr := ! Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))); while Present (Iface_DT_Ptr) and then Ekind (Node (Iface_DT_Ptr)) = E_Constant --- 4750,4770 ---- Tagged_Typ := Find_Dispatching_Type (Prim); if No (Access_Disp_Table (Tagged_Typ)) ! or else not Has_Interfaces (Tagged_Typ) or else not RTE_Available (RE_Interface_Tag) or else Restriction_Active (No_Dispatching_Calls) then return; end if; ! -- Skip the first two access-to-dispatch-table pointers since they ! -- leads to the primary dispatch table (predefined DT and user ! -- defined DT). We are only concerned with the secondary dispatch ! -- table pointers. Note that the access-to- dispatch-table pointer ! -- corresponds to the first implemented interface retrieved below. Iface_DT_Ptr := ! Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); while Present (Iface_DT_Ptr) and then Ekind (Node (Iface_DT_Ptr)) = E_Constant *************** package body Exp_Ch6 is *** 4776,4798 **** Thunk_Code, Build_Set_Predefined_Prim_Op_Address (Loc, ! Tag_Node => New_Reference_To (Node (Iface_DT_Ptr), Loc), Position => DT_Position (Prim), Address_Node => ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Thunk_Id, Loc), ! Attribute_Name => Name_Address)), Build_Set_Predefined_Prim_Op_Address (Loc, ! Tag_Node => New_Reference_To ! (Node (Next_Elmt (Iface_DT_Ptr)), Loc), Position => DT_Position (Prim), Address_Node => ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim, Loc), ! Attribute_Name => Name_Address)))); end if; Next_Elmt (Iface_DT_Ptr); pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); --- 4777,4817 ---- Thunk_Code, Build_Set_Predefined_Prim_Op_Address (Loc, ! Tag_Node => ! New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc), Position => DT_Position (Prim), Address_Node => ! Unchecked_Convert_To (RTE (RE_Prim_Ptr), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Thunk_Id, Loc), ! Attribute_Name => Name_Unrestricted_Access))), Build_Set_Predefined_Prim_Op_Address (Loc, ! Tag_Node => ! New_Reference_To ! (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))), ! Loc), Position => DT_Position (Prim), Address_Node => ! Unchecked_Convert_To (RTE (RE_Prim_Ptr), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim, Loc), ! Attribute_Name => Name_Unrestricted_Access))))); end if; + -- Skip the tag of the predefined primitives dispatch table + + Next_Elmt (Iface_DT_Ptr); + pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); + + -- Skip the tag of the no-thunks dispatch table + + Next_Elmt (Iface_DT_Ptr); + pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); + + -- Skip the tag of the predefined primitives no-thunks dispatch + -- table + Next_Elmt (Iface_DT_Ptr); pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); *************** package body Exp_Ch6 is *** 4823,4829 **** Typ : constant Entity_Id := Scope (DTC_Entity (Subp)); begin ! -- Handle private overriden primitives if not Is_CPP_Class (Typ) then Check_Overriding_Operation (Subp); --- 4842,4848 ---- Typ : constant Entity_Id := Scope (DTC_Entity (Subp)); begin ! -- Handle private overridden primitives if not Is_CPP_Class (Typ) then Check_Overriding_Operation (Subp); *************** package body Exp_Ch6 is *** 4859,4865 **** -- table slot. if not Is_Interface (Typ) ! or else Present (Abstract_Interface_Alias (Subp)) then if Is_Predefined_Dispatching_Operation (Subp) then Register_Predefined_DT_Entry (Subp); --- 4878,4884 ---- -- table slot. if not Is_Interface (Typ) ! or else Present (Interface_Alias (Subp)) then if Is_Predefined_Dispatching_Operation (Subp) then Register_Predefined_DT_Entry (Subp); *************** package body Exp_Ch6 is *** 4883,4889 **** begin if Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Subp); ! elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then Set_Returns_By_Ref (Subp); end if; end; --- 4902,4908 ---- begin if Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Subp); ! elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Subp); end if; end; *************** package body Exp_Ch6 is *** 5169,5177 **** end if; end Make_Build_In_Place_Call_In_Anonymous_Context; ! --------------------------------------------------- -- Make_Build_In_Place_Call_In_Assignment -- ! --------------------------------------------------- procedure Make_Build_In_Place_Call_In_Assignment (Assign : Node_Id; --- 5188,5196 ---- end if; end Make_Build_In_Place_Call_In_Anonymous_Context; ! -------------------------------------------- -- Make_Build_In_Place_Call_In_Assignment -- ! -------------------------------------------- procedure Make_Build_In_Place_Call_In_Assignment (Assign : Node_Id; *************** package body Exp_Ch6 is *** 5232,5239 **** Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); ! Add_Final_List_Actual_To_Build_In_Place_Call ! (Func_Call, Function_Id, Acc_Type => Empty); Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); --- 5251,5266 ---- Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); ! -- If Lhs is a selected component, then pass it along so that its prefix ! -- object will be used as the source of the finalization list. ! ! if Nkind (Lhs) = N_Selected_Component then ! Add_Final_List_Actual_To_Build_In_Place_Call ! (Func_Call, Function_Id, Acc_Type => Empty, Sel_Comp => Lhs); ! else ! Add_Final_List_Actual_To_Build_In_Place_Call ! (Func_Call, Function_Id, Acc_Type => Empty); ! end if; Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); *************** package body Exp_Ch6 is *** 5475,5481 **** if Is_Constrained (Underlying_Type (Result_Subt)) then Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl); else ! Insert_Before_And_Analyze (Object_Decl, Ptr_Typ_Decl); end if; -- Finally, create an access object initialized to a reference to the --- 5502,5508 ---- if Is_Constrained (Underlying_Type (Result_Subt)) then Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl); else ! Insert_Action (Object_Decl, Ptr_Typ_Decl); end if; -- Finally, create an access object initialized to a reference to the *************** package body Exp_Ch6 is *** 5553,5567 **** -- If the object entity has a class-wide Etype, then we need to change -- it to the result subtype of the function call, because otherwise the ! -- object will be class-wide without an explicit intialization and won't ! -- be allocated properly by the back end. It seems unclean to make such ! -- a revision to the type at this point, and we should try to improve ! -- this treatment when build-in-place functions with class-wide results ! -- are implemented. ??? if Is_Class_Wide_Type (Etype (Defining_Identifier (Object_Decl))) then Set_Etype (Defining_Identifier (Object_Decl), Result_Subt); end if; end Make_Build_In_Place_Call_In_Object_Declaration; end Exp_Ch6; --- 5580,5614 ---- -- If the object entity has a class-wide Etype, then we need to change -- it to the result subtype of the function call, because otherwise the ! -- object will be class-wide without an explicit initialization and ! -- won't be allocated properly by the back end. It seems unclean to make ! -- such a revision to the type at this point, and we should try to ! -- improve this treatment when build-in-place functions with class-wide ! -- results are implemented. ??? if Is_Class_Wide_Type (Etype (Defining_Identifier (Object_Decl))) then Set_Etype (Defining_Identifier (Object_Decl), Result_Subt); end if; end Make_Build_In_Place_Call_In_Object_Declaration; + -------------------------- + -- Needs_BIP_Final_List -- + -------------------------- + + function Needs_BIP_Final_List (E : Entity_Id) return Boolean is + pragma Assert (Is_Build_In_Place_Function (E)); + Result_Subt : constant Entity_Id := Underlying_Type (Etype (E)); + + begin + -- We need the BIP_Final_List if the result type needs finalization. We + -- also need it for tagged types, even if not class-wide, because some + -- type extension might need finalization, and all overriding functions + -- must have the same calling conventions. However, if there is a + -- pragma Restrictions (No_Finalization), we never need this parameter. + + return (Needs_Finalization (Result_Subt) + or else Is_Tagged_Type (Underlying_Type (Result_Subt))) + and then not Restriction_Active (No_Finalization); + end Needs_BIP_Final_List; + end Exp_Ch6; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch6.ads gcc-4.4.0/gcc/ada/exp_ch6.ads *** gcc-4.3.3/gcc/ada/exp_ch6.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_ch6.ads Fri Aug 22 13:25:19 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Exp_Ch6 is *** 41,47 **** procedure Freeze_Subprogram (N : Node_Id); -- generate the appropriate expansions related to Subprogram freeze ! -- nodes (e. g. the filling of the corresponding Dispatch Table for -- Primitive Operations) -- The following type defines the various forms of allocation used for the --- 41,47 ---- procedure Freeze_Subprogram (N : Node_Id); -- generate the appropriate expansions related to Subprogram freeze ! -- nodes (e.g. the filling of the corresponding Dispatch Table for -- Primitive Operations) -- The following type defines the various forms of allocation used for the *************** package Exp_Ch6 is *** 65,71 **** -- caller or callee, and if the callee, whether to use the secondary -- stack or the heap. See Create_Extra_Formals. BIP_Final_List, ! -- Present if result type has controlled parts. Pointer to caller's -- finalization list. BIP_Master, -- Present if result type contains tasks. Master associated with --- 65,71 ---- -- caller or callee, and if the callee, whether to use the secondary -- stack or the heap. See Create_Extra_Formals. BIP_Final_List, ! -- Present if result type needs finalization. Pointer to caller's -- finalization list. BIP_Master, -- Present if result type contains tasks. Master associated with *************** package Exp_Ch6 is *** 161,164 **** --- 161,169 ---- -- for which Is_Build_In_Place_Call is True, or an N_Qualified_Expression -- node applied to such a function call. + function Needs_BIP_Final_List (E : Entity_Id) return Boolean; + -- ???pragma Precondition (Is_Build_In_Place_Function (E)); + -- Ada 2005 (AI-318-02): Returns True if the function needs the + -- BIP_Final_List implicit parameter. + end Exp_Ch6; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch7.adb gcc-4.4.0/gcc/ada/exp_ch7.adb *** gcc-4.3.3/gcc/ada/exp_ch7.adb Thu Dec 13 10:25:35 2007 --- gcc-4.4.0/gcc/ada/exp_ch7.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Exp_Ch7 is *** 123,129 **** -------------------------------------------------- function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id; ! -- N is a node wich may generate a transient scope. Loop over the -- parent pointers of N until it find the appropriate node to -- wrap. It it returns Empty, it means that no transient scope is -- needed in this context. --- 123,129 ---- -------------------------------------------------- function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id; ! -- N is a node which may generate a transient scope. Loop over the -- parent pointers of N until it find the appropriate node to -- wrap. It it returns Empty, it means that no transient scope is -- needed in this context. *************** package body Exp_Ch7 is *** 137,154 **** Is_Master : Boolean; Is_Protected_Subprogram : Boolean; Is_Task_Allocation_Block : Boolean; ! Is_Asynchronous_Call_Block : Boolean) return Node_Id; ! -- Expand a the clean-up procedure for controlled and/or transient ! -- block, and/or task master or task body, or blocks used to ! -- implement task allocation or asynchronous entry calls, or ! -- procedures used to implement protected procedures. Clean is the ! -- entity for such a procedure. Mark is the entity for the secondary ! -- stack mark, if empty only controlled block clean-up will be ! -- performed. Flist is the entity for the local final list, if empty ! -- only transient scope clean-up will be performed. The flags ! -- Is_Task and Is_Master control the calls to the corresponding ! -- finalization actions for a task body or for an entity that is a ! -- task master. procedure Set_Node_To_Be_Wrapped (N : Node_Id); -- Set the field Node_To_Be_Wrapped of the current scope --- 137,156 ---- Is_Master : Boolean; Is_Protected_Subprogram : Boolean; Is_Task_Allocation_Block : Boolean; ! Is_Asynchronous_Call_Block : Boolean; ! Chained_Cleanup_Action : Node_Id) return Node_Id; ! -- Expand the clean-up procedure for a controlled and/or transient block, ! -- and/or task master or task body, or a block used to implement task ! -- allocation or asynchronous entry calls, or a procedure used to implement ! -- protected procedures. Clean is the entity for such a procedure. Mark ! -- is the entity for the secondary stack mark, if empty only controlled ! -- block clean-up will be performed. Flist is the entity for the local ! -- final list, if empty only transient scope clean-up will be performed. ! -- The flags Is_Task and Is_Master control the calls to the corresponding ! -- finalization actions for a task body or for an entity that is a task ! -- master. Finally if Chained_Cleanup_Action is present, it is a reference ! -- to a previous cleanup procedure, a call to which is appended at the ! -- end of the generated one. procedure Set_Node_To_Be_Wrapped (N : Node_Id); -- Set the field Node_To_Be_Wrapped of the current scope *************** package body Exp_Ch7 is *** 245,251 **** -- Finalization Management -- ----------------------------- ! -- This part describe how Initialization/Adjusment/Finalization procedures -- are generated and called. Two cases must be considered, types that are -- Controlled (Is_Controlled flag set) and composite types that contain -- controlled components (Has_Controlled_Component flag set). In the first --- 247,253 ---- -- Finalization Management -- ----------------------------- ! -- This part describe how Initialization/Adjustment/Finalization procedures -- are generated and called. Two cases must be considered, types that are -- Controlled (Is_Controlled flag set) and composite types that contain -- controlled components (Has_Controlled_Component flag set). In the first *************** package body Exp_Ch7 is *** 262,268 **** -- controlled components changes during execution. This controller -- component is itself controlled and is attached to the upper-level -- finalization chain. Its adjust primitive is in charge of calling adjust ! -- on the components and adusting the finalization pointer to match their -- new location (see a-finali.adb). -- It is not possible to use a similar technique for arrays that have --- 264,270 ---- -- controlled components changes during execution. This controller -- component is itself controlled and is attached to the upper-level -- finalization chain. Its adjust primitive is in charge of calling adjust ! -- on the components and adjusting the finalization pointer to match their -- new location (see a-finali.adb). -- It is not possible to use a similar technique for arrays that have *************** package body Exp_Ch7 is *** 844,925 **** end if; end Check_Visibly_Controlled; ! --------------------- ! -- Controlled_Type -- ! --------------------- ! ! function Controlled_Type (T : Entity_Id) return Boolean is ! ! function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; ! -- If type is not frozen yet, check explicitly among its components, ! -- because flag is not necessarily set. ! ! ----------------------------------- ! -- Has_Some_Controlled_Component -- ! ----------------------------------- ! ! function Has_Some_Controlled_Component ! (Rec : Entity_Id) return Boolean ! is ! Comp : Entity_Id; ! ! begin ! if Has_Controlled_Component (Rec) then ! return True; ! ! elsif not Is_Frozen (Rec) then ! if Is_Record_Type (Rec) then ! Comp := First_Entity (Rec); ! ! while Present (Comp) loop ! if not Is_Type (Comp) ! and then Controlled_Type (Etype (Comp)) ! then ! return True; ! end if; ! ! Next_Entity (Comp); ! end loop; ! ! return False; ! ! elsif Is_Array_Type (Rec) then ! return Is_Controlled (Component_Type (Rec)); ! ! else ! return Has_Controlled_Component (Rec); ! end if; ! else ! return False; ! end if; ! end Has_Some_Controlled_Component; ! ! -- Start of processing for Controlled_Type ! ! begin ! -- Class-wide types must be treated as controlled because they may ! -- contain an extension that has controlled components ! ! -- We can skip this if finalization is not available ! ! return (Is_Class_Wide_Type (T) ! and then not In_Finalization_Root (T) ! and then not Restriction_Active (No_Finalization)) ! or else Is_Controlled (T) ! or else Has_Some_Controlled_Component (T) ! or else (Is_Concurrent_Type (T) ! and then Present (Corresponding_Record_Type (T)) ! and then Controlled_Type (Corresponding_Record_Type (T))); ! end Controlled_Type; ! ! --------------------------- ! -- CW_Or_Controlled_Type -- ! --------------------------- ! function CW_Or_Controlled_Type (T : Entity_Id) return Boolean is begin ! return Is_Class_Wide_Type (T) or else Controlled_Type (T); ! end CW_Or_Controlled_Type; -------------------------- -- Controller_Component -- --- 846,859 ---- end if; end Check_Visibly_Controlled; ! ------------------------------- ! -- CW_Or_Has_Controlled_Part -- ! ------------------------------- ! function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is begin ! return Is_Class_Wide_Type (T) or else Needs_Finalization (T); ! end CW_Or_Has_Controlled_Part; -------------------------- -- Controller_Component -- *************** package body Exp_Ch7 is *** 1030,1036 **** ------------------------------- -- This procedure is called each time a transient block has to be inserted ! -- that is to say for each call to a function with unconstrained ot tagged -- result. It creates a new scope on the stack scope in order to enclose -- all transient variables generated --- 964,970 ---- ------------------------------- -- This procedure is called each time a transient block has to be inserted ! -- that is to say for each call to a function with unconstrained or tagged -- result. It creates a new scope on the stack scope in order to enclose -- all transient variables generated *************** package body Exp_Ch7 is *** 1120,1125 **** --- 1054,1062 ---- Nkind (N) = N_Block_Statement and then Is_Asynchronous_Call_Block (N); + Previous_At_End_Proc : constant Node_Id := + At_End_Proc (Handled_Statement_Sequence (N)); + Clean : Entity_Id; Loc : Source_Ptr; Mark : Entity_Id := Empty; *************** package body Exp_Ch7 is *** 1244,1254 **** Is_Master, Is_Protected, Is_Task_Allocation, ! Is_Asynchronous_Call)); ! -- If exception handlers are present, wrap the Sequence of ! -- statements in a block because it is not possible to get ! -- exception handlers and an AT END call in the same scope. if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then --- 1181,1198 ---- Is_Master, Is_Protected, Is_Task_Allocation, ! Is_Asynchronous_Call, ! Previous_At_End_Proc)); ! -- The previous AT END procedure, if any, has been captured in Clean: ! -- reset it to Empty now because we check further on that we never ! -- overwrite an existing AT END call. ! ! Set_At_End_Proc (Handled_Statement_Sequence (N), Empty); ! ! -- If exception handlers are present, wrap the Sequence of statements in ! -- a block because it is not possible to get exception handlers and an ! -- AT END call in the same scope. if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then *************** package body Exp_Ch7 is *** 1284,1291 **** if Is_Task_Allocation then Chain := Activation_Chain_Entity (N); - Decl := First (Declarations (N)); while Nkind (Decl) /= N_Object_Declaration or else Defining_Identifier (Decl) /= Chain loop --- 1228,1235 ---- if Is_Task_Allocation then Chain := Activation_Chain_Entity (N); + Decl := First (Declarations (N)); while Nkind (Decl) /= N_Object_Declaration or else Defining_Identifier (Decl) /= Chain loop *************** package body Exp_Ch7 is *** 1330,1336 **** (Handled_Statement_Sequence (N), Sloc (First (Declarations (N)))); -- The declarations of the _Clean procedure and finalization chain ! -- replace the old declarations that have been moved inward Set_Declarations (N, New_Decls); Analyze_Declarations (New_Decls); --- 1274,1280 ---- (Handled_Statement_Sequence (N), Sloc (First (Declarations (N)))); -- The declarations of the _Clean procedure and finalization chain ! -- replace the old declarations that have been moved inward. Set_Declarations (N, New_Decls); Analyze_Declarations (New_Decls); *************** package body Exp_Ch7 is *** 1342,1350 **** begin -- If the construct is a protected subprogram, then the call to ! -- the corresponding unprotected program appears in a block which ! -- is the last statement in the body, and it is this block that ! -- must be covered by the At_End handler. if Is_Protected then HSS := Handled_Statement_Sequence --- 1286,1294 ---- begin -- If the construct is a protected subprogram, then the call to ! -- the corresponding unprotected subprogram appears in a block which ! -- is the last statement in the body, and it is this block that must ! -- be covered by the At_End handler. if Is_Protected then HSS := Handled_Statement_Sequence *************** package body Exp_Ch7 is *** 1353,1358 **** --- 1297,1306 ---- HSS := Handled_Statement_Sequence (N); end if; + -- Never overwrite an existing AT END call + + pragma Assert (No (At_End_Proc (HSS))); + Set_At_End_Proc (HSS, New_Occurrence_Of (Clean, Loc)); Expand_At_End_Handler (HSS, Empty); end; *************** package body Exp_Ch7 is *** 1455,1460 **** --- 1403,1419 ---- -- Attach_To_Final_List (_Lx, Resx (Resx'last)._controller, 3); + -- If the context is an aggregate, the call will be expanded into an + -- assignment, and the attachment will be done when the aggregate + -- expansion is complete. See body of Exp_Aggr for the treatment of + -- other controlled components. + + if Nkind (Parent (N)) = N_Aggregate then + return; + end if; + + -- Case where type has controlled components + if Has_Controlled_Component (Rtype) then declare T1 : Entity_Id := Rtype; *************** package body Exp_Ch7 is *** 1520,1534 **** With_Attach => Make_Integer_Literal (Loc, Attach_Level)); end if; ! else ! -- Here, we have a controlled type that does not seem to have ! -- controlled components but it could be a class wide type whose ! -- further derivations have controlled components. So we don't know ! -- if the object itself needs to be attached or if it ! -- has a record controller. We need to call a runtime function ! -- (Deep_Tag_Attach) which knows what to do thanks to the ! -- RC_Offset in the dispatch table. Action := Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Deep_Tag_Attach), Loc), --- 1479,1492 ---- With_Attach => Make_Integer_Literal (Loc, Attach_Level)); end if; ! -- Here, we have a controlled type that does not seem to have ! -- controlled components but it could be a class wide type whose ! -- further derivations have controlled components. So we don't know ! -- if the object itself needs to be attached or if it has a record ! -- controller. We need to call a runtime function (Deep_Tag_Attach) ! -- which knows what to do thanks to the RC_Offset in the dispatch table. + else Action := Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Deep_Tag_Attach), Loc), *************** package body Exp_Ch7 is *** 1708,1717 **** R : Node_Id; begin -- Case of an internal component. The Final list is the record -- controller of the enclosing record. ! if Present (Ref) then R := Ref; loop case Nkind (R) is --- 1666,1681 ---- R : Node_Id; begin + -- If the restriction No_Finalization applies, then there's not any + -- finalization list available to return, so return Empty. + + if Restriction_Active (No_Finalization) then + return Empty; + -- Case of an internal component. The Final list is the record -- controller of the enclosing record. ! elsif Present (Ref) then R := Ref; loop case Nkind (R) is *************** package body Exp_Ch7 is *** 1741,1750 **** Selector_Name => Make_Identifier (Loc, Name_uController)), Selector_Name => Make_Identifier (Loc, Name_F)); ! -- Case of a dynamically allocated object. The final list is the ! -- corresponding list controller (the next entity in the scope of the ! -- access type with the right type). If the type comes from a With_Type ! -- clause, no controller was created, we use the global chain instead. -- An anonymous access type either has a list created for it when the -- allocator is a for an access parameter or an access discriminant, --- 1705,1717 ---- Selector_Name => Make_Identifier (Loc, Name_uController)), Selector_Name => Make_Identifier (Loc, Name_F)); ! -- Case of a dynamically allocated object whose access type has an ! -- Associated_Final_Chain. The final list is the corresponding list ! -- controller (the next entity in the scope of the access type with ! -- the right type). If the type comes from a With_Type clause, no ! -- controller was created, we use the global chain instead. (The code ! -- related to with_type clauses should presumably be removed at some ! -- point since that feature is obsolete???) -- An anonymous access type either has a list created for it when the -- allocator is a for an access parameter or an access discriminant, *************** package body Exp_Ch7 is *** 1752,1770 **** -- context is a declaration or an assignment. elsif Is_Access_Type (E) ! and then (Ekind (E) /= E_Anonymous_Access_Type ! or else ! Present (Associated_Final_Chain (E))) then ! if not From_With_Type (E) then return Make_Selected_Component (Loc, Prefix => New_Reference_To (Associated_Final_Chain (Base_Type (E)), Loc), Selector_Name => Make_Identifier (Loc, Name_F)); - else - return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E)); end if; else --- 1719,1739 ---- -- context is a declaration or an assignment. elsif Is_Access_Type (E) ! and then (Present (Associated_Final_Chain (E)) ! or else From_With_Type (E)) then ! if From_With_Type (E) then ! return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E)); ! ! -- Use the access type's associated finalization chain ! ! else return Make_Selected_Component (Loc, Prefix => New_Reference_To (Associated_Final_Chain (Base_Type (E)), Loc), Selector_Name => Make_Identifier (Loc, Name_F)); end if; else *************** package body Exp_Ch7 is *** 2001,2007 **** null; elsif Scope (Original_Record_Component (Comp)) = E ! and then Controlled_Type (Etype (Comp)) then return True; end if; --- 1970,1976 ---- null; elsif Scope (Original_Record_Component (Comp)) = E ! and then Needs_Finalization (Etype (Comp)) then return True; end if; *************** package body Exp_Ch7 is *** 2233,2239 **** Is_Master : Boolean; Is_Protected_Subprogram : Boolean; Is_Task_Allocation_Block : Boolean; ! Is_Asynchronous_Call_Block : Boolean) return Node_Id is Loc : constant Source_Ptr := Sloc (Clean); Stmt : constant List_Id := New_List; --- 2202,2209 ---- Is_Master : Boolean; Is_Protected_Subprogram : Boolean; Is_Task_Allocation_Block : Boolean; ! Is_Asynchronous_Call_Block : Boolean; ! Chained_Cleanup_Action : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Clean); Stmt : constant List_Id := New_List; *************** package body Exp_Ch7 is *** 2301,2314 **** if Nkind (Specification (N)) = N_Procedure_Specification and then Has_Entries (Pid) then ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Number_Entries (Pid) > 1 ! then ! Name := New_Reference_To (RTE (RE_Service_Entries), Loc); ! else ! Name := New_Reference_To (RTE (RE_Service_Entry), Loc); ! end if; Append_To (Stmt, Make_Procedure_Call_Statement (Loc, --- 2271,2286 ---- if Nkind (Specification (N)) = N_Procedure_Specification and then Has_Entries (Pid) then ! case Corresponding_Runtime_Package (Pid) is ! when System_Tasking_Protected_Objects_Entries => ! Name := New_Reference_To (RTE (RE_Service_Entries), Loc); ! ! when System_Tasking_Protected_Objects_Single_Entry => ! Name := New_Reference_To (RTE (RE_Service_Entry), Loc); ! ! when others => ! raise Program_Error; ! end case; Append_To (Stmt, Make_Procedure_Call_Statement (Loc, *************** package body Exp_Ch7 is *** 2329,2359 **** -- object is the record used to implement the protected object. -- It is a parameter to the protected subprogram. ! -- If the protected object is controlled (i.e it has entries or ! -- needs finalization for interrupt handling), call ! -- Unlock_Entries, except if the protected object follows the ! -- ravenscar profile, in which case call Unlock_Entry, otherwise ! -- call the simplified version, Unlock. ! ! if Has_Entries (Pid) ! or else Has_Interrupt_Handler (Pid) ! or else (Has_Attach_Handler (Pid) ! and then not Restricted_Profile) ! or else (Ada_Version >= Ada_05 ! and then Present (Interface_List (Parent (Pid)))) ! then ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Number_Entries (Pid) > 1 ! then Name := New_Reference_To (RTE (RE_Unlock_Entries), Loc); ! else Name := New_Reference_To (RTE (RE_Unlock_Entry), Loc); - end if; ! else ! Name := New_Reference_To (RTE (RE_Unlock), Loc); ! end if; Append_To (Stmt, Make_Procedure_Call_Statement (Loc, --- 2301,2319 ---- -- object is the record used to implement the protected object. -- It is a parameter to the protected subprogram. ! case Corresponding_Runtime_Package (Pid) is ! when System_Tasking_Protected_Objects_Entries => Name := New_Reference_To (RTE (RE_Unlock_Entries), Loc); ! ! when System_Tasking_Protected_Objects_Single_Entry => Name := New_Reference_To (RTE (RE_Unlock_Entry), Loc); ! when System_Tasking_Protected_Objects => ! Name := New_Reference_To (RTE (RE_Unlock), Loc); ! ! when others => ! raise Program_Error; ! end case; Append_To (Stmt, Make_Procedure_Call_Statement (Loc, *************** package body Exp_Ch7 is *** 2486,2491 **** --- 2446,2457 ---- New_Reference_To (Mark, Loc)))); end if; + if Present (Chained_Cleanup_Action) then + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => Chained_Cleanup_Action)); + end if; + Sbody := Make_Subprogram_Body (Loc, Specification => *************** package body Exp_Ch7 is *** 2750,2756 **** With_Attach => Make_Identifier (Loc, Name_B))); -- When the type is also a controlled type by itself, ! -- Initialize it and attach it to the finalization chain if Is_Controlled (Typ) then Append_To (Res, --- 2716,2722 ---- With_Attach => Make_Identifier (Loc, Name_B))); -- When the type is also a controlled type by itself, ! -- initialize it and attach it to the finalization chain. if Is_Controlled (Typ) then Append_To (Res, *************** package body Exp_Ch7 is *** 2773,2779 **** Make_Identifier (Loc, Name_B))); -- When the type is also a controlled type by itself, ! -- Adjust it it and attach it to the finalization chain if Is_Controlled (Typ) then Append_To (Res, --- 2739,2745 ---- Make_Identifier (Loc, Name_B))); -- When the type is also a controlled type by itself, ! -- adjust it and attach it to the finalization chain. if Is_Controlled (Typ) then Append_To (Res, *************** package body Exp_Ch7 is *** 3152,3161 **** and then Nkind (Action) /= N_Simple_Return_Statement and then Nkind (Par) /= N_Exception_Handler then - declare S : Entity_Id; K : Entity_Kind; begin S := Scope (Current_Scope); loop --- 3118,3127 ---- and then Nkind (Action) /= N_Simple_Return_Statement and then Nkind (Par) /= N_Exception_Handler then declare S : Entity_Id; K : Entity_Kind; + begin S := Scope (Current_Scope); loop *************** package body Exp_Ch7 is *** 3239,3244 **** --- 3205,3278 ---- end Make_Transient_Block; ------------------------ + -- Needs_Finalization -- + ------------------------ + + function Needs_Finalization (T : Entity_Id) return Boolean is + + function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; + -- If type is not frozen yet, check explicitly among its components, + -- because the Has_Controlled_Component flag is not necessarily set. + + ----------------------------------- + -- Has_Some_Controlled_Component -- + ----------------------------------- + + function Has_Some_Controlled_Component + (Rec : Entity_Id) return Boolean + is + Comp : Entity_Id; + + begin + if Has_Controlled_Component (Rec) then + return True; + + elsif not Is_Frozen (Rec) then + if Is_Record_Type (Rec) then + Comp := First_Entity (Rec); + + while Present (Comp) loop + if not Is_Type (Comp) + and then Needs_Finalization (Etype (Comp)) + then + return True; + end if; + + Next_Entity (Comp); + end loop; + + return False; + + elsif Is_Array_Type (Rec) then + return Needs_Finalization (Component_Type (Rec)); + + else + return Has_Controlled_Component (Rec); + end if; + else + return False; + end if; + end Has_Some_Controlled_Component; + + -- Start of processing for Needs_Finalization + + begin + -- Class-wide types must be treated as controlled because they may + -- contain an extension that has controlled components + + -- We can skip this if finalization is not available + + return (Is_Class_Wide_Type (T) + and then not In_Finalization_Root (T) + and then not Restriction_Active (No_Finalization)) + or else Is_Controlled (T) + or else Has_Some_Controlled_Component (T) + or else (Is_Concurrent_Type (T) + and then Present (Corresponding_Record_Type (T)) + and then Needs_Finalization (Corresponding_Record_Type (T))); + end Needs_Finalization; + + ------------------------ -- Node_To_Be_Wrapped -- ------------------------ *************** package body Exp_Ch7 is *** 3382,3400 **** Insert_List_Before_And_Analyze (First (List_Containing (N)), Nodes); ! -- Generate the Finalization calls by finalizing the list ! -- controller right away. It will be re-finalized on scope ! -- exit but it doesn't matter. It cannot be done when the ! -- call initializes a renaming object though because in this ! -- case, the object becomes a pointer to the temporary and thus ! -- increases its life span. Ditto if this is a renaming of a ! -- component of an expression (such as a function call). . -- Note that there is a problem if an actual in the call needs -- finalization, because in that case the call itself is the master, -- and the actual should be finalized on return from the call ??? if Nkind (N) = N_Object_Renaming_Declaration ! and then Controlled_Type (Etype (Defining_Identifier (N))) then null; --- 3416,3435 ---- Insert_List_Before_And_Analyze (First (List_Containing (N)), Nodes); ! -- Generate the Finalization calls by finalizing the list controller ! -- right away. It will be re-finalized on scope exit but it doesn't ! -- matter. It cannot be done when the call initializes a renaming ! -- object though because in this case, the object becomes a pointer ! -- to the temporary and thus increases its life span. Ditto if this ! -- is a renaming of a component of an expression (such as a function ! -- call). ! -- Note that there is a problem if an actual in the call needs -- finalization, because in that case the call itself is the master, -- and the actual should be finalized on return from the call ??? if Nkind (N) = N_Object_Renaming_Declaration ! and then Needs_Finalization (Etype (Defining_Identifier (N))) then null; *************** package body Exp_Ch7 is *** 3404,3410 **** N_Selected_Component, N_Indexed_Component) and then ! Controlled_Type (Etype (Prefix (Renamed_Object (Defining_Identifier (N))))) then null; --- 3439,3445 ---- N_Selected_Component, N_Indexed_Component) and then ! Needs_Finalization (Etype (Prefix (Renamed_Object (Defining_Identifier (N))))) then null; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch7.ads gcc-4.4.0/gcc/ada/exp_ch7.ads *** gcc-4.3.3/gcc/ada/exp_ch7.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_ch7.ads Fri Aug 22 13:25:50 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Exp_Ch7 is *** 57,70 **** function Controller_Component (Typ : Entity_Id) return Entity_Id; -- Returns the entity of the component whose name is 'Name_uController' ! function Controlled_Type (T : Entity_Id) return Boolean; ! -- True if T potentially needs finalization actions ! function CW_Or_Controlled_Type (T : Entity_Id) return Boolean; ! -- True if T is either a potentially controlled type or a class-wide type. ! -- Note that in normal mode, class-wide types are potentially controlled so ! -- this function is different from Controlled_Type only under restrictions ! -- No_Finalization. function Find_Final_List (E : Entity_Id; --- 57,73 ---- function Controller_Component (Typ : Entity_Id) return Entity_Id; -- Returns the entity of the component whose name is 'Name_uController' ! function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean; ! -- True if T is a class-wide type, or if it has controlled parts ("part" ! -- means T or any of its subcomponents). This is the same as ! -- Needs_Finalization, except when pragma Restrictions (No_Finalization) ! -- applies, in which case we know that class-wide objects do not contain ! -- controlled parts. ! procedure Expand_Ctrl_Function_Call (N : Node_Id); ! -- Expand a call to a function returning a controlled value. That is to ! -- say attach the result of the call to the current finalization list, ! -- which is the one of the transient scope created for such constructs. function Find_Final_List (E : Entity_Id; *************** package Exp_Ch7 is *** 77,83 **** -- creating this final list if necessary. function Has_New_Controlled_Component (E : Entity_Id) return Boolean; ! -- E is a type entity. Give the same resul as Has_Controlled_Component -- except for tagged extensions where the result is True only if the -- latest extension contains a controlled component. --- 80,86 ---- -- creating this final list if necessary. function Has_New_Controlled_Component (E : Entity_Id) return Boolean; ! -- E is a type entity. Give the same result as Has_Controlled_Component -- except for tagged extensions where the result is True only if the -- latest extension contains a controlled component. *************** package Exp_Ch7 is *** 87,94 **** With_Attach : Node_Id) return Node_Id; -- Attach the referenced object to the referenced Final Chain 'Flist_Ref' -- With_Attach is an expression of type Short_Short_Integer which can be ! -- either '0' to signify no attachment, '1' for attachement to a simply ! -- linked list or '2' for attachement to a doubly linked list. function Make_Init_Call (Ref : Node_Id; --- 90,97 ---- With_Attach : Node_Id) return Node_Id; -- Attach the referenced object to the referenced Final Chain 'Flist_Ref' -- With_Attach is an expression of type Short_Short_Integer which can be ! -- either '0' to signify no attachment, '1' for attachment to a simply ! -- linked list or '2' for attachment to a doubly linked list. function Make_Init_Call (Ref : Node_Id; *************** package Exp_Ch7 is *** 99,105 **** -- been previously analyzed) that references the object to be initialized. -- Typ is the expected type of Ref, which is either a controlled type -- (Is_Controlled) or a type with controlled components (Has_Controlled). ! -- With_Attach is an integer expression which is the attchment level, -- see System.Finalization_Implementation.Attach_To_Final_List for the -- documentation of Nb_Link. -- --- 102,108 ---- -- been previously analyzed) that references the object to be initialized. -- Typ is the expected type of Ref, which is either a controlled type -- (Is_Controlled) or a type with controlled components (Has_Controlled). ! -- With_Attach is an integer expression which is the attachment level, -- see System.Finalization_Implementation.Attach_To_Final_List for the -- documentation of Nb_Link. -- *************** package Exp_Ch7 is *** 158,172 **** -- object but not when finalizing the target of an assignment, it is not -- necessary either on scope exit. - procedure Expand_Ctrl_Function_Call (N : Node_Id); - -- Expand a call to a function returning a controlled value. That is to - -- say attach the result of the call to the current finalization list, - -- which is the one of the transient scope created for such constructs. - function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id; -- Generate an implicit exception handler with an 'others' choice, -- converting any occurrence to a raise of Program_Error. -------------------------------------------- -- Task and Protected Object finalization -- -------------------------------------------- --- 161,177 ---- -- object but not when finalizing the target of an assignment, it is not -- necessary either on scope exit. function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id; -- Generate an implicit exception handler with an 'others' choice, -- converting any occurrence to a raise of Program_Error. + function Needs_Finalization (T : Entity_Id) return Boolean; + -- True if T potentially needs finalization actions. True if T is + -- controlled, or has subcomponents. Also True if T is a class-wide type, + -- because some type extension might add controlled subcomponents, except + -- that if pragma Restrictions (No_Finalization) applies, this is False for + -- class-wide types. + -------------------------------------------- -- Task and Protected Object finalization -- -------------------------------------------- *************** package Exp_Ch7 is *** 232,238 **** procedure Wrap_Transient_Declaration (N : Node_Id); -- N is an object declaration. Expand the finalization calls after the ! -- declaration and make the outer scope beeing the transient one. procedure Wrap_Transient_Expression (N : Node_Id); -- N is a sub-expression. Expand a transient block around an expression --- 237,243 ---- procedure Wrap_Transient_Declaration (N : Node_Id); -- N is an object declaration. Expand the finalization calls after the ! -- declaration and make the outer scope being the transient one. procedure Wrap_Transient_Expression (N : Node_Id); -- N is a sub-expression. Expand a transient block around an expression diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch9.adb gcc-4.4.0/gcc/ada/exp_ch9.adb *** gcc-4.3.3/gcc/ada/exp_ch9.adb Wed Dec 19 16:23:32 2007 --- gcc-4.4.0/gcc/ada/exp_ch9.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Exp_Ch3; use Exp_Ch3; *** 32,43 **** --- 32,46 ---- with Exp_Ch11; use Exp_Ch11; with Exp_Ch6; use Exp_Ch6; with Exp_Dbug; use Exp_Dbug; + with Exp_Disp; use Exp_Disp; with Exp_Sel; use Exp_Sel; with Exp_Smem; use Exp_Smem; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Hostparm; + with Itypes; use Itypes; + with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; *************** with Sem_Util; use Sem_Util; *** 54,59 **** --- 57,63 ---- with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; + with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; *************** package body Exp_Ch9 is *** 79,106 **** Ent : Entity_Id; Index : Node_Id; Tsk : Entity_Id) return Node_Id; ! -- Compute the index position for an entry call. Tsk is the target ! -- task. If the bounds of some entry family depend on discriminants, ! -- the expression computed by this function uses the discriminants ! -- of the target task. procedure Add_Object_Pointer ! (Decls : List_Id; ! Pid : Entity_Id; ! Loc : Source_Ptr); ! -- Prepend an object pointer declaration to the declaration list ! -- Decls. This object pointer is initialized to a type conversion ! -- of the System.Address pointer passed to entry barrier functions ! -- and entry body procedures. procedure Add_Formal_Renamings (Spec : Node_Id; Decls : List_Id; Ent : Entity_Id; Loc : Source_Ptr); ! -- Create renaming declarations for the formals, inside the procedure ! -- that implements an entry body. The renamings make the original names ! -- of the formals accessible to gdb, and serve no other purpose. -- Spec is the specification of the procedure being built. -- Decls is the list of declarations to be enhanced. -- Ent is the entity for the original entry body. --- 83,109 ---- Ent : Entity_Id; Index : Node_Id; Tsk : Entity_Id) return Node_Id; ! -- Compute the index position for an entry call. Tsk is the target task. If ! -- the bounds of some entry family depend on discriminants, the expression ! -- computed by this function uses the discriminants of the target task. procedure Add_Object_Pointer ! (Loc : Source_Ptr; ! Conc_Typ : Entity_Id; ! Decls : List_Id); ! -- Prepend an object pointer declaration to the declaration list Decls. ! -- This object pointer is initialized to a type conversion of the System. ! -- Address pointer passed to entry barrier functions and entry body ! -- procedures. procedure Add_Formal_Renamings (Spec : Node_Id; Decls : List_Id; Ent : Entity_Id; Loc : Source_Ptr); ! -- Create renaming declarations for the formals, inside the procedure that ! -- implements an entry body. The renamings make the original names of the ! -- formals accessible to gdb, and serve no other purpose. -- Spec is the specification of the procedure being built. -- Decls is the list of declarations to be enhanced. -- Ent is the entity for the original entry body. *************** package body Exp_Ch9 is *** 118,127 **** -- for the specified entry body. function Build_Barrier_Function_Specification ! (Def_Id : Entity_Id; ! Loc : Source_Ptr) return Node_Id; ! -- Build a specification for a function implementing ! -- the protected entry barrier of the specified entry body. function Build_Entry_Count_Expression (Concurrent_Type : Node_Id; --- 121,130 ---- -- for the specified entry body. function Build_Barrier_Function_Specification ! (Loc : Source_Ptr; ! Def_Id : Entity_Id) return Node_Id; ! -- Build a specification for a function implementing the protected entry ! -- barrier of the specified entry body. function Build_Entry_Count_Expression (Concurrent_Type : Node_Id; *************** package body Exp_Ch9 is *** 138,144 **** Formals : List_Id; Decls : List_Id) return Entity_Id; -- Generate an access type for each actual parameter in the list Actuals. ! -- Cleate an encapsulating record that contains all the actuals and return -- its type. Generate: -- type Ann1 is access all -- ... --- 141,147 ---- Formals : List_Id; Decls : List_Id) return Entity_Id; -- Generate an access type for each actual parameter in the list Actuals. ! -- Create an encapsulating record that contains all the actuals and return -- its type. Generate: -- type Ann1 is access all -- ... *************** package body Exp_Ch9 is *** 149,177 **** -- : AnnN; -- end record; ! function Build_Wrapper_Body ! (Loc : Source_Ptr; ! Proc_Nam : Entity_Id; ! Obj_Typ : Entity_Id; ! Formals : List_Id) return Node_Id; ! -- Ada 2005 (AI-345): Build the body that wraps a primitive operation ! -- associated with a protected or task type. This is required to implement ! -- dispatching calls through interfaces. Proc_Nam is the entry name to be ! -- wrapped, Obj_Typ is the type of the newly added formal parameter to ! -- handle object notation, Formals are the original entry formals that will ! -- be explicitly replicated. ! function Build_Wrapper_Spec ! (Loc : Source_Ptr; ! Proc_Nam : Entity_Id; ! Obj_Typ : Entity_Id; ! Formals : List_Id) return Node_Id; ! -- Ada 2005 (AI-345): Build the specification of a primitive operation ! -- associated with a protected or task type. This is required implement ! -- dispatching calls through interfaces. Proc_Nam is the entry name to be ! -- wrapped, Obj_Typ is the type of the newly added formal parameter to ! -- handle object notation, Formals are the original entry formals that will ! -- be explicitly replicated. function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; -- Build the function that translates the entry index in the call --- 152,176 ---- -- : AnnN; -- end record; ! procedure Build_Wrapper_Bodies ! (Loc : Source_Ptr; ! Typ : Entity_Id; ! N : Node_Id); ! -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding ! -- record of a concurrent type. N is the insertion node where all bodies ! -- will be placed. This routine builds the bodies of the subprograms which ! -- serve as an indirection mechanism to overriding primitives of concurrent ! -- types, entries and protected procedures. Any new body is analyzed. ! procedure Build_Wrapper_Specs ! (Loc : Source_Ptr; ! Typ : Entity_Id; ! N : in out Node_Id); ! -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding ! -- record of a concurrent type. N is the insertion node where all specs ! -- will be placed. This routine builds the specs of the subprograms which ! -- serve as an indirection mechanism to overriding primitives of concurrent ! -- types, entries and protected procedures. Any new spec is analyzed. function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; -- Build the function that translates the entry index in the call *************** package body Exp_Ch9 is *** 187,203 **** (N : Node_Id; Ent : Entity_Id; Pid : Node_Id) return Node_Id; ! -- Build the procedure implementing the statement sequence of ! -- the specified entry body. function Build_Protected_Entry_Specification ! (Def_Id : Entity_Id; ! Ent_Id : Entity_Id; ! Loc : Source_Ptr) return Node_Id; ! -- Build a specification for a procedure implementing ! -- the statement sequence of the specified entry body. ! -- Add attributes associating it with the entry defining identifier ! -- Ent_Id. function Build_Protected_Subprogram_Body (N : Node_Id; --- 186,214 ---- (N : Node_Id; Ent : Entity_Id; Pid : Node_Id) return Node_Id; ! -- Build the procedure implementing the statement sequence of the specified ! -- entry body. function Build_Protected_Entry_Specification ! (Loc : Source_Ptr; ! Def_Id : Entity_Id; ! Ent_Id : Entity_Id) return Node_Id; ! -- Build a specification for the procedure implementing the statements of ! -- the specified entry body. Add attributes associating it with the entry ! -- defining identifier Ent_Id. ! ! function Build_Protected_Spec ! (N : Node_Id; ! Obj_Type : Entity_Id; ! Ident : Entity_Id; ! Unprotected : Boolean := False) return List_Id; ! -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_ ! -- Subprogram_Type. Builds signature of protected subprogram, adding the ! -- formal that corresponds to the object itself. For an access to protected ! -- subprogram, there is no object type to specify, so the parameter has ! -- type Address and mode In. An indirect call through such a pointer will ! -- convert the address to a reference to the actual object. The object is ! -- a limited record and therefore a by_reference type. function Build_Protected_Subprogram_Body (N : Node_Id; *************** package body Exp_Ch9 is *** 211,229 **** -- a cleanup handler that unlocks the object in all cases. -- (see Exp_Ch7.Expand_Cleanup_Actions). - function Build_Protected_Spec - (N : Node_Id; - Obj_Type : Entity_Id; - Unprotected : Boolean := False; - Ident : Entity_Id) return List_Id; - -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_ - -- Subprogram_Type. Builds signature of protected subprogram, adding the - -- formal that corresponds to the object itself. For an access to protected - -- subprogram, there is no object type to specify, so the additional - -- parameter has type Address and mode In. An indirect call through such - -- a pointer converts the address to a reference to the actual object. - -- The object is a limited record and therefore a by_reference type. - function Build_Selected_Name (Prefix : Entity_Id; Selector : Entity_Id; --- 222,227 ---- *************** package body Exp_Ch9 is *** 271,276 **** --- 269,282 ---- -- For each entry family in a concurrent type, create an anonymous array -- type of the right size, and add a component to the corresponding_record. + function Concurrent_Object + (Spec_Id : Entity_Id; + Conc_Typ : Entity_Id) return Entity_Id; + -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return + -- the entity associated with the concurrent object in the Protected_Body_ + -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity + -- denotes formal parameter _O, _object or _task. + function Copy_Result_Type (Res : Node_Id) return Node_Id; -- Copy the result type of a function specification, when building the -- internal operation corresponding to a protected function, or when *************** package body Exp_Ch9 is *** 279,284 **** --- 285,297 ---- -- same parameter names and the same resolved types, but with new entities -- for the formals. + procedure Debug_Private_Data_Declarations (Decls : List_Id); + -- Decls is a list which may contain the declarations created by Install_ + -- Private_Data_Declarations. All generated entities are marked as needing + -- debug info and debug nodes are manually generation where necessary. This + -- step of the expansion must to be done after private data has been moved + -- to its final resting scope to ensure proper visibility of debug objects. + function Family_Offset (Loc : Source_Ptr; Hi : Node_Id; *************** package body Exp_Ch9 is *** 311,317 **** Formals : out List_Id); -- Given a dispatching call, extract the entity of the name of the call, -- its object parameter, its actual parameters and the formal parameters ! -- of the overriden interface-level version. procedure Extract_Entry (N : Node_Id; --- 324,330 ---- Formals : out List_Id); -- Given a dispatching call, extract the entity of the name of the call, -- its object parameter, its actual parameters and the formal parameters ! -- of the overridden interface-level version. procedure Extract_Entry (N : Node_Id; *************** package body Exp_Ch9 is *** 330,345 **** -- when P is Name_uPriority, the call will also find Interrupt_Priority. -- ??? Should be implemented with the rep item chain mechanism. ! function Index_Constant_Declaration ! (N : Node_Id; ! Index_Id : Entity_Id; ! Prot : Entity_Id) return List_Id; ! -- For an entry family and its barrier function, we define a local entity ! -- that maps the index in the call into the entry index into the object: ! -- ! -- I : constant Index_Type := Index_Type'Val ( ! -- E - <> + ! -- Protected_Entry_Index (Index_Type'Pos (Index_Type'First))); function Is_Potentially_Large_Family (Base_Index : Entity_Id; --- 343,353 ---- -- when P is Name_uPriority, the call will also find Interrupt_Priority. -- ??? Should be implemented with the rep item chain mechanism. ! function Index_Object (Spec_Id : Entity_Id) return Entity_Id; ! -- Given a subprogram identifier, return the entity which is associated ! -- with the protection entry index in the Protected_Body_Subprogram or the ! -- Task_Body_Procedure of Spec_Id. The returned entity denotes formal ! -- parameter _E. function Is_Potentially_Large_Family (Base_Index : Entity_Id; *************** package body Exp_Ch9 is *** 347,352 **** --- 355,364 ---- Lo : Node_Id; Hi : Node_Id) return Boolean; + function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean; + -- Determine whether Id is a function or a procedure and is marked as a + -- private primitive. + function Null_Statements (Stats : List_Id) return Boolean; -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END. -- Allows labels, and pragma Warnings/Unreferenced in the sequence as *************** package body Exp_Ch9 is *** 394,409 **** -- a rescheduling is required, so this optimization is not allowed. This -- function returns True if the optimization is permitted. - procedure Update_Prival_Subtypes (N : Node_Id); - -- The actual subtypes of the privals will differ from the type of the - -- private declaration in the original protected type, if the protected - -- type has discriminants or if the prival has constrained components. - -- This is because the privals are generated out of sequence w.r.t. the - -- analysis of a protected body. After generating the bodies for protected - -- operations, we set correctly the type of all references to privals, by - -- means of a recursive tree traversal, which is heavy-handed but - -- correct. - ----------------------------- -- Actual_Index_Expression -- ----------------------------- --- 406,411 ---- *************** package body Exp_Ch9 is *** 599,682 **** return Expr; end Actual_Index_Expression; - ---------------------------------- - -- Add_Discriminal_Declarations -- - ---------------------------------- - - procedure Add_Discriminal_Declarations - (Decls : List_Id; - Typ : Entity_Id; - Name : Name_Id; - Loc : Source_Ptr) - is - D : Entity_Id; - - begin - if Has_Discriminants (Typ) then - D := First_Discriminant (Typ); - - while Present (D) loop - - Prepend_To (Decls, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Discriminal (D), - Subtype_Mark => New_Reference_To (Etype (D), Loc), - Name => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name), - Selector_Name => Make_Identifier (Loc, Chars (D))))); - - Next_Discriminant (D); - end loop; - end if; - end Add_Discriminal_Declarations; - - ------------------------ - -- Add_Object_Pointer -- - ------------------------ - - procedure Add_Object_Pointer - (Decls : List_Id; - Pid : Entity_Id; - Loc : Source_Ptr) - is - Decl : Node_Id; - Obj_Ptr : Node_Id; - - begin - -- Prepend the declaration of _object. This must be first in the - -- declaration list, since it is used by the discriminal and - -- prival declarations. - -- ??? An attempt to make this a renaming was unsuccessful. - -- - -- type poVP is access poV; - -- _object : poVP := poVP!O; - - Obj_Ptr := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name - (Chars (Corresponding_Record_Type (Pid)), 'P')); - - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uObject), - Object_Definition => New_Reference_To (Obj_Ptr, Loc), - Expression => - Unchecked_Convert_To (Obj_Ptr, - Make_Identifier (Loc, Name_uO))); - Set_Needs_Debug_Info (Defining_Identifier (Decl)); - Prepend_To (Decls, Decl); - - Prepend_To (Decls, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Obj_Ptr, - Type_Definition => Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Reference_To (Corresponding_Record_Type (Pid), Loc)))); - end Add_Object_Pointer; - -------------------------- -- Add_Formal_Renamings -- -------------------------- --- 601,606 ---- *************** package body Exp_Ch9 is *** 701,712 **** begin Formal := First_Formal (Ent); while Present (Formal) loop ! Comp := Entry_Component (Formal); ! New_F := ! Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); Set_Etype (New_F, Etype (Formal)); Set_Scope (New_F, Ent); ! Set_Needs_Debug_Info (New_F); -- That's the whole point. if Ekind (Formal) = E_In_Parameter then Set_Ekind (New_F, E_Constant); --- 625,642 ---- begin Formal := First_Formal (Ent); while Present (Formal) loop ! Comp := Entry_Component (Formal); ! New_F := ! Make_Defining_Identifier (Sloc (Formal), ! Chars => Chars (Formal)); Set_Etype (New_F, Etype (Formal)); Set_Scope (New_F, Ent); ! ! -- Now we set debug info needed on New_F even though it does not ! -- come from source, so that the debugger will get the right ! -- information for these generated names. ! ! Set_Debug_Info_Needed (New_F); if Ekind (Formal) = E_In_Parameter then Set_Ekind (New_F, E_Constant); *************** package body Exp_Ch9 is *** 720,726 **** Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => New_F, ! Subtype_Mark => New_Reference_To (Etype (Formal), Loc), Name => Make_Explicit_Dereference (Loc, Make_Selected_Component (Loc, --- 650,657 ---- Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => New_F, ! Subtype_Mark => ! New_Reference_To (Etype (Formal), Loc), Name => Make_Explicit_Dereference (Loc, Make_Selected_Component (Loc, *************** package body Exp_Ch9 is *** 736,848 **** end loop; end Add_Formal_Renamings; ! ------------------------------ ! -- Add_Private_Declarations -- ! ------------------------------ ! procedure Add_Private_Declarations ! (Decls : List_Id; ! Typ : Entity_Id; ! Name : Name_Id; ! Loc : Source_Ptr) is ! Body_Ent : constant Entity_Id := Corresponding_Body (Parent (Typ)); ! Def : constant Node_Id := Protected_Definition (Parent (Typ)); ! ! Decl : Node_Id; ! P : Node_Id; ! Pdef : Entity_Id; begin ! pragma Assert (Nkind (Def) = N_Protected_Definition); ! ! if Present (Private_Declarations (Def)) then ! P := First (Private_Declarations (Def)); ! while Present (P) loop ! if Nkind (P) = N_Component_Declaration then ! Pdef := Defining_Identifier (P); ! ! -- The privals are declared before the current body is ! -- analyzed. for visibility reasons. Set their Sloc so ! -- that it is consistent with their renaming declaration, ! -- to prevent anomalies in gdb. ! ! -- This kludgy model for privals should be redesigned ??? ! ! Set_Sloc (Prival (Pdef), Loc); ! ! Decl := ! Make_Object_Renaming_Declaration (Loc, ! Defining_Identifier => Prival (Pdef), ! Subtype_Mark => New_Reference_To (Etype (Pdef), Loc), ! Name => ! Make_Selected_Component (Loc, ! Prefix => Make_Identifier (Loc, Name), ! Selector_Name => Make_Identifier (Loc, Chars (Pdef)))); ! Set_Needs_Debug_Info (Defining_Identifier (Decl)); ! Prepend_To (Decls, Decl); ! end if; ! ! Next (P); ! end loop; ! end if; ! ! -- One more "prival" for object itself, with the right protection type ! ! declare ! Protection_Type : RE_Id; ! ! begin ! if Has_Attach_Handler (Typ) then ! if Restricted_Profile then ! if Has_Entries (Typ) then ! Protection_Type := RE_Protection_Entry; ! else ! Protection_Type := RE_Protection; ! end if; ! else ! Protection_Type := RE_Static_Interrupt_Protection; ! end if; ! ! elsif Has_Interrupt_Handler (Typ) then ! Protection_Type := RE_Dynamic_Interrupt_Protection; ! -- The type has explicit entries or generated primitive entry ! -- wrappers. ! elsif Has_Entries (Typ) ! or else (Ada_Version >= Ada_05 ! and then Present (Interface_List (Parent (Typ)))) ! then ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Number_Entries (Typ) > 1 ! then ! Protection_Type := RE_Protection_Entries; ! else ! Protection_Type := RE_Protection_Entry; ! end if; ! else ! Protection_Type := RE_Protection; ! end if; ! -- Adjust Sloc, as for the other privals ! Set_Sloc (Object_Ref (Body_Ent), Loc); ! Decl := ! Make_Object_Renaming_Declaration (Loc, ! Defining_Identifier => Object_Ref (Body_Ent), ! Subtype_Mark => New_Reference_To (RTE (Protection_Type), Loc), ! Name => ! Make_Selected_Component (Loc, ! Prefix => Make_Identifier (Loc, Name), ! Selector_Name => Make_Identifier (Loc, Name_uObject))); ! Set_Needs_Debug_Info (Defining_Identifier (Decl)); ! Prepend_To (Decls, Decl); ! end; ! end Add_Private_Declarations; ----------------------- -- Build_Accept_Body -- --- 667,725 ---- end loop; end Add_Formal_Renamings; ! ------------------------ ! -- Add_Object_Pointer -- ! ------------------------ ! procedure Add_Object_Pointer ! (Loc : Source_Ptr; ! Conc_Typ : Entity_Id; ! Decls : List_Id) is ! Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ); ! Decl : Node_Id; ! Obj_Ptr : Node_Id; begin ! -- Create the renaming declaration for the Protection object of a ! -- protected type. _Object is used by Complete_Entry_Body. ! -- ??? An attempt to make this a renaming was unsuccessful. ! -- Build the entity for the access type ! Obj_Ptr := ! Make_Defining_Identifier (Loc, ! New_External_Name (Chars (Rec_Typ), 'P')); ! -- Generate: ! -- _object : poVP := poVP!O; ! Decl := ! Make_Object_Declaration (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, Name_uObject), ! Object_Definition => ! New_Reference_To (Obj_Ptr, Loc), ! Expression => ! Unchecked_Convert_To (Obj_Ptr, ! Make_Identifier (Loc, Name_uO))); ! Set_Debug_Info_Needed (Defining_Identifier (Decl)); ! Prepend_To (Decls, Decl); ! -- Generate: ! -- type poVP is access poV; ! Decl := ! Make_Full_Type_Declaration (Loc, ! Defining_Identifier => ! Obj_Ptr, ! Type_Definition => ! Make_Access_To_Object_Definition (Loc, ! Subtype_Indication => ! New_Reference_To (Rec_Typ, Loc))); ! Set_Debug_Info_Needed (Defining_Identifier (Decl)); ! Prepend_To (Decls, Decl); ! end Add_Object_Pointer; ----------------------- -- Build_Accept_Body -- *************** package body Exp_Ch9 is *** 979,985 **** -- but it does have an activation chain on which to store the tasks -- temporarily. On successful return, the tasks on this chain are -- moved to the chain passed in by the caller. We do not build an ! -- Activatation_Chain_Entity for an N_Extended_Return_Statement, -- because we do not want to build a call to Activate_Tasks. Task -- activation is the responsibility of the caller. --- 856,862 ---- -- but it does have an activation chain on which to store the tasks -- temporarily. On successful return, the tasks on this chain are -- moved to the chain passed in by the caller. We do not build an ! -- Activation_Chain_Entity for an N_Extended_Return_Statement, -- because we do not want to build a call to Activate_Tasks. Task -- activation is the responsibility of the caller. *************** package body Exp_Ch9 is *** 1008,1074 **** Pid : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); ! Index_Spec : constant Node_Id := Entry_Index_Specification ! (Ent_Formals); ! Op_Decls : constant List_Id := New_List; ! Bdef : Entity_Id; ! Bspec : Node_Id; ! EBF : Node_Id; begin ! Bdef := ! Make_Defining_Identifier (Loc, ! Chars => Chars (Barrier_Function (Ent))); ! Bspec := Build_Barrier_Function_Specification (Bdef, Loc); ! ! -- ! -- ! -- ! -- Add discriminal and private renamings. These names have ! -- already been used to expand references to discriminants ! -- and private data. ! ! Add_Discriminal_Declarations (Op_Decls, Pid, Name_uObject, Loc); ! Add_Private_Declarations (Op_Decls, Pid, Name_uObject, Loc); ! Add_Object_Pointer (Op_Decls, Pid, Loc); ! ! -- If this is the barrier for an entry family, the entry index is ! -- visible in the body of the barrier. Create a local variable that ! -- converts the entry index (which is the last formal of the barrier ! -- function) into the appropriate offset into the entry array. The ! -- entry index constant must be set, as for the entry body, so that ! -- local references to the entry index are correctly replaced with ! -- the local variable. This parallels what is done for entry bodies. ! if Present (Index_Spec) then ! declare ! Index_Id : constant Entity_Id := Defining_Identifier (Index_Spec); ! Index_Con : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('J')); ! begin ! Set_Entry_Index_Constant (Index_Id, Index_Con); ! Append_List_To (Op_Decls, ! Index_Constant_Declaration (N, Index_Id, Pid)); ! end; ! end if; -- Note: the condition in the barrier function needs to be properly -- processed for the C/Fortran boolean possibility, but this happens -- automatically since the return statement does this normalization. ! EBF := Make_Subprogram_Body (Loc, ! Specification => Bspec, Declarations => Op_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Simple_Return_Statement (Loc, Expression => Condition (Ent_Formals))))); ! Set_Is_Entry_Barrier_Function (EBF); ! return EBF; end Build_Barrier_Function; ------------------------------------------ --- 885,921 ---- Pid : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); + Func_Id : constant Entity_Id := Barrier_Function (Ent); Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); ! Op_Decls : constant List_Id := New_List; ! Func_Body : Node_Id; begin ! -- Add a declaration for the Protection object, renaming declarations ! -- for the discriminals and privals and finally a declaration for the ! -- entry family index (if applicable). ! Install_Private_Data_Declarations ! (Loc, Func_Id, Pid, N, Op_Decls, True, Ekind (Ent) = E_Entry_Family); -- Note: the condition in the barrier function needs to be properly -- processed for the C/Fortran boolean possibility, but this happens -- automatically since the return statement does this normalization. ! Func_Body := Make_Subprogram_Body (Loc, ! Specification => ! Build_Barrier_Function_Specification (Loc, ! Make_Defining_Identifier (Loc, Chars (Func_Id))), Declarations => Op_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Simple_Return_Statement (Loc, Expression => Condition (Ent_Formals))))); ! Set_Is_Entry_Barrier_Function (Func_Body); ! ! return Func_Body; end Build_Barrier_Function; ------------------------------------------ *************** package body Exp_Ch9 is *** 1076,1100 **** ------------------------------------------ function Build_Barrier_Function_Specification ! (Def_Id : Entity_Id; ! Loc : Source_Ptr) return Node_Id is begin ! Set_Needs_Debug_Info (Def_Id); return Make_Function_Specification (Loc, Defining_Unit_Name => Def_Id, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, ! Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), Parameter_Type => New_Reference_To (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, ! Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE), Parameter_Type => New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), ! Result_Definition => New_Reference_To (Standard_Boolean, Loc)); end Build_Barrier_Function_Specification; -------------------------- --- 923,951 ---- ------------------------------------------ function Build_Barrier_Function_Specification ! (Loc : Source_Ptr; ! Def_Id : Entity_Id) return Node_Id is begin ! Set_Debug_Info_Needed (Def_Id); ! return Make_Function_Specification (Loc, Defining_Unit_Name => Def_Id, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, Name_uO), Parameter_Type => New_Reference_To (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, Name_uE), Parameter_Type => New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), ! Result_Definition => ! New_Reference_To (Standard_Boolean, Loc)); end Build_Barrier_Function_Specification; -------------------------- *************** package body Exp_Ch9 is *** 1257,1262 **** --- 1108,1441 ---- return Ecount; end Build_Entry_Count_Expression; + ----------------------- + -- Build_Entry_Names -- + ----------------------- + + function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Conc_Typ); + B_Decls : List_Id; + B_Stmts : List_Id; + Comp : Node_Id; + Index : Entity_Id; + Index_Typ : RE_Id; + Typ : Entity_Id := Conc_Typ; + + procedure Build_Entry_Family_Name (Id : Entity_Id); + -- Generate: + -- for Lnn in Family_Low .. Family_High loop + -- Inn := Inn + 1; + -- Set_Entry_Name + -- (_init._object, Inn, new String (" " & Lnn'Img)); + -- _init._task_id + -- end loop; + -- Note that the bounds of the range may reference discriminants. The + -- above construct is added directly to the statements of the block. + + procedure Build_Entry_Name (Id : Entity_Id); + -- Generate: + -- Inn := Inn + 1; + -- Set_Entry_Name (_init._task_id, Inn, new String (""); + -- _init._object + -- The above construct is added directly to the statements of the block. + + function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id; + -- Generate the call to the runtime routine Set_Entry_Name with actuals + -- _init._task_id or _init._object, Inn and Arg3. + + function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id; + -- Given a protected type or its corresponding record, find the type of + -- field _object. + + procedure Increment_Index (Stmts : List_Id); + -- Generate the following and add it to Stmts + -- Inn := Inn + 1; + + ----------------------------- + -- Build_Entry_Family_Name -- + ----------------------------- + + procedure Build_Entry_Family_Name (Id : Entity_Id) is + Def : constant Node_Id := + Discrete_Subtype_Definition (Parent (Id)); + L_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + L_Stmts : constant List_Id := New_List; + Val : Node_Id; + + function Build_Range (Def : Node_Id) return Node_Id; + -- Given a discrete subtype definition of an entry family, generate a + -- range node which covers the range of Def's type. + + ----------------- + -- Build_Range -- + ----------------- + + function Build_Range (Def : Node_Id) return Node_Id is + High : Node_Id := Type_High_Bound (Etype (Def)); + Low : Node_Id := Type_Low_Bound (Etype (Def)); + + begin + -- If a bound references a discriminant, generate an identifier + -- with the same name. Resolution will map it to the formals of + -- the init proc. + + if Is_Entity_Name (Low) + and then Ekind (Entity (Low)) = E_Discriminant + then + Low := Make_Identifier (Loc, Chars (Low)); + else + Low := New_Copy_Tree (Low); + end if; + + if Is_Entity_Name (High) + and then Ekind (Entity (High)) = E_Discriminant + then + High := Make_Identifier (Loc, Chars (High)); + else + High := New_Copy_Tree (High); + end if; + + return + Make_Range (Loc, + Low_Bound => Low, + High_Bound => High); + end Build_Range; + + -- Start of processing for Build_Entry_Family_Name + + begin + Get_Name_String (Chars (Id)); + + if Is_Enumeration_Type (Etype (Def)) then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ' '; + end if; + + -- Generate: + -- new String'("" & Lnn'Img); + + Val := + Make_Allocator (Loc, + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Reference_To (Standard_String, Loc), + Expression => + Make_Op_Concat (Loc, + Left_Opnd => + Make_String_Literal (Loc, + String_From_Name_Buffer), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (L_Id, Loc), + Attribute_Name => Name_Img)))); + + Increment_Index (L_Stmts); + Append_To (L_Stmts, Build_Set_Entry_Name_Call (Val)); + + -- Generate: + -- for Lnn in Family_Low .. Family_High loop + -- Inn := Inn + 1; + -- Set_Entry_Name (_init._task_id, Inn, ); + -- end loop; + + Append_To (B_Stmts, + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => L_Id, + Discrete_Subtype_Definition => + Build_Range (Def))), + Statements => L_Stmts, + End_Label => Empty)); + end Build_Entry_Family_Name; + + ---------------------- + -- Build_Entry_Name -- + ---------------------- + + procedure Build_Entry_Name (Id : Entity_Id) is + Val : Node_Id; + + begin + Get_Name_String (Chars (Id)); + Val := + Make_Allocator (Loc, + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Reference_To (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + String_From_Name_Buffer))); + + Increment_Index (B_Stmts); + Append_To (B_Stmts, Build_Set_Entry_Name_Call (Val)); + end Build_Entry_Name; + + ------------------------------- + -- Build_Set_Entry_Name_Call -- + ------------------------------- + + function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id is + Arg1 : Name_Id; + Proc : RE_Id; + + begin + -- Determine the proper name for the first argument and the RTS + -- routine to call. + + if Is_Protected_Type (Typ) then + Arg1 := Name_uObject; + Proc := RO_PE_Set_Entry_Name; + + else pragma Assert (Is_Task_Type (Typ)); + Arg1 := Name_uTask_Id; + Proc := RO_TS_Set_Entry_Name; + end if; + + -- Generate: + -- Set_Entry_Name (_init.Arg1, Inn, Arg3); + + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (Proc), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, -- _init._object + Prefix => -- _init._task_id + Make_Identifier (Loc, Name_uInit), + Selector_Name => + Make_Identifier (Loc, Arg1)), + New_Reference_To (Index, Loc), -- Inn + Arg3)); -- Val + end Build_Set_Entry_Name_Call; + + -------------------------- + -- Find_Protection_Type -- + -------------------------- + + function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is + Comp : Entity_Id; + Typ : Entity_Id := Conc_Typ; + + begin + if Is_Concurrent_Type (Typ) then + Typ := Corresponding_Record_Type (Typ); + end if; + + Comp := First_Component (Typ); + while Present (Comp) loop + if Chars (Comp) = Name_uObject then + return Base_Type (Etype (Comp)); + end if; + + Next_Component (Comp); + end loop; + + -- The corresponding record of a protected type should always have an + -- _object field. + + raise Program_Error; + end Find_Protection_Type; + + --------------------- + -- Increment_Index -- + --------------------- + + procedure Increment_Index (Stmts : List_Id) is + begin + -- Generate: + -- Inn := Inn + 1; + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Index, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => + New_Reference_To (Index, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, 1)))); + end Increment_Index; + + -- Start of processing for Build_Entry_Names + + begin + -- Retrieve the original concurrent type + + if Is_Concurrent_Record_Type (Typ) then + Typ := Corresponding_Concurrent_Type (Typ); + end if; + + pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ)); + + -- Nothing to do if the type has no entries + + if not Has_Entries (Typ) then + return Empty; + end if; + + -- Avoid generating entry names for a protected type with only one entry + + if Is_Protected_Type (Typ) + and then Find_Protection_Type (Typ) /= RTE (RE_Protection_Entries) + then + return Empty; + end if; + + Index := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + + -- Step 1: Generate the declaration of the index variable: + -- Inn : Protected_Entry_Index := 0; + -- or + -- Inn : Task_Entry_Index := 0; + + if Is_Protected_Type (Typ) then + Index_Typ := RE_Protected_Entry_Index; + else + Index_Typ := RE_Task_Entry_Index; + end if; + + B_Decls := New_List; + Append_To (B_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Index, + Object_Definition => + New_Reference_To (RTE (Index_Typ), Loc), + Expression => + Make_Integer_Literal (Loc, 0))); + + B_Stmts := New_List; + + -- Step 2: Generate a call to Set_Entry_Name for each entry and entry + -- family member. + + Comp := First_Entity (Typ); + while Present (Comp) loop + if Ekind (Comp) = E_Entry then + Build_Entry_Name (Comp); + + elsif Ekind (Comp) = E_Entry_Family then + Build_Entry_Family_Name (Comp); + end if; + + Next_Entity (Comp); + end loop; + + -- Step 3: Wrap the statements in a block + + return + Make_Block_Statement (Loc, + Declarations => B_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => B_Stmts)); + end Build_Entry_Names; + --------------------------- -- Build_Parameter_Block -- --------------------------- *************** package body Exp_Ch9 is *** 1362,1505 **** return Rec_Nam; end Build_Parameter_Block; ! ------------------------ ! -- Build_Wrapper_Body -- ! ------------------------ ! function Build_Wrapper_Body ! (Loc : Source_Ptr; ! Proc_Nam : Entity_Id; ! Obj_Typ : Entity_Id; ! Formals : List_Id) return Node_Id is ! Actuals : List_Id := No_List; ! Body_Spec : Node_Id; ! Conv_Id : Node_Id; ! First_Formal : Node_Id; ! Formal : Node_Id; ! begin ! Body_Spec := Build_Wrapper_Spec (Loc, Proc_Nam, Obj_Typ, Formals); ! -- If we did not generate the specification do have nothing else to do ! if Body_Spec = Empty then ! return Empty; ! end if; ! -- Map formals to actuals. Use the list built for the wrapper spec, ! -- skipping the object notation parameter. ! First_Formal := First (Parameter_Specifications (Body_Spec)); ! Formal := First_Formal; ! Next (Formal); ! if Present (Formal) then ! Actuals := New_List; ! while Present (Formal) loop ! Append_To (Actuals, ! Make_Identifier (Loc, Chars => ! Chars (Defining_Identifier (Formal)))); Next (Formal); - end loop; - end if; ! -- An access-to-variable first parameter will require an explicit ! -- dereference in the unchecked conversion. This case occurs when ! -- a protected entry wrapper must override an interface-level ! -- procedure with interface access as first parameter. ! -- SubprgName (O.all).Proc_Nam (Formal_1 .. Formal_N) ! if Nkind (Parameter_Type (First_Formal)) = N_Access_Definition then ! Conv_Id := ! Make_Explicit_Dereference (Loc, ! Prefix => ! Make_Identifier (Loc, Chars => Name_uO)); else ! Conv_Id := ! Make_Identifier (Loc, Chars => Name_uO); end if; ! if Ekind (Proc_Nam) = E_Function then ! return ! Make_Subprogram_Body (Loc, ! Specification => Body_Spec, ! Declarations => Empty_List, ! Handled_Statement_Sequence => ! Make_Handled_Sequence_Of_Statements (Loc, ! Statements => ! New_List ( ! Make_Simple_Return_Statement (Loc, ! Make_Function_Call (Loc, ! Name => ! Make_Selected_Component (Loc, ! Prefix => ! Unchecked_Convert_To ( ! Corresponding_Concurrent_Type (Obj_Typ), ! Conv_Id), ! Selector_Name => ! New_Reference_To (Proc_Nam, Loc)), ! Parameter_Associations => Actuals))))); ! else ! return ! Make_Subprogram_Body (Loc, ! Specification => Body_Spec, ! Declarations => Empty_List, ! Handled_Statement_Sequence => ! Make_Handled_Sequence_Of_Statements (Loc, ! Statements => ! New_List ( ! Make_Procedure_Call_Statement (Loc, ! Name => ! Make_Selected_Component (Loc, ! Prefix => ! Unchecked_Convert_To ( ! Corresponding_Concurrent_Type (Obj_Typ), ! Conv_Id), ! Selector_Name => ! New_Reference_To (Proc_Nam, Loc)), ! Parameter_Associations => Actuals)))); end if; ! end Build_Wrapper_Body; ------------------------ -- Build_Wrapper_Spec -- ------------------------ function Build_Wrapper_Spec ! (Loc : Source_Ptr; ! Proc_Nam : Entity_Id; ! Obj_Typ : Entity_Id; ! Formals : List_Id) return Node_Id is ! New_Name_Id : constant Entity_Id := ! Make_Defining_Identifier (Loc, Chars (Proc_Nam)); ! ! First_Param : Node_Id := Empty; ! Iface : Entity_Id; ! Iface_Elmt : Elmt_Id := No_Elmt; ! New_Formals : List_Id; ! Obj_Param : Node_Id; ! Obj_Param_Typ : Node_Id; ! Iface_Prim_Op : Entity_Id; ! Iface_Prim_Op_Elmt : Elmt_Id; function Overriding_Possible ! (Iface_Prim_Op : Entity_Id; ! Proc_Nam : Entity_Id) return Boolean; ! -- Determine whether a primitive operation can be overriden by the ! -- wrapper. Iface_Prim_Op is the candidate primitive operation of an ! -- abstract interface type, Proc_Nam is the generated entry wrapper. ! function Replicate_Entry_Formals (Loc : Source_Ptr; Formals : List_Id) return List_Id; ! -- An explicit parameter replication is required due to the ! -- Is_Entry_Formal flag being set for all the formals. The explicit -- replication removes the flag that would otherwise cause a different -- path of analysis. --- 1541,1781 ---- return Rec_Nam; end Build_Parameter_Block; ! -------------------------- ! -- Build_Wrapper_Bodies -- ! -------------------------- ! procedure Build_Wrapper_Bodies ! (Loc : Source_Ptr; ! Typ : Entity_Id; ! N : Node_Id) is ! Rec_Typ : Entity_Id; ! function Build_Wrapper_Body ! (Loc : Source_Ptr; ! Subp_Id : Entity_Id; ! Obj_Typ : Entity_Id; ! Formals : List_Id) return Node_Id; ! -- Ada 2005 (AI-345): Build the body that wraps a primitive operation ! -- associated with a protected or task type. Subp_Id is the subprogram ! -- name which will be wrapped. Obj_Typ is the type of the new formal ! -- parameter which handles dispatching and object notation. Formals are ! -- the original formals of Subp_Id which will be explicitly replicated. ! ------------------------ ! -- Build_Wrapper_Body -- ! ------------------------ ! function Build_Wrapper_Body ! (Loc : Source_Ptr; ! Subp_Id : Entity_Id; ! Obj_Typ : Entity_Id; ! Formals : List_Id) return Node_Id ! is ! Body_Spec : Node_Id; ! begin ! Body_Spec := Build_Wrapper_Spec (Loc, Subp_Id, Obj_Typ, Formals); ! -- The subprogram is not overriding or is not a primitive declared ! -- between two views. ! if No (Body_Spec) then ! return Empty; ! end if; ! declare ! Actuals : List_Id := No_List; ! Conv_Id : Node_Id; ! First_Formal : Node_Id; ! Formal : Node_Id; ! Nam : Node_Id; ! begin ! -- Map formals to actuals. Use the list built for the wrapper ! -- spec, skipping the object notation parameter. ! ! First_Formal := First (Parameter_Specifications (Body_Spec)); + Formal := First_Formal; Next (Formal); ! if Present (Formal) then ! Actuals := New_List; ! while Present (Formal) loop ! Append_To (Actuals, ! Make_Identifier (Loc, Chars => ! Chars (Defining_Identifier (Formal)))); ! Next (Formal); ! end loop; ! end if; ! ! -- Special processing for primitives declared between a private ! -- type and its completion. ! ! if Is_Private_Primitive_Subprogram (Subp_Id) then ! if No (Actuals) then ! Actuals := New_List; ! end if; ! ! Prepend_To (Actuals, ! Unchecked_Convert_To ( ! Corresponding_Concurrent_Type (Obj_Typ), ! Make_Identifier (Loc, Name_uO))); ! ! Nam := New_Reference_To (Subp_Id, Loc); ! ! else ! -- An access-to-variable object parameter requires an explicit ! -- dereference in the unchecked conversion. This case occurs ! -- when a protected entry wrapper must override an interface ! -- level procedure with interface access as first parameter. ! ! -- O.all.Subp_Id (Formal_1, ..., Formal_N) ! ! if Nkind (Parameter_Type (First_Formal)) = ! N_Access_Definition ! then ! Conv_Id := ! Make_Explicit_Dereference (Loc, ! Prefix => Make_Identifier (Loc, Name_uO)); ! else ! Conv_Id := Make_Identifier (Loc, Name_uO); ! end if; ! ! Nam := ! Make_Selected_Component (Loc, ! Prefix => ! Unchecked_Convert_To ( ! Corresponding_Concurrent_Type (Obj_Typ), ! Conv_Id), ! Selector_Name => ! New_Reference_To (Subp_Id, Loc)); ! end if; ! ! -- Create the subprogram body ! ! if Ekind (Subp_Id) = E_Function then ! return ! Make_Subprogram_Body (Loc, ! Specification => Body_Spec, ! Declarations => Empty_List, ! Handled_Statement_Sequence => ! Make_Handled_Sequence_Of_Statements (Loc, ! Statements => New_List ( ! Make_Simple_Return_Statement (Loc, ! Make_Function_Call (Loc, ! Name => Nam, ! Parameter_Associations => Actuals))))); ! ! else ! return ! Make_Subprogram_Body (Loc, ! Specification => Body_Spec, ! Declarations => Empty_List, ! Handled_Statement_Sequence => ! Make_Handled_Sequence_Of_Statements (Loc, ! Statements => New_List ( ! Make_Procedure_Call_Statement (Loc, ! Name => Nam, ! Parameter_Associations => Actuals)))); ! end if; ! end; ! end Build_Wrapper_Body; ! ! -- Start of processing for Build_Wrapper_Bodies ! ! begin ! if Is_Concurrent_Type (Typ) then ! Rec_Typ := Corresponding_Record_Type (Typ); else ! Rec_Typ := Typ; end if; ! -- Generate wrapper bodies for a concurrent type which implements an ! -- interface. ! ! if Present (Interfaces (Rec_Typ)) then ! declare ! Insert_Nod : Node_Id; ! Prim : Entity_Id; ! Prim_Elmt : Elmt_Id; ! Prim_Decl : Node_Id; ! Subp : Entity_Id; ! Wrap_Body : Node_Id; ! Wrap_Id : Entity_Id; ! ! begin ! Insert_Nod := N; ! ! -- Examine all primitive operations of the corresponding record ! -- type, looking for wrapper specs. Generate bodies in order to ! -- complete them. ! ! Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ)); ! while Present (Prim_Elmt) loop ! Prim := Node (Prim_Elmt); ! ! if (Ekind (Prim) = E_Function ! or else Ekind (Prim) = E_Procedure) ! and then Is_Primitive_Wrapper (Prim) ! then ! Subp := Wrapped_Entity (Prim); ! Prim_Decl := Parent (Parent (Prim)); ! ! Wrap_Body := ! Build_Wrapper_Body (Loc, ! Subp_Id => Subp, ! Obj_Typ => Rec_Typ, ! Formals => Parameter_Specifications (Parent (Subp))); ! Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body)); ! ! Set_Corresponding_Spec (Wrap_Body, Prim); ! Set_Corresponding_Body (Prim_Decl, Wrap_Id); ! ! Insert_After (Insert_Nod, Wrap_Body); ! Insert_Nod := Wrap_Body; ! ! Analyze (Wrap_Body); ! end if; ! ! Next_Elmt (Prim_Elmt); ! end loop; ! end; end if; ! end Build_Wrapper_Bodies; ------------------------ -- Build_Wrapper_Spec -- ------------------------ function Build_Wrapper_Spec ! (Loc : Source_Ptr; ! Subp_Id : Entity_Id; ! Obj_Typ : Entity_Id; ! Formals : List_Id) return Node_Id is ! First_Param : Node_Id; ! Iface : Entity_Id; ! Iface_Elmt : Elmt_Id; ! Iface_Op : Entity_Id; ! Iface_Op_Elmt : Elmt_Id; function Overriding_Possible ! (Iface_Op : Entity_Id; ! Wrapper : Entity_Id) return Boolean; ! -- Determine whether a primitive operation can be overridden by Wrapper. ! -- Iface_Op is the candidate primitive operation of an interface type, ! -- Wrapper is the generated entry wrapper. ! function Replicate_Formals (Loc : Source_Ptr; Formals : List_Id) return List_Id; ! -- An explicit parameter replication is required due to the Is_Entry_ ! -- Formal flag being set for all the formals of an entry. The explicit -- replication removes the flag that would otherwise cause a different -- path of analysis. *************** package body Exp_Ch9 is *** 1508,1525 **** ------------------------- function Overriding_Possible ! (Iface_Prim_Op : Entity_Id; ! Proc_Nam : Entity_Id) return Boolean is ! Prim_Op_Spec : constant Node_Id := Parent (Iface_Prim_Op); ! Proc_Spec : constant Node_Id := Parent (Proc_Nam); ! ! Is_Access_To_Variable : Boolean; ! Is_Out_Present : Boolean; function Type_Conformant_Parameters ! (Prim_Op_Param_Specs : List_Id; ! Proc_Param_Specs : List_Id) return Boolean; -- Determine whether the parameters of the generated entry wrapper -- and those of a primitive operation are type conformant. During -- this check, the first parameter of the primitive operation is --- 1784,1798 ---- ------------------------- function Overriding_Possible ! (Iface_Op : Entity_Id; ! Wrapper : Entity_Id) return Boolean is ! Iface_Op_Spec : constant Node_Id := Parent (Iface_Op); ! Wrapper_Spec : constant Node_Id := Parent (Wrapper); function Type_Conformant_Parameters ! (Iface_Op_Params : List_Id; ! Wrapper_Params : List_Id) return Boolean; -- Determine whether the parameters of the generated entry wrapper -- and those of a primitive operation are type conformant. During -- this check, the first parameter of the primitive operation is *************** package body Exp_Ch9 is *** 1530,1569 **** -------------------------------- function Type_Conformant_Parameters ! (Prim_Op_Param_Specs : List_Id; ! Proc_Param_Specs : List_Id) return Boolean is ! Prim_Op_Param : Node_Id; ! Prim_Op_Typ : Entity_Id; ! Proc_Param : Node_Id; ! Proc_Typ : Entity_Id; begin -- Skip the first parameter of the primitive operation ! Prim_Op_Param := Next (First (Prim_Op_Param_Specs)); ! Proc_Param := First (Proc_Param_Specs); ! while Present (Prim_Op_Param) ! and then Present (Proc_Param) loop ! Prim_Op_Typ := Find_Parameter_Type (Prim_Op_Param); ! Proc_Typ := Find_Parameter_Type (Proc_Param); -- The two parameters must be mode conformant if not Conforming_Types ! (Prim_Op_Typ, Proc_Typ, Mode_Conformant) then return False; end if; ! Next (Prim_Op_Param); ! Next (Proc_Param); end loop; -- One of the lists is longer than the other ! if Present (Prim_Op_Param) or else Present (Proc_Param) then return False; end if; --- 1803,1842 ---- -------------------------------- function Type_Conformant_Parameters ! (Iface_Op_Params : List_Id; ! Wrapper_Params : List_Id) return Boolean is ! Iface_Op_Param : Node_Id; ! Iface_Op_Typ : Entity_Id; ! Wrapper_Param : Node_Id; ! Wrapper_Typ : Entity_Id; begin -- Skip the first parameter of the primitive operation ! Iface_Op_Param := Next (First (Iface_Op_Params)); ! Wrapper_Param := First (Wrapper_Params); ! while Present (Iface_Op_Param) ! and then Present (Wrapper_Param) loop ! Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param); ! Wrapper_Typ := Find_Parameter_Type (Wrapper_Param); -- The two parameters must be mode conformant if not Conforming_Types ! (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant) then return False; end if; ! Next (Iface_Op_Param); ! Next (Wrapper_Param); end loop; -- One of the lists is longer than the other ! if Present (Iface_Op_Param) or else Present (Wrapper_Param) then return False; end if; *************** package body Exp_Ch9 is *** 1573,1631 **** -- Start of processing for Overriding_Possible begin ! if Chars (Iface_Prim_Op) /= Chars (Proc_Nam) then return False; end if; ! -- Special check for protected procedures: If an inherited subprogram ! -- is implemented by a protected procedure or an entry, then the ! -- first parameter of the inherited subprogram shall be of mode OUT ! -- or IN OUT, or an access-to-variable parameter. ! ! if Ekind (Iface_Prim_Op) = E_Procedure then ! ! Is_Out_Present := ! Present (Parameter_Specifications (Prim_Op_Spec)) ! and then ! Out_Present (First (Parameter_Specifications (Prim_Op_Spec))); ! ! Is_Access_To_Variable := ! Present (Parameter_Specifications (Prim_Op_Spec)) ! and then ! Nkind (Parameter_Type ! (First ! (Parameter_Specifications (Prim_Op_Spec)))) = ! N_Access_Definition; ! if not Is_Out_Present ! and then not Is_Access_To_Variable ! then ! return False; ! end if; end if; ! return Type_Conformant_Parameters ( ! Parameter_Specifications (Prim_Op_Spec), ! Parameter_Specifications (Proc_Spec)); end Overriding_Possible; ! ----------------------------- ! -- Replicate_Entry_Formals -- ! ----------------------------- ! function Replicate_Entry_Formals (Loc : Source_Ptr; Formals : List_Id) return List_Id is New_Formals : constant List_Id := New_List; Formal : Node_Id; begin Formal := First (Formals); while Present (Formal) loop -- Create an explicit copy of the entry parameter Append_To (New_Formals, Make_Parameter_Specification (Loc, Defining_Identifier => --- 1846,1923 ---- -- Start of processing for Overriding_Possible begin ! if Chars (Iface_Op) /= Chars (Wrapper) then return False; end if; ! -- If an inherited subprogram is implemented by a protected procedure ! -- or an entry, then the first parameter of the inherited subprogram ! -- shall be of mode OUT or IN OUT, or access-to-variable parameter. ! if Ekind (Iface_Op) = E_Procedure ! and then Present (Parameter_Specifications (Iface_Op_Spec)) ! then ! declare ! Obj_Param : constant Node_Id := ! First (Parameter_Specifications (Iface_Op_Spec)); ! begin ! if not Out_Present (Obj_Param) ! and then Nkind (Parameter_Type (Obj_Param)) /= ! N_Access_Definition ! then ! return False; ! end if; ! end; end if; ! return ! Type_Conformant_Parameters ( ! Parameter_Specifications (Iface_Op_Spec), ! Parameter_Specifications (Wrapper_Spec)); end Overriding_Possible; ! ----------------------- ! -- Replicate_Formals -- ! ----------------------- ! function Replicate_Formals (Loc : Source_Ptr; Formals : List_Id) return List_Id is New_Formals : constant List_Id := New_List; Formal : Node_Id; + Param_Type : Node_Id; begin Formal := First (Formals); + + -- Skip the object parameter when dealing with primitives declared + -- between two views. + + if Is_Private_Primitive_Subprogram (Subp_Id) then + Formal := Next (Formal); + end if; + while Present (Formal) loop -- Create an explicit copy of the entry parameter + -- When creating the wrapper subprogram for a primitive operation + -- of a protected interface we must construct an equivalent + -- signature to that of the overriding operation. For regular + -- parameters we can just use the type of the formal, but for + -- access to subprogram parameters we need to reanalyze the + -- parameter type to create local entities for the signature of + -- the subprogram type. Using the entities of the overriding + -- subprogram will result in out-of-scope errors in the back-end. + + if Nkind (Parameter_Type (Formal)) = N_Access_Definition then + Param_Type := Copy_Separate_Tree (Parameter_Type (Formal)); + else + Param_Type := + New_Reference_To (Etype (Parameter_Type (Formal)), Loc); + end if; + Append_To (New_Formals, Make_Parameter_Specification (Loc, Defining_Identifier => *************** package body Exp_Ch9 is *** 1633,1799 **** Chars => Chars (Defining_Identifier (Formal))), In_Present => In_Present (Formal), Out_Present => Out_Present (Formal), ! Parameter_Type => New_Reference_To (Etype ( ! Parameter_Type (Formal)), Loc))); Next (Formal); end loop; return New_Formals; ! end Replicate_Entry_Formals; -- Start of processing for Build_Wrapper_Spec begin ! -- The mode is determined by the first parameter of the interface-level ! -- procedure that the current entry is trying to override. ! ! pragma Assert (Is_Non_Empty_List (Abstract_Interface_List (Obj_Typ))); ! ! -- We must examine all the protected operations of the implemented ! -- interfaces in order to discover a possible overriding candidate. ! ! Iface := Etype (First (Abstract_Interface_List (Obj_Typ))); ! ! Examine_Parents : loop ! if Present (Primitive_Operations (Iface)) then ! Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); ! while Present (Iface_Prim_Op_Elmt) loop ! Iface_Prim_Op := Node (Iface_Prim_Op_Elmt); ! ! if not Is_Predefined_Dispatching_Operation (Iface_Prim_Op) then ! while Present (Alias (Iface_Prim_Op)) loop ! Iface_Prim_Op := Alias (Iface_Prim_Op); ! end loop; ! ! -- The current primitive operation can be overriden by the ! -- generated entry wrapper. ! ! if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then ! First_Param := First (Parameter_Specifications ! (Parent (Iface_Prim_Op))); ! goto Found; ! end if; ! end if; ! Next_Elmt (Iface_Prim_Op_Elmt); ! end loop; ! end if; ! exit Examine_Parents when Etype (Iface) = Iface; ! Iface := Etype (Iface); ! end loop Examine_Parents; ! if Present (Abstract_Interfaces ! (Corresponding_Record_Type (Scope (Proc_Nam)))) ! then ! Iface_Elmt := First_Elmt ! (Abstract_Interfaces ! (Corresponding_Record_Type (Scope (Proc_Nam)))); ! Examine_Interfaces : while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); if Present (Primitive_Operations (Iface)) then ! Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); ! while Present (Iface_Prim_Op_Elmt) loop ! Iface_Prim_Op := Node (Iface_Prim_Op_Elmt); ! if not Is_Predefined_Dispatching_Operation ! (Iface_Prim_Op) ! then ! while Present (Alias (Iface_Prim_Op)) loop ! Iface_Prim_Op := Alias (Iface_Prim_Op); ! end loop; ! -- The current primitive operation can be overriden by -- the generated entry wrapper. ! if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then ! First_Param := First (Parameter_Specifications ! (Parent (Iface_Prim_Op))); ! goto Found; end if; end if; ! Next_Elmt (Iface_Prim_Op_Elmt); end loop; end if; Next_Elmt (Iface_Elmt); ! end loop Examine_Interfaces; end if; ! -- Return if no interface primitive can be overriden ! return Empty; ! <> ! New_Formals := Replicate_Entry_Formals (Loc, Formals); ! -- ??? Certain source packages contain protected or task types that do ! -- not implement any interfaces and are compiled with the -gnat05 ! -- switch. In this case, a default first parameter is created. ! if Present (First_Param) then ! if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then ! Obj_Param_Typ := ! Make_Access_Definition (Loc, ! Subtype_Mark => ! New_Reference_To (Obj_Typ, Loc)); else ! Obj_Param_Typ := New_Reference_To (Obj_Typ, Loc); end if; ! Obj_Param := ! Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, Name_uO), ! In_Present => In_Present (First_Param), ! Out_Present => Out_Present (First_Param), ! Parameter_Type => Obj_Param_Typ); ! else ! Obj_Param := ! Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, Name_uO), ! In_Present => True, ! Out_Present => True, ! Parameter_Type => New_Reference_To (Obj_Typ, Loc)); end if; ! Prepend_To (New_Formals, Obj_Param); ! -- Minimum decoration needed to catch the entity in ! -- Sem_Ch6.Override_Dispatching_Operation ! if Ekind (Proc_Nam) = E_Procedure ! or else Ekind (Proc_Nam) = E_Entry then ! Set_Ekind (New_Name_Id, E_Procedure); ! Set_Is_Primitive_Wrapper (New_Name_Id); ! Set_Wrapped_Entity (New_Name_Id, Proc_Nam); ! return ! Make_Procedure_Specification (Loc, ! Defining_Unit_Name => New_Name_Id, ! Parameter_Specifications => New_Formals); ! else pragma Assert (Ekind (Proc_Nam) = E_Function); ! Set_Ekind (New_Name_Id, E_Function); ! return ! Make_Function_Specification (Loc, ! Defining_Unit_Name => New_Name_Id, ! Parameter_Specifications => New_Formals, ! Result_Definition => ! New_Copy (Result_Definition (Parent (Proc_Nam)))); end if; ! end Build_Wrapper_Spec; --------------------------- -- Build_Find_Body_Index -- --- 1925,2159 ---- Chars => Chars (Defining_Identifier (Formal))), In_Present => In_Present (Formal), Out_Present => Out_Present (Formal), ! Parameter_Type => Param_Type)); Next (Formal); end loop; return New_Formals; ! end Replicate_Formals; -- Start of processing for Build_Wrapper_Spec begin ! -- There is no point in building wrappers for non-tagged concurrent ! -- types. ! pragma Assert (Is_Tagged_Type (Obj_Typ)); ! -- An entry or a protected procedure can override a routine where the ! -- controlling formal is either IN OUT, OUT or is of access-to-variable ! -- type. Since the wrapper must have the exact same signature as that of ! -- the overridden subprogram, we try to find the overriding candidate ! -- and use its controlling formal. ! First_Param := Empty; ! -- Check every implemented interface ! if Present (Interfaces (Obj_Typ)) then ! Iface_Elmt := First_Elmt (Interfaces (Obj_Typ)); ! Search : while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); + -- Check every interface primitive + if Present (Primitive_Operations (Iface)) then ! Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); ! while Present (Iface_Op_Elmt) loop ! Iface_Op := Node (Iface_Op_Elmt); ! -- Ignore predefined primitives ! if not Is_Predefined_Dispatching_Operation (Iface_Op) then ! Iface_Op := Ultimate_Alias (Iface_Op); ! ! -- The current primitive operation can be overridden by -- the generated entry wrapper. ! if Overriding_Possible (Iface_Op, Subp_Id) then ! First_Param := ! First (Parameter_Specifications (Parent (Iface_Op))); ! exit Search; end if; end if; ! Next_Elmt (Iface_Op_Elmt); end loop; end if; Next_Elmt (Iface_Elmt); ! end loop Search; end if; ! -- If the subprogram to be wrapped is not overriding anything or is not ! -- a primitive declared between two views, do not produce anything. This ! -- avoids spurious errors involving overriding. ! if No (First_Param) ! and then not Is_Private_Primitive_Subprogram (Subp_Id) ! then ! return Empty; ! end if; ! declare ! Wrapper_Id : constant Entity_Id := ! Make_Defining_Identifier (Loc, Chars (Subp_Id)); ! New_Formals : List_Id; ! Obj_Param : Node_Id; ! Obj_Param_Typ : Entity_Id; ! begin ! -- Minimum decoration is needed to catch the entity in ! -- Sem_Ch6.Override_Dispatching_Operation. ! if Ekind (Subp_Id) = E_Function then ! Set_Ekind (Wrapper_Id, E_Function); ! else ! Set_Ekind (Wrapper_Id, E_Procedure); ! end if; ! Set_Is_Primitive_Wrapper (Wrapper_Id); ! Set_Wrapped_Entity (Wrapper_Id, Subp_Id); ! Set_Is_Private_Primitive (Wrapper_Id, ! Is_Private_Primitive_Subprogram (Subp_Id)); ! ! -- Process the formals ! ! New_Formals := Replicate_Formals (Loc, Formals); ! ! -- Routine Subp_Id has been found to override an interface primitive. ! -- If the interface operation has an access parameter, create a copy ! -- of it, with the same null exclusion indicator if present. ! ! if Present (First_Param) then ! if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then ! Obj_Param_Typ := ! Make_Access_Definition (Loc, ! Subtype_Mark => ! New_Reference_To (Obj_Typ, Loc)); ! Set_Null_Exclusion_Present (Obj_Param_Typ, ! Null_Exclusion_Present (Parameter_Type (First_Param))); ! ! else ! Obj_Param_Typ := New_Reference_To (Obj_Typ, Loc); ! end if; ! ! Obj_Param := ! Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, ! Chars => Name_uO), ! In_Present => In_Present (First_Param), ! Out_Present => Out_Present (First_Param), ! Parameter_Type => Obj_Param_Typ); ! ! -- If we are dealing with a primitive declared between two views, ! -- create a default parameter. ! ! else pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id)); ! Obj_Param := ! Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, Name_uO), ! In_Present => True, ! Out_Present => Ekind (Subp_Id) /= E_Function, ! Parameter_Type => New_Reference_To (Obj_Typ, Loc)); ! end if; ! ! Prepend_To (New_Formals, Obj_Param); ! ! -- Build the final spec ! ! if Ekind (Subp_Id) = E_Function then ! return ! Make_Function_Specification (Loc, ! Defining_Unit_Name => Wrapper_Id, ! Parameter_Specifications => New_Formals, ! Result_Definition => ! New_Copy (Result_Definition (Parent (Subp_Id)))); else ! return ! Make_Procedure_Specification (Loc, ! Defining_Unit_Name => Wrapper_Id, ! Parameter_Specifications => New_Formals); end if; + end; + end Build_Wrapper_Spec; ! ------------------------- ! -- Build_Wrapper_Specs -- ! ------------------------- ! procedure Build_Wrapper_Specs ! (Loc : Source_Ptr; ! Typ : Entity_Id; ! N : in out Node_Id) ! is ! Def : Node_Id; ! Rec_Typ : Entity_Id; ! ! begin ! if Is_Protected_Type (Typ) then ! Def := Protected_Definition (Parent (Typ)); ! else pragma Assert (Is_Task_Type (Typ)); ! Def := Task_Definition (Parent (Typ)); end if; ! Rec_Typ := Corresponding_Record_Type (Typ); ! -- Generate wrapper specs for a concurrent type which implements an ! -- interface and has visible entries and/or protected procedures. ! if Present (Interfaces (Rec_Typ)) ! and then Present (Def) ! and then Present (Visible_Declarations (Def)) then ! declare ! Decl : Node_Id; ! Wrap_Decl : Node_Id; ! Wrap_Spec : Node_Id; ! begin ! Decl := First (Visible_Declarations (Def)); ! while Present (Decl) loop ! Wrap_Spec := Empty; ! if Nkind (Decl) = N_Entry_Declaration ! and then Ekind (Defining_Identifier (Decl)) = E_Entry ! then ! Wrap_Spec := ! Build_Wrapper_Spec (Loc, ! Subp_Id => Defining_Identifier (Decl), ! Obj_Typ => Rec_Typ, ! Formals => Parameter_Specifications (Decl)); ! elsif Nkind (Decl) = N_Subprogram_Declaration then ! Wrap_Spec := ! Build_Wrapper_Spec (Loc, ! Subp_Id => Defining_Unit_Name (Specification (Decl)), ! Obj_Typ => Rec_Typ, ! Formals => ! Parameter_Specifications (Specification (Decl))); ! end if; ! ! if Present (Wrap_Spec) then ! Wrap_Decl := ! Make_Subprogram_Declaration (Loc, ! Specification => Wrap_Spec); ! ! Insert_After (N, Wrap_Decl); ! N := Wrap_Decl; ! ! Analyze (Wrap_Decl); ! end if; ! ! Next (Decl); ! end loop; ! end; end if; ! end Build_Wrapper_Specs; --------------------------- -- Build_Find_Body_Index -- *************** package body Exp_Ch9 is *** 1935,1941 **** Siz := Empty; Ent := First_Entity (Typ); ! Add_Object_Pointer (Decls, Typ, Loc); while Present (Ent) loop --- 2295,2301 ---- Siz := Empty; Ent := First_Entity (Typ); ! Add_Object_Pointer (Loc, Typ, Decls); while Present (Ent) loop *************** package body Exp_Ch9 is *** 2026,2036 **** -- Ada 2005 (AI-287): Do not set/get the has_master_entity reminder -- in internal scopes, unless present already.. Required for nested ! -- limited aggregates. This could use some more explanation ???? if Ada_Version >= Ada_05 then while Is_Internal (S) loop ! S := Scope (S); end loop; end if; --- 2386,2405 ---- -- Ada 2005 (AI-287): Do not set/get the has_master_entity reminder -- in internal scopes, unless present already.. Required for nested ! -- limited aggregates, where the expansion of task components may ! -- generate inner blocks. If the block is the rewriting of a call ! -- this is valid master. if Ada_Version >= Ada_05 then while Is_Internal (S) loop ! if Nkind (Parent (S)) = N_Block_Statement ! and then ! Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement ! then ! exit; ! else ! S := Scope (S); ! end if; end loop; end if; *************** package body Exp_Ch9 is *** 2101,2106 **** --- 2470,2476 ---- is Loc : constant Source_Ptr := Sloc (N); + Decls : constant List_Id := Declarations (N); End_Lab : constant Node_Id := End_Label (Handled_Statement_Sequence (N)); End_Loc : constant Source_Ptr := *************** package body Exp_Ch9 is *** 2110,2121 **** Han_Loc : Source_Ptr; -- Used for the exception handler, inserted at end of the body ! Op_Decls : constant List_Id := New_List; Edef : Entity_Id; Espec : Node_Id; - Op_Stats : List_Id; Ohandle : Node_Id; ! Complete : Node_Id; begin -- Set the source location on the exception handler only when debugging --- 2480,2491 ---- Han_Loc : Source_Ptr; -- Used for the exception handler, inserted at end of the body ! Op_Decls : constant List_Id := New_List; ! Complete : Node_Id; Edef : Entity_Id; Espec : Node_Id; Ohandle : Node_Id; ! Op_Stats : List_Id; begin -- Set the source location on the exception handler only when debugging *************** package body Exp_Ch9 is *** 2133,2180 **** Edef := Make_Defining_Identifier (Loc, Chars => Chars (Protected_Body_Subprogram (Ent))); ! Espec := Build_Protected_Entry_Specification (Edef, Empty, Loc); ! ! -- ! -- Add object pointer declaration. This is needed by the discriminal and ! -- prival renamings, which should already have been inserted into the ! -- declaration list. ! Add_Object_Pointer (Op_Decls, Pid, Loc); ! -- Add renamings for formals for use by debugger Add_Formal_Renamings (Espec, Op_Decls, Ent, Loc); ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Number_Entries (Pid) > 1 ! or else (Has_Attach_Handler (Pid) and then not Restricted_Profile) ! then ! Complete := New_Reference_To (RTE (RE_Complete_Entry_Body), Loc); ! else ! Complete := ! New_Reference_To (RTE (RE_Complete_Single_Entry_Body), Loc); ! end if; ! Op_Stats := New_List ( ! Make_Block_Statement (Loc, ! Declarations => Declarations (N), ! Handled_Statement_Sequence => ! Handled_Statement_Sequence (N)), ! Make_Procedure_Call_Statement (End_Loc, ! Name => Complete, ! Parameter_Associations => New_List ( ! Make_Attribute_Reference (End_Loc, ! Prefix => ! Make_Selected_Component (End_Loc, ! Prefix => ! Make_Identifier (End_Loc, Name_uObject), ! Selector_Name => ! Make_Identifier (End_Loc, Name_uObject)), Attribute_Name => Name_Unchecked_Access)))); -- When exceptions can not be propagated, we never need to call --- 2503,2555 ---- Edef := Make_Defining_Identifier (Loc, Chars => Chars (Protected_Body_Subprogram (Ent))); ! Espec := ! Build_Protected_Entry_Specification (Loc, Edef, Empty); ! -- Add the following declarations: ! -- type poVP is access poV; ! -- _object : poVP := poVP (_O); ! -- ! -- where _O is the formal parameter associated with the concurrent ! -- object. These declarations are needed for Complete_Entry_Body. ! Add_Object_Pointer (Loc, Pid, Op_Decls); ! -- Add renamings for all formals, the Protection object, discriminals, ! -- privals and the entry index constant for use by debugger. Add_Formal_Renamings (Espec, Op_Decls, Ent, Loc); + Debug_Private_Data_Declarations (Decls); ! case Corresponding_Runtime_Package (Pid) is ! when System_Tasking_Protected_Objects_Entries => ! Complete := ! New_Reference_To (RTE (RE_Complete_Entry_Body), Loc); ! when System_Tasking_Protected_Objects_Single_Entry => ! Complete := ! New_Reference_To (RTE (RE_Complete_Single_Entry_Body), Loc); ! when others => ! raise Program_Error; ! end case; ! Op_Stats := New_List ( ! Make_Block_Statement (Loc, ! Declarations => Decls, ! Handled_Statement_Sequence => ! Handled_Statement_Sequence (N)), ! ! Make_Procedure_Call_Statement (End_Loc, ! Name => Complete, ! Parameter_Associations => New_List ( ! Make_Attribute_Reference (End_Loc, ! Prefix => ! Make_Selected_Component (End_Loc, ! Prefix => ! Make_Identifier (End_Loc, Name_uObject), ! Selector_Name => ! Make_Identifier (End_Loc, Name_uObject)), Attribute_Name => Name_Unchecked_Access)))); -- When exceptions can not be propagated, we never need to call *************** package body Exp_Ch9 is *** 2187,2211 **** Declarations => Op_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, ! Op_Stats, ! End_Label => End_Lab)); else Ohandle := Make_Others_Choice (Loc); Set_All_Others (Ohandle); ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Number_Entries (Pid) > 1 ! or else (Has_Attach_Handler (Pid) and then not Restricted_Profile) ! then ! Complete := ! New_Reference_To (RTE (RE_Exceptional_Complete_Entry_Body), Loc); ! else ! Complete := New_Reference_To ( ! RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); ! end if; -- Create body of entry procedure. The renaming declarations are -- placed ahead of the block that contains the actual entry body. --- 2562,2588 ---- Declarations => Op_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, ! Statements => Op_Stats, ! End_Label => End_Lab)); else Ohandle := Make_Others_Choice (Loc); Set_All_Others (Ohandle); ! case Corresponding_Runtime_Package (Pid) is ! when System_Tasking_Protected_Objects_Entries => ! Complete := ! New_Reference_To ! (RTE (RE_Exceptional_Complete_Entry_Body), Loc); ! when System_Tasking_Protected_Objects_Single_Entry => ! Complete := ! New_Reference_To ! (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); ! ! when others => ! raise Program_Error; ! end case; -- Create body of entry procedure. The renaming declarations are -- placed ahead of the block that contains the actual entry body. *************** package body Exp_Ch9 is *** 2246,2282 **** ----------------------------------------- function Build_Protected_Entry_Specification ! (Def_Id : Entity_Id; ! Ent_Id : Entity_Id; ! Loc : Source_Ptr) return Node_Id is ! P : Entity_Id; begin ! Set_Needs_Debug_Info (Def_Id); ! P := Make_Defining_Identifier (Loc, Name_uP); if Present (Ent_Id) then Append_Elmt (P, Accept_Address (Ent_Id)); end if; ! return Make_Procedure_Specification (Loc, ! Defining_Unit_Name => Def_Id, ! Parameter_Specifications => New_List ( ! Make_Parameter_Specification (Loc, ! Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), ! Parameter_Type => ! New_Reference_To (RTE (RE_Address), Loc)), ! Make_Parameter_Specification (Loc, ! Defining_Identifier => P, ! Parameter_Type => ! New_Reference_To (RTE (RE_Address), Loc)), ! Make_Parameter_Specification (Loc, ! Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE), ! Parameter_Type => ! New_Reference_To (RTE (RE_Protected_Entry_Index), Loc)))); end Build_Protected_Entry_Specification; -------------------------- --- 2623,2661 ---- ----------------------------------------- function Build_Protected_Entry_Specification ! (Loc : Source_Ptr; ! Def_Id : Entity_Id; ! Ent_Id : Entity_Id) return Node_Id is ! P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP); begin ! Set_Debug_Info_Needed (Def_Id); if Present (Ent_Id) then Append_Elmt (P, Accept_Address (Ent_Id)); end if; ! return ! Make_Procedure_Specification (Loc, ! Defining_Unit_Name => Def_Id, ! Parameter_Specifications => New_List ( ! Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, Name_uO), ! Parameter_Type => ! New_Reference_To (RTE (RE_Address), Loc)), ! Make_Parameter_Specification (Loc, ! Defining_Identifier => P, ! Parameter_Type => ! New_Reference_To (RTE (RE_Address), Loc)), ! Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, Name_uE), ! Parameter_Type => ! New_Reference_To (RTE (RE_Protected_Entry_Index), Loc)))); end Build_Protected_Entry_Specification; -------------------------- *************** package body Exp_Ch9 is *** 2286,2312 **** function Build_Protected_Spec (N : Node_Id; Obj_Type : Entity_Id; ! Unprotected : Boolean := False; ! Ident : Entity_Id) return List_Id is ! Loc : constant Source_Ptr := Sloc (N); ! Decl : Node_Id; ! Formal : Entity_Id; ! New_Plist : List_Id; ! New_Param : Node_Id; begin New_Plist := New_List; Formal := First_Formal (Ident); while Present (Formal) loop New_Param := Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), ! In_Present => In_Present (Parent (Formal)), ! Out_Present => Out_Present (Parent (Formal)), ! Parameter_Type => ! New_Reference_To (Etype (Formal), Loc)); if Unprotected then Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); --- 2665,2691 ---- function Build_Protected_Spec (N : Node_Id; Obj_Type : Entity_Id; ! Ident : Entity_Id; ! Unprotected : Boolean := False) return List_Id is ! Loc : constant Source_Ptr := Sloc (N); ! Decl : Node_Id; ! Formal : Entity_Id; ! New_Plist : List_Id; ! New_Param : Node_Id; begin New_Plist := New_List; + Formal := First_Formal (Ident); while Present (Formal) loop New_Param := Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), ! In_Present => In_Present (Parent (Formal)), ! Out_Present => Out_Present (Parent (Formal)), ! Parameter_Type => New_Reference_To (Etype (Formal), Loc)); if Unprotected then Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); *************** package body Exp_Ch9 is *** 2326,2335 **** Make_Defining_Identifier (Loc, Name_uObject), In_Present => True, Out_Present => ! (Etype (Ident) = Standard_Void_Type ! and then not Is_RTE (Obj_Type, RE_Address)), ! Parameter_Type => New_Reference_To (Obj_Type, Loc)); ! Set_Needs_Debug_Info (Defining_Identifier (Decl)); Prepend_To (New_Plist, Decl); return New_Plist; --- 2705,2715 ---- Make_Defining_Identifier (Loc, Name_uObject), In_Present => True, Out_Present => ! (Etype (Ident) = Standard_Void_Type ! and then not Is_RTE (Obj_Type, RE_Address)), ! Parameter_Type => ! New_Reference_To (Obj_Type, Loc)); ! Set_Debug_Info_Needed (Defining_Identifier (Decl)); Prepend_To (New_Plist, Decl); return New_Plist; *************** package body Exp_Ch9 is *** 2340,2352 **** --------------------------------------- function Build_Protected_Sub_Specification ! (N : Node_Id; ! Prottyp : Entity_Id; ! Mode : Subprogram_Protection_Mode) return Node_Id is Loc : constant Source_Ptr := Sloc (N); Decl : Node_Id; ! Ident : Entity_Id; New_Id : Entity_Id; New_Plist : List_Id; New_Spec : Node_Id; --- 2720,2732 ---- --------------------------------------- function Build_Protected_Sub_Specification ! (N : Node_Id; ! Prot_Typ : Entity_Id; ! Mode : Subprogram_Protection_Mode) return Node_Id is Loc : constant Source_Ptr := Sloc (N); Decl : Node_Id; ! Def_Id : Entity_Id; New_Id : Entity_Id; New_Plist : List_Id; New_Spec : Node_Id; *************** package body Exp_Ch9 is *** 2357,2380 **** Unprotected_Mode => 'N'); begin ! if Ekind ! (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body then Decl := Unit_Declaration_Node (Corresponding_Spec (N)); else Decl := N; end if; ! Ident := Defining_Unit_Name (Specification (Decl)); New_Plist := ! Build_Protected_Spec (Decl, ! Corresponding_Record_Type (Prottyp), ! Mode = Unprotected_Mode, Ident); ! New_Id := Make_Defining_Identifier (Loc, ! Chars => Build_Selected_Name (Prottyp, Ident, Append_Chr (Mode))); -- The unprotected operation carries the user code, and debugging -- information must be generated for it, even though this spec does --- 2737,2759 ---- Unprotected_Mode => 'N'); begin ! if Ekind (Defining_Unit_Name (Specification (N))) = ! E_Subprogram_Body then Decl := Unit_Declaration_Node (Corresponding_Spec (N)); else Decl := N; end if; ! Def_Id := Defining_Unit_Name (Specification (Decl)); New_Plist := ! Build_Protected_Spec ! (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id, ! Mode = Unprotected_Mode); New_Id := Make_Defining_Identifier (Loc, ! Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode))); -- The unprotected operation carries the user code, and debugging -- information must be generated for it, even though this spec does *************** package body Exp_Ch9 is *** 2382,2399 **** -- into the protected operation, even though it only contains lock/ -- unlock calls. ! Set_Needs_Debug_Info (New_Id); if Nkind (Specification (Decl)) = N_Procedure_Specification then ! return Make_Procedure_Specification (Loc, Defining_Unit_Name => New_Id, Parameter_Specifications => New_Plist); ! else ! -- We need to create a new specification for the anonymous ! -- subprogram type. New_Spec := Make_Function_Specification (Loc, Defining_Unit_Name => New_Id, --- 2761,2777 ---- -- into the protected operation, even though it only contains lock/ -- unlock calls. ! Set_Debug_Info_Needed (New_Id); if Nkind (Specification (Decl)) = N_Procedure_Specification then ! New_Spec := Make_Procedure_Specification (Loc, Defining_Unit_Name => New_Id, Parameter_Specifications => New_Plist); ! -- Create a new specification for the anonymous subprogram type + else New_Spec := Make_Function_Specification (Loc, Defining_Unit_Name => New_Id, *************** package body Exp_Ch9 is *** 2402,2409 **** Copy_Result_Type (Result_Definition (Specification (Decl)))); Set_Return_Present (Defining_Unit_Name (New_Spec)); - return New_Spec; end if; end Build_Protected_Sub_Specification; ------------------------------------- --- 2780,2788 ---- Copy_Result_Type (Result_Definition (Specification (Decl)))); Set_Return_Present (Defining_Unit_Name (New_Spec)); end if; + + return New_Spec; end Build_Protected_Sub_Specification; ------------------------------------- *************** package body Exp_Ch9 is *** 2577,2587 **** end if; else ! Unprot_Call := Make_Procedure_Call_Statement (Loc, ! Name => ! Make_Identifier (Loc, ! Chars (Defining_Unit_Name (N_Op_Spec))), ! Parameter_Associations => Uactuals); end if; -- Wrap call in block that will be covered by an at_end handler --- 2956,2967 ---- end if; else ! Unprot_Call := ! Make_Procedure_Call_Statement (Loc, ! Name => ! Make_Identifier (Loc, ! Chars (Defining_Unit_Name (N_Op_Spec))), ! Parameter_Associations => Uactuals); end if; -- Wrap call in block that will be covered by an at_end handler *************** package body Exp_Ch9 is *** 2596,2631 **** -- Make the protected subprogram body. This locks the protected -- object and calls the unprotected version of the subprogram. ! -- If the protected object is controlled (i.e it has entries or ! -- needs finalization for interrupt handling), call Lock_Entries, ! -- except if the protected object follows the Ravenscar profile, in ! -- which case call Lock_Entry, otherwise call the simplified version, ! -- Lock. ! ! if Has_Entries (Pid) ! or else Has_Interrupt_Handler (Pid) ! or else (Has_Attach_Handler (Pid) ! and then not Restricted_Profile) ! or else (Ada_Version >= Ada_05 ! and then Present (Interface_List (Parent (Pid)))) ! then ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Number_Entries (Pid) > 1 ! or else (Has_Attach_Handler (Pid) and then not Restricted_Profile) ! then Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc); Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc); ! else Lock_Name := New_Reference_To (RTE (RE_Lock_Entry), Loc); Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc); - end if; ! else ! Lock_Name := New_Reference_To (RTE (RE_Lock), Loc); ! Service_Name := New_Reference_To (RTE (RE_Unlock), Loc); ! end if; Object_Parm := Make_Attribute_Reference (Loc, --- 2976,2997 ---- -- Make the protected subprogram body. This locks the protected -- object and calls the unprotected version of the subprogram. ! case Corresponding_Runtime_Package (Pid) is ! when System_Tasking_Protected_Objects_Entries => Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc); Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc); ! when System_Tasking_Protected_Objects_Single_Entry => Lock_Name := New_Reference_To (RTE (RE_Lock_Entry), Loc); Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc); ! when System_Tasking_Protected_Objects => ! Lock_Name := New_Reference_To (RTE (RE_Lock), Loc); ! Service_Name := New_Reference_To (RTE (RE_Unlock), Loc); ! ! when others => ! raise Program_Error; ! end case; Object_Parm := Make_Attribute_Reference (Loc, *************** package body Exp_Ch9 is *** 2941,2946 **** --- 3307,3336 ---- -- the _Task_Id or _Object from the result of doing an unchecked -- conversion to convert the value to the corresponding record type. + if Nkind (Concval) = N_Function_Call + and then Is_Task_Type (Conctyp) + and then Ada_Version >= Ada_05 + then + declare + Obj : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('F')); + Decl : Node_Id; + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Obj, + Object_Definition => New_Occurrence_Of (Conctyp, Loc), + Expression => Relocate_Node (Concval)); + Set_Etype (Obj, Conctyp); + Decls := New_List (Decl); + Rewrite (Concval, New_Occurrence_Of (Obj, Loc)); + end; + + else + Decls := New_List; + end if; + Parm1 := Concurrent_Ref (Concval); -- Second parameter is the entry index, computed by the routine *************** package body Exp_Ch9 is *** 2966,2977 **** Expression => Actual_Index_Expression ( Loc, Entity (Ename), Index, Concval)); ! Decls := New_List (Xdecl); Parm2 := New_Reference_To (X, Loc); else Xdecl := Empty; - Decls := New_List; Parm2 := Empty; end if; --- 3356,3366 ---- Expression => Actual_Index_Expression ( Loc, Entity (Ename), Index, Concval)); ! Append_To (Decls, Xdecl); Parm2 := New_Reference_To (X, Loc); else Xdecl := Empty; Parm2 := Empty; end if; *************** package body Exp_Ch9 is *** 3101,3175 **** -- Now we can create the call, case of protected type if Is_Protected_Type (Conctyp) then ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Number_Entries (Conctyp) > 1 ! or else (Has_Attach_Handler (Conctyp) ! and then not Restricted_Profile) ! then ! -- Change the type of the index declaration ! Set_Object_Definition (Xdecl, ! New_Reference_To (RTE (RE_Protected_Entry_Index), Loc)); ! -- Some additional declarations for protected entry calls ! if No (Decls) then ! Decls := New_List; ! end if; ! -- Bnn : Communications_Block; ! Comm_Name := ! Make_Defining_Identifier (Loc, New_Internal_Name ('B')); ! Append_To (Decls, ! Make_Object_Declaration (Loc, ! Defining_Identifier => Comm_Name, ! Object_Definition => ! New_Reference_To (RTE (RE_Communication_Block), Loc))); ! -- Some additional statements for protected entry calls ! -- Protected_Entry_Call ( ! -- Object => po._object'Access, ! -- E => ; ! -- Uninterpreted_Data => P'Address; ! -- Mode => Simple_Call; ! -- Block => Bnn); ! Call := ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), ! Parameter_Associations => New_List ( ! Make_Attribute_Reference (Loc, ! Attribute_Name => Name_Unchecked_Access, ! Prefix => Parm1), ! Parm2, ! Parm3, ! New_Reference_To (RTE (RE_Simple_Call), Loc), ! New_Occurrence_Of (Comm_Name, Loc))); ! else ! -- Protected_Single_Entry_Call ( ! -- Object => po._object'Access, ! -- Uninterpreted_Data => P'Address; ! -- Mode => Simple_Call); ! Call := ! Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To ( ! RTE (RE_Protected_Single_Entry_Call), Loc), ! Parameter_Associations => New_List ( ! Make_Attribute_Reference (Loc, ! Attribute_Name => Name_Unchecked_Access, ! Prefix => Parm1), ! Parm3, ! New_Reference_To (RTE (RE_Simple_Call), Loc))); ! end if; -- Case of task type --- 3490,3564 ---- -- Now we can create the call, case of protected type if Is_Protected_Type (Conctyp) then ! case Corresponding_Runtime_Package (Conctyp) is ! when System_Tasking_Protected_Objects_Entries => ! -- Change the type of the index declaration ! Set_Object_Definition (Xdecl, ! New_Reference_To (RTE (RE_Protected_Entry_Index), Loc)); ! -- Some additional declarations for protected entry calls ! if No (Decls) then ! Decls := New_List; ! end if; ! -- Bnn : Communications_Block; ! Comm_Name := ! Make_Defining_Identifier (Loc, New_Internal_Name ('B')); ! Append_To (Decls, ! Make_Object_Declaration (Loc, ! Defining_Identifier => Comm_Name, ! Object_Definition => ! New_Reference_To (RTE (RE_Communication_Block), Loc))); ! -- Some additional statements for protected entry calls ! -- Protected_Entry_Call ( ! -- Object => po._object'Access, ! -- E => ; ! -- Uninterpreted_Data => P'Address; ! -- Mode => Simple_Call; ! -- Block => Bnn); ! Call := ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), ! Parameter_Associations => New_List ( ! Make_Attribute_Reference (Loc, ! Attribute_Name => Name_Unchecked_Access, ! Prefix => Parm1), ! Parm2, ! Parm3, ! New_Reference_To (RTE (RE_Simple_Call), Loc), ! New_Occurrence_Of (Comm_Name, Loc))); ! when System_Tasking_Protected_Objects_Single_Entry => ! -- Protected_Single_Entry_Call ( ! -- Object => po._object'Access, ! -- Uninterpreted_Data => P'Address; ! -- Mode => Simple_Call); ! Call := ! Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To ( ! RTE (RE_Protected_Single_Entry_Call), Loc), ! ! Parameter_Associations => New_List ( ! Make_Attribute_Reference (Loc, ! Attribute_Name => Name_Unchecked_Access, ! Prefix => Parm1), ! Parm3, ! New_Reference_To (RTE (RE_Simple_Call), Loc))); ! ! when others => ! raise Program_Error; ! end case; -- Case of task type *************** package body Exp_Ch9 is *** 3488,3523 **** ----------------------------------- function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is ! Loc : constant Source_Ptr := Sloc (T); ! Nam : constant Name_Id := Chars (T); ! Ent : Entity_Id; begin ! Ent := Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Nam, 'B')); ! Set_Is_Internal (Ent); -- Associate the procedure with the task, if this is the declaration -- (and not the body) of the procedure. if No (Task_Body_Procedure (T)) then ! Set_Task_Body_Procedure (T, Ent); end if; return Make_Procedure_Specification (Loc, ! Defining_Unit_Name => Ent, ! Parameter_Specifications => ! New_List ( ! Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, Name_uTask), ! Parameter_Type => ! Make_Access_Definition (Loc, ! Subtype_Mark => ! New_Reference_To ! (Corresponding_Record_Type (T), Loc))))); end Build_Task_Proc_Specification; --------------------------------------- --- 3877,3909 ---- ----------------------------------- function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is ! Loc : constant Source_Ptr := Sloc (T); ! Spec_Id : Entity_Id; begin ! Spec_Id := Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Chars (T), 'B')); ! Set_Is_Internal (Spec_Id); -- Associate the procedure with the task, if this is the declaration -- (and not the body) of the procedure. if No (Task_Body_Procedure (T)) then ! Set_Task_Body_Procedure (T, Spec_Id); end if; return Make_Procedure_Specification (Loc, ! Defining_Unit_Name => Spec_Id, ! Parameter_Specifications => New_List ( ! Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, Name_uTask), ! Parameter_Type => ! Make_Access_Definition (Loc, ! Subtype_Mark => ! New_Reference_To (Corresponding_Record_Type (T), Loc))))); end Build_Task_Proc_Specification; --------------------------------------- *************** package body Exp_Ch9 is *** 3528,3552 **** (N : Node_Id; Pid : Node_Id) return Node_Id is ! Loc : constant Source_Ptr := Sloc (N); ! N_Op_Spec : Node_Id; ! Op_Decls : List_Id; begin -- Make an unprotected version of the subprogram for use within the same -- object, with a new name and an additional parameter representing the -- object. - Op_Decls := Declarations (N); - N_Op_Spec := - Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode); - return ! Make_Subprogram_Body (Loc, ! Specification => N_Op_Spec, ! Declarations => Op_Decls, ! Handled_Statement_Sequence => ! Handled_Statement_Sequence (N)); end Build_Unprotected_Subprogram_Body; ---------------------------- --- 3914,3937 ---- (N : Node_Id; Pid : Node_Id) return Node_Id is ! Decls : constant List_Id := Declarations (N); begin + -- Add renamings for the Protection object, discriminals, privals and + -- the entry index constant for use by debugger. + + Debug_Private_Data_Declarations (Decls); + -- Make an unprotected version of the subprogram for use within the same -- object, with a new name and an additional parameter representing the -- object. return ! Make_Subprogram_Body (Sloc (N), ! Specification => ! Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), ! Declarations => Decls, ! Handled_Statement_Sequence => Handled_Statement_Sequence (N)); end Build_Unprotected_Subprogram_Body; ---------------------------- *************** package body Exp_Ch9 is *** 3565,3573 **** begin Efam := First_Entity (Conctyp); - while Present (Efam) loop - if Ekind (Efam) = E_Entry_Family then Efam_Type := Make_Defining_Identifier (Loc, --- 3950,3956 ---- *************** package body Exp_Ch9 is *** 3577,3582 **** --- 3960,3966 ---- Bas : Entity_Id := Base_Type (Etype (Discrete_Subtype_Definition (Parent (Efam)))); + Bas_Decl : Node_Id := Empty; Lo, Hi : Node_Id; *************** package body Exp_Ch9 is *** 3586,3600 **** if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then Bas := ! Make_Defining_Identifier (Loc, New_Internal_Name ('B')); Bas_Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Bas, ! Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), ! Constraint => Make_Range_Constraint (Loc, Range_Expression => Make_Range (Loc, Make_Integer_Literal --- 3970,3986 ---- if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then Bas := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('B')); ! Bas_Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Bas, ! Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), ! Constraint => Make_Range_Constraint (Loc, Range_Expression => Make_Range (Loc, Make_Integer_Literal *************** package body Exp_Ch9 is *** 3652,3657 **** --- 4038,4065 ---- end loop; end Collect_Entry_Families; + ----------------------- + -- Concurrent_Object -- + ----------------------- + + function Concurrent_Object + (Spec_Id : Entity_Id; + Conc_Typ : Entity_Id) return Entity_Id + is + begin + -- Parameter _O or _object + + if Is_Protected_Type (Conc_Typ) then + return First_Formal (Protected_Body_Subprogram (Spec_Id)); + + -- Parameter _task + + else + pragma Assert (Is_Task_Type (Conc_Typ)); + return First_Formal (Task_Body_Procedure (Conc_Typ)); + end if; + end Concurrent_Object; + ---------------------- -- Copy_Result_Type -- ---------------------- *************** package body Exp_Ch9 is *** 3716,3722 **** -- objectR ! -- which is a renaming of the _object field of the current object object -- record, passed into protected operations as a parameter. function Concurrent_Ref (N : Node_Id) return Node_Id is --- 4124,4130 ---- -- objectR ! -- which is a renaming of the _object field of the current object -- record, passed into protected operations as a parameter. function Concurrent_Ref (N : Node_Id) return Node_Id is *************** package body Exp_Ch9 is *** 3823,3832 **** else pragma Assert (Is_Protected_Type (Entity (N))); return ! New_Reference_To ( ! Object_Ref (Corresponding_Body (Parent (Base_Type (Ntyp)))), ! Loc); end if; else --- 4231,4239 ---- else pragma Assert (Is_Protected_Type (Entity (N))); + return ! New_Reference_To (Find_Protection_Object (Current_Scope), Loc); end if; else *************** package body Exp_Ch9 is *** 3867,3872 **** --- 4274,4323 ---- end if; end Convert_Concurrent; + ------------------------------------- + -- Debug_Private_Data_Declarations -- + ------------------------------------- + + procedure Debug_Private_Data_Declarations (Decls : List_Id) is + Debug_Nod : Node_Id; + Decl : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) + and then not Comes_From_Source (Decl) + loop + -- Declaration for concurrent entity _object and its access type, + -- along with the entry index subtype: + -- type prot_typVP is access prot_typV; + -- _object : prot_typVP := prot_typV (_O); + -- subtype Jnn is range Low .. High; + + if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then + Set_Debug_Info_Needed (Defining_Identifier (Decl)); + + -- Declaration for the Protection object, discriminals, privals and + -- entry index constant: + -- conc_typR : protection_typ renames _object._object; + -- discr_nameD : discr_typ renames _object.discr_name; + -- discr_nameD : discr_typ renames _task.discr_name; + -- prival_name : comp_typ renames _object.comp_name; + -- J : constant Jnn := + -- Jnn'Val (_E - + Jnn'Pos (Jnn'First)); + + elsif Nkind (Decl) = N_Object_Renaming_Declaration then + Set_Debug_Info_Needed (Defining_Identifier (Decl)); + Debug_Nod := Debug_Renaming_Declaration (Decl); + + if Present (Debug_Nod) then + Insert_After (Decl, Debug_Nod); + end if; + end if; + + Next (Decl); + end loop; + end Debug_Private_Data_Declarations; + ---------------------------- -- Entry_Index_Expression -- ---------------------------- *************** package body Exp_Ch9 is *** 4185,4191 **** if Present (Ann) then Append_Elmt (Ann, Accept_Address (Ent)); ! Set_Needs_Debug_Info (Ann); end if; -- Create renaming declarations for the entry formals. Each reference --- 4636,4642 ---- if Present (Ann) then Append_Elmt (Ann, Accept_Address (Ent)); ! Set_Debug_Info_Needed (Ann); end if; -- Create renaming declarations for the entry formals. Each reference *************** package body Exp_Ch9 is *** 4215,4221 **** Set_Etype (New_F, Etype (Formal)); Set_Scope (New_F, Ent); ! Set_Needs_Debug_Info (New_F); -- That's the whole point. if Ekind (Formal) = E_In_Parameter then Set_Ekind (New_F, E_Constant); --- 4666,4677 ---- Set_Etype (New_F, Etype (Formal)); Set_Scope (New_F, Ent); ! ! -- Now we set debug info needed on New_F even though it does ! -- not come from source, so that the debugger will get the ! -- right information for these generated names. ! ! Set_Debug_Info_Needed (New_F); if Ekind (Formal) = E_In_Parameter then Set_Ekind (New_F, E_Constant); *************** package body Exp_Ch9 is *** 4271,4289 **** E_T : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('E')); P_List : constant List_Id := Build_Protected_Spec ! (N, RTE (RE_Address), False, D_T); Decl1 : Node_Id; Decl2 : Node_Id; Def1 : Node_Id; begin ! -- Create access to protected subprogram with full signature ! if Nkind (Type_Definition (N)) = N_Access_Function_Definition then Def1 := Make_Access_Function_Definition (Loc, Parameter_Specifications => P_List, ! Result_Definition => Copy_Result_Type (Result_Definition (Type_Definition (N)))); else --- 4727,4745 ---- E_T : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('E')); P_List : constant List_Id := Build_Protected_Spec ! (N, RTE (RE_Address), D_T, False); Decl1 : Node_Id; Decl2 : Node_Id; Def1 : Node_Id; begin ! -- Create access to subprogram with full signature ! if Etype (D_T) /= Standard_Void_Type then Def1 := Make_Access_Function_Definition (Loc, Parameter_Specifications => P_List, ! Result_Definition => Copy_Result_Type (Result_Definition (Type_Definition (N)))); else *************** package body Exp_Ch9 is *** 4297,4304 **** Defining_Identifier => D_T2, Type_Definition => Def1); - Analyze (Decl1); Insert_After (N, Decl1); -- Create Equivalent_Type, a record with two components for an access to -- object and an access to subprogram. --- 4753,4760 ---- Defining_Identifier => D_T2, Type_Definition => Def1); Insert_After (N, Decl1); + Analyze (Decl1); -- Create Equivalent_Type, a record with two components for an access to -- object and an access to subprogram. *************** package body Exp_Ch9 is *** 4309,4315 **** Make_Defining_Identifier (Loc, New_Internal_Name ('P')), Component_Definition => Make_Component_Definition (Loc, ! Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (RTE (RE_Address), Loc))), --- 4765,4771 ---- Make_Defining_Identifier (Loc, New_Internal_Name ('P')), Component_Definition => Make_Component_Definition (Loc, ! Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (RTE (RE_Address), Loc))), *************** package body Exp_Ch9 is *** 4318,4337 **** Make_Defining_Identifier (Loc, New_Internal_Name ('S')), Component_Definition => Make_Component_Definition (Loc, ! Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); Decl2 := Make_Full_Type_Declaration (Loc, Defining_Identifier => E_T, ! Type_Definition => Make_Record_Definition (Loc, Component_List => Make_Component_List (Loc, Component_Items => Comps))); - Analyze (Decl2); Insert_After (Decl1, Decl2); Set_Equivalent_Type (T, E_T); end Expand_Access_Protected_Subprogram_Type; --- 4774,4793 ---- Make_Defining_Identifier (Loc, New_Internal_Name ('S')), Component_Definition => Make_Component_Definition (Loc, ! Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); Decl2 := Make_Full_Type_Declaration (Loc, Defining_Identifier => E_T, ! Type_Definition => Make_Record_Definition (Loc, Component_List => Make_Component_List (Loc, Component_Items => Comps))); Insert_After (Decl1, Decl2); + Analyze (Decl2); Set_Equivalent_Type (T, E_T); end Expand_Access_Protected_Subprogram_Type; *************** package body Exp_Ch9 is *** 4340,4350 **** -------------------------- procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is ! Loc : constant Source_Ptr := Sloc (N); ! Prot : constant Entity_Id := Scope (Ent); ! Spec_Decl : constant Node_Id := Parent (Prot); ! Cond : constant Node_Id := Condition (Entry_Body_Formal_Part (N)); Func : Node_Id; B_F : Node_Id; Body_Decl : Node_Id; --- 4796,4805 ---- -------------------------- procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is ! Cond : constant Node_Id := Condition (Entry_Body_Formal_Part (N)); + Prot : constant Entity_Id := Scope (Ent); + Spec_Decl : constant Node_Id := Parent (Prot); Func : Node_Id; B_F : Node_Id; Body_Decl : Node_Id; *************** package body Exp_Ch9 is *** 4360,4366 **** -- unprotected version of a protected operation. The specification has -- been produced when the protected type declaration was elaborated. We -- build the body, insert it in the enclosing scope, but analyze it in ! -- the current context. A more uniform approach would be to treat -- barrier just as a protected function, and discard the protected -- version of it because it is never called. --- 4815,4821 ---- -- unprotected version of a protected operation. The specification has -- been produced when the protected type declaration was elaborated. We -- build the body, insert it in the enclosing scope, but analyze it in ! -- the current context. A more uniform approach would be to treat the -- barrier just as a protected function, and discard the protected -- version of it because it is never called. *************** package body Exp_Ch9 is *** 4377,4385 **** Insert_Before_And_Analyze (Body_Decl, B_F); - Update_Prival_Subtypes (B_F); - - Set_Privals (Spec_Decl, N, Loc, After_Barrier => True); Set_Discriminals (Spec_Decl); Set_Scope (Func, Scope (Prot)); --- 4832,4837 ---- *************** package body Exp_Ch9 is *** 4442,4484 **** Check_Restriction (Simple_Barriers, Cond); end Expand_Entry_Barrier; - ------------------------------------ - -- Expand_Entry_Body_Declarations -- - ------------------------------------ - - procedure Expand_Entry_Body_Declarations (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Index_Spec : Node_Id; - - begin - if Expander_Active then - - -- Expand entry bodies corresponding to entry families - -- by assigning a placeholder for the constant that will - -- be used to expand references to the entry index parameter. - - Index_Spec := - Entry_Index_Specification (Entry_Body_Formal_Part (N)); - - if Present (Index_Spec) then - declare - Index_Con : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('J')); - begin - -- Mark the index constant as having a valid value since it - -- will act as a renaming of the original entry index which - -- is known to be valid. - - Set_Is_Known_Valid (Index_Con); - - Set_Entry_Index_Constant - (Defining_Identifier (Index_Spec), Index_Con); - end; - end if; - end if; - end Expand_Entry_Body_Declarations; - ------------------------------ -- Expand_N_Abort_Statement -- ------------------------------ --- 4894,4899 ---- *************** package body Exp_Ch9 is *** 4595,4601 **** -- The first three declarations were already inserted ahead of the accept -- statement by the Expand_Accept_Declarations procedure, which was called ! -- directly from the semantics during analysis of the accept. statement, -- before analyzing its contained statements. -- The declarations from the N_Accept_Statement, as noted in Sinfo, come --- 5010,5016 ---- -- The first three declarations were already inserted ahead of the accept -- statement by the Expand_Accept_Declarations procedure, which was called ! -- directly from the semantics during analysis of the accept statement, -- before analyzing its contained statements. -- The declarations from the N_Accept_Statement, as noted in Sinfo, come *************** package body Exp_Ch9 is *** 6390,6437 **** ------------------------- procedure Expand_N_Entry_Body (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Dec : constant Node_Id := Parent (Current_Scope); - Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); - Index_Spec : constant Node_Id := - Entry_Index_Specification (Ent_Formals); - Next_Op : Node_Id; - First_Decl : constant Node_Id := First (Declarations (N)); - Index_Decl : List_Id; - begin ! -- Add the renamings for private declarations and discriminants ! ! Add_Discriminal_Declarations ! (Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc); ! Add_Private_Declarations ! (Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc); ! ! if Present (Index_Spec) then ! Index_Decl := ! Index_Constant_Declaration ! (N, ! Defining_Identifier (Index_Spec), Defining_Identifier (Dec)); ! ! -- If the entry has local declarations, insert index declaration ! -- before them, because the index may be used therein. ! ! if Present (First_Decl) then ! Insert_List_Before (First_Decl, Index_Decl); ! else ! Append_List_To (Declarations (N), Index_Decl); ! end if; ! end if; ! ! -- Associate privals and discriminals with the next protected operation ! -- body to be expanded. These are used to expand references to private ! -- data objects and discriminants, respectively. ! ! Next_Op := Next_Protected_Operation (N); ! if Present (Next_Op) then ! Set_Privals (Dec, Next_Op, Loc); ! Set_Discriminals (Dec); end if; end Expand_N_Entry_Body; --- 6805,6816 ---- ------------------------- procedure Expand_N_Entry_Body (N : Node_Id) is begin ! -- Associate discriminals with the next protected operation body to be ! -- expanded. ! if Present (Next_Protected_Operation (N)) then ! Set_Discriminals (Parent (Current_Scope)); end if; end Expand_N_Entry_Body; *************** package body Exp_Ch9 is *** 6439,6446 **** -- Expand_N_Entry_Call_Statement -- ----------------------------------- ! -- An entry call is expanded into GNARLI calls to implement ! -- a simple entry call (see Build_Simple_Entry_Call). procedure Expand_N_Entry_Call_Statement (N : Node_Id) is Concval : Node_Id; --- 6818,6825 ---- -- Expand_N_Entry_Call_Statement -- ----------------------------------- ! -- An entry call is expanded into GNARLI calls to implement a simple entry ! -- call (see Build_Simple_Entry_Call). procedure Expand_N_Entry_Call_Statement (N : Node_Id) is Concval : Node_Id; *************** package body Exp_Ch9 is *** 6683,6696 **** procedure Expand_N_Protected_Body (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Pid : constant Entity_Id := Corresponding_Spec (N); ! Has_Entries : Boolean := False; ! Op_Body : Node_Id; ! Op_Decl : Node_Id; ! Op_Id : Entity_Id; Disp_Op_Body : Node_Id; New_Op_Body : Node_Id; - Current_Node : Node_Id; Num_Entries : Natural := 0; function Build_Dispatching_Subprogram_Body (N : Node_Id; --- 7062,7078 ---- procedure Expand_N_Protected_Body (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Pid : constant Entity_Id := Corresponding_Spec (N); ! ! Current_Node : Node_Id; Disp_Op_Body : Node_Id; New_Op_Body : Node_Id; Num_Entries : Natural := 0; + Op_Body : Node_Id; + Op_Decl : Node_Id; + Op_Id : Entity_Id; + + Chain : Entity_Id := Empty; + -- Finalization chain that may be attached to new body function Build_Dispatching_Subprogram_Body (N : Node_Id; *************** package body Exp_Ch9 is *** 6783,6796 **** return; end if; ! if Nkind (Parent (N)) = N_Subunit then ! ! -- This is the proper body corresponding to a stub. The declarations ! -- must be inserted at the point of the stub, which is in the decla- ! -- rative part of the parent unit. Current_Node := Corresponding_Stub (Parent (N)); - else Current_Node := N; end if; --- 7165,7176 ---- return; end if; ! -- This is the proper body corresponding to a stub. The declarations ! -- must be inserted at the point of the stub, which in turn is in the ! -- declarative part of the parent unit. + if Nkind (Parent (N)) = N_Subunit then Current_Node := Corresponding_Stub (Parent (N)); else Current_Node := N; end if; *************** package body Exp_Ch9 is *** 6827,6839 **** -- entity is not further elaborated, and so the chain -- properly belongs to the newly created subprogram body. ! if Present ! (Finalization_Chain_Entity (Defining_Entity (Op_Body))) ! then Set_Finalization_Chain_Entity (Protected_Body_Subprogram ! (Corresponding_Spec (Op_Body)), ! Finalization_Chain_Entity (Defining_Entity (Op_Body))); Set_Analyzed (Handled_Statement_Sequence (New_Op_Body), False); end if; --- 7207,7219 ---- -- entity is not further elaborated, and so the chain -- properly belongs to the newly created subprogram body. ! Chain := ! Finalization_Chain_Entity (Defining_Entity (Op_Body)); ! ! if Present (Chain) then Set_Finalization_Chain_Entity (Protected_Body_Subprogram ! (Corresponding_Spec (Op_Body)), Chain); Set_Analyzed (Handled_Statement_Sequence (New_Op_Body), False); end if; *************** package body Exp_Ch9 is *** 6842,6851 **** Current_Node := New_Op_Body; Analyze (New_Op_Body); - Update_Prival_Subtypes (New_Op_Body); - -- Build the corresponding protected operation. It may ! -- appear that this is needed only this is a visible -- operation of the type, or if it is an interrupt handler, -- and this was the strategy used previously in GNAT. -- However, the operation may be exported through a --- 7222,7229 ---- Current_Node := New_Op_Body; Analyze (New_Op_Body); -- Build the corresponding protected operation. It may ! -- appear that this is needed only if this is a visible -- operation of the type, or if it is an interrupt handler, -- and this was the strategy used previously in GNAT. -- However, the operation may be exported through a *************** package body Exp_Ch9 is *** 6856,6869 **** if Present (Corresponding_Spec (Op_Body)) then Op_Decl := ! Unit_Declaration_Node (Corresponding_Spec (Op_Body)); ! if ! Nkind (Parent (Op_Decl)) = N_Protected_Definition then New_Op_Body := ! Build_Protected_Subprogram_Body ( ! Op_Body, Pid, Specification (New_Op_Body)); Insert_After (Current_Node, New_Op_Body); Analyze (New_Op_Body); --- 7234,7247 ---- if Present (Corresponding_Spec (Op_Body)) then Op_Decl := ! Unit_Declaration_Node (Corresponding_Spec (Op_Body)); ! if Nkind (Parent (Op_Decl)) = ! N_Protected_Definition then New_Op_Body := ! Build_Protected_Subprogram_Body ( ! Op_Body, Pid, Specification (New_Op_Body)); Insert_After (Current_Node, New_Op_Body); Analyze (New_Op_Body); *************** package body Exp_Ch9 is *** 6875,6881 **** -- an interface. if Ada_Version >= Ada_05 ! and then Present (Abstract_Interfaces ( Corresponding_Record_Type (Pid))) then Disp_Op_Body := --- 7253,7259 ---- -- an interface. if Ada_Version >= Ada_05 ! and then Present (Interfaces ( Corresponding_Record_Type (Pid))) then Disp_Op_Body := *************** package body Exp_Ch9 is *** 6893,6899 **** when N_Entry_Body => Op_Id := Defining_Identifier (Op_Body); - Has_Entries := True; Num_Entries := Num_Entries + 1; New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid); --- 7271,7276 ---- *************** package body Exp_Ch9 is *** 6902,6909 **** Current_Node := New_Op_Body; Analyze (New_Op_Body); - Update_Prival_Subtypes (New_Op_Body); - when N_Implicit_Label_Declaration => null; --- 7279,7284 ---- *************** package body Exp_Ch9 is *** 6946,6959 **** -- Finally, create the body of the function that maps an entry index -- into the corresponding body index, except when there is no entry, ! -- or in a ravenscar-like profile (no abort, no entry queue, 1 entry) ! if Has_Entries ! and then (Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Num_Entries > 1 ! or else (Has_Attach_Handler (Pid) ! and then not Restricted_Profile)) then New_Op_Body := Build_Find_Body_Index (Pid); Insert_After (Current_Node, New_Op_Body); --- 7321,7330 ---- -- Finally, create the body of the function that maps an entry index -- into the corresponding body index, except when there is no entry, ! -- or in a ravenscar-like profile. ! if Corresponding_Runtime_Package (Pid) = ! System_Tasking_Protected_Objects_Entries then New_Op_Body := Build_Find_Body_Index (Pid); Insert_After (Current_Node, New_Op_Body); *************** package body Exp_Ch9 is *** 6961,7024 **** Analyze (New_Op_Body); end if; ! -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after ! -- the protected body. At this point the entry specs have been created, -- frozen and included in the dispatch table for the protected type. ! pragma Assert (Present (Corresponding_Record_Type (Pid))); ! ! if Ada_Version >= Ada_05 ! and then Present (Protected_Definition (Parent (Pid))) ! and then Present (Abstract_Interfaces ! (Corresponding_Record_Type (Pid))) ! then ! declare ! Vis_Decl : Node_Id := ! First (Visible_Declarations ! (Protected_Definition (Parent (Pid)))); ! Wrap_Body : Node_Id; ! ! begin ! -- Examine the visible declarations of the protected type, looking ! -- for an entry declaration. We do not consider entry families ! -- since they cannot have dispatching operations, thus they do not ! -- need entry wrappers. ! ! while Present (Vis_Decl) loop ! if Nkind (Vis_Decl) = N_Entry_Declaration then ! Wrap_Body := ! Build_Wrapper_Body (Loc, ! Proc_Nam => Defining_Identifier (Vis_Decl), ! Obj_Typ => Corresponding_Record_Type (Pid), ! Formals => Parameter_Specifications (Vis_Decl)); ! ! if Wrap_Body /= Empty then ! Insert_After (Current_Node, Wrap_Body); ! Current_Node := Wrap_Body; ! ! Analyze (Wrap_Body); ! end if; ! ! elsif Nkind (Vis_Decl) = N_Subprogram_Declaration then ! Wrap_Body := ! Build_Wrapper_Body (Loc, ! Proc_Nam => Defining_Unit_Name ! (Specification (Vis_Decl)), ! Obj_Typ => Corresponding_Record_Type (Pid), ! Formals => Parameter_Specifications ! (Specification (Vis_Decl))); ! ! if Wrap_Body /= Empty then ! Insert_After (Current_Node, Wrap_Body); ! Current_Node := Wrap_Body; ! ! Analyze (Wrap_Body); ! end if; ! end if; ! ! Next (Vis_Decl); ! end loop; ! end; end if; end Expand_N_Protected_Body; --- 7332,7343 ---- Analyze (New_Op_Body); end if; ! -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the ! -- protected body. At this point all wrapper specs have been created, -- frozen and included in the dispatch table for the protected type. ! if Ada_Version >= Ada_05 then ! Build_Wrapper_Bodies (Loc, Pid, Current_Node); end if; end Expand_N_Protected_Body; *************** package body Exp_Ch9 is *** 7099,7108 **** -- the specs refer to this type. procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is ! Loc : constant Source_Ptr := Sloc (N); ! Prottyp : constant Entity_Id := Defining_Identifier (N); ! Pdef : constant Node_Id := Protected_Definition (N); -- This contains two lists; one for visible and one for private decls Rec_Decl : Node_Id; --- 7418,7427 ---- -- the specs refer to this type. procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is ! Loc : constant Source_Ptr := Sloc (N); ! Prot_Typ : constant Entity_Id := Defining_Identifier (N); ! Pdef : constant Node_Id := Protected_Definition (N); -- This contains two lists; one for visible and one for private decls Rec_Decl : Node_Id; *************** package body Exp_Ch9 is *** 7157,7166 **** -- Start of processing for Expand_N_Protected_Type_Declaration begin ! if Present (Corresponding_Record_Type (Prottyp)) then return; else ! Rec_Decl := Build_Corresponding_Record (N, Prottyp, Loc); end if; Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); --- 7476,7485 ---- -- Start of processing for Expand_N_Protected_Type_Declaration begin ! if Present (Corresponding_Record_Type (Prot_Typ)) then return; else ! Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc); end if; Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); *************** package body Exp_Ch9 is *** 7183,7194 **** -- This replacement is not applied to default expressions, for which -- the discriminal is correct. ! if Has_Discriminants (Prottyp) then declare Disc : Entity_Id; Decl : Node_Id; begin ! Disc := First_Discriminant (Prottyp); Decl := First (Discriminant_Specifications (Rec_Decl)); while Present (Disc) loop Append_Elmt (Discriminal (Disc), Discr_Map); --- 7502,7514 ---- -- This replacement is not applied to default expressions, for which -- the discriminal is correct. ! if Has_Discriminants (Prot_Typ) then declare Disc : Entity_Id; Decl : Node_Id; + begin ! Disc := First_Discriminant (Prot_Typ); Decl := First (Discriminant_Specifications (Rec_Decl)); while Present (Disc) loop Append_Elmt (Discriminal (Disc), Discr_Map); *************** package body Exp_Ch9 is *** 7204,7210 **** -- Add components for entry families. For each entry family, create an -- anonymous type declaration with the same size, and analyze the type. ! Collect_Entry_Families (Loc, Cdecls, Current_Node, Prottyp); -- Prepend the _Object field with the right type to the component list. -- We need to compute the number of entries, and in some cases the --- 7524,7530 ---- -- Add components for entry families. For each entry family, create an -- anonymous type declaration with the same size, and analyze the type. ! Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ); -- Prepend the _Object field with the right type to the component list. -- We need to compute the number of entries, and in some cases the *************** package body Exp_Ch9 is *** 7216,7229 **** Protection_Subtype : Node_Id; Entry_Count_Expr : constant Node_Id := Build_Entry_Count_Expression ! (Prottyp, Cdecls, Loc); begin ! if Has_Attach_Handler (Prottyp) then ! Ritem := First_Rep_Item (Prottyp); while Present (Ritem) loop if Nkind (Ritem) = N_Pragma ! and then Chars (Ritem) = Name_Attach_Handler then Num_Attach_Handler := Num_Attach_Handler + 1; end if; --- 7536,7551 ---- Protection_Subtype : Node_Id; Entry_Count_Expr : constant Node_Id := Build_Entry_Count_Expression ! (Prot_Typ, Cdecls, Loc); begin ! -- Could this be simplified using Corresponding_Runtime_Package??? ! ! if Has_Attach_Handler (Prot_Typ) then ! Ritem := First_Rep_Item (Prot_Typ); while Present (Ritem) loop if Nkind (Ritem) = N_Pragma ! and then Pragma_Name (Ritem) = Name_Attach_Handler then Num_Attach_Handler := Num_Attach_Handler + 1; end if; *************** package body Exp_Ch9 is *** 7232,7238 **** end loop; if Restricted_Profile then ! if Has_Entries (Prottyp) then Protection_Subtype := New_Reference_To (RTE (RE_Protection_Entry), Loc); else --- 7554,7560 ---- end loop; if Restricted_Profile then ! if Has_Entries (Prot_Typ) then Protection_Subtype := New_Reference_To (RTE (RE_Protection_Entry), Loc); else *************** package body Exp_Ch9 is *** 7254,7260 **** Make_Integer_Literal (Loc, Num_Attach_Handler)))); end if; ! elsif Has_Interrupt_Handler (Prottyp) then Protection_Subtype := Make_Subtype_Indication ( Sloc => Loc, --- 7576,7582 ---- Make_Integer_Literal (Loc, Num_Attach_Handler)))); end if; ! elsif Has_Interrupt_Handler (Prot_Typ) then Protection_Subtype := Make_Subtype_Indication ( Sloc => Loc, *************** package body Exp_Ch9 is *** 7267,7294 **** -- Type has explicit entries or generated primitive entry wrappers ! elsif Has_Entries (Prottyp) or else (Ada_Version >= Ada_05 and then Present (Interface_List (N))) then ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Number_Entries (Prottyp) > 1 ! then ! Protection_Subtype := ! Make_Subtype_Indication ( ! Sloc => Loc, ! Subtype_Mark => ! New_Reference_To (RTE (RE_Protection_Entries), Loc), ! Constraint => ! Make_Index_Or_Discriminant_Constraint ( ! Sloc => Loc, ! Constraints => New_List (Entry_Count_Expr))); ! else ! Protection_Subtype := ! New_Reference_To (RTE (RE_Protection_Entry), Loc); ! end if; else Protection_Subtype := New_Reference_To (RTE (RE_Protection), Loc); --- 7589,7616 ---- -- Type has explicit entries or generated primitive entry wrappers ! elsif Has_Entries (Prot_Typ) or else (Ada_Version >= Ada_05 and then Present (Interface_List (N))) then ! case Corresponding_Runtime_Package (Prot_Typ) is ! when System_Tasking_Protected_Objects_Entries => ! Protection_Subtype := ! Make_Subtype_Indication (Loc, ! Subtype_Mark => ! New_Reference_To (RTE (RE_Protection_Entries), Loc), ! Constraint => ! Make_Index_Or_Discriminant_Constraint ( ! Sloc => Loc, ! Constraints => New_List (Entry_Count_Expr))); ! when System_Tasking_Protected_Objects_Single_Entry => ! Protection_Subtype := ! New_Reference_To (RTE (RE_Protection_Entry), Loc); ! ! when others => ! raise Program_Error; ! end case; else Protection_Subtype := New_Reference_To (RTE (RE_Protection), Loc); *************** package body Exp_Ch9 is *** 7363,7369 **** Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification ! (Priv, Prottyp, Unprotected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); --- 7685,7691 ---- Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification ! (Priv, Prot_Typ, Unprotected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); *************** package body Exp_Ch9 is *** 7378,7384 **** Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification ! (Priv, Prottyp, Protected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); --- 7700,7706 ---- Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification ! (Priv, Prot_Typ, Protected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); *************** package body Exp_Ch9 is *** 7413,7479 **** Analyze (Rec_Decl, Suppress => All_Checks); -- Ada 2005 (AI-345): Construct the primitive entry wrappers before ! -- the corresponding record is frozen ! ! if Ada_Version >= Ada_05 ! and then Present (Visible_Declarations (Pdef)) ! and then Present (Corresponding_Record_Type ! (Defining_Identifier (Parent (Pdef)))) ! and then Present (Abstract_Interfaces ! (Corresponding_Record_Type ! (Defining_Identifier (Parent (Pdef))))) ! then ! declare ! Current_Node : Node_Id := Rec_Decl; ! Vis_Decl : Node_Id; ! Wrap_Spec : Node_Id; ! New_N : Node_Id; ! ! begin ! -- Examine the visible declarations of the protected type, looking ! -- for declarations of entries, and subprograms. We do not ! -- consider entry families since they cannot have dispatching ! -- operations, thus they do not need entry wrappers. ! ! Vis_Decl := First (Visible_Declarations (Pdef)); ! ! while Present (Vis_Decl) loop ! ! Wrap_Spec := Empty; ! ! if Nkind (Vis_Decl) = N_Entry_Declaration ! and then No (Discrete_Subtype_Definition (Vis_Decl)) ! then ! Wrap_Spec := ! Build_Wrapper_Spec (Loc, ! Proc_Nam => Defining_Identifier (Vis_Decl), ! Obj_Typ => Defining_Identifier (Rec_Decl), ! Formals => Parameter_Specifications (Vis_Decl)); ! ! elsif Nkind (Vis_Decl) = N_Subprogram_Declaration then ! Wrap_Spec := ! Build_Wrapper_Spec (Loc, ! Proc_Nam => Defining_Unit_Name ! (Specification (Vis_Decl)), ! Obj_Typ => Defining_Identifier (Rec_Decl), ! Formals => Parameter_Specifications ! (Specification (Vis_Decl))); ! ! end if; ! ! if Wrap_Spec /= Empty then ! New_N := Make_Subprogram_Declaration (Loc, ! Specification => Wrap_Spec); ! ! Insert_After (Current_Node, New_N); ! Current_Node := New_N; ! ! Analyze (New_N); ! end if; ! Next (Vis_Decl); ! end loop; ! end; end if; -- Collect pointers to entry bodies and their barriers, to be placed --- 7735,7745 ---- Analyze (Rec_Decl, Suppress => All_Checks); -- Ada 2005 (AI-345): Construct the primitive entry wrappers before ! -- the corresponding record is frozen. If any wrappers are generated, ! -- Current_Node is updated accordingly. ! if Ada_Version >= Ada_05 then ! Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node); end if; -- Collect pointers to entry bodies and their barriers, to be placed *************** package body Exp_Ch9 is *** 7481,7490 **** -- add an expression to the aggregate which is the initial value of -- this array. The array is declared after all protected subprograms. ! if Has_Entries (Prottyp) then ! Entries_Aggr := ! Make_Aggregate (Loc, Expressions => New_List); ! else Entries_Aggr := Empty; end if; --- 7747,7754 ---- -- add an expression to the aggregate which is the initial value of -- this array. The array is declared after all protected subprograms. ! if Has_Entries (Prot_Typ) then ! Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List); else Entries_Aggr := Empty; end if; *************** package body Exp_Ch9 is *** 7508,7514 **** Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification ! (Comp, Prottyp, Unprotected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); --- 7772,7778 ---- Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification ! (Comp, Prot_Typ, Unprotected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); *************** package body Exp_Ch9 is *** 7526,7532 **** Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification ! (Comp, Prottyp, Protected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); --- 7790,7796 ---- Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification ! (Comp, Prot_Typ, Protected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); *************** package body Exp_Ch9 is *** 7534,7551 **** Current_Node := Sub; -- Generate an overriding primitive operation specification for ! -- this subprogram if the protected type implements an inerface. if Ada_Version >= Ada_05 and then ! Present (Abstract_Interfaces ! (Corresponding_Record_Type (Prottyp))) then Sub := Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification ! (Comp, Prottyp, Dispatching_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); --- 7798,7814 ---- Current_Node := Sub; -- Generate an overriding primitive operation specification for ! -- this subprogram if the protected type implements an interface. if Ada_Version >= Ada_05 and then ! Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) then Sub := Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification ! (Comp, Prot_Typ, Dispatching_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); *************** package body Exp_Ch9 is *** 7570,7600 **** elsif Nkind (Comp) = N_Entry_Declaration then E_Count := E_Count + 1; Comp_Id := Defining_Identifier (Comp); ! Set_Privals_Chain (Comp_Id, New_Elmt_List); Edef := Make_Defining_Identifier (Loc, ! Build_Selected_Name (Prottyp, Comp_Id, 'E')); Sub := Make_Subprogram_Declaration (Loc, Specification => ! Build_Protected_Entry_Specification (Edef, Comp_Id, Loc)); Insert_After (Current_Node, Sub); Analyze (Sub); ! Set_Protected_Body_Subprogram ( ! Defining_Identifier (Comp), ! Defining_Unit_Name (Specification (Sub))); Current_Node := Sub; Bdef := Make_Defining_Identifier (Loc, ! Build_Selected_Name (Prottyp, Comp_Id, 'B')); Sub := Make_Subprogram_Declaration (Loc, Specification => ! Build_Barrier_Function_Specification (Bdef, Loc)); Insert_After (Current_Node, Sub); Analyze (Sub); --- 7833,7863 ---- elsif Nkind (Comp) = N_Entry_Declaration then E_Count := E_Count + 1; Comp_Id := Defining_Identifier (Comp); ! Edef := Make_Defining_Identifier (Loc, ! Build_Selected_Name (Prot_Typ, Comp_Id, 'E')); Sub := Make_Subprogram_Declaration (Loc, Specification => ! Build_Protected_Entry_Specification (Loc, Edef, Comp_Id)); Insert_After (Current_Node, Sub); Analyze (Sub); ! Set_Protected_Body_Subprogram ! (Defining_Identifier (Comp), ! Defining_Unit_Name (Specification (Sub))); Current_Node := Sub; Bdef := Make_Defining_Identifier (Loc, ! Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'B')); Sub := Make_Subprogram_Declaration (Loc, Specification => ! Build_Barrier_Function_Specification (Loc, Bdef)); Insert_After (Current_Node, Sub); Analyze (Sub); *************** package body Exp_Ch9 is *** 7631,7663 **** if Nkind (Comp) = N_Entry_Declaration then E_Count := E_Count + 1; Comp_Id := Defining_Identifier (Comp); ! Set_Privals_Chain (Comp_Id, New_Elmt_List); Edef := Make_Defining_Identifier (Loc, ! Build_Selected_Name (Prottyp, Comp_Id, 'E')); ! Sub := Make_Subprogram_Declaration (Loc, Specification => ! Build_Protected_Entry_Specification (Edef, Comp_Id, Loc)); Insert_After (Current_Node, Sub); Analyze (Sub); ! Set_Protected_Body_Subprogram ( ! Defining_Identifier (Comp), ! Defining_Unit_Name (Specification (Sub))); Current_Node := Sub; Bdef := Make_Defining_Identifier (Loc, ! Build_Selected_Name (Prottyp, Comp_Id, 'E')); Sub := Make_Subprogram_Declaration (Loc, Specification => ! Build_Barrier_Function_Specification (Bdef, Loc)); Insert_After (Current_Node, Sub); Analyze (Sub); --- 7894,7925 ---- if Nkind (Comp) = N_Entry_Declaration then E_Count := E_Count + 1; Comp_Id := Defining_Identifier (Comp); ! Edef := Make_Defining_Identifier (Loc, ! Build_Selected_Name (Prot_Typ, Comp_Id, 'E')); Sub := Make_Subprogram_Declaration (Loc, Specification => ! Build_Protected_Entry_Specification (Loc, Edef, Comp_Id)); Insert_After (Current_Node, Sub); Analyze (Sub); ! Set_Protected_Body_Subprogram ! (Defining_Identifier (Comp), ! Defining_Unit_Name (Specification (Sub))); Current_Node := Sub; Bdef := Make_Defining_Identifier (Loc, ! Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'E')); Sub := Make_Subprogram_Declaration (Loc, Specification => ! Build_Barrier_Function_Specification (Loc, Bdef)); Insert_After (Current_Node, Sub); Analyze (Sub); *************** package body Exp_Ch9 is *** 7669,7675 **** -- Collect pointers to the protected subprogram and the barrier -- of the current entry, for insertion into Entry_Bodies_Array. ! Append ( Make_Aggregate (Loc, Expressions => New_List ( Make_Attribute_Reference (Loc, --- 7931,7937 ---- -- Collect pointers to the protected subprogram and the barrier -- of the current entry, for insertion into Entry_Bodies_Array. ! Append_To (Expressions (Entries_Aggr), Make_Aggregate (Loc, Expressions => New_List ( Make_Attribute_Reference (Loc, *************** package body Exp_Ch9 is *** 7677,7684 **** Attribute_Name => Name_Unrestricted_Access), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Edef, Loc), ! Attribute_Name => Name_Unrestricted_Access))), ! Expressions (Entries_Aggr)); end if; Next (Comp); --- 7939,7945 ---- Attribute_Name => Name_Unrestricted_Access), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Edef, Loc), ! Attribute_Name => Name_Unrestricted_Access)))); end if; Next (Comp); *************** package body Exp_Ch9 is *** 7688,7733 **** -- Emit declaration for Entry_Bodies_Array, now that the addresses of -- all protected subprograms have been collected. ! if Has_Entries (Prottyp) then ! Body_Id := Make_Defining_Identifier (Sloc (Prottyp), ! New_External_Name (Chars (Prottyp), 'A')); ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else E_Count > 1 ! or else (Has_Attach_Handler (Prottyp) ! and then not Restricted_Profile) ! then ! Body_Arr := Make_Object_Declaration (Loc, ! Defining_Identifier => Body_Id, ! Aliased_Present => True, ! Object_Definition => ! Make_Subtype_Indication (Loc, ! Subtype_Mark => New_Reference_To ( ! RTE (RE_Protected_Entry_Body_Array), Loc), ! Constraint => ! Make_Index_Or_Discriminant_Constraint (Loc, ! Constraints => New_List ( ! Make_Range (Loc, ! Make_Integer_Literal (Loc, 1), ! Make_Integer_Literal (Loc, E_Count))))), ! Expression => Entries_Aggr); ! else ! Body_Arr := Make_Object_Declaration (Loc, ! Defining_Identifier => Body_Id, ! Aliased_Present => True, ! Object_Definition => New_Reference_To (RTE (RE_Entry_Body), Loc), ! Expression => ! Make_Aggregate (Loc, ! Expressions => New_List ( ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Bdef, Loc), ! Attribute_Name => Name_Unrestricted_Access), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Edef, Loc), ! Attribute_Name => Name_Unrestricted_Access)))); ! end if; -- A pointer to this array will be placed in the corresponding record -- by its initialization procedure so this needs to be analyzed here. --- 7949,7995 ---- -- Emit declaration for Entry_Bodies_Array, now that the addresses of -- all protected subprograms have been collected. ! if Has_Entries (Prot_Typ) then ! Body_Id := ! Make_Defining_Identifier (Sloc (Prot_Typ), ! Chars => New_External_Name (Chars (Prot_Typ), 'A')); ! case Corresponding_Runtime_Package (Prot_Typ) is ! when System_Tasking_Protected_Objects_Entries => ! Body_Arr := Make_Object_Declaration (Loc, ! Defining_Identifier => Body_Id, ! Aliased_Present => True, ! Object_Definition => ! Make_Subtype_Indication (Loc, ! Subtype_Mark => New_Reference_To ( ! RTE (RE_Protected_Entry_Body_Array), Loc), ! Constraint => ! Make_Index_Or_Discriminant_Constraint (Loc, ! Constraints => New_List ( ! Make_Range (Loc, ! Make_Integer_Literal (Loc, 1), ! Make_Integer_Literal (Loc, E_Count))))), ! Expression => Entries_Aggr); ! when System_Tasking_Protected_Objects_Single_Entry => ! Body_Arr := Make_Object_Declaration (Loc, ! Defining_Identifier => Body_Id, ! Aliased_Present => True, ! Object_Definition => New_Reference_To ! (RTE (RE_Entry_Body), Loc), ! Expression => ! Make_Aggregate (Loc, ! Expressions => New_List ( ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Bdef, Loc), ! Attribute_Name => Name_Unrestricted_Access), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Edef, Loc), ! Attribute_Name => Name_Unrestricted_Access)))); ! ! when others => ! raise Program_Error; ! end case; -- A pointer to this array will be placed in the corresponding record -- by its initialization procedure so this needs to be analyzed here. *************** package body Exp_Ch9 is *** 7736,7757 **** Current_Node := Body_Arr; Analyze (Body_Arr); ! Set_Entry_Bodies_Array (Prottyp, Body_Id); -- Finally, build the function that maps an entry index into the -- corresponding body. A pointer to this function is placed in each -- object of the type. Except for a ravenscar-like profile (no abort, -- no entry queue, 1 entry) ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else E_Count > 1 ! or else (Has_Attach_Handler (Prottyp) ! and then not Restricted_Profile) then Sub := Make_Subprogram_Declaration (Loc, ! Specification => Build_Find_Body_Index_Spec (Prottyp)); Insert_After (Current_Node, Sub); Analyze (Sub); end if; --- 7998,8016 ---- Current_Node := Body_Arr; Analyze (Body_Arr); ! Set_Entry_Bodies_Array (Prot_Typ, Body_Id); -- Finally, build the function that maps an entry index into the -- corresponding body. A pointer to this function is placed in each -- object of the type. Except for a ravenscar-like profile (no abort, -- no entry queue, 1 entry) ! if Corresponding_Runtime_Package (Prot_Typ) = ! System_Tasking_Protected_Objects_Entries then Sub := Make_Subprogram_Declaration (Loc, ! Specification => Build_Find_Body_Index_Spec (Prot_Typ)); Insert_After (Current_Node, Sub); Analyze (Sub); end if; *************** package body Exp_Ch9 is *** 8341,8347 **** Make_Defining_Identifier (Sloc (Ename), New_External_Name (Chars (Ename), 'A', Num_Accept)); ! Set_Needs_Debug_Info (PB_Ent, Comes_From_Source (Alt)); Proc_Body := Make_Subprogram_Body (Loc, --- 8600,8608 ---- Make_Defining_Identifier (Sloc (Ename), New_External_Name (Chars (Ename), 'A', Num_Accept)); ! if Comes_From_Source (Alt) then ! Set_Debug_Info_Needed (PB_Ent); ! end if; Proc_Body := Make_Subprogram_Body (Loc, *************** package body Exp_Ch9 is *** 8460,8466 **** Alt_Stats := New_List; end if; ! -- After the call, if any, branch to to trailing statements. We -- create a label for each, as well as the corresponding label -- declaration. --- 8721,8727 ---- Alt_Stats := New_List; end if; ! -- After the call, if any, branch to trailing statements. We -- create a label for each, as well as the corresponding label -- declaration. *************** package body Exp_Ch9 is *** 9252,9261 **** Call : Node_Id; New_N : Node_Id; begin ! -- Here we start the expansion by generating discriminal declarations ! Add_Discriminal_Declarations (Declarations (N), Ttyp, Name_uTask, Loc); -- Add a call to Abort_Undefer at the very beginning of the task -- body since this body is called with abort still deferred. --- 9513,9527 ---- Call : Node_Id; New_N : Node_Id; + Insert_Nod : Node_Id; + -- Used to determine the proper location of wrapper body insertions + begin ! -- Add renaming declarations for discriminals and a declaration for the ! -- entry family index (if applicable). ! Install_Private_Data_Declarations ! (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N)); -- Add a call to Abort_Undefer at the very beginning of the task -- body since this body is called with abort still deferred. *************** package body Exp_Ch9 is *** 9286,9300 **** New_N := Make_Subprogram_Body (Loc, ! Specification => Build_Task_Proc_Specification (Ttyp), ! Declarations => Declarations (N), Handled_Statement_Sequence => Handled_Statement_Sequence (N)); ! -- If the task contains generic instantiations, cleanup actions ! -- are delayed until after instantiation. Transfer the activation ! -- chain to the subprogram, to insure that the activation call is ! -- properly generated. It the task body contains inner tasks, indicate ! -- that the subprogram is a task master. if Delay_Cleanups (Ttyp) then Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); --- 9552,9566 ---- New_N := Make_Subprogram_Body (Loc, ! Specification => Build_Task_Proc_Specification (Ttyp), ! Declarations => Declarations (N), Handled_Statement_Sequence => Handled_Statement_Sequence (N)); ! -- If the task contains generic instantiations, cleanup actions are ! -- delayed until after instantiation. Transfer the activation chain to ! -- the subprogram, to insure that the activation call is properly ! -- generated. It the task body contains inner tasks, indicate that the ! -- subprogram is a task master. if Delay_Cleanups (Ttyp) then Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); *************** package body Exp_Ch9 is *** 9316,9373 **** end if; -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after ! -- the task body. At this point the entry specs have been created, -- frozen and included in the dispatch table for the task type. ! pragma Assert (Present (Corresponding_Record_Type (Ttyp))); ! ! if Ada_Version >= Ada_05 ! and then Present (Task_Definition (Parent (Ttyp))) ! and then Present (Abstract_Interfaces ! (Corresponding_Record_Type (Ttyp))) ! then ! declare ! Current_Node : Node_Id; ! Vis_Decl : Node_Id := ! First (Visible_Declarations (Task_Definition (Parent (Ttyp)))); ! Wrap_Body : Node_Id; ! ! begin ! if Nkind (Parent (N)) = N_Subunit then ! Current_Node := Corresponding_Stub (Parent (N)); ! else ! Current_Node := N; ! end if; ! ! -- Examine the visible declarations of the task type, looking for ! -- an entry declaration. We do not consider entry families since ! -- they cannot have dispatching operations, thus they do not need ! -- entry wrappers. ! ! while Present (Vis_Decl) loop ! if Nkind (Vis_Decl) = N_Entry_Declaration ! and then Ekind (Defining_Identifier (Vis_Decl)) = E_Entry ! then ! ! -- Create the specification of the wrapper ! ! Wrap_Body := ! Build_Wrapper_Body (Loc, ! Proc_Nam => Defining_Identifier (Vis_Decl), ! Obj_Typ => Corresponding_Record_Type (Ttyp), ! Formals => Parameter_Specifications (Vis_Decl)); ! ! if Wrap_Body /= Empty then ! Insert_After (Current_Node, Wrap_Body); ! Current_Node := Wrap_Body; ! ! Analyze (Wrap_Body); ! end if; ! end if; ! Next (Vis_Decl); ! end loop; ! end; end if; end Expand_N_Task_Body; --- 9582,9598 ---- end if; -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after ! -- the task body. At this point all wrapper specs have been created, -- frozen and included in the dispatch table for the task type. ! if Ada_Version >= Ada_05 then ! if Nkind (Parent (N)) = N_Subunit then ! Insert_Nod := Corresponding_Stub (Parent (N)); ! else ! Insert_Nod := N; ! end if; ! Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod); end if; end Expand_N_Task_Body; *************** package body Exp_Ch9 is *** 9392,9397 **** --- 9617,9626 ---- -- or -- taskZ : Size_Type := Size_Type (size_expression); + -- Note: No variable is needed to hold the task relative deadline since + -- its value would never be static because the parameter is of a private + -- type (Ada.Real_Time.Time_Span). + -- Next we create a corresponding record type declaration used to represent -- values of this task. The general form of this type declaration is *************** package body Exp_Ch9 is *** 9434,9439 **** --- 9663,9673 ---- -- present in the pragma, and is used to provide the Task_Image parameter -- to the call to Create_Task. + -- The _Relative_Deadline field is present only if a Relative_Deadline + -- pragma appears in the task definition. The expression captures the + -- argument that was present in the pragma, and is used to provide the + -- Relative_Deadline parameter to the call to Create_Task. + -- When a task is declared, an instance of the task value record is -- created. The elaboration of this declaration creates the correct bounds -- for the entry families, and also evaluates the size, priority, and *************** package body Exp_Ch9 is *** 9465,9474 **** -- the case of a simple entry. procedure Expand_N_Task_Type_Declaration (N : Node_Id) is ! Loc : constant Source_Ptr := Sloc (N); ! Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); ! Tasknm : constant Name_Id := Chars (Tasktyp); ! Taskdef : constant Node_Id := Task_Definition (N); Proc_Spec : Node_Id; Rec_Decl : Node_Id; --- 9699,9708 ---- -- the case of a simple entry. procedure Expand_N_Task_Type_Declaration (N : Node_Id) is ! Loc : constant Source_Ptr := Sloc (N); ! Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); ! Tasknm : constant Name_Id := Chars (Tasktyp); ! Taskdef : constant Node_Id := Task_Definition (N); Proc_Spec : Node_Id; Rec_Decl : Node_Id; *************** package body Exp_Ch9 is *** 9685,9691 **** -- the benefit of some versions of System.Interrupts which use -- a special server task with maximum interrupt priority. ! if Chars (Prag) = Name_Priority and then not GNAT_Mode then Rewrite (Expr, Convert_To (RTE (RE_Priority), Expr)); --- 9919,9925 ---- -- the benefit of some versions of System.Interrupts which use -- a special server task with maximum interrupt priority. ! if Pragma_Name (Prag) = Name_Priority and then not GNAT_Mode then Rewrite (Expr, Convert_To (RTE (RE_Priority), Expr)); *************** package body Exp_Ch9 is *** 9752,9757 **** --- 9986,10019 ---- (Taskdef, Name_Task_Info))))))); end if; + -- Add the _Relative_Deadline component if a Relative_Deadline pragma is + -- present. If we are using a restricted run time this component will + -- not be added (deadlines are not allowed by the Ravenscar profile). + + if not Restricted_Profile + and then Present (Taskdef) + and then Has_Relative_Deadline_Pragma (Taskdef) + then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uRelative_Deadline), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Reference_To (RTE (RE_Time_Span), Loc)), + + Expression => + Convert_To (RTE (RE_Time_Span), + Relocate_Node ( + Expression (First ( + Pragma_Argument_Associations ( + Find_Task_Or_Protected_Pragma + (Taskdef, Name_Relative_Deadline)))))))); + end if; + Insert_After (Size_Decl, Rec_Decl); -- Analyze the record declaration immediately after construction, *************** package body Exp_Ch9 is *** 9772,9828 **** -- The subprogram does not comes from source, so we have to indicate the -- need for debugging information explicitly. ! Set_Needs_Debug_Info ! (Defining_Entity (Proc_Spec), Comes_From_Source (Original_Node (N))); -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before -- the corresponding record has been frozen. ! if Ada_Version >= Ada_05 ! and then Present (Taskdef) ! and then Present (Corresponding_Record_Type ! (Defining_Identifier (Parent (Taskdef)))) ! and then Present (Abstract_Interfaces ! (Corresponding_Record_Type ! (Defining_Identifier (Parent (Taskdef))))) ! then ! declare ! Current_Node : Node_Id := Rec_Decl; ! Vis_Decl : Node_Id := First (Visible_Declarations (Taskdef)); ! Wrap_Spec : Node_Id; ! New_N : Node_Id; ! ! begin ! -- Examine the visible declarations of the task type, looking for ! -- an entry declaration. We do not consider entry families since ! -- they cannot have dispatching operations, thus they do not need ! -- entry wrappers. ! ! while Present (Vis_Decl) loop ! if Nkind (Vis_Decl) = N_Entry_Declaration ! and then Ekind (Defining_Identifier (Vis_Decl)) = E_Entry ! then ! Wrap_Spec := ! Build_Wrapper_Spec (Loc, ! Proc_Nam => Defining_Identifier (Vis_Decl), ! Obj_Typ => Etype (Rec_Ent), ! Formals => Parameter_Specifications (Vis_Decl)); ! ! if Wrap_Spec /= Empty then ! New_N := ! Make_Subprogram_Declaration (Loc, ! Specification => Wrap_Spec); ! ! Insert_After (Current_Node, New_N); ! Current_Node := New_N; ! ! Analyze (New_N); ! end if; ! end if; ! ! Next (Vis_Decl); ! end loop; ! end; end if; -- Ada 2005 (AI-345): We must defer freezing to allow further --- 10034,10048 ---- -- The subprogram does not comes from source, so we have to indicate the -- need for debugging information explicitly. ! if Comes_From_Source (Original_Node (N)) then ! Set_Debug_Info_Needed (Defining_Entity (Proc_Spec)); ! end if; -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before -- the corresponding record has been frozen. ! if Ada_Version >= Ada_05 then ! Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl); end if; -- Ada 2005 (AI-345): We must defer freezing to allow further *************** package body Exp_Ch9 is *** 9838,9844 **** declare L : constant List_Id := Freeze_Entity (Rec_Ent, Loc); - begin if Is_Non_Empty_List (L) then Insert_List_After (Body_Decl, L); --- 10058,10063 ---- *************** package body Exp_Ch9 is *** 10115,10121 **** Expression => D_Disc)); ! -- Do the assignement at this stage only because the evaluation of the -- expression must not occur before (see ACVC C97302A). Append_To (Stmts, --- 10334,10340 ---- Expression => D_Disc)); ! -- Do the assignment at this stage only because the evaluation of the -- expression must not occur before (see ACVC C97302A). Append_To (Stmts, *************** package body Exp_Ch9 is *** 10315,10321 **** Next (Stmt); end loop; ! -- Do the assignement at this stage only because the evaluation -- of the expression must not occur before (see ACVC C97302A). Insert_Before (Stmt, --- 10534,10540 ---- Next (Stmt); end loop; ! -- Do the assignment at this stage only because the evaluation -- of the expression must not occur before (see ACVC C97302A). Insert_Before (Stmt, *************** package body Exp_Ch9 is *** 10358,10389 **** Append_To (Params, New_Reference_To (B, Loc)); ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Number_Entries (Etype (Concval)) > 1 ! then ! Rewrite (Call, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To (RTE ( ! RE_Timed_Protected_Entry_Call), Loc), ! Parameter_Associations => Params)); ! else ! Param := First (Params); ! while Present (Param) ! and then not Is_RTE (Etype (Param), RE_Protected_Entry_Index) ! loop ! Next (Param); ! end loop; ! Remove (Param); ! Rewrite (Call, ! Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To ( ! RTE (RE_Timed_Protected_Single_Entry_Call), Loc), ! Parameter_Associations => Params)); ! end if; -- For the task case, build a Timed_Task_Entry_Call --- 10577,10611 ---- Append_To (Params, New_Reference_To (B, Loc)); ! case Corresponding_Runtime_Package (Etype (Concval)) is ! when System_Tasking_Protected_Objects_Entries => ! Rewrite (Call, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To ! (RTE (RE_Timed_Protected_Entry_Call), Loc), ! Parameter_Associations => Params)); ! when System_Tasking_Protected_Objects_Single_Entry => ! Param := First (Params); ! while Present (Param) ! and then not ! Is_RTE (Etype (Param), RE_Protected_Entry_Index) ! loop ! Next (Param); ! end loop; ! Remove (Param); ! ! Rewrite (Call, ! Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To ( ! RTE (RE_Timed_Protected_Single_Entry_Call), Loc), ! Parameter_Associations => Params)); ! ! when others => ! raise Program_Error; ! end case; -- For the task case, build a Timed_Task_Entry_Call *************** package body Exp_Ch9 is *** 10421,10476 **** -- Expand_Protected_Body_Declarations -- ---------------------------------------- - -- Part of the expansion of a protected body involves the creation of a - -- declaration that can be referenced from the statement sequences of the - -- entry bodies: - - -- A : Address; - - -- This declaration is inserted in the declarations of the service entries - -- procedure for the protected body, and it is important that it be - -- inserted before the statements of the entry body statement sequences are - -- analyzed. Thus it would be too late to create this declaration in the - -- Expand_N_Protected_Body routine, which is why there is a separate - -- procedure to be called directly from Sem_Ch9. - - -- Ann is used to hold the address of the record containing the parameters - -- (see Expand_N_Entry_Call for more details on how this record is built). - -- References to the parameters do an unchecked conversion of this address - -- to a pointer to the required record type, and then access the field that - -- holds the value of the required parameter. The entity for the address - -- variable is held as the top stack element (i.e. the last element) of the - -- Accept_Address stack in the corresponding entry entity, and this element - -- must be set in place before the statements are processed. - - -- No stack is needed for entry bodies, since they cannot be nested, but it - -- is kept for consistency between protected and task entries. The stack - -- will never contain more than one element. There is also only one such - -- variable for a given protected body, but this is placed on the - -- Accept_Address stack of all of the entries, again for consistency. - - -- To expand the requeue statement, a label is provided at the end of the - -- loop in the entry service routine created by the expander (see - -- Expand_N_Protected_Body for details), so that the statement can be - -- skipped after the requeue is complete. This label is created during the - -- expansion of the entry body, which will take place after the expansion - -- of the requeue statements that it contains, so a placeholder defining - -- identifier is associated with the task type here. - - -- Another label is provided following case statement created by the - -- expander. This label is need for implementing return statement from - -- entry body so that a return can be expanded as a goto to this label. - -- This label is created during the expansion of the entry body, which - -- will take place after the expansion of the return statements that it - -- contains. Therefore, just like the label for expanding requeues, we - -- need another placeholder for the label. - procedure Expand_Protected_Body_Declarations (N : Node_Id; Spec_Id : Entity_Id) is - Op : Node_Id; - begin if No_Run_Time_Mode then Error_Msg_CRT ("protected body", N); --- 10643,10652 ---- *************** package body Exp_Ch9 is *** 10478,10492 **** elsif Expander_Active then ! -- Associate privals with the first subprogram or entry body to be ! -- expanded. These are used to expand references to private data ! -- objects. ! ! Op := First_Protected_Operation (Declarations (N)); ! if Present (Op) then Set_Discriminals (Parent (Spec_Id)); - Set_Privals (Parent (Spec_Id), Op, Sloc (N)); end if; end if; end Expand_Protected_Body_Declarations; --- 10654,10664 ---- elsif Expander_Active then ! -- Associate discriminals with the first subprogram or entry body to ! -- be expanded. ! if Present (First_Protected_Operation (Declarations (N))) then Set_Discriminals (Parent (Spec_Id)); end if; end if; end Expand_Protected_Body_Declarations; *************** package body Exp_Ch9 is *** 10749,10759 **** N := First (Visible_Declarations (T)); while Present (N) loop if Nkind (N) = N_Pragma then ! if Chars (N) = P then return N; elsif P = Name_Priority ! and then Chars (N) = Name_Interrupt_Priority then return N; --- 10921,10931 ---- N := First (Visible_Declarations (T)); while Present (N) loop if Nkind (N) = N_Pragma then ! if Pragma_Name (N) = P then return N; elsif P = Name_Priority ! and then Pragma_Name (N) = Name_Interrupt_Priority then return N; *************** package body Exp_Ch9 is *** 10769,10779 **** N := First (Private_Declarations (T)); while Present (N) loop if Nkind (N) = N_Pragma then ! if Chars (N) = P then return N; elsif P = Name_Priority ! and then Chars (N) = Name_Interrupt_Priority then return N; --- 10941,10951 ---- N := First (Private_Declarations (T)); while Present (N) loop if Nkind (N) = N_Pragma then ! if Pragma_Name (N) = P then return N; elsif P = Name_Priority ! and then Pragma_Name (N) = Name_Interrupt_Priority then return N; *************** package body Exp_Ch9 is *** 10807,10937 **** return First_Op; end First_Protected_Operation; ! --------------------------------- ! -- Is_Potentially_Large_Family -- ! --------------------------------- ! function Is_Potentially_Large_Family ! (Base_Index : Entity_Id; ! Conctyp : Entity_Id; ! Lo : Node_Id; ! Hi : Node_Id) return Boolean is ! begin ! return Scope (Base_Index) = Standard_Standard ! and then Base_Index = Base_Type (Standard_Integer) ! and then Has_Discriminants (Conctyp) ! and then Present ! (Discriminant_Default_Value (First_Discriminant (Conctyp))) ! and then ! (Denotes_Discriminant (Lo, True) ! or else Denotes_Discriminant (Hi, True)); ! end Is_Potentially_Large_Family; ! -------------------------------- ! -- Index_Constant_Declaration -- ! -------------------------------- ! function Index_Constant_Declaration ! (N : Node_Id; ! Index_Id : Entity_Id; ! Prot : Entity_Id) return List_Id ! is ! Loc : constant Source_Ptr := Sloc (N); ! Decls : constant List_Id := New_List; ! Index_Con : constant Entity_Id := Entry_Index_Constant (Index_Id); ! Index_Typ : Entity_Id; ! Hi : Node_Id := Type_High_Bound (Etype (Index_Id)); ! Lo : Node_Id := Type_Low_Bound (Etype (Index_Id)); ! function Replace_Discriminant (Bound : Node_Id) return Node_Id; ! -- The bounds of the entry index may depend on discriminants, so each ! -- declaration of an entry_index_constant must have its own subtype ! -- declaration, using the local renaming of the object discriminant. -------------------------- -- Replace_Discriminant -- -------------------------- ! function Replace_Discriminant (Bound : Node_Id) return Node_Id is begin if Nkind (Bound) = N_Identifier ! and then Ekind (Entity (Bound)) = E_Constant ! and then Present (Discriminal_Link (Entity (Bound))) then return Make_Identifier (Loc, Chars (Entity (Bound))); else return Duplicate_Subexpr (Bound); end if; ! end Replace_Discriminant; ! -- Start of processing for Index_Constant_Declaration begin ! Set_Discriminal_Link (Index_Con, Index_Id); ! if Is_Entity_Name ( ! Original_Node (Discrete_Subtype_Definition (Parent (Index_Id)))) then ! -- Simple case: entry family is given by a subtype mark, and index ! -- constant has the same type, no replacement needed. ! Index_Typ := Etype (Index_Id); ! else ! Hi := Replace_Discriminant (Hi); ! Lo := Replace_Discriminant (Lo); ! Index_Typ := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); ! Append ( ! Make_Subtype_Declaration (Loc, ! Defining_Identifier => Index_Typ, ! Subtype_Indication => ! Make_Subtype_Indication (Loc, ! Subtype_Mark => ! New_Occurrence_Of (Base_Type (Etype (Index_Id)), Loc), ! Constraint => ! Make_Range_Constraint (Loc, ! Range_Expression => Make_Range (Loc, Lo, Hi)))), ! Decls); end if; ! Append ( ! Make_Object_Declaration (Loc, ! Defining_Identifier => Index_Con, ! Constant_Present => True, ! Object_Definition => New_Occurrence_Of (Index_Typ, Loc), ! Expression => ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Index_Typ, Loc), ! Attribute_Name => Name_Val, ! Expressions => New_List ( ! Make_Op_Add (Loc, ! Left_Opnd => ! Make_Op_Subtract (Loc, ! Left_Opnd => Make_Identifier (Loc, Name_uE), ! Right_Opnd => ! Entry_Index_Expression (Loc, ! Defining_Identifier (N), Empty, Prot)), ! Right_Opnd => ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Index_Typ, Loc), ! Attribute_Name => Name_Pos, ! Expressions => New_List ( ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Index_Typ, Loc), ! Attribute_Name => Name_First))))))), ! Decls); ! return Decls; ! end Index_Constant_Declaration; -------------------------------- -- Make_Initialize_Protection -- --- 10979,11423 ---- return First_Op; end First_Protected_Operation; ! --------------------------------------- ! -- Install_Private_Data_Declarations -- ! --------------------------------------- ! procedure Install_Private_Data_Declarations ! (Loc : Source_Ptr; ! Spec_Id : Entity_Id; ! Conc_Typ : Entity_Id; ! Body_Nod : Node_Id; ! Decls : List_Id; ! Barrier : Boolean := False; ! Family : Boolean := False) is ! Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ); ! Decl : Node_Id; ! Def : Node_Id; ! Insert_Node : Node_Id := Empty; ! Obj_Ent : Entity_Id; ! procedure Add (Decl : Node_Id); ! -- Add a single declaration after Insert_Node. If this is the first ! -- addition, Decl is added to the front of Decls and it becomes the ! -- insertion node. ! function Replace_Bound (Bound : Node_Id) return Node_Id; ! -- The bounds of an entry index may depend on discriminants, create a ! -- reference to the corresponding prival. Otherwise return a duplicate ! -- of the original bound. ! --------- ! -- Add -- ! --------- ! procedure Add (Decl : Node_Id) is ! begin ! if No (Insert_Node) then ! Prepend_To (Decls, Decl); ! else ! Insert_After (Insert_Node, Decl); ! end if; ! ! Insert_Node := Decl; ! end Add; -------------------------- -- Replace_Discriminant -- -------------------------- ! function Replace_Bound (Bound : Node_Id) return Node_Id is begin if Nkind (Bound) = N_Identifier ! and then Is_Discriminal (Entity (Bound)) then return Make_Identifier (Loc, Chars (Entity (Bound))); else return Duplicate_Subexpr (Bound); end if; ! end Replace_Bound; ! -- Start of processing for Install_Private_Data_Declarations begin ! -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote ! -- formal parameter _O, _object or _task depending on the context. ! Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ); ! ! -- Special processing of _O for barrier functions, protected entries ! -- and families. ! ! if Barrier ! or else ! (Is_Protected ! and then ! (Ekind (Spec_Id) = E_Entry ! or else Ekind (Spec_Id) = E_Entry_Family)) then ! declare ! Conc_Rec : constant Entity_Id := ! Corresponding_Record_Type (Conc_Typ); ! Typ_Id : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! New_External_Name (Chars (Conc_Rec), 'P')); ! begin ! -- Generate: ! -- type prot_typVP is access prot_typV; ! Decl := ! Make_Full_Type_Declaration (Loc, ! Defining_Identifier => Typ_Id, ! Type_Definition => ! Make_Access_To_Object_Definition (Loc, ! Subtype_Indication => ! New_Reference_To (Conc_Rec, Loc))); ! Add (Decl); ! -- Generate: ! -- _object : prot_typVP := prot_typV (_O); ! Decl := ! Make_Object_Declaration (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, Name_uObject), ! Object_Definition => New_Reference_To (Typ_Id, Loc), ! Expression => ! Unchecked_Convert_To (Typ_Id, ! New_Reference_To (Obj_Ent, Loc))); ! Add (Decl); ! -- Set the reference to the concurrent object + Obj_Ent := Defining_Identifier (Decl); + end; end if; ! -- Step 2: Create the Protection object and build its declaration for ! -- any protected entry (family) of subprogram. ! if Is_Protected then ! declare ! Prot_Ent : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! New_Internal_Name ('R')); ! Prot_Typ : RE_Id; ! begin ! Set_Protection_Object (Spec_Id, Prot_Ent); ! -- Determine the proper protection type ! if Has_Attach_Handler (Conc_Typ) ! and then not Restricted_Profile ! then ! Prot_Typ := RE_Static_Interrupt_Protection; ! elsif Has_Interrupt_Handler (Conc_Typ) then ! Prot_Typ := RE_Dynamic_Interrupt_Protection; ! ! -- The type has explicit entries or generated primitive entry ! -- wrappers. ! ! elsif Has_Entries (Conc_Typ) ! or else ! (Ada_Version >= Ada_05 ! and then Present (Interface_List (Parent (Conc_Typ)))) ! then ! case Corresponding_Runtime_Package (Conc_Typ) is ! when System_Tasking_Protected_Objects_Entries => ! Prot_Typ := RE_Protection_Entries; ! ! when System_Tasking_Protected_Objects_Single_Entry => ! Prot_Typ := RE_Protection_Entry; ! ! when others => ! raise Program_Error; ! end case; ! ! else ! Prot_Typ := RE_Protection; ! end if; ! ! -- Generate: ! -- conc_typR : protection_typ renames _object._object; ! ! Decl := ! Make_Object_Renaming_Declaration (Loc, ! Defining_Identifier => Prot_Ent, ! Subtype_Mark => ! New_Reference_To (RTE (Prot_Typ), Loc), ! Name => ! Make_Selected_Component (Loc, ! Prefix => ! New_Reference_To (Obj_Ent, Loc), ! Selector_Name => ! Make_Identifier (Loc, Name_uObject))); ! Add (Decl); ! end; ! end if; ! ! -- Step 3: Add discriminant renamings (if any) ! ! if Has_Discriminants (Conc_Typ) then ! declare ! D : Entity_Id; ! ! begin ! D := First_Discriminant (Conc_Typ); ! while Present (D) loop ! ! -- Adjust the source location ! ! Set_Sloc (Discriminal (D), Loc); ! ! -- Generate: ! -- discr_name : discr_typ renames _object.discr_name; ! -- or ! -- discr_name : discr_typ renames _task.discr_name; ! ! Decl := ! Make_Object_Renaming_Declaration (Loc, ! Defining_Identifier => Discriminal (D), ! Subtype_Mark => New_Reference_To (Etype (D), Loc), ! Name => ! Make_Selected_Component (Loc, ! Prefix => New_Reference_To (Obj_Ent, Loc), ! Selector_Name => Make_Identifier (Loc, Chars (D)))); ! Add (Decl); ! ! Next_Discriminant (D); ! end loop; ! end; ! end if; ! ! -- Step 4: Add private component renamings (if any) ! ! if Is_Protected then ! Def := Protected_Definition (Parent (Conc_Typ)); ! ! if Present (Private_Declarations (Def)) then ! declare ! Comp : Node_Id; ! Comp_Id : Entity_Id; ! Decl_Id : Entity_Id; ! ! begin ! Comp := First (Private_Declarations (Def)); ! while Present (Comp) loop ! if Nkind (Comp) = N_Component_Declaration then ! Comp_Id := Defining_Identifier (Comp); ! Decl_Id := ! Make_Defining_Identifier (Loc, Chars (Comp_Id)); ! ! -- Minimal decoration ! ! if Ekind (Spec_Id) = E_Function then ! Set_Ekind (Decl_Id, E_Constant); ! else ! Set_Ekind (Decl_Id, E_Variable); ! end if; ! ! Set_Prival (Comp_Id, Decl_Id); ! Set_Prival_Link (Decl_Id, Comp_Id); ! Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id)); ! ! -- Generate: ! -- comp_name : comp_typ renames _object.comp_name; ! ! Decl := ! Make_Object_Renaming_Declaration (Loc, ! Defining_Identifier => Decl_Id, ! Subtype_Mark => ! New_Reference_To (Etype (Comp_Id), Loc), ! Name => ! Make_Selected_Component (Loc, ! Prefix => ! New_Reference_To (Obj_Ent, Loc), ! Selector_Name => ! Make_Identifier (Loc, Chars (Comp_Id)))); ! Add (Decl); ! end if; ! ! Next (Comp); ! end loop; ! end; ! end if; ! end if; ! ! -- Step 5: Add the declaration of the entry index and the associated ! -- type for barrier functions and entry families. ! ! if (Barrier and then Family) ! or else Ekind (Spec_Id) = E_Entry_Family ! then ! declare ! E : constant Entity_Id := Index_Object (Spec_Id); ! Index : constant Entity_Id := ! Defining_Identifier ( ! Entry_Index_Specification ( ! Entry_Body_Formal_Part (Body_Nod))); ! Index_Con : constant Entity_Id := ! Make_Defining_Identifier (Loc, Chars (Index)); ! High : Node_Id; ! Index_Typ : Entity_Id; ! Low : Node_Id; ! ! begin ! -- Minimal decoration ! ! Set_Ekind (Index_Con, E_Constant); ! Set_Entry_Index_Constant (Index, Index_Con); ! Set_Discriminal_Link (Index_Con, Index); ! ! -- Retrieve the bounds of the entry family ! ! High := Type_High_Bound (Etype (Index)); ! Low := Type_Low_Bound (Etype (Index)); ! ! -- In the simple case the entry family is given by a subtype ! -- mark and the index constant has the same type. ! ! if Is_Entity_Name (Original_Node ( ! Discrete_Subtype_Definition (Parent (Index)))) ! then ! Index_Typ := Etype (Index); ! ! -- Otherwise a new subtype declaration is required ! ! else ! High := Replace_Bound (High); ! Low := Replace_Bound (Low); ! ! Index_Typ := ! Make_Defining_Identifier (Loc, New_Internal_Name ('J')); ! ! -- Generate: ! -- subtype Jnn is range Low .. High; ! ! Decl := ! Make_Subtype_Declaration (Loc, ! Defining_Identifier => Index_Typ, ! Subtype_Indication => ! Make_Subtype_Indication (Loc, ! Subtype_Mark => ! New_Reference_To (Base_Type (Etype (Index)), Loc), ! Constraint => ! Make_Range_Constraint (Loc, ! Range_Expression => ! Make_Range (Loc, Low, High)))); ! Add (Decl); ! end if; ! ! Set_Etype (Index_Con, Index_Typ); ! ! -- Create the object which designates the index: ! -- J : constant Jnn := ! -- Jnn'Val (_E - + Jnn'Pos (Jnn'First)); ! -- ! -- where Jnn is the subtype created above or the original type of ! -- the index, _E is a formal of the protected body subprogram and ! -- is the index of the first family member. ! ! Decl := ! Make_Object_Declaration (Loc, ! Defining_Identifier => Index_Con, ! Constant_Present => True, ! Object_Definition => ! New_Reference_To (Index_Typ, Loc), ! ! Expression => ! Make_Attribute_Reference (Loc, ! Prefix => ! New_Reference_To (Index_Typ, Loc), ! Attribute_Name => Name_Val, ! ! Expressions => New_List ( ! ! Make_Op_Add (Loc, ! Left_Opnd => ! Make_Op_Subtract (Loc, ! Left_Opnd => ! New_Reference_To (E, Loc), ! Right_Opnd => ! Entry_Index_Expression (Loc, ! Defining_Identifier (Body_Nod), ! Empty, Conc_Typ)), ! ! Right_Opnd => ! Make_Attribute_Reference (Loc, ! Prefix => ! New_Reference_To (Index_Typ, Loc), ! Attribute_Name => Name_Pos, ! Expressions => New_List ( ! Make_Attribute_Reference (Loc, ! Prefix => ! New_Reference_To (Index_Typ, Loc), ! Attribute_Name => Name_First))))))); ! Add (Decl); ! end; ! end if; ! end Install_Private_Data_Declarations; ! ! --------------------------------- ! -- Is_Potentially_Large_Family -- ! --------------------------------- ! ! function Is_Potentially_Large_Family ! (Base_Index : Entity_Id; ! Conctyp : Entity_Id; ! Lo : Node_Id; ! Hi : Node_Id) return Boolean ! is ! begin ! return Scope (Base_Index) = Standard_Standard ! and then Base_Index = Base_Type (Standard_Integer) ! and then Has_Discriminants (Conctyp) ! and then Present ! (Discriminant_Default_Value (First_Discriminant (Conctyp))) ! and then ! (Denotes_Discriminant (Lo, True) ! or else Denotes_Discriminant (Hi, True)); ! end Is_Potentially_Large_Family; ! ! ------------------------------------- ! -- Is_Private_Primitive_Subprogram -- ! ------------------------------------- ! ! function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is ! begin ! return ! (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure) ! and then Is_Private_Primitive (Id); ! end Is_Private_Primitive_Subprogram; ! ! ------------------ ! -- Index_Object -- ! ------------------ ! ! function Index_Object (Spec_Id : Entity_Id) return Entity_Id is ! Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id); ! Formal : Entity_Id; ! ! begin ! Formal := First_Formal (Bod_Subp); ! while Present (Formal) loop ! ! -- Look for formal parameter _E ! ! if Chars (Formal) = Name_uE then ! return Formal; ! end if; ! ! Next_Formal (Formal); ! end loop; ! ! -- A protected body subprogram should always have the parameter in ! -- question. ! ! raise Program_Error; ! end Index_Object; -------------------------------- -- Make_Initialize_Protection -- *************** package body Exp_Ch9 is *** 11071,11149 **** if Has_Entry or else Has_Interrupt_Handler (Ptyp) or else Has_Attach_Handler (Ptyp) ! or else (Ada_Version >= Ada_05 ! and then Present (Interface_List (Parent (Ptyp)))) then ! if Has_Entry or else not Restricted then ! Append_To (Args, ! Make_Attribute_Reference (Loc, ! Prefix => Make_Identifier (Loc, Name_uInit), ! Attribute_Name => Name_Address)); ! end if; ! ! -- Entry_Bodies parameter. This is a pointer to an array of pointers ! -- to the entry body procedures and barrier functions of the object. ! -- If the protected type has no entries this object will not exist; ! -- in this case, pass a null. ! if Has_Entry then ! P_Arr := Entry_Bodies_Array (Ptyp); ! Append_To (Args, ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (P_Arr, Loc), ! Attribute_Name => Name_Unrestricted_Access)); ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Number_Entries (Ptyp) > 1 ! or else (Has_Attach_Handler (Ptyp) and then not Restricted) ! then ! -- Find index mapping function (clumsy but ok for now) ! while Ekind (P_Arr) /= E_Function loop ! Next_Entity (P_Arr); ! end loop; Append_To (Args, ! Make_Attribute_Reference (Loc, ! Prefix => ! New_Reference_To (P_Arr, Loc), ! Attribute_Name => Name_Unrestricted_Access)); end if; ! elsif not Restricted then ! Append_To (Args, Make_Null (Loc)); ! Append_To (Args, Make_Null (Loc)); ! end if; ! if Abort_Allowed ! or else Restriction_Active (No_Entry_Queue) = False ! or else Number_Entries (Ptyp) > 1 ! or else (Has_Attach_Handler (Ptyp) ! and then not Restricted) ! then ! Append_To (L, ! Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To ( ! RTE (RE_Initialize_Protection_Entries), Loc), ! Parameter_Associations => Args)); ! elsif not Has_Entry and then Restricted then ! Append_To (L, ! Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To ( ! RTE (RE_Initialize_Protection), Loc), ! Parameter_Associations => Args)); - else Append_To (L, Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To ( ! RTE (RE_Initialize_Protection_Entry), Loc), Parameter_Associations => Args)); ! end if; ! else Append_To (L, Make_Procedure_Call_Statement (Loc, --- 11557,11647 ---- if Has_Entry or else Has_Interrupt_Handler (Ptyp) or else Has_Attach_Handler (Ptyp) ! or else Has_Interfaces (Protect_Rec) then ! declare ! Pkg_Id : constant RTU_Id := ! Corresponding_Runtime_Package (Ptyp); ! Called_Subp : RE_Id; ! begin ! case Pkg_Id is ! when System_Tasking_Protected_Objects_Entries => ! Called_Subp := RE_Initialize_Protection_Entries; ! when System_Tasking_Protected_Objects => ! Called_Subp := RE_Initialize_Protection; ! when System_Tasking_Protected_Objects_Single_Entry => ! Called_Subp := RE_Initialize_Protection_Entry; ! when others => ! raise Program_Error; ! end case; + if Has_Entry or else not Restricted then Append_To (Args, ! Make_Attribute_Reference (Loc, ! Prefix => Make_Identifier (Loc, Name_uInit), ! Attribute_Name => Name_Address)); end if; ! -- Entry_Bodies parameter. This is a pointer to an array of ! -- pointers to the entry body procedures and barrier functions of ! -- the object. If the protected type has no entries this object ! -- will not exist, in this case, pass a null. ! if Has_Entry then ! P_Arr := Entry_Bodies_Array (Ptyp); ! Append_To (Args, ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (P_Arr, Loc), ! Attribute_Name => Name_Unrestricted_Access)); ! ! if Pkg_Id = System_Tasking_Protected_Objects_Entries then ! ! -- Find index mapping function (clumsy but ok for now) ! ! while Ekind (P_Arr) /= E_Function loop ! Next_Entity (P_Arr); ! end loop; ! ! Append_To (Args, ! Make_Attribute_Reference (Loc, ! Prefix => ! New_Reference_To (P_Arr, Loc), ! Attribute_Name => Name_Unrestricted_Access)); ! ! -- Build_Entry_Names generation flag. When set to true, the ! -- runtime will allocate an array to hold the string names ! -- of protected entries. ! ! if not Restricted_Profile then ! if Entry_Names_OK then ! Append_To (Args, ! New_Reference_To (Standard_True, Loc)); ! else ! Append_To (Args, ! New_Reference_To (Standard_False, Loc)); ! end if; ! end if; ! end if; ! ! elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then ! Append_To (Args, Make_Null (Loc)); ! ! elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then ! Append_To (Args, Make_Null (Loc)); ! Append_To (Args, Make_Null (Loc)); ! Append_To (Args, New_Reference_To (Standard_False, Loc)); ! end if; Append_To (L, Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To (RTE (Called_Subp), Loc), Parameter_Associations => Args)); ! end; else Append_To (L, Make_Procedure_Call_Statement (Loc, *************** package body Exp_Ch9 is *** 11161,11200 **** -- or, in the case of Ravenscar: ! -- Install_Handlers -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); declare Args : constant List_Id := New_List; Table : constant List_Id := New_List; ! Ritem : Node_Id := First_Rep_Item (Ptyp); begin - if not Restricted then - - -- Appends the _object argument - - Append_To (Args, - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => Make_Identifier (Loc, Name_uObject)), - Attribute_Name => Name_Unchecked_Access)); - end if; - -- Build the Attach_Handler table argument while Present (Ritem) loop if Nkind (Ritem) = N_Pragma ! and then Chars (Ritem) = Name_Attach_Handler then declare Handler : constant Node_Id := First (Pragma_Argument_Associations (Ritem)); ! Interrupt : constant Node_Id := Next (Handler); ! Expr : constant Node_Id := Expression (Interrupt); begin Append_To (Table, --- 11659,11685 ---- -- or, in the case of Ravenscar: ! -- Install_Restricted_Handlers -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); declare Args : constant List_Id := New_List; Table : constant List_Id := New_List; ! Ritem : Node_Id := First_Rep_Item (Ptyp); begin -- Build the Attach_Handler table argument while Present (Ritem) loop if Nkind (Ritem) = N_Pragma ! and then Pragma_Name (Ritem) = Name_Attach_Handler then declare Handler : constant Node_Id := First (Pragma_Argument_Associations (Ritem)); ! Interrupt : constant Node_Id := Next (Handler); ! Expr : constant Node_Id := Expression (Interrupt); begin Append_To (Table, *************** package body Exp_Ch9 is *** 11217,11228 **** Append_To (Args, Make_Aggregate (Loc, Table)); ! -- Append the Install_Handler call to the statements ! Append_To (L, ! Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To (RTE (RE_Install_Handlers), Loc), ! Parameter_Associations => Args)); end; end if; --- 11702,11740 ---- Append_To (Args, Make_Aggregate (Loc, Table)); ! -- Append the Install_Handlers (or Install_Restricted_Handlers) ! -- call to the statements. ! if Restricted then ! -- Call a simplified version of Install_Handlers to be used ! -- when the Ravenscar restrictions are in effect ! -- (Install_Restricted_Handlers). ! ! Append_To (L, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To ! (RTE (RE_Install_Restricted_Handlers), Loc), ! Parameter_Associations => Args)); ! ! else ! -- First, prepends the _object argument ! ! Prepend_To (Args, ! Make_Attribute_Reference (Loc, ! Prefix => ! Make_Selected_Component (Loc, ! Prefix => Make_Identifier (Loc, Name_uInit), ! Selector_Name => Make_Identifier (Loc, Name_uObject)), ! Attribute_Name => Name_Unchecked_Access)); ! ! -- Then, insert call to Install_Handlers ! ! Append_To (L, ! Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To (RTE (RE_Install_Handlers), Loc), ! Parameter_Associations => Args)); ! end if; end; end if; *************** package body Exp_Ch9 is *** 11235,11247 **** function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Task_Rec); Name : Node_Id; - Tdef : Node_Id; Tdec : Node_Id; ! Ttyp : Node_Id; Tnam : Name_Id; ! Args : List_Id; ! Ecount : Node_Id; begin Ttyp := Corresponding_Concurrent_Type (Task_Rec); --- 11747,11759 ---- function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Task_Rec); + Args : List_Id; + Ecount : Node_Id; Name : Node_Id; Tdec : Node_Id; ! Tdef : Node_Id; Tnam : Name_Id; ! Ttyp : Node_Id; begin Ttyp := Corresponding_Concurrent_Type (Task_Rec); *************** package body Exp_Ch9 is *** 11346,11363 **** if not Restricted_Profile then -- Number of entries. This is an expression of the form: ! -- -- n + _Init.a'Length + _Init.a'B'Length + ... ! -- -- where a,b... are the entry family names for the task definition ! Ecount := Build_Entry_Count_Expression ( ! Ttyp, ! Component_Items (Component_List ( ! Type_Definition (Parent ( ! Corresponding_Record_Type (Ttyp))))), ! Loc); Append_To (Args, Ecount); -- Master parameter. This is a reference to the _Master parameter of --- 11858,11900 ---- if not Restricted_Profile then + -- Deadline parameter. If no Relative_Deadline pragma is present, + -- then the deadline is Time_Span_Zero. If a pragma is present, then + -- the deadline is taken from the _Relative_Deadline field of the + -- task value record, which was set from the pragma value. Note that + -- this parameter must not be generated for the restricted profiles + -- since Ravenscar does not allow deadlines. + + -- Case where pragma Relative_Deadline applies: use given value + + if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => + Make_Identifier (Loc, Name_uRelative_Deadline))); + + -- No pragma Relative_Deadline apply to the task + + else + Append_To (Args, + New_Reference_To (RTE (RE_Time_Span_Zero), Loc)); + end if; + -- Number of entries. This is an expression of the form: ! -- n + _Init.a'Length + _Init.a'B'Length + ... ! -- where a,b... are the entry family names for the task definition ! Ecount := ! Build_Entry_Count_Expression ! (Ttyp, ! Component_Items ! (Component_List ! (Type_Definition ! (Parent (Corresponding_Record_Type (Ttyp))))), ! Loc); Append_To (Args, Ecount); -- Master parameter. This is a reference to the _Master parameter of *************** package body Exp_Ch9 is *** 11374,11390 **** end if; -- State parameter. This is a pointer to the task body procedure. The ! -- required value is obtained by taking the address of the task body ! -- procedure and converting it (with an unchecked conversion) to the ! -- type required by the task kernel. For further details, see the ! -- description of Expand_N_Task_Body ! Append_To (Args, ! Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), ! Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Get_Task_Body_Procedure (Ttyp), Loc), ! Attribute_Name => Name_Address))); -- Discriminants parameter. This is just the address of the task -- value record itself (which contains the discriminant values --- 11911,11965 ---- end if; -- State parameter. This is a pointer to the task body procedure. The ! -- required value is obtained by taking 'Unrestricted_Access of the task ! -- body procedure and converting it (with an unchecked conversion) to ! -- the type required by the task kernel. For further details, see the ! -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather ! -- than 'Address in order to avoid creating trampolines. ! declare ! Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp); ! Subp_Ptr_Typ : constant Node_Id := ! Create_Itype (E_Access_Subprogram_Type, Tdec); ! Ref : constant Node_Id := Make_Itype_Reference (Loc); ! ! begin ! Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc); ! Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); ! ! -- Be sure to freeze a reference to the access-to-subprogram type, ! -- otherwise gigi will complain that it's in the wrong scope, because ! -- it's actually inside the init procedure for the record type that ! -- corresponds to the task type. ! ! -- This processing is causing a crash in the .NET/JVM back ends that ! -- is not yet understood, so skip it in these cases ??? ! ! if VM_Target = No_VM then ! Set_Itype (Ref, Subp_Ptr_Typ); ! Append_Freeze_Action (Task_Rec, Ref); ! ! Append_To (Args, ! Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), ! Make_Qualified_Expression (Loc, ! Subtype_Mark => New_Reference_To (Subp_Ptr_Typ, Loc), ! Expression => ! Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Body_Proc, Loc), ! Attribute_Name => Name_Unrestricted_Access)))); ! ! -- For the .NET/JVM cases revert to the original code below ??? ! ! else ! Append_To (Args, ! Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), ! Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Body_Proc, Loc), ! Attribute_Name => Name_Address))); ! end if; ! end; -- Discriminants parameter. This is just the address of the task -- value record itself (which contains the discriminant values *************** package body Exp_Ch9 is *** 11432,11445 **** Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); if Restricted_Profile then Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc); else Name := New_Reference_To (RTE (RE_Create_Task), Loc); end if; ! return Make_Procedure_Call_Statement (Loc, ! Name => Name, Parameter_Associations => Args); end Make_Task_Create_Call; ------------------------------ --- 12007,12035 ---- Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); + -- Build_Entry_Names generation flag. When set to true, the runtime + -- will allocate an array to hold the string names of task entries. + + if not Restricted_Profile then + if Has_Entries (Ttyp) + and then Entry_Names_OK + then + Append_To (Args, New_Reference_To (Standard_True, Loc)); + else + Append_To (Args, New_Reference_To (Standard_False, Loc)); + end if; + end if; + if Restricted_Profile then Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc); else Name := New_Reference_To (RTE (RE_Create_Task), Loc); end if; ! return ! Make_Procedure_Call_Statement (Loc, ! Name => Name, ! Parameter_Associations => Args); end Make_Task_Create_Call; ------------------------------ *************** package body Exp_Ch9 is *** 11473,11481 **** and then (Nkind_In (Stmt, N_Null_Statement, N_Label) or else (Nkind (Stmt) = N_Pragma ! and then (Chars (Stmt) = Name_Unreferenced or else ! Chars (Stmt) = Name_Warnings))) loop Next (Stmt); end loop; --- 12063,12073 ---- and then (Nkind_In (Stmt, N_Null_Statement, N_Label) or else (Nkind (Stmt) = N_Pragma ! and then (Pragma_Name (Stmt) = Name_Unreferenced or else ! Pragma_Name (Stmt) = Name_Unmodified ! or else ! Pragma_Name (Stmt) = Name_Warnings))) loop Next (Stmt); end loop; *************** package body Exp_Ch9 is *** 11681,11805 **** end if; end Set_Discriminals; - ----------------- - -- Set_Privals -- - ----------------- - - procedure Set_Privals - (Dec : Node_Id; - Op : Node_Id; - Loc : Source_Ptr; - After_Barrier : Boolean := False) - is - P_Decl : Node_Id; - P_Id : Entity_Id; - Priv : Entity_Id; - Def : Node_Id; - Body_Ent : Entity_Id; - For_Barrier : constant Boolean := - Nkind (Op) = N_Entry_Body and then not After_Barrier; - - Prec_Decl : constant Node_Id := - Parent (Corresponding_Record_Type - (Defining_Identifier (Dec))); - Prec_Def : constant Entity_Id := Type_Definition (Prec_Decl); - Obj_Decl : Node_Id; - P_Subtype : Entity_Id; - Assoc_L : constant Elist_Id := New_Elmt_List; - Op_Id : Entity_Id; - - begin - pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); - pragma Assert (Nkind_In (Op, N_Subprogram_Body, N_Entry_Body)); - - Def := Protected_Definition (Dec); - - if Present (Private_Declarations (Def)) then - P_Decl := First (Private_Declarations (Def)); - while Present (P_Decl) loop - if Nkind (P_Decl) = N_Component_Declaration then - P_Id := Defining_Identifier (P_Decl); - - if For_Barrier then - Priv := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (P_Id), 'P')); - else - Priv := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (P_Id))); - end if; - - Set_Ekind (Priv, E_Variable); - Set_Etype (Priv, Etype (P_Id)); - Set_Scope (Priv, Scope (P_Id)); - Set_Esize (Priv, Esize (Etype (P_Id))); - Set_Is_Aliased (Priv, Is_Aliased (P_Id)); - Set_Alignment (Priv, Alignment (Etype (P_Id))); - - -- If the type of the component is an itype, we must create a - -- new itype for the corresponding prival in each protected - -- operation, to avoid scoping problems. We create new itypes - -- by copying the tree for the component definition. - -- (Ada 2005) If the itype is an anonymous access type created - -- for an access definition for a component, it is declared in - -- the enclosing scope, and we do no create a local version of - -- it, to prevent scoping anomalies in gigi. - - if Is_Itype (Etype (P_Id)) - and then not - (Is_Access_Type (Etype (P_Id)) - and then Is_Local_Anonymous_Access (Etype (P_Id))) - then - Append_Elmt (P_Id, Assoc_L); - Append_Elmt (Priv, Assoc_L); - - if Nkind (Op) = N_Entry_Body then - Op_Id := Defining_Identifier (Op); - else - Op_Id := Defining_Unit_Name (Specification (Op)); - end if; - - Discard_Node - (New_Copy_Tree (P_Decl, Assoc_L, New_Scope => Op_Id)); - end if; - - Set_Protected_Operation (P_Id, Op); - Set_Prival (P_Id, Priv); - end if; - - Next (P_Decl); - end loop; - end if; - - -- There is one more implicit private decl: the object itself. "prival" - -- for this is attached to the protected body defining identifier. - - Body_Ent := Corresponding_Body (Dec); - - Priv := - Make_Defining_Identifier (Sloc (Body_Ent), - Chars => New_External_Name (Chars (Body_Ent), 'R')); - - -- Set the Etype to the implicit subtype of Protection created when - -- the protected type declaration was expanded. This node will not - -- be analyzed until it is used as the defining identifier for the - -- renaming declaration in the protected operation body, and it will - -- be needed in the references expanded before that body is expanded. - -- Since the Protection field is aliased, set Is_Aliased as well. - - Obj_Decl := First (Component_Items (Component_List (Prec_Def))); - while Chars (Defining_Identifier (Obj_Decl)) /= Name_uObject loop - Next (Obj_Decl); - end loop; - - P_Subtype := Etype (Defining_Identifier (Obj_Decl)); - Set_Ekind (Priv, E_Variable); - Set_Etype (Priv, P_Subtype); - Set_Is_Aliased (Priv); - Set_Object_Ref (Body_Ent, Priv); - end Set_Privals; - ----------------------- -- Trivial_Accept_OK -- ----------------------- --- 12273,12278 ---- *************** package body Exp_Ch9 is *** 11819,11825 **** when ' ' => return True; ! -- FIFO_Within_Priorities certainly certainly does not permit this -- optimization since the Rendezvous is a scheduling action that may -- require some other task to be run. --- 12292,12298 ---- when ' ' => return True; ! -- FIFO_Within_Priorities certainly does not permit this -- optimization since the Rendezvous is a scheduling action that may -- require some other task to be run. *************** package body Exp_Ch9 is *** 11835,12002 **** end case; end Trivial_Accept_OK; - ---------------------------- - -- Update_Prival_Subtypes -- - ---------------------------- - - procedure Update_Prival_Subtypes (N : Node_Id) is - - function Process (N : Node_Id) return Traverse_Result; - -- Update the etype of occurrences of privals whose etype does not - -- match the current Etype of the prival entity itself. - - procedure Update_Array_Bounds (E : Entity_Id); - -- Itypes generated for array expressions may depend on the - -- determinants of the protected object, and need to be processed - -- separately because they are not attached to the tree. - - procedure Update_Index_Types (N : Node_Id); - -- Similarly, update the types of expressions in indexed components - -- which may depend on other discriminants. - - ------------- - -- Process -- - ------------- - - function Process (N : Node_Id) return Traverse_Result is - begin - if Is_Entity_Name (N) then - declare - E : constant Entity_Id := Entity (N); - begin - if Present (E) - and then (Ekind (E) = E_Constant - or else Ekind (E) = E_Variable) - and then Nkind (Parent (E)) = N_Object_Renaming_Declaration - and then not Is_Scalar_Type (Etype (E)) - and then Etype (N) /= Etype (E) - then - - -- Ensure that reference and entity have the same Etype, - -- to prevent back-end inconsistencies. - - Set_Etype (N, Etype (E)); - Update_Index_Types (N); - - elsif Present (E) - and then Ekind (E) = E_Constant - and then Present (Discriminal_Link (E)) - then - Set_Etype (N, Etype (E)); - end if; - end; - - return OK; - - elsif Nkind_In (N, N_Defining_Identifier, - N_Defining_Operator_Symbol, - N_Defining_Character_Literal) - then - return Skip; - - elsif Nkind (N) = N_String_Literal then - - -- Array type, but bounds are constant - - return OK; - - elsif Nkind (N) = N_Object_Declaration - and then Is_Itype (Etype (Defining_Identifier (N))) - and then Is_Array_Type (Etype (Defining_Identifier (N))) - then - Update_Array_Bounds (Etype (Defining_Identifier (N))); - return OK; - - -- For array components of discriminated records, use the base type - -- directly, because it may depend indirectly on the discriminants of - -- the protected type. - - -- Cleaner would be a systematic mechanism to compute actual subtypes - -- of private components??? - - elsif Nkind (N) in N_Has_Etype - and then Present (Etype (N)) - and then Is_Array_Type (Etype (N)) - and then Nkind (N) = N_Selected_Component - and then Has_Discriminants (Etype (Prefix (N))) - then - Set_Etype (N, Base_Type (Etype (N))); - Update_Index_Types (N); - return OK; - - else - if Nkind (N) in N_Has_Etype - and then Present (Etype (N)) - and then Is_Itype (Etype (N)) then - - if Is_Array_Type (Etype (N)) then - Update_Array_Bounds (Etype (N)); - - elsif Is_Scalar_Type (Etype (N)) then - Update_Prival_Subtypes (Type_Low_Bound (Etype (N))); - Update_Prival_Subtypes (Type_High_Bound (Etype (N))); - end if; - end if; - - return OK; - end if; - end Process; - - ------------------------- - -- Update_Array_Bounds -- - ------------------------- - - procedure Update_Array_Bounds (E : Entity_Id) is - Ind : Node_Id; - begin - Ind := First_Index (E); - while Present (Ind) loop - Update_Prival_Subtypes (Type_Low_Bound (Etype (Ind))); - Update_Prival_Subtypes (Type_High_Bound (Etype (Ind))); - Next_Index (Ind); - end loop; - end Update_Array_Bounds; - - ------------------------ - -- Update_Index_Types -- - ------------------------ - - procedure Update_Index_Types (N : Node_Id) is - Indx1 : Node_Id; - I_Typ : Node_Id; - - begin - -- If the prefix has an actual subtype that is different from the - -- nominal one, update the types of the indices, so that the proper - -- constraints are applied. Do not apply this transformation to a - -- packed array, where the index type is computed for a byte array - -- and is different from the source index. - - if Nkind (Parent (N)) = N_Indexed_Component - and then - not Is_Bit_Packed_Array (Etype (Prefix (Parent (N)))) - then - Indx1 := First (Expressions (Parent (N))); - I_Typ := First_Index (Etype (N)); - - while Present (Indx1) and then Present (I_Typ) loop - - if not Is_Entity_Name (Indx1) then - Set_Etype (Indx1, Base_Type (Etype (I_Typ))); - end if; - - Next (Indx1); - Next_Index (I_Typ); - end loop; - end if; - end Update_Index_Types; - - procedure Traverse is new Traverse_Proc (Process); - - -- Start of processing for Update_Prival_Subtypes - - begin - Traverse (N); - end Update_Prival_Subtypes; - end Exp_Ch9; --- 12308,12311 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/exp_ch9.ads gcc-4.4.0/gcc/ada/exp_ch9.ads *** gcc-4.3.3/gcc/ada/exp_ch9.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_ch9.ads Wed Aug 20 12:06:35 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** *** 25,31 **** -- Expand routines for chapter 9 constructs - with Namet; use Namet; with Types; use Types; package Exp_Ch9 is --- 25,30 ---- *************** package Exp_Ch9 is *** 37,77 **** -- This type is used to distinguish the different protection modes of a -- protected subprogram. - procedure Add_Discriminal_Declarations - (Decls : List_Id; - Typ : Entity_Id; - Name : Name_Id; - Loc : Source_Ptr); - -- This routine is used to add discriminal declarations to task and - -- protected operation bodies. The discriminants are available by normal - -- selection from the concurrent object (whose name is passed as the third - -- parameter). Discriminant references inside the body have already - -- been replaced by references to the corresponding discriminals. The - -- declarations constructed by this procedure hook the references up with - -- the objects: - -- - -- discriminal_name : discr_type renames name.discriminant_name; - -- - -- Obviously we could have expanded the discriminant references in the - -- first place to be the appropriate selection, but this turns out to - -- be hard to do because it would introduce difference in handling of - -- discriminant references depending on their location. - - procedure Add_Private_Declarations - (Decls : List_Id; - Typ : Entity_Id; - Name : Name_Id; - Loc : Source_Ptr); - -- This routine is used to add private declarations to protected bodies. - -- These are analogous to the discriminal declarations added to tasks - -- and protected operations, and consist of a renaming of each private - -- object to a selection from the concurrent object passed as an extra - -- parameter to each such operation: - -- private_name : private_type renames name.private_name; - -- As with discriminals, private references inside the protected - -- subprogram bodies have already been replaced by references to the - -- corresponding privals. - procedure Build_Activation_Chain_Entity (N : Node_Id); -- Given a declaration N of an object that is a task, or contains tasks -- (other than allocators to tasks) this routine ensures that an activation --- 36,41 ---- *************** package Exp_Ch9 is *** 94,99 **** --- 58,68 ---- -- build record declaration. N is the type declaration, Ctyp is the -- concurrent entity (task type or protected type). + function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id; + -- Create the statements which populate the entry names array of a task or + -- protected type. The statements are wrapped inside a block due to a local + -- declaration. + procedure Build_Master_Entity (E : Entity_Id); -- Given an entity E for the declaration of an object containing tasks -- or of a type declaration for an allocator whose designated type is a *************** package Exp_Ch9 is *** 113,124 **** -- declarative part. function Build_Protected_Sub_Specification ! (N : Node_Id; ! Prottyp : Entity_Id; ! Mode : Subprogram_Protection_Mode) return Node_Id; ! -- Build specification for protected subprogram. This is called when -- expanding a protected type, and also when expanding the declaration for ! -- an Access_To_Protected_Subprogram type. In the latter case, Prottyp is -- empty, and the first parameter of the signature of the protected op is -- of type System.Address. --- 82,93 ---- -- declarative part. function Build_Protected_Sub_Specification ! (N : Node_Id; ! Prot_Typ : Entity_Id; ! Mode : Subprogram_Protection_Mode) return Node_Id; ! -- Build the specification for protected subprogram. This is called when -- expanding a protected type, and also when expanding the declaration for ! -- an Access_To_Protected_Subprogram type. In the latter case, Prot_Typ is -- empty, and the first parameter of the signature of the protected op is -- of type System.Address. *************** package Exp_Ch9 is *** 184,189 **** --- 153,170 ---- -- aggregate. It replaces the call to Init (Args) done by -- Build_Task_Allocate_Block. + function Build_Wrapper_Spec + (Loc : Source_Ptr; + Subp_Id : Entity_Id; + Obj_Typ : Entity_Id; + Formals : List_Id) return Node_Id; + -- Ada 2005 (AI-345): Build the specification of a primitive operation + -- associated with a protected or task type. This is required to implement + -- dispatching calls through interfaces. Subp_Id is the primitive to be + -- wrapped, Obj_Typ is the type of the newly added formal parameter to + -- handle object notation, Formals are the original entry formals that + -- will be explicitly replicated. + function Concurrent_Ref (N : Node_Id) return Node_Id; -- Given the name of a concurrent object (task or protected object), or -- the name of an access to a concurrent object, this function returns an *************** package Exp_Ch9 is *** 194,210 **** function Convert_Concurrent (N : Node_Id; ! Typ : Entity_Id) ! return Node_Id; ! -- N is an expression of type Typ. If the type is not a concurrent ! -- type then it is returned unchanged. If it is a task or protected ! -- reference, Convert_Concurrent creates an unchecked conversion node ! -- from this expression to the corresponding concurrent record type ! -- value. We need this in any situation where the concurrent type is ! -- used, because the actual concurrent object is an object of the ! -- corresponding concurrent type, and manipulations on the concurrent ! -- object actually manipulate the corresponding object of the record ! -- type. function Entry_Index_Expression (Sloc : Source_Ptr; --- 175,189 ---- function Convert_Concurrent (N : Node_Id; ! Typ : Entity_Id) return Node_Id; ! -- N is an expression of type Typ. If the type is not a concurrent type ! -- then it is returned unchanged. If it is a task or protected reference, ! -- Convert_Concurrent creates an unchecked conversion node from this ! -- expression to the corresponding concurrent record type value. We need ! -- this in any situation where the concurrent type is used, because the ! -- actual concurrent object is an object of the corresponding concurrent ! -- type, and manipulations on the concurrent object actually manipulate the ! -- corresponding object of the record type. function Entry_Index_Expression (Sloc : Source_Ptr; *************** package Exp_Ch9 is *** 219,225 **** procedure Establish_Task_Master (N : Node_Id); -- Given a subprogram body, or a block statement, or a task body, this ! -- proccedure makes the necessary transformations required of a task -- master (add Enter_Master call at start, and establish a cleanup -- routine to make sure Complete_Master is called on exit). --- 198,204 ---- procedure Establish_Task_Master (N : Node_Id); -- Given a subprogram body, or a block statement, or a task body, this ! -- procedure makes the necessary transformations required of a task -- master (add Enter_Master call at start, and establish a cleanup -- routine to make sure Complete_Master is called on exit). *************** package Exp_Ch9 is *** 237,251 **** -- Expand the entry barrier into a function. This is called directly -- from Analyze_Entry_Body so that the discriminals and privals of the -- barrier can be attached to the function declaration list, and a new ! -- set prepared for the entry body procedure, bedore the entry body -- statement sequence can be expanded. The resulting function is analyzed -- now, within the context of the protected object, to resolve calls to -- other protected functions. - procedure Expand_Entry_Body_Declarations (N : Node_Id); - -- Expand declarations required for the expansion of the - -- statements of the body. - procedure Expand_N_Abort_Statement (N : Node_Id); procedure Expand_N_Accept_Statement (N : Node_Id); procedure Expand_N_Asynchronous_Select (N : Node_Id); --- 216,226 ---- -- Expand the entry barrier into a function. This is called directly -- from Analyze_Entry_Body so that the discriminals and privals of the -- barrier can be attached to the function declaration list, and a new ! -- set prepared for the entry body procedure, before the entry body -- statement sequence can be expanded. The resulting function is analyzed -- now, within the context of the protected object, to resolve calls to -- other protected functions. procedure Expand_N_Abort_Statement (N : Node_Id); procedure Expand_N_Accept_Statement (N : Node_Id); procedure Expand_N_Asynchronous_Select (N : Node_Id); *************** package Exp_Ch9 is *** 277,287 **** procedure Expand_Protected_Body_Declarations (N : Node_Id; Spec_Id : Entity_Id); ! -- Expand declarations required for a protected body. See bodies of ! -- both Expand_Protected_Body_Declarations and Expand_N_Protected_Body ! -- for full details of the nature and use of these declarations. ! -- The second argument is the entity for the corresponding ! -- protected type declaration. function External_Subprogram (E : Entity_Id) return Entity_Id; -- return the external version of a protected operation, which locks --- 252,261 ---- procedure Expand_Protected_Body_Declarations (N : Node_Id; Spec_Id : Entity_Id); ! -- Expand declarations required for a protected body. See bodies of both ! -- Expand_Protected_Body_Declarations and Expand_N_Protected_Body for full ! -- details of the nature and use of these declarations. The second argument ! -- is the entity for the corresponding protected type declaration. function External_Subprogram (E : Entity_Id) return Entity_Id; -- return the external version of a protected operation, which locks *************** package Exp_Ch9 is *** 291,333 **** -- Given the declarations list for a protected body, find the -- first protected operation body. function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id; -- Given the entity of the record type created for a task type, build -- the call to Create_Task function Make_Initialize_Protection ! (Protect_Rec : Entity_Id) ! return List_Id; -- Given the entity of the record type created for a protected type, build -- a list of statements needed for proper initialization of the object. function Next_Protected_Operation (N : Node_Id) return Node_Id; ! -- Given a protected operation node (a subprogram or entry body), ! -- find the following node in the declarations list. procedure Set_Discriminals (Dec : Node_Id); ! -- Replace discriminals in a protected type for use by the ! -- next protected operation on the type. Each operation needs a ! -- new set of discirminals, since it needs a unique renaming of ! -- the discriminant fields in the record used to implement the ! -- protected type. ! ! procedure Set_Privals ! (Dec : Node_Id; ! Op : Node_Id; ! Loc : Source_Ptr; ! After_Barrier : Boolean := False); ! -- Associates a new set of privals (placeholders for later access to ! -- private components of protected objects) with the private object ! -- declarations of a protected object. These will be used to expand ! -- the references to private objects in the next protected ! -- subprogram or entry body to be expanded. ! -- ! -- The flag After_Barrier indicates whether this is called after building ! -- the barrier function for an entry body. This flag determines whether ! -- the privals should have source names (which simplifies debugging) or ! -- internally generated names. Entry barriers contain no debuggable code, ! -- and there may be visibility conflicts between an entry index and a ! -- a prival, so privals for barrier function have internal names. end Exp_Ch9; --- 265,343 ---- -- Given the declarations list for a protected body, find the -- first protected operation body. + procedure Install_Private_Data_Declarations + (Loc : Source_Ptr; + Spec_Id : Entity_Id; + Conc_Typ : Entity_Id; + Body_Nod : Node_Id; + Decls : List_Id; + Barrier : Boolean := False; + Family : Boolean := False); + -- This routines generates several types, objects and object renamings used + -- in the handling of discriminants and private components of protected and + -- task types. It also generates the entry index for entry families. Formal + -- Spec_Id denotes an entry, entry family or a subprogram, Conc_Typ is the + -- concurrent type where Spec_Id resides, Body_Nod is the corresponding + -- body of Spec_Id, Decls are the declarations of the subprogram or entry. + -- Flag Barrier denotes whether the context is an entry barrier function. + -- Flag Family is used in conjunction with Barrier to denote a barrier for + -- an entry family. + -- + -- The generated types, entities and renamings are: + -- + -- * If flag Barrier is set or Spec_Id denotes a protected entry or an + -- entry family, generate: + -- + -- type prot_typVP is access prot_typV; + -- _object : prot_typVP := prot_typV (_O); + -- + -- where prot_typV is the corresponding record of a protected type and + -- _O is a formal parameter representing the concurrent object of either + -- the barrier function or the entry (family). + -- + -- * If Conc_Typ is a protected type, create a renaming for the Protection + -- field _object: + -- + -- conc_typR : protection_typ renames _object._object; + -- + -- * If Conc_Typ has discriminants, create renamings of the form: + -- + -- discr_nameD : discr_typ renames _object.discr_name; + -- or + -- discr_nameD : discr_typ renames _task.discr_name; + -- + -- * If Conc_Typ denotes a protected type and has private components, + -- generate renamings of the form: + -- + -- comp_name : comp_typ renames _object.comp_name; + -- + -- * Finally, is flag Barrier and Family are set or Spec_Id denotes an + -- entry family, generate the entry index constant: + -- + -- subtype Jnn is range Low .. High; + -- J : constant Jnn := + -- Jnn'Val (_E - + Jnn'Pos (Jnn'First)); + -- + -- All the above declarations are inserted in the order shown to the front + -- of Decls. + function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id; -- Given the entity of the record type created for a task type, build -- the call to Create_Task function Make_Initialize_Protection ! (Protect_Rec : Entity_Id) return List_Id; -- Given the entity of the record type created for a protected type, build -- a list of statements needed for proper initialization of the object. function Next_Protected_Operation (N : Node_Id) return Node_Id; ! -- Given a protected operation node (a subprogram or entry body), find the ! -- following node in the declarations list. procedure Set_Discriminals (Dec : Node_Id); ! -- Replace discriminals in a protected type for use by the next protected ! -- operation on the type. Each operation needs a new set of discriminals, ! -- since it needs a unique renaming of the discriminant fields in the ! -- record used to implement the protected type. end Exp_Ch9; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_dbug.adb gcc-4.4.0/gcc/ada/exp_dbug.adb *** gcc-4.3.3/gcc/ada/exp_dbug.adb Wed Sep 26 10:43:08 2007 --- gcc-4.4.0/gcc/ada/exp_dbug.adb Tue Apr 8 06:44:39 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2008, 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- -- *************** package body Exp_Dbug is *** 464,470 **** Set_Debug_Renaming_Link (Obj, Entity (Ren)); ! Set_Needs_Debug_Info (Obj); -- Mark the object as internal so that it won't be initialized when -- pragma Initialize_Scalars or Normalize_Scalars is in use. --- 464,470 ---- Set_Debug_Renaming_Link (Obj, Entity (Ren)); ! Set_Debug_Info_Needed (Obj); -- Mark the object as internal so that it won't be initialized when -- pragma Initialize_Scalars or Normalize_Scalars is in use. *************** package body Exp_Dbug is *** 535,541 **** -- For all these cases, just return the name unchanged then ! Name_Buffer (Name_Len + 1) := ASCII.Nul; return; end if; --- 535,541 ---- -- For all these cases, just return the name unchanged then ! Name_Buffer (Name_Len + 1) := ASCII.NUL; return; end if; *************** package body Exp_Dbug is *** 751,757 **** Get_Qualified_Name_And_Append (E); end if; ! Name_Buffer (Name_Len + 1) := ASCII.Nul; end Get_External_Name; ----------------------------------- --- 751,757 ---- Get_Qualified_Name_And_Append (E); end if; ! Name_Buffer (Name_Len + 1) := ASCII.NUL; end Get_External_Name; ----------------------------------- *************** package body Exp_Dbug is *** 784,790 **** if Has_Suffix then Add_Str_To_Name_Buffer ("___"); Add_Str_To_Name_Buffer (Suffix); ! Name_Buffer (Name_Len + 1) := ASCII.Nul; end if; end Get_External_Name_With_Suffix; --- 784,790 ---- if Has_Suffix then Add_Str_To_Name_Buffer ("___"); Add_Str_To_Name_Buffer (Suffix); ! Name_Buffer (Name_Len + 1) := ASCII.NUL; end if; end Get_External_Name_With_Suffix; *************** package body Exp_Dbug is *** 1242,1248 **** Add_Str_To_Name_Buffer ("__"); end if; ! -- Otherwise get name and note if it is a NPBE Get_Name_String_And_Append (Chars (E)); --- 1242,1248 ---- Add_Str_To_Name_Buffer ("__"); end if; ! -- Otherwise get name and note if it is a BNPE Get_Name_String_And_Append (Chars (E)); diff -Nrcpad gcc-4.3.3/gcc/ada/exp_dbug.ads gcc-4.4.0/gcc/ada/exp_dbug.ads *** gcc-4.3.3/gcc/ada/exp_dbug.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_dbug.ads Sat Sep 20 10:29:08 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2008, 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- -- *************** package Exp_Dbug is *** 66,72 **** -- For global entities, the encoded name includes all components of the -- fully expanded name (but omitting Standard at the start). For example, -- if a library level child package P.Q has an embedded package R, and ! -- there is an entity in this embdded package whose name is S, the encoded -- name will include the components p.q.r.s. -- For local entities, the encoded name only includes the components up to --- 66,72 ---- -- For global entities, the encoded name includes all components of the -- fully expanded name (but omitting Standard at the start). For example, -- if a library level child package P.Q has an embedded package R, and ! -- there is an entity in this embedded package whose name is S, the encoded -- name will include the components p.q.r.s. -- For local entities, the encoded name only includes the components up to *************** package Exp_Dbug is *** 358,364 **** -- the protected/non-locking version of the operation. -- Operations generated for protected entries follow the same encoding. ! -- Each entry results in two suprograms: a procedure that holds the -- entry body, and a function that holds the evaluation of the barrier. -- The names of these subprograms include the prefix '_E' or '_B' res- -- pectively. The names also include a numeric suffix to render them --- 358,364 ---- -- the protected/non-locking version of the operation. -- Operations generated for protected entries follow the same encoding. ! -- Each entry results in two subprograms: a procedure that holds the -- entry body, and a function that holds the evaluation of the barrier. -- The names of these subprograms include the prefix '_E' or '_B' res- -- pectively. The names also include a numeric suffix to render them *************** package Exp_Dbug is *** 851,857 **** -- The size of the objects typed as x should be obtained from the -- structure of x (and x___XVE, if applicable) as for ordinary types -- unless there is a variable named x___XVZ, which, if present, will ! -- hold the the size (in bits) of x. -- The type x will either be a subtype of y (see also Subtypes of -- Variant Records, below) or will contain no fields at all. The layout, --- 851,857 ---- -- The size of the objects typed as x should be obtained from the -- structure of x (and x___XVE, if applicable) as for ordinary types -- unless there is a variable named x___XVZ, which, if present, will ! -- hold the size (in bytes) of x. -- The type x will either be a subtype of y (see also Subtypes of -- Variant Records, below) or will contain no fields at all. The layout, *************** package Exp_Dbug is *** 1423,1429 **** -- Character types are enumeration types at least one of whose enumeration -- literals is a character literal. Enumeration literals are usually simply -- represented using their identifier names. If the enumeration literal is ! -- a character literal, the name aencoded as described in the following -- paragraph. -- A name QUhh, where each 'h' is a lower-case hexadecimal digit, stands --- 1423,1429 ---- -- Character types are enumeration types at least one of whose enumeration -- literals is a character literal. Enumeration literals are usually simply -- represented using their identifier names. If the enumeration literal is ! -- a character literal, the name is encoded as described in the following -- paragraph. -- A name QUhh, where each 'h' is a lower-case hexadecimal digit, stands *************** package Exp_Dbug is *** 1450,1456 **** -- Set Name_Buffer and Name_Len to the external name of one secondary -- dispatch table of Typ. If the interface has been inherited from some -- ancestor then Ancestor_Typ is such node (in this case the secondary DT ! -- is needed to handle overriden primitives); if there is no such ancestor -- then Ancestor_Typ is equal to Typ. -- -- Internal rule followed for the generation of the external name: --- 1450,1456 ---- -- Set Name_Buffer and Name_Len to the external name of one secondary -- dispatch table of Typ. If the interface has been inherited from some -- ancestor then Ancestor_Typ is such node (in this case the secondary DT ! -- is needed to handle overridden primitives); if there is no such ancestor -- then Ancestor_Typ is equal to Typ. -- -- Internal rule followed for the generation of the external name: *************** package Exp_Dbug is *** 1490,1496 **** -- -- These are the external names generated for Case_1.Typ (note that -- Pkg1.Typ is associated with the Primary Dispatch Table, because it ! -- is the the parent of this type, and hence no external name is -- generated for it). -- case_1__typ0P (associated with Pkg2.Typ) -- case_1__typ1P (associated with Pkg3.Typ) --- 1490,1496 ---- -- -- These are the external names generated for Case_1.Typ (note that -- Pkg1.Typ is associated with the Primary Dispatch Table, because it ! -- is the parent of this type, and hence no external name is -- generated for it). -- case_1__typ0P (associated with Pkg2.Typ) -- case_1__typ1P (associated with Pkg3.Typ) diff -Nrcpad gcc-4.3.3/gcc/ada/exp_disp.adb gcc-4.4.0/gcc/ada/exp_disp.adb *** gcc-4.3.3/gcc/ada/exp_disp.adb Thu Dec 13 10:26:10 2007 --- gcc-4.4.0/gcc/ada/exp_disp.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Rident; use Rident; *** 46,51 **** --- 46,52 ---- with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch6; use Sem_Ch6; + with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; *************** package body Exp_Disp is *** 76,82 **** function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean; -- Returns true if Prim is not a predefined dispatching primitive but it is ! -- an alias of a predefined dispatching primitive (ie. through a renaming) function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; -- Check if the type has a private view or if the public view appears --- 77,83 ---- function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean; -- Returns true if Prim is not a predefined dispatching primitive but it is ! -- an alias of a predefined dispatching primitive (i.e. through a renaming) function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; -- Check if the type has a private view or if the public view appears *************** package body Exp_Disp is *** 98,104 **** --- 99,113 ---- ------------------------ function Building_Static_DT (Typ : Entity_Id) return Boolean is + Root_Typ : Entity_Id := Root_Type (Typ); + begin + -- Handle private types + + if Present (Full_View (Root_Typ)) then + Root_Typ := Full_View (Root_Typ); + end if; + return Static_Dispatch_Tables and then Is_Library_Level_Tagged_Type (Typ) *************** package body Exp_Disp is *** 106,112 **** -- build the dispatch tables because we must inherit primitives -- from the CPP side. ! and then not Is_CPP_Class (Root_Type (Typ)); end Building_Static_DT; ---------------------------------- --- 115,121 ---- -- build the dispatch tables because we must inherit primitives -- from the CPP side. ! and then not Is_CPP_Class (Root_Typ); end Building_Static_DT; ---------------------------------- *************** package body Exp_Disp is *** 164,188 **** -- Handle private types of library level tagged types. We must -- exchange the private and full-view to ensure the correct ! -- expansion. elsif (Nkind (D) = N_Private_Type_Declaration or else Nkind (D) = N_Private_Extension_Declaration) and then Present (Full_View (Defining_Entity (D))) - and then Is_Library_Level_Tagged_Type - (Full_View (Defining_Entity (D))) - and then Ekind (Full_View (Defining_Entity (D))) - /= E_Record_Subtype then declare ! E1, E2 : Entity_Id; begin ! E1 := Defining_Entity (D); ! E2 := Full_View (Defining_Entity (D)); ! Exchange_Entities (E1, E2); ! Insert_List_After_And_Analyze (Last (Target_List), ! Make_DT (E1)); ! Exchange_Entities (E1, E2); end; end if; --- 173,200 ---- -- Handle private types of library level tagged types. We must -- exchange the private and full-view to ensure the correct ! -- expansion. If the full view is a synchronized type ignore ! -- the type because the table will be built for the corresponding ! -- record type, that has its own declaration. elsif (Nkind (D) = N_Private_Type_Declaration or else Nkind (D) = N_Private_Extension_Declaration) and then Present (Full_View (Defining_Entity (D))) then declare ! E1 : constant Entity_Id := Defining_Entity (D); ! E2 : constant Entity_Id := Full_View (E1); ! begin ! if Is_Library_Level_Tagged_Type (E2) ! and then Ekind (E2) /= E_Record_Subtype ! and then not Is_Concurrent_Type (E2) ! then ! Exchange_Declarations (E1); ! Insert_List_After_And_Analyze (Last (Target_List), ! Make_DT (E1)); ! Exchange_Declarations (E2); ! end if; end; end if; *************** package body Exp_Disp is *** 326,333 **** Loc : constant Source_Ptr := Sloc (Call_Node); Call_Typ : constant Entity_Id := Etype (Call_Node); ! Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); ! Param_List : constant List_Id := Parameter_Associations (Call_Node); Subp : Entity_Id; CW_Typ : Entity_Id; --- 338,346 ---- Loc : constant Source_Ptr := Sloc (Call_Node); Call_Typ : constant Entity_Id := Etype (Call_Node); ! Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); ! Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); ! Param_List : constant List_Id := Parameter_Associations (Call_Node); Subp : Entity_Id; CW_Typ : Entity_Id; *************** package body Exp_Disp is *** 407,415 **** -- This capability of dispatching directly by tag is also needed by the -- implementation of AI-260 (for the generic dispatching constructors). ! if Etype (Ctrl_Arg) = RTE (RE_Tag) or else (RTE_Available (RE_Interface_Tag) ! and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)) then CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp)); --- 420,428 ---- -- This capability of dispatching directly by tag is also needed by the -- implementation of AI-260 (for the generic dispatching constructors). ! if Ctrl_Typ = RTE (RE_Tag) or else (RTE_Available (RE_Interface_Tag) ! and then Ctrl_Typ = RTE (RE_Interface_Tag)) then CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp)); *************** package body Exp_Disp is *** 418,428 **** -- there are cases where the controlling type is resolved to a specific -- type (such as for designated types of arguments such as CW'Access). ! elsif Is_Access_Type (Etype (Ctrl_Arg)) then ! CW_Typ := Class_Wide_Type (Designated_Type (Etype (Ctrl_Arg))); else ! CW_Typ := Class_Wide_Type (Etype (Ctrl_Arg)); end if; Typ := Root_Type (CW_Typ); --- 431,441 ---- -- there are cases where the controlling type is resolved to a specific -- type (such as for designated types of arguments such as CW'Access). ! elsif Is_Access_Type (Ctrl_Typ) then ! CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ)); else ! CW_Typ := Class_Wide_Type (Ctrl_Typ); end if; Typ := Root_Type (CW_Typ); *************** package body Exp_Disp is *** 547,553 **** Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node); Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node); Set_Etype (Subp_Typ, Res_Typ); - Init_Size_Align (Subp_Ptr_Typ); Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); -- Create a new list of parameters which is a copy of the old formal --- 560,565 ---- *************** package body Exp_Disp is *** 574,591 **** Set_Etype (New_Formal, Etype (Param)); end if; ! if Is_Itype (Etype (New_Formal)) then ! Extra := New_Copy (Etype (New_Formal)); ! ! if Ekind (Extra) = E_Record_Subtype ! or else Ekind (Extra) = E_Class_Wide_Subtype ! then ! Set_Cloned_Subtype (Extra, Etype (New_Formal)); ! end if; ! ! Set_Etype (New_Formal, Extra); ! Set_Scope (Etype (New_Formal), Subp_Typ); ! end if; Extra := New_Formal; Next_Formal (Old_Formal); --- 586,596 ---- Set_Etype (New_Formal, Etype (Param)); end if; ! -- If the type of the formal is an itype, there was code here ! -- introduced in 1998 in revision 1.46, to create a new itype ! -- by copy. This seems useless, and in fact leads to semantic ! -- errors when the itype is the completion of a type derived ! -- from a private type. Extra := New_Formal; Next_Formal (Old_Formal); *************** package body Exp_Disp is *** 612,625 **** Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); -- If the controlling argument is a value of type Ada.Tag or an abstract -- interface class-wide type then use it directly. Otherwise, the tag -- must be extracted from the controlling object. ! if Etype (Ctrl_Arg) = RTE (RE_Tag) or else (RTE_Available (RE_Interface_Tag) ! and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)) then Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); --- 617,631 ---- Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); + Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ)); -- If the controlling argument is a value of type Ada.Tag or an abstract -- interface class-wide type then use it directly. Otherwise, the tag -- must be extracted from the controlling object. ! if Ctrl_Typ = RTE (RE_Tag) or else (RTE_Available (RE_Interface_Tag) ! and then Ctrl_Typ = RTE (RE_Interface_Tag)) then Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); *************** package body Exp_Disp is *** 641,648 **** -- Ada 2005 (AI-251): Abstract interface class-wide type ! elsif Is_Interface (Etype (Ctrl_Arg)) ! and then Is_Class_Wide_Type (Etype (Ctrl_Arg)) then Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); --- 647,654 ---- -- Ada 2005 (AI-251): Abstract interface class-wide type ! elsif Is_Interface (Ctrl_Typ) ! and then Is_Class_Wide_Type (Ctrl_Typ) then Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); *************** package body Exp_Disp is *** 719,725 **** Rewrite (Call_Node, New_Call); -- Suppress all checks during the analysis of the expanded code ! -- to avoid the generation of spureous warnings under ZFP run-time. Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); end Expand_Dispatching_Call; --- 725,731 ---- Rewrite (Call_Node, New_Call); -- Suppress all checks during the analysis of the expanded code ! -- to avoid the generation of spurious warnings under ZFP run-time. Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); end Expand_Dispatching_Call; *************** package body Exp_Disp is *** 760,765 **** --- 766,783 ---- Iface_Typ := Root_Type (Iface_Typ); end if; + -- If the target type is a tagged synchronized type, the dispatch table + -- info is in the corresponding record type. + + if Is_Concurrent_Type (Iface_Typ) then + Iface_Typ := Corresponding_Record_Type (Iface_Typ); + end if; + + -- Freeze the entity associated with the target interface to have + -- available the attribute Access_Disp_Table. + + Freeze_Before (N, Iface_Typ); + pragma Assert (not Is_Static or else (not Is_Class_Wide_Type (Iface_Typ) and then Is_Interface (Iface_Typ))); *************** package body Exp_Disp is *** 778,784 **** -- Give error if configurable run time and Displace not available if not RTE_Available (RE_Displace) then ! Error_Msg_CRT ("abstract interface types", N); return; end if; --- 796,802 ---- -- Give error if configurable run time and Displace not available if not RTE_Available (RE_Displace) then ! Error_Msg_CRT ("dynamic interface conversion", N); return; end if; *************** package body Exp_Disp is *** 794,802 **** -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2 if Is_Access_Type (Operand_Typ) then - pragma Assert - (Is_Interface (Directly_Designated_Type (Operand_Typ))); - Rewrite (N, Unchecked_Convert_To (Etype (N), Make_Function_Call (Loc, --- 812,817 ---- *************** package body Exp_Disp is *** 837,845 **** begin New_Itype := Create_Itype (E_Anonymous_Access_Type, N); ! Set_Etype (New_Itype, New_Itype); ! Init_Esize (New_Itype); ! Init_Size_Align (New_Itype); Set_Directly_Designated_Type (New_Itype, Etyp); Rewrite (N, --- 852,858 ---- begin New_Itype := Create_Itype (E_Anonymous_Access_Type, N); ! Set_Etype (New_Itype, New_Itype); Set_Directly_Designated_Type (New_Itype, Etyp); Rewrite (N, *************** package body Exp_Disp is *** 1038,1044 **** if Nkind (Name (Call_Node)) = N_Explicit_Dereference then Subp := Etype (Name (Call_Node)); ! -- Normal case else Subp := Entity (Name (Call_Node)); --- 1051,1062 ---- if Nkind (Name (Call_Node)) = N_Explicit_Dereference then Subp := Etype (Name (Call_Node)); ! -- Call using selected component ! ! elsif Nkind (Name (Call_Node)) = N_Selected_Component then ! Subp := Entity (Selector_Name (Name (Call_Node))); ! ! -- Call using direct name else Subp := Entity (Name (Call_Node)); *************** package body Exp_Disp is *** 1079,1085 **** -- a parent of the type of the actual because in this case the -- interface primitives are located in the primary dispatch table. ! elsif Is_Parent (Formal_Typ, Actual_Typ) then null; -- Implicit conversion to the class-wide formal type to force --- 1097,1103 ---- -- a parent of the type of the actual because in this case the -- interface primitives are located in the primary dispatch table. ! elsif Is_Ancestor (Formal_Typ, Actual_Typ) then null; -- Implicit conversion to the class-wide formal type to force *************** package body Exp_Disp is *** 1125,1131 **** -- a parent of the type of the actual because in this case the -- interface primitives are located in the primary dispatch table. ! elsif Is_Parent (Formal_DDT, Actual_DDT) then null; else --- 1143,1149 ---- -- a parent of the type of the actual because in this case the -- interface primitives are located in the primary dispatch table. ! elsif Is_Ancestor (Formal_DDT, Actual_DDT) then null; else *************** package body Exp_Disp is *** 1135,1142 **** -- If the type of the actual parameter comes from a limited -- with-clause and the non-limited view is already available ! -- we replace the anonymous access type by a duplicate decla ! -- ration whose designated type is the non-limited view if Ekind (Actual_DDT) = E_Incomplete_Type and then Present (Non_Limited_View (Actual_DDT)) --- 1153,1160 ---- -- If the type of the actual parameter comes from a limited -- with-clause and the non-limited view is already available ! -- we replace the anonymous access type by a duplicate ! -- declaration whose designated type is the non-limited view if Ekind (Actual_DDT) = E_Incomplete_Type and then Present (Non_Limited_View (Actual_DDT)) *************** package body Exp_Disp is *** 1203,1208 **** --- 1221,1228 ---- Decl_1 : Node_Id; Decl_2 : Node_Id; Formal : Node_Id; + New_Arg : Node_Id; + Offset_To_Top : Node_Id; Target : Entity_Id; Target_Formal : Entity_Id; *************** package body Exp_Disp is *** 1210,1222 **** Thunk_Id := Empty; Thunk_Code := Empty; - -- Give message if configurable run-time and Offset_To_Top unavailable - - if not RTE_Available (RE_Offset_To_Top) then - Error_Msg_CRT ("abstract interface types", Prim); - return; - end if; - -- Traverse the list of alias to find the final target Target := Prim; --- 1230,1235 ---- *************** package body Exp_Disp is *** 1282,1287 **** --- 1295,1314 ---- (Directly_Designated_Type (Etype (Target_Formal)), Loc))); + New_Arg := + Unchecked_Convert_To (RTE (RE_Address), + New_Reference_To (Defining_Identifier (Formal), Loc)); + + if not RTE_Available (RE_Offset_To_Top) then + Offset_To_Top := + Build_Offset_To_Top (Loc, New_Arg); + else + Offset_To_Top := + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), + Parameter_Associations => New_List (New_Arg)); + end if; + Decl_1 := Make_Object_Declaration (Loc, Defining_Identifier => *************** package body Exp_Disp is *** 1297,1310 **** (RTE (RE_Storage_Offset), New_Reference_To (Defining_Identifier (Formal), Loc)), Right_Opnd => ! Make_Function_Call (Loc, ! Name => ! New_Reference_To (RTE (RE_Offset_To_Top), Loc), ! Parameter_Associations => New_List ( ! Unchecked_Convert_To ! (RTE (RE_Address), ! New_Reference_To ! (Defining_Identifier (Formal), Loc)))))); Append_To (Decl, Decl_2); Append_To (Decl, Decl_1); --- 1324,1330 ---- (RTE (RE_Storage_Offset), New_Reference_To (Defining_Identifier (Formal), Loc)), Right_Opnd => ! Offset_To_Top)); Append_To (Decl, Decl_2); Append_To (Decl, Decl_1); *************** package body Exp_Disp is *** 1324,1329 **** --- 1344,1366 ---- -- - Offset_To_Top (Formal'Address) -- S2 : Addr_Ptr := Addr_Ptr!(S1) + New_Arg := + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Defining_Identifier (Formal), Loc), + Attribute_Name => + Name_Address); + + if not RTE_Available (RE_Offset_To_Top) then + Offset_To_Top := + Build_Offset_To_Top (Loc, New_Arg); + else + Offset_To_Top := + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), + Parameter_Associations => New_List (New_Arg)); + end if; + Decl_1 := Make_Object_Declaration (Loc, Defining_Identifier => *************** package body Exp_Disp is *** 1342,1356 **** (Defining_Identifier (Formal), Loc), Attribute_Name => Name_Address)), Right_Opnd => ! Make_Function_Call (Loc, ! Name => ! New_Reference_To (RTE (RE_Offset_To_Top), Loc), ! Parameter_Associations => New_List ( ! Make_Attribute_Reference (Loc, ! Prefix => ! New_Reference_To ! (Defining_Identifier (Formal), Loc), ! Attribute_Name => Name_Address))))); Decl_2 := Make_Object_Declaration (Loc, --- 1379,1385 ---- (Defining_Identifier (Formal), Loc), Attribute_Name => Name_Address)), Right_Opnd => ! Offset_To_Top)); Decl_2 := Make_Object_Declaration (Loc, *************** package body Exp_Disp is *** 1438,1443 **** --- 1467,1516 ---- and then not Restriction_Active (No_Dispatching_Calls); end Has_DT; + ----------------------------------------- + -- Is_Predefined_Dispatching_Operation -- + ----------------------------------------- + + function Is_Predefined_Dispatching_Operation + (E : Entity_Id) return Boolean + is + TSS_Name : TSS_Name_Type; + + begin + if not Is_Dispatching_Operation (E) then + return False; + end if; + + Get_Name_String (Chars (E)); + + -- Most predefined primitives have internally generated names. Equality + -- must be treated differently; the predefined operation is recognized + -- as a homogeneous binary operator that returns Boolean. + + if Name_Len > TSS_Name_Type'Last then + TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 + .. Name_Len)); + if Chars (E) = Name_uSize + or else Chars (E) = Name_uAlignment + or else TSS_Name = TSS_Stream_Read + or else TSS_Name = TSS_Stream_Write + or else TSS_Name = TSS_Stream_Input + or else TSS_Name = TSS_Stream_Output + or else + (Chars (E) = Name_Op_Eq + and then Etype (First_Entity (E)) = Etype (Last_Entity (E))) + or else Chars (E) = Name_uAssign + or else TSS_Name = TSS_Deep_Adjust + or else TSS_Name = TSS_Deep_Finalize + or else Is_Predefined_Interface_Primitive (E) + then + return True; + end if; + end if; + + return False; + end Is_Predefined_Dispatching_Operation; + ------------------------------------- -- Is_Predefined_Dispatching_Alias -- ------------------------------------- *************** package body Exp_Disp is *** 1463,1468 **** --- 1536,1556 ---- return False; end Is_Predefined_Dispatching_Alias; + --------------------------------------- + -- Is_Predefined_Interface_Primitive -- + --------------------------------------- + + function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is + begin + return Ada_Version >= Ada_05 + and then (Chars (E) = Name_uDisp_Asynchronous_Select or else + Chars (E) = Name_uDisp_Conditional_Select or else + Chars (E) = Name_uDisp_Get_Prim_Op_Kind or else + Chars (E) = Name_uDisp_Get_Task_Id or else + Chars (E) = Name_uDisp_Requeue or else + Chars (E) = Name_uDisp_Timed_Select); + end Is_Predefined_Interface_Primitive; + ---------------------------------------- -- Make_Disp_Asynchronous_Select_Body -- ---------------------------------------- *************** package body Exp_Disp is *** 1531,1536 **** --- 1619,1625 ---- Decls : constant List_Id := New_List; DT_Ptr : Entity_Id; Loc : constant Source_Ptr := Sloc (Typ); + Obj_Ref : Node_Id; Stmts : constant List_Id := New_List; begin *************** package body Exp_Disp is *** 1593,1638 **** Object_Definition => New_Reference_To (RTE (RE_Communication_Block), Loc))); ! -- Generate: ! -- Protected_Entry_Call ! -- (T._object'Access, -- Object ! -- Protected_Entry_Index! (I), -- E ! -- P, -- Uninterpreted_Data ! -- Asynchronous_Call, -- Mode ! -- Bnn); -- Communication_Block ! -- where T is the protected object, I is the entry index, P are ! -- the wrapped parameters and B is the name of the communication ! -- block. ! Append_To (Stmts, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), ! Parameter_Associations => ! New_List ( ! Make_Attribute_Reference (Loc, -- T._object'Access ! Attribute_Name => ! Name_Unchecked_Access, ! Prefix => ! Make_Selected_Component (Loc, ! Prefix => ! Make_Identifier (Loc, Name_uT), ! Selector_Name => ! Make_Identifier (Loc, Name_uObject))), ! Make_Unchecked_Type_Conversion (Loc, -- entry index ! Subtype_Mark => ! New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), ! Expression => ! Make_Identifier (Loc, Name_uI)), ! Make_Identifier (Loc, Name_uP), -- parameter block ! New_Reference_To ( -- Asynchronous_Call ! RTE (RE_Asynchronous_Call), Loc), ! New_Reference_To (Com_Block, Loc)))); -- comm block -- Generate: -- B := Dummy_Communication_Block (Bnn); --- 1682,1759 ---- Object_Definition => New_Reference_To (RTE (RE_Communication_Block), Loc))); ! -- Build T._object'Access for calls below ! Obj_Ref := ! Make_Attribute_Reference (Loc, ! Attribute_Name => Name_Unchecked_Access, ! Prefix => ! Make_Selected_Component (Loc, ! Prefix => Make_Identifier (Loc, Name_uT), ! Selector_Name => Make_Identifier (Loc, Name_uObject))); ! case Corresponding_Runtime_Package (Conc_Typ) is ! when System_Tasking_Protected_Objects_Entries => ! -- Generate: ! -- Protected_Entry_Call ! -- (T._object'Access, -- Object ! -- Protected_Entry_Index! (I), -- E ! -- P, -- Uninterpreted_Data ! -- Asynchronous_Call, -- Mode ! -- Bnn); -- Communication_Block ! -- where T is the protected object, I is the entry index, P ! -- is the wrapped parameters and B is the name of the ! -- communication block. ! Append_To (Stmts, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), ! Parameter_Associations => ! New_List ( ! Obj_Ref, ! Make_Unchecked_Type_Conversion (Loc, -- entry index ! Subtype_Mark => ! New_Reference_To ! (RTE (RE_Protected_Entry_Index), Loc), ! Expression => Make_Identifier (Loc, Name_uI)), ! ! Make_Identifier (Loc, Name_uP), -- parameter block ! New_Reference_To ( -- Asynchronous_Call ! RTE (RE_Asynchronous_Call), Loc), ! ! New_Reference_To (Com_Block, Loc)))); -- comm block ! ! when System_Tasking_Protected_Objects_Single_Entry => ! ! -- Generate: ! -- procedure Protected_Single_Entry_Call ! -- (Object : Protection_Entry_Access; ! -- Uninterpreted_Data : System.Address; ! -- Mode : Call_Modes); ! ! Append_To (Stmts, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To ! (RTE (RE_Protected_Single_Entry_Call), Loc), ! Parameter_Associations => ! New_List ( ! Obj_Ref, ! ! Make_Attribute_Reference (Loc, ! Prefix => Make_Identifier (Loc, Name_uP), ! Attribute_Name => Name_Address), ! ! New_Reference_To ! (RTE (RE_Asynchronous_Call), Loc)))); ! ! when others => ! raise Program_Error; ! end case; -- Generate: -- B := Dummy_Communication_Block (Bnn); *************** package body Exp_Disp is *** 1660,1666 **** -- Asynchronous_Call, -- Mode -- F); -- Rendezvous_Successful ! -- where T is the task object, I is the entry index, P are the -- wrapped parameters and F is the status flag. Append_To (Stmts, --- 1781,1787 ---- -- Asynchronous_Call, -- Mode -- F); -- Rendezvous_Successful ! -- where T is the task object, I is the entry index, P is the -- wrapped parameters and F is the status flag. Append_To (Stmts, *************** package body Exp_Disp is *** 1669,1675 **** New_Reference_To (RTE (RE_Task_Entry_Call), Loc), Parameter_Associations => New_List ( - Make_Selected_Component (Loc, -- T._task_id Prefix => Make_Identifier (Loc, Name_uT), --- 1790,1795 ---- *************** package body Exp_Disp is *** 1843,1848 **** --- 1963,1969 ---- Conc_Typ : Entity_Id := Empty; Decls : constant List_Id := New_List; DT_Ptr : Entity_Id; + Obj_Ref : Node_Id; Stmts : constant List_Id := New_List; begin *************** package body Exp_Disp is *** 1929,1974 **** if Ekind (Conc_Typ) = E_Protected_Type then ! -- Generate: ! -- Protected_Entry_Call ! -- (T._object'Access, -- Object ! -- Protected_Entry_Index! (I), -- E ! -- P, -- Uninterpreted_Data ! -- Conditional_Call, -- Mode ! -- Bnn); -- Block ! -- where T is the protected object, I is the entry index, P are ! -- the wrapped parameters and Bnn is the name of the communication ! -- block. ! Append_To (Stmts, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), ! Parameter_Associations => ! New_List ( ! Make_Attribute_Reference (Loc, -- T._object'Access ! Attribute_Name => ! Name_Unchecked_Access, ! Prefix => ! Make_Selected_Component (Loc, ! Prefix => ! Make_Identifier (Loc, Name_uT), ! Selector_Name => ! Make_Identifier (Loc, Name_uObject))), ! Make_Unchecked_Type_Conversion (Loc, -- entry index ! Subtype_Mark => ! New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), ! Expression => ! Make_Identifier (Loc, Name_uI)), ! Make_Identifier (Loc, Name_uP), -- parameter block ! New_Reference_To ( -- Conditional_Call ! RTE (RE_Conditional_Call), Loc), ! New_Reference_To ( -- Bnn ! Blk_Nam, Loc)))); -- Generate: -- F := not Cancelled (Bnn); --- 2050,2122 ---- if Ekind (Conc_Typ) = E_Protected_Type then ! Obj_Ref := -- T._object'Access ! Make_Attribute_Reference (Loc, ! Attribute_Name => Name_Unchecked_Access, ! Prefix => ! Make_Selected_Component (Loc, ! Prefix => Make_Identifier (Loc, Name_uT), ! Selector_Name => Make_Identifier (Loc, Name_uObject))); ! case Corresponding_Runtime_Package (Conc_Typ) is ! when System_Tasking_Protected_Objects_Entries => ! -- Generate: ! -- Protected_Entry_Call ! -- (T._object'Access, -- Object ! -- Protected_Entry_Index! (I), -- E ! -- P, -- Uninterpreted_Data ! -- Conditional_Call, -- Mode ! -- Bnn); -- Block ! -- where T is the protected object, I is the entry index, P ! -- are the wrapped parameters and Bnn is the name of the ! -- communication block. ! Append_To (Stmts, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), ! Parameter_Associations => ! New_List ( ! Obj_Ref, ! Make_Unchecked_Type_Conversion (Loc, -- entry index ! Subtype_Mark => ! New_Reference_To ! (RTE (RE_Protected_Entry_Index), Loc), ! Expression => Make_Identifier (Loc, Name_uI)), ! ! Make_Identifier (Loc, Name_uP), -- parameter block ! ! New_Reference_To ( -- Conditional_Call ! RTE (RE_Conditional_Call), Loc), ! New_Reference_To ( -- Bnn ! Blk_Nam, Loc)))); ! ! when System_Tasking_Protected_Objects_Single_Entry => ! ! -- If we are compiling for a restricted run-time, the call ! -- uses the simpler form. ! ! Append_To (Stmts, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To ! (RTE (RE_Protected_Single_Entry_Call), Loc), ! Parameter_Associations => ! New_List ( ! Obj_Ref, ! ! Make_Attribute_Reference (Loc, ! Prefix => Make_Identifier (Loc, Name_uP), ! Attribute_Name => Name_Address), ! ! New_Reference_To ! (RTE (RE_Conditional_Call), Loc)))); ! when others => ! raise Program_Error; ! end case; -- Generate: -- F := not Cancelled (Bnn); *************** package body Exp_Disp is *** 2339,2417 **** -- A); -- end if; ! Append_To (Stmts, ! Make_If_Statement (Loc, ! Condition => ! Make_Identifier (Loc, Name_uF), ! Then_Statements => ! New_List ( ! -- Call to Requeue_Protected_Entry ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To ( ! RTE (RE_Requeue_Protected_Entry), Loc), ! Parameter_Associations => ! New_List ( ! Make_Unchecked_Type_Conversion (Loc, -- PEA (P) ! Subtype_Mark => ! New_Reference_To ( ! RTE (RE_Protection_Entries_Access), Loc), ! Expression => ! Make_Identifier (Loc, Name_uP)), ! Make_Attribute_Reference (Loc, -- O._object'Acc ! Attribute_Name => ! Name_Unchecked_Access, ! Prefix => ! Make_Selected_Component (Loc, ! Prefix => ! Make_Identifier (Loc, Name_uO), ! Selector_Name => ! Make_Identifier (Loc, Name_uObject))), ! Make_Unchecked_Type_Conversion (Loc, -- entry index ! Subtype_Mark => ! New_Reference_To ( ! RTE (RE_Protected_Entry_Index), Loc), ! Expression => ! Make_Identifier (Loc, Name_uI)), ! Make_Identifier (Loc, Name_uA)))), -- abort status ! Else_Statements => ! New_List ( ! -- Call to Requeue_Task_To_Protected_Entry ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To ( ! RTE (RE_Requeue_Task_To_Protected_Entry), Loc), ! Parameter_Associations => ! New_List ( ! Make_Attribute_Reference (Loc, -- O._object'Acc ! Attribute_Name => ! Name_Unchecked_Access, ! Prefix => ! Make_Selected_Component (Loc, ! Prefix => ! Make_Identifier (Loc, Name_uO), ! Selector_Name => ! Make_Identifier (Loc, Name_uObject))), ! Make_Unchecked_Type_Conversion (Loc, -- entry index ! Subtype_Mark => ! New_Reference_To ( ! RTE (RE_Protected_Entry_Index), Loc), ! Expression => ! Make_Identifier (Loc, Name_uI)), ! Make_Identifier (Loc, Name_uA)))))); -- abort status else pragma Assert (Is_Task_Type (Conc_Typ)); --- 2487,2569 ---- -- A); -- end if; ! if Restriction_Active (No_Entry_Queue) then ! Append_To (Stmts, Make_Null_Statement (Loc)); ! else ! Append_To (Stmts, ! Make_If_Statement (Loc, ! Condition => ! Make_Identifier (Loc, Name_uF), ! Then_Statements => ! New_List ( ! -- Call to Requeue_Protected_Entry ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To ( ! RTE (RE_Requeue_Protected_Entry), Loc), ! Parameter_Associations => ! New_List ( ! Make_Unchecked_Type_Conversion (Loc, -- PEA (P) ! Subtype_Mark => ! New_Reference_To ( ! RTE (RE_Protection_Entries_Access), Loc), ! Expression => ! Make_Identifier (Loc, Name_uP)), ! Make_Attribute_Reference (Loc, -- O._object'Acc ! Attribute_Name => ! Name_Unchecked_Access, ! Prefix => ! Make_Selected_Component (Loc, ! Prefix => ! Make_Identifier (Loc, Name_uO), ! Selector_Name => ! Make_Identifier (Loc, Name_uObject))), ! Make_Unchecked_Type_Conversion (Loc, -- entry index ! Subtype_Mark => ! New_Reference_To ( ! RTE (RE_Protected_Entry_Index), Loc), ! Expression => ! Make_Identifier (Loc, Name_uI)), ! Make_Identifier (Loc, Name_uA)))), -- abort status ! Else_Statements => ! New_List ( ! -- Call to Requeue_Task_To_Protected_Entry ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To ( ! RTE (RE_Requeue_Task_To_Protected_Entry), Loc), ! Parameter_Associations => ! New_List ( ! Make_Attribute_Reference (Loc, -- O._object'Acc ! Attribute_Name => ! Name_Unchecked_Access, ! Prefix => ! Make_Selected_Component (Loc, ! Prefix => ! Make_Identifier (Loc, Name_uO), ! Selector_Name => ! Make_Identifier (Loc, Name_uObject))), ! Make_Unchecked_Type_Conversion (Loc, -- entry index ! Subtype_Mark => ! New_Reference_To ( ! RTE (RE_Protected_Entry_Index), Loc), ! Expression => ! Make_Identifier (Loc, Name_uI)), ! Make_Identifier (Loc, Name_uA)))))); -- abort status ! end if; else pragma Assert (Is_Task_Type (Conc_Typ)); *************** package body Exp_Disp is *** 2658,2663 **** --- 2810,2816 ---- Conc_Typ : Entity_Id := Empty; Decls : constant List_Id := New_List; DT_Ptr : Entity_Id; + Obj_Ref : Node_Id; Stmts : constant List_Id := New_List; begin *************** package body Exp_Disp is *** 2727,2774 **** New_Reference_To (DT_Ptr, Loc)), Make_Identifier (Loc, Name_uS))))); if Ekind (Conc_Typ) = E_Protected_Type then ! -- Generate: ! -- Timed_Protected_Entry_Call ( ! -- T._object'access, -- Protected_Entry_Index! (I), ! -- P, ! -- D, ! -- M, ! -- F); -- where T is the protected object, I is the entry index, P are -- the wrapped parameters, D is the delay amount, M is the delay -- mode and F is the status flag. ! Append_To (Stmts, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc), ! Parameter_Associations => ! New_List ( ! Make_Attribute_Reference (Loc, -- T._object'access ! Attribute_Name => ! Name_Unchecked_Access, ! Prefix => ! Make_Selected_Component (Loc, ! Prefix => ! Make_Identifier (Loc, Name_uT), ! Selector_Name => ! Make_Identifier (Loc, Name_uObject))), ! Make_Unchecked_Type_Conversion (Loc, -- entry index ! Subtype_Mark => ! New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), ! Expression => ! Make_Identifier (Loc, Name_uI)), ! Make_Identifier (Loc, Name_uP), -- parameter block ! Make_Identifier (Loc, Name_uD), -- delay ! Make_Identifier (Loc, Name_uM), -- delay mode ! Make_Identifier (Loc, Name_uF)))); -- status flag else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); --- 2880,2962 ---- New_Reference_To (DT_Ptr, Loc)), Make_Identifier (Loc, Name_uS))))); + -- Protected case + if Ekind (Conc_Typ) = E_Protected_Type then ! -- Build T._object'Access ! ! Obj_Ref := ! Make_Attribute_Reference (Loc, ! Attribute_Name => Name_Unchecked_Access, ! Prefix => ! Make_Selected_Component (Loc, ! Prefix => Make_Identifier (Loc, Name_uT), ! Selector_Name => Make_Identifier (Loc, Name_uObject))); ! ! -- Normal case, No_Entry_Queue restriction not active. In this ! -- case we generate: ! ! -- Timed_Protected_Entry_Call ! -- (T._object'access, -- Protected_Entry_Index! (I), ! -- P, D, M, F); -- where T is the protected object, I is the entry index, P are -- the wrapped parameters, D is the delay amount, M is the delay -- mode and F is the status flag. ! case Corresponding_Runtime_Package (Conc_Typ) is ! when System_Tasking_Protected_Objects_Entries => ! Append_To (Stmts, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To ! (RTE (RE_Timed_Protected_Entry_Call), Loc), ! Parameter_Associations => ! New_List ( ! Obj_Ref, ! Make_Unchecked_Type_Conversion (Loc, -- entry index ! Subtype_Mark => ! New_Reference_To ! (RTE (RE_Protected_Entry_Index), Loc), ! Expression => ! Make_Identifier (Loc, Name_uI)), ! Make_Identifier (Loc, Name_uP), -- parameter block ! Make_Identifier (Loc, Name_uD), -- delay ! Make_Identifier (Loc, Name_uM), -- delay mode ! Make_Identifier (Loc, Name_uF)))); -- status flag ! when System_Tasking_Protected_Objects_Single_Entry => ! -- Generate: ! ! -- Timed_Protected_Single_Entry_Call ! -- (T._object'access, P, D, M, F); ! ! -- where T is the protected object, P is the wrapped ! -- parameters, D is the delay amount, M is the delay mode, F ! -- is the status flag. ! ! Append_To (Stmts, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Reference_To ! (RTE (RE_Timed_Protected_Single_Entry_Call), Loc), ! Parameter_Associations => ! New_List ( ! Obj_Ref, ! Make_Identifier (Loc, Name_uP), -- parameter block ! Make_Identifier (Loc, Name_uD), -- delay ! Make_Identifier (Loc, Name_uM), -- delay mode ! Make_Identifier (Loc, Name_uF)))); -- status flag ! ! when others => ! raise Program_Error; ! end case; ! ! -- Task case else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); *************** package body Exp_Disp is *** 2940,2945 **** --- 3128,3137 ---- (Expression (Parent (RTE (RE_Max_Predef_Prims))))); + DT_Decl : constant Elist_Id := New_Elmt_List; + DT_Aggr : constant Elist_Id := New_Elmt_List; + -- Entities marked with attribute Is_Dispatch_Table_Entity + procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id); -- Verify that all non-tagged types in the profile of a subprogram -- are frozen at the point the subprogram is frozen. This enforces *************** package body Exp_Disp is *** 2957,2968 **** -- generate forward references and statically allocate the table. procedure Make_Secondary_DT ! (Typ : Entity_Id; ! Iface : Entity_Id; ! Num_Iface_Prims : Nat; ! Iface_DT_Ptr : Entity_Id; ! Build_Thunks : Boolean; ! Result : List_Id); -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch -- Table of Typ associated with Iface. Each abstract interface of Typ -- has two secondary dispatch tables: one containing pointers to thunks --- 3149,3161 ---- -- generate forward references and statically allocate the table. procedure Make_Secondary_DT ! (Typ : Entity_Id; ! Iface : Entity_Id; ! Num_Iface_Prims : Nat; ! Iface_DT_Ptr : Entity_Id; ! Predef_Prims_Ptr : Entity_Id; ! Build_Thunks : Boolean; ! Result : List_Id); -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch -- Table of Typ associated with Iface. Each abstract interface of Typ -- has two secondary dispatch tables: one containing pointers to thunks *************** package body Exp_Disp is *** 3024,3035 **** ----------------------- procedure Make_Secondary_DT ! (Typ : Entity_Id; ! Iface : Entity_Id; ! Num_Iface_Prims : Nat; ! Iface_DT_Ptr : Entity_Id; ! Build_Thunks : Boolean; ! Result : List_Id) is Loc : constant Source_Ptr := Sloc (Typ); Name_DT : constant Name_Id := New_Internal_Name ('T'); --- 3217,3229 ---- ----------------------- procedure Make_Secondary_DT ! (Typ : Entity_Id; ! Iface : Entity_Id; ! Num_Iface_Prims : Nat; ! Iface_DT_Ptr : Entity_Id; ! Predef_Prims_Ptr : Entity_Id; ! Build_Thunks : Boolean; ! Result : List_Id) is Loc : constant Source_Ptr := Sloc (Typ); Name_DT : constant Name_Id := New_Internal_Name ('T'); *************** package body Exp_Disp is *** 3058,3067 **** if not Building_Static_DT (Typ) then Set_Ekind (Predef_Prims, E_Variable); - Set_Is_Statically_Allocated (Predef_Prims); - Set_Ekind (Iface_DT, E_Variable); - Set_Is_Statically_Allocated (Iface_DT); -- Statically allocated dispatch tables and related entities are -- constants. --- 3252,3258 ---- *************** package body Exp_Disp is *** 3125,3130 **** --- 3316,3322 ---- declare Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; + Decl : Node_Id; Thunk_Id : Entity_Id; Thunk_Code : Node_Id; *************** package body Exp_Disp is *** 3168,3193 **** for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim_Table (J), Loc), ! Attribute_Name => Name_Address); else ! New_Node := ! New_Reference_To (RTE (RE_Null_Address), Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, Constant_Present => Building_Static_DT (Typ), Aliased_Present => True, ! Object_Definition => ! New_Reference_To (RTE (RE_Address_Array), Loc), ! Expression => Make_Aggregate (Loc, ! Expressions => Prim_Ops_Aggr_List))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, --- 3360,3402 ---- for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := ! Unchecked_Convert_To (RTE (RE_Prim_Ptr), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim_Table (J), Loc), ! Attribute_Name => Name_Unrestricted_Access)); else ! New_Node := Make_Null (Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; + New_Node := + Make_Aggregate (Loc, + Expressions => Prim_Ops_Aggr_List); + + -- Remember aggregates initializing dispatch tables + + Append_Elmt (New_Node, DT_Aggr); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')), + Subtype_Indication => + New_Reference_To (RTE (RE_Address_Array), Loc)); + + Append_To (Result, Decl); + Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, Constant_Present => Building_Static_DT (Typ), Aliased_Present => True, ! Object_Definition => New_Reference_To ! (Defining_Identifier (Decl), Loc), ! Expression => New_Node)); Append_To (Result, Make_Attribute_Definition_Clause (Loc, *************** package body Exp_Disp is *** 3268,3274 **** or else Is_Controlled (Typ) or else Restriction_Active (No_Dispatching_Calls) or else not Is_Limited_Type (Typ) ! or else not Has_Abstract_Interfaces (Typ) or else not Build_Thunks then -- No OSD table required --- 3477,3483 ---- or else Is_Controlled (Typ) or else Restriction_Active (No_Dispatching_Calls) or else not Is_Limited_Type (Typ) ! or else not Has_Interfaces (Typ) or else not Build_Thunks then -- No OSD table required *************** package body Exp_Disp is *** 3296,3306 **** while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); ! if Present (Abstract_Interface_Alias (Prim)) and then Find_Dispatching_Type ! (Abstract_Interface_Alias (Prim)) = Iface then ! Prim_Alias := Abstract_Interface_Alias (Prim); E := Prim; while Present (Alias (E)) loop --- 3505,3515 ---- while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); ! if Present (Interface_Alias (Prim)) and then Find_Dispatching_Type ! (Interface_Alias (Prim)) = Iface then ! Prim_Alias := Interface_Alias (Prim); E := Prim; while Present (Alias (E)) loop *************** package body Exp_Disp is *** 3387,3401 **** Prim_Ops_Aggr_List := New_List; if Empty_DT then ! Append_To (Prim_Ops_Aggr_List, ! New_Reference_To (RTE (RE_Null_Address), Loc)); elsif Is_Abstract_Type (Typ) or else not Building_Static_DT (Typ) then for J in 1 .. Nb_Prim loop ! Append_To (Prim_Ops_Aggr_List, ! New_Reference_To (RTE (RE_Null_Address), Loc)); end loop; else --- 3596,3608 ---- Prim_Ops_Aggr_List := New_List; if Empty_DT then ! Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); elsif Is_Abstract_Type (Typ) or else not Building_Static_DT (Typ) then for J in 1 .. Nb_Prim loop ! Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); end loop; else *************** package body Exp_Disp is *** 3413,3443 **** Prim := Node (Prim_Elmt); if not Is_Predefined_Dispatching_Operation (Prim) ! and then Present (Abstract_Interface_Alias (Prim)) and then not Is_Abstract_Subprogram (Alias (Prim)) and then not Is_Imported (Alias (Prim)) and then Find_Dispatching_Type ! (Abstract_Interface_Alias (Prim)) = Iface -- Generate the code of the thunk only if the abstract -- interface type is not an immediate ancestor of -- Tagged_Type; otherwise the DT associated with the -- interface is the primary DT. ! and then not Is_Parent (Iface, Typ) then if not Build_Thunks then Pos := ! UI_To_Int ! (DT_Position (Abstract_Interface_Alias (Prim))); Prim_Table (Pos) := Alias (Prim); else Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); if Present (Thunk_Id) then Pos := ! UI_To_Int ! (DT_Position (Abstract_Interface_Alias (Prim))); Prim_Table (Pos) := Thunk_Id; Append_To (Result, Thunk_Code); --- 3620,3648 ---- Prim := Node (Prim_Elmt); if not Is_Predefined_Dispatching_Operation (Prim) ! and then Present (Interface_Alias (Prim)) and then not Is_Abstract_Subprogram (Alias (Prim)) and then not Is_Imported (Alias (Prim)) and then Find_Dispatching_Type ! (Interface_Alias (Prim)) = Iface -- Generate the code of the thunk only if the abstract -- interface type is not an immediate ancestor of -- Tagged_Type; otherwise the DT associated with the -- interface is the primary DT. ! and then not Is_Ancestor (Iface, Typ) then if not Build_Thunks then Pos := ! UI_To_Int (DT_Position (Interface_Alias (Prim))); Prim_Table (Pos) := Alias (Prim); else Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); if Present (Thunk_Id) then Pos := ! UI_To_Int (DT_Position (Interface_Alias (Prim))); Prim_Table (Pos) := Thunk_Id; Append_To (Result, Thunk_Code); *************** package body Exp_Disp is *** 3451,3462 **** for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim_Table (J), Loc), ! Attribute_Name => Name_Address); else ! New_Node := ! New_Reference_To (RTE (RE_Null_Address), Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); --- 3656,3667 ---- for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := ! Unchecked_Convert_To (RTE (RE_Prim_Ptr), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim_Table (J), Loc), ! Attribute_Name => Name_Unrestricted_Access)); else ! New_Node := Make_Null (Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); *************** package body Exp_Disp is *** 3464,3472 **** end; end if; ! Append_To (DT_Aggr_List, Make_Aggregate (Loc, ! Expressions => Prim_Ops_Aggr_List)); Append_To (Result, Make_Object_Declaration (Loc, --- 3669,3683 ---- end; end if; ! New_Node := Make_Aggregate (Loc, ! Expressions => Prim_Ops_Aggr_List); ! ! Append_To (DT_Aggr_List, New_Node); ! ! -- Remember aggregates initializing dispatch tables ! ! Append_Elmt (New_Node, DT_Aggr); Append_To (Result, Make_Object_Declaration (Loc, *************** package body Exp_Disp is *** 3513,3525 **** (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); end Make_Secondary_DT; -- Local variables ! Elab_Code : constant List_Id := New_List; ! Result : constant List_Id := New_List; ! Tname : constant Name_Id := Chars (Typ); AI : Elmt_Id; AI_Tag_Elmt : Elmt_Id; AI_Tag_Comp : Elmt_Id; --- 3724,3756 ---- (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Predef_Prims_Ptr, + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Address), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Iface_DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Predef_Prims), Loc)), + Attribute_Name => Name_Address))); + + -- Remember entities containing dispatch tables + + Append_Elmt (Predef_Prims, DT_Decl); + Append_Elmt (Iface_DT, DT_Decl); end Make_Secondary_DT; -- Local variables ! Elab_Code : constant List_Id := New_List; ! Result : constant List_Id := New_List; ! Tname : constant Name_Id := Chars (Typ); AI : Elmt_Id; AI_Tag_Elmt : Elmt_Id; AI_Tag_Comp : Elmt_Id; *************** package body Exp_Disp is *** 3530,3544 **** I_Depth : Nat := 0; Iface_Table_Node : Node_Id; Name_ITable : Name_Id; - Name_No_Reg : Name_Id; Nb_Predef_Prims : Nat := 0; Nb_Prim : Nat := 0; New_Node : Node_Id; - No_Reg : Node_Id; - Null_Parent_Tag : Boolean := False; Num_Ifaces : Nat := 0; ! Old_Tag1 : Node_Id; ! Old_Tag2 : Node_Id; Prim : Entity_Id; Prim_Elmt : Elmt_Id; Prim_Ops_Aggr_List : List_Id; --- 3761,3771 ---- I_Depth : Nat := 0; Iface_Table_Node : Node_Id; Name_ITable : Name_Id; Nb_Predef_Prims : Nat := 0; Nb_Prim : Nat := 0; New_Node : Node_Id; Num_Ifaces : Nat := 0; ! Parent_Typ : Entity_Id; Prim : Entity_Id; Prim_Elmt : Elmt_Id; Prim_Ops_Aggr_List : List_Id; *************** package body Exp_Disp is *** 3634,3639 **** --- 3861,3874 ---- end if; end if; + -- Initialize Parent_Typ handling private types + + Parent_Typ := Etype (Typ); + + if Present (Full_View (Parent_Typ)) then + Parent_Typ := Full_View (Parent_Typ); + end if; + -- Ensure that all the primitives are frozen. This is only required when -- building static dispatch tables --- the primitives must be frozen to -- be referenced (otherwise we have problems with the backend). It is *************** package body Exp_Disp is *** 3682,3692 **** -- Ada 2005 (AI-251): Build the secondary dispatch tables ! if Has_Abstract_Interfaces (Typ) then Collect_Interface_Components (Typ, Typ_Comps); Suffix_Index := 0; ! AI_Tag_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); AI_Tag_Comp := First_Elmt (Typ_Comps); while Present (AI_Tag_Comp) loop --- 3917,3928 ---- -- Ada 2005 (AI-251): Build the secondary dispatch tables ! if Has_Interfaces (Typ) then Collect_Interface_Components (Typ, Typ_Comps); Suffix_Index := 0; ! AI_Tag_Elmt := ! Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); AI_Tag_Comp := First_Elmt (Typ_Comps); while Present (AI_Tag_Comp) loop *************** package body Exp_Disp is *** 3699,3709 **** Num_Iface_Prims => UI_To_Int (DT_Entry_Count (Node (AI_Tag_Comp))), Iface_DT_Ptr => Node (AI_Tag_Elmt), Build_Thunks => True, Result => Result); Next_Elmt (AI_Tag_Elmt); ! -- Build the secondary table contaning pointers to primitives -- (used to give support to Generic Dispatching Constructors). Make_Secondary_DT --- 3935,3950 ---- Num_Iface_Prims => UI_To_Int (DT_Entry_Count (Node (AI_Tag_Comp))), Iface_DT_Ptr => Node (AI_Tag_Elmt), + Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), Build_Thunks => True, Result => Result); Next_Elmt (AI_Tag_Elmt); ! -- Skip the secondary dispatch table of predefined primitives ! ! Next_Elmt (AI_Tag_Elmt); ! ! -- Build the secondary table containing pointers to primitives -- (used to give support to Generic Dispatching Constructors). Make_Secondary_DT *************** package body Exp_Disp is *** 3712,3721 **** --- 3953,3967 ---- Num_Iface_Prims => UI_To_Int (DT_Entry_Count (Node (AI_Tag_Comp))), Iface_DT_Ptr => Node (AI_Tag_Elmt), + Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), Build_Thunks => False, Result => Result); Next_Elmt (AI_Tag_Elmt); + -- Skip the secondary dispatch table of predefined primitives + + Next_Elmt (AI_Tag_Elmt); + Suffix_Index := Suffix_Index + 1; Next_Elmt (AI_Tag_Comp); end loop; *************** package body Exp_Disp is *** 3727,3755 **** DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); ! Set_Is_Statically_Allocated (DT); ! Set_Is_Statically_Allocated (SSD); ! Set_Is_Statically_Allocated (TSD); ! Set_Is_Statically_Allocated (Predef_Prims); ! ! -- Generate code to define the boolean that controls registration, in ! -- order to avoid multiple registrations for tagged types defined in ! -- multiple-called scopes. ! ! Name_No_Reg := New_External_Name (Tname, 'F', Suffix_Index => -1); ! No_Reg := Make_Defining_Identifier (Loc, Name_No_Reg); ! ! Set_Ekind (No_Reg, E_Variable); ! Set_Is_Statically_Allocated (No_Reg); ! ! Append_To (Result, ! Make_Object_Declaration (Loc, ! Defining_Identifier => No_Reg, ! Object_Definition => New_Reference_To (Standard_Boolean, Loc), ! Expression => New_Reference_To (Standard_True, Loc))); -- In case of locally defined tagged type we declare the object ! -- contanining the dispatch table by means of a variable. Its -- initialization is done later by means of an assignment. This is -- required to generate its External_Tag. --- 3973,3986 ---- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); ! Set_Is_Statically_Allocated (DT, Is_Library_Level_Tagged_Type (Typ)); ! Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ)); ! Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ)); ! Set_Is_Statically_Allocated (Predef_Prims, ! Is_Library_Level_Tagged_Type (Typ)); -- In case of locally defined tagged type we declare the object ! -- containing the dispatch table by means of a variable. Its -- initialization is done later by means of an assignment. This is -- required to generate its External_Tag. *************** package body Exp_Disp is *** 3850,3855 **** --- 4081,4103 ---- New_Occurrence_Of (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => + Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))), + Constant_Present => True, + Object_Definition => New_Reference_To + (RTE (RE_Address), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Predef_Prims), Loc)), + Attribute_Name => Name_Address))); end if; end if; *************** package body Exp_Disp is *** 3890,3895 **** --- 4138,4144 ---- -- HT_Link => HT_Link'Address, -- Transportable => <>, -- RC_Offset => <>, + -- [ Size_Func => Size_Prim'Access ] -- [ Interfaces_Table => <> ] -- [ SSD => SSD_Table'Address ] -- Tags_Table => (0 => null, *************** package body Exp_Disp is *** 4049,4071 **** -- External tag of a library-level tagged type: Check for a definition -- of External_Tag. The clause is considered only if it applies to this -- specific tagged type, as opposed to one of its ancestors. else declare ! Def : constant Node_Id := Get_Attribute_Definition_Clause (Typ, ! Attribute_External_Tag); Old_Val : String_Id; New_Val : String_Id; E : Entity_Id; begin if not Present (Def) ! or else Entity (Name (Def)) /= Typ then New_Node := Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Exname, Loc), Attribute_Name => Name_Address)); else Old_Val := Strval (Expr_Value_S (Expression (Def))); --- 4298,4325 ---- -- External tag of a library-level tagged type: Check for a definition -- of External_Tag. The clause is considered only if it applies to this -- specific tagged type, as opposed to one of its ancestors. + -- If the type is an unconstrained type extension, we are building the + -- dispatch table of its anonymous base type, so the external tag, if + -- any was specified, must be retrieved from the first subtype. else declare ! Def : constant Node_Id := Get_Attribute_Definition_Clause ! (First_Subtype (Typ), ! Attribute_External_Tag); ! Old_Val : String_Id; New_Val : String_Id; E : Entity_Id; begin if not Present (Def) ! or else Entity (Name (Def)) /= First_Subtype (Typ) then New_Node := Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Exname, Loc), Attribute_Name => Name_Address)); else Old_Val := Strval (Expr_Value_S (Expression (Def))); *************** package body Exp_Disp is *** 4165,4179 **** declare RC_Offset_Node : Node_Id; - Parent_Typ : Entity_Id; begin - if Present (Full_View (Etype (Typ))) then - Parent_Typ := Full_View (Etype (Typ)); - else - Parent_Typ := Etype (Typ); - end if; - if not Has_Controlled_Component (Typ) then RC_Offset_Node := Make_Integer_Literal (Loc, 0); --- 4419,4426 ---- *************** package body Exp_Disp is *** 4213,4225 **** Append_To (TSD_Aggr_List, RC_Offset_Node); end; -- Interfaces_Table (required for AI-405) if RTE_Record_Component_Available (RE_Interfaces_Table) then -- Count the number of interface types implemented by Typ ! Collect_Abstract_Interfaces (Typ, Typ_Ifaces); AI := First_Elmt (Typ_Ifaces); while Present (AI) loop --- 4460,4518 ---- Append_To (TSD_Aggr_List, RC_Offset_Node); end; + -- Size_Func + + if RTE_Record_Component_Available (RE_Size_Func) then + if not Building_Static_DT (Typ) + or else Is_Interface (Typ) + then + Append_To (TSD_Aggr_List, + Unchecked_Convert_To (RTE (RE_Size_Ptr), + New_Reference_To (RTE (RE_Null_Address), Loc))); + + else + declare + Prim_Elmt : Elmt_Id; + Prim : Entity_Id; + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Chars (Prim) = Name_uSize then + while Present (Alias (Prim)) loop + Prim := Alias (Prim); + end loop; + + if Is_Abstract_Subprogram (Prim) then + Append_To (TSD_Aggr_List, + Unchecked_Convert_To (RTE (RE_Size_Ptr), + New_Reference_To (RTE (RE_Null_Address), Loc))); + else + Append_To (TSD_Aggr_List, + Unchecked_Convert_To (RTE (RE_Size_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Unrestricted_Access))); + end if; + + exit; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + end if; + end if; + -- Interfaces_Table (required for AI-405) if RTE_Record_Component_Available (RE_Interfaces_Table) then -- Count the number of interface types implemented by Typ ! Collect_Interfaces (Typ, Typ_Ifaces); AI := First_Elmt (Typ_Ifaces); while Present (AI) loop *************** package body Exp_Disp is *** 4241,4267 **** begin AI := First_Elmt (Typ_Ifaces); while Present (AI) loop ! if Is_Parent (Node (AI), Typ) then Sec_DT_Tag := New_Reference_To (DT_Ptr, Loc); else ! Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); pragma Assert (Has_Thunks (Node (Elmt))); while Ekind (Node (Elmt)) = E_Constant and then not ! Is_Parent (Node (AI), Related_Type (Node (Elmt))) loop pragma Assert (Has_Thunks (Node (Elmt))); Next_Elmt (Elmt); pragma Assert (not Has_Thunks (Node (Elmt))); Next_Elmt (Elmt); end loop; pragma Assert (Ekind (Node (Elmt)) = E_Constant ! and then not Has_Thunks (Node (Next_Elmt (Elmt)))); Sec_DT_Tag := ! New_Reference_To (Node (Next_Elmt (Elmt)), Loc); end if; Append_To (TSD_Ifaces_List, --- 4534,4568 ---- begin AI := First_Elmt (Typ_Ifaces); while Present (AI) loop ! if Is_Ancestor (Node (AI), Typ) then Sec_DT_Tag := New_Reference_To (DT_Ptr, Loc); else ! Elmt := ! Next_Elmt ! (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); pragma Assert (Has_Thunks (Node (Elmt))); while Ekind (Node (Elmt)) = E_Constant and then not ! Is_Ancestor (Node (AI), Related_Type (Node (Elmt))) loop pragma Assert (Has_Thunks (Node (Elmt))); Next_Elmt (Elmt); + pragma Assert (Has_Thunks (Node (Elmt))); + Next_Elmt (Elmt); + pragma Assert (not Has_Thunks (Node (Elmt))); + Next_Elmt (Elmt); pragma Assert (not Has_Thunks (Node (Elmt))); Next_Elmt (Elmt); end loop; pragma Assert (Ekind (Node (Elmt)) = E_Constant ! and then not ! Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt))))); Sec_DT_Tag := ! New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))), ! Loc); end if; Append_To (TSD_Ifaces_List, *************** package body Exp_Disp is *** 4298,4304 **** Name_ITable := New_External_Name (Tname, 'I'); ITable := Make_Defining_Identifier (Loc, Name_ITable); ! Set_Is_Statically_Allocated (ITable); -- The table of interfaces is not constant; its slots are -- filled at run-time by the IP routine using attribute --- 4599,4606 ---- Name_ITable := New_External_Name (Tname, 'I'); ITable := Make_Defining_Identifier (Loc, Name_ITable); ! Set_Is_Statically_Allocated (ITable, ! Is_Library_Level_Tagged_Type (Typ)); -- The table of interfaces is not constant; its slots are -- filled at run-time by the IP routine using attribute *************** package body Exp_Disp is *** 4354,4360 **** if Ada_Version >= Ada_05 and then Has_DT (Typ) and then Is_Concurrent_Record_Type (Typ) ! and then Has_Abstract_Interfaces (Typ) and then Nb_Prim > 0 and then not Is_Abstract_Type (Typ) and then not Is_Controlled (Typ) --- 4656,4662 ---- if Ada_Version >= Ada_05 and then Has_DT (Typ) and then Is_Concurrent_Record_Type (Typ) ! and then Has_Interfaces (Typ) and then Nb_Prim > 0 and then not Is_Abstract_Type (Typ) and then not Is_Controlled (Typ) *************** package body Exp_Disp is *** 4398,4431 **** -- Initialize the table of ancestor tags. In case of interface types -- this table is not needed. ! declare ! Current_Typ : Entity_Id; ! Parent_Typ : Entity_Id; ! Pos : Nat; ! begin ! TSD_Tags_List := New_List; ! -- If we are not statically allocating the dispatch table then we ! -- must fill position 0 with null because we still have not ! -- generated the tag of Typ. ! if not Building_Static_DT (Typ) ! or else Is_Interface (Typ) ! then ! Append_To (TSD_Tags_List, ! Unchecked_Convert_To (RTE (RE_Tag), ! New_Reference_To (RTE (RE_Null_Address), Loc))); ! -- Otherwise we can safely reference the tag ! else ! Append_To (TSD_Tags_List, ! New_Reference_To (DT_Ptr, Loc)); ! end if; ! -- Fill the rest of the table with the tags of the ancestors Pos := 1; Current_Typ := Typ; --- 4700,4733 ---- -- Initialize the table of ancestor tags. In case of interface types -- this table is not needed. ! TSD_Tags_List := New_List; ! -- If we are not statically allocating the dispatch table then we must ! -- fill position 0 with null because we still have not generated the ! -- tag of Typ. ! if not Building_Static_DT (Typ) ! or else Is_Interface (Typ) ! then ! Append_To (TSD_Tags_List, ! Unchecked_Convert_To (RTE (RE_Tag), ! New_Reference_To (RTE (RE_Null_Address), Loc))); ! -- Otherwise we can safely reference the tag ! else ! Append_To (TSD_Tags_List, ! New_Reference_To (DT_Ptr, Loc)); ! end if; ! -- Fill the rest of the table with the tags of the ancestors ! declare ! Current_Typ : Entity_Id; ! Parent_Typ : Entity_Id; ! Pos : Nat; + begin Pos := 1; Current_Typ := Typ; *************** package body Exp_Disp is *** 4612,4617 **** --- 4914,4920 ---- declare Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; + Decl : Node_Id; E : Entity_Id; begin *************** package body Exp_Disp is *** 4645,4669 **** for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim_Table (J), Loc), ! Attribute_Name => Name_Address); else ! New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, Aliased_Present => True, Constant_Present => Building_Static_DT (Typ), ! Object_Definition => ! New_Reference_To (RTE (RE_Address_Array), Loc), ! Expression => Make_Aggregate (Loc, ! Expressions => Prim_Ops_Aggr_List))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, --- 4948,4990 ---- for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := ! Unchecked_Convert_To (RTE (RE_Prim_Ptr), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim_Table (J), Loc), ! Attribute_Name => Name_Unrestricted_Access)); else ! New_Node := Make_Null (Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; + New_Node := + Make_Aggregate (Loc, + Expressions => Prim_Ops_Aggr_List); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')), + Subtype_Indication => + New_Reference_To (RTE (RE_Address_Array), Loc)); + + Append_To (Result, Decl); + Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, Aliased_Present => True, Constant_Present => Building_Static_DT (Typ), ! Object_Definition => New_Reference_To ! (Defining_Identifier (Decl), Loc), ! Expression => New_Node)); ! ! -- Remember aggregates initializing dispatch tables ! ! Append_Elmt (New_Node, DT_Aggr); Append_To (Result, Make_Attribute_Definition_Clause (Loc, *************** package body Exp_Disp is *** 4716,4724 **** -- Offset_To_Top ! if RTE_Record_Component_Available (RE_Offset_To_Top) then ! Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); ! end if; -- Typeinfo --- 5037,5043 ---- -- Offset_To_Top ! Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); -- Typeinfo *************** package body Exp_Disp is *** 4732,4744 **** Prim_Ops_Aggr_List := New_List; if Nb_Prim = 0 then ! Append_To (Prim_Ops_Aggr_List, ! New_Reference_To (RTE (RE_Null_Address), Loc)); elsif not Building_Static_DT (Typ) then for J in 1 .. Nb_Prim loop ! Append_To (Prim_Ops_Aggr_List, ! New_Reference_To (RTE (RE_Null_Address), Loc)); end loop; else --- 5051,5061 ---- Prim_Ops_Aggr_List := New_List; if Nb_Prim = 0 then ! Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); elsif not Building_Static_DT (Typ) then for J in 1 .. Nb_Prim loop ! Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); end loop; else *************** package body Exp_Disp is *** 4756,4762 **** Prim := Node (Prim_Elmt); if Is_Imported (Prim) ! or else Present (Abstract_Interface_Alias (Prim)) or else Is_Predefined_Dispatching_Operation (Prim) then null; --- 5073,5079 ---- Prim := Node (Prim_Elmt); if Is_Imported (Prim) ! or else Present (Interface_Alias (Prim)) or else Is_Predefined_Dispatching_Operation (Prim) then null; *************** package body Exp_Disp is *** 4772,4778 **** if not Is_Predefined_Dispatching_Operation (E) and then not Is_Abstract_Subprogram (E) ! and then not Present (Abstract_Interface_Alias (E)) then pragma Assert (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); --- 5089,5095 ---- if not Is_Predefined_Dispatching_Operation (E) and then not Is_Abstract_Subprogram (E) ! and then not Present (Interface_Alias (E)) then pragma Assert (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); *************** package body Exp_Disp is *** 4787,4797 **** for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim_Table (J), Loc), ! Attribute_Name => Name_Address); else ! New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); --- 5104,5115 ---- for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := ! Unchecked_Convert_To (RTE (RE_Prim_Ptr), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim_Table (J), Loc), ! Attribute_Name => Name_Unrestricted_Access)); else ! New_Node := Make_Null (Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); *************** package body Exp_Disp is *** 4799,4807 **** end; end if; ! Append_To (DT_Aggr_List, Make_Aggregate (Loc, ! Expressions => Prim_Ops_Aggr_List)); -- In case of locally defined tagged types we have already declared -- and uninitialized object for the dispatch table, which is now --- 5117,5131 ---- end; end if; ! New_Node := Make_Aggregate (Loc, ! Expressions => Prim_Ops_Aggr_List); ! ! Append_To (DT_Aggr_List, New_Node); ! ! -- Remember aggregates initializing dispatch tables ! ! Append_Elmt (New_Node, DT_Aggr); -- In case of locally defined tagged types we have already declared -- and uninitialized object for the dispatch table, which is now *************** package body Exp_Disp is *** 4871,4953 **** (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); end if; if Building_Static_DT (Typ) then null; -- If the ancestor is a CPP_Class type we inherit the dispatch tables -- in the init proc, and we don't need to fill them in here. ! elsif Is_CPP_Class (Etype (Typ)) then null; ! -- Otherwise we fill in the dispatch tables here else ! if Typ = Etype (Typ) ! or else Is_CPP_Class (Etype (Typ)) ! or else Is_Interface (Typ) ! then ! Null_Parent_Tag := True; ! ! Old_Tag1 := ! Unchecked_Convert_To (RTE (RE_Tag), ! Make_Integer_Literal (Loc, 0)); ! Old_Tag2 := ! Unchecked_Convert_To (RTE (RE_Tag), ! Make_Integer_Literal (Loc, 0)); ! ! else ! Old_Tag1 := ! New_Reference_To ! (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); ! Old_Tag2 := ! New_Reference_To ! (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); ! end if; ! ! if Typ /= Etype (Typ) and then not Is_Interface (Typ) and then not Restriction_Active (No_Dispatching_Calls) then -- Inherit the dispatch table ! if not Is_Interface (Etype (Typ)) then ! if not Null_Parent_Tag then ! declare ! Nb_Prims : constant Int := ! UI_To_Int (DT_Entry_Count ! (First_Tag_Component (Etype (Typ)))); ! begin ! Append_To (Elab_Code, ! Build_Inherit_Predefined_Prims (Loc, ! Old_Tag_Node => Old_Tag1, ! New_Tag_Node => ! New_Reference_To (DT_Ptr, Loc))); ! if Nb_Prims /= 0 then ! Append_To (Elab_Code, ! Build_Inherit_Prims (Loc, ! Typ => Typ, ! Old_Tag_Node => Old_Tag2, ! New_Tag_Node => New_Reference_To (DT_Ptr, Loc), ! Num_Prims => Nb_Prims)); ! end if; ! end; ! end if; end if; -- Inherit the secondary dispatch tables of the ancestor ! if not Is_CPP_Class (Etype (Typ)) then declare Sec_DT_Ancestor : Elmt_Id := Next_Elmt (First_Elmt ! (Access_Disp_Table (Etype (Typ)))); Sec_DT_Typ : Elmt_Id := Next_Elmt ! (First_Elmt ! (Access_Disp_Table (Typ))); procedure Copy_Secondary_DTs (Typ : Entity_Id); -- Local procedure required to climb through the ancestors --- 5195,5278 ---- (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); end if; + -- Inherit the dispatch tables of the parent + + -- There is no need to inherit anything from the parent when building + -- static dispatch tables because the whole dispatch table (including + -- inherited primitives) has been already built. + if Building_Static_DT (Typ) then null; -- If the ancestor is a CPP_Class type we inherit the dispatch tables -- in the init proc, and we don't need to fill them in here. ! elsif Is_CPP_Class (Parent_Typ) then null; ! -- Otherwise we fill in the dispatch tables here else ! if Typ /= Parent_Typ and then not Is_Interface (Typ) and then not Restriction_Active (No_Dispatching_Calls) then -- Inherit the dispatch table ! if not Is_Interface (Typ) ! and then not Is_Interface (Parent_Typ) ! and then not Is_CPP_Class (Parent_Typ) ! then ! declare ! Nb_Prims : constant Int := ! UI_To_Int (DT_Entry_Count ! (First_Tag_Component (Parent_Typ))); ! begin ! Append_To (Elab_Code, ! Build_Inherit_Predefined_Prims (Loc, ! Old_Tag_Node => ! New_Reference_To ! (Node ! (Next_Elmt ! (First_Elmt ! (Access_Disp_Table (Parent_Typ)))), Loc), ! New_Tag_Node => ! New_Reference_To ! (Node ! (Next_Elmt ! (First_Elmt ! (Access_Disp_Table (Typ)))), Loc))); ! ! if Nb_Prims /= 0 then ! Append_To (Elab_Code, ! Build_Inherit_Prims (Loc, ! Typ => Typ, ! Old_Tag_Node => ! New_Reference_To ! (Node ! (First_Elmt ! (Access_Disp_Table (Parent_Typ))), Loc), ! New_Tag_Node => New_Reference_To (DT_Ptr, Loc), ! Num_Prims => Nb_Prims)); ! end if; ! end; end if; -- Inherit the secondary dispatch tables of the ancestor ! if not Is_CPP_Class (Parent_Typ) then declare Sec_DT_Ancestor : Elmt_Id := Next_Elmt + (Next_Elmt (First_Elmt ! (Access_Disp_Table (Parent_Typ)))); Sec_DT_Typ : Elmt_Id := Next_Elmt ! (Next_Elmt ! (First_Elmt ! (Access_Disp_Table (Typ)))); procedure Copy_Secondary_DTs (Typ : Entity_Id); -- Local procedure required to climb through the ancestors *************** package body Exp_Disp is *** 4974,4984 **** Copy_Secondary_DTs (Etype (Typ)); end if; ! if Present (Abstract_Interfaces (Typ)) ! and then not Is_Empty_Elmt_List ! (Abstract_Interfaces (Typ)) then ! Iface := First_Elmt (Abstract_Interfaces (Typ)); E := First_Entity (Typ); while Present (E) and then Present (Node (Sec_DT_Ancestor)) --- 5299,5308 ---- Copy_Secondary_DTs (Etype (Typ)); end if; ! if Present (Interfaces (Typ)) ! and then not Is_Empty_Elmt_List (Interfaces (Typ)) then ! Iface := First_Elmt (Interfaces (Typ)); E := First_Entity (Typ); while Present (E) and then Present (Node (Sec_DT_Ancestor)) *************** package body Exp_Disp is *** 4998,5009 **** Build_Inherit_Predefined_Prims (Loc, Old_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), ! New_Reference_To ! (Node (Sec_DT_Ancestor), Loc)), New_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To ! (Node (Sec_DT_Typ), Loc)))); if Num_Prims /= 0 then Append_To (Elab_Code, --- 5322,5336 ---- Build_Inherit_Predefined_Prims (Loc, Old_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), ! New_Reference_To ! (Node ! (Next_Elmt (Sec_DT_Ancestor)), ! Loc)), New_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To ! (Node (Next_Elmt (Sec_DT_Typ)), ! Loc)))); if Num_Prims /= 0 then Append_To (Elab_Code, *************** package body Exp_Disp is *** 5027,5032 **** --- 5354,5365 ---- Next_Elmt (Sec_DT_Ancestor); Next_Elmt (Sec_DT_Typ); + -- Skip the secondary dispatch table of + -- predefined primitives + + Next_Elmt (Sec_DT_Ancestor); + Next_Elmt (Sec_DT_Typ); + if not Is_Interface (Etype (Typ)) then -- Inherit second secondary dispatch table *************** package body Exp_Disp is *** 5036,5046 **** Old_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To ! (Node (Sec_DT_Ancestor), Loc)), New_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To ! (Node (Sec_DT_Typ), Loc)))); if Num_Prims /= 0 then Append_To (Elab_Code, --- 5369,5382 ---- Old_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To ! (Node ! (Next_Elmt (Sec_DT_Ancestor)), ! Loc)), New_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To ! (Node (Next_Elmt (Sec_DT_Typ)), ! Loc)))); if Num_Prims /= 0 then Append_To (Elab_Code, *************** package body Exp_Disp is *** 5064,5069 **** --- 5400,5412 ---- Next_Elmt (Sec_DT_Ancestor); Next_Elmt (Sec_DT_Typ); + + -- Skip the secondary dispatch table of + -- predefined primitives + + Next_Elmt (Sec_DT_Ancestor); + Next_Elmt (Sec_DT_Typ); + Next_Elmt (Iface); end if; *************** package body Exp_Disp is *** 5097,5115 **** -- Skip this action in the following cases: -- 1) if Register_Tag is not available. -- 2) in No_Run_Time mode. ! -- 3) if Typ is an abstract interface type (the secondary tags will ! -- be registered later in types implementing this interface type). ! -- 4) if Typ is not defined at the library level (this is required -- to avoid adding concurrency control to the hash table used -- by the run-time to register the tags). - -- Generate: - -- if No_Reg then - -- [ Elab_Code ] - -- [ Register_Tag (Dt_Ptr); ] - -- No_Reg := False; - -- end if; - if not No_Run_Time_Mode and then Is_Library_Level_Entity (Typ) and then RTE_Available (RE_Register_Tag) --- 5440,5449 ---- -- Skip this action in the following cases: -- 1) if Register_Tag is not available. -- 2) in No_Run_Time mode. ! -- 3) if Typ is not defined at the library level (this is required -- to avoid adding concurrency control to the hash table used -- by the run-time to register the tags). if not No_Run_Time_Mode and then Is_Library_Level_Entity (Typ) and then RTE_Available (RE_Register_Tag) *************** package body Exp_Disp is *** 5121,5135 **** New_List (New_Reference_To (DT_Ptr, Loc)))); end if; ! Append_To (Elab_Code, ! Make_Assignment_Statement (Loc, ! Name => New_Reference_To (No_Reg, Loc), ! Expression => New_Reference_To (Standard_False, Loc))); ! ! Append_To (Result, ! Make_Implicit_If_Statement (Typ, ! Condition => New_Reference_To (No_Reg, Loc), ! Then_Statements => Elab_Code)); -- Populate the two auxiliary tables used for dispatching -- asynchronous, conditional and timed selects for synchronized --- 5455,5463 ---- New_List (New_Reference_To (DT_Ptr, Loc)))); end if; ! if not Is_Empty_List (Elab_Code) then ! Append_List_To (Result, Elab_Code); ! end if; -- Populate the two auxiliary tables used for dispatching -- asynchronous, conditional and timed selects for synchronized *************** package body Exp_Disp is *** 5137,5151 **** if Ada_Version >= Ada_05 and then Is_Concurrent_Record_Type (Typ) ! and then Has_Abstract_Interfaces (Typ) then Append_List_To (Result, Make_Select_Specific_Data_Table (Typ)); end if; Analyze_List (Result, Suppress => All_Checks); Set_Has_Dispatch_Table (Typ); return Result; end Make_DT; --- 5465,5519 ---- if Ada_Version >= Ada_05 and then Is_Concurrent_Record_Type (Typ) ! and then Has_Interfaces (Typ) then Append_List_To (Result, Make_Select_Specific_Data_Table (Typ)); end if; + -- Remember entities containing dispatch tables + + Append_Elmt (Predef_Prims, DT_Decl); + Append_Elmt (DT, DT_Decl); + Analyze_List (Result, Suppress => All_Checks); Set_Has_Dispatch_Table (Typ); + -- Mark entities containing dispatch tables. Required by the + -- backend to handle them properly. + + if not Is_Interface (Typ) then + declare + Elmt : Elmt_Id; + + begin + -- Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have + -- the decoration required by the backend + + Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr)); + Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr)); + + -- Object declarations + + Elmt := First_Elmt (DT_Decl); + while Present (Elmt) loop + Set_Is_Dispatch_Table_Entity (Node (Elmt)); + pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype + or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype); + Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt))); + Next_Elmt (Elmt); + end loop; + + -- Aggregates initializing dispatch tables + + Elmt := First_Elmt (DT_Aggr); + while Present (Elmt) loop + Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt))); + Next_Elmt (Elmt); + end loop; + end; + end if; + return Result; end Make_DT; *************** package body Exp_Disp is *** 5252,5258 **** -- Look for primitive overriding an abstract interface subprogram ! if Present (Abstract_Interface_Alias (Prim)) and then not Examined (UI_To_Int (DT_Position (Alias (Prim)))) then Prim_Pos := DT_Position (Alias (Prim)); --- 5620,5626 ---- -- Look for primitive overriding an abstract interface subprogram ! if Present (Interface_Alias (Prim)) and then not Examined (UI_To_Int (DT_Position (Alias (Prim)))) then Prim_Pos := DT_Position (Alias (Prim)); *************** package body Exp_Disp is *** 5312,5351 **** --------------- function Make_Tags (Typ : Entity_Id) return List_Id is ! Loc : constant Source_Ptr := Sloc (Typ); ! Tname : constant Name_Id := Chars (Typ); ! Result : constant List_Id := New_List; ! AI_Tag_Comp : Elmt_Id; ! DT : Node_Id; ! DT_Constr_List : List_Id; ! DT_Ptr : Node_Id; ! Iface_DT_Ptr : Node_Id; ! Nb_Prim : Nat; ! Suffix_Index : Int; ! Typ_Name : Name_Id; ! Typ_Comps : Elist_Id; begin -- 1) Generate the primary and secondary tag entities -- Collect the components associated with secondary dispatch tables ! if Has_Abstract_Interfaces (Typ) then Collect_Interface_Components (Typ, Typ_Comps); end if; ! -- 1) Generate the primary tag entity DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P')); Set_Etype (DT_Ptr, RTE (RE_Tag)); -- Import the forward declaration of the Dispatch Table wrapper record -- (Make_DT will take care of its exportation) if Building_Static_DT (Typ) then ! DT := Make_Defining_Identifier (Loc, ! New_External_Name (Tname, 'T')); -- Generate: -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim); --- 5680,5730 ---- --------------- function Make_Tags (Typ : Entity_Id) return List_Id is ! Loc : constant Source_Ptr := Sloc (Typ); ! Tname : constant Name_Id := Chars (Typ); ! Result : constant List_Id := New_List; ! AI_Tag_Comp : Elmt_Id; ! DT : Node_Id; ! DT_Constr_List : List_Id; ! DT_Ptr : Node_Id; ! Predef_Prims_Ptr : Node_Id; ! Iface_DT_Ptr : Node_Id; ! Nb_Prim : Nat; ! Suffix_Index : Int; ! Typ_Name : Name_Id; ! Typ_Comps : Elist_Id; begin -- 1) Generate the primary and secondary tag entities -- Collect the components associated with secondary dispatch tables ! if Has_Interfaces (Typ) then Collect_Interface_Components (Typ, Typ_Comps); end if; ! -- 1) Generate the primary tag entities ! ! -- Primary dispatch table containing user-defined primitives DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P')); Set_Etype (DT_Ptr, RTE (RE_Tag)); + -- Primary dispatch table containing predefined primitives + + Predef_Prims_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Tname, 'Y')); + Set_Etype (Predef_Prims_Ptr, RTE (RE_Address)); + -- Import the forward declaration of the Dispatch Table wrapper record -- (Make_DT will take care of its exportation) if Building_Static_DT (Typ) then ! DT := ! Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Tname, 'T')); -- Generate: -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim); *************** package body Exp_Disp is *** 5371,5376 **** --- 5750,5756 ---- Set_Dispatch_Table_Wrapper (Typ, DT); if Has_DT (Typ) then + -- Calculate the number of primitives of the dispatch table and -- the size of the Type_Specific_Data record. *************** package body Exp_Disp is *** 5415,5420 **** --- 5795,5816 ---- (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Predef_Prims_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To + (RTE (RE_Address), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Predef_Prims), Loc)), + Attribute_Name => Name_Address))); + -- No dispatch table required else *************** package body Exp_Disp is *** 5450,5459 **** pragma Assert (No (Access_Disp_Table (Typ))); Set_Access_Disp_Table (Typ, New_Elmt_List); Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); -- 2) Generate the secondary tag entities ! if Has_Abstract_Interfaces (Typ) then Suffix_Index := 0; -- For each interface type we build an unique external name --- 5846,5856 ---- pragma Assert (No (Access_Disp_Table (Typ))); Set_Access_Disp_Table (Typ, New_Elmt_List); Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); + Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ)); -- 2) Generate the secondary tag entities ! if Has_Interfaces (Typ) then Suffix_Index := 0; -- For each interface type we build an unique external name *************** package body Exp_Disp is *** 5471,5476 **** --- 5868,5876 ---- Typ_Name := Name_Find; + -- Secondary dispatch table referencing thunks to user-defined + -- primitives covered by this interface. + Iface_DT_Ptr := Make_Defining_Identifier (Loc, Chars => New_External_Name (Typ_Name, 'P')); *************** package body Exp_Disp is *** 5478,5496 **** Set_Ekind (Iface_DT_Ptr, E_Constant); Set_Is_Tag (Iface_DT_Ptr); Set_Has_Thunks (Iface_DT_Ptr); ! Set_Is_Statically_Allocated (Iface_DT_Ptr); Set_Is_True_Constant (Iface_DT_Ptr); Set_Related_Type (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); Iface_DT_Ptr := Make_Defining_Identifier (Loc, Chars => New_External_Name (Typ_Name, 'D')); Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); Set_Ekind (Iface_DT_Ptr, E_Constant); Set_Is_Tag (Iface_DT_Ptr); ! Set_Is_Statically_Allocated (Iface_DT_Ptr); Set_Is_True_Constant (Iface_DT_Ptr); Set_Related_Type (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); --- 5878,5933 ---- Set_Ekind (Iface_DT_Ptr, E_Constant); Set_Is_Tag (Iface_DT_Ptr); Set_Has_Thunks (Iface_DT_Ptr); ! Set_Is_Statically_Allocated (Iface_DT_Ptr, ! Is_Library_Level_Tagged_Type (Typ)); ! Set_Is_True_Constant (Iface_DT_Ptr); ! Set_Related_Type ! (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); ! Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); ! ! -- Secondary dispatch table referencing thunks to predefined ! -- primitives. ! ! Iface_DT_Ptr := ! Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Typ_Name, 'Y')); ! Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); ! Set_Ekind (Iface_DT_Ptr, E_Constant); ! Set_Is_Tag (Iface_DT_Ptr); ! Set_Has_Thunks (Iface_DT_Ptr); ! Set_Is_Statically_Allocated (Iface_DT_Ptr, ! Is_Library_Level_Tagged_Type (Typ)); Set_Is_True_Constant (Iface_DT_Ptr); Set_Related_Type (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + -- Secondary dispatch table referencing user-defined primitives + -- covered by this interface. + Iface_DT_Ptr := Make_Defining_Identifier (Loc, Chars => New_External_Name (Typ_Name, 'D')); Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); Set_Ekind (Iface_DT_Ptr, E_Constant); Set_Is_Tag (Iface_DT_Ptr); ! Set_Is_Statically_Allocated (Iface_DT_Ptr, ! Is_Library_Level_Tagged_Type (Typ)); ! Set_Is_True_Constant (Iface_DT_Ptr); ! Set_Related_Type ! (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); ! Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); ! ! -- Secondary dispatch table referencing predefined primitives ! ! Iface_DT_Ptr := ! Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Typ_Name, 'Z')); ! Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); ! Set_Ekind (Iface_DT_Ptr, E_Constant); ! Set_Is_Tag (Iface_DT_Ptr); ! Set_Is_Statically_Allocated (Iface_DT_Ptr, ! Is_Library_Level_Tagged_Type (Typ)); Set_Is_True_Constant (Iface_DT_Ptr); Set_Related_Type (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); *************** package body Exp_Disp is *** 5505,5511 **** -- expand dispatching calls through the primary dispatch table. -- Generate: ! -- type Typ_DT is array (1 .. Nb_Prims) of Address; -- type Typ_DT_Acc is access Typ_DT; declare --- 5942,5948 ---- -- expand dispatching calls through the primary dispatch table. -- Generate: ! -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr; -- type Typ_DT_Acc is access Typ_DT; declare *************** package body Exp_Disp is *** 5533,5539 **** Component_Definition => Make_Component_Definition (Loc, Subtype_Indication => ! New_Reference_To (RTE (RE_Address), Loc))))); Append_To (Result, Make_Full_Type_Declaration (Loc, --- 5970,5976 ---- Component_Definition => Make_Component_Definition (Loc, Subtype_Indication => ! New_Reference_To (RTE (RE_Prim_Ptr), Loc))))); Append_To (Result, Make_Full_Type_Declaration (Loc, *************** package body Exp_Disp is *** 5552,5557 **** --- 5989,5999 ---- Analyze_List (Result); Set_Suppress_Init_Proc (Base_Type (DT_Prims)); + + -- Mark entity of dispatch table. Required by the backend to handle + -- the properly. + + Set_Is_Dispatch_Table_Entity (DT_Prims); end; Set_Ekind (DT_Ptr, E_Constant); *************** package body Exp_Disp is *** 5571,5579 **** begin -- The scope must be a package ! if Ekind (Scop) /= E_Package ! and then Ekind (Scop) /= E_Generic_Package ! then return False; end if; --- 6013,6019 ---- begin -- The scope must be a package ! if not Is_Package_Or_Generic_Package (Scop) then return False; end if; *************** package body Exp_Disp is *** 5614,5619 **** --- 6054,6066 ---- Full_Typ := Corresponding_Concurrent_Type (Typ); end if; + -- When a private tagged type is completed by a concurrent type, + -- retrieve the full view. + + if Is_Private_Type (Full_Typ) then + Full_Typ := Full_View (Full_Typ); + end if; + if Ekind (Prim_Op) = E_Function then -- Protected function *************** package body Exp_Disp is *** 5691,5699 **** L : List_Id; Pos : Uint; Tag : Entity_Id; Thunk_Id : Entity_Id; Thunk_Code : Node_Id; - Typ : Entity_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); --- 6138,6146 ---- L : List_Id; Pos : Uint; Tag : Entity_Id; + Tag_Typ : Entity_Id; Thunk_Id : Entity_Id; Thunk_Code : Node_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); *************** package body Exp_Disp is *** 5702,5735 **** return; end if; ! if not Present (Abstract_Interface_Alias (Prim)) then ! Typ := Scope (DTC_Entity (Prim)); ! DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); ! Pos := DT_Position (Prim); ! Tag := First_Tag_Component (Typ); if Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim) then Insert_After (Ins_Nod, Build_Set_Predefined_Prim_Op_Address (Loc, Tag_Node => New_Reference_To (DT_Ptr, Loc), Position => Pos, ! Address_Node => Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim, Loc), ! Attribute_Name => Name_Address))); else pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); Insert_After (Ins_Nod, Build_Set_Prim_Op_Address (Loc, ! Typ => Typ, Tag_Node => New_Reference_To (DT_Ptr, Loc), Position => Pos, ! Address_Node => Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim, Loc), ! Attribute_Name => Name_Address))); end if; -- Ada 2005 (AI-251): Primitive associated with an interface type --- 6149,6201 ---- return; end if; ! if not Present (Interface_Alias (Prim)) then ! Tag_Typ := Scope (DTC_Entity (Prim)); ! Pos := DT_Position (Prim); ! Tag := First_Tag_Component (Tag_Typ); if Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim) then + DT_Ptr := + Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ)))); + Insert_After (Ins_Nod, Build_Set_Predefined_Prim_Op_Address (Loc, Tag_Node => New_Reference_To (DT_Ptr, Loc), Position => Pos, ! Address_Node => ! Unchecked_Convert_To (RTE (RE_Prim_Ptr), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim, Loc), ! Attribute_Name => Name_Unrestricted_Access)))); ! ! -- Register copy of the pointer to the 'size primitive in the TSD. ! ! if Chars (Prim) = Name_uSize ! and then RTE_Record_Component_Available (RE_Size_Func) ! then ! DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); ! Insert_After (Ins_Nod, ! Build_Set_Size_Function (Loc, ! Tag_Node => New_Reference_To (DT_Ptr, Loc), ! Size_Func => Prim)); ! end if; else pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); Insert_After (Ins_Nod, Build_Set_Prim_Op_Address (Loc, ! Typ => Tag_Typ, Tag_Node => New_Reference_To (DT_Ptr, Loc), Position => Pos, ! Address_Node => ! Unchecked_Convert_To (RTE (RE_Prim_Ptr), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Prim, Loc), ! Attribute_Name => Name_Unrestricted_Access)))); end if; -- Ada 2005 (AI-251): Primitive associated with an interface type *************** package body Exp_Disp is *** 5739,5752 **** -- else to do here. else ! Typ := Find_Dispatching_Type (Alias (Prim)); ! Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim)); pragma Assert (Is_Interface (Iface_Typ)); Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); ! if not Is_Parent (Iface_Typ, Typ) and then Present (Thunk_Code) then -- Comment needed on why checks are suppressed. This is not just --- 6205,6218 ---- -- else to do here. else ! Tag_Typ := Find_Dispatching_Type (Alias (Prim)); ! Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim)); pragma Assert (Is_Interface (Iface_Typ)); Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); ! if not Is_Ancestor (Iface_Typ, Tag_Typ) and then Present (Thunk_Code) then -- Comment needed on why checks are suppressed. This is not just *************** package body Exp_Disp is *** 5759,5797 **** -- the secondary dispatch table of Prim's controlling type with -- Thunk_Id's address. ! Iface_DT_Elmt := Find_Interface_ADT (Typ, Iface_Typ); Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (Has_Thunks (Iface_DT_Ptr)); ! Iface_Prim := Abstract_Interface_Alias (Prim); ! Pos := DT_Position (Iface_Prim); ! Tag := First_Tag_Component (Iface_Typ); ! L := New_List; if Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim) then Append_To (L, Build_Set_Predefined_Prim_Op_Address (Loc, ! Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Position => Pos, Address_Node => ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Thunk_Id, Loc), ! Attribute_Name => Name_Address))); Next_Elmt (Iface_DT_Elmt); Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (not Has_Thunks (Iface_DT_Ptr)); Append_To (L, Build_Set_Predefined_Prim_Op_Address (Loc, ! Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Position => Pos, Address_Node => ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Alias (Prim), Loc), ! Attribute_Name => Name_Address))); Insert_Actions_After (Ins_Nod, L); --- 6225,6268 ---- -- the secondary dispatch table of Prim's controlling type with -- Thunk_Id's address. ! Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ); Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (Has_Thunks (Iface_DT_Ptr)); ! Iface_Prim := Interface_Alias (Prim); ! Pos := DT_Position (Iface_Prim); ! Tag := First_Tag_Component (Iface_Typ); ! L := New_List; if Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim) then Append_To (L, Build_Set_Predefined_Prim_Op_Address (Loc, ! Tag_Node => ! New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc), Position => Pos, Address_Node => ! Unchecked_Convert_To (RTE (RE_Prim_Ptr), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Thunk_Id, Loc), ! Attribute_Name => Name_Unrestricted_Access)))); Next_Elmt (Iface_DT_Elmt); + Next_Elmt (Iface_DT_Elmt); Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (not Has_Thunks (Iface_DT_Ptr)); Append_To (L, Build_Set_Predefined_Prim_Op_Address (Loc, ! Tag_Node => ! New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc), Position => Pos, Address_Node => ! Unchecked_Convert_To (RTE (RE_Prim_Ptr), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Alias (Prim), Loc), ! Attribute_Name => Name_Unrestricted_Access)))); Insert_Actions_After (Ins_Nod, L); *************** package body Exp_Disp is *** 5804,5815 **** Typ => Iface_Typ, Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Position => Pos, ! Address_Node => Make_Attribute_Reference (Loc, ! Prefix => ! New_Reference_To (Thunk_Id, Loc), ! Attribute_Name => Name_Address))); Next_Elmt (Iface_DT_Elmt); Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (not Has_Thunks (Iface_DT_Ptr)); --- 6275,6288 ---- Typ => Iface_Typ, Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Position => Pos, ! Address_Node => ! Unchecked_Convert_To (RTE (RE_Prim_Ptr), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Thunk_Id, Loc), ! Attribute_Name => Name_Unrestricted_Access)))); Next_Elmt (Iface_DT_Elmt); + Next_Elmt (Iface_DT_Elmt); Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (not Has_Thunks (Iface_DT_Ptr)); *************** package body Exp_Disp is *** 5818,5827 **** Typ => Iface_Typ, Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Position => Pos, ! Address_Node => Make_Attribute_Reference (Loc, ! Prefix => ! New_Reference_To (Alias (Prim), Loc), ! Attribute_Name => Name_Address))); Insert_Actions_After (Ins_Nod, L); end if; --- 6291,6301 ---- Typ => Iface_Typ, Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Position => Pos, ! Address_Node => ! Unchecked_Convert_To (RTE (RE_Prim_Ptr), ! Make_Attribute_Reference (Loc, ! Prefix => New_Reference_To (Alias (Prim), Loc), ! Attribute_Name => Name_Unrestricted_Access)))); Insert_Actions_After (Ins_Nod, L); end if; *************** package body Exp_Disp is *** 5836,5842 **** procedure Set_All_DT_Position (Typ : Entity_Id) is procedure Validate_Position (Prim : Entity_Id); ! -- Check that the position assignated to Prim is completely safe -- (it has not been assigned to a previously defined primitive -- operation of Typ) --- 6310,6316 ---- procedure Set_All_DT_Position (Typ : Entity_Id) is procedure Validate_Position (Prim : Entity_Id); ! -- Check that the position assigned to Prim is completely safe -- (it has not been assigned to a previously defined primitive -- operation of Typ) *************** package body Exp_Disp is *** 5867,5873 **** -- Primitive operations covering abstract interfaces are -- allocated later ! elsif Present (Abstract_Interface_Alias (Op)) then null; -- Predefined dispatching operations are completely safe. They --- 6341,6347 ---- -- Primitive operations covering abstract interfaces are -- allocated later ! elsif Present (Interface_Alias (Op)) then null; -- Predefined dispatching operations are completely safe. They *************** package body Exp_Disp is *** 5947,5954 **** -- Start of processing for Set_All_DT_Position begin -- Set the DT_Position for each primitive operation. Perform some ! -- sanity checks to avoid to build completely inconsistant dispatch -- tables. -- First stage: Set the DTC entity of all the primitive operations --- 6421,6430 ---- -- Start of processing for Set_All_DT_Position begin + pragma Assert (Present (First_Tag_Component (Typ))); + -- Set the DT_Position for each primitive operation. Perform some ! -- sanity checks to avoid to build completely inconsistent dispatch -- tables. -- First stage: Set the DTC entity of all the primitive operations *************** package body Exp_Disp is *** 5972,5978 **** -- Clear any previous value of the DT_Position attribute. In this -- way we ensure that the final position of all the primitives is ! -- stablished by the following stages of this algorithm. Set_DT_Position (Prim, No_Uint); --- 6448,6454 ---- -- Clear any previous value of the DT_Position attribute. In this -- way we ensure that the final position of all the primitives is ! -- established by the following stages of this algorithm. Set_DT_Position (Prim, No_Uint); *************** package body Exp_Disp is *** 5980,5987 **** end loop; declare ! Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean ! := (others => False); E : Entity_Id; procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id); --- 6456,6464 ---- end loop; declare ! Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean := ! (others => False); ! E : Entity_Id; procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id); *************** package body Exp_Disp is *** 6101,6117 **** -- Overriding primitives of ancestor abstract interfaces ! elsif Present (Abstract_Interface_Alias (Prim)) ! and then Is_Parent ! (Find_Dispatching_Type ! (Abstract_Interface_Alias (Prim)), ! Typ) then pragma Assert (DT_Position (Prim) = No_Uint ! and then Present (DTC_Entity ! (Abstract_Interface_Alias (Prim)))); ! E := Abstract_Interface_Alias (Prim); Set_DT_Position (Prim, DT_Position (E)); pragma Assert --- 6578,6591 ---- -- Overriding primitives of ancestor abstract interfaces ! elsif Present (Interface_Alias (Prim)) ! and then Is_Ancestor ! (Find_Dispatching_Type (Interface_Alias (Prim)), Typ) then pragma Assert (DT_Position (Prim) = No_Uint ! and then Present (DTC_Entity (Interface_Alias (Prim)))); ! E := Interface_Alias (Prim); Set_DT_Position (Prim, DT_Position (E)); pragma Assert *************** package body Exp_Disp is *** 6121,6133 **** Set_Fixed_Prim (UI_To_Int (DT_Position (Prim))); -- Overriding primitives must use the same entry as the ! -- overriden primitive. ! elsif not Present (Abstract_Interface_Alias (Prim)) and then Present (Alias (Prim)) and then Chars (Prim) = Chars (Alias (Prim)) and then Find_Dispatching_Type (Alias (Prim)) /= Typ ! and then Is_Parent (Find_Dispatching_Type (Alias (Prim)), Typ) and then Present (DTC_Entity (Alias (Prim))) then --- 6595,6607 ---- Set_Fixed_Prim (UI_To_Int (DT_Position (Prim))); -- Overriding primitives must use the same entry as the ! -- overridden primitive. ! elsif not Present (Interface_Alias (Prim)) and then Present (Alias (Prim)) and then Chars (Prim) = Chars (Alias (Prim)) and then Find_Dispatching_Type (Alias (Prim)) /= Typ ! and then Is_Ancestor (Find_Dispatching_Type (Alias (Prim)), Typ) and then Present (DTC_Entity (Alias (Prim))) then *************** package body Exp_Disp is *** 6157,6163 **** -- Primitives covering interface primitives are handled later ! elsif Present (Abstract_Interface_Alias (Prim)) then null; else --- 6631,6637 ---- -- Primitives covering interface primitives are handled later ! elsif Present (Interface_Alias (Prim)) then null; else *************** package body Exp_Disp is *** 6186,6201 **** Prim := Node (Prim_Elmt); if DT_Position (Prim) = No_Uint ! and then Present (Abstract_Interface_Alias (Prim)) then pragma Assert (Present (Alias (Prim)) and then Find_Dispatching_Type (Alias (Prim)) = Typ); -- Check if this entry will be placed in the primary DT ! if Is_Parent (Find_Dispatching_Type ! (Abstract_Interface_Alias (Prim)), ! Typ) then pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); Set_DT_Position (Prim, DT_Position (Alias (Prim))); --- 6660,6674 ---- Prim := Node (Prim_Elmt); if DT_Position (Prim) = No_Uint ! and then Present (Interface_Alias (Prim)) then pragma Assert (Present (Alias (Prim)) and then Find_Dispatching_Type (Alias (Prim)) = Typ); -- Check if this entry will be placed in the primary DT ! if Is_Ancestor ! (Find_Dispatching_Type (Interface_Alias (Prim)), Typ) then pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); Set_DT_Position (Prim, DT_Position (Alias (Prim))); *************** package body Exp_Disp is *** 6204,6212 **** else pragma Assert ! (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint); Set_DT_Position (Prim, ! DT_Position (Abstract_Interface_Alias (Prim))); end if; end if; --- 6677,6685 ---- else pragma Assert ! (DT_Position (Interface_Alias (Prim)) /= No_Uint); Set_DT_Position (Prim, ! DT_Position (Interface_Alias (Prim))); end if; end if; *************** package body Exp_Disp is *** 6231,6237 **** Prim := Node (Prim_Elmt); -- At this point all the primitives MUST have a position ! -- in the dispatch table if DT_Position (Prim) = No_Uint then raise Program_Error; --- 6704,6710 ---- Prim := Node (Prim_Elmt); -- At this point all the primitives MUST have a position ! -- in the dispatch table. if DT_Position (Prim) = No_Uint then raise Program_Error; *************** package body Exp_Disp is *** 6246,6252 **** DT_Length := UI_To_Int (DT_Position (Prim)); end if; ! -- Ensure that the asignated position to non-predefined -- dispatching operations in the dispatch table is correct. if not (Is_Predefined_Dispatching_Operation (Prim) --- 6719,6725 ---- DT_Length := UI_To_Int (DT_Position (Prim)); end if; ! -- Ensure that the assigned position to non-predefined -- dispatching operations in the dispatch table is correct. if not (Is_Predefined_Dispatching_Operation (Prim) *************** package body Exp_Disp is *** 6269,6282 **** -- point of declaration, but for inherited operations it must -- be done when building the dispatch table. ! -- Ada 2005 (AI-251): Hidden entities associated with abstract ! -- interface primitives are not taken into account because the ! -- check is done with the aliased primitive. if Is_Abstract_Type (Typ) and then Is_Abstract_Subprogram (Prim) and then Present (Alias (Prim)) ! and then not Present (Abstract_Interface_Alias (Prim)) and then Is_Derived_Type (Typ) and then In_Private_Part (Current_Scope) and then --- 6742,6757 ---- -- point of declaration, but for inherited operations it must -- be done when building the dispatch table. ! -- Ada 2005 (AI-251): Primitives associated with interfaces are ! -- excluded from this check because interfaces must be visible in ! -- the public and private part (RM 7.3 (7.3/2)) if Is_Abstract_Type (Typ) and then Is_Abstract_Subprogram (Prim) and then Present (Alias (Prim)) ! and then not Is_Interface ! (Find_Dispatching_Type (Ultimate_Alias (Prim))) ! and then not Present (Interface_Alias (Prim)) and then Is_Derived_Type (Typ) and then In_Private_Part (Current_Scope) and then *************** package body Exp_Disp is *** 6322,6329 **** Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length)); -- The derived type must have at least as many components as its parent ! -- (for root types, the Etype points back to itself and the test cannot ! -- fail) if DT_Entry_Count (The_Tag) < DT_Entry_Count (First_Tag_Component (Parent_Typ)) --- 6797,6803 ---- Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length)); -- The derived type must have at least as many components as its parent ! -- (for root types Etype points to itself and the test cannot fail). if DT_Entry_Count (The_Tag) < DT_Entry_Count (First_Tag_Component (Parent_Typ)) *************** package body Exp_Disp is *** 6393,6408 **** Prim : Entity_Id) is begin ! if Present (Abstract_Interface_Alias (Prim)) and then Is_Interface ! (Find_Dispatching_Type ! (Abstract_Interface_Alias (Prim))) then Set_DTC_Entity (Prim, Find_Interface_Tag (T => Tagged_Type, ! Iface => Find_Dispatching_Type ! (Abstract_Interface_Alias (Prim)))); else Set_DTC_Entity (Prim, First_Tag_Component (Tagged_Type)); --- 6867,6880 ---- Prim : Entity_Id) is begin ! if Present (Interface_Alias (Prim)) and then Is_Interface ! (Find_Dispatching_Type (Interface_Alias (Prim))) then Set_DTC_Entity (Prim, Find_Interface_Tag (T => Tagged_Type, ! Iface => Find_Dispatching_Type (Interface_Alias (Prim)))); else Set_DTC_Entity (Prim, First_Tag_Component (Tagged_Type)); *************** package body Exp_Disp is *** 6531,6542 **** Write_Name (Chars (Scope (DTC_Entity (Alias (Prim))))); end if; ! if Present (Abstract_Interface_Alias (Prim)) then Write_Str (", AI_Alias of "); ! Write_Name (Chars (Scope (DTC_Entity ! (Abstract_Interface_Alias (Prim))))); Write_Char (':'); ! Write_Int (Int (Abstract_Interface_Alias (Prim))); end if; Write_Str (")"); --- 7003,7014 ---- Write_Name (Chars (Scope (DTC_Entity (Alias (Prim))))); end if; ! if Present (Interface_Alias (Prim)) then Write_Str (", AI_Alias of "); ! Write_Name ! (Chars (Find_Dispatching_Type (Interface_Alias (Prim)))); Write_Char (':'); ! Write_Int (Int (Interface_Alias (Prim))); end if; Write_Str (")"); diff -Nrcpad gcc-4.3.3/gcc/ada/exp_disp.ads gcc-4.4.0/gcc/ada/exp_disp.ads *** gcc-4.3.3/gcc/ada/exp_disp.ads Thu Dec 13 10:26:10 2007 --- gcc-4.4.0/gcc/ada/exp_disp.ads Mon May 26 13:43:18 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Exp_Disp is *** 212,217 **** --- 212,224 ---- -- Otherwise they are set to the defining identifier and the subprogram -- body of the generated thunk. + function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; + -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation + + function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean; + -- Ada 2005 (AI-345): Returns True if E is one of the predefined primitives + -- required to implement interfaces. + function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id; -- Expand the declarations for the Dispatch Table. The node N is the -- declaration that forces the generation of the table. It is used to place diff -Nrcpad gcc-4.3.3/gcc/ada/exp_dist.adb gcc-4.4.0/gcc/ada/exp_dist.adb *** gcc-4.3.3/gcc/ada/exp_dist.adb Mon Oct 15 13:55:07 2007 --- gcc-4.4.0/gcc/ada/exp_dist.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Sem_Dist; use Sem_Dist; *** 43,49 **** with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; - with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Tbuild; use Tbuild; --- 43,48 ---- *************** package body Exp_Dist is *** 184,189 **** --- 183,194 ---- -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type). + function Build_Stub_Tag + (Loc : Source_Ptr; + RACW_Type : Entity_Id) return Node_Id; + -- Return an expression denoting the tag of the stub type associated with + -- RACW_Type. + function Build_Subprogram_Calling_Stubs (Vis_Decl : Node_Id; Subp_Id : Node_Id; *************** package body Exp_Dist is *** 216,221 **** --- 221,231 ---- -- the controlling formal of the equivalent RACW operation for a RAS -- type is always left in first position. + function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean; + -- True when Typ is an unconstrained type, or a null-excluding access type. + -- In either case, this means stubs cannot contain a default-initialized + -- object declaration of such type. + procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id; Decls : List_Id); *************** package body Exp_Dist is *** 377,382 **** --- 387,395 ---- Equal => "="); -- Mapping between a RCI subprogram and the corresponding calling stubs + function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure; + -- Return the stub information associated with the given RACW type + procedure Add_Stub_Type (Designated_Type : Entity_Id; RACW_Type : Entity_Id; *************** package body Exp_Dist is *** 471,479 **** RPC_Receiver_Decl : Node_Id; Body_Decls : List_Id); -- Add declaration for TSSs for a given RACW type. The declarations are ! -- added just after the declaration of the RACW type itself, while the ! -- bodies are inserted at the end of Body_Decls. Runtime-specific ancillary ! -- subprogram for Add_RACW_Features. procedure Specific_Add_RAST_Features (Vis_Decl : Node_Id; --- 484,493 ---- RPC_Receiver_Decl : Node_Id; Body_Decls : List_Id); -- Add declaration for TSSs for a given RACW type. The declarations are ! -- added just after the declaration of the RACW type itself. If the RACW ! -- appears in the main unit, Body_Decls is a list of declarations to which ! -- the bodies are appended. Else Body_Decls is No_List. ! -- PCS-specific ancillary subprogram for Add_RACW_Features. procedure Specific_Add_RAST_Features (Vis_Decl : Node_Id; *************** package body Exp_Dist is *** 494,500 **** when others => Partition : Entity_Id; ! -- A variable containing the Partition_ID of the target parition RPC_Receiver : Node_Id; -- An expression whose value is the address of the target RPC --- 508,514 ---- when others => Partition : Entity_Id; ! -- A variable containing the Partition_ID of the target partition RPC_Receiver : Node_Id; -- An expression whose value is the address of the target RPC *************** package body Exp_Dist is *** 756,762 **** package Helpers is ! -- Routines to build distribtion helper subprograms for user-defined -- types. For implementation of the Distributed systems annex (DSA) -- over the PolyORB generic middleware components, it is necessary to -- generate several supporting subprograms for each application data --- 770,776 ---- package Helpers is ! -- Routines to build distribution helper subprograms for user-defined -- types. For implementation of the Distributed systems annex (DSA) -- over the PolyORB generic middleware components, it is necessary to -- generate several supporting subprograms for each application data *************** package body Exp_Dist is *** 844,849 **** --- 858,882 ---- end PolyORB_Support; + -- The following PolyORB-specific subprograms are made visible to Exp_Attr: + + function Build_From_Any_Call + (Typ : Entity_Id; + N : Node_Id; + Decls : List_Id) return Node_Id + renames PolyORB_Support.Helpers.Build_From_Any_Call; + + function Build_To_Any_Call + (N : Node_Id; + Decls : List_Id) return Node_Id + renames PolyORB_Support.Helpers.Build_To_Any_Call; + + function Build_TypeCode_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Decls : List_Id) return Node_Id + renames PolyORB_Support.Helpers.Build_TypeCode_Call; + ------------------------------------ -- Local variables and structures -- ------------------------------------ *************** package body Exp_Dist is *** 1079,1086 **** Existing : Boolean; -- True when appropriate stubs have already been generated (this is the -- case when another RACW with the same designated type has already been ! -- encountered, in which case we reuse the previous stubs rather than ! -- generating new ones). begin if not Expander_Active then --- 1112,1119 ---- Existing : Boolean; -- True when appropriate stubs have already been generated (this is the -- case when another RACW with the same designated type has already been ! -- encountered), in which case we reuse the previous stubs rather than ! -- generating new ones. begin if not Expander_Active then *************** package body Exp_Dist is *** 1139,1144 **** --- 1172,1184 ---- Body_Decls => Body_Decls, Existing => Existing); + -- If this RACW is not in the main unit, do not generate primitive or + -- TSS bodies. + + if not Entity_Is_In_Main_Unit (RACW_Type) then + Body_Decls := No_List; + end if; + Add_RACW_Asynchronous_Flag (Declarations => Decls, RACW_Type => RACW_Type); *************** package body Exp_Dist is *** 1151,1162 **** RPC_Receiver_Decl => RPC_Receiver_Decl, Body_Decls => Body_Decls); ! if not Same_Scope and then not Existing then ! -- The RACW has been declared in another scope than the designated ! -- type and has not been handled by another RACW in the same package ! -- as the first one, so add primitives for the stub type here. Validate_RACW_Primitives (RACW_Type); Add_RACW_Primitive_Declarations_And_Bodies (Designated_Type => Desig, --- 1191,1203 ---- RPC_Receiver_Decl => RPC_Receiver_Decl, Body_Decls => Body_Decls); ! -- If we already have stubs for this designated type, nothing to do ! if Existing then ! return; ! end if; + if Is_Frozen (Desig) then Validate_RACW_Primitives (RACW_Type); Add_RACW_Primitive_Declarations_And_Bodies (Designated_Type => Desig, *************** package body Exp_Dist is *** 1164,1173 **** Body_Decls => Body_Decls); else ! -- Validate_RACW_Primitives will be called when the designated type ! -- is frozen, see Exp_Ch3.Freeze_Type. ! ! -- ??? Shouldn't we have a pragma Assert (not Is_Frozen (Desig))? Add_Access_Type_To_Process (E => Desig, A => RACW_Type); end if; --- 1205,1213 ---- Body_Decls => Body_Decls); else ! -- Validate_RACW_Primitives requires the list of all primitives of ! -- the designated type, so defer processing until Desig is frozen. ! -- See Exp_Ch3.Freeze_Type. Add_Access_Type_To_Process (E => Desig, A => RACW_Type); end if; *************** package body Exp_Dist is *** 1234,1239 **** --- 1274,1280 ---- RPC_Receiver := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('P')); + Specific_Build_RPC_Receiver_Body (RPC_Receiver => RPC_Receiver, Request => RPC_Receiver_Request, *************** package body Exp_Dist is *** 1375,1387 **** Parameter_Associations => New_List ( New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), Make_String_Literal (Loc, Subp_Str))), Then_Statements => New_List ( Make_Assignment_Statement (Loc, Name => New_Occurrence_Of ( RPC_Receiver_Subp_Index, Loc), Expression => Make_Integer_Literal (Loc, ! Current_Primitive_Number))))); end if; Append_To (RPC_Receiver_Case_Alternatives, --- 1416,1429 ---- Parameter_Associations => New_List ( New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), Make_String_Literal (Loc, Subp_Str))), + Then_Statements => New_List ( Make_Assignment_Statement (Loc, Name => New_Occurrence_Of ( RPC_Receiver_Subp_Index, Loc), Expression => Make_Integer_Literal (Loc, ! Intval => Current_Primitive_Number))))); end if; Append_To (RPC_Receiver_Case_Alternatives, *************** package body Exp_Dist is *** 1452,1461 **** RAS_Type : constant Entity_Id := Defining_Identifier (N); Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type); RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type); - Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type)); - - Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); - pragma Assert (Stub_Elements /= Empty_Stub_Structure); RACW_Primitive_Name : Node_Id; --- 1494,1499 ---- *************** package body Exp_Dist is *** 1629,1645 **** Subp_Name : constant Entity_Id := Defining_Unit_Name (Specification (Vis_Decl)); ! Pkg_Name : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => ! New_External_Name (Chars (Subp_Name), 'P', -1)); Proxy_Type : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => ! New_External_Name ( ! Related_Id => Chars (Subp_Name), ! Suffix => 'P')); Proxy_Type_Full_View : constant Entity_Id := Make_Defining_Identifier (Loc, --- 1667,1682 ---- Subp_Name : constant Entity_Id := Defining_Unit_Name (Specification (Vis_Decl)); ! Pkg_Name : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Chars (Subp_Name), 'P', -1)); Proxy_Type : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => ! New_External_Name ! (Related_Id => Chars (Subp_Name), ! Suffix => 'P')); Proxy_Type_Full_View : constant Entity_Id := Make_Defining_Identifier (Loc, *************** package body Exp_Dist is *** 1685,1696 **** Append_To (Vis_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Proxy_Object_Addr, ! Constant_Present => ! True, ! Object_Definition => ! New_Occurrence_Of (RTE (RE_Address), Loc))); -- private --- 1722,1730 ---- Append_To (Vis_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Proxy_Object_Addr, ! Constant_Present => True, ! Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); -- private *************** package body Exp_Dist is *** 1701,1708 **** Append_To (Pvt_Decls, Make_Full_Type_Declaration (Loc, ! Defining_Identifier => ! Proxy_Type_Full_View, Type_Definition => Build_Remote_Subprogram_Proxy_Type (Loc, New_Occurrence_Of (All_Calls_Remote_E, Loc)))); --- 1735,1741 ---- Append_To (Pvt_Decls, Make_Full_Type_Declaration (Loc, ! Defining_Identifier => Proxy_Type_Full_View, Type_Definition => Build_Remote_Subprogram_Proxy_Type (Loc, New_Occurrence_Of (All_Calls_Remote_E, Loc)))); *************** package body Exp_Dist is *** 1730,1748 **** if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then Perform_Call := Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (Subp_Name, Loc), ! Parameter_Associations => ! Actuals); else Perform_Call := Make_Simple_Return_Statement (Loc, Expression => ! Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (Subp_Name, Loc), ! Parameter_Associations => ! Actuals)); end if; Formal := First (Parameter_Specifications (Subp_Decl_Spec)); --- 1763,1777 ---- if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then Perform_Call := Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (Subp_Name, Loc), ! Parameter_Associations => Actuals); else Perform_Call := Make_Simple_Return_Statement (Loc, Expression => ! Make_Function_Call (Loc, ! Name => New_Occurrence_Of (Subp_Name, Loc), ! Parameter_Associations => Actuals)); end if; Formal := First (Parameter_Specifications (Subp_Decl_Spec)); *************** package body Exp_Dist is *** 1758,1788 **** Append_To (Pvt_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, ! Name_uO), ! Aliased_Present => ! True, ! Object_Definition => ! New_Occurrence_Of (Proxy_Type, Loc))); -- A : constant System.Address := O'Address; Append_To (Pvt_Decls, Make_Object_Declaration (Loc, Defining_Identifier => ! Make_Defining_Identifier (Loc, ! Chars (Proxy_Object_Addr)), ! Constant_Present => ! True, ! Object_Definition => ! New_Occurrence_Of (RTE (RE_Address), Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of ( Defining_Identifier (Last (Pvt_Decls)), Loc), ! Attribute_Name => ! Name_Address))); Append_To (Decls, Make_Package_Declaration (Loc, --- 1787,1809 ---- Append_To (Pvt_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), ! Aliased_Present => True, ! Object_Definition => New_Occurrence_Of (Proxy_Type, Loc))); -- A : constant System.Address := O'Address; Append_To (Pvt_Decls, Make_Object_Declaration (Loc, Defining_Identifier => ! Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)), ! Constant_Present => True, ! Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of ( Defining_Identifier (Last (Pvt_Decls)), Loc), ! Attribute_Name => Name_Address))); Append_To (Decls, Make_Package_Declaration (Loc, *************** package body Exp_Dist is *** 1796,1807 **** Append_To (Decls, Make_Package_Body (Loc, Defining_Unit_Name => ! Make_Defining_Identifier (Loc, ! Chars (Pkg_Name)), Declarations => New_List ( Make_Subprogram_Body (Loc, ! Specification => ! Subp_Body_Spec, Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, --- 1817,1826 ---- Append_To (Decls, Make_Package_Body (Loc, Defining_Unit_Name => ! Make_Defining_Identifier (Loc, Chars (Pkg_Name)), Declarations => New_List ( Make_Subprogram_Body (Loc, ! Specification => Subp_Body_Spec, Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, *************** package body Exp_Dist is *** 1857,1862 **** --- 1876,1883 ---- Stub_Type := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); + Set_Ekind (Stub_Type, E_Record_Type); + Set_Is_RACW_Stub_Type (Stub_Type); Stub_Type_Access := Make_Defining_Identifier (Loc, Chars => New_External_Name *************** package body Exp_Dist is *** 2005,2011 **** -- We have an unconstrained Etyp: build the actual constrained -- subtype for the value we just read from the stream. ! -- suubtype S is ; Append_To (Decls, Build_Actual_Subtype (Etyp, --- 2026,2032 ---- -- We have an unconstrained Etyp: build the actual constrained -- subtype for the value we just read from the stream. ! -- subtype S is ; Append_To (Decls, Build_Actual_Subtype (Etyp, *************** package body Exp_Dist is *** 2043,2052 **** Chars => Name_Address, Expression => Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Constant_Object, Loc), ! Attribute_Name => ! Name_Address))); end; end if; --- 2064,2071 ---- Chars => Name_Address, Expression => Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Constant_Object, Loc), ! Attribute_Name => Name_Address))); end; end if; *************** package body Exp_Dist is *** 2062,2069 **** Make_Object_Declaration (Loc, Defining_Identifier => Object, Constant_Present => Present (Expr) and then not Variable, ! Object_Definition => ! New_Occurrence_Of (Etyp, Loc), Expression => Expr)); if Constant_Present (Last (Decls)) then --- 2081,2087 ---- Make_Object_Declaration (Loc, Defining_Identifier => Object, Constant_Present => Present (Expr) and then not Variable, ! Object_Definition => New_Occurrence_Of (Etyp, Loc), Expression => Expr)); if Constant_Present (Last (Decls)) then *************** package body Exp_Dist is *** 2095,2111 **** Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, ! Prefix => ! New_Occurrence_Of (Pointer, Loc), Selector_Name => New_Occurrence_Of (First_Tag_Component (Designated_Type (Etype (Pointer))), Loc)), Expression => Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Stub_Type, Loc), ! Attribute_Name => ! Name_Tag))); -- Note: The assignment to Pointer._Tag is safe here because -- we carefully ensured that Stub_Type has exactly the same layout --- 2113,2126 ---- Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, ! Prefix => New_Occurrence_Of (Pointer, Loc), Selector_Name => New_Occurrence_Of (First_Tag_Component (Designated_Type (Etype (Pointer))), Loc)), Expression => Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Stub_Type, Loc), ! Attribute_Name => Name_Tag))); -- Note: The assignment to Pointer._Tag is safe here because -- we carefully ensured that Stub_Type has exactly the same layout *************** package body Exp_Dist is *** 2121,2126 **** --- 2136,2142 ---- Constrained_List : List_Id; Unconstrained_List : List_Id; Current_Parameter : Node_Id; + Ptyp : Node_Id; First_Parameter : Node_Id; For_RAS : Boolean := False; *************** package body Exp_Dist is *** 2140,2154 **** For_RAS := True; end if; ! -- Loop through the parameters and add them to the right list Current_Parameter := First_Parameter; while Present (Current_Parameter) loop ! if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition ! or else ! Is_Constrained (Etype (Parameter_Type (Current_Parameter))) ! or else ! Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter)))) and then not (For_RAS and then Current_Parameter = First_Parameter) then Append_To (Constrained_List, New_Copy (Current_Parameter)); --- 2156,2172 ---- For_RAS := True; end if; ! -- Loop through the parameters and add them to the right list. Note that ! -- we treat a parameter of a null-excluding access type as unconstrained ! -- because we can't declare an object of such a type with default ! -- initialization. Current_Parameter := First_Parameter; while Present (Current_Parameter) loop ! Ptyp := Parameter_Type (Current_Parameter); ! ! if (Nkind (Ptyp) = N_Access_Definition ! or else not Transmit_As_Unconstrained (Etype (Ptyp))) and then not (For_RAS and then Current_Parameter = First_Parameter) then Append_To (Constrained_List, New_Copy (Current_Parameter)); *************** package body Exp_Dist is *** 2209,2216 **** Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), ! Attribute_Name => ! Name_Version))); Append_To (L, Reg); Analyze (Reg); end Build_Passive_Partition_Stub; --- 2227,2233 ---- Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), ! Attribute_Name => Name_Version))); Append_To (L, Reg); Analyze (Reg); end Build_Passive_Partition_Stub; *************** package body Exp_Dist is *** 2284,2289 **** --- 2301,2322 ---- New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); end Build_Remote_Subprogram_Proxy_Type; + -------------------- + -- Build_Stub_Tag -- + -------------------- + + function Build_Stub_Tag + (Loc : Source_Ptr; + RACW_Type : Entity_Id) return Node_Id + is + Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type); + begin + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag); + end Build_Stub_Tag; + ------------------------------------ -- Build_Subprogram_Calling_Stubs -- ------------------------------------ *************** package body Exp_Dist is *** 2671,2678 **** Append_To (Stmts, Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_NVList_Create), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (NVList, Loc)))); end Declare_Create_NVList; --- 2704,2710 ---- Append_To (Stmts, Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (NVList, Loc)))); end Declare_Create_NVList; *************** package body Exp_Dist is *** 2800,2806 **** --- 2832,2840 ---- declare HSS_Stmts : constant List_Id := Statements (Handled_Statement_Sequence (Unit_Node)); + First_HSS_Stmt : constant Node_Id := First (HSS_Stmts); + begin if No (First_HSS_Stmt) then Append_List_To (HSS_Stmts, Stubs_Stmts); *************** package body Exp_Dist is *** 2828,2834 **** Body_Decls : List_Id); -- Add Read attribute for the RACW type. The declaration and attribute -- definition clauses are inserted right after the declaration of ! -- RACW_Type, while the subprogram body is appended to Body_Decls. procedure Add_RACW_Write_Attribute (RACW_Type : Entity_Id; --- 2862,2869 ---- Body_Decls : List_Id); -- Add Read attribute for the RACW type. The declaration and attribute -- definition clauses are inserted right after the declaration of ! -- RACW_Type. If Body_Decls is not No_List, the subprogram body is ! -- appended to it (case where the RACW declaration is in the main unit). procedure Add_RACW_Write_Attribute (RACW_Type : Entity_Id; *************** package body Exp_Dist is *** 2859,2865 **** (Loc : Source_Ptr; Decls : List_Id; RPC_Receiver : Entity_Id; ! Stub_Elements : Stub_Structure) is begin -- The RPC receiver body should not be the completion of the -- declaration recorded in the stub structure, because then the --- 2894,2901 ---- (Loc : Source_Ptr; Decls : List_Id; RPC_Receiver : Entity_Id; ! Stub_Elements : Stub_Structure) ! is begin -- The RPC receiver body should not be the completion of the -- declaration recorded in the stub structure, because then the *************** package body Exp_Dist is *** 2912,2929 **** Attribute_Name => Name_Address); end if; ! Add_RACW_Write_Attribute ( ! RACW_Type, ! Stub_Type, ! Stub_Type_Access, ! RPC_Receiver, ! Body_Decls); ! Add_RACW_Read_Attribute ( ! RACW_Type, ! Stub_Type, ! Stub_Type_Access, ! Body_Decls); end Add_RACW_Features; ----------------------------- --- 2948,2965 ---- Attribute_Name => Name_Address); end if; ! Add_RACW_Write_Attribute ! (RACW_Type, ! Stub_Type, ! Stub_Type_Access, ! RPC_Receiver, ! Body_Decls); ! Add_RACW_Read_Attribute ! (RACW_Type, ! Stub_Type, ! Stub_Type_Access, ! Body_Decls); end Add_RACW_Features; ----------------------------- *************** package body Exp_Dist is *** 2941,2976 **** Body_Node : Node_Id; Decls : List_Id; - Statements : List_Id; Local_Statements : List_Id; Remote_Statements : List_Id; -- Various parts of the procedure ! Procedure_Name : constant Name_Id := ! New_Internal_Name ('R'); ! Source_Partition : constant Entity_Id := ! Make_Defining_Identifier ! (Loc, New_Internal_Name ('P')); ! Source_Receiver : constant Entity_Id := ! Make_Defining_Identifier ! (Loc, New_Internal_Name ('S')); ! Source_Address : constant Entity_Id := ! Make_Defining_Identifier ! (Loc, New_Internal_Name ('P')); ! Local_Stub : constant Entity_Id := ! Make_Defining_Identifier ! (Loc, New_Internal_Name ('L')); ! Stubbed_Result : constant Entity_Id := Make_Defining_Identifier ! (Loc, New_Internal_Name ('S')); Asynchronous_Flag : constant Entity_Id := Asynchronous_Flags_Table.Get (RACW_Type); pragma Assert (Present (Asynchronous_Flag)); -- Start of processing for Add_RACW_Read_Attribute begin -- Generate object declarations Decls := New_List ( --- 2977,3043 ---- Body_Node : Node_Id; + Statements : constant List_Id := New_List; Decls : List_Id; Local_Statements : List_Id; Remote_Statements : List_Id; -- Various parts of the procedure ! Pnam : constant Entity_Id := Make_Defining_Identifier ! (Loc, New_Internal_Name ('R')); Asynchronous_Flag : constant Entity_Id := Asynchronous_Flags_Table.Get (RACW_Type); pragma Assert (Present (Asynchronous_Flag)); + -- Prepare local identifiers + + Source_Partition : Entity_Id; + Source_Receiver : Entity_Id; + Source_Address : Entity_Id; + Local_Stub : Entity_Id; + Stubbed_Result : Entity_Id; + -- Start of processing for Add_RACW_Read_Attribute begin + Build_Stream_Procedure (Loc, + RACW_Type, Body_Node, Pnam, Statements, Outp => True); + Proc_Decl := Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Read, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + + if No (Body_Decls) then + + -- Case of processing an RACW type from another unit than the + -- main one: do not generate a body. + + return; + end if; + + -- Prepare local identifiers + + Source_Partition := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Source_Receiver := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Source_Address := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Local_Stub := + Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + Stubbed_Result := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + -- Generate object declarations Decls := New_List ( *************** package body Exp_Dist is *** 3007,3013 **** -- Read the source Partition_ID and RPC_Receiver from incoming stream ! Statements := New_List ( Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (RTE (RE_Partition_ID), Loc), --- 3074,3080 ---- -- Read the source Partition_ID and RPC_Receiver from incoming stream ! Append_List_To (Statements, New_List ( Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (RTE (RE_Partition_ID), Loc), *************** package body Exp_Dist is *** 3032,3056 **** Name_Read, Expressions => New_List ( Stream_Parameter, ! New_Occurrence_Of (Source_Address, Loc)))); -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result Set_Etype (Stubbed_Result, Stub_Type_Access); ! -- If the Address is Null_Address, then return a null object ! Append_To (Statements, ! Make_Implicit_If_Statement (RACW_Type, ! Condition => ! Make_Op_Eq (Loc, ! Left_Opnd => New_Occurrence_Of (Source_Address, Loc), ! Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), ! Then_Statements => New_List ( ! Make_Assignment_Statement (Loc, ! Name => Result, ! Expression => Make_Null (Loc)), ! Make_Simple_Return_Statement (Loc)))); -- If the RACW denotes an object created on the current partition, -- Local_Statements will be executed. The real object will be used. --- 3099,3139 ---- Name_Read, Expressions => New_List ( Stream_Parameter, ! New_Occurrence_Of (Source_Address, Loc))))); -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result Set_Etype (Stubbed_Result, Stub_Type_Access); ! -- If the Address is Null_Address, then return a null object, unless ! -- RACW_Type is null-excluding, in which case unconditionally raise ! -- CONSTRAINT_ERROR instead. ! declare ! Zero_Statements : List_Id; ! -- Statements executed when a zero value is received ! ! begin ! if Can_Never_Be_Null (RACW_Type) then ! Zero_Statements := New_List ( ! Make_Raise_Constraint_Error (Loc, ! Reason => CE_Null_Not_Allowed)); ! else ! Zero_Statements := New_List ( ! Make_Assignment_Statement (Loc, ! Name => Result, ! Expression => Make_Null (Loc)), ! Make_Simple_Return_Statement (Loc)); ! end if; ! ! Append_To (Statements, ! Make_Implicit_If_Statement (RACW_Type, ! Condition => ! Make_Op_Eq (Loc, ! Left_Opnd => New_Occurrence_Of (Source_Address, Loc), ! Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), ! Then_Statements => Zero_Statements)); ! end; -- If the RACW denotes an object created on the current partition, -- Local_Statements will be executed. The real object will be used. *************** package body Exp_Dist is *** 3131,3155 **** Then_Statements => Local_Statements, Else_Statements => Remote_Statements)); - Build_Stream_Procedure - (Loc, RACW_Type, Body_Node, - Make_Defining_Identifier (Loc, Procedure_Name), - Statements, Outp => True); Set_Declarations (Body_Node, Decls); - - Proc_Decl := Make_Subprogram_Declaration (Loc, - Copy_Specification (Loc, Specification (Body_Node))); - - Attr_Decl := - Make_Attribute_Definition_Clause (Loc, - Name => New_Occurrence_Of (RACW_Type, Loc), - Chars => Name_Read, - Expression => - New_Occurrence_Of ( - Defining_Unit_Name (Specification (Proc_Decl)), Loc)); - - Insert_After (Declaration_Node (RACW_Type), Proc_Decl); - Insert_After (Proc_Decl, Attr_Decl); Append_To (Body_Decls, Body_Node); end Add_RACW_Read_Attribute; --- 3214,3220 ---- *************** package body Exp_Dist is *** 3168,3181 **** Proc_Decl : Node_Id; Attr_Decl : Node_Id; ! Statements : List_Id; Local_Statements : List_Id; Remote_Statements : List_Id; Null_Statements : List_Id; ! Procedure_Name : constant Name_Id := New_Internal_Name ('R'); begin -- Build the code fragment corresponding to the marshalling of a -- local object. --- 3233,3268 ---- Proc_Decl : Node_Id; Attr_Decl : Node_Id; ! Statements : constant List_Id := New_List; Local_Statements : List_Id; Remote_Statements : List_Id; Null_Statements : List_Id; ! Pnam : constant Entity_Id := ! Make_Defining_Identifier (Loc, New_Internal_Name ('R')); begin + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); + + Proc_Decl := Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Write, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + + if No (Body_Decls) then + return; + end if; + -- Build the code fragment corresponding to the marshalling of a -- local object. *************** package body Exp_Dist is *** 3204,3238 **** -- a remote object. Remote_Statements := New_List ( - Pack_Node_Into_Stream_Access (Loc, ! Stream => Stream_Parameter, ! Object => Make_Selected_Component (Loc, ! Prefix => Unchecked_Convert_To (Stub_Type_Access, ! Object), ! Selector_Name => ! Make_Identifier (Loc, Name_Origin)), ! Etyp => RTE (RE_Partition_ID)), Pack_Node_Into_Stream_Access (Loc, Stream => Stream_Parameter, Object => Make_Selected_Component (Loc, ! Prefix => Unchecked_Convert_To (Stub_Type_Access, ! Object), ! Selector_Name => ! Make_Identifier (Loc, Name_Receiver)), Etyp => RTE (RE_Unsigned_64)), Pack_Node_Into_Stream_Access (Loc, Stream => Stream_Parameter, Object => Make_Selected_Component (Loc, ! Prefix => Unchecked_Convert_To (Stub_Type_Access, ! Object), ! Selector_Name => ! Make_Identifier (Loc, Name_Addr)), Etyp => RTE (RE_Unsigned_64))); -- Build code fragment corresponding to marshalling of a null object --- 3291,3321 ---- -- a remote object. Remote_Statements := New_List ( Pack_Node_Into_Stream_Access (Loc, ! Stream => Stream_Parameter, ! Object => Make_Selected_Component (Loc, ! Prefix => ! Unchecked_Convert_To (Stub_Type_Access, Object), ! Selector_Name => Make_Identifier (Loc, Name_Origin)), ! Etyp => RTE (RE_Partition_ID)), Pack_Node_Into_Stream_Access (Loc, Stream => Stream_Parameter, Object => Make_Selected_Component (Loc, ! Prefix => ! Unchecked_Convert_To (Stub_Type_Access, Object), ! Selector_Name => Make_Identifier (Loc, Name_Receiver)), Etyp => RTE (RE_Unsigned_64)), Pack_Node_Into_Stream_Access (Loc, Stream => Stream_Parameter, Object => Make_Selected_Component (Loc, ! Prefix => ! Unchecked_Convert_To (Stub_Type_Access, Object), ! Selector_Name => Make_Identifier (Loc, Name_Addr)), Etyp => RTE (RE_Unsigned_64))); -- Build code fragment corresponding to marshalling of a null object *************** package body Exp_Dist is *** 3253,3265 **** Object => Make_Integer_Literal (Loc, Uint_0), Etyp => RTE (RE_Unsigned_64))); ! Statements := New_List ( Make_Implicit_If_Statement (RACW_Type, Condition => Make_Op_Eq (Loc, Left_Opnd => Object, Right_Opnd => Make_Null (Loc)), Then_Statements => Null_Statements, Elsif_Parts => New_List ( Make_Elsif_Part (Loc, Condition => --- 3336,3350 ---- Object => Make_Integer_Literal (Loc, Uint_0), Etyp => RTE (RE_Unsigned_64))); ! Append_To (Statements, Make_Implicit_If_Statement (RACW_Type, Condition => Make_Op_Eq (Loc, Left_Opnd => Object, Right_Opnd => Make_Null (Loc)), + Then_Statements => Null_Statements, + Elsif_Parts => New_List ( Make_Elsif_Part (Loc, Condition => *************** package body Exp_Dist is *** 3268,3273 **** --- 3353,3359 ---- Make_Attribute_Reference (Loc, Prefix => Object, Attribute_Name => Name_Tag), + Right_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Stub_Type, Loc), *************** package body Exp_Dist is *** 3275,3298 **** Then_Statements => Remote_Statements)), Else_Statements => Local_Statements)); - Build_Stream_Procedure - (Loc, RACW_Type, Body_Node, - Make_Defining_Identifier (Loc, Procedure_Name), - Statements, Outp => False); - - Proc_Decl := Make_Subprogram_Declaration (Loc, - Copy_Specification (Loc, Specification (Body_Node))); - - Attr_Decl := - Make_Attribute_Definition_Clause (Loc, - Name => New_Occurrence_Of (RACW_Type, Loc), - Chars => Name_Write, - Expression => - New_Occurrence_Of ( - Defining_Unit_Name (Specification (Proc_Decl)), Loc)); - - Insert_After (Declaration_Node (RACW_Type), Proc_Decl); - Insert_After (Proc_Decl, Attr_Decl); Append_To (Body_Decls, Body_Node); end Add_RACW_Write_Attribute; --- 3361,3366 ---- *************** package body Exp_Dist is *** 3400,3406 **** begin Proc_Decls := New_List ( ! -- Common declarations Make_Object_Declaration (Loc, Defining_Identifier => Origin, --- 3468,3474 ---- begin Proc_Decls := New_List ( ! -- Common declarations Make_Object_Declaration (Loc, Defining_Identifier => Origin, *************** package body Exp_Dist is *** 3414,3428 **** Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc)))), ! -- Declaration use only in the local case: proxy address Make_Object_Declaration (Loc, Defining_Identifier => Proxy_Addr, Object_Definition => New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), ! -- Declarations used only in the remote case: stub object and ! -- stub pointer. Make_Object_Declaration (Loc, Defining_Identifier => Local_Stub, --- 3482,3496 ---- Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc)))), ! -- Declaration use only in the local case: proxy address Make_Object_Declaration (Loc, Defining_Identifier => Proxy_Addr, Object_Definition => New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), ! -- Declarations used only in the remote case: stub object and ! -- stub pointer. Make_Object_Declaration (Loc, Defining_Identifier => Local_Stub, *************** package body Exp_Dist is *** 3441,3447 **** Attribute_Name => Name_Unchecked_Access))); Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); ! -- Build_Get_Unique_RP_Call needs this information -- Note: Here we assume that the Fat_Type is a record -- containing just a pointer to a proxy or stub object. --- 3509,3516 ---- Attribute_Name => Name_Unchecked_Access))); Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); ! ! -- Build_Get_Unique_RP_Call needs above information -- Note: Here we assume that the Fat_Type is a record -- containing just a pointer to a proxy or stub object. *************** package body Exp_Dist is *** 3458,3465 **** -- end if; Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc), New_Occurrence_Of (Subp_Id, Loc), --- 3527,3533 ---- -- end if; Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc), New_Occurrence_Of (Subp_Id, Loc), *************** package body Exp_Dist is *** 3476,3484 **** --- 3544,3554 ---- Make_Function_Call (Loc, New_Occurrence_Of ( RTE (RE_Get_Local_Partition_Id), Loc))), + Right_Opnd => Make_Op_Not (Loc, New_Occurrence_Of (All_Calls_Remote, Loc))), + Then_Statements => New_List ( Make_Simple_Return_Statement (Loc, Unchecked_Convert_To (Fat_Type, *************** package body Exp_Dist is *** 3497,3508 **** Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), ! -- E.4.1(9) A remote call is asynchronous if it is a call to ! -- a procedure, or a call through a value of an access-to-procedure ! -- type, to which a pragma Asynchronous applies. ! -- Parameter Asynch_P is true when the procedure is asynchronous; ! -- Expression Asynch_T is true when the type is asynchronous. Set_Field (Name_Asynchronous, Make_Or_Else (Loc, --- 3567,3578 ---- Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), ! -- E.4.1(9) A remote call is asynchronous if it is a call to ! -- a procedure or a call through a value of an access-to-procedure ! -- type to which a pragma Asynchronous applies. ! -- Asynch_P is true when the procedure is asynchronous; ! -- Asynch_T is true when the type is asynchronous. Set_Field (Name_Asynchronous, Make_Or_Else (Loc, *************** package body Exp_Dist is *** 3653,3660 **** New_List ( Make_Procedure_Call_Statement (Loc, Name => ! New_Occurrence_Of ( ! Defining_Entity (Stubs), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc)))))); end Append_Stubs_To; --- 3723,3729 ---- New_List ( Make_Procedure_Call_Statement (Loc, Name => ! New_Occurrence_Of (Defining_Entity (Stubs), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc)))))); end Append_Stubs_To; *************** package body Exp_Dist is *** 3697,3706 **** --- 3766,3777 ---- Make_Op_Eq (Loc, New_Occurrence_Of (Subp_Id, Loc), Make_Integer_Literal (Loc, 0)), + Then_Statements => New_List ( Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Subp_Id, Loc), + Expression => Make_Selected_Component (Loc, Prefix => *************** package body Exp_Dist is *** 3715,3720 **** --- 3786,3792 ---- Make_Selected_Component (Loc, Prefix => Request_Parameter, Selector_Name => Name_Params))))), + Selector_Name => Make_Identifier (Loc, Name_Subp_Id)))))); *************** package body Exp_Dist is *** 3736,3741 **** --- 3808,3814 ---- New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), Result_Definition => New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); + Append_To (Decls, Current_Declaration); Analyze (Current_Declaration); *************** package body Exp_Dist is *** 3818,3823 **** --- 3891,3897 ---- Choices => New_List ( Make_Integer_Literal (Loc, Current_Subprogram_Number)), + Expression => Make_Aggregate (Loc, Component_Associations => New_List ( *************** package body Exp_Dist is *** 3829,3838 **** Proxy_Object_Addr, Loc)))))); Append_Stubs_To (Pkg_RPC_Receiver_Cases, ! Stubs => ! Current_Stubs, ! Subprogram_Number => ! Current_Subprogram_Number); end; Current_Subprogram_Number := Current_Subprogram_Number + 1; --- 3903,3910 ---- Proxy_Object_Addr, Loc)))))); Append_Stubs_To (Pkg_RPC_Receiver_Cases, ! Stubs => Current_Stubs, ! Subprogram_Number => Current_Subprogram_Number); end; Current_Subprogram_Number := Current_Subprogram_Number + 1; *************** package body Exp_Dist is *** 3851,3865 **** Append_To (Pkg_RPC_Receiver_Cases, Make_Case_Statement_Alternative (Loc, ! Discrete_Choices => ! New_List (Make_Others_Choice (Loc)), ! Statements => ! New_List (Make_Null_Statement (Loc)))); Append_To (Pkg_RPC_Receiver_Statements, Make_Case_Statement (Loc, ! Expression => ! New_Occurrence_Of (Subp_Id, Loc), Alternatives => Pkg_RPC_Receiver_Cases)); Append_To (Decls, --- 3923,3934 ---- Append_To (Pkg_RPC_Receiver_Cases, Make_Case_Statement_Alternative (Loc, ! Discrete_Choices => New_List (Make_Others_Choice (Loc)), ! Statements => New_List (Make_Null_Statement (Loc)))); Append_To (Pkg_RPC_Receiver_Statements, Make_Case_Statement (Loc, ! Expression => New_Occurrence_Of (Subp_Id, Loc), Alternatives => Pkg_RPC_Receiver_Cases)); Append_To (Decls, *************** package body Exp_Dist is *** 3879,3886 **** First_RCI_Subprogram_Id), High_Bound => Make_Integer_Literal (Loc, ! First_RCI_Subprogram_Id ! + List_Length (Subp_Info_List) - 1))))))); -- For a degenerate RCI with no visible subprograms, Subp_Info_List -- has zero length, and the declaration is for an empty array, in --- 3948,3956 ---- First_RCI_Subprogram_Id), High_Bound => Make_Integer_Literal (Loc, ! Intval => ! First_RCI_Subprogram_Id ! + List_Length (Subp_Info_List) - 1))))))); -- For a degenerate RCI with no visible subprograms, Subp_Info_List -- has zero length, and the declaration is for an empty array, in *************** package body Exp_Dist is *** 3911,3923 **** Make_Selected_Component (Loc, Prefix => Make_Indexed_Component (Loc, ! Prefix => ! New_Occurrence_Of (Subp_Info_Array, Loc), Expressions => New_List ( Convert_To (Standard_Integer, Make_Identifier (Loc, Name_Subp_Id)))), ! Selector_Name => ! Make_Identifier (Loc, Name_Addr)); -- Case of no visible subprogram: just raise Constraint_Error, we -- know for sure we got junk from a remote partition. --- 3981,3991 ---- Make_Selected_Component (Loc, Prefix => Make_Indexed_Component (Loc, ! Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), Expressions => New_List ( Convert_To (Standard_Integer, Make_Identifier (Loc, Name_Subp_Id)))), ! Selector_Name => Make_Identifier (Loc, Name_Addr)); -- Case of no visible subprogram: just raise Constraint_Error, we -- know for sure we got junk from a remote partition. *************** package body Exp_Dist is *** 3933,3947 **** Make_Subprogram_Body (Loc, Specification => Copy_Specification (Loc, Parent (Lookup_RAS_Info)), ! Declarations => ! No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Simple_Return_Statement (Loc, Expression => ! OK_Convert_To (RTE (RE_Unsigned_64), ! Subp_Info_Addr)))))); end; Analyze (Last (Decls)); --- 4001,4014 ---- Make_Subprogram_Body (Loc, Specification => Copy_Specification (Loc, Parent (Lookup_RAS_Info)), ! Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Simple_Return_Statement (Loc, Expression => ! OK_Convert_To ! (RTE (RE_Unsigned_64), Subp_Info_Addr)))))); end; Analyze (Last (Decls)); *************** package body Exp_Dist is *** 3961,3970 **** Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Pkg_RPC_Receiver, Loc), ! Attribute_Name => ! Name_Unrestricted_Access)); -- Version --- 4028,4035 ---- Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), ! Attribute_Name => Name_Unrestricted_Access)); -- Version *************** package body Exp_Dist is *** 3972,3997 **** Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), ! Attribute_Name => ! Name_Version)); -- Subp_Info Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Subp_Info_Array, Loc), ! Attribute_Name => ! Name_Address)); -- Subp_Info_Len Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Subp_Info_Array, Loc), ! Attribute_Name => ! Name_Length)); -- Generate the call --- 4037,4057 ---- Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), ! Attribute_Name => Name_Version)); -- Subp_Info Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), ! Attribute_Name => Name_Address)); -- Subp_Info_Len Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), ! Attribute_Name => Name_Length)); -- Generate the call *************** package body Exp_Dist is *** 4129,4138 **** Attribute_Name => Name_Write, Expressions => New_List ( Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Stream_Parameter, Loc), ! Attribute_Name => ! Name_Access), Target_RPC_Receiver))); -- Then put the Subprogram_Id of the subprogram we want to call in --- 4189,4196 ---- Attribute_Name => Name_Write, Expressions => New_List ( Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Stream_Parameter, Loc), ! Attribute_Name => Name_Access), Target_RPC_Receiver))); -- Then put the Subprogram_Id of the subprogram we want to call in *************** package body Exp_Dist is *** 4140,4153 **** Append_To (Statements, Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), ! Attribute_Name => ! Name_Write, Expressions => New_List ( Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Stream_Parameter, Loc), Attribute_Name => Name_Access), Subprogram_Id))); --- 4198,4208 ---- Append_To (Statements, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), ! Attribute_Name => Name_Write, Expressions => New_List ( Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Stream_Parameter, Loc), Attribute_Name => Name_Access), Subprogram_Id))); *************** package body Exp_Dist is *** 4163,4169 **** begin if Is_RACW_Controlling_Formal ! (Current_Parameter, Stub_Type) then -- In the case of a controlling formal argument, we marshall -- its addr field rather than the local stub. --- 4218,4224 ---- begin if Is_RACW_Controlling_Formal ! (Current_Parameter, Stub_Type) then -- In the case of a controlling formal argument, we marshall -- its addr field rather than the local stub. *************** package body Exp_Dist is *** 4179,4186 **** Etyp => RTE (RE_Unsigned_64))); else ! Value := New_Occurrence_Of ! (Defining_Identifier (Current_Parameter), Loc); -- Access type parameters are transmitted as in out -- parameters. However, a dereference is needed so that --- 4234,4242 ---- Etyp => RTE (RE_Unsigned_64))); else ! Value := ! New_Occurrence_Of ! (Defining_Identifier (Current_Parameter), Loc); -- Access type parameters are transmitted as in out -- parameters. However, a dereference is needed so that *************** package body Exp_Dist is *** 4193,4200 **** Etyp := Etype (Typ); end if; ! Constrained := ! Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); -- Any parameter but unconstrained out parameters are -- transmitted to the peer. --- 4249,4255 ---- Etyp := Etype (Typ); end if; ! Constrained := not Transmit_As_Unconstrained (Etyp); -- Any parameter but unconstrained out parameters are -- transmitted to the peer. *************** package body Exp_Dist is *** 4205,4212 **** then Append_To (Statements, Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Etyp, Loc), Attribute_Name => Output_From_Constrained (Constrained), Expressions => New_List ( --- 4260,4266 ---- then Append_To (Statements, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Etyp, Loc), Attribute_Name => Output_From_Constrained (Constrained), Expressions => New_List ( *************** package body Exp_Dist is *** 4252,4264 **** Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Standard_Boolean, Loc), ! Attribute_Name => ! Name_Write, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => ! New_Occurrence_Of (Stream_Parameter, Loc), ! Attribute_Name => Name_Access), New_Occurrence_Of (Extra_Parameter, Loc)))); end if; --- 4306,4317 ---- Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Standard_Boolean, Loc), ! Attribute_Name => Name_Write, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => ! New_Occurrence_Of ! (Stream_Parameter, Loc), Attribute_Name => Name_Access), New_Occurrence_Of (Extra_Parameter, Loc)))); end if; *************** package body Exp_Dist is *** 4284,4291 **** Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Stream_Parameter, Loc), ! Attribute_Name => ! Name_Access)))); else Asynchronous_Statements := No_List; end if; --- 4337,4343 ---- Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Stream_Parameter, Loc), ! Attribute_Name => Name_Access)))); else Asynchronous_Statements := No_List; end if; *************** package body Exp_Dist is *** 4304,4317 **** Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Stream_Parameter, Loc), ! Attribute_Name => ! Name_Access), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Result_Parameter, Loc), ! Attribute_Name => ! Name_Access)))); -- Read the exception occurrence from the result stream and -- reraise it. It does no harm if this is a Null_Occurrence since --- 4356,4367 ---- Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Stream_Parameter, Loc), ! Attribute_Name => Name_Access), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Result_Parameter, Loc), ! Attribute_Name => Name_Access)))); -- Read the exception occurrence from the result stream and -- reraise it. It does no harm if this is a Null_Occurrence since *************** package body Exp_Dist is *** 4322,4336 **** Prefix => New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), ! Attribute_Name => ! Name_Read, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Result_Parameter, Loc), ! Attribute_Name => ! Name_Access), New_Occurrence_Of (Exception_Return_Parameter, Loc)))); Append_To (Non_Asynchronous_Statements, --- 4372,4384 ---- Prefix => New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), ! Attribute_Name => Name_Read, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Result_Parameter, Loc), ! Attribute_Name => Name_Access), New_Occurrence_Of (Exception_Return_Parameter, Loc)))); Append_To (Non_Asynchronous_Statements, *************** package body Exp_Dist is *** 4403,4410 **** Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Result_Parameter, Loc), ! Attribute_Name => ! Name_Access), Value))); end if; end; --- 4451,4457 ---- Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Result_Parameter, Loc), ! Attribute_Name => Name_Access), Value))); end if; end; *************** package body Exp_Dist is *** 4495,4503 **** New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), Attribute_Name => Name_Input, Expressions => New_List ( ! Make_Selected_Component (Loc, ! Prefix => Request, ! Selector_Name => Name_Params))))); Stmts := New_List; --- 4542,4550 ---- New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), Attribute_Name => Name_Input, Expressions => New_List ( ! Make_Selected_Component (Loc, ! Prefix => Request, ! Selector_Name => Name_Params))))); Stmts := New_List; *************** package body Exp_Dist is *** 4735,4743 **** New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), Attribute_Name => Name_Write, Expressions => New_List ( ! Make_Selected_Component (Loc, ! Prefix => Request_Parameter, ! Selector_Name => Name_Result), New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); if Dynamically_Asynchronous then --- 4782,4790 ---- New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), Attribute_Name => Name_Write, Expressions => New_List ( ! Make_Selected_Component (Loc, ! Prefix => Request_Parameter, ! Selector_Name => Name_Result), New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); if Dynamically_Asynchronous then *************** package body Exp_Dist is *** 4786,4793 **** Etyp := Etype (Parameter_Type (Current_Parameter)); end if; ! Constrained := ! Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); if In_Present (Current_Parameter) or else not Out_Present (Current_Parameter) --- 4833,4839 ---- Etyp := Etype (Parameter_Type (Current_Parameter)); end if; ! Constrained := not Transmit_As_Unconstrained (Etyp); if In_Present (Current_Parameter) or else not Out_Present (Current_Parameter) *************** package body Exp_Dist is *** 4821,4835 **** Append_To (Decls, Input_With_Tag_Check (Loc, Var_Type => Etyp, ! Stream => Make_Selected_Component (Loc, ! Prefix => Request_Parameter, ! Selector_Name => Name_Params))); -- Prepare function call expression ! Expr := Make_Function_Call (Loc, ! New_Occurrence_Of (Defining_Unit_Name ! (Specification (Last (Decls))), Loc)); end if; end if; --- 4867,4885 ---- Append_To (Decls, Input_With_Tag_Check (Loc, Var_Type => Etyp, ! Stream => ! Make_Selected_Component (Loc, ! Prefix => Request_Parameter, ! Selector_Name => Name_Params))); -- Prepare function call expression ! Expr := ! Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of ! (Defining_Unit_Name ! (Specification (Last (Decls))), Loc)); end if; end if; *************** package body Exp_Dist is *** 5168,5173 **** --- 5218,5236 ---- end Get_And_Reset_RACW_Bodies; ----------------------- + -- Get_Stub_Elements -- + ----------------------- + + function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); + begin + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + return Stub_Elements; + end Get_Stub_Elements; + + ----------------------- -- Get_Subprogram_Id -- ----------------------- *************** package body Exp_Dist is *** 5441,5447 **** Body_Decls : List_Id); -- Add Read attribute for the RACW type. The declaration and attribute -- definition clauses are inserted right after the declaration of ! -- RACW_Type, while the subprogram body is appended to Body_Decls. procedure Add_RACW_Write_Attribute (RACW_Type : Entity_Id; --- 5504,5511 ---- Body_Decls : List_Id); -- Add Read attribute for the RACW type. The declaration and attribute -- definition clauses are inserted right after the declaration of ! -- RACW_Type. If Body_Decls is not No_List, the subprogram body is ! -- appended to it (case where the RACW declaration is in the main unit). procedure Add_RACW_Write_Attribute (RACW_Type : Entity_Id; *************** package body Exp_Dist is *** 5452,5467 **** procedure Add_RACW_From_Any (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; Body_Decls : List_Id); -- Add the From_Any TSS for this RACW type procedure Add_RACW_To_Any ! (Designated_Type : Entity_Id; ! RACW_Type : Entity_Id; ! Stub_Type : Entity_Id; ! Stub_Type_Access : Entity_Id; Body_Decls : List_Id); -- Add the To_Any TSS for this RACW type --- 5516,5526 ---- procedure Add_RACW_From_Any (RACW_Type : Entity_Id; Body_Decls : List_Id); -- Add the From_Any TSS for this RACW type procedure Add_RACW_To_Any ! (RACW_Type : Entity_Id; Body_Decls : List_Id); -- Add the To_Any TSS for this RACW type *************** package body Exp_Dist is *** 5548,5568 **** begin Add_RACW_From_Any (RACW_Type => RACW_Type, - Stub_Type => Stub_Type, - Stub_Type_Access => Stub_Type_Access, Body_Decls => Body_Decls); Add_RACW_To_Any ! (Designated_Type => Desig, ! RACW_Type => RACW_Type, ! Stub_Type => Stub_Type, ! Stub_Type_Access => Stub_Type_Access, Body_Decls => Body_Decls); - -- In the PolyORB case, the RACW 'Read and 'Write attributes are - -- implemented in terms of the From_Any and To_Any TSSs, so these - -- TSSs must be expanded before 'Read and 'Write. - Add_RACW_Write_Attribute (RACW_Type => RACW_Type, Stub_Type => Stub_Type, --- 5607,5618 ---- begin Add_RACW_From_Any (RACW_Type => RACW_Type, Body_Decls => Body_Decls); Add_RACW_To_Any ! (RACW_Type => RACW_Type, Body_Decls => Body_Decls); Add_RACW_Write_Attribute (RACW_Type => RACW_Type, Stub_Type => Stub_Type, *************** package body Exp_Dist is *** 5587,5796 **** procedure Add_RACW_From_Any (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; Body_Decls : List_Id) is Loc : constant Source_Ptr := Sloc (RACW_Type); Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); Fnam : constant Entity_Id := ! Make_Defining_Identifier (Loc, New_Internal_Name ('F')); Func_Spec : Node_Id; Func_Decl : Node_Id; Func_Body : Node_Id; - Decls : List_Id; Statements : List_Id; - Stub_Statements : List_Id; - Local_Statements : List_Id; -- Various parts of the subprogram Any_Parameter : constant Entity_Id := Make_Defining_Identifier (Loc, Name_A); - Reference : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('R')); - Is_Local : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('L')); - Addr : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('A')); - Local_Stub : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('L')); - Stubbed_Result : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('S')); - - Stub_Condition : Node_Id; - -- An expression that determines whether we create a stub for the - -- newly-unpacked RACW. Normally we create a stub only for remote - -- objects, but in the case of an RACW used to implement a RAS, we - -- also create a stub for local subprograms if a pragma - -- All_Calls_Remote applies. Asynchronous_Flag : constant Entity_Id := Asynchronous_Flags_Table.Get (RACW_Type); -- The flag object declared in Add_RACW_Asynchronous_Flag begin - - -- Object declarations - - Decls := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => - Reference, - Object_Definition => - New_Occurrence_Of (RTE (RE_Object_Ref), Loc), - Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Any_Parameter, Loc)))), - - Make_Object_Declaration (Loc, - Defining_Identifier => Local_Stub, - Aliased_Present => True, - Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), - - Make_Object_Declaration (Loc, - Defining_Identifier => Stubbed_Result, - Object_Definition => - New_Occurrence_Of (Stub_Type_Access, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Local_Stub, Loc), - Attribute_Name => - Name_Unchecked_Access)), - - Make_Object_Declaration (Loc, - Defining_Identifier => Is_Local, - Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)), - - Make_Object_Declaration (Loc, - Defining_Identifier => Addr, - Object_Definition => - New_Occurrence_Of (RTE (RE_Address), Loc))); - - -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result - - Set_Etype (Stubbed_Result, Stub_Type_Access); - - -- If the ref Is_Nil, return a null pointer - - Statements := New_List ( - Make_Implicit_If_Statement (RACW_Type, - Condition => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Is_Nil), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Reference, Loc))), - Then_Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Make_Null (Loc))))); - - Append_To (Statements, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Reference, Loc), - New_Occurrence_Of (Is_Local, Loc), - New_Occurrence_Of (Addr, Loc)))); - - -- If the object is located on another partition, then a stub object - -- will be created with all the information needed to rebuild the - -- real object at the other end. This stanza is always used in the - -- case of RAS types, for which a stub is required even for local - -- subprograms. - - Stub_Statements := New_List ( - Make_Assignment_Statement (Loc, - Name => Make_Selected_Component (Loc, - Prefix => Stubbed_Result, - Selector_Name => Name_Target), - Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Entity_Of), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Reference, Loc)))), - - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), - Parameter_Associations => New_List ( - Make_Selected_Component (Loc, - Prefix => Stubbed_Result, - Selector_Name => Name_Target))), - - Make_Assignment_Statement (Loc, - Name => Make_Selected_Component (Loc, - Prefix => Stubbed_Result, - Selector_Name => Name_Asynchronous), - Expression => - New_Occurrence_Of (Asynchronous_Flag, Loc))); - - -- ??? Issue with asynchronous calls here: the Asynchronous flag is - -- set on the stub type if, and only if, the RACW type has a pragma - -- Asynchronous. This is incorrect for RACWs that implement RAS - -- types, because in that case the /designated subprogram/ (not the - -- type) might be asynchronous, and that causes the stub to need to - -- be asynchronous too. A solution is to transport a RAS as a struct - -- containing a RACW and an asynchronous flag, and to properly alter - -- the Asynchronous component in the stub type in the RAS's _From_Any - -- TSS. - - Append_List_To (Stub_Statements, - Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type)); - - -- Distinguish between the local and remote cases, and execute the - -- appropriate piece of code. - - Stub_Condition := New_Occurrence_Of (Is_Local, Loc); - - if Is_RAS then - Stub_Condition := Make_And_Then (Loc, - Left_Opnd => - Stub_Condition, - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To ( - RTE (RE_RAS_Proxy_Type_Access), - New_Occurrence_Of (Addr, Loc)), - Selector_Name => - Make_Identifier (Loc, - Name_All_Calls_Remote))); - end if; - - Local_Statements := New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Unchecked_Convert_To (RACW_Type, - New_Occurrence_Of (Addr, Loc)))); - - Append_To (Statements, - Make_Implicit_If_Statement (RACW_Type, - Condition => - Stub_Condition, - Then_Statements => Local_Statements, - Else_Statements => Stub_Statements)); - - Append_To (Statements, - Make_Simple_Return_Statement (Loc, - Expression => Unchecked_Convert_To (RACW_Type, - New_Occurrence_Of (Stubbed_Result, Loc)))); - Func_Spec := Make_Function_Specification (Loc, Defining_Unit_Name => --- 5637,5666 ---- procedure Add_RACW_From_Any (RACW_Type : Entity_Id; Body_Decls : List_Id) is Loc : constant Source_Ptr := Sloc (RACW_Type); Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); Fnam : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Chars (RACW_Type), 'F')); Func_Spec : Node_Id; Func_Decl : Node_Id; Func_Body : Node_Id; Statements : List_Id; -- Various parts of the subprogram Any_Parameter : constant Entity_Id := Make_Defining_Identifier (Loc, Name_A); Asynchronous_Flag : constant Entity_Id := Asynchronous_Flags_Table.Get (RACW_Type); -- The flag object declared in Add_RACW_Asynchronous_Flag begin Func_Spec := Make_Function_Specification (Loc, Defining_Unit_Name => *************** package body Exp_Dist is *** 5807,5826 **** -- entity in the declaration spec, not those of the body spec. Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); Func_Body := Make_Subprogram_Body (Loc, ! Specification => ! Copy_Specification (Loc, Func_Spec), ! Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Statements)); - Insert_After (Declaration_Node (RACW_Type), Func_Decl); Append_To (Body_Decls, Func_Body); - - Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any); end Add_RACW_From_Any; ----------------------------- --- 5677,5722 ---- -- entity in the declaration spec, not those of the body spec. Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + Insert_After (Declaration_Node (RACW_Type), Func_Decl); + Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any); + + if No (Body_Decls) then + return; + end if; + + -- ??? Issue with asynchronous calls here: the Asynchronous flag is + -- set on the stub type if, and only if, the RACW type has a pragma + -- Asynchronous. This is incorrect for RACWs that implement RAS + -- types, because in that case the /designated subprogram/ (not the + -- type) might be asynchronous, and that causes the stub to need to + -- be asynchronous too. A solution is to transport a RAS as a struct + -- containing a RACW and an asynchronous flag, and to properly alter + -- the Asynchronous component in the stub type in the RAS's _From_Any + -- TSS. + + Statements := New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Unchecked_Convert_To (RACW_Type, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc), + Parameter_Associations => New_List ( + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any_Parameter, Loc))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + New_Occurrence_Of (Asynchronous_Flag, Loc)))))); Func_Body := Make_Subprogram_Body (Loc, ! Specification => Copy_Specification (Loc, Func_Spec), ! Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Statements)); Append_To (Body_Decls, Func_Body); end Add_RACW_From_Any; ----------------------------- *************** package body Exp_Dist is *** 5843,5863 **** Body_Node : Node_Id; ! Decls : List_Id; ! Statements : List_Id; -- Various parts of the procedure ! Procedure_Name : constant Name_Id := ! New_Internal_Name ('R'); ! Source_Ref : constant Entity_Id := ! Make_Defining_Identifier ! (Loc, New_Internal_Name ('R')); Asynchronous_Flag : constant Entity_Id := Asynchronous_Flags_Table.Get (RACW_Type); pragma Assert (Present (Asynchronous_Flag)); function Stream_Parameter return Node_Id; function Result return Node_Id; -- Functions to create occurrences of the formal parameter names ------------ --- 5739,5762 ---- Body_Node : Node_Id; ! Decls : constant List_Id := New_List; ! Statements : constant List_Id := New_List; ! Reference : constant Entity_Id := ! Make_Defining_Identifier (Loc, Name_R); -- Various parts of the procedure ! Pnam : constant Entity_Id := Make_Defining_Identifier (Loc, ! New_Internal_Name ('R')); ! ! Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); ! Asynchronous_Flag : constant Entity_Id := Asynchronous_Flags_Table.Get (RACW_Type); pragma Assert (Present (Asynchronous_Flag)); function Stream_Parameter return Node_Id; function Result return Node_Id; + -- Functions to create occurrences of the formal parameter names ------------ *************** package body Exp_Dist is *** 5881,5934 **** -- Start of processing for Add_RACW_Read_Attribute begin ! -- Generate object declarations ! Decls := New_List ( Make_Object_Declaration (Loc, ! Defining_Identifier => Source_Ref, ! Object_Definition => New_Occurrence_Of (RTE (RE_Object_Ref), Loc))); ! Statements := New_List ( Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (RTE (RE_Object_Ref), Loc), Attribute_Name => Name_Read, Expressions => New_List ( Stream_Parameter, ! New_Occurrence_Of (Source_Ref, Loc))), Make_Assignment_Statement (Loc, ! Name => Result, Expression => ! PolyORB_Support.Helpers.Build_From_Any_Call ( ! RACW_Type, Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), Parameter_Associations => New_List ( ! New_Occurrence_Of (Source_Ref, Loc))), ! Decls))); - Build_Stream_Procedure - (Loc, RACW_Type, Body_Node, - Make_Defining_Identifier (Loc, Procedure_Name), - Statements, Outp => True); Set_Declarations (Body_Node, Decls); - - Proc_Decl := Make_Subprogram_Declaration (Loc, - Copy_Specification (Loc, Specification (Body_Node))); - - Attr_Decl := - Make_Attribute_Definition_Clause (Loc, - Name => New_Occurrence_Of (RACW_Type, Loc), - Chars => Name_Read, - Expression => - New_Occurrence_Of ( - Defining_Unit_Name (Specification (Proc_Decl)), Loc)); - - Insert_After (Declaration_Node (RACW_Type), Proc_Decl); - Insert_After (Proc_Decl, Attr_Decl); Append_To (Body_Decls, Body_Node); end Add_RACW_Read_Attribute; --- 5780,5837 ---- -- Start of processing for Add_RACW_Read_Attribute begin ! Build_Stream_Procedure ! (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True); ! Proc_Decl := Make_Subprogram_Declaration (Loc, ! Copy_Specification (Loc, Specification (Body_Node))); ! ! Attr_Decl := ! Make_Attribute_Definition_Clause (Loc, ! Name => New_Occurrence_Of (RACW_Type, Loc), ! Chars => Name_Read, ! Expression => ! New_Occurrence_Of ( ! Defining_Unit_Name (Specification (Proc_Decl)), Loc)); ! ! Insert_After (Declaration_Node (RACW_Type), Proc_Decl); ! Insert_After (Proc_Decl, Attr_Decl); ! ! if No (Body_Decls) then ! return; ! end if; ! ! Append_To (Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Reference, ! Object_Definition => New_Occurrence_Of (RTE (RE_Object_Ref), Loc))); ! Append_List_To (Statements, New_List ( Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (RTE (RE_Object_Ref), Loc), Attribute_Name => Name_Read, Expressions => New_List ( Stream_Parameter, ! New_Occurrence_Of (Reference, Loc))), ! Make_Assignment_Statement (Loc, ! Name => Result, Expression => ! Unchecked_Convert_To (RACW_Type, Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Get_RACW), Loc), Parameter_Associations => New_List ( ! New_Occurrence_Of (Reference, Loc), ! Build_Stub_Tag (Loc, RACW_Type), ! New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), ! New_Occurrence_Of (Asynchronous_Flag, Loc))))))); Set_Declarations (Body_Node, Decls); Append_To (Body_Decls, Body_Node); end Add_RACW_Read_Attribute; *************** package body Exp_Dist is *** 5937,5957 **** --------------------- procedure Add_RACW_To_Any ! (Designated_Type : Entity_Id; ! RACW_Type : Entity_Id; ! Stub_Type : Entity_Id; ! Stub_Type_Access : Entity_Id; Body_Decls : List_Id) is Loc : constant Source_Ptr := Sloc (RACW_Type); ! Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); ! Fnam : Entity_Id; Stub_Elements : constant Stub_Structure := ! Stubs_Table.Get (Designated_Type); ! pragma Assert (Stub_Elements /= Empty_Stub_Structure); Func_Spec : Node_Id; Func_Decl : Node_Id; --- 5840,5858 ---- --------------------- procedure Add_RACW_To_Any ! (RACW_Type : Entity_Id; Body_Decls : List_Id) is Loc : constant Source_Ptr := Sloc (RACW_Type); ! Fnam : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Chars (RACW_Type), 'T')); ! Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); Stub_Elements : constant Stub_Structure := ! Get_Stub_Elements (RACW_Type); Func_Spec : Node_Id; Func_Decl : Node_Id; *************** package body Exp_Dist is *** 5959,5972 **** Decls : List_Id; Statements : List_Id; - Null_Statements : List_Id; - Local_Statements : List_Id := No_List; - Stub_Statements : List_Id; - If_Node : Node_Id; -- Various parts of the subprogram ! RACW_Parameter : constant Entity_Id ! := Make_Defining_Identifier (Loc, Name_R); Reference : constant Entity_Id := Make_Defining_Identifier --- 5860,5869 ---- Decls : List_Id; Statements : List_Id; -- Various parts of the subprogram ! RACW_Parameter : constant Entity_Id := ! Make_Defining_Identifier (Loc, Name_R); Reference : constant Entity_Id := Make_Defining_Identifier *************** package body Exp_Dist is *** 5976,6096 **** (Loc, New_Internal_Name ('A')); begin ! -- Object declarations ! ! Decls := New_List ( ! Make_Object_Declaration (Loc, ! Defining_Identifier => ! Reference, ! Object_Definition => ! New_Occurrence_Of (RTE (RE_Object_Ref), Loc)), ! Make_Object_Declaration (Loc, ! Defining_Identifier => ! Any, ! Object_Definition => ! New_Occurrence_Of (RTE (RE_Any), Loc))); ! ! -- If the object is null, nothing to do (Reference is already ! -- a Nil ref.) ! ! Null_Statements := New_List (Make_Null_Statement (Loc)); ! if Is_RAS then ! -- If the object is a RAS designating a local subprogram, we ! -- already have a target reference. ! Local_Statements := New_List ( ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Set_Ref), Loc), ! Parameter_Associations => New_List ( ! New_Occurrence_Of (Reference, Loc), ! Make_Selected_Component (Loc, ! Prefix => ! Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), ! New_Occurrence_Of (RACW_Parameter, Loc)), ! Selector_Name => Make_Identifier (Loc, Name_Target))))); ! else ! -- If the object is a local RACW object, use Get_Reference now to ! -- obtain a reference. ! Local_Statements := New_List ( ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Get_Reference), Loc), ! Parameter_Associations => New_List ( ! Unchecked_Convert_To ( ! RTE (RE_Address), ! New_Occurrence_Of (RACW_Parameter, Loc)), ! Make_String_Literal (Loc, ! Full_Qualified_Name (Designated_Type)), ! Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of ( ! Defining_Identifier ( ! Stub_Elements.RPC_Receiver_Decl), Loc), ! Attribute_Name => ! Name_Access), ! New_Occurrence_Of (Reference, Loc)))); ! end if; ! -- If the object is located on another partition, use the target from ! -- the stub. ! Stub_Statements := New_List ( ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Set_Ref), Loc), ! Parameter_Associations => New_List ( ! New_Occurrence_Of (Reference, Loc), ! Make_Selected_Component (Loc, ! Prefix => Unchecked_Convert_To (Stub_Type_Access, ! New_Occurrence_Of (RACW_Parameter, Loc)), ! Selector_Name => ! Make_Identifier (Loc, Name_Target))))); ! -- Distinguish between the null, local and remote cases, and execute ! -- the appropriate piece of code. ! If_Node := ! Make_Implicit_If_Statement (RACW_Type, ! Condition => ! Make_Op_Eq (Loc, ! Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc), ! Right_Opnd => Make_Null (Loc)), ! Then_Statements => Null_Statements, ! Elsif_Parts => New_List ( ! Make_Elsif_Part (Loc, ! Condition => ! Make_Op_Ne (Loc, ! Left_Opnd => ! Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (RACW_Parameter, Loc), ! Attribute_Name => Name_Tag), ! Right_Opnd => ! Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Stub_Type, Loc), ! Attribute_Name => Name_Tag)), ! Then_Statements => Local_Statements)), ! Else_Statements => Stub_Statements); Statements := New_List ( - If_Node, Make_Assignment_Statement (Loc, ! Name => ! New_Occurrence_Of (Any, Loc), Expression => Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Reference, Loc)))), Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Set_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), Make_Selected_Component (Loc, --- 5873,5958 ---- (Loc, New_Internal_Name ('A')); begin + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + RACW_Parameter, + Parameter_Type => + New_Occurrence_Of (RACW_Type, Loc))), + Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); ! -- NOTE: The usage occurrences of RACW_Parameter must refer to the ! -- entity in the declaration spec, not in the body spec. ! Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); ! Insert_After (Declaration_Node (RACW_Type), Func_Decl); ! Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any); ! if No (Body_Decls) then ! return; ! end if; ! -- Generate: ! -- R : constant Object_Ref := ! -- Get_Reference ! -- (Address!(RACW), ! -- "typ", ! -- Stub_Type'Tag, ! -- Is_RAS, ! -- RPC_Receiver'Access); ! -- A : Any; ! Decls := New_List ( ! Make_Object_Declaration (Loc, ! Defining_Identifier => Reference, ! Constant_Present => True, ! Object_Definition => ! New_Occurrence_Of (RTE (RE_Object_Ref), Loc), ! Expression => ! Make_Function_Call (Loc, ! Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), ! Parameter_Associations => New_List ( ! Unchecked_Convert_To (RTE (RE_Address), ! New_Occurrence_Of (RACW_Parameter, Loc)), ! Make_String_Literal (Loc, ! Strval => Full_Qualified_Name ! (Etype (Designated_Type (RACW_Type)))), ! Build_Stub_Tag (Loc, RACW_Type), ! New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), ! Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of ! (Defining_Identifier ! (Stub_Elements.RPC_Receiver_Decl), Loc), ! Attribute_Name => Name_Access)))), ! Make_Object_Declaration (Loc, ! Defining_Identifier => Any, ! Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc))); ! -- Generate: ! -- Any := TA_ObjRef (Reference); ! -- Set_TC (Any, RPC_Receiver.Obj_TypeCode); ! -- return Any; Statements := New_List ( Make_Assignment_Statement (Loc, ! Name => New_Occurrence_Of (Any, Loc), Expression => Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Reference, Loc)))), + Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), Make_Selected_Component (Loc, *************** package body Exp_Dist is *** 6098,6140 **** Defining_Identifier ( Stub_Elements.RPC_Receiver_Decl), Selector_Name => Name_Obj_TypeCode))), - Make_Simple_Return_Statement (Loc, - Expression => - New_Occurrence_Of (Any, Loc))); ! Fnam := Make_Defining_Identifier ( ! Loc, New_Internal_Name ('T')); ! ! Func_Spec := ! Make_Function_Specification (Loc, ! Defining_Unit_Name => ! Fnam, ! Parameter_Specifications => New_List ( ! Make_Parameter_Specification (Loc, ! Defining_Identifier => ! RACW_Parameter, ! Parameter_Type => ! New_Occurrence_Of (RACW_Type, Loc))), ! Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); ! ! -- NOTE: The usage occurrences of RACW_Parameter must refer to the ! -- entity in the declaration spec, not in the body spec. ! ! Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); Func_Body := Make_Subprogram_Body (Loc, ! Specification => ! Copy_Specification (Loc, Func_Spec), Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Statements)); - - Insert_After (Declaration_Node (RACW_Type), Func_Decl); Append_To (Body_Decls, Func_Body); - - Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any); end Add_RACW_To_Any; ----------------------- --- 5960,5977 ---- Defining_Identifier ( Stub_Elements.RPC_Receiver_Decl), Selector_Name => Name_Obj_TypeCode))), ! Make_Simple_Return_Statement (Loc, ! Expression => New_Occurrence_Of (Any, Loc))); Func_Body := Make_Subprogram_Body (Loc, ! Specification => Copy_Specification (Loc, Func_Spec), Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Statements)); Append_To (Body_Decls, Func_Body); end Add_RACW_To_Any; ----------------------- *************** package body Exp_Dist is *** 6148,6154 **** is Loc : constant Source_Ptr := Sloc (RACW_Type); ! Fnam : Entity_Id; Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Designated_Type); --- 5985,5993 ---- is Loc : constant Source_Ptr := Sloc (RACW_Type); ! Fnam : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Chars (RACW_Type), 'Y')); Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Designated_Type); *************** package body Exp_Dist is *** 6159,6186 **** Func_Body : Node_Id; begin - Fnam := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); -- The spec for this subprogram has a dummy 'access RACW' argument, -- which serves only for overloading purposes. Func_Spec := Make_Function_Specification (Loc, ! Defining_Unit_Name => ! Fnam, ! Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); -- NOTE: The usage occurrences of RACW_Parameter must refer to the -- entity in the declaration spec, not those of the body spec. Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); Func_Body := Make_Subprogram_Body (Loc, ! Specification => ! Copy_Specification (Loc, Func_Spec), Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, --- 5998,6026 ---- Func_Body : Node_Id; begin -- The spec for this subprogram has a dummy 'access RACW' argument, -- which serves only for overloading purposes. Func_Spec := Make_Function_Specification (Loc, ! Defining_Unit_Name => Fnam, ! Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); -- NOTE: The usage occurrences of RACW_Parameter must refer to the -- entity in the declaration spec, not those of the body spec. Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + Insert_After (Declaration_Node (RACW_Type), Func_Decl); + Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode); + + if No (Body_Decls) then + return; + end if; Func_Body := Make_Subprogram_Body (Loc, ! Specification => Copy_Specification (Loc, Func_Spec), Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, *************** package body Exp_Dist is *** 6189,6202 **** Expression => Make_Selected_Component (Loc, Prefix => ! Defining_Identifier ( ! Stub_Elements.RPC_Receiver_Decl), Selector_Name => Name_Obj_TypeCode))))); - Insert_After (Declaration_Node (RACW_Type), Func_Decl); Append_To (Body_Decls, Func_Body); - - Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode); end Add_RACW_TypeCode; ------------------------------ --- 6029,6039 ---- Expression => Make_Selected_Component (Loc, Prefix => ! Defining_Identifier ! (Stub_Elements.RPC_Receiver_Decl), Selector_Name => Name_Obj_TypeCode))))); Append_To (Body_Decls, Func_Body); end Add_RACW_TypeCode; ------------------------------ *************** package body Exp_Dist is *** 6215,6226 **** Loc : constant Source_Ptr := Sloc (RACW_Type); Body_Node : Node_Id; Proc_Decl : Node_Id; Attr_Decl : Node_Id; ! Statements : List_Id; ! Procedure_Name : constant Name_Id := New_Internal_Name ('R'); function Stream_Parameter return Node_Id; function Object return Node_Id; --- 6052,6069 ---- Loc : constant Source_Ptr := Sloc (RACW_Type); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + Stub_Elements : constant Stub_Structure := + Get_Stub_Elements (RACW_Type); + Body_Node : Node_Id; Proc_Decl : Node_Id; Attr_Decl : Node_Id; ! Statements : constant List_Id := New_List; ! Pnam : constant Entity_Id := ! Make_Defining_Identifier (Loc, New_Internal_Name ('R')); function Stream_Parameter return Node_Id; function Object return Node_Id; *************** package body Exp_Dist is *** 6231,6245 **** ------------ function Object return Node_Id is - Object_Ref : constant Node_Id := - Make_Identifier (Loc, Name_V); - begin ! -- Etype must be set for Build_To_Any_Call ! ! Set_Etype (Object_Ref, RACW_Type); ! ! return Object_Ref; end Object; ---------------------- --- 6074,6081 ---- ------------ function Object return Node_Id is begin ! return Make_Identifier (Loc, Name_V); end Object; ---------------------- *************** package body Exp_Dist is *** 6254,6275 **** -- Start of processing for Add_RACW_Write_Attribute begin - Statements := New_List ( - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), - Parameter_Associations => New_List ( - PolyORB_Support.Helpers.Build_To_Any_Call - (Object, Body_Decls))), - Etyp => RTE (RE_Object_Ref))); - Build_Stream_Procedure ! (Loc, RACW_Type, Body_Node, ! Make_Defining_Identifier (Loc, Procedure_Name), ! Statements, Outp => False); Proc_Decl := Make_Subprogram_Declaration (Loc, --- 6090,6097 ---- -- Start of processing for Add_RACW_Write_Attribute begin Build_Stream_Procedure ! (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); Proc_Decl := Make_Subprogram_Declaration (Loc, *************** package body Exp_Dist is *** 6285,6290 **** --- 6107,6139 ---- Insert_After (Declaration_Node (RACW_Type), Proc_Decl); Insert_After (Proc_Decl, Attr_Decl); + + if No (Body_Decls) then + return; + end if; + + Append_To (Statements, + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), Object), + Make_String_Literal (Loc, + Strval => Full_Qualified_Name + (Etype (Designated_Type (RACW_Type)))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier + (Stub_Elements.RPC_Receiver_Decl), Loc), + Attribute_Name => Name_Access))), + + Etyp => RTE (RE_Object_Ref))); + Append_To (Body_Decls, Body_Node); end Add_RACW_Write_Attribute; *************** package body Exp_Dist is *** 6320,6332 **** -- corresponding record type. RACW_Type : constant Entity_Id := ! Underlying_RACW_Type (Ras_Type); ! Desig : constant Entity_Id := ! Etype (Designated_Type (RACW_Type)); Stub_Elements : constant Stub_Structure := ! Stubs_Table.Get (Desig); ! pragma Assert (Stub_Elements /= Empty_Stub_Structure); Proc : constant Entity_Id := Make_Defining_Identifier (Loc, --- 6169,6178 ---- -- corresponding record type. RACW_Type : constant Entity_Id := ! Underlying_RACW_Type (Ras_Type); Stub_Elements : constant Stub_Structure := ! Get_Stub_Elements (RACW_Type); Proc : constant Entity_Id := Make_Defining_Identifier (Loc, *************** package body Exp_Dist is *** 6438,6445 **** New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), Make_Object_Declaration (Loc, ! Defining_Identifier => ! Stub_Ptr, Object_Definition => New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), Expression => --- 6284,6290 ---- New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), Make_Object_Declaration (Loc, ! Defining_Identifier => Stub_Ptr, Object_Definition => New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), Expression => *************** package body Exp_Dist is *** 6455,6462 **** Proc_Statements := New_List ( Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc), New_Occurrence_Of (Subp_Id, Loc), --- 6300,6306 ---- Proc_Statements := New_List ( Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc), New_Occurrence_Of (Subp_Id, Loc), *************** package body Exp_Dist is *** 6467,6474 **** -- obtain the local address of its proxy (A). Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc), New_Occurrence_Of (Is_Local, Loc), --- 6311,6317 ---- -- obtain the local address of its proxy (A). Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc), New_Occurrence_Of (Is_Local, Loc), *************** package body Exp_Dist is *** 6482,6489 **** -- if L then Make_Implicit_If_Statement (N, ! Condition => ! New_Occurrence_Of (Is_Local, Loc), Then_Statements => New_List ( --- 6325,6331 ---- -- if L then Make_Implicit_If_Statement (N, ! Condition => New_Occurrence_Of (Is_Local, Loc), Then_Statements => New_List ( *************** package body Exp_Dist is *** 6493,6504 **** Condition => Make_Op_Eq (Loc, Make_Selected_Component (Loc, ! Prefix => ! Unchecked_Convert_To ( ! RTE (RE_RAS_Proxy_Type_Access), ! New_Occurrence_Of (Local_Addr, Loc)), ! Selector_Name => ! Make_Identifier (Loc, Name_Target)), Make_Null (Loc)), Then_Statements => New_List ( --- 6335,6345 ---- Condition => Make_Op_Eq (Loc, Make_Selected_Component (Loc, ! Prefix => ! Unchecked_Convert_To ! (RTE (RE_RAS_Proxy_Type_Access), ! New_Occurrence_Of (Local_Addr, Loc)), ! Selector_Name => Make_Identifier (Loc, Name_Target)), Make_Null (Loc)), Then_Statements => New_List ( *************** package body Exp_Dist is *** 6508,6539 **** Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, ! Prefix => ! Unchecked_Convert_To ( ! RTE (RE_RAS_Proxy_Type_Access), ! New_Occurrence_Of (Local_Addr, Loc)), ! Selector_Name => ! Make_Identifier (Loc, Name_Target)), Expression => Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Entity_Of), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc)))), -- Inc_Usage (A.Target); Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => ! Unchecked_Convert_To ( ! RTE (RE_RAS_Proxy_Type_Access), ! New_Occurrence_Of (Local_Addr, Loc)), ! Selector_Name => Make_Identifier (Loc, ! Name_Target)))))), -- end if; -- if not All_Calls_Remote then --- 6349,6377 ---- Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, ! Prefix => ! Unchecked_Convert_To ! (RTE (RE_RAS_Proxy_Type_Access), ! New_Occurrence_Of (Local_Addr, Loc)), ! Selector_Name => Make_Identifier (Loc, Name_Target)), Expression => Make_Function_Call (Loc, ! Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc)))), -- Inc_Usage (A.Target); Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => ! Unchecked_Convert_To ! (RTE (RE_RAS_Proxy_Type_Access), ! New_Occurrence_Of (Local_Addr, Loc)), ! Selector_Name => ! Make_Identifier (Loc, Name_Target)))))), -- end if; -- if not All_Calls_Remote then *************** package body Exp_Dist is *** 6543,6554 **** Make_Implicit_If_Statement (N, Condition => Make_Op_Not (Loc, ! New_Occurrence_Of (All_Calls_Remote, Loc)), Then_Statements => New_List ( Make_Simple_Return_Statement (Loc, ! Unchecked_Convert_To (Fat_Type, ! New_Occurrence_Of (Local_Addr, Loc)))))))); Append_List_To (Proc_Statements, New_List ( --- 6381,6394 ---- Make_Implicit_If_Statement (N, Condition => Make_Op_Not (Loc, ! Right_Opnd => ! New_Occurrence_Of (All_Calls_Remote, Loc)), Then_Statements => New_List ( Make_Simple_Return_Statement (Loc, ! Expression => ! Unchecked_Convert_To ! (Fat_Type, New_Occurrence_Of (Local_Addr, Loc)))))))); Append_List_To (Proc_Statements, New_List ( *************** package body Exp_Dist is *** 6556,6571 **** Set_Field (Name_Target, Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Entity_Of), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc)))), -- Inc_Usage (Stub.Target); Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => Stub_Ptr, --- 6396,6409 ---- Set_Field (Name_Target, Make_Function_Call (Loc, ! Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc)))), -- Inc_Usage (Stub.Target); Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => Stub_Ptr, *************** package body Exp_Dist is *** 6580,6592 **** Set_Field (Name_Asynchronous, Make_Or_Else (Loc, ! New_Occurrence_Of (Asynch_P, Loc), ! New_Occurrence_Of (Boolean_Literals ( ! Is_Asynchronous (Ras_Type)), Loc))))); Append_List_To (Proc_Statements, ! Build_Get_Unique_RP_Call (Loc, ! Stub_Ptr, Stub_Elements.Stub_Type)); Append_To (Proc_Statements, Make_Simple_Return_Statement (Loc, --- 6418,6430 ---- Set_Field (Name_Asynchronous, Make_Or_Else (Loc, ! Left_Opnd => New_Occurrence_Of (Asynch_P, Loc), ! Right_Opnd => ! New_Occurrence_Of ! (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc))))); Append_List_To (Proc_Statements, ! Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); Append_To (Proc_Statements, Make_Simple_Return_Statement (Loc, *************** package body Exp_Dist is *** 6672,6685 **** Func_Spec := Make_Function_Specification (Loc, ! Defining_Unit_Name => ! Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Any_Parameter, ! Parameter_Type => ! New_Occurrence_Of (RTE (RE_Any), Loc))), Result_Definition => New_Occurrence_Of (RAS_Type, Loc)); Discard_Node ( --- 6510,6520 ---- Func_Spec := Make_Function_Specification (Loc, ! Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, ! Defining_Identifier => Any_Parameter, ! Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), Result_Definition => New_Occurrence_Of (RAS_Type, Loc)); Discard_Node ( *************** package body Exp_Dist is *** 6724,6759 **** Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type)); Decls := New_List ( Make_Object_Declaration (Loc, ! Defining_Identifier => ! Any, ! Object_Definition => ! New_Occurrence_Of (RTE (RE_Any), Loc), ! Expression => PolyORB_Support.Helpers.Build_To_Any_Call (RACW_Parameter, No_List))); Statements := New_List ( Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Set_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, RAS_Type, Decls))), Make_Simple_Return_Statement (Loc, ! Expression => ! New_Occurrence_Of (Any, Loc))); Func_Spec := Make_Function_Specification (Loc, ! Defining_Unit_Name => ! Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, ! Defining_Identifier => ! RAS_Parameter, ! Parameter_Type => ! New_Occurrence_Of (RAS_Type, Loc))), Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); Discard_Node ( --- 6559,6588 ---- Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type)); Decls := New_List ( Make_Object_Declaration (Loc, ! Defining_Identifier => Any, ! Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), ! Expression => PolyORB_Support.Helpers.Build_To_Any_Call (RACW_Parameter, No_List))); Statements := New_List ( Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, RAS_Type, Decls))), + Make_Simple_Return_Statement (Loc, ! Expression => New_Occurrence_Of (Any, Loc))); Func_Spec := Make_Function_Specification (Loc, ! Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, ! Defining_Identifier => RAS_Parameter, ! Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))), Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); Discard_Node ( *************** package body Exp_Dist is *** 6776,6792 **** Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, Make_TSS_Name (RAS_Type, TSS_TypeCode)); ! Func_Spec : Node_Id; ! ! Decls : constant List_Id := New_List; ! Name_String, Repo_Id_String : String_Id; begin Func_Spec := Make_Function_Specification (Loc, ! Defining_Unit_Name => ! Fnam, ! Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); PolyORB_Support.Helpers.Build_Name_And_Repository_Id (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String); --- 6605,6620 ---- Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, Make_TSS_Name (RAS_Type, TSS_TypeCode)); ! Func_Spec : Node_Id; ! Decls : constant List_Id := New_List; ! Name_String : String_Id; ! Repo_Id_String : String_Id; begin Func_Spec := Make_Function_Specification (Loc, ! Defining_Unit_Name => Fnam, ! Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); PolyORB_Support.Helpers.Build_Name_And_Repository_Id (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String); *************** package body Exp_Dist is *** 6801,6824 **** Make_Simple_Return_Statement (Loc, Expression => Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_TC_Build), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (RTE (RE_TC_Object), Loc), Make_Aggregate (Loc, Expressions => New_List ( Make_Function_Call (Loc, ! Name => New_Occurrence_Of ( ! RTE (RE_TA_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, Name_String))), Make_Function_Call (Loc, ! Name => New_Occurrence_Of ( ! RTE (RE_TA_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, ! Repo_Id_String)))))))))))); Set_TSS (RAS_Type, Fnam); end Add_RAS_TypeCode; --- 6629,6653 ---- Make_Simple_Return_Statement (Loc, Expression => Make_Function_Call (Loc, ! Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (RTE (RE_TC_Object), Loc), Make_Aggregate (Loc, Expressions => New_List ( Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of ! (RTE (RE_TA_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, Name_String))), Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of ! (RTE (RE_TA_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, ! Strval => Repo_Id_String)))))))))))); Set_TSS (RAS_Type, Fnam); end Add_RAS_TypeCode; *************** package body Exp_Dist is *** 6837,6850 **** Make_Defining_Identifier (Loc, New_Internal_Name ('H')); Pkg_RPC_Receiver_Object : Node_Id; - Pkg_RPC_Receiver_Body : Node_Id; Pkg_RPC_Receiver_Decls : List_Id; Pkg_RPC_Receiver_Statements : List_Id; ! Pkg_RPC_Receiver_Cases : constant List_Id := New_List; -- A Pkg_RPC_Receiver is built to decode the request ! Request : Node_Id; -- Request object received from neutral layer Subp_Id : Entity_Id; --- 6666,6679 ---- Make_Defining_Identifier (Loc, New_Internal_Name ('H')); Pkg_RPC_Receiver_Object : Node_Id; Pkg_RPC_Receiver_Body : Node_Id; Pkg_RPC_Receiver_Decls : List_Id; Pkg_RPC_Receiver_Statements : List_Id; ! ! Pkg_RPC_Receiver_Cases : constant List_Id := New_List; -- A Pkg_RPC_Receiver is built to decode the request ! Request : Node_Id; -- Request object received from neutral layer Subp_Id : Entity_Id; *************** package body Exp_Dist is *** 6852,6867 **** -- distribution core. Subp_Index : Entity_Id; ! -- Internal index as determined by matching either the ! -- method name from the request structure, or the local ! -- subprogram address (in case of a RAS). Is_Local : constant Entity_Id := ! Make_Defining_Identifier (Loc, New_Internal_Name ('L')); Local_Address : constant Entity_Id := ! Make_Defining_Identifier (Loc, New_Internal_Name ('A')); ! -- Address of a local subprogram designated by a ! -- reference corresponding to a RAS. Dispatch_On_Address : constant List_Id := New_List; Dispatch_On_Name : constant List_Id := New_List; --- 6681,6699 ---- -- distribution core. Subp_Index : Entity_Id; ! -- Internal index as determined by matching either the method name ! -- from the request structure, or the local subprogram address (in ! -- case of a RAS). Is_Local : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('L')); ! Local_Address : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('A')); ! -- Address of a local subprogram designated by a reference ! -- corresponding to a RAS. Dispatch_On_Address : constant List_Id := New_List; Dispatch_On_Name : constant List_Id := New_List; *************** package body Exp_Dist is *** 6916,6923 **** Defining_Entity (Stubs), Loc), Parameter_Associations => New_List (New_Occurrence_Of (Request, Loc)))); ! if Nkind (Specification (Declaration)) ! = N_Function_Specification or else not Is_Asynchronous (Defining_Entity (Specification (Declaration))) then --- 6748,6755 ---- Defining_Entity (Stubs), Loc), Parameter_Associations => New_List (New_Occurrence_Of (Request, Loc)))); ! ! if Nkind (Specification (Declaration)) = N_Function_Specification or else not Is_Asynchronous (Defining_Entity (Specification (Declaration))) then *************** package body Exp_Dist is *** 6928,6935 **** Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Integer_Literal (Loc, Subp_Number)), ! Statements => ! Case_Stmts)); Append_To (Dispatch_On_Name, Make_Elsif_Part (Loc, --- 6760,6766 ---- Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Integer_Literal (Loc, Subp_Number)), ! Statements => Case_Stmts)); Append_To (Dispatch_On_Name, Make_Elsif_Part (Loc, *************** package body Exp_Dist is *** 6940,6964 **** Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Id, Loc), New_Occurrence_Of (Subp_Dist_Name, Loc))), Then_Statements => New_List ( Make_Assignment_Statement (Loc, New_Occurrence_Of (Subp_Index, Loc), ! Make_Integer_Literal (Loc, ! Subp_Number))))); Append_To (Dispatch_On_Address, Make_Elsif_Part (Loc, Condition => Make_Op_Eq (Loc, ! Left_Opnd => ! New_Occurrence_Of (Local_Address, Loc), ! Right_Opnd => ! New_Occurrence_Of (Subp_Proxy_Addr, Loc)), Then_Statements => New_List ( Make_Assignment_Statement (Loc, New_Occurrence_Of (Subp_Index, Loc), ! Make_Integer_Literal (Loc, ! Subp_Number))))); end Append_Stubs_To; -- Start of processing for Add_Receiving_Stubs_To_Declarations --- 6771,6793 ---- Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Id, Loc), New_Occurrence_Of (Subp_Dist_Name, Loc))), + Then_Statements => New_List ( Make_Assignment_Statement (Loc, New_Occurrence_Of (Subp_Index, Loc), ! Make_Integer_Literal (Loc, Subp_Number))))); Append_To (Dispatch_On_Address, Make_Elsif_Part (Loc, Condition => Make_Op_Eq (Loc, ! Left_Opnd => New_Occurrence_Of (Local_Address, Loc), ! Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)), ! Then_Statements => New_List ( Make_Assignment_Statement (Loc, New_Occurrence_Of (Subp_Index, Loc), ! Make_Integer_Literal (Loc, Subp_Number))))); end Append_Stubs_To; -- Start of processing for Add_Receiving_Stubs_To_Declarations *************** package body Exp_Dist is *** 6996,7015 **** Append_To (Pkg_RPC_Receiver_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Is_Local, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc))); Append_To (Pkg_RPC_Receiver_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Local_Address, Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); Append_To (Pkg_RPC_Receiver_Statements, Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => Request, --- 6825,6843 ---- Append_To (Pkg_RPC_Receiver_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Is_Local, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc))); + Append_To (Pkg_RPC_Receiver_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Local_Address, Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); + Append_To (Pkg_RPC_Receiver_Statements, Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => Request, *************** package body Exp_Dist is *** 7044,7054 **** Subp_Val : String_Id; Subp_Dist_Name : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! New_External_Name ( ! Related_Id => Chars (Subp_Def), ! Suffix => 'D', ! Suffix_Index => -1)); Proxy_Object_Addr : Entity_Id; --- 6872,6883 ---- Subp_Val : String_Id; Subp_Dist_Name : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => ! New_External_Name ! (Related_Id => Chars (Subp_Def), ! Suffix => 'D', ! Suffix_Index => -1)); Proxy_Object_Addr : Entity_Id; *************** package body Exp_Dist is *** 7069,7097 **** -- Build RAS proxy Add_RAS_Proxy_And_Analyze (Decls, ! Vis_Decl => ! Current_Declaration, ! All_Calls_Remote_E => ! All_Calls_Remote_E, ! Proxy_Object_Addr => ! Proxy_Object_Addr); -- Compute distribution identifier ! Assign_Subprogram_Identifier ( ! Subp_Def, ! Current_Subprogram_Number, ! Subp_Val); ! pragma Assert (Current_Subprogram_Number = ! Get_Subprogram_Id (Subp_Def)); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Subp_Dist_Name, Constant_Present => True, ! Object_Definition => New_Occurrence_Of ( ! Standard_String, Loc), Expression => Make_String_Literal (Loc, Subp_Val))); Analyze (Last (Decls)); --- 6898,6923 ---- -- Build RAS proxy Add_RAS_Proxy_And_Analyze (Decls, ! Vis_Decl => Current_Declaration, ! All_Calls_Remote_E => All_Calls_Remote_E, ! Proxy_Object_Addr => Proxy_Object_Addr); -- Compute distribution identifier ! Assign_Subprogram_Identifier ! (Subp_Def, ! Current_Subprogram_Number, ! Subp_Val); ! pragma Assert ! (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def)); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Subp_Dist_Name, Constant_Present => True, ! Object_Definition => ! New_Occurrence_Of (Standard_String, Loc), Expression => Make_String_Literal (Loc, Subp_Val))); Analyze (Last (Decls)); *************** package body Exp_Dist is *** 7104,7124 **** Append_To (Subp_Info_List, Make_Component_Association (Loc, Choices => New_List ( ! Make_Integer_Literal (Loc, ! Current_Subprogram_Number)), Expression => Make_Aggregate (Loc, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => ! New_Occurrence_Of ( ! Subp_Dist_Name, Loc), Attribute_Name => Name_Address), Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of ( ! Subp_Dist_Name, Loc), Attribute_Name => Name_Length), New_Occurrence_Of (Proxy_Object_Addr, Loc))))); Append_Stubs_To (Pkg_RPC_Receiver_Cases, --- 6930,6950 ---- Append_To (Subp_Info_List, Make_Component_Association (Loc, Choices => New_List ( ! Make_Integer_Literal (Loc, Current_Subprogram_Number)), ! Expression => Make_Aggregate (Loc, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => ! New_Occurrence_Of (Subp_Dist_Name, Loc), Attribute_Name => Name_Address), + Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Subp_Dist_Name, Loc), Attribute_Name => Name_Length), + New_Occurrence_Of (Proxy_Object_Addr, Loc))))); Append_Stubs_To (Pkg_RPC_Receiver_Cases, *************** package body Exp_Dist is *** 7148,7159 **** Make_Index_Or_Discriminant_Constraint (Loc, New_List ( Make_Range (Loc, ! Low_Bound => Make_Integer_Literal (Loc, ! First_RCI_Subprogram_Id), High_Bound => Make_Integer_Literal (Loc, ! First_RCI_Subprogram_Id ! + List_Length (Subp_Info_List) - 1))))))); if Present (First (Subp_Info_List)) then Set_Expression (Last (Decls), --- 6974,6987 ---- Make_Index_Or_Discriminant_Constraint (Loc, New_List ( Make_Range (Loc, ! Low_Bound => ! Make_Integer_Literal (Loc, ! Intval => First_RCI_Subprogram_Id), High_Bound => Make_Integer_Literal (Loc, ! Intval => ! First_RCI_Subprogram_Id ! + List_Length (Subp_Info_List) - 1))))))); if Present (First (Subp_Info_List)) then Set_Expression (Last (Decls), *************** package body Exp_Dist is *** 7179,7205 **** Make_Implicit_If_Statement (Pkg_Spec, Condition => Make_Op_Ne (Loc, ! Left_Opnd => New_Occurrence_Of ! (Local_Address, Loc), Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)), Then_Statements => New_List ( Make_Implicit_If_Statement (Pkg_Spec, ! Condition => ! New_Occurrence_Of (Standard_False, Loc), Then_Statements => New_List ( Make_Null_Statement (Loc)), ! Elsif_Parts => ! Dispatch_On_Address)), Else_Statements => New_List ( Make_Implicit_If_Statement (Pkg_Spec, ! Condition => ! New_Occurrence_Of (Standard_False, Loc), ! Then_Statements => New_List ( ! Make_Null_Statement (Loc)), ! Elsif_Parts => ! Dispatch_On_Name)))); else -- For a degenerate RCI with no visible subprograms, --- 7007,7028 ---- Make_Implicit_If_Statement (Pkg_Spec, Condition => Make_Op_Ne (Loc, ! Left_Opnd => New_Occurrence_Of (Local_Address, Loc), Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)), + Then_Statements => New_List ( Make_Implicit_If_Statement (Pkg_Spec, ! Condition => New_Occurrence_Of (Standard_False, Loc), Then_Statements => New_List ( Make_Null_Statement (Loc)), ! Elsif_Parts => Dispatch_On_Address)), Else_Statements => New_List ( Make_Implicit_If_Statement (Pkg_Spec, ! Condition => New_Occurrence_Of (Standard_False, Loc), ! Then_Statements => New_List (Make_Null_Statement (Loc)), ! Elsif_Parts => Dispatch_On_Name)))); else -- For a degenerate RCI with no visible subprograms, *************** package body Exp_Dist is *** 7227,7241 **** Append_To (Pkg_RPC_Receiver_Cases, Make_Case_Statement_Alternative (Loc, ! Discrete_Choices => ! New_List (Make_Others_Choice (Loc)), ! Statements => ! New_List (Make_Null_Statement (Loc)))); Append_To (Pkg_RPC_Receiver_Statements, Make_Case_Statement (Loc, ! Expression => ! New_Occurrence_Of (Subp_Index, Loc), Alternatives => Pkg_RPC_Receiver_Cases)); -- Pkg_RPC_Receiver body is now complete: insert it into the tree and --- 7050,7061 ---- Append_To (Pkg_RPC_Receiver_Cases, Make_Case_Statement_Alternative (Loc, ! Discrete_Choices => New_List (Make_Others_Choice (Loc)), ! Statements => New_List (Make_Null_Statement (Loc)))); Append_To (Pkg_RPC_Receiver_Statements, Make_Case_Statement (Loc, ! Expression => New_Occurrence_Of (Subp_Index, Loc), Alternatives => Pkg_RPC_Receiver_Cases)); -- Pkg_RPC_Receiver body is now complete: insert it into the tree and *************** package body Exp_Dist is *** 7249,7318 **** Defining_Identifier => Make_Defining_Identifier (Loc, New_Internal_Name ('R')), Aliased_Present => True, ! Object_Definition => ! New_Occurrence_Of (RTE (RE_Servant), Loc)); Append_To (Decls, Pkg_RPC_Receiver_Object); Analyze (Last (Decls)); Get_Library_Unit_Name_String (Pkg_Spec); Append_To (Register_Pkg_Actuals, - -- Name Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); Append_To (Register_Pkg_Actuals, - -- Version Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), ! Attribute_Name => ! Name_Version)); Append_To (Register_Pkg_Actuals, - -- Handler Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), Attribute_Name => Name_Access)); Append_To (Register_Pkg_Actuals, - -- Receiver Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of ( ! Defining_Identifier ( ! Pkg_RPC_Receiver_Object), Loc), ! Attribute_Name => ! Name_Access)); Append_To (Register_Pkg_Actuals, - -- Subp_Info Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Subp_Info_Array, Loc), ! Attribute_Name => ! Name_Address)); Append_To (Register_Pkg_Actuals, - -- Subp_Info_Len Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Subp_Info_Array, Loc), ! Attribute_Name => ! Name_Length)); Append_To (Register_Pkg_Actuals, - -- Is_All_Calls_Remote New_Occurrence_Of (All_Calls_Remote_E, Loc)); Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc), Parameter_Associations => Register_Pkg_Actuals)); Analyze (Last (Stmts)); - end Add_Receiving_Stubs_To_Declarations; --------------------------------- --- 7069,7139 ---- Defining_Identifier => Make_Defining_Identifier (Loc, New_Internal_Name ('R')), Aliased_Present => True, ! Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); Append_To (Decls, Pkg_RPC_Receiver_Object); Analyze (Last (Decls)); Get_Library_Unit_Name_String (Pkg_Spec); + + -- Name + Append_To (Register_Pkg_Actuals, Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); + -- Version + Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), ! Attribute_Name => Name_Version)); ! ! -- Handler Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), Attribute_Name => Name_Access)); + -- Receiver + Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of ( ! Defining_Identifier (Pkg_RPC_Receiver_Object), Loc), ! Attribute_Name => Name_Access)); ! ! -- Subp_Info Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), ! Attribute_Name => Name_Address)); ! ! -- Subp_Info_Len Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), ! Attribute_Name => Name_Length)); ! ! -- Is_All_Calls_Remote Append_To (Register_Pkg_Actuals, New_Occurrence_Of (All_Calls_Remote_E, Loc)); + -- ??? + Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc), Parameter_Associations => Register_Pkg_Actuals)); Analyze (Last (Stmts)); end Add_Receiving_Stubs_To_Declarations; --------------------------------- *************** package body Exp_Dist is *** 7387,7394 **** begin -- ??? document general form of stub subprograms for the PolyORB case ! Request := ! Make_Defining_Identifier (Loc, New_Internal_Name ('R')); Append_To (Decls, Make_Object_Declaration (Loc, --- 7208,7214 ---- begin -- ??? document general form of stub subprograms for the PolyORB case ! Request := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); Append_To (Decls, Make_Object_Declaration (Loc, *************** package body Exp_Dist is *** 7398,7408 **** New_Occurrence_Of (RTE (RE_Request_Access), Loc))); Result := ! Make_Defining_Identifier (Loc, New_Internal_Name ('R')); if Is_Function then ! Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, ! Etype (Result_Definition (Spec)), Decls); else Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc); end if; --- 7218,7230 ---- New_Occurrence_Of (RTE (RE_Request_Access), Loc))); Result := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('R')); if Is_Function then ! Result_TC := ! PolyORB_Support.Helpers.Build_TypeCode_Call ! (Loc, Etype (Result_Definition (Spec)), Decls); else Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc); end if; *************** package body Exp_Dist is *** 7417,7424 **** Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, ! Choices => New_List ( ! Make_Identifier (Loc, Name_Name)), Expression => New_Occurrence_Of (RTE (RE_Result_Name), Loc)), Make_Component_Association (Loc, --- 7239,7245 ---- Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, ! Choices => New_List (Make_Identifier (Loc, Name_Name)), Expression => New_Occurrence_Of (RTE (RE_Result_Name), Loc)), Make_Component_Association (Loc, *************** package body Exp_Dist is *** 7426,7440 **** Make_Identifier (Loc, Name_Argument)), Expression => Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Create_Any), Loc), ! Parameter_Associations => New_List ( ! Result_TC))), Make_Component_Association (Loc, ! Choices => New_List ( Make_Identifier (Loc, Name_Arg_Modes)), ! Expression => ! Make_Integer_Literal (Loc, 0)))))); if not Is_Known_Asynchronous then Exception_Return_Parameter := --- 7247,7258 ---- Make_Identifier (Loc, Name_Argument)), Expression => Make_Function_Call (Loc, ! Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), ! Parameter_Associations => New_List (Result_TC))), Make_Component_Association (Loc, ! Choices => New_List ( Make_Identifier (Loc, Name_Arg_Modes)), ! Expression => Make_Integer_Literal (Loc, 0)))))); if not Is_Known_Asynchronous then Exception_Return_Parameter := *************** package body Exp_Dist is *** 7463,7468 **** --- 7281,7287 ---- Is_First_Controlling_Formal := not First_Controlling_Formal_Seen; First_Controlling_Formal_Seen := True; + else Is_Controlling_Formal := False; Is_First_Controlling_Formal := False; *************** package body Exp_Dist is *** 7470,7477 **** if Is_Controlling_Formal then ! -- In the case of a controlling formal argument, we send its ! -- reference. Etyp := RACW_Type; --- 7289,7295 ---- if Is_Controlling_Formal then ! -- For a controlling formal argument, we send its reference Etyp := RACW_Type; *************** package body Exp_Dist is *** 7479,7489 **** Etyp := Etype (Parameter_Type (Current_Parameter)); end if; ! -- The first controlling formal parameter is treated specially: it ! -- is used to set the target object of the call. if not Is_First_Controlling_Formal then - declare Constrained : constant Boolean := Is_Constrained (Etyp) --- 7297,7306 ---- Etyp := Etype (Parameter_Type (Current_Parameter)); end if; ! -- The first controlling formal parameter is treated specially: ! -- it is used to set the target object of the call. if not Is_First_Controlling_Formal then declare Constrained : constant Boolean := Is_Constrained (Etyp) *************** package body Exp_Dist is *** 7516,7525 **** else Actual_Parameter := OK_Convert_To (Etyp, Make_Attribute_Reference (Loc, ! Prefix => ! Actual_Parameter, ! Attribute_Name => ! Name_Unrestricted_Access)); end if; end if; --- 7333,7340 ---- else Actual_Parameter := OK_Convert_To (Etyp, Make_Attribute_Reference (Loc, ! Prefix => Actual_Parameter, ! Attribute_Name => Name_Unrestricted_Access)); end if; end if; *************** package body Exp_Dist is *** 7534,7559 **** -- parameter (always passed as a reference) other than -- the first one. ! Expr := PolyORB_Support.Helpers.Build_To_Any_Call ( ! Actual_Parameter, Decls); else Expr := Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Create_Any), Loc), Parameter_Associations => New_List ( ! PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, ! Etyp, Decls))); end if; Append_To (Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Any, Aliased_Present => False, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), ! Expression => ! Expr)); Append_To (Statements, Add_Parameter_To_NVList (Loc, --- 7349,7372 ---- -- parameter (always passed as a reference) other than -- the first one. ! Expr := PolyORB_Support.Helpers.Build_To_Any_Call ! (Actual_Parameter, Decls); ! else Expr := Make_Function_Call (Loc, ! Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), Parameter_Associations => New_List ( ! PolyORB_Support.Helpers.Build_TypeCode_Call ! (Loc, Etyp, Decls))); end if; Append_To (Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Any, Aliased_Present => False, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), ! Expression => Expr)); Append_To (Statements, Add_Parameter_To_NVList (Loc, *************** package body Exp_Dist is *** 7571,7580 **** New_Occurrence_Of ( Defining_Identifier (Current_Parameter), Loc), Expression => ! PolyORB_Support.Helpers.Build_From_Any_Call ( ! Etype (Parameter_Type (Current_Parameter)), ! New_Occurrence_Of (Any, Loc), ! Decls))); end if; end; --- 7384,7393 ---- New_Occurrence_Of ( Defining_Identifier (Current_Parameter), Loc), Expression => ! PolyORB_Support.Helpers.Build_From_Any_Call ! (Etype (Parameter_Type (Current_Parameter)), ! New_Occurrence_Of (Any, Loc), ! Decls))); end if; end; *************** package body Exp_Dist is *** 7584,7591 **** -- this status is transmitted as well. -- This should be done for accessibility as well ??? ! if Nkind (Parameter_Type (Current_Parameter)) ! /= N_Access_Definition and then Need_Extra_Constrained (Current_Parameter) then -- In this block, we do not use the extra formal that has been --- 7397,7404 ---- -- this status is transmitted as well. -- This should be done for accessibility as well ??? ! if Nkind (Parameter_Type (Current_Parameter)) /= ! N_Access_Definition and then Need_Extra_Constrained (Current_Parameter) then -- In this block, we do not use the extra formal that has been *************** package body Exp_Dist is *** 7596,7623 **** declare Extra_Any_Parameter : constant Entity_Id := ! Make_Defining_Identifier ! (Loc, New_Internal_Name ('P')); Parameter_Exp : constant Node_Id := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of ( Defining_Identifier (Current_Parameter), Loc), Attribute_Name => Name_Constrained); begin Set_Etype (Parameter_Exp, Etype (Standard_Boolean)); Append_To (Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Extra_Any_Parameter, Aliased_Present => False, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), Expression => ! PolyORB_Support.Helpers.Build_To_Any_Call ( ! Parameter_Exp, ! Decls))); Append_To (Extra_Formal_Statements, Add_Parameter_To_NVList (Loc, --- 7409,7435 ---- declare Extra_Any_Parameter : constant Entity_Id := ! Make_Defining_Identifier ! (Loc, New_Internal_Name ('P')); Parameter_Exp : constant Node_Id := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of ( Defining_Identifier (Current_Parameter), Loc), Attribute_Name => Name_Constrained); + begin Set_Etype (Parameter_Exp, Etype (Standard_Boolean)); Append_To (Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Extra_Any_Parameter, Aliased_Present => False, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), Expression => ! PolyORB_Support.Helpers.Build_To_Any_Call ! (Parameter_Exp, Decls))); Append_To (Extra_Formal_Statements, Add_Parameter_To_NVList (Loc, *************** package body Exp_Dist is *** 7639,7644 **** --- 7451,7457 ---- Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Request_Create), Loc), + Parameter_Associations => New_List ( Target_Object, Subprogram_Id, *************** package body Exp_Dist is *** 7649,7662 **** Append_To (Parameter_Associations (Last (Statements)), New_Occurrence_Of (Request, Loc)); ! pragma Assert ( ! not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then ! Asynchronous_P := New_Occurrence_Of ( ! Boolean_Literals (Is_Known_Asynchronous), Loc); else pragma Assert (Present (Asynchronous)); Asynchronous_P := New_Copy_Tree (Asynchronous); -- The expression node Asynchronous will be used to build an 'if' -- statement at the end of Build_General_Calling_Stubs: we need to -- make a copy here. --- 7462,7479 ---- Append_To (Parameter_Associations (Last (Statements)), New_Occurrence_Of (Request, Loc)); ! pragma Assert ! (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); ! if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then ! Asynchronous_P := ! New_Occurrence_Of ! (Boolean_Literals (Is_Known_Asynchronous), Loc); ! else pragma Assert (Present (Asynchronous)); Asynchronous_P := New_Copy_Tree (Asynchronous); + -- The expression node Asynchronous will be used to build an 'if' -- statement at the end of Build_General_Calling_Stubs: we need to -- make a copy here. *************** package body Exp_Dist is *** 7698,7714 **** Append_To (Non_Asynchronous_Statements, Make_Tag_Check (Loc, Make_Simple_Return_Statement (Loc, ! PolyORB_Support.Helpers.Build_From_Any_Call ( ! Etype (Result_Definition (Spec)), ! Make_Selected_Component (Loc, ! Prefix => Result, ! Selector_Name => Name_Argument), ! Decls)))); end if; end if; ! Append_List_To (Non_Asynchronous_Statements, ! After_Statements); if Is_Known_Asynchronous then Append_List_To (Statements, Asynchronous_Statements); --- 7515,7530 ---- Append_To (Non_Asynchronous_Statements, Make_Tag_Check (Loc, Make_Simple_Return_Statement (Loc, ! PolyORB_Support.Helpers.Build_From_Any_Call ! (Etype (Result_Definition (Spec)), ! Make_Selected_Component (Loc, ! Prefix => Result, ! Selector_Name => Name_Argument), ! Decls)))); end if; end if; ! Append_List_To (Non_Asynchronous_Statements, After_Statements); if Is_Known_Asynchronous then Append_List_To (Statements, Asynchronous_Statements); *************** package body Exp_Dist is *** 7745,7752 **** --- 7561,7570 ---- Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Target_Reference, + Object_Definition => New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + Expression => Make_Function_Call (Loc, Name => *************** package body Exp_Dist is *** 7755,7761 **** Make_Selected_Component (Loc, Prefix => Controlling_Parameter, Selector_Name => Name_Target))))); ! -- Controlling_Parameter has the same components as -- System.Partition_Interface.RACW_Stub_Type. Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc); --- 7573,7580 ---- Make_Selected_Component (Loc, Prefix => Controlling_Parameter, Selector_Name => Name_Target))))); ! ! -- Note: Controlling_Parameter has the same components as -- System.Partition_Interface.RACW_Stub_Type. Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc); *************** package body Exp_Dist is *** 7763,7773 **** else Target_Info.Object := Make_Selected_Component (Loc, ! Prefix => ! Make_Identifier (Loc, Chars (RCI_Locator)), Selector_Name => Make_Identifier (Loc, Name_Get_RCI_Package_Ref)); end if; return Target_Info; end Build_Stub_Target; --- 7582,7592 ---- else Target_Info.Object := Make_Selected_Component (Loc, ! Prefix => Make_Identifier (Loc, Chars (RCI_Locator)), Selector_Name => Make_Identifier (Loc, Name_Get_RCI_Package_Ref)); end if; + return Target_Info; end Build_Stub_Target; *************** package body Exp_Dist is *** 7803,7822 **** Make_Defining_Identifier (Loc, Name_Target), Component_Definition => Make_Component_Definition (Loc, ! Aliased_Present => ! False, Subtype_Indication => New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))), Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Asynchronous), Component_Definition => Make_Component_Definition (Loc, Aliased_Present => False, Subtype_Indication => ! New_Occurrence_Of ( ! Standard_Boolean, Loc))))))); RPC_Receiver_Decl := Make_Object_Declaration (Loc, --- 7622,7640 ---- Make_Defining_Identifier (Loc, Name_Target), Component_Definition => Make_Component_Definition (Loc, ! Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))), Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Asynchronous), + Component_Definition => Make_Component_Definition (Loc, Aliased_Present => False, Subtype_Indication => ! New_Occurrence_Of (Standard_Boolean, Loc))))))); RPC_Receiver_Decl := Make_Object_Declaration (Loc, *************** package body Exp_Dist is *** 7964,7971 **** New_Occurrence_Of (Parent_Primitive, Loc); else Called_Subprogram := ! New_Occurrence_Of ( ! Defining_Unit_Name (Specification (Vis_Decl)), Loc); end if; Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements); --- 7782,7789 ---- New_Occurrence_Of (Parent_Primitive, Loc); else Called_Subprogram := ! New_Occurrence_Of ! (Defining_Unit_Name (Specification (Vis_Decl)), Loc); end if; Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements); *************** package body Exp_Dist is *** 7982,7992 **** Any : Entity_Id := Empty; Object : constant Entity_Id := Make_Defining_Identifier (Loc, ! New_Internal_Name ('P')); Expr : Node_Id := Empty; ! Is_Controlling_Formal : constant Boolean ! := Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type); Is_First_Controlling_Formal : Boolean := False; --- 7800,7811 ---- Any : Entity_Id := Empty; Object : constant Entity_Id := Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('P')); Expr : Node_Id := Empty; ! Is_Controlling_Formal : constant Boolean := ! Is_RACW_Controlling_Formal ! (Current_Parameter, Stub_Type); Is_First_Controlling_Formal : Boolean := False; *************** package body Exp_Dist is *** 8007,8036 **** Is_First_Controlling_Formal := not First_Controlling_Formal_Seen; First_Controlling_Formal_Seen := True; else Etyp := Etype (Parameter_Type (Current_Parameter)); end if; Constrained := ! Is_Constrained (Etyp) ! or else Is_Elementary_Type (Etyp); if not Is_First_Controlling_Formal then ! Any := Make_Defining_Identifier (Loc, ! New_Internal_Name ('A')); Append_To (Outer_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Any, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), Expression => Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Create_Any), Loc), Parameter_Associations => New_List ( ! PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, ! Etyp, Outer_Decls))))); Append_To (Outer_Statements, Add_Parameter_To_NVList (Loc, --- 7826,7855 ---- Is_First_Controlling_Formal := not First_Controlling_Formal_Seen; First_Controlling_Formal_Seen := True; + else Etyp := Etype (Parameter_Type (Current_Parameter)); end if; Constrained := ! Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); if not Is_First_Controlling_Formal then ! Any := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('A')); ! Append_To (Outer_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Any, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), Expression => Make_Function_Call (Loc, ! Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), Parameter_Associations => New_List ( ! PolyORB_Support.Helpers.Build_TypeCode_Call ! (Loc, Etyp, Outer_Decls))))); Append_To (Outer_Statements, Add_Parameter_To_NVList (Loc, *************** package body Exp_Dist is *** 8043,8076 **** if Is_First_Controlling_Formal then declare Addr : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! New_Internal_Name ('A')); Is_Local : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! New_Internal_Name ('L')); ! begin -- Special case: obtain the first controlling formal -- from the target of the remote call, instead of the -- argument list. Append_To (Outer_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Addr, Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); Append_To (Outer_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Is_Local, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc))); Append_To (Outer_Statements, Make_Procedure_Call_Statement (Loc, Name => ! New_Occurrence_Of ( ! RTE (RE_Get_Local_Address), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => --- 7862,7895 ---- if Is_First_Controlling_Formal then declare Addr : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('A')); ! Is_Local : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('L')); + begin -- Special case: obtain the first controlling formal -- from the target of the remote call, instead of the -- argument list. Append_To (Outer_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Addr, Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); + Append_To (Outer_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Is_Local, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc))); + Append_To (Outer_Statements, Make_Procedure_Call_Statement (Loc, Name => ! New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => *************** package body Exp_Dist is *** 8101,8113 **** if Constrained then Append_To (Statements, Make_Assignment_Statement (Loc, ! Name => ! New_Occurrence_Of (Object, Loc), ! Expression => ! Expr)); Expr := Empty; else null; -- Expr will be used to initialize (and constrain) the -- parameter when it is declared. end if; --- 7920,7931 ---- if Constrained then Append_To (Statements, Make_Assignment_Statement (Loc, ! Name => New_Occurrence_Of (Object, Loc), ! Expression => Expr)); Expr := Empty; else null; + -- Expr will be used to initialize (and constrain) the -- parameter when it is declared. end if; *************** package body Exp_Dist is *** 8148,8160 **** then Append_To (After_Statements, Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), ! PolyORB_Support.Helpers.Build_To_Any_Call ( ! New_Occurrence_Of (Object, Loc), ! Decls)))); end if; -- For RACW controlling formals, the Etyp of Object is always --- 7966,7976 ---- then Append_To (After_Statements, Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), ! PolyORB_Support.Helpers.Build_To_Any_Call ! (New_Occurrence_Of (Object, Loc), Decls)))); end if; -- For RACW controlling formals, the Etyp of Object is always *************** package body Exp_Dist is *** 8163,8187 **** if Is_Controlling_Formal then if Nkind (Parameter_Type (Current_Parameter)) /= ! N_Access_Definition then Append_To (Parameter_List, Make_Parameter_Association (Loc, Selector_Name => ! New_Occurrence_Of ( ! Defining_Identifier (Current_Parameter), Loc), Explicit_Actual_Parameter => Make_Explicit_Dereference (Loc, ! Unchecked_Convert_To (RACW_Type, ! OK_Convert_To (RTE (RE_Address), ! New_Occurrence_Of (Object, Loc)))))); else Append_To (Parameter_List, Make_Parameter_Association (Loc, Selector_Name => ! New_Occurrence_Of ( ! Defining_Identifier (Current_Parameter), Loc), Explicit_Actual_Parameter => Unchecked_Convert_To (RACW_Type, OK_Convert_To (RTE (RE_Address), --- 7979,8005 ---- if Is_Controlling_Formal then if Nkind (Parameter_Type (Current_Parameter)) /= ! N_Access_Definition then Append_To (Parameter_List, Make_Parameter_Association (Loc, Selector_Name => ! New_Occurrence_Of ! (Defining_Identifier (Current_Parameter), Loc), Explicit_Actual_Parameter => Make_Explicit_Dereference (Loc, ! Prefix => ! Unchecked_Convert_To (RACW_Type, ! OK_Convert_To (RTE (RE_Address), ! New_Occurrence_Of (Object, Loc)))))); else Append_To (Parameter_List, Make_Parameter_Association (Loc, Selector_Name => ! New_Occurrence_Of ! (Defining_Identifier (Current_Parameter), Loc), ! Explicit_Actual_Parameter => Unchecked_Convert_To (RACW_Type, OK_Convert_To (RTE (RE_Address), *************** package body Exp_Dist is *** 8212,8232 **** Extra_Constrained (Defining_Identifier (Current_Parameter)); Extra_Any : constant Entity_Id := ! Make_Defining_Identifier ! (Loc, New_Internal_Name ('A')); Formal_Entity : constant Entity_Id := ! Make_Defining_Identifier ! (Loc, Chars (Extra_Parameter)); Formal_Type : constant Entity_Id := Etype (Extra_Parameter); begin Append_To (Outer_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Extra_Any, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), Expression => --- 8030,8051 ---- Extra_Constrained (Defining_Identifier (Current_Parameter)); + Extra_Any : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('A')); Formal_Entity : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => Chars (Extra_Parameter)); Formal_Type : constant Entity_Id := Etype (Extra_Parameter); + begin Append_To (Outer_Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Extra_Any, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), Expression => *************** package body Exp_Dist is *** 8252,8264 **** Append_To (Statements, Make_Assignment_Statement (Loc, ! Name => ! New_Occurrence_Of (Formal_Entity, Loc), Expression => ! PolyORB_Support.Helpers.Build_From_Any_Call ( ! Formal_Type, ! New_Occurrence_Of (Extra_Any, Loc), ! Decls))); Set_Extra_Constrained (Object, Formal_Entity); end; end if; --- 8071,8082 ---- Append_To (Statements, Make_Assignment_Statement (Loc, ! Name => New_Occurrence_Of (Formal_Entity, Loc), Expression => ! PolyORB_Support.Helpers.Build_From_Any_Call ! (Formal_Type, ! New_Occurrence_Of (Extra_Any, Loc), ! Decls))); Set_Extra_Constrained (Object, Formal_Entity); end; end if; *************** package body Exp_Dist is *** 8273,8296 **** Append_To (Outer_Statements, Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Request_Arguments), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc), New_Occurrence_Of (Arguments, Loc)))); if Nkind (Specification (Vis_Decl)) = N_Function_Specification then ! -- The remote subprogram is a function. We build an inner block to ! -- be able to hold a potentially unconstrained result in a ! -- variable. declare Etyp : constant Entity_Id := Etype (Result_Definition (Specification (Vis_Decl))); Result : constant Node_Id := Make_Defining_Identifier (Loc, ! New_Internal_Name ('R')); begin Inner_Decls := New_List ( Make_Object_Declaration (Loc, --- 8091,8113 ---- Append_To (Outer_Statements, Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc), New_Occurrence_Of (Arguments, Loc)))); if Nkind (Specification (Vis_Decl)) = N_Function_Specification then ! -- The remote subprogram is a function: Build an inner block to be ! -- able to hold a potentially unconstrained result in a variable. declare Etyp : constant Entity_Id := Etype (Result_Definition (Specification (Vis_Decl))); Result : constant Node_Id := Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('R')); ! begin Inner_Decls := New_List ( Make_Object_Declaration (Loc, *************** package body Exp_Dist is *** 8306,8312 **** -- For a remote call to a function with a class-wide type, -- check that the returned value satisfies the requirements ! -- of E.4(18). Append_To (Inner_Decls, Make_Transportable_Check (Loc, --- 8123,8129 ---- -- For a remote call to a function with a class-wide type, -- check that the returned value satisfies the requirements ! -- of (RM E.4(18)). Append_To (Inner_Decls, Make_Transportable_Check (Loc, *************** package body Exp_Dist is *** 8317,8329 **** Set_Etype (Result, Etyp); Append_To (After_Statements, Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Set_Result), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc), ! PolyORB_Support.Helpers.Build_To_Any_Call ( ! New_Occurrence_Of (Result, Loc), ! Decls)))); -- A DSA function does not have out or inout arguments end; --- 8134,8145 ---- Set_Etype (Result, Etyp); Append_To (After_Statements, Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc), ! PolyORB_Support.Helpers.Build_To_Any_Call ! (New_Occurrence_Of (Result, Loc), Decls)))); ! -- A DSA function does not have out or inout arguments end; *************** package body Exp_Dist is *** 8344,8351 **** Append_To (After_Statements, Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc)))); --- 8160,8166 ---- Append_To (After_Statements, Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc)))); *************** package body Exp_Dist is *** 8383,8389 **** Statements => New_List (Make_Null_Statement (Loc)))); else - -- In the other cases, if an exception is raised, then the -- exception occurrence is propagated. --- 8198,8203 ---- *************** package body Exp_Dist is *** 8392,8399 **** Append_To (Outer_Statements, Make_Block_Statement (Loc, ! Declarations => ! Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Statements))); --- 8206,8212 ---- Append_To (Outer_Statements, Make_Block_Statement (Loc, ! Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Statements))); *************** package body Exp_Dist is *** 8420,8435 **** function Find_Numeric_Representation (Typ : Entity_Id) return Entity_Id; ! -- Given a numeric type Typ, return the smallest integer or floarting -- point type from Standard, or the smallest unsigned (modular) type -- from System.Unsigned_Types, whose range encompasses that of Typ. ! function Make_Stream_Procedure_Function_Name (Loc : Source_Ptr; Typ : Entity_Id; Nam : Name_Id) return Entity_Id; ! -- Return the name to be assigned for stream subprogram Nam of Typ. ! -- (copied from exp_strm.adb, should be shared???) ------------------------------------------------------------ -- Common subprograms for building various tree fragments -- --- 8233,8247 ---- function Find_Numeric_Representation (Typ : Entity_Id) return Entity_Id; ! -- Given a numeric type Typ, return the smallest integer or floating -- point type from Standard, or the smallest unsigned (modular) type -- from System.Unsigned_Types, whose range encompasses that of Typ. ! function Make_Helper_Function_Name (Loc : Source_Ptr; Typ : Entity_Id; Nam : Name_Id) return Entity_Id; ! -- Return the name to be assigned for helper subprogram Nam of Typ ------------------------------------------------------------ -- Common subprograms for building various tree fragments -- *************** package body Exp_Dist is *** 8440,8447 **** Any : Entity_Id; TC : Node_Id; Idx : Node_Id) return Node_Id; ! -- Build a call to Get_Aggregate_Element on Any ! -- for typecode TC, returning the Idx'th element. generic Subprogram : Entity_Id; --- 8252,8259 ---- Any : Entity_Id; TC : Node_Id; Idx : Node_Id) return Node_Id; ! -- Build a call to Get_Aggregate_Element on Any for typecode TC, ! -- returning the Idx'th element. generic Subprogram : Entity_Id; *************** package body Exp_Dist is *** 8554,8561 **** Fnam : Entity_Id := Empty; Lib_RE : RE_Id := RE_Null; Result : Node_Id; - begin -- First simple case where the From_Any function is present -- in the type's TSS. --- 8366,8373 ---- Fnam : Entity_Id := Empty; Lib_RE : RE_Id := RE_Null; Result : Node_Id; + begin -- First simple case where the From_Any function is present -- in the type's TSS. *************** package body Exp_Dist is *** 8638,8643 **** --- 8450,8460 ---- elsif U_Type = Standard_String then Lib_RE := RE_FA_String; + -- Special DSA types + + elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then + Lib_RE := RE_FA_A; + -- Other (non-primitive) types else *************** package body Exp_Dist is *** 8679,8711 **** Decl : out Node_Id; Fnam : out Entity_Id) is ! Spec : Node_Id; Decls : constant List_Id := New_List; ! Stms : constant List_Id := New_List; ! Any_Parameter : constant Entity_Id ! := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); begin if Is_Itype (Typ) then Build_From_Any_Function (Loc => Loc, ! Typ => Etype (Typ), ! Decl => Decl, ! Fnam => Fnam); return; end if; ! Fnam := Make_Stream_Procedure_Function_Name (Loc, ! Typ, Name_uFrom_Any); Spec := Make_Function_Specification (Loc, Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Any_Parameter, ! Parameter_Type => ! New_Occurrence_Of (RTE (RE_Any), Loc))), Result_Definition => New_Occurrence_Of (Typ, Loc)); -- The following is taken care of by Exp_Dist.Add_RACW_From_Any --- 8496,8530 ---- Decl : out Node_Id; Fnam : out Entity_Id) is ! Spec : Node_Id; Decls : constant List_Id := New_List; ! Stms : constant List_Id := New_List; ! ! Any_Parameter : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! New_Internal_Name ('A')); ! ! Use_Opaque_Representation : Boolean; ! begin if Is_Itype (Typ) then Build_From_Any_Function (Loc => Loc, ! Typ => Etype (Typ), ! Decl => Decl, ! Fnam => Fnam); return; end if; ! Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any); Spec := Make_Function_Specification (Loc, Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, ! Defining_Identifier => Any_Parameter, ! Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), Result_Definition => New_Occurrence_Of (Typ, Loc)); -- The following is taken care of by Exp_Dist.Add_RACW_From_Any *************** package body Exp_Dist is *** 8713,8730 **** pragma Assert (not (Is_Remote_Access_To_Class_Wide_Type (Typ))); ! if Is_Derived_Type (Typ) ! and then not Is_Tagged_Type (Typ) then Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => ! OK_Convert_To ( ! Typ, ! Build_From_Any_Call ( ! Root_Type (Typ), ! New_Occurrence_Of (Any_Parameter, Loc), ! Decls)))); elsif Is_Record_Type (Typ) and then not Is_Derived_Type (Typ) --- 8532,8560 ---- pragma Assert (not (Is_Remote_Access_To_Class_Wide_Type (Typ))); ! Use_Opaque_Representation := False; ! ! if Has_Stream_Attribute_Definition ! (Typ, TSS_Stream_Output, At_Any_Place => True) ! or else ! Has_Stream_Attribute_Definition ! (Typ, TSS_Stream_Write, At_Any_Place => True) then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Use_Opaque_Representation := True; + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => ! OK_Convert_To (Typ, ! Build_From_Any_Call ! (Root_Type (Typ), ! New_Occurrence_Of (Any_Parameter, Loc), ! Decls)))); elsif Is_Record_Type (Typ) and then not Is_Derived_Type (Typ) *************** package body Exp_Dist is *** 8734,8752 **** Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => ! OK_Convert_To ( ! Typ, ! Build_From_Any_Call ( ! Etype (Typ), ! New_Occurrence_Of (Any_Parameter, Loc), ! Decls)))); else declare ! Disc : Entity_Id := Empty; Discriminant_Associations : List_Id; ! Rdef : constant Node_Id := ! Type_Definition (Declaration_Node (Typ)); ! Component_Counter : Int := 0; -- The returned object --- 8564,8583 ---- Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => ! OK_Convert_To (Typ, ! Build_From_Any_Call ! (Etype (Typ), ! New_Occurrence_Of (Any_Parameter, Loc), ! Decls)))); ! else declare ! Disc : Entity_Id := Empty; Discriminant_Associations : List_Id; ! Rdef : constant Node_Id := ! Type_Definition ! (Declaration_Node (Typ)); ! Component_Counter : Int := 0; -- The returned object *************** package body Exp_Dist is *** 8765,8772 **** procedure FA_Append_Record_Traversal is new Append_Record_Traversal ! (Rec => Res, ! Add_Process_Element => FA_Rec_Add_Process_Element); -------------------------------- -- FA_Rec_Add_Process_Element -- --- 8596,8603 ---- procedure FA_Append_Record_Traversal is new Append_Record_Traversal ! (Rec => Res, ! Add_Process_Element => FA_Rec_Add_Process_Element); -------------------------------- -- FA_Rec_Add_Process_Element -- *************** package body Exp_Dist is *** 8795,8801 **** Build_From_Any_Call (Etype (Field), Build_Get_Aggregate_Element (Loc, Any => Any, ! Tc => Build_TypeCode_Call (Loc, Etype (Field), Decls), Idx => Make_Integer_Literal (Loc, Counter)), --- 8626,8632 ---- Build_From_Any_Call (Etype (Field), Build_Get_Aggregate_Element (Loc, Any => Any, ! TC => Build_TypeCode_Call (Loc, Etype (Field), Decls), Idx => Make_Integer_Literal (Loc, Counter)), *************** package body Exp_Dist is *** 8805,8811 **** -- A variant part declare ! Variant : Node_Id; Struct_Counter : Int := 0; Block_Decls : constant List_Id := New_List; --- 8636,8642 ---- -- A variant part declare ! Variant : Node_Id; Struct_Counter : Int := 0; Block_Decls : constant List_Id := New_List; *************** package body Exp_Dist is *** 8822,8855 **** begin Append_To (Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Struct_Any, ! Constant_Present => ! True, ! Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), ! Expression => Make_Function_Call (Loc, ! Name => New_Occurrence_Of ( ! RTE (RE_Extract_Union_Value), Loc), Parameter_Associations => New_List ( Build_Get_Aggregate_Element (Loc, Any => Any, ! Tc => Make_Function_Call (Loc, ! Name => New_Occurrence_Of ( ! RTE (RE_Any_Member_Type), Loc), ! Parameter_Associations => ! New_List ( ! New_Occurrence_Of (Any, Loc), ! Make_Integer_Literal (Loc, ! Counter))), ! Idx => Make_Integer_Literal (Loc, ! Counter)))))); Append_To (Stmts, Make_Block_Statement (Loc, ! Declarations => ! Block_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Block_Stmts))); --- 8653,8687 ---- begin Append_To (Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Struct_Any, ! Constant_Present => True, ! Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), ! Expression => Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of ! (RTE (RE_Extract_Union_Value), Loc), ! Parameter_Associations => New_List ( Build_Get_Aggregate_Element (Loc, Any => Any, ! TC => ! Make_Function_Call (Loc, ! Name => New_Occurrence_Of ( ! RTE (RE_Any_Member_Type), Loc), ! Parameter_Associations => ! New_List ( ! New_Occurrence_Of (Any, Loc), ! Make_Integer_Literal (Loc, ! Intval => Counter))), ! Idx => ! Make_Integer_Literal (Loc, ! Intval => Counter)))))); Append_To (Stmts, Make_Block_Statement (Loc, ! Declarations => Block_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Block_Stmts))); *************** package body Exp_Dist is *** 8859,8873 **** Expression => Make_Selected_Component (Loc, Prefix => Rec, ! Selector_Name => ! Chars (Name (Field))), ! Alternatives => ! Alt_List)); Variant := First_Non_Pragma (Variants (Field)); while Present (Variant) loop ! Choice_List := New_Copy_List_Tree ! (Discrete_Choices (Variant)); VP_Stmts := New_List; --- 8691,8704 ---- Expression => Make_Selected_Component (Loc, Prefix => Rec, ! Selector_Name => Chars (Name (Field))), ! Alternatives => Alt_List)); Variant := First_Non_Pragma (Variants (Field)); while Present (Variant) loop ! Choice_List := ! New_Copy_List_Tree ! (Discrete_Choices (Variant)); VP_Stmts := New_List; *************** package body Exp_Dist is *** 8888,8899 **** Append_To (Alt_List, Make_Case_Statement_Alternative (Loc, Discrete_Choices => Choice_List, ! Statements => ! VP_Stmts)); Next_Non_Pragma (Variant); end loop; end; end if; Counter := Counter + 1; end FA_Rec_Add_Process_Element; --- 8719,8730 ---- Append_To (Alt_List, Make_Case_Statement_Alternative (Loc, Discrete_Choices => Choice_List, ! Statements => VP_Stmts)); Next_Non_Pragma (Variant); end loop; end; end if; + Counter := Counter + 1; end FA_Rec_Add_Process_Element; *************** package body Exp_Dist is *** 8915,8934 **** begin Append_To (Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Disc_Var_Name, ! Constant_Present => True, ! Object_Definition => New_Occurrence_Of (Disc_Type, Loc), Expression => Build_From_Any_Call (Disc_Type, Build_Get_Aggregate_Element (Loc, Any => Any_Parameter, ! Tc => Build_TypeCode_Call (Loc, Disc_Type, Decls), ! Idx => Make_Integer_Literal ! (Loc, Component_Counter)), Decls))); Component_Counter := Component_Counter + 1; Append_To (Discriminant_Associations, --- 8746,8766 ---- begin Append_To (Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Disc_Var_Name, ! Constant_Present => True, ! Object_Definition => New_Occurrence_Of (Disc_Type, Loc), + Expression => Build_From_Any_Call (Disc_Type, Build_Get_Aggregate_Element (Loc, Any => Any_Parameter, ! TC => Build_TypeCode_Call (Loc, Disc_Type, Decls), ! Idx => Make_Integer_Literal (Loc, ! Intval => Component_Counter)), Decls))); + Component_Counter := Component_Counter + 1; Append_To (Discriminant_Associations, *************** package body Exp_Dist is *** 8958,8967 **** Append_To (Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Res, ! Object_Definition => ! Res_Definition)); -- ... then all components --- 8790,8797 ---- Append_To (Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Res, ! Object_Definition => Res_Definition)); -- ... then all components *************** package body Exp_Dist is *** 9018,9023 **** --- 8848,8854 ---- -- sufficient to determine the typecode of Datum -- (which can be a TC_SEQUENCE or TC_ARRAY -- depending on the value of Constrained). + -- Therefore we retrieve the typecode which has -- been constructed in Append_Array_Traversal with -- a call to Get_Any_Type. *************** package body Exp_Dist is *** 9039,9045 **** Element_Any := Build_Get_Aggregate_Element (Loc, Any => Any, ! Tc => Element_TC, Idx => New_Occurrence_Of (Counter, Loc)); end; --- 8870,8876 ---- Element_Any := Build_Get_Aggregate_Element (Loc, Any => Any, ! TC => Element_TC, Idx => New_Occurrence_Of (Counter, Loc)); end; *************** package body Exp_Dist is *** 9052,9061 **** New_Occurrence_Of (Counter, Loc), Expression => Make_Op_Add (Loc, ! Left_Opnd => ! New_Occurrence_Of (Counter, Loc), ! Right_Opnd => ! Make_Integer_Literal (Loc, 1)))); if Nkind (Datum) /= N_Attribute_Reference then --- 8883,8890 ---- New_Occurrence_Of (Counter, Loc), Expression => Make_Op_Add (Loc, ! Left_Opnd => New_Occurrence_Of (Counter, Loc), ! Right_Opnd => Make_Integer_Literal (Loc, 1)))); if Nkind (Datum) /= N_Attribute_Reference then *************** package body Exp_Dist is *** 9065,9074 **** if Etype (Datum) /= RTE (RE_Any) then Set_Expression (Assignment, ! Build_From_Any_Call ( ! Component_Type (Typ), ! Element_Any, ! Decls)); else Set_Expression (Assignment, Element_Any); end if; --- 8894,8901 ---- if Etype (Datum) /= RTE (RE_Any) then Set_Expression (Assignment, ! Build_From_Any_Call ! (Component_Type (Typ), Element_Any, Decls)); else Set_Expression (Assignment, Element_Any); end if; *************** package body Exp_Dist is *** 9123,9154 **** Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Lnam), ! Constant_Present => ! True, Object_Definition => New_Occurrence_Of (Indt, Loc), Expression => ! Build_From_Any_Call ( ! Indt, ! Build_Get_Aggregate_Element (Loc, ! Any => Any_Parameter, ! Tc => Build_TypeCode_Call (Loc, ! Indt, Decls), ! Idx => Make_Integer_Literal (Loc, J - 1)), Decls))); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Hnam), ! Constant_Present => ! True, Object_Definition => New_Occurrence_Of (Indt, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Indt, Loc), Attribute_Name => Name_Val, Expressions => New_List ( Make_Op_Subtract (Loc, Left_Opnd => --- 8950,8985 ---- Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Lnam), ! Constant_Present => True, Object_Definition => New_Occurrence_Of (Indt, Loc), Expression => ! Build_From_Any_Call ! (Indt, ! Build_Get_Aggregate_Element (Loc, ! Any => Any_Parameter, ! TC => Build_TypeCode_Call ! (Loc, Indt, Decls), ! Idx => ! Make_Integer_Literal (Loc, J - 1)), Decls))); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Hnam), ! ! Constant_Present => True, ! Object_Definition => New_Occurrence_Of (Indt, Loc), + Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Indt, Loc), + Attribute_Name => Name_Val, + Expressions => New_List ( Make_Op_Subtract (Loc, Left_Opnd => *************** package body Exp_Dist is *** 9157,9167 **** OK_Convert_To ( Standard_Long_Integer, Make_Identifier (Loc, Lnam)), Right_Opnd => OK_Convert_To ( Standard_Long_Integer, Make_Function_Call (Loc, ! Name => New_Occurrence_Of (RTE ( RE_Get_Nested_Sequence_Length ), Loc), Parameter_Associations => --- 8988,9000 ---- OK_Convert_To ( Standard_Long_Integer, Make_Identifier (Loc, Lnam)), + Right_Opnd => OK_Convert_To ( Standard_Long_Integer, Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE ( RE_Get_Nested_Sequence_Length ), Loc), Parameter_Associations => *************** package body Exp_Dist is *** 9169,9175 **** New_Occurrence_Of ( Any_Parameter, Loc), Make_Integer_Literal (Loc, ! J))))), Right_Opnd => Make_Integer_Literal (Loc, 1)))))); --- 9002,9009 ---- New_Occurrence_Of ( Any_Parameter, Loc), Make_Integer_Literal (Loc, ! Intval => J))))), ! Right_Opnd => Make_Integer_Literal (Loc, 1)))))); *************** package body Exp_Dist is *** 9187,9194 **** Initial_Counter_Value := Ndim; Res_Subtype_Indication := Make_Subtype_Indication (Loc, ! Subtype_Mark => ! Res_Subtype_Indication, Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Ranges)); --- 9021,9027 ---- Initial_Counter_Value := Ndim; Res_Subtype_Indication := Make_Subtype_Indication (Loc, ! Subtype_Mark => Res_Subtype_Indication, Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Ranges)); *************** package body Exp_Dist is *** 9212,9226 **** Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Component_TC, ! Constant_Present => True, ! Object_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc), ! Expression => Build_TypeCode_Call (Loc, Component_Type (Typ), Decls))); ! Append_From_Any_Array_Iterator (Stms, ! Any_Parameter, Counter); Append_To (Stms, Make_Simple_Return_Statement (Loc, --- 9045,9059 ---- Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Component_TC, ! Constant_Present => True, ! Object_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc), ! Expression => Build_TypeCode_Call (Loc, Component_Type (Typ), Decls))); ! Append_From_Any_Array_Iterator ! (Stms, Any_Parameter, Counter); Append_To (Stms, Make_Simple_Return_Statement (Loc, *************** package body Exp_Dist is *** 9231,9244 **** Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => ! Unchecked_Convert_To ( ! Typ, ! Build_From_Any_Call ( ! Find_Numeric_Representation (Typ), ! New_Occurrence_Of (Any_Parameter, Loc), ! Decls)))); else -- Default: type is represented as an opaque sequence of bytes declare --- 9064,9081 ---- Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => ! Unchecked_Convert_To (Typ, ! Build_From_Any_Call ! (Find_Numeric_Representation (Typ), ! New_Occurrence_Of (Any_Parameter, Loc), ! Decls)))); else + Use_Opaque_Representation := True; + end if; + + if Use_Opaque_Representation then + -- Default: type is represented as an opaque sequence of bytes declare *************** package body Exp_Dist is *** 9254,9263 **** Append_To (Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => ! Strm, ! Aliased_Present => ! True, Object_Definition => New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); --- 9091,9098 ---- Append_To (Decls, Make_Object_Declaration (Loc, ! Defining_Identifier => Strm, ! Aliased_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); *************** package body Exp_Dist is *** 9274,9281 **** Append_To (Stms, Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any_Parameter, Loc), New_Occurrence_Of (Strm, Loc)))); --- 9109,9115 ---- Append_To (Stms, Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any_Parameter, Loc), New_Occurrence_Of (Strm, Loc)))); *************** package body Exp_Dist is *** 9292,9299 **** Make_Object_Declaration (Loc, Defining_Identifier => Res, Constant_Present => True, ! Object_Definition => ! New_Occurrence_Of (Typ, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), --- 9126,9132 ---- Make_Object_Declaration (Loc, Defining_Identifier => Res, Constant_Present => True, ! Object_Definition => New_Occurrence_Of (Typ, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), *************** package body Exp_Dist is *** 9310,9317 **** Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), Parameter_Associations => ! New_List ( ! New_Occurrence_Of (Strm, Loc))), Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Res, Loc)))))); --- 9143,9149 ---- Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), Parameter_Associations => ! New_List (New_Occurrence_Of (Strm, Loc))), Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Res, Loc)))))); *************** package body Exp_Dist is *** 9340,9347 **** begin return Make_Function_Call (Loc, Name => ! New_Occurrence_Of ( ! RTE (RE_Get_Aggregate_Element), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), TC, --- 9172,9178 ---- begin return Make_Function_Call (Loc, Name => ! New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), TC, *************** package body Exp_Dist is *** 9484,9490 **** --- 9315,9330 ---- elsif U_Type = Standard_String then Lib_RE := RE_TA_String; + -- Special DSA types + + elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then + Lib_RE := RE_TA_A; + U_Type := Typ; + elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then + + -- No corresponding FA_TC ??? + Lib_RE := RE_TA_TC; -- Other (non-primitive) types *************** package body Exp_Dist is *** 9535,9540 **** --- 9375,9384 ---- Any_Decl : Node_Id; Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls); + Use_Opaque_Representation : Boolean; + -- When True, use stream attributes and represent type as an + -- opaque sequence of bytes. + begin if Is_Itype (Typ) then Build_To_Any_Function *************** package body Exp_Dist is *** 9545,9605 **** return; end if; ! Fnam := Make_Stream_Procedure_Function_Name (Loc, ! Typ, Name_uTo_Any); Spec := Make_Function_Specification (Loc, Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Expr_Parameter, ! Parameter_Type => ! New_Occurrence_Of (Typ, Loc))), ! Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); Set_Etype (Expr_Parameter, Typ); Any_Decl := Make_Object_Declaration (Loc, ! Defining_Identifier => ! Any, ! Object_Definition => ! New_Occurrence_Of (RTE (RE_Any), Loc)); - if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then declare ! Rt_Type : constant Entity_Id ! := Root_Type (Typ); ! Expr : constant Node_Id ! := OK_Convert_To ( ! Rt_Type, ! New_Occurrence_Of (Expr_Parameter, Loc)); begin Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls)); end; elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then declare ! Rt_Type : constant Entity_Id ! := Etype (Typ); ! Expr : constant Node_Id ! := OK_Convert_To ( ! Rt_Type, ! New_Occurrence_Of (Expr_Parameter, Loc)); begin ! Set_Expression (Any_Decl, ! Build_To_Any_Call (Expr, Decls)); end; else declare ! Disc : Entity_Id := Empty; ! Rdef : constant Node_Id := ! Type_Definition (Declaration_Node (Typ)); ! Counter : Int := 0; Elements : constant List_Id := New_List; procedure TA_Rec_Add_Process_Element --- 9389,9463 ---- return; end if; ! Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any); Spec := Make_Function_Specification (Loc, Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, ! Defining_Identifier => Expr_Parameter, ! Parameter_Type => New_Occurrence_Of (Typ, Loc))), ! Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); Set_Etype (Expr_Parameter, Typ); Any_Decl := Make_Object_Declaration (Loc, ! Defining_Identifier => Any, ! Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); ! ! Use_Opaque_Representation := False; ! ! if Has_Stream_Attribute_Definition ! (Typ, TSS_Stream_Output, At_Any_Place => True) ! or else ! Has_Stream_Attribute_Definition ! (Typ, TSS_Stream_Write, At_Any_Place => True) ! then ! -- If user-defined stream attributes are specified for this ! -- type, use them and transmit data as an opaque sequence of ! -- stream elements. ! ! Use_Opaque_Representation := True; ! ! elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then ! ! -- Non-tagged derived type: convert to root type declare ! Rt_Type : constant Entity_Id := Root_Type (Typ); ! Expr : constant Node_Id := ! OK_Convert_To ! (Rt_Type, ! New_Occurrence_Of (Expr_Parameter, Loc)); begin Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls)); end; elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then + + -- Non-tagged record type + if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then declare ! Rt_Type : constant Entity_Id := Etype (Typ); ! Expr : constant Node_Id := ! OK_Convert_To (Rt_Type, ! New_Occurrence_Of (Expr_Parameter, Loc)); begin ! Set_Expression ! (Any_Decl, Build_To_Any_Call (Expr, Decls)); end; + -- Comment needed here (and label on declare block ???) + else declare ! Disc : Entity_Id := Empty; ! Rdef : constant Node_Id := ! Type_Definition (Declaration_Node (Typ)); ! Counter : Int := 0; Elements : constant List_Id := New_List; procedure TA_Rec_Add_Process_Element *************** package body Exp_Dist is *** 9608,9613 **** --- 9466,9472 ---- Counter : in out Int; Rec : Entity_Id; Field : Node_Id); + -- Processing routine for traversal below procedure TA_Append_Record_Traversal is new Append_Record_Traversal *************** package body Exp_Dist is *** 9649,9663 **** else -- A variant part ! declare ! Variant : Node_Id; Struct_Counter : Int := 0; Block_Decls : constant List_Id := New_List; Block_Stmts : constant List_Id := New_List; VP_Stmts : List_Id; ! Alt_List : constant List_Id := New_List; Choice_List : List_Id; Union_Any : constant Entity_Id := --- 9508,9522 ---- else -- A variant part ! Variant_Part : declare ! Variant : Node_Id; Struct_Counter : Int := 0; Block_Decls : constant List_Id := New_List; Block_Stmts : constant List_Id := New_List; VP_Stmts : List_Id; ! Alt_List : constant List_Id := New_List; Choice_List : List_Id; Union_Any : constant Entity_Id := *************** package body Exp_Dist is *** 9670,9677 **** function Make_Discriminant_Reference return Node_Id; ! -- Build a selected component for the ! -- discriminant of this variant part. --------------------------------- -- Make_Discriminant_Reference -- --- 9529,9536 ---- function Make_Discriminant_Reference return Node_Id; ! -- Build reference to the discriminant for this ! -- variant part. --------------------------------- -- Make_Discriminant_Reference -- *************** package body Exp_Dist is *** 9690,9695 **** --- 9549,9556 ---- return Nod; end Make_Discriminant_Reference; + -- Start processing for Variant_Part + begin Append_To (Stmts, Make_Block_Statement (Loc, *************** package body Exp_Dist is *** 9699,9709 **** Make_Handled_Sequence_Of_Statements (Loc, Statements => Block_Stmts))); ! -- Declare the Variant Part aggregate ! -- (Union_Any). ! -- Knowing the position of this VP in ! -- the variant record, we can fetch the ! -- VP typecode from Container. Append_To (Block_Decls, Make_Object_Declaration (Loc, --- 9560,9569 ---- Make_Handled_Sequence_Of_Statements (Loc, Statements => Block_Stmts))); ! -- Declare variant part aggregate (Union_Any). ! -- Knowing the position of this VP in the ! -- variant record, we can fetch the VP typecode ! -- from Container. Append_To (Block_Decls, Make_Object_Declaration (Loc, *************** package body Exp_Dist is *** 9724,9732 **** Make_Integer_Literal (Loc, Counter))))))); ! -- Declare the inner struct aggregate ! -- (that will contain the components ! -- of this VP) Append_To (Block_Decls, Make_Object_Declaration (Loc, --- 9584,9591 ---- Make_Integer_Literal (Loc, Counter))))))); ! -- Declare inner struct aggregate (which ! -- contains the components of this VP). Append_To (Block_Decls, Make_Object_Declaration (Loc, *************** package body Exp_Dist is *** 9747,9762 **** Make_Integer_Literal (Loc, Uint_1))))))); ! -- Construct a case statement that will choose ! -- the appropriate code at runtime depending on ! -- the discriminant. Append_To (Block_Stmts, Make_Case_Statement (Loc, ! Expression => ! Make_Discriminant_Reference, ! Alternatives => ! Alt_List)); Variant := First_Non_Pragma (Variants (Field)); while Present (Variant) loop --- 9606,9617 ---- Make_Integer_Literal (Loc, Uint_1))))))); ! -- Build case statement Append_To (Block_Stmts, Make_Case_Statement (Loc, ! Expression => Make_Discriminant_Reference, ! Alternatives => Alt_List)); Variant := First_Non_Pragma (Variants (Field)); while Present (Variant) loop *************** package body Exp_Dist is *** 9765,9772 **** VP_Stmts := New_List; ! -- Append discriminant value to union ! -- aggregate. Append_To (VP_Stmts, Make_Procedure_Call_Statement (Loc, --- 9620,9626 ---- VP_Stmts := New_List; ! -- Append discriminant val to union aggregate Append_To (VP_Stmts, Make_Procedure_Call_Statement (Loc, *************** package body Exp_Dist is *** 9775,9783 **** RTE (RE_Add_Aggregate_Element), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Union_Any, Loc), ! Build_To_Any_Call ( ! Make_Discriminant_Reference, ! Block_Decls)))); -- Populate inner struct aggregate --- 9629,9637 ---- RTE (RE_Add_Aggregate_Element), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Union_Any, Loc), ! Build_To_Any_Call ! (Make_Discriminant_Reference, ! Block_Decls)))); -- Populate inner struct aggregate *************** package body Exp_Dist is *** 9821,9832 **** Append_To (Alt_List, Make_Case_Statement_Alternative (Loc, Discrete_Choices => Choice_List, ! Statements => VP_Stmts)); Next_Non_Pragma (Variant); end loop; ! end; end if; Counter := Counter + 1; end TA_Rec_Add_Process_Element; --- 9675,9687 ---- Append_To (Alt_List, Make_Case_Statement_Alternative (Loc, Discrete_Choices => Choice_List, ! Statements => VP_Stmts)); Next_Non_Pragma (Variant); end loop; ! end Variant_Part; end if; + Counter := Counter + 1; end TA_Rec_Add_Process_Element; *************** package body Exp_Dist is *** 9936,9941 **** --- 9791,9799 ---- end if; elsif Is_Array_Type (Typ) then + + -- Constrained and unconstrained array types + declare Constrained : constant Boolean := Is_Constrained (Typ); *************** package body Exp_Dist is *** 10021,10026 **** --- 9879,9887 ---- end; elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then + + -- Integer types + Set_Expression (Any_Decl, Build_To_Any_Call ( OK_Convert_To ( *************** package body Exp_Dist is *** 10029,10042 **** Decls)); else ! -- Default: type is represented as an opaque sequence of bytes declare ! Strm : constant Entity_Id := Make_Defining_Identifier (Loc, ! New_Internal_Name ('S')); begin ! -- Strm : aliased Buffer_Stream_Type; Append_To (Decls, Make_Object_Declaration (Loc, --- 9890,9911 ---- Decls)); else ! -- Default case, including tagged types: opaque representation ! ! Use_Opaque_Representation := True; ! end if; + if Use_Opaque_Representation then declare ! Strm : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('S')); ! -- Stream used to store data representation produced by ! -- stream attribute. begin ! -- Generate: ! -- Strm : aliased Buffer_Stream_Type; Append_To (Decls, Make_Object_Declaration (Loc, *************** package body Exp_Dist is *** 10047,10053 **** Object_Definition => New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); ! -- Allocate_Buffer (Strm); Append_To (Stms, Make_Procedure_Call_Statement (Loc, --- 9916,9923 ---- Object_Definition => New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); ! -- Generate: ! -- Allocate_Buffer (Strm); Append_To (Stms, Make_Procedure_Call_Statement (Loc, *************** package body Exp_Dist is *** 10056,10089 **** Parameter_Associations => New_List ( New_Occurrence_Of (Strm, Loc)))); ! -- T'Output (Strm'Access, E); Append_To (Stms, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Output, ! Expressions => New_List ( Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Strm, Loc), Attribute_Name => Name_Access), New_Occurrence_Of (Expr_Parameter, Loc)))); ! -- BS_To_Any (Strm, A); Append_To (Stms, Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_BS_To_Any), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Strm, Loc), New_Occurrence_Of (Any, Loc)))); ! -- Release_Buffer (Strm); Append_To (Stms, Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Strm, Loc)))); end; --- 9926,9960 ---- Parameter_Associations => New_List ( New_Occurrence_Of (Strm, Loc)))); ! -- Generate: ! -- T'Output (Strm'Access, E); Append_To (Stms, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Output, ! Expressions => New_List ( Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Strm, Loc), Attribute_Name => Name_Access), New_Occurrence_Of (Expr_Parameter, Loc)))); ! -- Generate: ! -- BS_To_Any (Strm, A); Append_To (Stms, Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Strm, Loc), New_Occurrence_Of (Any, Loc)))); ! -- Generate: ! -- Release_Buffer (Strm); Append_To (Stms, Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Strm, Loc)))); end; *************** package body Exp_Dist is *** 10106,10113 **** Decl := Make_Subprogram_Body (Loc, ! Specification => Spec, ! Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stms)); --- 9977,9984 ---- Decl := Make_Subprogram_Body (Loc, ! Specification => Spec, ! Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stms)); *************** package body Exp_Dist is *** 10122,10142 **** Typ : Entity_Id; Decls : List_Id) return Node_Id is ! U_Type : Entity_Id := Underlying_Type (Typ); -- The full view, if Typ is private; the completion, -- if Typ is incomplete. ! Fnam : Entity_Id := Empty; ! Lib_RE : RE_Id := RE_Null; ! ! Expr : Node_Id; begin -- Special case System.PolyORB.Interface.Any: its primitives have -- not been set yet, so can't call Find_Inherited_TSS. if Typ = RTE (RE_Any) then ! Fnam := RTE (RE_TC_Any); else -- First simple case where the TypeCode is present --- 9993,10012 ---- Typ : Entity_Id; Decls : List_Id) return Node_Id is ! U_Type : Entity_Id := Underlying_Type (Typ); -- The full view, if Typ is private; the completion, -- if Typ is incomplete. ! Fnam : Entity_Id := Empty; ! Lib_RE : RE_Id := RE_Null; ! Expr : Node_Id; begin -- Special case System.PolyORB.Interface.Any: its primitives have -- not been set yet, so can't call Find_Inherited_TSS. if Typ = RTE (RE_Any) then ! Fnam := RTE (RE_TC_A); else -- First simple case where the TypeCode is present *************** package body Exp_Dist is *** 10217,10222 **** --- 10087,10097 ---- elsif U_Type = Standard_String then Lib_RE := RE_TC_String; + -- Special DSA types + + elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then + Lib_RE := RE_TC_A; + -- Other (non-primitive) types else *************** package body Exp_Dist is *** 10260,10267 **** Stms : constant List_Id := New_List; TCNam : constant Entity_Id := ! Make_Stream_Procedure_Function_Name (Loc, ! Typ, Name_uTypeCode); Parameters : List_Id; --- 10135,10141 ---- Stms : constant List_Id := New_List; TCNam : constant Entity_Id := ! Make_Helper_Function_Name (Loc, Typ, Name_TypeCode); Parameters : List_Id; *************** package body Exp_Dist is *** 10310,10317 **** begin Append_To (Parameter_List, Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_TA_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, S)))); end Add_String_Parameter; --- 10184,10190 ---- begin Append_To (Parameter_List, Make_Function_Call (Loc, ! Name => New_Occurrence_Of (RTE (RE_TA_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, S)))); end Add_String_Parameter; *************** package body Exp_Dist is *** 10327,10336 **** begin Append_To (Parameter_List, Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_TA_TC), Loc), ! Parameter_Associations => New_List ( ! TC_Node))); end Add_TypeCode_Parameter; ------------------------ --- 10200,10207 ---- begin Append_To (Parameter_List, Make_Function_Call (Loc, ! Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc), ! Parameter_Associations => New_List (TC_Node))); end Add_TypeCode_Parameter; ------------------------ *************** package body Exp_Dist is *** 10344,10351 **** begin Append_To (Parameter_List, Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_TA_LI), Loc), Parameter_Associations => New_List (Expr_Node))); end Add_Long_Parameter; --- 10215,10221 ---- begin Append_To (Parameter_List, Make_Function_Call (Loc, ! Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc), Parameter_Associations => New_List (Expr_Node))); end Add_Long_Parameter; *************** package body Exp_Dist is *** 10406,10412 **** Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => ! Make_Constructed_TypeCode (Kind, Parameters))); end Return_Constructed_TypeCode; ------------------ --- 10276,10282 ---- Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => ! Make_Constructed_TypeCode (Kind, Parameters))); end Return_Constructed_TypeCode; ------------------ *************** package body Exp_Dist is *** 10445,10452 **** -- A regular component ! Add_TypeCode_Parameter ( ! Build_TypeCode_Call (Loc, Etype (Field), Decls), Params); Get_Name_String (Chars (Field)); Add_String_Parameter (String_From_Name_Buffer, Params); --- 10315,10322 ---- -- A regular component ! Add_TypeCode_Parameter ! (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params); Get_Name_String (Chars (Field)); Add_String_Parameter (String_From_Name_Buffer, Params); *************** package body Exp_Dist is *** 10483,10489 **** -- to the union parameter list. -- Ordering of declarations is a complete mess in this ! -- area, it is supposed to be types/varibles, then -- subprogram specs, then subprogram bodies ??? --------------------------------------- --- 10353,10359 ---- -- to the union parameter list. -- Ordering of declarations is a complete mess in this ! -- area, it is supposed to be types/variables, then -- subprogram specs, then subprogram bodies ??? --------------------------------------- *************** package body Exp_Dist is *** 10586,10592 **** declare Default_Node : constant Node_Id := ! Pick (Union_TC_Params, 4); New_Default_Node : constant Node_Id := Make_Function_Call (Loc, --- 10456,10462 ---- declare Default_Node : constant Node_Id := ! Pick (Union_TC_Params, 4); New_Default_Node : constant Node_Id := Make_Function_Call (Loc, *************** package body Exp_Dist is *** 10629,10635 **** declare Exp : constant Node_Id := ! New_Copy_Tree (Choice); begin Append_To (Union_TC_Params, Build_To_Any_Call (Exp, Decls)); --- 10499,10505 ---- declare Exp : constant Node_Id := ! New_Copy_Tree (Choice); begin Append_To (Union_TC_Params, Build_To_Any_Call (Exp, Decls)); *************** package body Exp_Dist is *** 10637,10650 **** Add_Params_For_Variant_Components; end case; Next (Choice); Choice_Index := Choice_Index + 1; - end loop; Next_Non_Pragma (Variant); end loop; - end; end if; end TC_Rec_Add_Process_Element; --- 10507,10519 ---- Add_Params_For_Variant_Components; end case; + Next (Choice); Choice_Index := Choice_Index + 1; end loop; Next_Non_Pragma (Variant); end loop; end; end if; end TC_Rec_Add_Process_Element; *************** package body Exp_Dist is *** 10666,10697 **** Spec := Make_Function_Specification (Loc, ! Defining_Unit_Name => Fnam, Parameter_Specifications => Empty_List, ! Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); Build_Name_And_Repository_Id (Typ, Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str); Initialize_Parameter_List (Type_Name_Str, Type_Repo_Id_Str, Parameters); ! if Is_Derived_Type (Typ) ! and then not Is_Tagged_Type (Typ) then Return_Alias_TypeCode ( Build_TypeCode_Call (Loc, Etype (Typ), Decls)); ! elsif Is_Integer_Type (Typ) ! or else Is_Unsigned_Type (Typ) ! then Return_Alias_TypeCode ( Build_TypeCode_Call (Loc, Find_Numeric_Representation (Typ), Decls)); ! elsif Is_Record_Type (Typ) ! and then not Is_Tagged_Type (Typ) ! then -- Record typecodes are encoded as follows: -- -- TC_STRUCT --- 10535,10574 ---- Spec := Make_Function_Specification (Loc, ! Defining_Unit_Name => Fnam, Parameter_Specifications => Empty_List, ! Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); Build_Name_And_Repository_Id (Typ, Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str); + Initialize_Parameter_List (Type_Name_Str, Type_Repo_Id_Str, Parameters); ! if Has_Stream_Attribute_Definition ! (Typ, TSS_Stream_Output, At_Any_Place => True) ! or else ! Has_Stream_Attribute_Definition ! (Typ, TSS_Stream_Write, At_Any_Place => True) then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Return_Alias_TypeCode + (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then Return_Alias_TypeCode ( Build_TypeCode_Call (Loc, Etype (Typ), Decls)); ! elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then Return_Alias_TypeCode ( Build_TypeCode_Call (Loc, Find_Numeric_Representation (Typ), Decls)); ! elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then -- Record typecodes are encoded as follows: -- -- TC_STRUCT *************** package body Exp_Dist is *** 10736,10755 **** -- | [VP Name] if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then ! Return_Alias_TypeCode ( ! Build_TypeCode_Call (Loc, Etype (Typ), Decls)); else declare Disc : Entity_Id := Empty; Rdef : constant Node_Id := ! Type_Definition (Declaration_Node (Typ)); Dummy_Counter : Int := 0; begin -- Construct the discriminants typecodes if Has_Discriminants (Typ) then Disc := First_Discriminant (Typ); end if; while Present (Disc) loop Add_TypeCode_Parameter ( Build_TypeCode_Call (Loc, Etype (Disc), Decls), --- 10613,10635 ---- -- | [VP Name] if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then ! Return_Alias_TypeCode ! (Build_TypeCode_Call (Loc, Etype (Typ), Decls)); ! else declare Disc : Entity_Id := Empty; Rdef : constant Node_Id := ! Type_Definition (Declaration_Node (Typ)); Dummy_Counter : Int := 0; + begin -- Construct the discriminants typecodes if Has_Discriminants (Typ) then Disc := First_Discriminant (Typ); end if; + while Present (Disc) loop Add_TypeCode_Parameter ( Build_TypeCode_Call (Loc, Etype (Disc), Decls), *************** package body Exp_Dist is *** 10778,10786 **** Indx : Node_Id := First_Index (Typ); begin ! Inner_TypeCode := Build_TypeCode_Call (Loc, ! Component_Type (Typ), ! Decls); for J in 1 .. Ndim loop if Constrained then --- 10658,10665 ---- Indx : Node_Id := First_Index (Typ); begin ! Inner_TypeCode := ! Build_TypeCode_Call (Loc, Component_Type (Typ), Decls); for J in 1 .. Ndim loop if Constrained then *************** package body Exp_Dist is *** 10789,10801 **** Build_To_Any_Call ( OK_Convert_To (RTE (RE_Long_Unsigned), Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Typ, Loc), ! Attribute_Name => ! Name_Length, Expressions => New_List ( Make_Integer_Literal (Loc, ! Ndim - J + 1)))), Decls), Build_To_Any_Call (Inner_TypeCode, Decls))); --- 10668,10678 ---- Build_To_Any_Call ( OK_Convert_To (RTE (RE_Long_Unsigned), Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Typ, Loc), ! Attribute_Name => Name_Length, Expressions => New_List ( Make_Integer_Literal (Loc, ! Intval => Ndim - J + 1)))), Decls), Build_To_Any_Call (Inner_TypeCode, Decls))); *************** package body Exp_Dist is *** 10842,10849 **** Decl := Make_Subprogram_Body (Loc, ! Specification => Spec, ! Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stms)); --- 10719,10726 ---- Decl := Make_Subprogram_Body (Loc, ! Specification => Spec, ! Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stms)); *************** package body Exp_Dist is *** 10947,10953 **** Make_Indexed_Component (Loc, New_Occurrence_Of (Arry, Loc), Indices); - begin Set_Etype (Element_Expr, Component_Type (Typ)); Add_Process_Element (Stmts, --- 10824,10829 ---- *************** package body Exp_Dist is *** 10979,10986 **** declare Loop_Any : Node_Id := Inner_Any; - begin -- For the first dimension of a constrained array, we add -- elements directly in the corresponding Any; there is no -- intervening inner Any. --- 10855,10862 ---- declare Loop_Any : Node_Id := Inner_Any; + begin -- For the first dimension of a constrained array, we add -- elements directly in the corresponding Any; there is no -- intervening inner Any. *************** package body Exp_Dist is *** 11030,11037 **** if Constrained then Inner_Any_TypeCode_Expr := Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Get_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc))); else --- 10906,10912 ---- if Constrained then Inner_Any_TypeCode_Expr := Make_Function_Call (Loc, ! Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc))); else *************** package body Exp_Dist is *** 11046,11056 **** else Inner_Any_TypeCode_Expr := Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Content_Type), Loc), Parameter_Associations => New_List ( Make_Identifier (Loc, ! New_External_Name ('T', Depth - 1)))); end if; Append_To (Decls, --- 10921,10930 ---- else Inner_Any_TypeCode_Expr := Make_Function_Call (Loc, ! Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc), Parameter_Associations => New_List ( Make_Identifier (Loc, ! Chars => New_External_Name ('T', Depth - 1)))); end if; Append_To (Decls, *************** package body Exp_Dist is *** 11124,11152 **** end; end Append_Array_Traversal; ! ----------------------------------------- ! -- Make_Stream_Procedure_Function_Name -- ! ----------------------------------------- ! function Make_Stream_Procedure_Function_Name (Loc : Source_Ptr; Typ : Entity_Id; Nam : Name_Id) return Entity_Id is begin ! -- For tagged types, we use a canonical name so that it matches ! -- the primitive spec. For all other cases, we use a serialized ! -- name so that multiple generations of the same procedure do not ! -- clash. ! if Is_Tagged_Type (Typ) then ! return Make_Defining_Identifier (Loc, Nam); ! else ! return Make_Defining_Identifier (Loc, Chars => ! New_External_Name (Nam, ' ', Increment_Serial_Number)); ! end if; ! end Make_Stream_Procedure_Function_Name; end Helpers; ----------------------------------- --- 10998,11037 ---- end; end Append_Array_Traversal; ! ------------------------------- ! -- Make_Helper_Function_Name -- ! ------------------------------- ! function Make_Helper_Function_Name (Loc : Source_Ptr; Typ : Entity_Id; Nam : Name_Id) return Entity_Id is begin ! declare ! Serial : Nat := 0; ! -- For tagged types, we use a canonical name so that it matches ! -- the primitive spec. For all other cases, we use a serialized ! -- name so that multiple generations of the same procedure do ! -- not clash. ! begin ! if not Is_Tagged_Type (Typ) then ! Serial := Increment_Serial_Number; ! end if; ! ! -- Use prefixed underscore to avoid potential clash with used ! -- identifier (we use attribute names for Nam). ! ! return ! Make_Defining_Identifier (Loc, Chars => ! New_External_Name ! (Related_Id => Nam, ! Suffix => ' ', Suffix_Index => Serial, ! Prefix => '_')); ! end; ! end Make_Helper_Function_Name; end Helpers; ----------------------------------- *************** package body Exp_Dist is *** 11226,11237 **** is Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Full_View); begin if Stub_Elements /= Empty_Stub_Structure then ! Add_RACW_Primitive_Declarations_And_Bodies ! (Full_View, ! Stub_Elements.RPC_Receiver_Decl, ! Stub_Elements.Body_Decls); end if; end Remote_Types_Tagged_Full_View_Encountered; --- 11111,11146 ---- is Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Full_View); + begin + -- For an RACW encountered before the freeze point of its designated + -- type, the stub type is generated at the point of the RACW declaration + -- but the primitives are generated only once the designated type is + -- frozen. That freeze can occur in another scope, for example when the + -- RACW is declared in a nested package. In that case we need to + -- reestablish the stub type's scope prior to generating its primitive + -- operations. + if Stub_Elements /= Empty_Stub_Structure then ! declare ! Saved_Scope : constant Entity_Id := Current_Scope; ! Stubs_Scope : constant Entity_Id := ! Scope (Stub_Elements.Stub_Type); ! ! begin ! if Current_Scope /= Stubs_Scope then ! Push_Scope (Stubs_Scope); ! end if; ! ! Add_RACW_Primitive_Declarations_And_Bodies ! (Full_View, ! Stub_Elements.RPC_Receiver_Decl, ! Stub_Elements.Body_Decls); ! ! if Current_Scope /= Saved_Scope then ! Pop_Scope; ! end if; ! end; end if; end Remote_Types_Tagged_Full_View_Encountered; *************** package body Exp_Dist is *** 11294,11300 **** (Loc : Source_Ptr; Decls : List_Id; RPC_Receiver : Entity_Id; ! Stub_Elements : Stub_Structure) is begin case Get_PCS_Name is when Name_PolyORB_DSA => --- 11203,11210 ---- (Loc : Source_Ptr; Decls : List_Id; RPC_Receiver : Entity_Id; ! Stub_Elements : Stub_Structure) ! is begin case Get_PCS_Name is when Name_PolyORB_DSA => *************** package body Exp_Dist is *** 11316,11340 **** Stub_Type : Entity_Id; Stub_Type_Access : Entity_Id; RPC_Receiver_Decl : Node_Id; ! Body_Decls : List_Id) is begin case Get_PCS_Name is when Name_PolyORB_DSA => ! PolyORB_Support.Add_RACW_Features ( ! RACW_Type, ! Desig, ! Stub_Type, ! Stub_Type_Access, ! RPC_Receiver_Decl, ! Body_Decls); when others => ! GARLIC_Support.Add_RACW_Features ( ! RACW_Type, ! Stub_Type, ! Stub_Type_Access, ! RPC_Receiver_Decl, ! Body_Decls); end case; end Specific_Add_RACW_Features; --- 11226,11251 ---- Stub_Type : Entity_Id; Stub_Type_Access : Entity_Id; RPC_Receiver_Decl : Node_Id; ! Body_Decls : List_Id) ! is begin case Get_PCS_Name is when Name_PolyORB_DSA => ! PolyORB_Support.Add_RACW_Features ! (RACW_Type, ! Desig, ! Stub_Type, ! Stub_Type_Access, ! RPC_Receiver_Decl, ! Body_Decls); when others => ! GARLIC_Support.Add_RACW_Features ! (RACW_Type, ! Stub_Type, ! Stub_Type_Access, ! RPC_Receiver_Decl, ! Body_Decls); end case; end Specific_Add_RACW_Features; *************** package body Exp_Dist is *** 11344,11350 **** procedure Specific_Add_RAST_Features (Vis_Decl : Node_Id; ! RAS_Type : Entity_Id) is begin case Get_PCS_Name is when Name_PolyORB_DSA => --- 11255,11262 ---- procedure Specific_Add_RAST_Features (Vis_Decl : Node_Id; ! RAS_Type : Entity_Id) ! is begin case Get_PCS_Name is when Name_PolyORB_DSA => *************** package body Exp_Dist is *** 11366,11376 **** begin case Get_PCS_Name is when Name_PolyORB_DSA => ! PolyORB_Support.Add_Receiving_Stubs_To_Declarations ( ! Pkg_Spec, Decls, Stmts); when others => ! GARLIC_Support.Add_Receiving_Stubs_To_Declarations ( ! Pkg_Spec, Decls, Stmts); end case; end Specific_Add_Receiving_Stubs_To_Declarations; --- 11278,11288 ---- begin case Get_PCS_Name is when Name_PolyORB_DSA => ! PolyORB_Support.Add_Receiving_Stubs_To_Declarations ! (Pkg_Spec, Decls, Stmts); when others => ! GARLIC_Support.Add_Receiving_Stubs_To_Declarations ! (Pkg_Spec, Decls, Stmts); end case; end Specific_Add_Receiving_Stubs_To_Declarations; *************** package body Exp_Dist is *** 11395,11428 **** begin case Get_PCS_Name is when Name_PolyORB_DSA => ! PolyORB_Support.Build_General_Calling_Stubs ( ! Decls, ! Statements, ! Target.Object, ! Subprogram_Id, ! Asynchronous, ! Is_Known_Asynchronous, ! Is_Known_Non_Asynchronous, ! Is_Function, ! Spec, ! Stub_Type, ! RACW_Type, ! Nod); when others => ! GARLIC_Support.Build_General_Calling_Stubs ( ! Decls, ! Statements, ! Target.Partition, ! Target.RPC_Receiver, ! Subprogram_Id, ! Asynchronous, ! Is_Known_Asynchronous, ! Is_Known_Non_Asynchronous, ! Is_Function, ! Spec, ! Stub_Type, ! RACW_Type, ! Nod); end case; end Specific_Build_General_Calling_Stubs; --- 11307,11341 ---- begin case Get_PCS_Name is when Name_PolyORB_DSA => ! PolyORB_Support.Build_General_Calling_Stubs ! (Decls, ! Statements, ! Target.Object, ! Subprogram_Id, ! Asynchronous, ! Is_Known_Asynchronous, ! Is_Known_Non_Asynchronous, ! Is_Function, ! Spec, ! Stub_Type, ! RACW_Type, ! Nod); ! when others => ! GARLIC_Support.Build_General_Calling_Stubs ! (Decls, ! Statements, ! Target.Partition, ! Target.RPC_Receiver, ! Subprogram_Id, ! Asynchronous, ! Is_Known_Asynchronous, ! Is_Known_Non_Asynchronous, ! Is_Function, ! Spec, ! Stub_Type, ! RACW_Type, ! Nod); end case; end Specific_Build_General_Calling_Stubs; *************** package body Exp_Dist is *** 11448,11453 **** --- 11361,11367 ---- Subp_Index, Stmts, Decl); + when others => GARLIC_Support.Build_RPC_Receiver_Body (RPC_Receiver, *************** package body Exp_Dist is *** 11474,11479 **** --- 11388,11394 ---- when Name_PolyORB_DSA => return PolyORB_Support.Build_Stub_Target (Loc, Decls, RCI_Locator, Controlling_Parameter); + when others => return GARLIC_Support.Build_Stub_Target (Loc, Decls, RCI_Locator, Controlling_Parameter); *************** package body Exp_Dist is *** 11496,11501 **** --- 11411,11417 ---- PolyORB_Support.Build_Stub_Type ( RACW_Type, Stub_Type, Stub_Type_Decl, RPC_Receiver_Decl); + when others => GARLIC_Support.Build_Stub_Type ( RACW_Type, Stub_Type, *************** package body Exp_Dist is *** 11514,11537 **** begin case Get_PCS_Name is when Name_PolyORB_DSA => ! return PolyORB_Support.Build_Subprogram_Receiving_Stubs ( ! Vis_Decl, ! Asynchronous, ! Dynamically_Asynchronous, ! Stub_Type, ! RACW_Type, ! Parent_Primitive); when others => ! return GARLIC_Support.Build_Subprogram_Receiving_Stubs ( ! Vis_Decl, ! Asynchronous, ! Dynamically_Asynchronous, ! Stub_Type, ! RACW_Type, ! Parent_Primitive); end case; end Specific_Build_Subprogram_Receiving_Stubs; -------------------------- -- Underlying_RACW_Type -- -------------------------- --- 11430,11465 ---- begin case Get_PCS_Name is when Name_PolyORB_DSA => ! return PolyORB_Support.Build_Subprogram_Receiving_Stubs ! (Vis_Decl, ! Asynchronous, ! Dynamically_Asynchronous, ! Stub_Type, ! RACW_Type, ! Parent_Primitive); ! when others => ! return GARLIC_Support.Build_Subprogram_Receiving_Stubs ! (Vis_Decl, ! Asynchronous, ! Dynamically_Asynchronous, ! Stub_Type, ! RACW_Type, ! Parent_Primitive); end case; end Specific_Build_Subprogram_Receiving_Stubs; + ------------------------------- + -- Transmit_As_Unconstrained -- + ------------------------------- + + function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is + begin + return + not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ)) + or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ)); + end Transmit_As_Unconstrained; + -------------------------- -- Underlying_RACW_Type -- -------------------------- *************** package body Exp_Dist is *** 11548,11557 **** end if; return ! Etype (Subtype_Indication ( ! Component_Definition ( ! First (Component_Items (Component_List ( ! Type_Definition (Declaration_Node (Record_Type)))))))); end Underlying_RACW_Type; end Exp_Dist; --- 11476,11487 ---- end if; return ! Etype (Subtype_Indication ! (Component_Definition ! (First (Component_Items ! (Component_List ! (Type_Definition ! (Declaration_Node (Record_Type)))))))); end Underlying_RACW_Type; end Exp_Dist; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_dist.ads gcc-4.4.0/gcc/ada/exp_dist.ads *** gcc-4.3.3/gcc/ada/exp_dist.ads Wed Sep 26 10:42:09 2007 --- gcc-4.4.0/gcc/ada/exp_dist.ads Mon Aug 4 09:50:09 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** *** 26,37 **** -- This package contains utility routines used for the generation of the -- stubs relevant to the distribution annex. ! with Namet; use Namet; ! with Types; use Types; package Exp_Dist is ! PCS_Version_Number : constant := 1; -- PCS interface version. This is used to check for consistency between the -- compiler used to generate distribution stubs and the PCS implementation. -- It must be incremented whenever a change is made to the generated code --- 26,41 ---- -- This package contains utility routines used for the generation of the -- stubs relevant to the distribution annex. ! with Namet; use Namet; ! with Snames; use Snames; ! with Types; use Types; package Exp_Dist is ! PCS_Version_Number : constant array (PCS_Names) of Int := ! (Name_No_DSA => 1, ! Name_GARLIC_DSA => 1, ! Name_PolyORB_DSA => 2); -- PCS interface version. This is used to check for consistency between the -- compiler used to generate distribution stubs and the PCS implementation. -- It must be incremented whenever a change is made to the generated code *************** package Exp_Dist is *** 53,59 **** Insertion_Node : Node_Id; Body_Decls : List_Id); -- Add primitive for the stub type, and the RPC receiver. The declarations ! -- are inserted after insertion_Node, while the bodies are appened at the -- end of Decls. procedure Remote_Types_Tagged_Full_View_Encountered --- 57,63 ---- Insertion_Node : Node_Id; Body_Decls : List_Id); -- Add primitive for the stub type, and the RPC receiver. The declarations ! -- are inserted after Insertion_Node, while the bodies are appended at the -- end of Decls. procedure Remote_Types_Tagged_Full_View_Encountered *************** package Exp_Dist is *** 125,128 **** --- 129,165 ---- -- a remote call) satisfies the requirements for being transportable -- across partitions, raising Program_Error if it does not. + ---------------------------------------------------------------- + -- Functions for expansion of PolyORB/DSA specific attributes -- + ---------------------------------------------------------------- + + function Build_From_Any_Call + (Typ : Entity_Id; + N : Node_Id; + Decls : List_Id) return Node_Id; + -- Build call to From_Any attribute function of type Typ with expression + -- N as actual parameter. Decls is the declarations list for an appropriate + -- enclosing scope of the point where the call will be inserted; if the + -- From_Any attribute for Typ needs to be generated at this point, its + -- declaration is appended to Decls. + + function Build_To_Any_Call + (N : Node_Id; + Decls : List_Id) return Node_Id; + -- Build call to To_Any attribute function with expression as actual + -- parameter. Decls is the declarations list for an appropriate + -- enclosing scope of the point where the call will be inserted; if + -- the To_Any attribute for Typ needs to be generated at this point, + -- its declaration is appended to Decls. + + function Build_TypeCode_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Decls : List_Id) return Node_Id; + -- Build call to TypeCode attribute function for Typ. Decls is the + -- declarations list for an appropriate enclosing scope of the point + -- where the call will be inserted; if the To_Any attribute for Typ + -- needs to be generated at this point, its declaration is appended + -- to Decls. + end Exp_Dist; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_fixd.adb gcc-4.4.0/gcc/ada/exp_fixd.adb *** gcc-4.3.3/gcc/ada/exp_fixd.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/exp_fixd.adb Wed May 28 13:05:46 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Exp_Fixd is *** 103,109 **** function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id; -- Builds an N_Op_Multiply node from the given left and right operand -- expressions, using the source location from Sloc (N). The operands are ! -- either both Universal_Real, in which case Build_Divide differs from -- Make_Op_Multiply only in that the Etype of the resulting node is set (to -- Universal_Real), or they can be integer types. In this case the integer -- types need not be the same, and Build_Multiply chooses a type long --- 103,109 ---- function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id; -- Builds an N_Op_Multiply node from the given left and right operand -- expressions, using the source location from Sloc (N). The operands are ! -- either both Universal_Real, in which case Build_Multiply differs from -- Make_Op_Multiply only in that the Etype of the resulting node is set (to -- Universal_Real), or they can be integer types. In this case the integer -- types need not be the same, and Build_Multiply chooses a type long *************** package body Exp_Fixd is *** 623,647 **** -- the effective size of an operand is the RM_Size of the operand. -- But a special case arises with operands whose size is known at -- compile time. In this case, we can use the actual value of the ! -- operand to get its size if it would fit in 8 or 16 bits. ! ! -- Note: if both operands are known at compile time (can that ! -- happen?) and both were equal to the power of 2, then we would ! -- be one bit off in this test, so for the left operand, we only ! -- go up to the power of 2 - 1. This ensures that we do not get ! -- this anomolous case, and in practice the right operand is by ! -- far the more likely one to be the constant. Left_Size := UI_To_Int (RM_Size (Left_Type)); if Compile_Time_Known_Value (L) then declare Val : constant Uint := Expr_Value (L); - begin ! if Val < Int'(2 ** 8) then Left_Size := 8; ! elsif Val < Int'(2 ** 16) then Left_Size := 16; end if; end; --- 623,639 ---- -- the effective size of an operand is the RM_Size of the operand. -- But a special case arises with operands whose size is known at -- compile time. In this case, we can use the actual value of the ! -- operand to get its size if it would fit signed in 8 or 16 bits. Left_Size := UI_To_Int (RM_Size (Left_Type)); if Compile_Time_Known_Value (L) then declare Val : constant Uint := Expr_Value (L); begin ! if Val < Int'(2 ** 7) then Left_Size := 8; ! elsif Val < Int'(2 ** 15) then Left_Size := 16; end if; end; *************** package body Exp_Fixd is *** 652,669 **** if Compile_Time_Known_Value (R) then declare Val : constant Uint := Expr_Value (R); - begin ! if Val <= Int'(2 ** 8) then Right_Size := 8; ! elsif Val <= Int'(2 ** 16) then Right_Size := 16; end if; end; end if; -- Now the result size must be at least twice the longer of ! -- the two sizes, to accomodate all possible results. Rsize := 2 * Int'Max (Left_Size, Right_Size); --- 644,660 ---- if Compile_Time_Known_Value (R) then declare Val : constant Uint := Expr_Value (R); begin ! if Val <= Int'(2 ** 7) then Right_Size := 8; ! elsif Val <= Int'(2 ** 15) then Right_Size := 16; end if; end; end if; -- Now the result size must be at least twice the longer of ! -- the two sizes, to accommodate all possible results. Rsize := 2 * Int'Max (Left_Size, Right_Size); *************** package body Exp_Fixd is *** 2123,2129 **** if Etype (Left) = Universal_Real then if Nkind (Left) = N_Real_Literal then ! Do_Multiply_Fixed_Universal (N, Right, Left); elsif Nkind (Left) = N_Type_Conversion then Rewrite_Non_Static_Universal (Left); --- 2114,2120 ---- if Etype (Left) = Universal_Real then if Nkind (Left) = N_Real_Literal then ! Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left); elsif Nkind (Left) = N_Type_Conversion then Rewrite_Non_Static_Universal (Left); *************** package body Exp_Fixd is *** 2214,2220 **** Right : constant Node_Id := Right_Opnd (N); begin if Etype (Left) = Universal_Real then ! Do_Multiply_Fixed_Universal (N, Right, Left); elsif Etype (Right) = Universal_Real then Do_Multiply_Fixed_Universal (N, Left, Right); else --- 2205,2211 ---- Right : constant Node_Id := Right_Opnd (N); begin if Etype (Left) = Universal_Real then ! Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left); elsif Etype (Right) = Universal_Real then Do_Multiply_Fixed_Universal (N, Left, Right); else diff -Nrcpad gcc-4.3.3/gcc/ada/exp_fixd.ads gcc-4.4.0/gcc/ada/exp_fixd.ads *** gcc-4.3.3/gcc/ada/exp_fixd.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_fixd.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Exp_Fixd is *** 32,38 **** -- General note on universal fixed. In the routines below, a fixed-point -- type is always a specific fixed-point type or universal real, never -- universal fixed. Universal fixed only appears as the result type of a ! -- division or multplication and in all such cases, the parent node, which -- must be either a conversion node or a 'Round attribute reference node, -- has the specific type information. In both cases, the parent node is -- removed from the tree, and the appropriate routine in this package is --- 32,38 ---- -- General note on universal fixed. In the routines below, a fixed-point -- type is always a specific fixed-point type or universal real, never -- universal fixed. Universal fixed only appears as the result type of a ! -- division or multiplication and in all such cases, the parent node, which -- must be either a conversion node or a 'Round attribute reference node, -- has the specific type information. In both cases, the parent node is -- removed from the tree, and the appropriate routine in this package is diff -Nrcpad gcc-4.3.3/gcc/ada/exp_imgv.adb gcc-4.4.0/gcc/ada/exp_imgv.adb *** gcc-4.3.3/gcc/ada/exp_imgv.adb Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/exp_imgv.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package body Exp_Imgv is *** 556,562 **** -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) -- where typS and typI and the Lit_Strings and Lit_Indexes entities ! -- from T's root type entitym and Num is Enum'Pos (Enum'Last). The -- Value_Enumeration_NN function will search the tables looking for -- X and return the position number in the table if found which is -- used to provide the result of 'Value (using Enum'Val). If the --- 556,562 ---- -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) -- where typS and typI and the Lit_Strings and Lit_Indexes entities ! -- from T's root type entity, and Num is Enum'Pos (Enum'Last). The -- Value_Enumeration_NN function will search the tables looking for -- X and return the position number in the table if found which is -- used to provide the result of 'Value (using Enum'Val). If the diff -Nrcpad gcc-4.3.3/gcc/ada/exp_intr.adb gcc-4.4.0/gcc/ada/exp_intr.adb *** gcc-4.3.3/gcc/ada/exp_intr.adb Thu Dec 13 10:26:41 2007 --- gcc-4.4.0/gcc/ada/exp_intr.adb Fri Aug 22 12:59:45 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Rtsfind; use Rtsfind; *** 45,50 **** --- 45,51 ---- with Sem; use Sem; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; + with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; *************** package body Exp_Intr is *** 87,93 **** -- K is the kind for the shift node procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id); ! -- Expand a call to an instantiation of Unchecked_Convertion into a node -- N_Unchecked_Type_Conversion. procedure Expand_Unc_Deallocation (N : Node_Id); --- 88,94 ---- -- K is the kind for the shift node procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id); ! -- Expand a call to an instantiation of Unchecked_Conversion into a node -- N_Unchecked_Type_Conversion. procedure Expand_Unc_Deallocation (N : Node_Id); *************** package body Exp_Intr is *** 97,103 **** procedure Expand_To_Address (N : Node_Id); procedure Expand_To_Pointer (N : Node_Id); -- Expand a call to corresponding function, declared in an instance of ! -- System.Addess_To_Access_Conversions. procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); -- Rewrite the node by the appropriate string or positive constant. --- 98,104 ---- procedure Expand_To_Address (N : Node_Id); procedure Expand_To_Pointer (N : Node_Id); -- Expand a call to corresponding function, declared in an instance of ! -- System.Address_To_Access_Conversions. procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); -- Rewrite the node by the appropriate string or positive constant. *************** package body Exp_Intr is *** 165,171 **** -- If the result type is not parent of Tag_Arg then we need to -- locate the tag of the secondary dispatch table. ! if not Is_Parent (Etype (Result_Typ), Etype (Tag_Arg)) then pragma Assert (not Is_Interface (Etype (Tag_Arg))); Iface_Tag := --- 166,172 ---- -- If the result type is not parent of Tag_Arg then we need to -- locate the tag of the secondary dispatch table. ! if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg)) then pragma Assert (not Is_Interface (Etype (Tag_Arg))); Iface_Tag := *************** package body Exp_Intr is *** 659,664 **** --- 660,667 ---- -- String cases else + Name_Len := 0; + case Nam is when Name_File => Get_Decoded_Name_String *************** package body Exp_Intr is *** 668,679 **** Build_Location_String (Loc); when Name_Enclosing_Entity => - Name_Len := 0; - - Ent := Current_Scope; -- Skip enclosing blocks to reach enclosing unit while Present (Ent) loop exit when Ekind (Ent) /= E_Block and then Ekind (Ent) /= E_Loop; --- 671,680 ---- Build_Location_String (Loc); when Name_Enclosing_Entity => -- Skip enclosing blocks to reach enclosing unit + Ent := Current_Scope; while Present (Ent) loop exit when Ekind (Ent) /= E_Block and then Ekind (Ent) /= E_Loop; *************** package body Exp_Intr is *** 682,688 **** -- Ent now points to the relevant defining entity - Name_Len := 0; Write_Entity_Name (Ent); when others => --- 683,688 ---- *************** package body Exp_Intr is *** 690,696 **** end case; Rewrite (N, ! Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); Analyze_And_Resolve (N, Standard_String); end if; --- 690,697 ---- end case; Rewrite (N, ! Make_String_Literal (Loc, ! Strval => String_From_Name_Buffer)); Analyze_And_Resolve (N, Standard_String); end if; *************** package body Exp_Intr is *** 814,820 **** -- Processing for pointer to controlled type ! if Controlled_Type (Desig_T) then Deref := Make_Explicit_Dereference (Loc, Prefix => Duplicate_Subexpr_No_Checks (Arg)); --- 815,821 ---- -- Processing for pointer to controlled type ! if Needs_Finalization (Desig_T) then Deref := Make_Explicit_Dereference (Loc, Prefix => Duplicate_Subexpr_No_Checks (Arg)); diff -Nrcpad gcc-4.3.3/gcc/ada/exp_pakd.adb gcc-4.4.0/gcc/ada/exp_pakd.adb *** gcc-4.3.3/gcc/ada/exp_pakd.adb Wed Dec 19 16:23:43 2007 --- gcc-4.4.0/gcc/ada/exp_pakd.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Layout; use Layout; *** 33,38 **** --- 33,39 ---- with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; + with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; *************** package body Exp_Pakd is *** 534,540 **** -- directly using Insert_Action. ------------------------------ ! -- Compute_Linear_Subcsript -- ------------------------------ procedure Compute_Linear_Subscript --- 535,541 ---- -- directly using Insert_Action. ------------------------------ ! -- Compute_Linear_Subscript -- ------------------------------ procedure Compute_Linear_Subscript *************** package body Exp_Pakd is *** 1091,1097 **** -- discriminants, so we treat it as a default/per-object expression. Set_Parent (Len_Expr, Typ); ! Analyze_Per_Use_Expression (Len_Expr, Standard_Long_Long_Integer); -- Use a modular type if possible. We can do this if we have -- static bounds, and the length is small enough, and the length --- 1092,1098 ---- -- discriminants, so we treat it as a default/per-object expression. Set_Parent (Len_Expr, Typ); ! Preanalyze_Spec_Expression (Len_Expr, Standard_Long_Long_Integer); -- Use a modular type if possible. We can do this if we have -- static bounds, and the length is small enough, and the length *************** package body Exp_Pakd is *** 1359,1365 **** Rhs := Convert_To (Ctyp, Rhs); Set_Parent (Rhs, N); ! Analyze_And_Resolve (Rhs, Ctyp); -- Case of component size 1,2,4 or any component size for the modular -- case. These are the cases for which we can inline the code. --- 1360,1378 ---- Rhs := Convert_To (Ctyp, Rhs); Set_Parent (Rhs, N); ! ! -- If we are building the initialization procedure for a packed array, ! -- and Initialize_Scalars is enabled, each component assignment is an ! -- out-of-range value by design. Compile this value without checks, ! -- because a call to the array init_proc must not raise an exception. ! ! if Within_Init_Proc ! and then Initialize_Scalars ! then ! Analyze_And_Resolve (Rhs, Ctyp, Suppress => All_Checks); ! else ! Analyze_And_Resolve (Rhs, Ctyp); ! end if; -- Case of component size 1,2,4 or any component size for the modular -- case. These are the cases for which we can inline the code. *************** package body Exp_Pakd is *** 1528,1534 **** else -- We have to convert the right hand side to Etype (Obj). ! -- A special case case arises if what we have now is a Val -- attribute reference whose expression type is Etype (Obj). -- This happens for assignments of fields from the same -- array. In this case we get the required right hand side --- 1541,1547 ---- else -- We have to convert the right hand side to Etype (Obj). ! -- A special case arises if what we have now is a Val -- attribute reference whose expression type is Etype (Obj). -- This happens for assignments of fields from the same -- array. In this case we get the required right hand side *************** package body Exp_Pakd is *** 1761,1807 **** Ltyp := Etype (L); Rtyp := Etype (R); ! -- First an odd and silly test. We explicitly check for the XOR ! -- case where the component type is True .. True, since this will ! -- raise constraint error. A special check is required since CE ! -- will not be required other wise (cf Expand_Packed_Not). ! ! -- No such check is required for AND and OR, since for both these ! -- cases False op False = False, and True op True = True. if Nkind (N) = N_Op_Xor then ! declare ! CT : constant Entity_Id := Component_Type (Rtyp); ! BT : constant Entity_Id := Base_Type (CT); ! ! begin ! Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, ! Condition => ! Make_Op_And (Loc, ! Left_Opnd => ! Make_Op_Eq (Loc, ! Left_Opnd => ! Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (CT, Loc), ! Attribute_Name => Name_First), ! ! Right_Opnd => ! Convert_To (BT, ! New_Occurrence_Of (Standard_True, Loc))), ! ! Right_Opnd => ! Make_Op_Eq (Loc, ! Left_Opnd => ! Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (CT, Loc), ! Attribute_Name => Name_Last), ! ! Right_Opnd => ! Convert_To (BT, ! New_Occurrence_Of (Standard_True, Loc)))), ! Reason => CE_Range_Check_Failed)); ! end; end if; -- Now that that silliness is taken care of, get packed array type --- 1774,1784 ---- Ltyp := Etype (L); Rtyp := Etype (R); ! -- Deal with silly case of XOR where the subcomponent has a range ! -- True .. True where an exception must be raised. if Nkind (N) = N_Op_Xor then ! Silly_Boolean_Array_Xor_Test (N, Rtyp); end if; -- Now that that silliness is taken care of, get packed array type *************** package body Exp_Pakd is *** 1997,2003 **** Left_Opnd => Make_Shift_Right (Obj, Shift), Right_Opnd => Lit); ! -- We neded to analyze this before we do the unchecked convert -- below, but we need it temporarily attached to the tree for -- this analysis (hence the temporary Set_Parent call). --- 1974,1980 ---- Left_Opnd => Make_Shift_Right (Obj, Shift), Right_Opnd => Lit); ! -- We needed to analyze this before we do the unchecked convert -- below, but we need it temporarily attached to the tree for -- this analysis (hence the temporary Set_Parent call). *************** package body Exp_Pakd is *** 2173,2209 **** Convert_To_Actual_Subtype (Opnd); Rtyp := Etype (Opnd); ! -- First an odd and silly test. We explicitly check for the case ! -- where the 'First of the component type is equal to the 'Last of ! -- this component type, and if this is the case, we make sure that ! -- constraint error is raised. The reason is that the NOT is bound ! -- to cause CE in this case, and we will not otherwise catch it. ! ! -- Believe it or not, this was reported as a bug. Note that nearly ! -- always, the test will evaluate statically to False, so the code ! -- will be statically removed, and no extra overhead caused. ! ! declare ! CT : constant Entity_Id := Component_Type (Rtyp); ! ! begin ! Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, ! Condition => ! Make_Op_Eq (Loc, ! Left_Opnd => ! Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (CT, Loc), ! Attribute_Name => Name_First), ! Right_Opnd => ! Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (CT, Loc), ! Attribute_Name => Name_Last)), ! Reason => CE_Range_Check_Failed)); ! end; ! -- Now that that silliness is taken care of, get packed array type Convert_To_PAT_Type (Opnd); PAT := Etype (Opnd); --- 2150,2160 ---- Convert_To_Actual_Subtype (Opnd); Rtyp := Etype (Opnd); ! -- Deal with silly False..False and True..True subtype case ! Silly_Boolean_Array_Not_Test (N, Rtyp); ! -- Now that the silliness is taken care of, get packed array type Convert_To_PAT_Type (Opnd); PAT := Etype (Opnd); diff -Nrcpad gcc-4.3.3/gcc/ada/exp_pakd.ads gcc-4.4.0/gcc/ada/exp_pakd.ads *** gcc-4.3.3/gcc/ada/exp_pakd.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_pakd.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Exp_Pakd is *** 218,224 **** -- Note: although this routine is included in the expander package for -- packed types, it is actually called unconditionally from Freeze, -- whether or not expansion (and code generation) is enabled. We do this ! -- since we want gigi to be able to properly compute type charactersitics -- (for the Data Decomposition Annex of ASIS, and possible other future -- uses) even if code generation is not active. Strictly this means that -- this procedure is not part of the expander, but it seems appropriate --- 218,224 ---- -- Note: although this routine is included in the expander package for -- packed types, it is actually called unconditionally from Freeze, -- whether or not expansion (and code generation) is enabled. We do this ! -- since we want gigi to be able to properly compute type characteristics -- (for the Data Decomposition Annex of ASIS, and possible other future -- uses) even if code generation is not active. Strictly this means that -- this procedure is not part of the expander, but it seems appropriate *************** package Exp_Pakd is *** 263,269 **** function Involves_Packed_Array_Reference (N : Node_Id) return Boolean; -- N is the node for a name. This function returns true if the name -- involves a packed array reference. A node involves a packed array ! -- reference if it is itself an indexed compoment referring to a bit- -- packed array, or it is a selected component whose prefix involves -- a packed array reference. --- 263,269 ---- function Involves_Packed_Array_Reference (N : Node_Id) return Boolean; -- N is the node for a name. This function returns true if the name -- involves a packed array reference. A node involves a packed array ! -- reference if it is itself an indexed component referring to a bit- -- packed array, or it is a selected component whose prefix involves -- a packed array reference. diff -Nrcpad gcc-4.3.3/gcc/ada/exp_prag.adb gcc-4.4.0/gcc/ada/exp_prag.adb *** gcc-4.3.3/gcc/ada/exp_prag.adb Thu Dec 13 10:26:56 2007 --- gcc-4.4.0/gcc/ada/exp_prag.adb Tue Apr 8 06:45:25 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Restrict; use Restrict; *** 40,46 **** with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; - with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; --- 40,45 ---- *************** package body Exp_Prag is *** 60,75 **** function Arg1 (N : Node_Id) return Node_Id; function Arg2 (N : Node_Id) return Node_Id; -- Obtain specified pragma argument expression procedure Expand_Pragma_Abort_Defer (N : Node_Id); ! procedure Expand_Pragma_Assert (N : Node_Id); procedure Expand_Pragma_Common_Object (N : Node_Id); procedure Expand_Pragma_Import_Or_Interface (N : Node_Id); procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); procedure Expand_Pragma_Psect_Object (N : Node_Id); ---------- -- Arg1 -- --- 59,76 ---- function Arg1 (N : Node_Id) return Node_Id; function Arg2 (N : Node_Id) return Node_Id; + function Arg3 (N : Node_Id) return Node_Id; -- Obtain specified pragma argument expression procedure Expand_Pragma_Abort_Defer (N : Node_Id); ! procedure Expand_Pragma_Check (N : Node_Id); procedure Expand_Pragma_Common_Object (N : Node_Id); procedure Expand_Pragma_Import_Or_Interface (N : Node_Id); procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); procedure Expand_Pragma_Psect_Object (N : Node_Id); + procedure Expand_Pragma_Relative_Deadline (N : Node_Id); ---------- -- Arg1 -- *************** package body Exp_Prag is *** 93,101 **** --- 94,104 ---- function Arg2 (N : Node_Id) return Node_Id is Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + begin if No (Arg1) then return Empty; + else declare Arg : constant Node_Id := Next (Arg1); *************** package body Exp_Prag is *** 111,135 **** end if; end Arg2; --------------------- -- Expand_N_Pragma -- --------------------- procedure Expand_N_Pragma (N : Node_Id) is begin ! -- Note: we may have a pragma whose chars field is not a -- recognized pragma, and we must ignore it at this stage. ! if Is_Pragma_Name (Chars (N)) then ! case Get_Pragma_Id (Chars (N)) is -- Pragmas requiring special expander action when Pragma_Abort_Defer => Expand_Pragma_Abort_Defer (N); ! when Pragma_Assert => ! Expand_Pragma_Assert (N); when Pragma_Common_Object => Expand_Pragma_Common_Object (N); --- 114,173 ---- end if; end Arg2; + ---------- + -- Arg3 -- + ---------- + + function Arg3 (N : Node_Id) return Node_Id is + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + + begin + if No (Arg1) then + return Empty; + + else + declare + Arg : Node_Id := Next (Arg1); + begin + if No (Arg) then + return Empty; + + else + Next (Arg); + + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + then + return Expression (Arg); + else + return Arg; + end if; + end if; + end; + end if; + end Arg3; + --------------------- -- Expand_N_Pragma -- --------------------- procedure Expand_N_Pragma (N : Node_Id) is + Pname : constant Name_Id := Pragma_Name (N); + begin ! -- Note: we may have a pragma whose Pragma_Identifier field is not a -- recognized pragma, and we must ignore it at this stage. ! if Is_Pragma_Name (Pname) then ! case Get_Pragma_Id (Pname) is -- Pragmas requiring special expander action when Pragma_Abort_Defer => Expand_Pragma_Abort_Defer (N); ! when Pragma_Check => ! Expand_Pragma_Check (N); when Pragma_Common_Object => Expand_Pragma_Common_Object (N); *************** package body Exp_Prag is *** 155,160 **** --- 193,201 ---- when Pragma_Psect_Object => Expand_Pragma_Psect_Object (N); + when Pragma_Relative_Deadline => + Expand_Pragma_Relative_Deadline (N); + -- All other pragmas need no expander action when others => null; *************** package body Exp_Prag is *** 225,249 **** end Expand_Pragma_Abort_Defer; -------------------------- ! -- Expand_Pragma_Assert -- -------------------------- ! procedure Expand_Pragma_Assert (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); ! Cond : constant Node_Id := Arg1 (N); ! Msg : String_Id; begin ! -- We already know that assertions are enabled, because otherwise ! -- the semantic pass dealt with rewriting the assertion (see Sem_Prag) ! ! pragma Assert (Assertions_Enabled); ! -- Since assertions are on, we rewrite the pragma with its -- corresponding if statement, and then analyze the statement -- The normal case expansion transforms: ! -- pragma Assert (condition [,message]); -- into --- 266,290 ---- end Expand_Pragma_Abort_Defer; -------------------------- ! -- Expand_Pragma_Check -- -------------------------- ! procedure Expand_Pragma_Check (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); ! Cond : constant Node_Id := Arg2 (N); ! Nam : constant Name_Id := Chars (Arg1 (N)); ! Msg : Node_Id; begin ! -- We already know that this check is enabled, because otherwise the ! -- semantic pass dealt with rewriting the assertion (see Sem_Prag) ! -- Since this check is enabled, we rewrite the pragma into a -- corresponding if statement, and then analyze the statement + -- The normal case expansion transforms: ! -- pragma Check (name, condition [,message]); -- into *************** package body Exp_Prag is *** 252,258 **** -- end if; -- where Str is the message if one is present, or the default of ! -- file:line if no message is given. -- An alternative expansion is used when the No_Exception_Propagation -- restriction is active and there is a local Assert_Failure handler. --- 293,301 ---- -- end if; -- where Str is the message if one is present, or the default of ! -- name failed at file:line if no message is given (the "name failed ! -- at" is omitted for name = Assertion, since it is redundant, given ! -- that the name of the exception is Assert_Failure. -- An alternative expansion is used when the No_Exception_Propagation -- restriction is active and there is a local Assert_Failure handler. *************** package body Exp_Prag is *** 279,285 **** -- Case where we generate a direct raise if (Debug_Flag_Dot_G ! or else Restriction_Active (No_Exception_Propagation)) and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)) then Rewrite (N, --- 322,328 ---- -- Case where we generate a direct raise if (Debug_Flag_Dot_G ! or else Restriction_Active (No_Exception_Propagation)) and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)) then Rewrite (N, *************** package body Exp_Prag is *** 295,307 **** -- Case where we call the procedure else ! -- First, we need to prepare the string literal - if Present (Arg2 (N)) then - Msg := Strval (Expr_Value_S (Arg2 (N))); else Build_Location_String (Loc); ! Msg := String_From_Name_Buffer; end if; -- Now rewrite as an if statement --- 338,366 ---- -- Case where we call the procedure else ! -- First, we need to prepare the string argument ! ! -- If we have a message given, use it ! ! if Present (Arg3 (N)) then ! Msg := Arg3 (N); ! ! -- Otherwise string is "name failed at location" except in the case ! -- of Assertion where "name failed at" is omitted. else + if Nam = Name_Assertion then + Name_Len := 0; + else + Get_Name_String (Nam); + Set_Casing (Identifier_Casing (Current_Source_File)); + Add_Str_To_Name_Buffer (" failed at "); + end if; + Build_Location_String (Loc); ! Msg := ! Make_String_Literal (Loc, ! Strval => String_From_Name_Buffer); end if; -- Now rewrite as an if statement *************** package body Exp_Prag is *** 315,322 **** Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), ! Parameter_Associations => New_List ( ! Make_String_Literal (Loc, Msg)))))); end if; Analyze (N); --- 374,380 ---- Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), ! Parameter_Associations => New_List (Msg))))); end if; Analyze (N); *************** package body Exp_Prag is *** 328,344 **** and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure) then -- If original condition was a Standard.False, we assume that this is ! -- indeed intented to raise assert error and no warning is required. if Is_Entity_Name (Original_Node (Cond)) and then Entity (Original_Node (Cond)) = Standard_False then return; ! else Error_Msg_N ("?assertion will fail at run-time", N); end if; end if; ! end Expand_Pragma_Assert; --------------------------------- -- Expand_Pragma_Common_Object -- --- 386,404 ---- and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure) then -- If original condition was a Standard.False, we assume that this is ! -- indeed intended to raise assert error and no warning is required. if Is_Entity_Name (Original_Node (Cond)) and then Entity (Original_Node (Cond)) = Standard_False then return; ! elsif Nam = Name_Assertion then Error_Msg_N ("?assertion will fail at run-time", N); + else + Error_Msg_N ("?check will fail at run time", N); end if; end if; ! end Expand_Pragma_Check; --------------------------------- -- Expand_Pragma_Common_Object -- *************** package body Exp_Prag is *** 350,355 **** --- 410,417 ---- -- For now we do nothing with the size attribute ??? + -- Note: Psect_Object shares this processing + procedure Expand_Pragma_Common_Object (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); *************** package body Exp_Prag is *** 392,398 **** -- Insert the pragma Insert_After_And_Analyze (N, - Make_Pragma (Loc, Chars => Name_Machine_Attribute, Pragma_Argument_Associations => New_List ( --- 454,459 ---- *************** package body Exp_Prag is *** 731,740 **** -- Convert to Common_Object, and expand the resulting pragma ! procedure Expand_Pragma_Psect_Object (N : Node_Id) is begin ! Set_Chars (N, Name_Common_Object); ! Expand_Pragma_Common_Object (N); ! end Expand_Pragma_Psect_Object; end Exp_Prag; --- 792,833 ---- -- Convert to Common_Object, and expand the resulting pragma ! procedure Expand_Pragma_Psect_Object (N : Node_Id) ! renames Expand_Pragma_Common_Object; ! ! ------------------------------------- ! -- Expand_Pragma_Relative_Deadline -- ! ------------------------------------- ! ! procedure Expand_Pragma_Relative_Deadline (N : Node_Id) is ! P : constant Node_Id := Parent (N); ! Loc : constant Source_Ptr := Sloc (N); ! begin ! -- Expand the pragma only in the case of the main subprogram. For tasks ! -- the expansion is done in exp_ch9. Generate a call to Set_Deadline ! -- at Clock plus the relative deadline specified in the pragma. Time ! -- values are translated into Duration to allow for non-private ! -- addition operation. ! ! if Nkind (P) = N_Subprogram_Body then ! Rewrite ! (N, ! Make_Procedure_Call_Statement (Loc, ! Name => New_Reference_To (RTE (RE_Set_Deadline), Loc), ! Parameter_Associations => New_List ( ! Unchecked_Convert_To (RTE (RO_RT_Time), ! Make_Op_Add (Loc, ! Left_Opnd => ! Make_Function_Call (Loc, ! New_Reference_To (RTE (RO_RT_To_Duration), Loc), ! New_List (Make_Function_Call (Loc, ! New_Reference_To (RTE (RE_Clock), Loc)))), ! Right_Opnd => ! Unchecked_Convert_To (Standard_Duration, Arg1 (N))))))); ! ! Analyze (N); ! end if; ! end Expand_Pragma_Relative_Deadline; end Exp_Prag; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_smem.adb gcc-4.4.0/gcc/ada/exp_smem.adb *** gcc-4.3.3/gcc/ada/exp_smem.adb Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/exp_smem.adb Tue Jun 3 17:41:43 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2008, 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- -- *************** package body Exp_Smem is *** 52,58 **** procedure Add_Write_After (N : Node_Id); -- Insert a Shared_Var_WOpen call for variable after the node ! -- Insert_Node, as recorded by On_Lhs_Of_Assigment (where it points -- to the assignment statement) or Is_Out_Actual (where it points to -- the procedure call statement). --- 52,58 ---- procedure Add_Write_After (N : Node_Id); -- Insert a Shared_Var_WOpen call for variable after the node ! -- Insert_Node, as recorded by On_Lhs_Of_Assignment (where it points -- to the assignment statement) or Is_Out_Actual (where it points to -- the procedure call statement). *************** package body Exp_Smem is *** 71,76 **** --- 71,99 ---- -- OUT or IN OUT parameter to a procedure call. If the result is -- True, then Insert_Node is set to point to the call. + function Build_Shared_Var_Proc_Call + (Loc : Source_Ptr; + E : Node_Id; + N : Name_Id) return Node_Id; + -- Build a call to support procedure N for shared object E (provided by + -- the instance of System.Shared_Storage.Shared_Var_Procs associated to E). + + -------------------------------- + -- Build_Shared_Var_Proc_Call -- + -------------------------------- + + function Build_Shared_Var_Proc_Call + (Loc : Source_Ptr; + E : Entity_Id; + N : Name_Id) return Node_Id is + begin + return Make_Procedure_Call_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Shared_Var_Procs_Instance (E), Loc), + Selector_Name => Make_Identifier (Loc, Chars => N))); + end Build_Shared_Var_Proc_Call; + --------------------- -- Add_Read_Before -- --------------------- *************** package body Exp_Smem is *** 78,91 **** procedure Add_Read_Before (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Ent : constant Node_Id := Entity (N); - begin ! if Present (Shared_Var_Read_Proc (Ent)) then ! Insert_Action (N, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (Shared_Var_Read_Proc (Ent), Loc), ! Parameter_Associations => Empty_List)); end if; end Add_Read_Before; --- 101,109 ---- procedure Add_Read_Before (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Ent : constant Node_Id := Entity (N); begin ! if Present (Shared_Var_Procs_Instance (Ent)) then ! Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Ent, Name_Read)); end if; end Add_Read_Before; *************** package body Exp_Smem is *** 134,141 **** -- Now, right after the Lock, insert a call to read the object Insert_Before_And_Analyze (Inode, ! Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (Shared_Var_Read_Proc (Obj), Loc))); -- Now insert the Unlock call after --- 152,158 ---- -- Now, right after the Lock, insert a call to read the object Insert_Before_And_Analyze (Inode, ! Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read)); -- Now insert the Unlock call after *************** package body Exp_Smem is *** 150,157 **** if Nkind (N) = N_Procedure_Call_Statement then Insert_After_And_Analyze (Inode, ! Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (Shared_Var_Assign_Proc (Obj), Loc))); end if; end Add_Shared_Var_Lock_Procs; --- 167,173 ---- if Nkind (N) = N_Procedure_Call_Statement then Insert_After_And_Analyze (Inode, ! Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write)); end if; end Add_Shared_Var_Lock_Procs; *************** package body Exp_Smem is *** 165,176 **** Ent : constant Node_Id := Entity (N); begin ! if Present (Shared_Var_Assign_Proc (Ent)) then Insert_After_And_Analyze (Insert_Node, ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (Shared_Var_Assign_Proc (Ent), Loc), ! Parameter_Associations => Empty_List)); end if; end Add_Write_After; --- 181,189 ---- Ent : constant Node_Id := Entity (N); begin ! if Present (Shared_Var_Procs_Instance (Ent)) then Insert_After_And_Analyze (Insert_Node, ! Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write)); end if; end Add_Write_After; *************** package body Exp_Smem is *** 276,296 **** Ent : constant Entity_Id := Defining_Identifier (N); Typ : constant Entity_Id := Etype (Ent); Vnm : String_Id; - Atr : Node_Id; After : constant Node_Id := Next (N); -- Node located right after N originally (after insertion of the SV -- procs this node is right after the last inserted node). ! Assign_Proc : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Chars (Ent), 'A')); ! ! Read_Proc : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Chars (Ent), 'R')); ! S : Entity_Id; -- Start of processing for Make_Shared_Var_Procs --- 289,306 ---- Ent : constant Entity_Id := Defining_Identifier (N); Typ : constant Entity_Id := Etype (Ent); Vnm : String_Id; After : constant Node_Id := Next (N); -- Node located right after N originally (after insertion of the SV -- procs this node is right after the last inserted node). ! SVP_Instance : constant Entity_Id := Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Chars (Ent), 'G')); ! -- Instance of System.Shared_Storage.Shared_Var_Procs associated ! -- with Ent. ! Instantiation : Node_Id; ! -- Package instantiation node for SVP_Instance -- Start of processing for Make_Shared_Var_Procs *************** package body Exp_Smem is *** 298,446 **** Build_Full_Name (Ent, Vnm); -- We turn off Shared_Passive during construction and analysis of ! -- the assign and read routines, to avoid improper attempts to ! -- process the variable references within these procedures. Set_Is_Shared_Passive (Ent, False); ! -- Construct assignment routine ! ! -- procedure VarA is ! -- S : Ada.Streams.Stream_IO.Stream_Access; ! -- begin ! -- S := Shared_Var_WOpen ("pkg.var"); ! -- typ'Write (S, var); ! -- Shared_Var_Close (S); ! -- end VarA; ! ! S := Make_Defining_Identifier (Loc, Name_uS); ! ! Atr := ! Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Typ, Loc), ! Attribute_Name => Name_Write, ! Expressions => New_List ( ! New_Reference_To (S, Loc), ! New_Occurrence_Of (Ent, Loc))); ! ! Insert_After_And_Analyze (N, ! Make_Subprogram_Body (Loc, ! Specification => ! Make_Procedure_Specification (Loc, ! Defining_Unit_Name => Assign_Proc), ! ! -- S : Ada.Streams.Stream_IO.Stream_Access; ! ! Declarations => New_List ( ! Make_Object_Declaration (Loc, ! Defining_Identifier => S, ! Object_Definition => ! New_Occurrence_Of (RTE (RE_Stream_Access), Loc))), ! ! Handled_Statement_Sequence => ! Make_Handled_Sequence_Of_Statements (Loc, ! Statements => New_List ( ! ! -- S := Shared_Var_WOpen ("pkg.var"); ! ! Make_Assignment_Statement (Loc, ! Name => New_Reference_To (S, Loc), ! Expression => ! Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of ! (RTE (RE_Shared_Var_WOpen), Loc), ! Parameter_Associations => New_List ( ! Make_String_Literal (Loc, Vnm)))), ! ! Atr, ! ! -- Shared_Var_Close (S); ! ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of (RTE (RE_Shared_Var_Close), Loc), ! Parameter_Associations => ! New_List (New_Reference_To (S, Loc))))))); ! ! -- Construct read routine ! ! -- procedure varR is ! -- S : Ada.Streams.Stream_IO.Stream_Access; ! -- begin ! -- S := Shared_Var_ROpen ("pkg.var"); ! -- if S /= null then ! -- typ'Read (S, Var); ! -- Shared_Var_Close (S); ! -- end if; ! -- end varR; ! ! S := Make_Defining_Identifier (Loc, Name_uS); ! ! Atr := ! Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Typ, Loc), ! Attribute_Name => Name_Read, ! Expressions => New_List ( ! New_Reference_To (S, Loc), ! New_Occurrence_Of (Ent, Loc))); ! ! Insert_After_And_Analyze (N, ! Make_Subprogram_Body (Loc, ! Specification => ! Make_Procedure_Specification (Loc, ! Defining_Unit_Name => Read_Proc), ! ! -- S : Ada.Streams.Stream_IO.Stream_Access; ! ! Declarations => New_List ( ! Make_Object_Declaration (Loc, ! Defining_Identifier => S, ! Object_Definition => ! New_Occurrence_Of (RTE (RE_Stream_Access), Loc))), ! ! Handled_Statement_Sequence => ! Make_Handled_Sequence_Of_Statements (Loc, ! Statements => New_List ( ! ! -- S := Shared_Var_ROpen ("pkg.var"); ! ! Make_Assignment_Statement (Loc, ! Name => New_Reference_To (S, Loc), ! Expression => ! Make_Function_Call (Loc, ! Name => ! New_Occurrence_Of ! (RTE (RE_Shared_Var_ROpen), Loc), ! Parameter_Associations => New_List ( ! Make_String_Literal (Loc, Vnm)))), ! ! -- if S /= null then ! ! Make_Implicit_If_Statement (N, ! Condition => ! Make_Op_Ne (Loc, ! Left_Opnd => New_Reference_To (S, Loc), ! Right_Opnd => Make_Null (Loc)), ! ! Then_Statements => New_List ( ! ! -- typ'Read (S, Var); ! Atr, ! -- Shared_Var_Close (S); ! Make_Procedure_Call_Statement (Loc, ! Name => ! New_Occurrence_Of ! (RTE (RE_Shared_Var_Close), Loc), ! Parameter_Associations => ! New_List (New_Reference_To (S, Loc))))))))); ! Set_Is_Shared_Passive (Ent, True); ! Set_Shared_Var_Assign_Proc (Ent, Assign_Proc); ! Set_Shared_Var_Read_Proc (Ent, Read_Proc); -- Return last node before After --- 308,340 ---- Build_Full_Name (Ent, Vnm); -- We turn off Shared_Passive during construction and analysis of ! -- the generic package instantiation, to avoid improper attempts to ! -- process the variable references within these instantiation. Set_Is_Shared_Passive (Ent, False); ! -- Construct generic package instantiation ! -- package varG is new Shared_Var_Procs (Typ, var, "pkg.var"); ! Instantiation := ! Make_Package_Instantiation (Loc, ! Defining_Unit_Name => SVP_Instance, ! Name => ! New_Occurrence_Of (RTE (RE_Shared_Var_Procs), Loc), ! Generic_Associations => New_List ( ! Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter => ! New_Occurrence_Of (Typ, Loc)), ! Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter => ! New_Occurrence_Of (Ent, Loc)), ! Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter => ! Make_String_Literal (Loc, Vnm)))); ! Insert_After_And_Analyze (N, Instantiation); ! Set_Is_Shared_Passive (Ent, True); ! Set_Shared_Var_Procs_Instance ! (Ent, Defining_Entity (Instance_Spec (Instantiation))); -- Return last node before After diff -Nrcpad gcc-4.3.3/gcc/ada/exp_smem.ads gcc-4.4.0/gcc/ada/exp_smem.ads *** gcc-4.3.3/gcc/ada/exp_smem.ads Mon Sep 10 12:49:21 2007 --- gcc-4.4.0/gcc/ada/exp_smem.ads Tue May 20 12:46:42 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2008, 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- -- *************** package Exp_Smem is *** 49,58 **** -- read/write calls for the protected object within the lock region. function Make_Shared_Var_Procs (N : Node_Id) return Node_Id; ! -- N is the node for the declaration of a shared passive variable. This ! -- procedure constructs and inserts the read and assignment procedures ! -- for the shared memory variable. See System.Shared_Storage for a full ! -- description of these procedures and how they are used. The last inserted ! -- node is returned. end Exp_Smem; --- 49,59 ---- -- read/write calls for the protected object within the lock region. function Make_Shared_Var_Procs (N : Node_Id) return Node_Id; ! -- N is the node for the declaration of a shared passive variable. ! -- This procedure constructs an instantiation of ! -- System.Shared_Storage.Shared_Var_Procs that contains the read and ! -- assignment procedures for the shared memory variable. ! -- See System.Shared_Storage for a full description of these procedures ! -- and how they are used. The last inserted node is returned. end Exp_Smem; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_strm.adb gcc-4.4.0/gcc/ada/exp_strm.adb *** gcc-4.3.3/gcc/ada/exp_strm.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_strm.adb Wed Aug 20 14:27:01 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Exp_Strm is *** 373,379 **** -- array may be user-defined, and be frozen after the type for which -- we are generating the stream subprogram. In that case, freeze the -- stream attribute of the component type, whose declaration could not ! -- generate any additional freezing actions in any case. See 5509-003. if Nam = Name_Read then RW := TSS (Base_Type (Ctyp), TSS_Stream_Read); --- 373,379 ---- -- array may be user-defined, and be frozen after the type for which -- we are generating the stream subprogram. In that case, freeze the -- stream attribute of the component type, whose declaration could not ! -- generate any additional freezing actions in any case. if Nam = Name_Read then RW := TSS (Base_Type (Ctyp), TSS_Stream_Read); *************** package body Exp_Strm is *** 521,527 **** elsif P_Size <= Standard_Long_Float_Size and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size ! or else Rt_Type = Standard_Float) then Lib_RE := RE_I_LF; --- 521,527 ---- elsif P_Size <= Standard_Long_Float_Size and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size ! or else Rt_Type = Standard_Long_Float) then Lib_RE := RE_I_LF; *************** package body Exp_Strm is *** 735,741 **** elsif P_Size <= Standard_Long_Float_Size and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size ! or else Rt_Type = Standard_Float) then Lib_RE := RE_W_LF; --- 735,741 ---- elsif P_Size <= Standard_Long_Float_Size and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size ! or else Rt_Type = Standard_Long_Float) then Lib_RE := RE_W_LF; *************** package body Exp_Strm is *** 1092,1104 **** Decl : out Node_Id; Fnam : out Entity_Id) is ! Cn : Name_Id; ! J : Pos; ! Decls : List_Id; ! Constr : List_Id; ! Stms : List_Id; ! Discr : Entity_Id; ! Odef : Node_Id; begin Decls := New_List; --- 1092,1105 ---- Decl : out Node_Id; Fnam : out Entity_Id) is ! Cn : Name_Id; ! J : Pos; ! Decls : List_Id; ! Constr : List_Id; ! Obj_Decl : Node_Id; ! Stms : List_Id; ! Discr : Entity_Id; ! Odef : Node_Id; begin Decls := New_List; *************** package body Exp_Strm is *** 1112,1123 **** while Present (Discr) loop Cn := New_External_Name ('C', J); ! Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Cn), Object_Definition => ! New_Occurrence_Of (Etype (Discr), Loc))); Append_To (Decls, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Etype (Discr), Loc), --- 1113,1134 ---- while Present (Discr) loop Cn := New_External_Name ('C', J); ! Decl := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Cn), Object_Definition => ! New_Occurrence_Of (Etype (Discr), Loc)); + -- If this is an access discriminant, do not perform default + -- initialization. The discriminant is about to get its value + -- from Read, and if the type is null excluding we do not want + -- spurious warnings on an initial null value. + + if Is_Access_Type (Etype (Discr)) then + Set_No_Initialization (Decl); + end if; + + Append_To (Decls, Decl); Append_To (Decls, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Etype (Discr), Loc), *************** package body Exp_Strm is *** 1152,1165 **** -- Perhaps we should just generate an extended return in all cases??? if Ada_Version >= Ada_05 then Stms := New_List ( Make_Extended_Return_Statement (Loc, ! Return_Object_Declarations => ! New_List (Make_Object_Declaration (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, Name_V), ! Object_Definition => Odef)), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List (Make_Attribute_Reference (Loc, --- 1163,1185 ---- -- Perhaps we should just generate an extended return in all cases??? + Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Object_Definition => Odef); + + -- If the type is an access type, do not perform default initialization. + -- The object is about to get its value from Read, and if the type is + -- null excluding we do not want spurious warnings on an initial null. + + if Is_Access_Type (Typ) then + Set_No_Initialization (Obj_Decl); + end if; + if Ada_Version >= Ada_05 then Stms := New_List ( Make_Extended_Return_Statement (Loc, ! Return_Object_Declarations => New_List (Obj_Decl), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List (Make_Attribute_Reference (Loc, *************** package body Exp_Strm is *** 1170,1179 **** Make_Identifier (Loc, Name_V))))))); else ! Append_To (Decls, ! Make_Object_Declaration (Loc, ! Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), ! Object_Definition => Odef)); Stms := New_List ( Make_Attribute_Reference (Loc, --- 1190,1196 ---- Make_Identifier (Loc, Name_V))))))); else ! Append_To (Decls, Obj_Decl); Stms := New_List ( Make_Attribute_Reference (Loc, diff -Nrcpad gcc-4.3.3/gcc/ada/exp_tss.adb gcc-4.4.0/gcc/ada/exp_tss.adb *** gcc-4.3.3/gcc/ada/exp_tss.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_tss.adb Fri Aug 22 13:26:28 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Einfo; use Einfo; *** 28,33 **** --- 28,35 ---- with Elists; use Elists; with Exp_Util; use Exp_Util; with Lib; use Lib; + with Restrict; use Restrict; + with Rident; use Rident; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; *************** package body Exp_Tss is *** 55,61 **** elsif Is_Concurrent_Type (Full_Type) and then Present (Corresponding_Record_Type (Base_Type (Full_Type))) then ! return Init_Proc (Corresponding_Record_Type (Base_Type (Full_Type))); else Proc := Init_Proc (Base_Type (Full_Type)); --- 57,68 ---- elsif Is_Concurrent_Type (Full_Type) and then Present (Corresponding_Record_Type (Base_Type (Full_Type))) then ! -- The initialization routine to be called is that of the base type ! -- of the corresponding record type, which may itself be a subtype ! -- and possibly an itype. ! ! return Init_Proc ! (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type)))); else Proc := Init_Proc (Base_Type (Full_Type)); *************** package body Exp_Tss is *** 159,169 **** -- Has_Non_Null_Base_Init_Proc -- --------------------------------- function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is BIP : constant Entity_Id := Base_Init_Proc (Typ); - begin ! return Present (BIP) and then not Is_Null_Init_Proc (BIP); end Has_Non_Null_Base_Init_Proc; --------------- --- 166,181 ---- -- Has_Non_Null_Base_Init_Proc -- --------------------------------- + -- Note: if a base Init_Proc is present, and No_Default_Initialization is + -- present, then we must avoid testing for a null init proc, since there + -- is no init proc present in this case. + function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is BIP : constant Entity_Id := Base_Init_Proc (Typ); begin ! return Present (BIP) ! and then (Restriction_Active (No_Default_Initialization) ! or else not Is_Null_Init_Proc (BIP)); end Has_Non_Null_Base_Init_Proc; --------------- *************** package body Exp_Tss is *** 306,325 **** ------------- procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is - Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS); - begin ! -- Case of insertion location is in unit defining the type ! if In_Same_Code_Unit (Typ, TSS) then ! Append_Freeze_Action (Typ, Subprog_Body); ! -- Otherwise, we are using an already existing TSS in another unit ! else null; end if; Copy_TSS (TSS, Typ); end Set_TSS; --- 318,348 ---- ------------- procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is begin ! -- Make sure body of subprogram is frozen ! -- Skip this for Init_Proc with No_Default_Initialization, since the ! -- Init proc is a dummy void entity in this case to be ignored. ! if Is_Init_Proc (TSS) ! and then Restriction_Active (No_Default_Initialization) ! then ! null; ! -- Skip this if not in the same code unit (since it means we are using ! -- an already existing TSS in another unit) ! ! elsif not In_Same_Code_Unit (Typ, TSS) then null; + + -- Otherwise make sure body is frozen + + else + Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS)); end if; + -- Set TSS entry + Copy_TSS (TSS, Typ); end Set_TSS; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_tss.ads gcc-4.4.0/gcc/ada/exp_tss.ads *** gcc-4.3.3/gcc/ada/exp_tss.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_tss.ads Tue Apr 8 07:18:13 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Exp_Tss is *** 50,58 **** ------------------------- -- In the current version of this package, only the case of generating a ! -- TSS at the point of declaration of the type is accomodated. A clear -- improvement would be to follow through with the full implementation ! -- as described above, and also accomodate the requirement of generating -- only one copy in a given object file. -- For now, we deal with the local case by generating duplicate versions --- 50,58 ---- ------------------------- -- In the current version of this package, only the case of generating a ! -- TSS at the point of declaration of the type is accommodated. A clear -- improvement would be to follow through with the full implementation ! -- as described above, and also accommodate the requirement of generating -- only one copy in a given object file. -- For now, we deal with the local case by generating duplicate versions *************** package Exp_Tss is *** 215,221 **** function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean; -- Returns true if the given type has a defined Base_Init_Proc and -- this init proc is not a null init proc (null init procs occur as ! -- a result of the processing for Initialize_Scalars. This function -- is used to test for the presence of an init proc in cases where -- a null init proc is considered equivalent to no init proc. --- 215,221 ---- function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean; -- Returns true if the given type has a defined Base_Init_Proc and -- this init proc is not a null init proc (null init procs occur as ! -- a result of the processing for Initialize_Scalars). This function -- is used to test for the presence of an init proc in cases where -- a null init proc is considered equivalent to no init proc. diff -Nrcpad gcc-4.3.3/gcc/ada/exp_util.adb gcc-4.4.0/gcc/ada/exp_util.adb *** gcc-4.3.3/gcc/ada/exp_util.adb Thu Dec 13 10:22:06 2007 --- gcc-4.4.0/gcc/ada/exp_util.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Exp_Util is *** 336,342 **** -- component, whose prefix is the outer variable of the array type. -- The n-dimensional array type has known indices Index, Index2... -- Id_Ref is an indexed component form created by the enclosing init proc. ! -- Its successive indices are Val1, Val2,.. which are the loop variables -- in the loops that call the individual task init proc on each component. -- The generated function has the following structure: --- 336,342 ---- -- component, whose prefix is the outer variable of the array type. -- The n-dimensional array type has known indices Index, Index2... -- Id_Ref is an indexed component form created by the enclosing init proc. ! -- Its successive indices are Val1, Val2, ... which are the loop variables -- in the loops that call the individual task init proc on each component. -- The generated function has the following structure: *************** package body Exp_Util is *** 908,916 **** function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is begin ! -- If no component clause, then everything is fine, since the ! -- back end never bit-misaligns by default, even if there is ! -- a pragma Packed for the record. if No (Component_Clause (Comp)) then return False; --- 908,916 ---- function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is begin ! -- If no component clause, then everything is fine, since the back end ! -- never bit-misaligns by default, even if there is a pragma Packed for ! -- the record. if No (Component_Clause (Comp)) then return False; *************** package body Exp_Util is *** 933,940 **** then return False; ! -- Otherwise if the component is not byte aligned, we ! -- know we have the nasty unaligned case. elsif Normalized_First_Bit (Comp) /= Uint_0 or else Esize (Comp) mod System_Storage_Unit /= Uint_0 --- 933,940 ---- then return False; ! -- Otherwise if the component is not byte aligned, we know we have the ! -- nasty unaligned case. elsif Normalized_First_Bit (Comp) /= Uint_0 or else Esize (Comp) mod System_Storage_Unit /= Uint_0 *************** package body Exp_Util is *** 948,953 **** --- 948,997 ---- end if; end Component_May_Be_Bit_Aligned; + ----------------------------------- + -- Corresponding_Runtime_Package -- + ----------------------------------- + + function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is + Pkg_Id : RTU_Id := RTU_Null; + + begin + pragma Assert (Is_Concurrent_Type (Typ)); + + if Ekind (Typ) in Protected_Kind then + if Has_Entries (Typ) + or else Has_Interrupt_Handler (Typ) + or else (Has_Attach_Handler (Typ) + and then not Restricted_Profile) + + -- A protected type without entries that covers an interface and + -- overrides the abstract routines with protected procedures is + -- considered equivalent to a protected type with entries in the + -- context of dispatching select statements. It is sufficient to + -- check for the presence of an interface list in the declaration + -- node to recognize this case. + + or else Present (Interface_List (Parent (Typ))) + then + if Abort_Allowed + or else Restriction_Active (No_Entry_Queue) = False + or else Number_Entries (Typ) > 1 + or else (Has_Attach_Handler (Typ) + and then not Restricted_Profile) + then + Pkg_Id := System_Tasking_Protected_Objects_Entries; + else + Pkg_Id := System_Tasking_Protected_Objects_Single_Entry; + end if; + + else + Pkg_Id := System_Tasking_Protected_Objects; + end if; + end if; + + return Pkg_Id; + end Corresponding_Runtime_Package; + ------------------------------- -- Convert_To_Actual_Subtype -- ------------------------------- *************** package body Exp_Util is *** 1072,1077 **** --- 1116,1134 ---- end if; end Ensure_Defined; + -------------------- + -- Entry_Names_OK -- + -------------------- + + function Entry_Names_OK return Boolean is + begin + return + not Restricted_Profile + and then not Global_Discard_Names + and then not Restriction_Active (No_Implicit_Heap_Allocations) + and then not Restriction_Active (No_Local_Allocators); + end Entry_Names_OK; + --------------------- -- Evolve_And_Then -- --------------------- *************** package body Exp_Util is *** 1183,1189 **** Constraints => New_List (New_Reference_To (Slice_Type, Loc))))); ! -- This subtype indication may be used later for contraint checks -- we better make sure that if a variable was used as a bound of -- of the original slice, its value is frozen. --- 1240,1246 ---- Constraints => New_List (New_Reference_To (Slice_Type, Loc))))); ! -- This subtype indication may be used later for constraint checks -- we better make sure that if a variable was used as a bound of -- of the original slice, its value is frozen. *************** package body Exp_Util is *** 1329,1397 **** (T : Entity_Id; Iface : Entity_Id) return Elmt_Id is ! ADT : Elmt_Id; ! Found : Boolean := False; ! Typ : Entity_Id := T; ! ! procedure Find_Secondary_Table (Typ : Entity_Id); ! -- Internal subprogram used to recursively climb to the ancestors ! ! -------------------------- ! -- Find_Secondary_Table -- ! -------------------------- ! ! procedure Find_Secondary_Table (Typ : Entity_Id) is ! AI_Elmt : Elmt_Id; ! AI : Node_Id; ! ! begin ! pragma Assert (Typ /= Iface); ! ! -- Climb to the ancestor (if any) handling synchronized interface ! -- derivations and private types ! ! if Is_Concurrent_Record_Type (Typ) then ! declare ! Iface_List : constant List_Id := Abstract_Interface_List (Typ); ! ! begin ! if Is_Non_Empty_List (Iface_List) then ! Find_Secondary_Table (Etype (First (Iface_List))); ! end if; ! end; ! ! elsif Present (Full_View (Etype (Typ))) then ! if Full_View (Etype (Typ)) /= Typ then ! Find_Secondary_Table (Full_View (Etype (Typ))); ! end if; ! ! elsif Etype (Typ) /= Typ then ! Find_Secondary_Table (Etype (Typ)); ! end if; ! ! -- Traverse the list of interfaces implemented by the type ! ! if not Found ! and then Present (Abstract_Interfaces (Typ)) ! and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) ! then ! AI_Elmt := First_Elmt (Abstract_Interfaces (Typ)); ! while Present (AI_Elmt) loop ! AI := Node (AI_Elmt); ! ! if AI = Iface or else Is_Ancestor (Iface, AI) then ! Found := True; ! return; ! end if; ! ! Next_Elmt (ADT); ! Next_Elmt (ADT); ! Next_Elmt (AI_Elmt); ! end loop; ! end if; ! end Find_Secondary_Table; ! ! -- Start of processing for Find_Interface_ADT begin pragma Assert (Is_Interface (Iface)); --- 1386,1393 ---- (T : Entity_Id; Iface : Entity_Id) return Elmt_Id is ! ADT : Elmt_Id; ! Typ : Entity_Id := T; begin pragma Assert (Is_Interface (Iface)); *************** package body Exp_Util is *** 1420,1430 **** (not Is_Class_Wide_Type (Typ) and then Ekind (Typ) /= E_Incomplete_Type); ! ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); ! pragma Assert (Present (Node (ADT))); ! Find_Secondary_Table (Typ); ! pragma Assert (Found); ! return ADT; end Find_Interface_ADT; ------------------------ --- 1416,1438 ---- (not Is_Class_Wide_Type (Typ) and then Ekind (Typ) /= E_Incomplete_Type); ! if Is_Ancestor (Iface, Typ) then ! return First_Elmt (Access_Disp_Table (Typ)); ! ! else ! ADT := ! Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); ! while Present (ADT) ! and then Present (Related_Type (Node (ADT))) ! and then Related_Type (Node (ADT)) /= Iface ! and then not Is_Ancestor (Iface, Related_Type (Node (ADT))) ! loop ! Next_Elmt (ADT); ! end loop; ! ! pragma Assert (Present (Related_Type (Node (ADT)))); ! return ADT; ! end if; end Find_Interface_ADT; ------------------------ *************** package body Exp_Util is *** 1439,1452 **** Found : Boolean := False; Typ : Entity_Id := T; - Is_Primary_Tag : Boolean := False; - - Is_Sync_Typ : Boolean := False; - -- In case of non concurrent-record-types each parent-type has the - -- tags associated with the interface types that are not implemented - -- by the ancestors; concurrent-record-types have their whole list of - -- interface tags (and this case requires some special management). - procedure Find_Tag (Typ : Entity_Id); -- Internal subprogram used to recursively climb to the ancestors --- 1447,1452 ---- *************** package body Exp_Util is *** 1463,1494 **** -- therefore shares the main tag. if Typ = Iface then ! if Is_Sync_Typ then ! Is_Primary_Tag := True; ! else ! pragma Assert ! (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); ! AI_Tag := First_Tag_Component (Typ); ! end if; ! Found := True; return; end if; - -- Handle synchronized interface derivations - - if Is_Concurrent_Record_Type (Typ) then - declare - Iface_List : constant List_Id := Abstract_Interface_List (Typ); - begin - if Is_Non_Empty_List (Iface_List) then - Find_Tag (Etype (First (Iface_List))); - end if; - end; - -- Climb to the root type handling private types ! elsif Present (Full_View (Etype (Typ))) then if Full_View (Etype (Typ)) /= Typ then Find_Tag (Full_View (Etype (Typ))); end if; --- 1463,1477 ---- -- therefore shares the main tag. if Typ = Iface then ! pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); ! AI_Tag := First_Tag_Component (Typ); Found := True; return; end if; -- Climb to the root type handling private types ! if Present (Full_View (Etype (Typ))) then if Full_View (Etype (Typ)) /= Typ then Find_Tag (Full_View (Etype (Typ))); end if; *************** package body Exp_Util is *** 1500,1518 **** -- Traverse the list of interfaces implemented by the type if not Found ! and then Present (Abstract_Interfaces (Typ)) ! and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) then -- Skip the tag associated with the primary table ! if not Is_Sync_Typ then ! pragma Assert ! (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); ! AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); ! pragma Assert (Present (AI_Tag)); ! end if; ! AI_Elmt := First_Elmt (Abstract_Interfaces (Typ)); while Present (AI_Elmt) loop AI := Node (AI_Elmt); --- 1483,1498 ---- -- Traverse the list of interfaces implemented by the type if not Found ! and then Present (Interfaces (Typ)) ! and then not (Is_Empty_Elmt_List (Interfaces (Typ))) then -- Skip the tag associated with the primary table ! pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); ! AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); ! pragma Assert (Present (AI_Tag)); ! AI_Elmt := First_Elmt (Interfaces (Typ)); while Present (AI_Elmt) loop AI := Node (AI_Elmt); *************** package body Exp_Util is *** 1563,1711 **** Typ := Non_Limited_View (Typ); end if; ! if not Is_Concurrent_Record_Type (Typ) then ! Find_Tag (Typ); ! pragma Assert (Found); ! return AI_Tag; ! ! -- Concurrent record types ! ! else ! Is_Sync_Typ := True; ! AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); ! Find_Tag (Typ); ! pragma Assert (Found); ! ! if Is_Primary_Tag then ! return First_Tag_Component (Typ); ! else ! return AI_Tag; ! end if; ! end if; ! end Find_Interface_Tag; ! ! -------------------- ! -- Find_Interface -- ! -------------------- ! ! function Find_Interface ! (T : Entity_Id; ! Comp : Entity_Id) return Entity_Id ! is ! AI_Tag : Entity_Id; ! Found : Boolean := False; ! Iface : Entity_Id; ! Typ : Entity_Id := T; ! ! Is_Sync_Typ : Boolean := False; ! -- In case of non concurrent-record-types each parent-type has the ! -- tags associated with the interface types that are not implemented ! -- by the ancestors; concurrent-record-types have their whole list of ! -- interface tags (and this case requires some special management). ! ! procedure Find_Iface (Typ : Entity_Id); ! -- Internal subprogram used to recursively climb to the ancestors ! ! ---------------- ! -- Find_Iface -- ! ---------------- ! ! procedure Find_Iface (Typ : Entity_Id) is ! AI_Elmt : Elmt_Id; ! ! begin ! -- Climb to the root type ! ! -- Handle sychronized interface derivations ! ! if Is_Concurrent_Record_Type (Typ) then ! declare ! Iface_List : constant List_Id := Abstract_Interface_List (Typ); ! begin ! if Is_Non_Empty_List (Iface_List) then ! Find_Iface (Etype (First (Iface_List))); ! end if; ! end; ! ! -- Handle the common case ! ! elsif Etype (Typ) /= Typ then ! pragma Assert (not Present (Full_View (Etype (Typ)))); ! Find_Iface (Etype (Typ)); ! end if; ! ! -- Traverse the list of interfaces implemented by the type ! ! if not Found ! and then Present (Abstract_Interfaces (Typ)) ! and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) ! then ! -- Skip the tag associated with the primary table ! ! if not Is_Sync_Typ then ! pragma Assert ! (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); ! AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); ! pragma Assert (Present (AI_Tag)); ! end if; ! ! AI_Elmt := First_Elmt (Abstract_Interfaces (Typ)); ! while Present (AI_Elmt) loop ! if AI_Tag = Comp then ! Iface := Node (AI_Elmt); ! Found := True; ! return; ! end if; ! ! AI_Tag := Next_Tag_Component (AI_Tag); ! Next_Elmt (AI_Elmt); ! end loop; ! end if; ! end Find_Iface; ! ! -- Start of processing for Find_Interface ! ! begin ! -- Handle private types ! ! if Has_Private_Declaration (Typ) ! and then Present (Full_View (Typ)) ! then ! Typ := Full_View (Typ); ! end if; ! ! -- Handle access types ! ! if Is_Access_Type (Typ) then ! Typ := Directly_Designated_Type (Typ); ! end if; ! ! -- Handle task and protected types implementing interfaces ! ! if Is_Concurrent_Type (Typ) then ! Typ := Corresponding_Record_Type (Typ); ! end if; ! ! if Is_Class_Wide_Type (Typ) then ! Typ := Etype (Typ); ! end if; ! ! -- Handle entities from the limited view ! ! if Ekind (Typ) = E_Incomplete_Type then ! pragma Assert (Present (Non_Limited_View (Typ))); ! Typ := Non_Limited_View (Typ); ! end if; ! ! if Is_Concurrent_Record_Type (Typ) then ! Is_Sync_Typ := True; ! AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); ! end if; ! ! Find_Iface (Typ); pragma Assert (Found); ! return Iface; ! end Find_Interface; ------------------ -- Find_Prim_Op -- --- 1543,1552 ---- Typ := Non_Limited_View (Typ); end if; ! Find_Tag (Typ); pragma Assert (Found); ! return AI_Tag; ! end Find_Interface_Tag; ------------------ -- Find_Prim_Op -- *************** package body Exp_Util is *** 1740,1746 **** or else Etype (First_Entity (Op)) = Etype (Last_Entity (Op))); Next_Elmt (Prim); ! pragma Assert (Present (Prim)); end loop; return Node (Prim); --- 1581,1592 ---- or else Etype (First_Entity (Op)) = Etype (Last_Entity (Op))); Next_Elmt (Prim); ! ! -- Raise Program_Error if no primitive found ! ! if No (Prim) then ! raise Program_Error; ! end if; end loop; return Node (Prim); *************** package body Exp_Util is *** 1767,1778 **** Prim := First_Elmt (Primitive_Operations (Typ)); while not Is_TSS (Node (Prim), Name) loop Next_Elmt (Prim); ! pragma Assert (Present (Prim)); end loop; return Node (Prim); end Find_Prim_Op; ---------------------- -- Force_Evaluation -- ---------------------- --- 1613,1657 ---- Prim := First_Elmt (Primitive_Operations (Typ)); while not Is_TSS (Node (Prim), Name) loop Next_Elmt (Prim); ! ! -- Raise program error if no primitive found ! ! if No (Prim) then ! raise Program_Error; ! end if; end loop; return Node (Prim); end Find_Prim_Op; + ---------------------------- + -- Find_Protection_Object -- + ---------------------------- + + function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is + S : Entity_Id; + + begin + S := Scop; + while Present (S) loop + if (Ekind (S) = E_Entry + or else Ekind (S) = E_Entry_Family + or else Ekind (S) = E_Function + or else Ekind (S) = E_Procedure) + and then Present (Protection_Object (S)) + then + return Protection_Object (S); + end if; + + S := Scope (S); + end loop; + + -- If we do not find a Protection object in the scope chain, then + -- something has gone wrong, most likely the object was never created. + + raise Program_Error; + end Find_Protection_Object; + ---------------------- -- Force_Evaluation -- ---------------------- *************** package body Exp_Util is *** 2016,2022 **** -- If the variable reference does not come from source, we -- cannot reliably tell whether it appears in the else part. ! -- In particular, if if appears in generated code for a node -- that requires finalization, it may be attached to a list -- that has not been yet inserted into the code. For now, -- treat it as unknown. --- 1895,1901 ---- -- If the variable reference does not come from source, we -- cannot reliably tell whether it appears in the else part. ! -- In particular, if it appears in generated code for a node -- that requires finalization, it may be attached to a list -- that has not been yet inserted into the code. For now, -- treat it as unknown. *************** package body Exp_Util is *** 2080,2086 **** if N = CV then Sens := True; ! -- Otherwise we must be in susbequent ELSIF or ELSE part else Sens := False; --- 1959,1965 ---- if N = CV then Sens := True; ! -- Otherwise we must be in subsequent ELSIF or ELSE part else Sens := False; *************** package body Exp_Util is *** 2251,2263 **** return; end if; ! -- Ignore insert of actions from inside default expression in the ! -- special preliminary analyze mode. Any insertions at this point ! -- have no relevance, since we are only doing the analyze to freeze ! -- the types of any static expressions. See section "Handling of ! -- Default Expressions" in the spec of package Sem for further details. ! if In_Default_Expression then return; end if; --- 2130,2143 ---- return; end if; ! -- Ignore insert of actions from inside default expression (or other ! -- similar "spec expression") in the special spec-expression analyze ! -- mode. Any insertions at this point have no relevance, since we are ! -- only doing the analyze to freeze the types of any static expressions. ! -- See section "Handling of Default Expressions" in the spec of package ! -- Sem for further details. ! if In_Spec_Expression then return; end if; *************** package body Exp_Util is *** 2820,2826 **** -- This is the proper body corresponding to a stub. Insertion -- must be done at the point of the stub, which is in the decla- ! -- tive part of the parent unit. P := Corresponding_Stub (Parent (N)); --- 2700,2706 ---- -- This is the proper body corresponding to a stub. Insertion -- must be done at the point of the stub, which is in the decla- ! -- rative part of the parent unit. P := Corresponding_Stub (Parent (N)); *************** package body Exp_Util is *** 2972,3022 **** and then Is_Library_Level_Entity (Typ); end Is_Library_Level_Tagged_Type; - ----------------------------------------- - -- Is_Predefined_Dispatching_Operation -- - ----------------------------------------- - - function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean - is - TSS_Name : TSS_Name_Type; - - begin - if not Is_Dispatching_Operation (E) then - return False; - end if; - - Get_Name_String (Chars (E)); - - if Name_Len > TSS_Name_Type'Last then - TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 - .. Name_Len)); - if Chars (E) = Name_uSize - or else Chars (E) = Name_uAlignment - or else TSS_Name = TSS_Stream_Read - or else TSS_Name = TSS_Stream_Write - or else TSS_Name = TSS_Stream_Input - or else TSS_Name = TSS_Stream_Output - or else - (Chars (E) = Name_Op_Eq - and then Etype (First_Entity (E)) = Etype (Last_Entity (E))) - or else Chars (E) = Name_uAssign - or else TSS_Name = TSS_Deep_Adjust - or else TSS_Name = TSS_Deep_Finalize - or else (Ada_Version >= Ada_05 - and then (Chars (E) = Name_uDisp_Asynchronous_Select - or else Chars (E) = Name_uDisp_Conditional_Select - or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind - or else Chars (E) = Name_uDisp_Get_Task_Id - or else Chars (E) = Name_uDisp_Requeue - or else Chars (E) = Name_uDisp_Timed_Select)) - then - return True; - end if; - end if; - - return False; - end Is_Predefined_Dispatching_Operation; - ---------------------------------- -- Is_Possibly_Unaligned_Object -- ---------------------------------- --- 2852,2857 ---- *************** package body Exp_Util is *** 3400,3405 **** --- 3235,3274 ---- and then Etype (Full_View (T)) /= T); end Is_Untagged_Derivation; + --------------------------- + -- Is_Volatile_Reference -- + --------------------------- + + function Is_Volatile_Reference (N : Node_Id) return Boolean is + begin + if Nkind (N) in N_Has_Etype + and then Present (Etype (N)) + and then Treat_As_Volatile (Etype (N)) + then + return True; + + elsif Is_Entity_Name (N) then + return Treat_As_Volatile (Entity (N)); + + elsif Nkind (N) = N_Slice then + return Is_Volatile_Reference (Prefix (N)); + + elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then + if (Is_Entity_Name (Prefix (N)) + and then Has_Volatile_Components (Entity (Prefix (N)))) + or else (Present (Etype (Prefix (N))) + and then Has_Volatile_Components (Etype (Prefix (N)))) + then + return True; + else + return Is_Volatile_Reference (Prefix (N)); + end if; + + else + return False; + end if; + end Is_Volatile_Reference; + -------------------- -- Kill_Dead_Code -- -------------------- *************** package body Exp_Util is *** 3663,3669 **** -- Generate the following code: -- type Equiv_T is record ! -- _parent : T (List of discriminant constaints taken from Exp); -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8); -- end Equiv_T; -- --- 3532,3538 ---- -- Generate the following code: -- type Equiv_T is record ! -- _parent : T (List of discriminant constraints taken from Exp); -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8); -- end Equiv_T; -- *************** package body Exp_Util is *** 3876,3883 **** -- Make_Subtype_From_Expr -- ---------------------------- ! -- 1. If Expr is an uncontrained array expression, creates ! -- Unc_Type(Expr'first(1)..Expr'Last(1),..., Expr'first(n)..Expr'last(n)) -- 2. If Expr is a unconstrained discriminated type expression, creates -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n) --- 3745,3752 ---- -- Make_Subtype_From_Expr -- ---------------------------- ! -- 1. If Expr is an unconstrained array expression, creates ! -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n)) -- 2. If Expr is a unconstrained discriminated type expression, creates -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n) *************** package body Exp_Util is *** 4180,4187 **** begin -- If we know the component size and it is less than 64, then ! -- we are definitely OK. The back end always does assignment ! -- of misaligned small objects correctly. if Known_Static_Component_Size (Ptyp) and then Component_Size (Ptyp) <= 64 --- 4049,4056 ---- begin -- If we know the component size and it is less than 64, then ! -- we are definitely OK. The back end always does assignment of ! -- misaligned small objects correctly. if Known_Static_Component_Size (Ptyp) and then Component_Size (Ptyp) <= 64 *************** package body Exp_Util is *** 4216,4224 **** end if; end; ! -- If we have neither a record nor array component, 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. when others => return False; --- 4085,4099 ---- end if; end; ! -- For a slice, test the prefix, if that is possibly misaligned, ! -- then for sure the slice is! ! ! when N_Slice => ! return Possible_Bit_Aligned_Component (Prefix (N)); ! ! -- 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. when others => return False; *************** package body Exp_Util is *** 4266,4272 **** -- this may happen with any array or record type. On the other hand, we -- cannot create temporaries for all expressions for which this -- condition is true, for various reasons that might require clearing up ! -- ??? For example, descriminant references that appear out of place, or -- spurious type errors with class-wide expressions. As a result, we -- limit the transformation to loop bounds, which is so far the only -- case that requires it. --- 4141,4147 ---- -- this may happen with any array or record type. On the other hand, we -- cannot create temporaries for all expressions for which this -- condition is true, for various reasons that might require clearing up ! -- ??? For example, discriminant references that appear out of place, or -- spurious type errors with class-wide expressions. As a result, we -- limit the transformation to loop bounds, which is so far the only -- case that requires it. *************** package body Exp_Util is *** 4334,4340 **** -- hand, if we do not consider them to be side effect free, then -- we get some awkward expansions in -gnato mode, resulting in -- code insertions at a point where we do not have a clear model ! -- for performing the insertions. See 4908-002/comment for details. -- Special handling for entity names --- 4209,4215 ---- -- hand, if we do not consider them to be side effect free, then -- we get some awkward expansions in -gnato mode, resulting in -- code insertions at a point where we do not have a clear model ! -- for performing the insertions. -- Special handling for entity names *************** package body Exp_Util is *** 4358,4371 **** return False; -- Variables are considered to be a side effect if Variable_Ref ! -- is set or if we have a volatile variable and Name_Req is off. -- If Name_Req is True then we can't help returning a name which -- effectively allows multiple references in any case. elsif Is_Variable (N) then return not Variable_Ref ! and then (not Treat_As_Volatile (Entity (N)) ! or else Name_Req); -- Any other entity (e.g. a subtype name) is definitely side -- effect free. --- 4233,4245 ---- return False; -- Variables are considered to be a side effect if Variable_Ref ! -- is set or if we have a volatile reference and Name_Req is off. -- If Name_Req is True then we can't help returning a name which -- effectively allows multiple references in any case. elsif Is_Variable (N) then return not Variable_Ref ! and then (not Is_Volatile_Reference (N) or else Name_Req); -- Any other entity (e.g. a subtype name) is definitely side -- effect free. *************** package body Exp_Util is *** 4379,4387 **** elsif Compile_Time_Known_Value (N) then return True; ! -- A variable renaming is not side-effet free, because the -- renaming will function like a macro in the front-end in ! -- some cases, and an assignment can modify the the component -- designated by N, so we need to create a temporary for it. elsif Is_Entity_Name (Original_Node (N)) --- 4253,4261 ---- elsif Compile_Time_Known_Value (N) then return True; ! -- A variable renaming is not side-effect free, because the -- renaming will function like a macro in the front-end in ! -- some cases, and an assignment can modify the component -- designated by N, so we need to create a temporary for it. elsif Is_Entity_Name (Original_Node (N)) *************** package body Exp_Util is *** 4590,4606 **** Scope_Suppress := (others => True); -- If it is a scalar type and we need to capture the value, just make ! -- a copy. Likewise for a function or operator call. And if we have a ! -- volatile variable and Nam_Req is not set (see comments above for ! -- Side_Effect_Free). if Is_Elementary_Type (Exp_Type) and then (Variable_Ref or else Nkind (Exp) = N_Function_Call or else Nkind (Exp) in N_Op ! or else (not Name_Req ! and then Is_Entity_Name (Exp) ! and then Treat_As_Volatile (Entity (Exp)))) then Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); Set_Etype (Def_Id, Exp_Type); --- 4464,4479 ---- Scope_Suppress := (others => True); -- If it is a scalar type and we need to capture the value, just make ! -- a copy. Likewise for a function call, an attribute reference or an ! -- operator. And if we have a volatile reference and Name_Req is not ! -- set (see comments above for Side_Effect_Free). if Is_Elementary_Type (Exp_Type) and then (Variable_Ref or else Nkind (Exp) = N_Function_Call + or else Nkind (Exp) = N_Attribute_Reference or else Nkind (Exp) in N_Op ! or else (not Name_Req and then Is_Volatile_Reference (Exp))) then Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); Set_Etype (Def_Id, Exp_Type); *************** package body Exp_Util is *** 4645,4653 **** -- If this is a type conversion, leave the type conversion and remove -- the side effects in the expression. This is important in several ! -- circumstances: for change of representations, and also when this ! -- is a view conversion to a smaller object, where gigi can end up ! -- creating its own temporary of the wrong size. elsif Nkind (Exp) = N_Type_Conversion then Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref); --- 4518,4526 ---- -- If this is a type conversion, leave the type conversion and remove -- the side effects in the expression. This is important in several ! -- circumstances: for change of representations, and also when this is ! -- a view conversion to a smaller object, where gigi can end up creating ! -- its own temporary of the wrong size. elsif Nkind (Exp) = N_Type_Conversion then Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref); *************** package body Exp_Util is *** 4660,4666 **** elsif Nkind (Exp) = N_Unchecked_Type_Conversion and then not Safe_Unchecked_Type_Conversion (Exp) then ! if CW_Or_Controlled_Type (Exp_Type) then -- Use a renaming to capture the expression, rather than create -- a controlled temporary. --- 4533,4539 ---- elsif Nkind (Exp) = N_Unchecked_Type_Conversion and then not Safe_Unchecked_Type_Conversion (Exp) then ! if CW_Or_Has_Controlled_Part (Exp_Type) then -- Use a renaming to capture the expression, rather than create -- a controlled temporary. *************** package body Exp_Util is *** 4691,4704 **** end if; -- For expressions that denote objects, we can use a renaming scheme. ! -- We skip using this if we have a volatile variable and we do not ! -- have Nam_Req set true (see comments above for Side_Effect_Free). elsif Is_Object_Reference (Exp) and then Nkind (Exp) /= N_Function_Call ! and then (Name_Req ! or else not Is_Entity_Name (Exp) ! or else not Treat_As_Volatile (Entity (Exp))) then Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); --- 4564,4575 ---- end if; -- For expressions that denote objects, we can use a renaming scheme. ! -- We skip using this if we have a volatile reference and we do not ! -- have Name_Req set true (see comments above for Side_Effect_Free). elsif Is_Object_Reference (Exp) and then Nkind (Exp) /= N_Function_Call ! and then (Name_Req or else not Is_Volatile_Reference (Exp)) then Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); *************** package body Exp_Util is *** 4737,4743 **** -- If this is a packed reference, or a selected component with a -- non-standard representation, a reference to the temporary will -- be replaced by a copy of the original expression (see ! -- exp_ch2.Expand_Renaming). Otherwise the temporary must be -- elaborated by gigi, and is of course not to be replaced in-line -- by the expression it renames, which would defeat the purpose of -- removing the side-effect. --- 4608,4614 ---- -- If this is a packed reference, or a selected component with a -- non-standard representation, a reference to the temporary will -- be replaced by a copy of the original expression (see ! -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be -- elaborated by gigi, and is of course not to be replaced in-line -- by the expression it renames, which would defeat the purpose of -- removing the side-effect. *************** package body Exp_Util is *** 4754,4759 **** --- 4625,4660 ---- -- Otherwise we generate a reference to the value else + -- Special processing for function calls that return a task. We need + -- to build a declaration that will enable build-in-place expansion + -- of the call. + + -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have + -- to accommodate functions returning limited objects by reference. + + if Nkind (Exp) = N_Function_Call + and then Is_Task_Type (Etype (Exp)) + and then Ada_Version >= Ada_05 + then + declare + Obj : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('F')); + Decl : Node_Id; + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Obj, + Object_Definition => New_Occurrence_Of (Exp_Type, Loc), + Expression => Relocate_Node (Exp)); + Insert_Action (Exp, Decl); + Set_Etype (Obj, Exp_Type); + Rewrite (Exp, New_Occurrence_Of (Obj, Loc)); + return; + end; + end if; + Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); Ptr_Typ_Decl := *************** package body Exp_Util is *** 5161,5169 **** Analyze (Asn); ! -- Kill current value indication. This is necessary because ! -- the tests of this flag are inserted out of sequence and must ! -- not pick up bogus indications of the wrong constant value. Set_Current_Value (Ent, Empty); end if; --- 5062,5070 ---- Analyze (Asn); ! -- Kill current value indication. This is necessary because the ! -- tests of this flag are inserted out of sequence and must not ! -- pick up bogus indications of the wrong constant value. Set_Current_Value (Ent, Empty); end if; *************** package body Exp_Util is *** 5196,5201 **** --- 5097,5183 ---- end if; end Set_Renamed_Subprogram; + ---------------------------------- + -- Silly_Boolean_Array_Not_Test -- + ---------------------------------- + + -- This procedure implements an odd and silly test. We explicitly check + -- for the case where the 'First of the component type is equal to the + -- 'Last of this component type, and if this is the case, we make sure + -- that constraint error is raised. The reason is that the NOT is bound + -- to cause CE in this case, and we will not otherwise catch it. + + -- Believe it or not, this was reported as a bug. Note that nearly + -- always, the test will evaluate statically to False, so the code will + -- be statically removed, and no extra overhead caused. + + procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + CT : constant Entity_Id := Component_Type (T); + + begin + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_First), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_Last)), + Reason => CE_Range_Check_Failed)); + end Silly_Boolean_Array_Not_Test; + + ---------------------------------- + -- Silly_Boolean_Array_Xor_Test -- + ---------------------------------- + + -- This procedure implements an odd and silly test. We explicitly check + -- for the XOR case where the component type is True .. True, since this + -- will raise constraint error. A special check is required since CE + -- will not be required otherwise (cf Expand_Packed_Not). + + -- No such check is required for AND and OR, since for both these cases + -- False op False = False, and True op True = True. + + procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + CT : constant Entity_Id := Component_Type (T); + BT : constant Entity_Id := Base_Type (CT); + + begin + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_And (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_First), + + Right_Opnd => + Convert_To (BT, + New_Occurrence_Of (Standard_True, Loc))), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_Last), + + Right_Opnd => + Convert_To (BT, + New_Occurrence_Of (Standard_True, Loc)))), + Reason => CE_Range_Check_Failed)); + end Silly_Boolean_Array_Xor_Test; + -------------------------- -- Target_Has_Fixed_Ops -- -------------------------- *************** package body Exp_Util is *** 5206,5212 **** Long_Integer_Sized_Small : Ureal; -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this ! -- functoin is called (we don't want to compute it more than once) First_Time_For_THFO : Boolean := True; -- Set to False after first call (if Fractional_Fixed_Ops_On_Target) --- 5188,5194 ---- Long_Integer_Sized_Small : Ureal; -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this ! -- function is called (we don't want to compute it more than once) First_Time_For_THFO : Boolean := True; -- Set to False after first call (if Fractional_Fixed_Ops_On_Target) diff -Nrcpad gcc-4.3.3/gcc/ada/exp_util.ads gcc-4.4.0/gcc/ada/exp_util.ads *** gcc-4.3.3/gcc/ada/exp_util.ads Thu Dec 13 10:22:06 2007 --- gcc-4.4.0/gcc/ada/exp_util.ads Wed Jul 30 17:38:16 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Exp_Util is *** 205,210 **** --- 205,211 ---- -- index values. For composite types, the result includes two declarations: -- one for a generated function that computes the image without using -- concatenation, and one for the variable that holds the result. + -- -- If In_Init_Proc is true, the call is part of the initialization of -- a component of a composite type, and the enclosing initialization -- procedure must be flagged as using the secondary stack. If In_Init_Proc *************** package Exp_Util is *** 212,256 **** -- function itself must do its own cleanups. function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean; ! -- This function is in charge of detecting record components that may cause ! -- trouble in the back end if an attempt is made to assign the component. ! -- The back end can handle such assignments with no problem if the ! -- components involved are small (64-bits or less) records or scalar items ! -- (including bit-packed arrays represented with modular types) or are both ! -- aligned on a byte boundary (starting on a byte boundary, and occupying ! -- an integral number of bytes). -- -- However, problems arise for records larger than 64 bits, or for arrays -- (other than bit-packed arrays represented with a modular type) if the -- component starts on a non-byte boundary, or does not occupy an integral ! -- number of bytes (i.e. there are some bits possibly shared with fields at ! -- the start or beginning of the component). The back end cannot handle -- loading and storing such components in a single operation. -- -- This function is used to detect the troublesome situation. it is ! -- conservative in the sense that it produces True unless it knows for sure ! -- that the component is safe (as outlined in the first paragraph above). ! -- The code generation for record and array assignment checks for trouble ! -- using this function, and if so the assignment is generated -- component-wise, which the back end is required to handle correctly. -- ! -- Note that in GNAT 3, the back end will reject such components anyway, so ! -- the hard work in checking for this case is wasted in GNAT 3, but it's ! -- harmless, so it is easier to do it in all cases, rather than -- conditionalize it in GNAT 5 or beyond. procedure Convert_To_Actual_Subtype (Exp : Node_Id); ! -- The Etype of an expression is the nominal type of the expression, not ! -- the actual subtype. Often these are the same, but not always. For ! -- example, a reference to a formal of unconstrained type has the -- unconstrained type as its Etype, but the actual subtype is obtained by -- applying the actual bounds. This routine is given an expression, Exp, ! -- and (if necessary), replaces it using Rewrite, with a conversion to the ! -- actual subtype, building the actual subtype if necessary. If the -- expression is already of the requested type, then it is unchanged. function Current_Sem_Unit_Declarations return List_Id; ! -- Return the a place where it is fine to insert declarations for the -- current semantic unit. If the unit is a package body, return the -- visible declarations of the corresponding spec. For RCI stubs, this -- is necessary because the point at which they are generated may not --- 213,265 ---- -- function itself must do its own cleanups. function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean; ! -- This function is in charge of detecting record components that may ! -- cause trouble in the back end if an attempt is made to assign the ! -- component. The back end can handle such assignments with no problem if ! -- the components involved are small (64-bits or less) records or scalar ! -- items (including bit-packed arrays represented with modular types) or ! -- are both aligned on a byte boundary (starting on a byte boundary, and ! -- occupying an integral number of bytes). -- -- However, problems arise for records larger than 64 bits, or for arrays -- (other than bit-packed arrays represented with a modular type) if the -- component starts on a non-byte boundary, or does not occupy an integral ! -- number of bytes (i.e. there are some bits possibly shared with fields ! -- at the start or beginning of the component). The back end cannot handle -- loading and storing such components in a single operation. -- -- This function is used to detect the troublesome situation. it is ! -- conservative in the sense that it produces True unless it knows for ! -- sure that the component is safe (as outlined in the first paragraph ! -- above). The code generation for record and array assignment checks for ! -- trouble using this function, and if so the assignment is generated -- component-wise, which the back end is required to handle correctly. -- ! -- Note that in GNAT 3, the back end will reject such components anyway, ! -- so the hard work in checking for this case is wasted in GNAT 3, but ! -- it is harmless, so it is easier to do it in all cases, rather than -- conditionalize it in GNAT 5 or beyond. procedure Convert_To_Actual_Subtype (Exp : Node_Id); ! -- The Etype of an expression is the nominal type of the expression, ! -- not the actual subtype. Often these are the same, but not always. ! -- For example, a reference to a formal of unconstrained type has the -- unconstrained type as its Etype, but the actual subtype is obtained by -- applying the actual bounds. This routine is given an expression, Exp, ! -- and (if necessary), replaces it using Rewrite, with a conversion to ! -- the actual subtype, building the actual subtype if necessary. If the -- expression is already of the requested type, then it is unchanged. + function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id; + -- Return the id of the runtime package that will provide support for + -- concurrent type Typ. Currently only protected types are supported, + -- and the returned value is one of the following: + -- System_Tasking_Protected_Objects + -- System_Tasking_Protected_Objects_Entries + -- System_Tasking_Protected_Objects_Single_Entry + function Current_Sem_Unit_Declarations return List_Id; ! -- Return the place where it is fine to insert declarations for the -- current semantic unit. If the unit is a package body, return the -- visible declarations of the corresponding spec. For RCI stubs, this -- is necessary because the point at which they are generated may not *************** package Exp_Util is *** 306,311 **** --- 315,325 ---- -- used to ensure that an Itype is properly defined outside a conditional -- construct when it is referenced in more than one branch. + function Entry_Names_OK return Boolean; + -- Determine whether it is appropriate to dynamically allocate strings + -- which represent entry [family member] names. These strings are created + -- by the compiler and used by GDB. + procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id); -- Rewrites Cond with the expression: Cond and then Cond1. If Cond is -- Empty, then simply returns Cond1 (this allows the use of Empty to *************** package Exp_Util is *** 329,341 **** -- declarations and/or allocations when the type is indefinite (including -- class-wide). - function Find_Interface - (T : Entity_Id; - Comp : Entity_Id) return Entity_Id; - -- Ada 2005 (AI-251): Given a tagged type and one of its components - -- associated with the secondary dispatch table of an abstract interface - -- type, return the associated abstract interface type. - function Find_Interface_ADT (T : Entity_Id; Iface : Entity_Id) return Elmt_Id; --- 343,348 ---- *************** package Exp_Util is *** 353,359 **** -- Find the first primitive operation of type T whose name is 'Name'. -- This function allows the use of a primitive operation which is not -- directly visible. If T is a class wide type, then the reference is ! -- to an operation of the corresponding root type. function Find_Prim_Op (T : Entity_Id; --- 360,369 ---- -- Find the first primitive operation of type T whose name is 'Name'. -- This function allows the use of a primitive operation which is not -- directly visible. If T is a class wide type, then the reference is ! -- to an operation of the corresponding root type. Raises Program_Error ! -- exception if no primitive operation is found. This is normally an ! -- internal error, but in some cases is an expected consequence of ! -- illegalities elsewhere. function Find_Prim_Op (T : Entity_Id; *************** package Exp_Util is *** 363,375 **** -- with the indicated suffix). This function allows use of a primitive -- operation which is not directly visible. If T is a class wide type, -- then the reference is to an operation of the corresponding root type. procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False); -- Force the evaluation of the expression right away. Similar behavior -- to Remove_Side_Effects when Variable_Ref is set to TRUE. That is to ! -- say, it removes the side-effects and capture the values of the -- variables. Remove_Side_Effects guarantees that multiple evaluations -- of the same expression won't generate multiple side effects, whereas -- Force_Evaluation further guarantees that all evaluations will yield --- 373,395 ---- -- with the indicated suffix). This function allows use of a primitive -- operation which is not directly visible. If T is a class wide type, -- then the reference is to an operation of the corresponding root type. + -- Raises Program_Error exception if no primitive operation is found. + -- This is normally an internal error, but in some cases is an expected + -- consequence of illegalities elsewhere. + + function Find_Protection_Object (Scop : Entity_Id) return Entity_Id; + -- Traverse the scope stack starting from Scop and look for an entry, + -- entry family, or a subprogram that has a Protection_Object and return + -- it. Raises Program_Error if no such entity is found since the context + -- in which this routine is invoked should always have a protection + -- object. procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False); -- Force the evaluation of the expression right away. Similar behavior -- to Remove_Side_Effects when Variable_Ref is set to TRUE. That is to ! -- say, it removes the side-effects and captures the values of the -- variables. Remove_Side_Effects guarantees that multiple evaluations -- of the same expression won't generate multiple side effects, whereas -- Force_Evaluation further guarantees that all evaluations will yield *************** package Exp_Util is *** 421,427 **** -- homonym number used to disambiguate overloaded subprograms in the same -- scope (the number is used as part of constructed names to make sure that -- they are unique). The number is the ordinal position on the Homonym ! -- chain, counting only entries in the curren scope. If an entity is not -- overloaded, the returned number will be one. function Inside_Init_Proc return Boolean; --- 441,447 ---- -- homonym number used to disambiguate overloaded subprograms in the same -- scope (the number is used as part of constructed names to make sure that -- they are unique). The number is the ordinal position on the Homonym ! -- chain, counting only entries in the current scope. If an entity is not -- overloaded, the returned number will be one. function Inside_Init_Proc return Boolean; *************** package Exp_Util is *** 429,435 **** function In_Unconditional_Context (Node : Node_Id) return Boolean; -- Node is the node for a statement or a component of a statement. This ! -- function deteermines if the statement appears in a context that is -- unconditionally executed, i.e. it is not within a loop or a conditional -- or a case statement etc. --- 449,455 ---- function In_Unconditional_Context (Node : Node_Id) return Boolean; -- Node is the node for a statement or a component of a statement. This ! -- function determines if the statement appears in a context that is -- unconditionally executed, i.e. it is not within a loop or a conditional -- or a case statement etc. *************** package Exp_Util is *** 442,450 **** -- Return True if Typ is a library level tagged type. Currently we use -- this information to build statically allocated dispatch tables. - function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; - -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation - function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean; -- Determine whether the node P is a reference to a bit packed array, i.e. -- whether the designated object is a component of a bit packed array, or a --- 462,467 ---- *************** package Exp_Util is *** 466,472 **** -- Node N is an object reference. This function returns True if it is -- possible that the object may not be aligned according to the normal -- default alignment requirement for its type (e.g. if it appears in a ! -- packed record, or as part of a component that has a component clause. function Is_Renamed_Object (N : Node_Id) return Boolean; -- Returns True if the node N is a renamed object. An expression is --- 483,489 ---- -- Node N is an object reference. This function returns True if it is -- possible that the object may not be aligned according to the normal -- default alignment requirement for its type (e.g. if it appears in a ! -- packed record, or as part of a component that has a component clause.) function Is_Renamed_Object (N : Node_Id) return Boolean; -- Returns True if the node N is a renamed object. An expression is *************** package Exp_Util is *** 483,488 **** --- 500,512 ---- -- Returns true if type T is not tagged and is a derived type, -- or is a private type whose completion is such a type. + function Is_Volatile_Reference (N : Node_Id) return Boolean; + -- Checks if the node N represents a volatile reference, which can be + -- either a direct reference to a variable treated as volatile, or an + -- indexed/selected component where the prefix is treated as volatile, + -- or has Volatile_Components set. A slice of a volatile variable is + -- also volatile. + procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False); -- N represents a node for a section of code that is known to be dead. Any -- exception handler references and warning messages relating to this code *************** package Exp_Util is *** 547,558 **** -- returned only if the replacement is safe. function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean; ! -- This function is used in processing the assignment of a record or ! -- indexed component. The argument N is either the left hand or right ! -- hand side of an assignment, and this function determines if there ! -- is a record component reference where the record may be bit aligned ! -- in a manner that causes trouble for the back end (see description ! -- of Exp_Util.Component_May_Be_Bit_Aligned for further details). procedure Remove_Side_Effects (Exp : Node_Id; --- 571,582 ---- -- returned only if the replacement is safe. function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean; ! -- This function is used during processing the assignment of a record or ! -- indexed component. The argument N is either the left hand or right hand ! -- side of an assignment, and this function determines if there is a record ! -- component reference where the record may be bit aligned in a manner that ! -- causes trouble for the back end (see Component_May_Be_Bit_Aligned for ! -- further details). procedure Remove_Side_Effects (Exp : Node_Id; *************** package Exp_Util is *** 605,610 **** --- 629,646 ---- -- renamed subprogram. The node is rewritten to be an identifier that -- refers directly to the renamed subprogram, given by entity E. + procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id); + -- N is the node for a boolean array NOT operation, and T is the type of + -- the array. This routine deals with the silly case where the subtype of + -- the boolean array is False..False or True..True, where it is required + -- that a Constraint_Error exception be raised (RM 4.5.6(6)). + + procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id); + -- N is the node for a boolean array XOR operation, and T is the type of + -- the array. This routine deals with the silly case where the subtype of + -- the boolean array is True..True, where a raise of a Constraint_Error + -- exception is required (RM 4.5.6(6)). + function Target_Has_Fixed_Ops (Left_Typ : Entity_Id; Right_Typ : Entity_Id; diff -Nrcpad gcc-4.3.3/gcc/ada/exp_vfpt.adb gcc-4.4.0/gcc/ada/exp_vfpt.adb *** gcc-4.3.3/gcc/ada/exp_vfpt.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_vfpt.adb Mon May 26 15:51:38 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2008, 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- -- *************** package body Exp_VFpt is *** 242,248 **** Func : RE_Id; function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id; ! -- Given one of the two types T, determines the coresponding call -- type, i.e. the type to be used for the call (or the result of -- the call). The actual operand is converted to (or from) this type. -- Otyp is the other type, which is useful in figuring out the result. --- 242,248 ---- Func : RE_Id; function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id; ! -- Given one of the two types T, determines the corresponding call -- type, i.e. the type to be used for the call (or the result of -- the call). The actual operand is converted to (or from) this type. -- Otyp is the other type, which is useful in figuring out the result. *************** package body Exp_VFpt is *** 443,448 **** --- 443,483 ---- Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks); end Expand_Vax_Conversion; + ------------------------------- + -- Expand_Vax_Foreign_Return -- + ------------------------------- + + procedure Expand_Vax_Foreign_Return (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Base_Type (Etype (N)); + Func : RE_Id; + Args : List_Id; + Atyp : Entity_Id; + Rtyp : constant Entity_Id := Etype (N); + + begin + if Digits_Value (Typ) = VAXFF_Digits then + Func := RE_Return_F; + Atyp := RTE (RE_F); + elsif Digits_Value (Typ) = VAXDF_Digits then + Func := RE_Return_D; + Atyp := RTE (RE_D); + else pragma Assert (Digits_Value (Typ) = VAXGF_Digits); + Func := RE_Return_G; + Atyp := RTE (RE_G); + end if; + + Args := New_List (Convert_To (Atyp, N)); + + Rewrite (N, + Convert_To (Rtyp, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => Args))); + + Analyze_And_Resolve (N, Typ, Suppress => All_Checks); + end Expand_Vax_Foreign_Return; + ----------------------------- -- Expand_Vax_Real_Literal -- ----------------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/exp_vfpt.ads gcc-4.4.0/gcc/ada/exp_vfpt.ads *** gcc-4.3.3/gcc/ada/exp_vfpt.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/exp_vfpt.ads Tue May 27 08:50:43 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Exp_VFpt is *** 45,50 **** --- 45,56 ---- -- The node N is a type conversion node where either the source or the -- target type, or both, are Vax floating-point type. + procedure Expand_Vax_Foreign_Return (N : Node_Id); + -- The node N is a call to a foreign function that returns a Vax float + -- value in a floating point register. Wraps the call in an asm stub + -- that moves the return value to an integer location on Alpha/VMS, + -- noop everywhere else. + procedure Expand_Vax_Real_Literal (N : Node_Id); -- The node N is a real literal node where the type is a Vax floating-point -- type. This procedure rewrites the node to eliminate the occurrence of diff -Nrcpad gcc-4.3.3/gcc/ada/expander.adb gcc-4.4.0/gcc/ada/expander.adb *** gcc-4.3.3/gcc/ada/expander.adb Thu Dec 13 10:24:44 2007 --- gcc-4.4.0/gcc/ada/expander.adb Tue Apr 8 06:57:39 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Expander is *** 73,84 **** procedure Expand (N : Node_Id) is begin ! -- If we were analyzing a default expression the Full_Analysis flag must ! -- be off. If we are in expansion mode then we must be performing a full ! -- analysis. If we are analyzing a generic then Expansion must be off. pragma Assert ! (not (Full_Analysis and then In_Default_Expression) and then (Full_Analysis or else not Expander_Active) and then not (Inside_A_Generic and then Expander_Active)); --- 73,85 ---- procedure Expand (N : Node_Id) is begin ! -- If we were analyzing a default expression (or other spec expression) ! -- the Full_Analysis flag must be off. If we are in expansion mode then ! -- we must be performing a full analysis. If we are analyzing a generic ! -- then Expansion must be off. pragma Assert ! (not (Full_Analysis and then In_Spec_Expression) and then (Full_Analysis or else not Expander_Active) and then not (Inside_A_Generic and then Expander_Active)); diff -Nrcpad gcc-4.3.3/gcc/ada/expander.ads gcc-4.4.0/gcc/ada/expander.ads *** gcc-4.3.3/gcc/ada/expander.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/expander.ads Tue Apr 8 06:57:39 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Expander is *** 138,144 **** -- (b) when starting/completing the pre-analysis of an expression -- (see the spec of package Sem for more info on pre-analysis.) -- ! -- Note that when processing a default expression (In_Default_Expression -- is True) or performing semantic analysis of a generic spec or body -- (Inside_A_Generic) or when performing pre-analysis (Full_Analysis is -- False) the Expander_Active flag is False. --- 138,144 ---- -- (b) when starting/completing the pre-analysis of an expression -- (see the spec of package Sem for more info on pre-analysis.) -- ! -- Note that when processing a spec expression (In_Spec_Expression -- is True) or performing semantic analysis of a generic spec or body -- (Inside_A_Generic) or when performing pre-analysis (Full_Analysis is -- False) the Expander_Active flag is False. diff -Nrcpad gcc-4.3.3/gcc/ada/fe.h gcc-4.4.0/gcc/ada/fe.h *** gcc-4.3.3/gcc/ada/fe.h Thu Dec 13 10:19:19 2007 --- gcc-4.4.0/gcc/ada/fe.h Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Header File * * * ! * Copyright (C) 1992-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Header File * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** extern char Fold_Lower[], Fold_Upper[]; *** 46,55 **** /* debug: */ - #define Debug_Flag_XX debug__debug_flag_xx #define Debug_Flag_NN debug__debug_flag_nn - - extern Boolean Debug_Flag_XX; extern Boolean Debug_Flag_NN; /* einfo: We will be setting Esize for types, Component_Bit_Offset for fields, --- 45,51 ---- *************** extern void Set_Has_No_Elaboration_Code *** 222,229 **** --- 218,227 ---- /* targparm: */ + #define Backend_Overflow_Checks_On_Target targparm__backend_overflow_checks_on_target #define Stack_Check_Probes_On_Target targparm__stack_check_probes_on_target #define Stack_Check_Limits_On_Target targparm__stack_check_limits_on_target + extern Boolean Backend_Overflow_Checks_On_Target; extern Boolean Stack_Check_Probes_On_Target; extern Boolean Stack_Check_Limits_On_Target; diff -Nrcpad gcc-4.3.3/gcc/ada/final.c gcc-4.4.0/gcc/ada/final.c *** gcc-4.3.3/gcc/ada/final.c Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/final.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2003 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * diff -Nrcpad gcc-4.3.3/gcc/ada/fmap.adb gcc-4.4.0/gcc/ada/fmap.adb *** gcc-4.3.3/gcc/ada/fmap.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/fmap.adb Mon Apr 14 21:07:59 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** with GNAT.HTable; *** 37,44 **** package body Fmap is ! subtype Big_String is String (Positive); ! type Big_String_Ptr is access all Big_String; function To_Big_String_Ptr is new Unchecked_Conversion (Source_Buffer_Ptr, Big_String_Ptr); --- 37,46 ---- package body Fmap is ! No_Mapping_File : Boolean := False; ! -- Set to True when the specified mapping file cannot be read in ! -- procedure Initialize, so that no attempt is made to open the mapping ! -- file in procedure Update_Mapping_File. function To_Big_String_Ptr is new Unchecked_Conversion (Source_Buffer_Ptr, Big_String_Ptr); *************** package body Fmap is *** 301,306 **** --- 303,309 ---- Write_Str ("warning: could not read mapping file """); Write_Str (File_Name); Write_Line (""""); + No_Mapping_File := True; else BS := To_Big_String_Ptr (Src); *************** package body Fmap is *** 479,505 **** -- Start of Update_Mapping_File begin -- Only Update if there are new entries in the mappings if Last_In_Table < File_Mapping.Last then ! -- If the tables have been emptied, recreate the file. ! -- Otherwise, append to it. ! ! if Last_In_Table = 0 then ! declare ! Discard : Boolean; ! pragma Warnings (Off, Discard); ! begin ! Delete_File (File_Name, Discard); ! end; ! ! File := Create_File (File_Name, Binary); ! ! else ! File := Open_Read_Write (Name => File_Name, Fmode => Binary); ! end if; if File /= Invalid_FD then if Last_In_Table > 0 then --- 482,498 ---- -- Start of Update_Mapping_File begin + -- If the mapping file could not be read, then it will not be possible + -- to update it. + if No_Mapping_File then + return; + end if; -- Only Update if there are new entries in the mappings if Last_In_Table < File_Mapping.Last then ! File := Open_Read_Write (Name => File_Name, Fmode => Binary); if File /= Invalid_FD then if Last_In_Table > 0 then diff -Nrcpad gcc-4.3.3/gcc/ada/fname-sf.adb gcc-4.4.0/gcc/ada/fname-sf.adb *** gcc-4.3.3/gcc/ada/fname-sf.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/fname-sf.adb Tue Apr 8 06:48:30 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Unchecked_Conversion; *** 34,42 **** package body Fname.SF is - subtype Big_String is String (Positive); - type Big_String_Ptr is access all Big_String; - function To_Big_String_Ptr is new Unchecked_Conversion (Source_Buffer_Ptr, Big_String_Ptr); --- 34,39 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/fname.adb gcc-4.4.0/gcc/ada/fname.adb *** gcc-4.3.3/gcc/ada/fname.adb Wed Jun 6 10:19:40 2007 --- gcc-4.4.0/gcc/ada/fname.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/fname.ads gcc-4.4.0/gcc/ada/fname.ads *** gcc-4.3.3/gcc/ada/fname.ads Wed Jun 6 10:19:40 2007 --- gcc-4.4.0/gcc/ada/fname.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Fname is *** 68,79 **** (Fname : File_Name_Type; Renamings_Included : Boolean := True) return Boolean; -- This function determines if the given file name (which must be a simple ! -- file name with no directory information) is the file name for one of ! -- the predefined library units. On return, Name_Buffer contains the ! -- file name. The Renamings_Included parameter indicates whether annex ! -- J renamings such as Text_IO are to be considered as predefined. If ! -- Renamings_Included is True, then Text_IO will return True, otherwise ! -- only children of Ada, Interfaces and System return True. function Is_Predefined_File_Name (Renamings_Included : Boolean := True) return Boolean; --- 66,79 ---- (Fname : File_Name_Type; Renamings_Included : Boolean := True) return Boolean; -- This function determines if the given file name (which must be a simple ! -- file name with no directory information) is the file name for one of the ! -- predefined library units (i.e. part of the Ada, System, or Interface ! -- hierarchies). Note that units in the GNAT hierarchy are not considered ! -- predefined (see Is_Internal_File_Name below). On return, Name_Buffer ! -- contains the file name. The Renamings_Included parameter indicates ! -- whether annex J renamings such as Text_IO are to be considered as ! -- predefined. If Renamings_Included is True, then Text_IO will return ! -- True, otherwise only children of Ada, Interfaces and System return True. function Is_Predefined_File_Name (Renamings_Included : Boolean := True) return Boolean; *************** package Fname is *** 82,90 **** function Is_Internal_File_Name (Fname : File_Name_Type; Renamings_Included : Boolean := True) return Boolean; ! -- Similar to Is_Predefined_File_Name. The internal file set is a ! -- superset of the predefined file set including children of GNAT, ! -- and also children of DEC for the VMS case. procedure Tree_Read; -- Dummy procedure (reads dummy table values from tree file) --- 82,90 ---- function Is_Internal_File_Name (Fname : File_Name_Type; Renamings_Included : Boolean := True) return Boolean; ! -- Similar to Is_Predefined_File_Name. The internal file set is a superset ! -- of the predefined file set including children of GNAT, and also children ! -- of DEC for the VMS case. procedure Tree_Read; -- Dummy procedure (reads dummy table values from tree file) diff -Nrcpad gcc-4.3.3/gcc/ada/freeze.adb gcc-4.4.0/gcc/ada/freeze.adb *** gcc-4.3.3/gcc/ada/freeze.adb Wed Dec 19 16:23:55 2007 --- gcc-4.4.0/gcc/ada/freeze.adb Thu Apr 9 23:23:07 2009 *************** *** 6,23 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,23 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- ! -- -- ! -- You should have received a copy of the GNU General Public License along -- ! -- with this program; see file COPYING3. If not see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** with Debug; use Debug; *** 29,35 **** --- 29,37 ---- with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; + with Exp_Ch3; use Exp_Ch3; with Exp_Ch7; use Exp_Ch7; + with Exp_Disp; use Exp_Disp; with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; with Exp_Tss; use Exp_Tss; *************** package body Freeze is *** 132,137 **** --- 134,143 ---- -- the designated type. Otherwise freezing the access type does not freeze -- the designated type. + procedure Generate_Prim_Op_References (Typ : Entity_Id); + -- For a tagged type, generate implicit references to its primitive + -- operations, for source navigation. + procedure Process_Default_Expressions (E : Entity_Id; After : in out Node_Id); *************** package body Freeze is *** 155,168 **** -- setting of Debug_Info_Needed for the entity. This flag is set if -- the entity comes from source, or if we are in Debug_Generated_Code -- mode or if the -gnatdV debug flag is set. However, it never sets ! -- the flag if Debug_Info_Off is set. ! ! procedure Set_Debug_Info_Needed (T : Entity_Id); ! -- Sets the Debug_Info_Needed flag on entity T if not already set, and ! -- also on any entities that are needed by T (for an object, the type ! -- of the object is needed, and for a type, the subsidiary types are ! -- needed -- see body for details). Never has any effect on T if the ! -- Debug_Info_Off flag is set. procedure Undelay_Type (T : Entity_Id); -- T is a type of a component that we know to be an Itype. --- 161,168 ---- -- setting of Debug_Info_Needed for the entity. This flag is set if -- the entity comes from source, or if we are in Debug_Generated_Code -- mode or if the -gnatdV debug flag is set. However, it never sets ! -- the flag if Debug_Info_Off is set. This procedure also ensures that ! -- subsidiary entities have the flag set as required. procedure Undelay_Type (T : Entity_Id); -- T is a type of a component that we know to be an Itype. *************** package body Freeze is *** 337,343 **** begin -- The controlling formal may be an access parameter, or the ! -- actual may be an access value, so ajust accordingly. if Is_Access_Type (Pref_Type) and then not Is_Access_Type (Form_Type) --- 337,343 ---- begin -- The controlling formal may be an access parameter, or the ! -- actual may be an access value, so adjust accordingly. if Is_Access_Type (Pref_Type) and then not Is_Access_Type (Form_Type) *************** package body Freeze is *** 518,524 **** -- the address expression must be a constant. if (No (Expression (Decl)) ! and then not Controlled_Type (Typ) and then (not Has_Non_Null_Base_Init_Proc (Typ) or else Is_Imported (E))) --- 518,524 ---- -- the address expression must be a constant. if (No (Expression (Decl)) ! and then not Needs_Finalization (Typ) and then (not Has_Non_Null_Base_Init_Proc (Typ) or else Is_Imported (E))) *************** package body Freeze is *** 547,553 **** end if; if not Error_Posted (Expr) ! and then not Controlled_Type (Typ) then Warn_Overlay (Expr, Typ, Name (Addr)); end if; --- 547,553 ---- end if; if not Error_Posted (Expr) ! and then not Needs_Finalization (Typ) then Warn_Overlay (Expr, Typ, Name (Addr)); end if; *************** package body Freeze is *** 623,639 **** if Size_Known_At_Compile_Time (T) then return True; elsif Is_Scalar_Type (T) or else Is_Task_Type (T) then ! return not Is_Generic_Type (T); elsif Is_Array_Type (T) then if Ekind (T) = E_String_Literal_Subtype then Set_Small_Size (T, Component_Size (T) * String_Literal_Length (T)); return True; elsif not Is_Constrained (T) then return False; --- 623,651 ---- if Size_Known_At_Compile_Time (T) then return True; + -- Always True for scalar types. This is true even for generic formal + -- scalar types. We used to return False in the latter case, but the + -- size is known at compile time, even in the template, we just do + -- not know the exact size but that's not the point of this routine. + elsif Is_Scalar_Type (T) or else Is_Task_Type (T) then ! return True; ! ! -- Array types elsif Is_Array_Type (T) then + + -- String literals always have known size, and we can set it + if Ekind (T) = E_String_Literal_Subtype then Set_Small_Size (T, Component_Size (T) * String_Literal_Length (T)); return True; + -- Unconstrained types never have known at compile time size + elsif not Is_Constrained (T) then return False; *************** package body Freeze is *** 643,648 **** --- 655,662 ---- elsif Error_Posted (T) then return False; + -- Otherwise if component size unknown, then array size unknown + elsif not Size_Known (Component_Type (T)) then return False; end if; *************** package body Freeze is *** 691,699 **** --- 705,717 ---- return True; end; + -- Access types always have known at compile time sizes + elsif Is_Access_Type (T) then return True; + -- For non-generic private types, go to underlying type if present + elsif Is_Private_Type (T) and then not Is_Generic_Type (T) and then Present (Underlying_Type (T)) *************** package body Freeze is *** 707,712 **** --- 725,732 ---- return Size_Known (Underlying_Type (T)); end if; + -- Record types + elsif Is_Record_Type (T) then -- A class-wide type is never considered to have a known size *************** package body Freeze is *** 797,803 **** -- discriminant. -- This is because gigi computes the size by doing a ! -- substituation of the appropriate discriminant value in -- the size expression for the base type, and gigi is not -- clever enough to evaluate the resulting expression (which -- involves a call to rep_to_pos) at compile time. --- 817,823 ---- -- discriminant. -- This is because gigi computes the size by doing a ! -- substitution of the appropriate discriminant value in -- the size expression for the base type, and gigi is not -- clever enough to evaluate the resulting expression (which -- involves a call to rep_to_pos) at compile time. *************** package body Freeze is *** 912,917 **** --- 932,939 ---- return True; end; + -- All other cases, size not known at compile time + else return False; end if; *************** package body Freeze is *** 956,967 **** procedure Check_Debug_Info_Needed (T : Entity_Id) is begin ! if Needs_Debug_Info (T) or else Debug_Info_Off (T) then return; elsif Comes_From_Source (T) or else Debug_Generated_Code or else Debug_Flag_VV then Set_Debug_Info_Needed (T); end if; --- 978,990 ---- procedure Check_Debug_Info_Needed (T : Entity_Id) is begin ! if Debug_Info_Off (T) then return; elsif Comes_From_Source (T) or else Debug_Generated_Code or else Debug_Flag_VV + or else Needs_Debug_Info (T) then Set_Debug_Info_Needed (T); end if; *************** package body Freeze is *** 1105,1112 **** New_N := Make_Object_Declaration (Loc, Defining_Identifier => Temp, ! Object_definition => New_Occurrence_Of (Typ, Loc), ! Expression => Relocate_Node (E)); Insert_Before (Parent (E), New_N); Analyze (New_N); --- 1128,1135 ---- New_N := Make_Object_Declaration (Loc, Defining_Identifier => Temp, ! Object_Definition => New_Occurrence_Of (Typ, Loc), ! Expression => Relocate_Node (E)); Insert_Before (Parent (E), New_N); Analyze (New_N); *************** package body Freeze is *** 1303,1309 **** -- We also add finalization chains to access types whose designated -- types are controlled. This is normally done when freezing the type, -- but this misses recursive type definitions where the later members ! -- of the recursion introduce controlled components (e.g. 5624-001). -- Loop through entities --- 1326,1332 ---- -- We also add finalization chains to access types whose designated -- types are controlled. This is normally done when freezing the type, -- but this misses recursive type definitions where the later members ! -- of the recursion introduce controlled components. -- Loop through entities *************** package body Freeze is *** 1358,1364 **** elsif Is_Access_Type (E) and then Comes_From_Source (E) and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type ! and then Controlled_Type (Designated_Type (E)) and then No (Associated_Final_Chain (E)) then Build_Final_List (Parent (E), E); --- 1381,1387 ---- elsif Is_Access_Type (E) and then Comes_From_Source (E) and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type ! and then Needs_Finalization (Designated_Type (E)) and then No (Associated_Final_Chain (E)) then Build_Final_List (Parent (E), E); *************** package body Freeze is *** 1772,1789 **** & "(component is little-endian)?", CLC); end if; ! -- Do not allow non-contiguous field else Error_Msg_N ! ("attempt to specify non-contiguous field" ! & " not permitted", CLC); Error_Msg_N ! ("\(caused by non-standard Bit_Order " ! & "specified)", CLC); end if; ! -- Case where field fits in one storage unit else -- Give warning if suspicious component clause --- 1795,1815 ---- & "(component is little-endian)?", CLC); end if; ! -- Do not allow non-contiguous field else Error_Msg_N ! ("attempt to specify non-contiguous field " ! & "not permitted", CLC); Error_Msg_N ! ("\caused by non-standard Bit_Order " ! & "specified", CLC); ! Error_Msg_N ! ("\consider possibility of using " ! & "Ada 2005 mode here", CLC); end if; ! -- Case where field fits in one storage unit else -- Give warning if suspicious component clause *************** package body Freeze is *** 1856,1862 **** then declare Will_Be_Frozen : Boolean := False; ! S : Entity_Id := Scope (Rec); begin -- We have a pretty bad kludge here. Suppose Rec is subtype --- 1882,1888 ---- then declare Will_Be_Frozen : Boolean := False; ! S : Entity_Id; begin -- We have a pretty bad kludge here. Suppose Rec is subtype *************** package body Freeze is *** 1874,1879 **** --- 1900,1906 ---- -- do, then mark that Comp'Base will actually be frozen. If -- so, we merely undelay it. + S := Scope (Rec); while Present (S) loop if Is_Subprogram (S) then Will_Be_Frozen := True; *************** package body Freeze is *** 1994,2007 **** end if; end if; -- Check for useless pragma Pack when all components placed. We only -- do this check for record types, not subtypes, since a subtype may -- have all its components placed, and it still makes perfectly good ! -- sense to pack other subtypes or the parent type. if Ekind (Rec) = E_Record_Type and then Is_Packed (Rec) and then not Unplaced_Component then -- Reset packed status. Probably not necessary, but we do it so -- that there is no chance of the back end doing something strange --- 2021,2051 ---- end if; end if; + -- Set OK_To_Reorder_Components depending on debug flags + + if Rec = Base_Type (Rec) + and then Convention (Rec) = Convention_Ada + then + if (Has_Discriminants (Rec) and then Debug_Flag_Dot_V) + or else + (not Has_Discriminants (Rec) and then Debug_Flag_Dot_R) + then + Set_OK_To_Reorder_Components (Rec); + end if; + end if; + -- Check for useless pragma Pack when all components placed. We only -- do this check for record types, not subtypes, since a subtype may -- have all its components placed, and it still makes perfectly good ! -- sense to pack other subtypes or the parent type. We do not give ! -- this warning if Optimize_Alignment is set to Space, since the ! -- pragma Pack does have an effect in this case (it always resets ! -- the alignment to one). if Ekind (Rec) = E_Record_Type and then Is_Packed (Rec) and then not Unplaced_Component + and then Optimize_Alignment /= 'S' then -- Reset packed status. Probably not necessary, but we do it so -- that there is no chance of the back end doing something strange *************** package body Freeze is *** 2093,2108 **** -- Generate warning for applying C or C++ convention to a record -- with discriminants. This is suppressed for the unchecked union ! -- case, since the whole point in this case is interface C. if Has_Discriminants (E) and then not Is_Unchecked_Union (E) - and then not Warnings_Off (E) - and then not Warnings_Off (Base_Type (E)) and then (Convention (E) = Convention_C or else Convention (E) = Convention_CPP) and then Comes_From_Source (E) then declare Cprag : constant Node_Id := Get_Rep_Pragma (E, Name_Convention); --- 2137,2155 ---- -- Generate warning for applying C or C++ convention to a record -- with discriminants. This is suppressed for the unchecked union ! -- case, since the whole point in this case is interface C. We also ! -- do not generate this within instantiations, since we will have ! -- generated a message on the template. if Has_Discriminants (E) and then not Is_Unchecked_Union (E) and then (Convention (E) = Convention_C or else Convention (E) = Convention_CPP) and then Comes_From_Source (E) + and then not In_Instance + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (Base_Type (E)) then declare Cprag : constant Node_Id := Get_Rep_Pragma (E, Name_Convention); *************** package body Freeze is *** 2330,2345 **** end if; -- Check suspicious parameter for C function. These tests ! -- apply only to exported/imported suboprograms. if Warn_On_Export_Import and then (Convention (E) = Convention_C or else Convention (E) = Convention_CPP) - and then not Warnings_Off (E) - and then not Warnings_Off (F_Type) - and then not Warnings_Off (Formal) and then (Is_Imported (E) or else Is_Exported (E)) then Error_Msg_Qual_Level := 1; --- 2377,2394 ---- end if; -- Check suspicious parameter for C function. These tests ! -- apply only to exported/imported subprograms. if Warn_On_Export_Import + and then Comes_From_Source (E) and then (Convention (E) = Convention_C or else Convention (E) = Convention_CPP) and then (Is_Imported (E) or else Is_Exported (E)) + and then Convention (E) /= Convention (Formal) + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (F_Type) + and then not Has_Warnings_Off (Formal) then Error_Msg_Qual_Level := 1; *************** package body Freeze is *** 2356,2361 **** --- 2405,2412 ---- elsif Root_Type (F_Type) = Standard_Boolean and then Convention (F_Type) = Convention_Ada + and then not Has_Warnings_Off (F_Type) + and then not Has_Size_Clause (F_Type) then Error_Msg_N ("?& is an 8-bit Ada Boolean, " *************** package body Freeze is *** 2482,2495 **** and then (Convention (E) = Convention_C or else Convention (E) = Convention_CPP) - and then not Warnings_Off (E) - and then not Warnings_Off (R_Type) and then (Is_Imported (E) or else Is_Exported (E)) then -- Check suspicious return of fat C pointer if Is_Access_Type (R_Type) and then Esize (R_Type) > Ttypes.System_Address_Size then Error_Msg_N ("?return type of& does not " --- 2533,2546 ---- and then (Convention (E) = Convention_C or else Convention (E) = Convention_CPP) and then (Is_Imported (E) or else Is_Exported (E)) then -- Check suspicious return of fat C pointer if Is_Access_Type (R_Type) and then Esize (R_Type) > Ttypes.System_Address_Size + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) then Error_Msg_N ("?return type of& does not " *************** package body Freeze is *** 2499,2504 **** --- 2550,2558 ---- elsif Root_Type (R_Type) = Standard_Boolean and then Convention (R_Type) = Convention_Ada + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) + and then not Has_Size_Clause (R_Type) then Error_Msg_N ("?return type of & is an 8-bit " *************** package body Freeze is *** 2512,2517 **** --- 2566,2573 ---- Is_Tagged_Type (Designated_Type (R_Type)))) and then Convention (E) = Convention_C + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) then Error_Msg_N ("?return type of & does not " *************** package body Freeze is *** 2521,2526 **** --- 2577,2584 ---- elsif Ekind (R_Type) = E_Access_Subprogram_Type and then not Has_Foreign_Convention (R_Type) + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) then Error_Msg_N ("?& should return a foreign " *************** package body Freeze is *** 2537,2553 **** and then not Is_Imported (E) and then Has_Foreign_Convention (E) and then Warn_On_Export_Import then Error_Msg_N ("?foreign convention function& should not " & ! "return unconstrained array", E); -- Ada 2005 (AI-326): Check wrong use of tagged -- incomplete type ! -- -- type T is tagged; -- function F (X : Boolean) return T; -- ERROR elsif Ekind (Etype (E)) = E_Incomplete_Type and then Is_Tagged_Type (Etype (E)) and then No (Full_View (Etype (E))) --- 2595,2617 ---- and then not Is_Imported (E) and then Has_Foreign_Convention (E) and then Warn_On_Export_Import + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (Etype (E)) then Error_Msg_N ("?foreign convention function& should not " & ! "return unconstrained array!", E); -- Ada 2005 (AI-326): Check wrong use of tagged -- incomplete type ! -- type T is tagged; -- function F (X : Boolean) return T; -- ERROR + -- The type must be declared in the current scope for the + -- use to be legal, and the full view must be available + -- when the construct that mentions it is frozen. + elsif Ekind (Etype (E)) = E_Incomplete_Type and then Is_Tagged_Type (Etype (E)) and then No (Full_View (Etype (E))) *************** package body Freeze is *** 2555,2561 **** then Error_Msg_N ("(Ada 2005): invalid use of tagged incomplete type", ! E); end if; end if; end; --- 2619,2625 ---- then Error_Msg_N ("(Ada 2005): invalid use of tagged incomplete type", ! E); end if; end if; end; *************** package body Freeze is *** 2582,2591 **** -- Here for other than a subprogram or type else -- If entity has a type, and it is not a generic unit, then -- freeze it first (RM 13.14(10)). ! if Present (Etype (E)) and then Ekind (E) /= E_Generic_Function then Freeze_And_Append (Etype (E), Loc, Result); --- 2646,2674 ---- -- Here for other than a subprogram or type else + -- For a generic package, freeze types within, so that proper + -- cross-reference information is generated for tagged types. + -- This is the only freeze processing needed for generic packages. + + if Ekind (E) = E_Generic_Package then + declare + T : Entity_Id; + + begin + T := First_Entity (E); + while Present (T) loop + if Is_Type (T) then + Generate_Prim_Op_References (T); + end if; + + Next_Entity (T); + end loop; + end; + -- If entity has a type, and it is not a generic unit, then -- freeze it first (RM 13.14(10)). ! elsif Present (Etype (E)) and then Ekind (E) /= E_Generic_Function then Freeze_And_Append (Etype (E), Loc, Result); *************** package body Freeze is *** 2602,2611 **** Validate_Object_Declaration (Declaration_Node (E)); ! -- If there is an address clause, check it is valid Check_Address_Clause (E); -- For imported objects, set Is_Public unless there is also an -- address clause, which means that there is no external symbol -- needed for the Import (Is_Public may still be set for other --- 2685,2723 ---- Validate_Object_Declaration (Declaration_Node (E)); ! -- If there is an address clause, check that it is valid Check_Address_Clause (E); + -- If the object needs any kind of default initialization, an + -- error must be issued if No_Default_Initialization applies. + -- The check doesn't apply to imported objects, which are not + -- ever default initialized, and is why the check is deferred + -- until freezing, at which point we know if Import applies. + -- Deferred constants are also exempted from this test because + -- their completion is explicit, or through an import pragma. + + if Ekind (E) = E_Constant + and then Present (Full_View (E)) + then + null; + + elsif Comes_From_Source (E) + and then not Is_Imported (E) + and then not Has_Init_Expression (Declaration_Node (E)) + and then + ((Has_Non_Null_Base_Init_Proc (Etype (E)) + and then not No_Initialization (Declaration_Node (E)) + and then not Is_Value_Type (Etype (E)) + and then not Suppress_Init_Proc (Etype (E))) + or else + (Needs_Simple_Initialization (Etype (E)) + and then not Is_Internal (E))) + then + Check_Restriction + (No_Default_Initialization, Declaration_Node (E)); + end if; + -- For imported objects, set Is_Public unless there is also an -- address clause, which means that there is no external symbol -- needed for the Import (Is_Public may still be set for other *************** package body Freeze is *** 2889,2895 **** -- processing is only done for base types, since all the -- representation aspects involved are type-related. This -- is not just an optimization, if we start processing the ! -- subtypes, they intefere with the settings on the base -- type (this is because Is_Packed has a slightly different -- meaning before and after freezing). --- 3001,3007 ---- -- processing is only done for base types, since all the -- representation aspects involved are type-related. This -- is not just an optimization, if we start processing the ! -- subtypes, they interfere with the settings on the base -- type (this is because Is_Packed has a slightly different -- meaning before and after freezing). *************** package body Freeze is *** 3196,3202 **** Freeze_Record_Type (E); -- For a concurrent type, freeze corresponding record type. This ! -- does not correpond to any specific rule in the RM, but the -- record type is essentially part of the concurrent type. -- Freeze as well all local entities. This includes record types -- created for entry parameter blocks, and whatever local entities --- 3308,3314 ---- Freeze_Record_Type (E); -- For a concurrent type, freeze corresponding record type. This ! -- does not correspond to any specific rule in the RM, but the -- record type is essentially part of the concurrent type. -- Freeze as well all local entities. This includes record types -- created for entry parameter blocks, and whatever local entities *************** package body Freeze is *** 3490,3498 **** if Is_Pure_Unit_Access_Type (E) and then (Ada_Version < Ada_05 ! or else not No_Pool_Assigned (E)) then Error_Msg_N ("named access type not allowed in pure unit", E); end if; end if; --- 3602,3624 ---- if Is_Pure_Unit_Access_Type (E) and then (Ada_Version < Ada_05 ! or else not No_Pool_Assigned (E)) then Error_Msg_N ("named access type not allowed in pure unit", E); + + if Ada_Version >= Ada_05 then + Error_Msg_N + ("\would be legal if Storage_Size of 0 given?", E); + + elsif No_Pool_Assigned (E) then + Error_Msg_N + ("\would be legal in Ada 2005?", E); + + else + Error_Msg_N + ("\would be legal in Ada 2005 if " + & "Storage_Size of 0 given?", E); + end if; end if; end if; *************** package body Freeze is *** 3532,3597 **** end if; end if; ! -- Generate primitive operation references for a tagged type ! ! if Is_Tagged_Type (E) ! and then not Is_Class_Wide_Type (E) ! then ! declare ! Prim_List : Elist_Id; ! Prim : Elmt_Id; ! Ent : Entity_Id; ! Aux_E : Entity_Id; ! ! begin ! -- Handle subtypes ! ! if Ekind (E) = E_Protected_Subtype ! or else Ekind (E) = E_Task_Subtype ! then ! Aux_E := Etype (E); ! else ! Aux_E := E; ! end if; ! ! -- Ada 2005 (AI-345): In case of concurrent type generate ! -- reference to the wrapper that allow us to dispatch calls ! -- through their implemented abstract interface types. ! ! -- The check for Present here is to protect against previously ! -- reported critical errors. ! ! if Is_Concurrent_Type (Aux_E) ! and then Present (Corresponding_Record_Type (Aux_E)) ! then ! Prim_List := Primitive_Operations ! (Corresponding_Record_Type (Aux_E)); ! else ! Prim_List := Primitive_Operations (Aux_E); ! end if; ! ! -- Loop to generate references for primitive operations ! ! if Present (Prim_List) then ! Prim := First_Elmt (Prim_List); ! while Present (Prim) loop ! ! -- If the operation is derived, get the original for ! -- cross-reference purposes (it is the original for ! -- which we want the xref, and for which the comes ! -- from source test needs to be performed). ! ! Ent := Node (Prim); ! while Present (Alias (Ent)) loop ! Ent := Alias (Ent); ! end loop; ! Generate_Reference (E, Ent, 'p', Set_Ref => False); ! Next_Elmt (Prim); ! end loop; ! end if; ! end; ! end if; -- Now that all types from which E may depend are frozen, see if the -- size is known at compile time, if it must be unsigned, or if --- 3658,3666 ---- end if; end if; ! -- Generate references to primitive operations for a tagged type ! Generate_Prim_Op_References (E); -- Now that all types from which E may depend are frozen, see if the -- size is known at compile time, if it must be unsigned, or if *************** package body Freeze is *** 3610,3616 **** if Has_Size_Clause (E) and then not Size_Known_At_Compile_Time (E) then ! -- Supress this message if errors posted on E, even if we are -- in all errors mode, since this is often a junk message if not Error_Posted (E) then --- 3679,3685 ---- if Has_Size_Clause (E) and then not Size_Known_At_Compile_Time (E) then ! -- Suppress this message if errors posted on E, even if we are -- in all errors mode, since this is often a junk message if not Error_Posted (E) then *************** package body Freeze is *** 3766,3777 **** --- 3835,3870 ---- procedure Freeze_Enumeration_Type (Typ : Entity_Id) is begin + -- By default, if no size clause is present, an enumeration type with + -- Convention C is assumed to interface to a C enum, and has integer + -- size. This applies to types. For subtypes, verify that its base + -- type has no size clause either. + if Has_Foreign_Convention (Typ) and then not Has_Size_Clause (Typ) + and then not Has_Size_Clause (Base_Type (Typ)) and then Esize (Typ) < Standard_Integer_Size then Init_Esize (Typ, Standard_Integer_Size); + else + -- If the enumeration type interfaces to C, and it has a size clause + -- that specifies less than int size, it warrants a warning. The + -- user may intend the C type to be an enum or a char, so this is + -- not by itself an error that the Ada compiler can detect, but it + -- it is a worth a heads-up. For Boolean and Character types we + -- assume that the programmer has the proper C type in mind. + + if Convention (Typ) = Convention_C + and then Has_Size_Clause (Typ) + and then Esize (Typ) /= Esize (Standard_Integer) + and then not Is_Boolean_Type (Typ) + and then not Is_Character_Type (Typ) + then + Error_Msg_N + ("C enum types have the size of a C int?", Size_Clause (Typ)); + end if; + Adjust_Esize_For_Alignment (Typ); end if; end Freeze_Enumeration_Type; *************** package body Freeze is *** 3781,3792 **** ----------------------- procedure Freeze_Expression (N : Node_Id) is ! In_Def_Exp : constant Boolean := In_Default_Expression; ! Typ : Entity_Id; ! Nam : Entity_Id; ! Desig_Typ : Entity_Id; ! P : Node_Id; ! Parent_P : Node_Id; Freeze_Outside : Boolean := False; -- This flag is set true if the entity must be frozen outside the --- 3874,3885 ---- ----------------------- procedure Freeze_Expression (N : Node_Id) is ! In_Spec_Exp : constant Boolean := In_Spec_Expression; ! Typ : Entity_Id; ! Nam : Entity_Id; ! Desig_Typ : Entity_Id; ! P : Node_Id; ! Parent_P : Node_Id; Freeze_Outside : Boolean := False; -- This flag is set true if the entity must be frozen outside the *************** package body Freeze is *** 3857,3863 **** -- make sure that we actually have a real expression (if we have -- a subtype indication, we can't test Is_Static_Expression!) ! if In_Def_Exp and then Nkind (N) in N_Subexpr and then not Is_Static_Expression (N) then --- 3950,3956 ---- -- make sure that we actually have a real expression (if we have -- a subtype indication, we can't test Is_Static_Expression!) ! if In_Spec_Exp and then Nkind (N) in N_Subexpr and then not Is_Static_Expression (N) then *************** package body Freeze is *** 3989,3995 **** -- For either of these cases, we skip the freezing ! if not In_Default_Expression and then Nkind (N) = N_Identifier and then (Present (Entity (N))) then --- 4082,4088 ---- -- For either of these cases, we skip the freezing ! if not In_Spec_Expression and then Nkind (N) = N_Identifier and then (Present (Entity (N))) then *************** package body Freeze is *** 4021,4027 **** and then Is_Enumeration_Type (Etype (N)) then -- If enumeration literal appears directly as the choice, ! -- do not freeze (this is the normal non-overloade case) if Nkind (Parent (N)) = N_Component_Association and then First (Choices (Parent (N))) = N --- 4114,4120 ---- and then Is_Enumeration_Type (Etype (N)) then -- If enumeration literal appears directly as the choice, ! -- do not freeze (this is the normal non-overloaded case) if Nkind (Parent (N)) = N_Component_Association and then First (Choices (Parent (N))) = N *************** package body Freeze is *** 4176,4186 **** -- static type, and the freeze scope needs to be the outer scope, not -- the scope of the subprogram with the default parameter. ! -- For default expressions in generic units, the Move_Freeze_Nodes ! -- mechanism (see sem_ch12.adb) takes care of placing them at the proper ! -- place, after the generic unit. ! if (In_Def_Exp and not Inside_A_Generic) or else Freeze_Outside or else (Is_Type (Current_Scope) and then (not Is_Concurrent_Type (Current_Scope) --- 4269,4279 ---- -- static type, and the freeze scope needs to be the outer scope, not -- the scope of the subprogram with the default parameter. ! -- For default expressions and other spec expressions in generic units, ! -- the Move_Freeze_Nodes mechanism (see sem_ch12.adb) takes care of ! -- placing them at the proper place, after the generic unit. ! if (In_Spec_Exp and not Inside_A_Generic) or else Freeze_Outside or else (Is_Type (Current_Scope) and then (not Is_Concurrent_Type (Current_Scope) *************** package body Freeze is *** 4228,4242 **** end if; -- Now we have the right place to do the freezing. First, a special ! -- adjustment, if we are in default expression analysis mode, these ! -- freeze actions must not be thrown away (normally all inserted actions ! -- are thrown away in this mode. However, the freeze actions are from ! -- static expressions and one of the important reasons we are doing this -- special analysis is to get these freeze actions. Therefore we turn ! -- off the In_Default_Expression mode to propagate these freeze actions. -- This also means they get properly analyzed and expanded. ! In_Default_Expression := False; -- Freeze the designated type of an allocator (RM 13.14(13)) --- 4321,4335 ---- end if; -- Now we have the right place to do the freezing. First, a special ! -- adjustment, if we are in spec-expression analysis mode, these freeze ! -- actions must not be thrown away (normally all inserted actions are ! -- thrown away in this mode. However, the freeze actions are from static ! -- expressions and one of the important reasons we are doing this -- special analysis is to get these freeze actions. Therefore we turn ! -- off the In_Spec_Expression mode to propagate these freeze actions. -- This also means they get properly analyzed and expanded. ! In_Spec_Expression := False; -- Freeze the designated type of an allocator (RM 13.14(13)) *************** package body Freeze is *** 4257,4263 **** Freeze_Before (P, Nam); end if; ! In_Default_Expression := In_Def_Exp; end Freeze_Expression; ----------------------------- --- 4350,4358 ---- Freeze_Before (P, Nam); end if; ! -- Restore In_Spec_Expression flag ! ! In_Spec_Expression := In_Spec_Exp; end Freeze_Expression; ----------------------------- *************** package body Freeze is *** 4384,4390 **** -- case of both bounds negative, because the sign will be dealt -- with anyway. Furthermore we can't just go making such a bound -- symmetrical, since in a twos-complement system, there is an ! -- extra negative value which could not be accomodated on the -- positive side. if Typ = Btyp --- 4479,4485 ---- -- case of both bounds negative, because the sign will be dealt -- with anyway. Furthermore we can't just go making such a bound -- symmetrical, since in a twos-complement system, there is an ! -- extra negative value which could not be accommodated on the -- positive side. if Typ = Btyp *************** package body Freeze is *** 5054,5059 **** --- 5149,5167 ---- Error_Msg_N ("pragma Inline_Always not allowed for dispatching subprograms", E); end if; + + -- Because of the implicit representation of inherited predefined + -- operators in the front-end, the overriding status of the operation + -- may be affected when a full view of a type is analyzed, and this is + -- not captured by the analysis of the corresponding type declaration. + -- Therefore the correctness of a not-overriding indicator must be + -- rechecked when the subprogram is frozen. + + if Nkind (E) = N_Defining_Operator_Symbol + and then not Error_Posted (Parent (E)) + then + Check_Overriding_Indicator (E, Empty, Is_Primitive (E)); + end if; end Freeze_Subprogram; ---------------------- *************** package body Freeze is *** 5097,5102 **** --- 5205,5276 ---- end Is_Fully_Defined; --------------------------------- + -- Generate_Prim_Op_References -- + --------------------------------- + + procedure Generate_Prim_Op_References (Typ : Entity_Id) is + Base_T : Entity_Id; + Prim : Elmt_Id; + Prim_List : Elist_Id; + Ent : Entity_Id; + + begin + -- Handle subtypes of synchronized types + + if Ekind (Typ) = E_Protected_Subtype + or else Ekind (Typ) = E_Task_Subtype + then + Base_T := Etype (Typ); + else + Base_T := Typ; + end if; + + -- References to primitive operations are only relevant for tagged types + + if not Is_Tagged_Type (Base_T) + or else Is_Class_Wide_Type (Base_T) + then + return; + end if; + + -- Ada 2005 (AI-345): For synchronized types generate reference + -- to the wrapper that allow us to dispatch calls through their + -- implemented abstract interface types. + + -- The check for Present here is to protect against previously + -- reported critical errors. + + if Is_Concurrent_Type (Base_T) + and then Present (Corresponding_Record_Type (Base_T)) + then + Prim_List := Primitive_Operations + (Corresponding_Record_Type (Base_T)); + else + Prim_List := Primitive_Operations (Base_T); + end if; + + if No (Prim_List) then + return; + end if; + + Prim := First_Elmt (Prim_List); + while Present (Prim) loop + + -- If the operation is derived, get the original for cross-reference + -- reference purposes (it is the original for which we want the xref + -- and for which the comes_from_source test must be performed). + + Ent := Node (Prim); + while Present (Alias (Ent)) loop + Ent := Alias (Ent); + end loop; + + Generate_Reference (Typ, Ent, 'p', Set_Ref => False); + Next_Elmt (Prim); + end loop; + end Generate_Prim_Op_References; + + --------------------------------- -- Process_Default_Expressions -- --------------------------------- *************** package body Freeze is *** 5233,5239 **** Next_Formal (Formal); end loop; - end Process_Default_Expressions; ---------------------------------------- --- 5407,5412 ---- *************** package body Freeze is *** 5266,5330 **** end if; end Set_Component_Alignment_If_Not_Set; - --------------------------- - -- Set_Debug_Info_Needed -- - --------------------------- - - procedure Set_Debug_Info_Needed (T : Entity_Id) is - begin - if No (T) - or else Needs_Debug_Info (T) - or else Debug_Info_Off (T) - then - return; - else - Set_Needs_Debug_Info (T); - end if; - - if Is_Object (T) then - Set_Debug_Info_Needed (Etype (T)); - - elsif Is_Type (T) then - Set_Debug_Info_Needed (Etype (T)); - - if Is_Record_Type (T) then - declare - Ent : Entity_Id := First_Entity (T); - begin - while Present (Ent) loop - Set_Debug_Info_Needed (Ent); - Next_Entity (Ent); - end loop; - end; - - elsif Is_Array_Type (T) then - Set_Debug_Info_Needed (Component_Type (T)); - - declare - Indx : Node_Id := First_Index (T); - begin - while Present (Indx) loop - Set_Debug_Info_Needed (Etype (Indx)); - Indx := Next_Index (Indx); - end loop; - end; - - if Is_Packed (T) then - Set_Debug_Info_Needed (Packed_Array_Type (T)); - end if; - - elsif Is_Access_Type (T) then - Set_Debug_Info_Needed (Directly_Designated_Type (T)); - - elsif Is_Private_Type (T) then - Set_Debug_Info_Needed (Full_View (T)); - - elsif Is_Protected_Type (T) then - Set_Debug_Info_Needed (Corresponding_Record_Type (T)); - end if; - end if; - end Set_Debug_Info_Needed; - ------------------ -- Undelay_Type -- ------------------ --- 5439,5444 ---- *************** package body Freeze is *** 5439,5445 **** if Present (Decl) and then Nkind (Decl) = N_Pragma ! and then Chars (Decl) = Name_Import then return; end if; --- 5553,5559 ---- if Present (Decl) and then Nkind (Decl) = N_Pragma ! and then Pragma_Name (Decl) = Name_Import then return; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/freeze.ads gcc-4.4.0/gcc/ada/freeze.ads *** gcc-4.3.3/gcc/ada/freeze.ads Tue Aug 14 08:39:20 2007 --- gcc-4.4.0/gcc/ada/freeze.ads Thu Apr 9 23:23:07 2009 *************** *** 6,23 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,23 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- ! -- -- ! -- You should have received a copy of the GNU General Public License along -- ! -- with this program; see file COPYING3. If not see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Freeze is *** 178,184 **** procedure Expand_Atomic_Aggregate (E : Entity_Id; Typ : Entity_Id); -- If an atomic object is initialized with an aggregate or is assigned -- an aggregate, we have to prevent a piecemeal access or assignment ! -- to the object, even if the aggregate is to be expanded. we create -- a temporary for the aggregate, and assign the temporary instead, -- so that the back end can generate an atomic move for it. --- 178,184 ---- procedure Expand_Atomic_Aggregate (E : Entity_Id; Typ : Entity_Id); -- If an atomic object is initialized with an aggregate or is assigned -- an aggregate, we have to prevent a piecemeal access or assignment ! -- to the object, even if the aggregate is to be expanded. We create -- a temporary for the aggregate, and assign the temporary instead, -- so that the back end can generate an atomic move for it. diff -Nrcpad gcc-4.3.3/gcc/ada/frontend.adb gcc-4.4.0/gcc/ada/frontend.adb *** gcc-4.3.3/gcc/ada/frontend.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/frontend.adb Tue Apr 8 06:45:25 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Rtsfind; *** 47,52 **** --- 47,53 ---- with Sprint; with Scn; use Scn; with Sem; use Sem; + with Sem_Aux; with Sem_Ch8; use Sem_Ch8; with Sem_Elab; use Sem_Elab; with Sem_Prag; use Sem_Prag; *************** with Tbuild; use Tbuild; *** 59,66 **** with Types; use Types; procedure Frontend is ! Config_Pragmas : List_Id; ! -- Gather configuration pragmas begin -- Carry out package initializations. These are initializations which --- 60,67 ---- with Types; use Types; procedure Frontend is ! Config_Pragmas : List_Id; ! -- Gather configuration pragmas begin -- Carry out package initializations. These are initializations which *************** begin *** 75,83 **** --- 76,87 ---- Nlists.Initialize; Elists.Initialize; Lib.Load.Initialize; + Sem_Aux.Initialize; Sem_Ch8.Initialize; + Sem_Prag.Initialize; Fname.UF.Initialize; Checks.Initialize; + Sem_Warn.Initialize; -- Create package Standard *************** begin *** 102,108 **** end if; -- Now that the preprocessing situation is established, we are able to ! -- load the main source (this is no longer done by Lib.Load.Initalize). Lib.Load.Load_Main_Source; --- 106,112 ---- end if; -- Now that the preprocessing situation is established, we are able to ! -- load the main source (this is no longer done by Lib.Load.Initialize). Lib.Load.Load_Main_Source; *************** begin *** 207,212 **** --- 211,224 ---- Fmap.Initialize (Mapping_File_Name.all); end if; + -- Adjust Optimize_Alignment mode from debug switches if necessary + + if Debug_Flag_Dot_SS then + Optimize_Alignment := 'S'; + elsif Debug_Flag_Dot_TT then + Optimize_Alignment := 'T'; + end if; + -- We have now processed the command line switches, and the gnat.adc -- file, so this is the point at which we want to capture the values -- of the configuration switches (see Opt for further details). *************** begin *** 326,331 **** --- 338,344 ---- Sem_Warn.Output_Non_Modifed_In_Out_Warnings; Sem_Warn.Output_Unreferenced_Messages; Sem_Warn.Check_Unused_Withs; + Sem_Warn.Output_Unused_Warnings_Off_Warnings; end if; end if; *************** begin *** 345,351 **** Sprint.Source_Dump; -- If a mapping file has been specified by a -gnatem switch, update ! -- it if there has been some sourcs that were not in the mappings. if Mapping_File_Name /= null then Fmap.Update_Mapping_File (Mapping_File_Name.all); --- 358,364 ---- Sprint.Source_Dump; -- If a mapping file has been specified by a -gnatem switch, update ! -- it if there has been some sources that were not in the mappings. if Mapping_File_Name /= null then Fmap.Update_Mapping_File (Mapping_File_Name.all); diff -Nrcpad gcc-4.3.3/gcc/ada/g-allein.ads gcc-4.4.0/gcc/ada/g-allein.ads *** gcc-4.3.3/gcc/ada/g-allein.ads Fri Dec 9 17:10:03 2005 --- gcc-4.4.0/gcc/ada/g-allein.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-alleve.adb gcc-4.4.0/gcc/ada/g-alleve.adb *** gcc-4.3.3/gcc/ada/g-alleve.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/g-alleve.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (Soft Binding Version) -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- B o d y -- -- (Soft Binding Version) -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body GNAT.Altivec.Low_Level_Vect *** 1864,1870 **** function To_Pixel (Source : unsigned_short) return Pixel_16 is ! -- This conversion should not depend on the host endianess; -- therefore, we cannot use an unchecked conversion. Target : Pixel_16; --- 1862,1868 ---- function To_Pixel (Source : unsigned_short) return Pixel_16 is ! -- This conversion should not depend on the host endianness; -- therefore, we cannot use an unchecked conversion. Target : Pixel_16; *************** package body GNAT.Altivec.Low_Level_Vect *** 1879,1885 **** function To_Pixel (Source : unsigned_int) return Pixel_32 is ! -- This conversion should not depend on the host endianess; -- therefore, we cannot use an unchecked conversion. Target : Pixel_32; --- 1877,1883 ---- function To_Pixel (Source : unsigned_int) return Pixel_32 is ! -- This conversion should not depend on the host endianness; -- therefore, we cannot use an unchecked conversion. Target : Pixel_32; *************** package body GNAT.Altivec.Low_Level_Vect *** 1898,1907 **** function To_unsigned_int (Source : Pixel_32) return unsigned_int is ! -- This conversion should not depend on the host endianess; -- therefore, we cannot use an unchecked conversion. -- It should also be the same result, value-wise, on two hosts ! -- with the same endianess. Target : unsigned_int := 0; --- 1896,1905 ---- function To_unsigned_int (Source : Pixel_32) return unsigned_int is ! -- This conversion should not depend on the host endianness; -- therefore, we cannot use an unchecked conversion. -- It should also be the same result, value-wise, on two hosts ! -- with the same endianness. Target : unsigned_int := 0; *************** package body GNAT.Altivec.Low_Level_Vect *** 1930,1939 **** function To_unsigned_short (Source : Pixel_16) return unsigned_short is ! -- This conversion should not depend on the host endianess; -- therefore, we cannot use an unchecked conversion. -- It should also be the same result, value-wise, on two hosts ! -- with the same endianess. Target : unsigned_short := 0; --- 1928,1937 ---- function To_unsigned_short (Source : Pixel_16) return unsigned_short is ! -- This conversion should not depend on the host endianness; -- therefore, we cannot use an unchecked conversion. -- It should also be the same result, value-wise, on two hosts ! -- with the same endianness. Target : unsigned_short := 0; *************** package body GNAT.Altivec.Low_Level_Vect *** 2765,2773 **** -- ??? Check the precision of the operation. -- As described in [PEM-6 vexptefp]: ! -- If theorical_result is equal to 2 at the power of A (J) with -- infinite precision, we should have: ! -- abs ((D (J) - theorical_result) / theorical_result) <= 1/16 D.Values (J) := 2.0 ** NJ_Truncate (VA.Values (J)); end loop; --- 2763,2771 ---- -- ??? Check the precision of the operation. -- As described in [PEM-6 vexptefp]: ! -- If theoretical_result is equal to 2 at the power of A (J) with -- infinite precision, we should have: ! -- abs ((D (J) - theoretical_result) / theoretical_result) <= 1/16 D.Values (J) := 2.0 ** NJ_Truncate (VA.Values (J)); end loop; diff -Nrcpad gcc-4.3.3/gcc/ada/g-alleve.ads gcc-4.4.0/gcc/ada/g-alleve.ads *** gcc-4.3.3/gcc/ada/g-alleve.ads Fri Apr 6 09:21:48 2007 --- gcc-4.4.0/gcc/ada/g-alleve.ads Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- S p e c -- -- (Soft Binding Version) -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- S p e c -- -- (Soft Binding Version) -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-altcon.adb gcc-4.4.0/gcc/ada/g-altcon.adb *** gcc-4.3.3/gcc/ada/g-altcon.adb Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/g-altcon.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** with System; use System; *** 37,43 **** package body GNAT.Altivec.Conversions is ! -- All the vector/view conversions operate similarily: bare unchecked -- conversion on big endian targets, and elements permutation on little -- endian targets. We call "Mirroring" the elements permutation process. --- 35,41 ---- package body GNAT.Altivec.Conversions is ! -- All the vector/view conversions operate similarly: bare unchecked -- conversion on big endian targets, and elements permutation on little -- endian targets. We call "Mirroring" the elements permutation process. diff -Nrcpad gcc-4.3.3/gcc/ada/g-altcon.ads gcc-4.4.0/gcc/ada/g-altcon.ads *** gcc-4.3.3/gcc/ada/g-altcon.ads Fri Dec 9 17:10:03 2005 --- gcc-4.4.0/gcc/ada/g-altcon.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-altive.ads gcc-4.4.0/gcc/ada/g-altive.ads *** gcc-4.3.3/gcc/ada/g-altive.ads Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/g-altive.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 135,141 **** -- of driving ideas: -- o From the clients standpoint, the two versions of the binding should be ! -- as easily exchangable as possible, -- o From the maintenance standpoint, we want to avoid as much code -- duplication as possible. --- 133,139 ---- -- of driving ideas: -- o From the clients standpoint, the two versions of the binding should be ! -- as easily exchangeable as possible, -- o From the maintenance standpoint, we want to avoid as much code -- duplication as possible. *************** package GNAT.Altivec is *** 345,351 **** -- support of the target. Note that this means that there may be -- minor differences in results between targets when the floating- -- point implementations are slightly different, as would happen ! -- with normal non-altivec floating-point operations. In particular -- the Altivec simulations may yield slightly different results -- from those obtained on a true hardware Altivec target if the -- floating-point implementation is not 100% compatible. --- 343,349 ---- -- support of the target. Note that this means that there may be -- minor differences in results between targets when the floating- -- point implementations are slightly different, as would happen ! -- with normal non-Altivec floating-point operations. In particular -- the Altivec simulations may yield slightly different results -- from those obtained on a true hardware Altivec target if the -- floating-point implementation is not 100% compatible. diff -Nrcpad gcc-4.3.3/gcc/ada/g-alveop.adb gcc-4.4.0/gcc/ada/g-alveop.adb *** gcc-4.3.3/gcc/ada/g-alveop.adb Fri Dec 9 17:10:03 2005 --- gcc-4.4.0/gcc/ada/g-alveop.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-alveop.ads gcc-4.4.0/gcc/ada/g-alveop.ads *** gcc-4.3.3/gcc/ada/g-alveop.ads Fri Dec 9 17:10:03 2005 --- gcc-4.4.0/gcc/ada/g-alveop.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package GNAT.Altivec.Vector_Operations i *** 43,49 **** -- much smaller set of low level primitives with type conversions around. -- -- In some cases, a direct binding without any intermediate body is ! -- possible or even even mandatory for technical reasons. What we provide -- here for such cases are renamings of straight imports exposed by -- Altivec.Low_Level_Interface. See the comments in the private part for -- additional details. --- 41,47 ---- -- much smaller set of low level primitives with type conversions around. -- -- In some cases, a direct binding without any intermediate body is ! -- possible or even mandatory for technical reasons. What we provide -- here for such cases are renamings of straight imports exposed by -- Altivec.Low_Level_Interface. See the comments in the private part for -- additional details. *************** private *** 8097,8103 **** pragma Inline_Always (vec_any_numeric); pragma Inline_Always (vec_any_out); ! -- Similarily, vec_step is expected to be turned into a compile time -- constant, so ... pragma Inline_Always (vec_step); --- 8095,8101 ---- pragma Inline_Always (vec_any_numeric); pragma Inline_Always (vec_any_out); ! -- Similarly, vec_step is expected to be turned into a compile time -- constant, so ... pragma Inline_Always (vec_step); diff -Nrcpad gcc-4.3.3/gcc/ada/g-alvety.ads gcc-4.4.0/gcc/ada/g-alvety.ads *** gcc-4.3.3/gcc/ada/g-alvety.ads Fri Dec 9 17:10:03 2005 --- gcc-4.4.0/gcc/ada/g-alvety.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-alvevi.ads gcc-4.4.0/gcc/ada/g-alvevi.ads *** gcc-4.3.3/gcc/ada/g-alvevi.ads Fri Dec 9 17:10:03 2005 --- gcc-4.4.0/gcc/ada/g-alvevi.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- ! -- MA 02111-1307, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 38,44 **** -- Accessing vector contents with direct memory overlays should be avoided -- because actual vector representations may vary across configurations, for ! -- instance to accomodate different target endianness. -- The natural representation of a vector is an array indexed by vector -- component number, which is materialized by the Varray type definitions --- 36,42 ---- -- Accessing vector contents with direct memory overlays should be avoided -- because actual vector representations may vary across configurations, for ! -- instance to accommodate different target endianness. -- The natural representation of a vector is an array indexed by vector -- component number, which is materialized by the Varray type definitions diff -Nrcpad gcc-4.3.3/gcc/ada/g-arrspl.adb gcc-4.4.0/gcc/ada/g-arrspl.adb *** gcc-4.3.3/gcc/ada/g-arrspl.adb Fri Apr 6 09:21:59 2007 --- gcc-4.4.0/gcc/ada/g-arrspl.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body GNAT.Array_Split is *** 47,54 **** function Count (Source : Element_Sequence; Pattern : Element_Set) return Natural; ! -- Returns the number of occurences of Pattern elements in Source, 0 is ! -- returned if no occurence is found in Source. ------------ -- Adjust -- --- 45,52 ---- function Count (Source : Element_Sequence; Pattern : Element_Set) return Natural; ! -- Returns the number of occurrences of Pattern elements in Source, 0 is ! -- returned if no occurrence is found in Source. ------------ -- Adjust -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-arrspl.ads gcc-4.4.0/gcc/ada/g-arrspl.ads *** gcc-4.3.3/gcc/ada/g-arrspl.ads Tue Oct 31 18:14:24 2006 --- gcc-4.4.0/gcc/ada/g-arrspl.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-awk.adb gcc-4.4.0/gcc/ada/g-awk.adb *** gcc-4.3.3/gcc/ada/g-awk.adb Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/g-awk.adb Wed Aug 6 08:32:32 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2008, AdaCore -- -- -- -- 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- -- *************** pragma Ada_95; *** 36,45 **** -- Default_Session (see below) do not work when compiling clients of this -- package that instantiate generic units herein. - pragma Style_Checks (All_Checks); - -- Turn off alpha ordering check for subprograms, since we cannot - -- Put Finalize and Initialize in alpha order (see comments). - with Ada.Exceptions; with Ada.Text_IO; with Ada.Strings.Unbounded; --- 36,41 ---- *************** package body GNAT.AWK is *** 56,61 **** --- 52,69 ---- use Ada; use Ada.Strings.Unbounded; + ----------------------- + -- Local subprograms -- + ----------------------- + + -- The following two subprograms provide a functional interface to the + -- two special session variables, that are manipulated explicitly by + -- Finalize, but must be declared after Finalize to prevent static + -- elaboration warnings. + + function Get_Def return Session_Data_Access; + procedure Set_Cur; + ---------------- -- Split mode -- ---------------- *************** package body GNAT.AWK is *** 277,282 **** --- 285,308 ---- procedure Free is new Unchecked_Deallocation (Session_Data, Session_Data_Access); + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Session : in out Session_Type) is + begin + -- We release the session data only if it is not the default session + + if Session.Data /= Get_Def then + Free (Session.Data); + + -- Since we have closed the current session, set it to point now to + -- the default session. + + Set_Cur; + end if; + end Finalize; + ---------------- -- Initialize -- ---------------- *************** package body GNAT.AWK is *** 301,334 **** -- Session Variables -- ----------------------- - -- These must come after the body of Initialize, since they make - -- implicit calls to Initialize at elaboration time. - Def_Session : Session_Type; Cur_Session : Session_Type; - -------------- - -- Finalize -- - -------------- - - -- Note: Finalize must come after Initialize and the definition - -- of the Def_Session and Cur_Session variables, since it references - -- the latter. - - procedure Finalize (Session : in out Session_Type) is - begin - -- We release the session data only if it is not the default session - - if Session.Data /= Def_Session.Data then - Free (Session.Data); - - -- Since we have closed the current session, set it to point now to - -- the default session. - - Cur_Session.Data := Def_Session.Data; - end if; - end Finalize; - ---------------------- -- Private Services -- ---------------------- --- 327,335 ---- *************** package body GNAT.AWK is *** 644,650 **** when others => Raise_With_Info (File_Error'Identity, ! "Error scaning directory " & Directory & " for files " & Filenames & '.', Session); end Add_Files; --- 645,651 ---- when others => Raise_With_Info (File_Error'Identity, ! "Error scanning directory " & Directory & " for files " & Filenames & '.', Session); end Add_Files; *************** package body GNAT.AWK is *** 1480,1485 **** --- 1481,1504 ---- Split.Current_Line (Session.Data.Separators.all, Session); end Split_Line; + ------------- + -- Get_Def -- + ------------- + + function Get_Def return Session_Data_Access is + begin + return Def_Session.Data; + end Get_Def; + + ------------- + -- Set_Cur -- + ------------- + + procedure Set_Cur is + begin + Cur_Session.Data := Def_Session.Data; + end Set_Cur; + begin -- We have declared two sessions but both should share the same data. -- The current session must point to the default session as its initial diff -Nrcpad gcc-4.3.3/gcc/ada/g-busorg.ads gcc-4.4.0/gcc/ada/g-busorg.ads *** gcc-4.3.3/gcc/ada/g-busorg.ads Wed Jun 6 10:28:31 2007 --- gcc-4.4.0/gcc/ada/g-busorg.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2006, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- 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,49 **** -- There is also GNAT.Bubble_Sort_A, which is now considered obsolete, but -- was an older version working with subprogram parameters. This version ! -- is retained for baccwards compatibility with old versions of GNAT. generic -- The data to be sorted is assumed to be indexed by integer values from --- 43,49 ---- -- There is also GNAT.Bubble_Sort_A, which is now considered obsolete, but -- was an older version working with subprogram parameters. This version ! -- is retained for backwards compatibility with old versions of GNAT. generic -- The data to be sorted is assumed to be indexed by integer values from diff -Nrcpad gcc-4.3.3/gcc/ada/g-byorma.adb gcc-4.4.0/gcc/ada/g-byorma.adb *** gcc-4.3.3/gcc/ada/g-byorma.adb Thu Dec 13 10:29:24 2007 --- gcc-4.4.0/gcc/ada/g-byorma.adb Tue May 20 12:52:53 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Byte_Order_Mark is *** 44,70 **** XML_Support : Boolean := False) is begin ! -- UTF-16 (big-endian) ! ! if Str'Length >= 2 ! and then Str (Str'First) = Character'Val (16#FE#) ! and then Str (Str'First + 1) = Character'Val (16#FF#) ! then ! Len := 2; ! BOM := UTF16_BE; ! ! -- UTF-16 (little-endian) ! ! elsif Str'Length >= 2 ! and then Str (Str'First) = Character'Val (16#FF#) ! and then Str (Str'First + 1) = Character'Val (16#FE#) ! then ! Len := 2; ! BOM := UTF16_LE; -- UTF-32 (big-endian) ! elsif Str'Length >= 4 and then Str (Str'First) = Character'Val (16#00#) and then Str (Str'First + 1) = Character'Val (16#00#) and then Str (Str'First + 2) = Character'Val (16#FE#) --- 44,56 ---- XML_Support : Boolean := False) is begin ! -- Note: the order of these tests is important, because in some cases ! -- one sequence is a prefix of a longer sequence, and we must test for ! -- the longer sequence first -- UTF-32 (big-endian) ! if Str'Length >= 4 and then Str (Str'First) = Character'Val (16#00#) and then Str (Str'First + 1) = Character'Val (16#00#) and then Str (Str'First + 2) = Character'Val (16#FE#) *************** package body GNAT.Byte_Order_Mark is *** 84,89 **** --- 70,93 ---- Len := 4; BOM := UTF32_LE; + -- UTF-16 (big-endian) + + elsif Str'Length >= 2 + and then Str (Str'First) = Character'Val (16#FE#) + and then Str (Str'First + 1) = Character'Val (16#FF#) + then + Len := 2; + BOM := UTF16_BE; + + -- UTF-16 (little-endian) + + elsif Str'Length >= 2 + and then Str (Str'First) = Character'Val (16#FF#) + and then Str (Str'First + 1) = Character'Val (16#FE#) + then + Len := 2; + BOM := UTF16_LE; + -- UTF-8 (endian-independent) elsif Str'Length >= 3 *************** package body GNAT.Byte_Order_Mark is *** 175,181 **** and then Str (Str'First + 2) = Character'Val (16#78#) and then Str (Str'First + 3) = Character'Val (16#6D#) then ! -- Utf8, ASCII, some part of ISO8859, Shift-JIS, EUC,... Len := 0; BOM := Unknown; --- 179,185 ---- and then Str (Str'First + 2) = Character'Val (16#78#) and then Str (Str'First + 3) = Character'Val (16#6D#) then ! -- UTF-8, ASCII, some part of ISO8859, Shift-JIS, EUC,... Len := 0; BOM := Unknown; diff -Nrcpad gcc-4.3.3/gcc/ada/g-calend.adb gcc-4.4.0/gcc/ada/g-calend.adb *** gcc-4.3.3/gcc/ada/g-calend.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/g-calend.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Calendar is *** 307,313 **** pragma Unreferenced (Hour, Minute, Second, Sub_Second); function Is_Leap (Year : Year_Number) return Boolean; ! -- Return True if Year denotes a leap year. Leap centential years are -- properly handled. function Jan_1_Day_Of_Week --- 307,313 ---- pragma Unreferenced (Hour, Minute, Second, Sub_Second); function Is_Leap (Year : Year_Number) return Boolean; ! -- Return True if Year denotes a leap year. Leap centennial years are -- properly handled. function Jan_1_Day_Of_Week diff -Nrcpad gcc-4.3.3/gcc/ada/g-calend.ads gcc-4.4.0/gcc/ada/g-calend.ads *** gcc-4.3.3/gcc/ada/g-calend.ads Thu Dec 13 10:27:07 2007 --- gcc-4.4.0/gcc/ada/g-calend.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 39,45 **** -- Ada.Calendar. It provides Split and Time_Of to build and split a Time -- data. And it provides accessor functions to get only one of Hour, Minute, -- Second, Second_Duration. Other functions are to access more advanced ! -- valueas like Day_Of_Week, Day_In_Year and Week_In_Year. with Ada.Calendar; with Interfaces.C; --- 37,43 ---- -- Ada.Calendar. It provides Split and Time_Of to build and split a Time -- data. And it provides accessor functions to get only one of Hour, Minute, -- Second, Second_Duration. Other functions are to access more advanced ! -- values like Day_Of_Week, Day_In_Year and Week_In_Year. with Ada.Calendar; with Interfaces.C; *************** package GNAT.Calendar is *** 64,70 **** function Minute (Date : Ada.Calendar.Time) return Minute_Number; function Second (Date : Ada.Calendar.Time) return Second_Number; function Sub_Second (Date : Ada.Calendar.Time) return Second_Duration; ! -- Hour, Minute, Sedond and Sub_Second returns the complete time data for -- the Date (H:M:S.SS). See Ada.Calendar for Year, Month, Day accessors. -- Second_Duration precision depends on the target clock precision. --- 62,68 ---- function Minute (Date : Ada.Calendar.Time) return Minute_Number; function Second (Date : Ada.Calendar.Time) return Second_Number; function Sub_Second (Date : Ada.Calendar.Time) return Second_Duration; ! -- Hour, Minute, Second and Sub_Second returns the complete time data for -- the Date (H:M:S.SS). See Ada.Calendar for Year, Month, Day accessors. -- Second_Duration precision depends on the target clock precision. diff -Nrcpad gcc-4.3.3/gcc/ada/g-casuti.ads gcc-4.4.0/gcc/ada/g-casuti.ads *** gcc-4.3.3/gcc/ada/g-casuti.ads Mon Sep 5 08:07:00 2005 --- gcc-4.4.0/gcc/ada/g-casuti.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- 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- -- *************** package GNAT.Case_Util is *** 59,65 **** procedure To_Upper (A : in out String) renames System.Case_Util.To_Upper; ! -- Folds all characters of string A to upper csae function To_Lower (A : Character) return Character renames System.Case_Util.To_Lower; --- 59,65 ---- procedure To_Upper (A : in out String) renames System.Case_Util.To_Upper; ! -- Folds all characters of string A to upper case function To_Lower (A : Character) return Character renames System.Case_Util.To_Lower; diff -Nrcpad gcc-4.3.3/gcc/ada/g-catiio.adb gcc-4.4.0/gcc/ada/g-catiio.adb *** gcc-4.3.3/gcc/ada/g-catiio.adb Thu Dec 13 10:27:07 2007 --- gcc-4.4.0/gcc/ada/g-catiio.adb Fri Aug 22 08:54:14 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Calendar.Time_IO is *** 536,542 **** constant array (Ada.Calendar.Month_Number) of String3 := ("JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC"); ! -- Short version of the month names, used when parsing date strings. S : String := Str; --- 536,542 ---- constant array (Ada.Calendar.Month_Number) of String3 := ("JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC"); ! -- Short version of the month names, used when parsing date strings S : String := Str; *************** package body GNAT.Calendar.Time_IO is *** 560,572 **** D : String (1 .. 21); D_Length : constant Natural := Date'Length; ! Year : Year_Number; ! Month : Month_Number; ! Day : Day_Number; ! Hour : Hour_Number; ! Minute : Minute_Number; ! Second : Second_Number; ! Sub_Second : Second_Duration; procedure Extract_Date (Year : out Year_Number; --- 560,571 ---- D : String (1 .. 21); D_Length : constant Natural := Date'Length; ! Year : Year_Number; ! Month : Month_Number; ! Day : Day_Number; ! Hour : Hour_Number; ! Minute : Minute_Number; ! Second : Second_Number; procedure Extract_Date (Year : out Year_Number; *************** package body GNAT.Calendar.Time_IO is *** 770,778 **** -- Start of processing for Value begin - Split (Clock, Year, Month, Day, Hour, Minute, Second, Sub_Second); - Sub_Second := 0.0; - -- Length checks if D_Length /= 8 --- 769,774 ---- *************** package body GNAT.Calendar.Time_IO is *** 792,803 **** D (1 .. D_Length) := Date; ! if D_Length /= 8 ! or else D (3) /= ':' ! then Extract_Date (Year, Month, Day, Time_Start); Extract_Time (Time_Start, Hour, Minute, Second, Check_Space => True); else Extract_Time (1, Hour, Minute, Second, Check_Space => False); end if; --- 788,806 ---- D (1 .. D_Length) := Date; ! if D_Length /= 8 or else D (3) /= ':' then Extract_Date (Year, Month, Day, Time_Start); Extract_Time (Time_Start, Hour, Minute, Second, Check_Space => True); + else + declare + Discard : Second_Duration; + pragma Unreferenced (Discard); + begin + Split (Clock, Year, Month, Day, Hour, Minute, Second, + Sub_Second => Discard); + end; + Extract_Time (1, Hour, Minute, Second, Check_Space => False); end if; *************** package body GNAT.Calendar.Time_IO is *** 813,829 **** raise Constraint_Error; end if; ! return Time_Of (Year, Month, Day, Hour, Minute, Second, Sub_Second); end Value; -------------- -- Put_Time -- -------------- ! procedure Put_Time ! (Date : Ada.Calendar.Time; ! Picture : Picture_String) ! is begin Ada.Text_IO.Put (Image (Date, Picture)); end Put_Time; --- 816,829 ---- raise Constraint_Error; end if; ! return Time_Of (Year, Month, Day, Hour, Minute, Second); end Value; -------------- -- Put_Time -- -------------- ! procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String) is begin Ada.Text_IO.Put (Image (Date, Picture)); end Put_Time; diff -Nrcpad gcc-4.3.3/gcc/ada/g-catiio.ads gcc-4.4.0/gcc/ada/g-catiio.ads *** gcc-4.3.3/gcc/ada/g-catiio.ads Thu Dec 13 10:27:07 2007 --- gcc-4.4.0/gcc/ada/g-catiio.ads Wed Aug 20 16:12:38 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- 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- -- *************** package GNAT.Calendar.Time_IO is *** 125,136 **** -- The following formats are also supported. They all accept an optional -- time with the format "hh:mm:ss". The time is separated from the date by -- exactly one space character. -- When the time is not specified, it is set to 00:00:00. The delimiter '*' -- must be either '-' and '/' and both occurrences must use the same -- character. - -- Trailing characters (in particular spaces) are not allowed. -- ! -- yyyy*mm*dd -- yy*mm*dd - Year is assumed to be 20yy -- mm*dd*yyyy - (US date format) -- dd*mmm*yyyy - month spelled out --- 125,138 ---- -- The following formats are also supported. They all accept an optional -- time with the format "hh:mm:ss". The time is separated from the date by -- exactly one space character. + -- -- When the time is not specified, it is set to 00:00:00. The delimiter '*' -- must be either '-' and '/' and both occurrences must use the same -- character. -- ! -- Trailing characters (in particular spaces) are not allowed ! -- ! -- yyyy*mm*dd - ISO format -- yy*mm*dd - Year is assumed to be 20yy -- mm*dd*yyyy - (US date format) -- dd*mmm*yyyy - month spelled out *************** package GNAT.Calendar.Time_IO is *** 139,152 **** -- mmm dd, yyyy - month spelled out -- dd mmm yyyy - month spelled out -- ! -- Constraint_Error is raised if the input string is malformatted or -- the resulting time is not valid. ! procedure Put_Time ! (Date : Ada.Calendar.Time; ! Picture : Picture_String); ! -- Put Date with format Picture. Raise Picture_Error if picture string is ! -- wrong private ISO_Date : constant Picture_String := "%Y-%m-%d"; --- 141,152 ---- -- mmm dd, yyyy - month spelled out -- dd mmm yyyy - month spelled out -- ! -- Constraint_Error is raised if the input string is malformed (does not ! -- conform to one of the above dates, or has an invalid time string), or -- the resulting time is not valid. ! procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String); ! -- Put Date with format Picture. Raise Picture_Error if bad picture string private ISO_Date : constant Picture_String := "%Y-%m-%d"; diff -Nrcpad gcc-4.3.3/gcc/ada/g-cgideb.adb gcc-4.4.0/gcc/ada/g-cgideb.adb *** gcc-4.3.3/gcc/ada/g-cgideb.adb Wed Jun 6 10:52:32 2007 --- gcc-4.4.0/gcc/ada/g-cgideb.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.CGI.Debug is *** 41,47 **** -- To create a new IO mode you must: -- 1. create a new package spec -- 2. create a new type derived from IO.Format ! -- 3. implement all the abstract rountines in IO package IO is --- 41,47 ---- -- To create a new IO mode you must: -- 1. create a new package spec -- 2. create a new type derived from IO.Format ! -- 3. implement all the abstract routines in IO package IO is diff -Nrcpad gcc-4.3.3/gcc/ada/g-comlin.adb gcc-4.4.0/gcc/ada/g-comlin.adb *** gcc-4.3.3/gcc/ada/g-comlin.adb Thu Dec 13 10:23:29 2007 --- gcc-4.4.0/gcc/ada/g-comlin.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 32,38 **** ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; ! with GNAT.OS_Lib; use GNAT.OS_Lib; package body GNAT.Command_Line is --- 30,38 ---- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; ! with Ada.Strings.Unbounded; ! ! with GNAT.OS_Lib; use GNAT.OS_Lib; package body GNAT.Command_Line is *************** package body GNAT.Command_Line is *** 43,49 **** Parameter_With_Optional_Space, -- ':' in getopt Parameter_With_Space_Or_Equal, -- '=' in getopt Parameter_No_Space, -- '!' in getopt ! Parameter_Optional); -- '?' in getop procedure Set_Parameter (Variable : out Parameter_Type; --- 43,49 ---- Parameter_With_Optional_Space, -- ':' in getopt Parameter_With_Space_Or_Equal, -- '=' in getopt Parameter_No_Space, -- '!' in getopt ! Parameter_Optional); -- '?' in getopt procedure Set_Parameter (Variable : out Parameter_Type; *************** package body GNAT.Command_Line is *** 101,140 **** procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Command_Line_Configuration_Record, Command_Line_Configuration); - type Boolean_Chars is array (Character) of Boolean; - procedure Remove (Line : in out Argument_List_Access; Index : Integer); -- Remove a specific element from Line ! procedure Append ! (Line : in out Argument_List_Access; ! Str : String_Access); ! -- Append a new element to Line ! function Args_From_Expanded (Args : Boolean_Chars) return String; ! -- Return the string made of all characters with True in Args generic ! with procedure Callback (Simple_Switch : String); procedure For_Each_Simple_Switch ! (Cmd : Command_Line; ! Switch : String); -- Breaks Switch into as simple switches as possible (expanding aliases and -- ungrouping common prefixes when possible), and call Callback for each of -- these. procedure Group_Switches ! (Cmd : Command_Line; ! Result : Argument_List_Access; ! Params : Argument_List_Access); ! -- Group switches with common prefixes whenever possible. ! -- Once they have been grouped, we also check items for possible aliasing procedure Alias_Switches (Cmd : Command_Line; Result : Argument_List_Access; Params : Argument_List_Access); ! -- When possible, replace or more switches by an alias, ie a shorter -- version. function Looking_At --- 101,156 ---- procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Command_Line_Configuration_Record, Command_Line_Configuration); procedure Remove (Line : in out Argument_List_Access; Index : Integer); -- Remove a specific element from Line ! procedure Add ! (Line : in out Argument_List_Access; ! Str : String_Access; ! Before : Boolean := False); ! -- Add a new element to Line. If Before is True, the item is inserted at ! -- the beginning, else it is appended. ! function Can_Have_Parameter (S : String) return Boolean; ! -- True if S can have a parameter. ! ! function Require_Parameter (S : String) return Boolean; ! -- True if S requires a parameter. ! ! function Actual_Switch (S : String) return String; ! -- Remove any possible trailing '!', ':', '?' and '=' generic ! with procedure Callback (Simple_Switch : String; Parameter : String); procedure For_Each_Simple_Switch ! (Cmd : Command_Line; ! Switch : String; ! Parameter : String := ""; ! Unalias : Boolean := True); -- Breaks Switch into as simple switches as possible (expanding aliases and -- ungrouping common prefixes when possible), and call Callback for each of -- these. + procedure Sort_Sections + (Line : GNAT.OS_Lib.Argument_List_Access; + Sections : GNAT.OS_Lib.Argument_List_Access; + Params : GNAT.OS_Lib.Argument_List_Access); + -- Reorder the command line switches so that the switches belonging to a + -- section are grouped together. + procedure Group_Switches ! (Cmd : Command_Line; ! Result : Argument_List_Access; ! Sections : Argument_List_Access; ! Params : Argument_List_Access); ! -- Group switches with common prefixes whenever possible. Once they have ! -- been grouped, we also check items for possible aliasing. procedure Alias_Switches (Cmd : Command_Line; Result : Argument_List_Access; Params : Argument_List_Access); ! -- When possible, replace one or more switches by an alias, i.e. a shorter -- version. function Looking_At *************** package body GNAT.Command_Line is *** 264,271 **** end; end if; end loop; - - return String'(1 .. 0 => ' '); end Expansion; ----------------- --- 280,285 ---- *************** package body GNAT.Command_Line is *** 567,573 **** -- Always prepend the switch character, so that users know that -- this comes from a switch on the command line. This is -- especially important when Concatenate is False, since ! -- otherwise the currrent argument first character is lost. Set_Parameter (Parser.The_Switch, --- 581,587 ---- -- Always prepend the switch character, so that users know that -- this comes from a switch on the command line. This is -- especially important when Concatenate is False, since ! -- otherwise the current argument first character is lost. Set_Parameter (Parser.The_Switch, *************** package body GNAT.Command_Line is *** 1052,1076 **** end if; end Free; - ------------------------ - -- Args_From_Expanded -- - ------------------------ - - function Args_From_Expanded (Args : Boolean_Chars) return String is - Result : String (1 .. Args'Length); - Index : Natural := Result'First; - - begin - for A in Args'Range loop - if Args (A) then - Result (Index) := A; - Index := Index + 1; - end if; - end loop; - - return Result (1 .. Index - 1); - end Args_From_Expanded; - ------------------ -- Define_Alias -- ------------------ --- 1066,1071 ---- *************** package body GNAT.Command_Line is *** 1085,1092 **** Config := new Command_Line_Configuration_Record; end if; ! Append (Config.Aliases, new String'(Switch)); ! Append (Config.Expansions, new String'(Expanded)); end Define_Alias; ------------------- --- 1080,1087 ---- Config := new Command_Line_Configuration_Record; end if; ! Add (Config.Aliases, new String'(Switch)); ! Add (Config.Expansions, new String'(Expanded)); end Define_Alias; ------------------- *************** package body GNAT.Command_Line is *** 1102,1122 **** Config := new Command_Line_Configuration_Record; end if; ! Append (Config.Prefixes, new String'(Prefix)); end Define_Prefix; ----------------------- -- Set_Configuration -- ----------------------- procedure Set_Configuration ! (Cmd : in out Command_Line; ! Config : Command_Line_Configuration) is begin Cmd.Config := Config; end Set_Configuration; ---------------------- -- Set_Command_Line -- ---------------------- --- 1097,1190 ---- Config := new Command_Line_Configuration_Record; end if; ! Add (Config.Prefixes, new String'(Prefix)); end Define_Prefix; + ------------------- + -- Define_Switch -- + ------------------- + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Switch : String) + is + begin + if Config = null then + Config := new Command_Line_Configuration_Record; + end if; + + Add (Config.Switches, new String'(Switch)); + end Define_Switch; + + -------------------- + -- Define_Section -- + -------------------- + + procedure Define_Section + (Config : in out Command_Line_Configuration; + Section : String) + is + begin + if Config = null then + Config := new Command_Line_Configuration_Record; + end if; + + Add (Config.Sections, new String'(Section)); + end Define_Section; + + ------------------ + -- Get_Switches -- + ------------------ + + function Get_Switches + (Config : Command_Line_Configuration; + Switch_Char : Character) + return String + is + Ret : Ada.Strings.Unbounded.Unbounded_String; + use type Ada.Strings.Unbounded.Unbounded_String; + + begin + if Config = null or else Config.Switches = null then + return ""; + end if; + + for J in Config.Switches'Range loop + if Config.Switches (J) (Config.Switches (J)'First) = Switch_Char then + Ret := + Ret & " " & + Config.Switches (J) + (Config.Switches (J)'First + 1 .. Config.Switches (J)'Last); + else + Ret := Ret & " " & Config.Switches (J).all; + end if; + end loop; + + return Ada.Strings.Unbounded.To_String (Ret); + end Get_Switches; + ----------------------- -- Set_Configuration -- ----------------------- procedure Set_Configuration ! (Cmd : in out Command_Line; ! Config : Command_Line_Configuration) is begin Cmd.Config := Config; end Set_Configuration; + ----------------------- + -- Get_Configuration -- + ----------------------- + + function Get_Configuration + (Cmd : Command_Line) return Command_Line_Configuration is + begin + return Cmd.Config; + end Get_Configuration; + ---------------------- -- Set_Command_Line -- ---------------------- *************** package body GNAT.Command_Line is *** 1127,1135 **** Getopt_Description : String := ""; Switch_Char : Character := '-') is ! Tmp : Argument_List_Access; ! Parser : Opt_Parser; ! S : Character; begin Free (Cmd.Expanded); --- 1195,1228 ---- Getopt_Description : String := ""; Switch_Char : Character := '-') is ! Tmp : Argument_List_Access; ! Parser : Opt_Parser; ! S : Character; ! Section : String_Access := null; ! ! function Real_Full_Switch ! (S : Character; ! Parser : Opt_Parser) return String; ! -- Ensure that the returned switch value contains the ! -- Switch_Char prefix if needed. ! ! ---------------------- ! -- Real_Full_Switch -- ! ---------------------- ! ! function Real_Full_Switch ! (S : Character; ! Parser : Opt_Parser) return String ! is ! begin ! if S = '*' then ! return Full_Switch (Parser); ! else ! return Switch_Char & Full_Switch (Parser); ! end if; ! end Real_Full_Switch; ! ! -- Start of processing for Set_Command_Line begin Free (Cmd.Expanded); *************** package body GNAT.Command_Line is *** 1146,1165 **** Parser => Parser); exit when S = ASCII.NUL; ! if S = '*' then ! Add_Switch (Cmd, Full_Switch (Parser), Parameter (Parser), ! Separator (Parser)); ! else ! Add_Switch ! (Cmd, Switch_Char & Full_Switch (Parser), ! Parameter (Parser), Separator (Parser)); ! end if; exception when Invalid_Parameter => -- Add it with no parameter, if that's the way the user ! -- wants it ! Add_Switch (Cmd, Switch_Char & Full_Switch (Parser)); end; end loop; --- 1239,1320 ---- Parser => Parser); exit when S = ASCII.NUL; ! declare ! Sw : constant String := ! Real_Full_Switch (S, Parser); ! Is_Section : Boolean := False; ! ! begin ! if Cmd.Config /= null ! and then Cmd.Config.Sections /= null ! then ! Section_Search : ! for S in Cmd.Config.Sections'Range loop ! if Sw = Cmd.Config.Sections (S).all then ! Section := Cmd.Config.Sections (S); ! Is_Section := True; ! ! exit Section_Search; ! end if; ! end loop Section_Search; ! end if; ! ! if not Is_Section then ! if Section = null then ! ! -- Work around some weird cases: some switches may ! -- expect parameters, but have the same value as ! -- longer switches: -gnaty3 (-gnaty, parameter=3) and ! -- -gnatya (-gnatya, no parameter). ! ! -- So we are calling add_switch here with parameter ! -- attached. This will be anyway correctly handled by ! -- Add_Switch if -gnaty3 is actually provided. ! ! if Separator (Parser) = ASCII.NUL then ! Add_Switch ! (Cmd, Sw & Parameter (Parser), ""); ! else ! Add_Switch ! (Cmd, Sw, Parameter (Parser), Separator (Parser)); ! end if; ! else ! if Separator (Parser) = ASCII.NUL then ! Add_Switch ! (Cmd, Sw & Parameter (Parser), "", ! Separator (Parser), ! Section.all); ! else ! Add_Switch ! (Cmd, Sw, ! Parameter (Parser), ! Separator (Parser), ! Section.all); ! end if; ! end if; ! end if; ! end; exception when Invalid_Parameter => + -- Add it with no parameter, if that's the way the user ! -- wants it. ! ! -- Specify the separator in all cases, as the switch might ! -- need to be unaliased, and the alias might contain ! -- switches with parameters. ! ! if Section = null then ! Add_Switch ! (Cmd, Switch_Char & Full_Switch (Parser), ! Separator => Separator (Parser)); ! else ! Add_Switch ! (Cmd, Switch_Char & Full_Switch (Parser), ! Separator => Separator (Parser), ! Section => Section.all); ! end if; end; end loop; *************** package body GNAT.Command_Line is *** 1180,1193 **** and then Type_Str (Index .. Index + Substring'Length - 1) = Substring; end Looking_At; ---------------------------- -- For_Each_Simple_Switch -- ---------------------------- procedure For_Each_Simple_Switch ! (Cmd : Command_Line; ! Switch : String) is begin -- Are we adding a switch that can in fact be expanded through aliases ? -- If yes, we add separately each of its expansion. --- 1335,1509 ---- and then Type_Str (Index .. Index + Substring'Length - 1) = Substring; end Looking_At; + ------------------------ + -- Can_Have_Parameter -- + ------------------------ + + function Can_Have_Parameter (S : String) return Boolean is + begin + if S'Length <= 1 then + return False; + end if; + + case S (S'Last) is + when '!' | ':' | '?' | '=' => + return True; + when others => + return False; + end case; + end Can_Have_Parameter; + + ----------------------- + -- Require_Parameter -- + ----------------------- + + function Require_Parameter (S : String) return Boolean is + begin + if S'Length <= 1 then + return False; + end if; + + case S (S'Last) is + when '!' | ':' | '=' => + return True; + when others => + return False; + end case; + end Require_Parameter; + + ------------------- + -- Actual_Switch -- + ------------------- + + function Actual_Switch (S : String) return String is + begin + if S'Length <= 1 then + return S; + end if; + + case S (S'Last) is + when '!' | ':' | '?' | '=' => + return S (S'First .. S'Last - 1); + when others => + return S; + end case; + end Actual_Switch; + ---------------------------- -- For_Each_Simple_Switch -- ---------------------------- procedure For_Each_Simple_Switch ! (Cmd : Command_Line; ! Switch : String; ! Parameter : String := ""; ! Unalias : Boolean := True) is + function Group_Analysis + (Prefix : String; + Group : String) return Boolean; + -- Perform the analysis of a group of switches. + + -------------------- + -- Group_Analysis -- + -------------------- + + function Group_Analysis + (Prefix : String; + Group : String) return Boolean + is + Idx : Natural; + Found : Boolean; + + begin + Idx := Group'First; + while Idx <= Group'Last loop + Found := False; + + for S in Cmd.Config.Switches'Range loop + declare + Sw : constant String := + Actual_Switch + (Cmd.Config.Switches (S).all); + Full : constant String := + Prefix & Group (Idx .. Group'Last); + Last : Natural; + Param : Natural; + + begin + if Sw'Length >= Prefix'Length + + -- Verify that sw starts with Prefix + + and then Looking_At (Sw, Sw'First, Prefix) + + -- Verify that the group starts with sw + + and then Looking_At (Full, Full'First, Sw) + then + Last := Idx + Sw'Length - Prefix'Length - 1; + Param := Last + 1; + + if Can_Have_Parameter (Cmd.Config.Switches (S).all) then + + -- Include potential parameter to the recursive call. + -- Only numbers are allowed. + + while Last < Group'Last + and then Group (Last + 1) in '0' .. '9' + loop + Last := Last + 1; + end loop; + end if; + + if not Require_Parameter (Cmd.Config.Switches (S).all) + or else Last >= Param + then + if Idx = Group'First + and then Last = Group'Last + and then Last < Param + then + -- The group only concerns a single switch. Do not + -- perform recursive call. + + -- Note that we still perform a recursive call if + -- a parameter is detected in the switch, as this + -- is a way to correctly identify such a parameter + -- in aliases. + + return False; + end if; + + Found := True; + + -- Recursive call, using the detected parameter if any + + if Last >= Param then + For_Each_Simple_Switch + (Cmd, + Prefix & Group (Idx .. Param - 1), + Group (Param .. Last)); + else + For_Each_Simple_Switch + (Cmd, Prefix & Group (Idx .. Last), ""); + end if; + + Idx := Last + 1; + exit; + end if; + end if; + end; + end loop; + + if not Found then + For_Each_Simple_Switch (Cmd, Prefix & Group (Idx), ""); + Idx := Idx + 1; + end if; + end loop; + + return True; + end Group_Analysis; + begin -- Are we adding a switch that can in fact be expanded through aliases ? -- If yes, we add separately each of its expansion. *************** package body GNAT.Command_Line is *** 1197,1209 **** -- in which we do things here, the expansion of the alias will itself -- be checked for a common prefix and further split into simple switches ! if Cmd.Config /= null and then Cmd.Config.Aliases /= null then for A in Cmd.Config.Aliases'Range loop ! if Cmd.Config.Aliases (A).all = Switch then For_Each_Simple_Switch ! (Cmd, Cmd.Config.Expansions (A).all); return; end if; end loop; --- 1513,1528 ---- -- in which we do things here, the expansion of the alias will itself -- be checked for a common prefix and further split into simple switches ! if Unalias ! and then Cmd.Config /= null and then Cmd.Config.Aliases /= null then for A in Cmd.Config.Aliases'Range loop ! if Cmd.Config.Aliases (A).all = Switch ! and then Parameter = "" ! then For_Each_Simple_Switch ! (Cmd, Cmd.Config.Expansions (A).all, ""); return; end if; end loop; *************** package body GNAT.Command_Line is *** 1221,1239 **** (Switch, Switch'First, Cmd.Config.Prefixes (P).all) then -- Alias expansion will be done recursively ! for S in Switch'First + Cmd.Config.Prefixes (P)'Length ! .. Switch'Last ! loop ! For_Each_Simple_Switch ! (Cmd, Cmd.Config.Prefixes (P).all & Switch (S)); ! end loop; ! return; end if; end loop; end if; ! Callback (Switch); end For_Each_Simple_Switch; ---------------- --- 1540,1616 ---- (Switch, Switch'First, Cmd.Config.Prefixes (P).all) then -- Alias expansion will be done recursively + if Cmd.Config.Switches = null then + for S in Switch'First + Cmd.Config.Prefixes (P)'Length + .. Switch'Last + loop + For_Each_Simple_Switch + (Cmd, Cmd.Config.Prefixes (P).all & Switch (S), ""); + end loop; ! return; ! ! elsif Group_Analysis ! (Cmd.Config.Prefixes (P).all, ! Switch ! (Switch'First + Cmd.Config.Prefixes (P)'Length ! .. Switch'Last)) ! then ! -- Recursive calls already done on each switch of the ! -- group. Let's return to not call Callback. ! return; ! end if; end if; end loop; end if; ! -- Test if added switch is a known switch with parameter attached ! ! if Parameter = "" ! and then Cmd.Config /= null ! and then Cmd.Config.Switches /= null ! then ! for S in Cmd.Config.Switches'Range loop ! declare ! Sw : constant String := ! Actual_Switch (Cmd.Config.Switches (S).all); ! Last : Natural; ! Param : Natural; ! ! begin ! -- Verify that switch starts with Sw ! -- What if the "verification" fails??? ! ! if Switch'Length >= Sw'Length ! and then Looking_At (Switch, Switch'First, Sw) ! then ! Param := Switch'First + Sw'Length - 1; ! Last := Param; ! ! if Can_Have_Parameter (Cmd.Config.Switches (S).all) then ! while Last < Switch'Last ! and then Switch (Last + 1) in '0' .. '9' ! loop ! Last := Last + 1; ! end loop; ! end if; ! ! -- If full Switch is a known switch with attached parameter ! -- then we use this parameter in the callback. ! ! if Last = Switch'Last then ! Callback ! (Switch (Switch'First .. Param), ! Switch (Param + 1 .. Last)); ! return; ! ! end if; ! end if; ! end; ! end loop; ! end if; ! ! Callback (Switch, Parameter); end For_Each_Simple_Switch; ---------------- *************** package body GNAT.Command_Line is *** 1241,1291 **** ---------------- procedure Add_Switch ! (Cmd : in out Command_Line; ! Switch : String; ! Parameter : String := ""; ! Separator : Character := ' ') is ! procedure Add_Simple_Switch (Simple : String); -- Add a new switch that has had all its aliases expanded, and switches ! -- ungrouped. We know there is no more aliases in Switches ----------------------- -- Add_Simple_Switch -- ----------------------- ! procedure Add_Simple_Switch (Simple : String) is begin if Cmd.Expanded = null then Cmd.Expanded := new Argument_List'(1 .. 1 => new String'(Simple)); ! if Parameter = "" then Cmd.Params := new Argument_List'(1 .. 1 => null); else ! Cmd.Params := new Argument_List' ! (1 .. 1 => new String'(Separator & Parameter)); end if; else ! -- Do we already have this switch ? for C in Cmd.Expanded'Range loop if Cmd.Expanded (C).all = Simple and then ! ((Cmd.Params (C) = null and then Parameter = "") ! or else ! (Cmd.Params (C) /= null ! and then Cmd.Params (C).all = Separator & Parameter)) then return; end if; end loop; ! Append (Cmd.Expanded, new String'(Simple)); - if Parameter = "" then - Append (Cmd.Params, null); else ! Append (Cmd.Params, new String'(Separator & Parameter)); end if; end if; end Add_Simple_Switch; --- 1618,1727 ---- ---------------- procedure Add_Switch ! (Cmd : in out Command_Line; ! Switch : String; ! Parameter : String := ""; ! Separator : Character := ' '; ! Section : String := ""; ! Add_Before : Boolean := False) is ! Success : Boolean; ! pragma Unreferenced (Success); ! begin ! Add_Switch ! (Cmd, Switch, Parameter, Separator, Section, Add_Before, Success); ! end Add_Switch; ! ! ---------------- ! -- Add_Switch -- ! ---------------- ! ! procedure Add_Switch ! (Cmd : in out Command_Line; ! Switch : String; ! Parameter : String := ""; ! Separator : Character := ' '; ! Section : String := ""; ! Add_Before : Boolean := False; ! Success : out Boolean) ! is ! procedure Add_Simple_Switch (Simple : String; Param : String); -- Add a new switch that has had all its aliases expanded, and switches ! -- ungrouped. We know there are no more aliases in Switches. ----------------------- -- Add_Simple_Switch -- ----------------------- ! procedure Add_Simple_Switch (Simple : String; Param : String) is begin if Cmd.Expanded = null then Cmd.Expanded := new Argument_List'(1 .. 1 => new String'(Simple)); ! ! if Param /= "" then ! Cmd.Params := new Argument_List' ! (1 .. 1 => new String'(Separator & Param)); ! ! else Cmd.Params := new Argument_List'(1 .. 1 => null); + end if; + + if Section = "" then + Cmd.Sections := new Argument_List'(1 .. 1 => null); + else ! Cmd.Sections := new Argument_List' ! (1 .. 1 => new String'(Section)); end if; else ! -- Do we already have this switch? for C in Cmd.Expanded'Range loop if Cmd.Expanded (C).all = Simple and then ! ((Cmd.Params (C) = null and then Param = "") ! or else ! (Cmd.Params (C) /= null ! and then Cmd.Params (C).all = Separator & Param)) ! and then ! ((Cmd.Sections (C) = null and then Section = "") ! or else ! (Cmd.Sections (C) /= null ! and then Cmd.Sections (C).all = Section)) then return; end if; end loop; ! -- Inserting at least one switch ! ! Success := True; ! Add (Cmd.Expanded, new String'(Simple), Add_Before); ! ! if Param /= "" then ! Add ! (Cmd.Params, ! new String'(Separator & Param), ! Add_Before); else ! Add ! (Cmd.Params, ! null, ! Add_Before); ! end if; ! ! if Section = "" then ! Add ! (Cmd.Sections, ! null, ! Add_Before); ! else ! Add ! (Cmd.Sections, ! new String'(Section), ! Add_Before); end if; end if; end Add_Simple_Switch; *************** package body GNAT.Command_Line is *** 1296,1302 **** -- Start of processing for Add_Switch begin ! Add_Simple_Switches (Cmd, Switch); Free (Cmd.Coalesce); end Add_Switch; --- 1732,1739 ---- -- Start of processing for Add_Switch begin ! Success := False; ! Add_Simple_Switches (Cmd, Switch, Parameter); Free (Cmd.Coalesce); end Add_Switch; *************** package body GNAT.Command_Line is *** 1323,1375 **** Unchecked_Free (Tmp); end Remove; ! ------------ ! -- Append -- ! ------------ ! procedure Append ! (Line : in out Argument_List_Access; ! Str : String_Access) is Tmp : Argument_List_Access := Line; begin if Tmp /= null then Line := new Argument_List (Tmp'First .. Tmp'Last + 1); ! Line (Tmp'Range) := Tmp.all; Unchecked_Free (Tmp); else ! Line := new Argument_List (1 .. 1); end if; ! Line (Line'Last) := Str; ! end Append; ------------------- -- Remove_Switch -- ------------------- procedure Remove_Switch ! (Cmd : in out Command_Line; ! Switch : String; ! Remove_All : Boolean := False) is ! procedure Remove_Simple_Switch (Simple : String); -- Removes a simple switch, with no aliasing or grouping -------------------------- -- Remove_Simple_Switch -- -------------------------- ! procedure Remove_Simple_Switch (Simple : String) is C : Integer; begin if Cmd.Expanded /= null then C := Cmd.Expanded'First; while C <= Cmd.Expanded'Last loop ! if Cmd.Expanded (C).all = Simple then Remove (Cmd.Expanded, C); Remove (Cmd.Params, C); if not Remove_All then return; --- 1760,1852 ---- Unchecked_Free (Tmp); end Remove; ! --------- ! -- Add -- ! --------- ! procedure Add ! (Line : in out Argument_List_Access; ! Str : String_Access; ! Before : Boolean := False) is Tmp : Argument_List_Access := Line; + begin if Tmp /= null then Line := new Argument_List (Tmp'First .. Tmp'Last + 1); ! ! if Before then ! Line (Tmp'First) := Str; ! Line (Tmp'First + 1 .. Tmp'Last + 1) := Tmp.all; ! else ! Line (Tmp'Range) := Tmp.all; ! Line (Tmp'Last + 1) := Str; ! end if; ! Unchecked_Free (Tmp); + else ! Line := new Argument_List'(1 .. 1 => Str); end if; + end Add; ! ------------------- ! -- Remove_Switch -- ! ------------------- ! ! procedure Remove_Switch ! (Cmd : in out Command_Line; ! Switch : String; ! Remove_All : Boolean := False; ! Has_Parameter : Boolean := False; ! Section : String := "") ! is ! Success : Boolean; ! pragma Unreferenced (Success); ! begin ! Remove_Switch (Cmd, Switch, Remove_All, Has_Parameter, Section, Success); ! end Remove_Switch; ------------------- -- Remove_Switch -- ------------------- procedure Remove_Switch ! (Cmd : in out Command_Line; ! Switch : String; ! Remove_All : Boolean := False; ! Has_Parameter : Boolean := False; ! Section : String := ""; ! Success : out Boolean) is ! procedure Remove_Simple_Switch (Simple : String; Param : String); -- Removes a simple switch, with no aliasing or grouping -------------------------- -- Remove_Simple_Switch -- -------------------------- ! procedure Remove_Simple_Switch (Simple : String; Param : String) is C : Integer; + pragma Unreferenced (Param); begin if Cmd.Expanded /= null then C := Cmd.Expanded'First; while C <= Cmd.Expanded'Last loop ! if Cmd.Expanded (C).all = Simple ! and then ! (Remove_All ! or else (Cmd.Sections (C) = null ! and then Section = "") ! or else (Cmd.Sections (C) /= null ! and then Section = Cmd.Sections (C).all)) ! and then (not Has_Parameter or else Cmd.Params (C) /= null) ! then Remove (Cmd.Expanded, C); Remove (Cmd.Params, C); + Remove (Cmd.Sections, C); + Success := True; if not Remove_All then return; *************** package body GNAT.Command_Line is *** 1383,1394 **** end Remove_Simple_Switch; procedure Remove_Simple_Switches is ! new For_Each_Simple_Switch (Remove_Simple_Switch); -- Start of processing for Remove_Switch begin ! Remove_Simple_Switches (Cmd, Switch); Free (Cmd.Coalesce); end Remove_Switch; --- 1860,1872 ---- end Remove_Simple_Switch; procedure Remove_Simple_Switches is ! new For_Each_Simple_Switch (Remove_Simple_Switch); -- Start of processing for Remove_Switch begin ! Success := False; ! Remove_Simple_Switches (Cmd, Switch, "", Unalias => not Has_Parameter); Free (Cmd.Coalesce); end Remove_Switch; *************** package body GNAT.Command_Line is *** 1399,1414 **** procedure Remove_Switch (Cmd : in out Command_Line; Switch : String; ! Parameter : String) is ! procedure Remove_Simple_Switch (Simple : String); -- Removes a simple switch, with no aliasing or grouping -------------------------- -- Remove_Simple_Switch -- -------------------------- ! procedure Remove_Simple_Switch (Simple : String) is C : Integer; begin --- 1877,1893 ---- procedure Remove_Switch (Cmd : in out Command_Line; Switch : String; ! Parameter : String; ! Section : String := "") is ! procedure Remove_Simple_Switch (Simple : String; Param : String); -- Removes a simple switch, with no aliasing or grouping -------------------------- -- Remove_Simple_Switch -- -------------------------- ! procedure Remove_Simple_Switch (Simple : String; Param : String) is C : Integer; begin *************** package body GNAT.Command_Line is *** 1417,1423 **** while C <= Cmd.Expanded'Last loop if Cmd.Expanded (C).all = Simple and then ! ((Cmd.Params (C) = null and then Parameter = "") or else (Cmd.Params (C) /= null and then --- 1896,1908 ---- while C <= Cmd.Expanded'Last loop if Cmd.Expanded (C).all = Simple and then ! ((Cmd.Sections (C) = null ! and then Section = "") ! or else ! (Cmd.Sections (C) /= null ! and then Section = Cmd.Sections (C).all)) ! and then ! ((Cmd.Params (C) = null and then Param = "") or else (Cmd.Params (C) /= null and then *************** package body GNAT.Command_Line is *** 1426,1438 **** Cmd.Params (C) (Cmd.Params (C)'First + 1 .. Cmd.Params (C)'Last) = ! Parameter)) then Remove (Cmd.Expanded, C); Remove (Cmd.Params, C); -- The switch is necessarily unique by construction of ! -- Add_Switch return; --- 1911,1924 ---- Cmd.Params (C) (Cmd.Params (C)'First + 1 .. Cmd.Params (C)'Last) = ! Param)) then Remove (Cmd.Expanded, C); Remove (Cmd.Params, C); + Remove (Cmd.Sections, C); -- The switch is necessarily unique by construction of ! -- Add_Switch. return; *************** package body GNAT.Command_Line is *** 1449,1455 **** -- Start of processing for Remove_Switch begin ! Remove_Simple_Switches (Cmd, Switch); Free (Cmd.Coalesce); end Remove_Switch; --- 1935,1941 ---- -- Start of processing for Remove_Switch begin ! Remove_Simple_Switches (Cmd, Switch, Parameter); Free (Cmd.Coalesce); end Remove_Switch; *************** package body GNAT.Command_Line is *** 1458,1473 **** -------------------- procedure Group_Switches ! (Cmd : Command_Line; ! Result : Argument_List_Access; ! Params : Argument_List_Access) is ! type Boolean_Array is array (Result'Range) of Boolean; ! Matched : Boolean_Array; ! Count : Natural; ! First : Natural; ! From_Args : Boolean_Chars; begin if Cmd.Config = null --- 1944,1993 ---- -------------------- procedure Group_Switches ! (Cmd : Command_Line; ! Result : Argument_List_Access; ! Sections : Argument_List_Access; ! Params : Argument_List_Access) is ! function Compatible_Parameter (Param : String_Access) return Boolean; ! -- True when the parameter can be part of a group ! -------------------------- ! -- Compatible_Parameter -- ! -------------------------- ! ! function Compatible_Parameter (Param : String_Access) return Boolean is ! begin ! -- No parameter OK ! ! if Param = null then ! return True; ! ! -- We need parameters without separators ! ! elsif Param (Param'First) /= ASCII.NUL then ! return False; ! ! -- Parameters must be all digits ! ! else ! for J in Param'First + 1 .. Param'Last loop ! if Param (J) not in '0' .. '9' then ! return False; ! end if; ! end loop; ! ! return True; ! end if; ! end Compatible_Parameter; ! ! -- Local declarations ! ! Group : Ada.Strings.Unbounded.Unbounded_String; ! First : Natural; ! use type Ada.Strings.Unbounded.Unbounded_String; ! ! -- Start of processing for Group_Switches begin if Cmd.Config = null *************** package body GNAT.Command_Line is *** 1477,1517 **** end if; for P in Cmd.Config.Prefixes'Range loop ! Matched := (others => False); ! Count := 0; for C in Result'Range loop if Result (C) /= null ! and then Params (C) = null -- ignored if has a parameter and then Looking_At (Result (C).all, Result (C)'First, Cmd.Config.Prefixes (P).all) then ! Matched (C) := True; ! Count := Count + 1; ! end if; ! end loop; ! if Count > 1 then ! From_Args := (others => False); ! First := 0; - for M in Matched'Range loop - if Matched (M) then if First = 0 then ! First := M; end if; ! for A in Result (M)'First + Cmd.Config.Prefixes (P)'Length ! .. Result (M)'Last ! loop ! From_Args (Result (M)(A)) := True; ! end loop; ! Free (Result (M)); end if; ! end loop; ! Result (First) := new String' ! (Cmd.Config.Prefixes (P).all & Args_From_Expanded (From_Args)); end if; end loop; end Group_Switches; --- 1997,2064 ---- end if; for P in Cmd.Config.Prefixes'Range loop ! Group := Ada.Strings.Unbounded.Null_Unbounded_String; ! First := 0; for C in Result'Range loop if Result (C) /= null ! and then Compatible_Parameter (Params (C)) and then Looking_At (Result (C).all, Result (C)'First, Cmd.Config.Prefixes (P).all) then ! -- If we are still in the same section, group the switches ! if First = 0 ! or else ! (Sections (C) = null ! and then Sections (First) = null) ! or else ! (Sections (C) /= null ! and then Sections (First) /= null ! and then Sections (C).all = Sections (First).all) ! then ! Group := ! Group & ! Result (C) ! (Result (C)'First + Cmd.Config.Prefixes (P)'Length .. ! Result (C)'Last); ! ! if Params (C) /= null then ! Group := ! Group & ! Params (C) (Params (C)'First + 1 .. Params (C)'Last); ! Free (Params (C)); ! end if; if First = 0 then ! First := C; end if; ! Free (Result (C)); ! ! else ! -- We changed section: we put the grouped switches to the ! -- first place, on continue with the new section. ! ! Result (First) := ! new String' ! (Cmd.Config.Prefixes (P).all & ! Ada.Strings.Unbounded.To_String (Group)); ! Group := ! Ada.Strings.Unbounded.To_Unbounded_String ! (Result (C) ! (Result (C)'First + Cmd.Config.Prefixes (P)'Length .. ! Result (C)'Last)); ! First := C; end if; ! end if; ! end loop; ! if First > 0 then ! Result (First) := ! new String' ! (Cmd.Config.Prefixes (P).all & ! Ada.Strings.Unbounded.To_String (Group)); end if; end loop; end Group_Switches; *************** package body GNAT.Command_Line is *** 1528,1549 **** Found : Boolean; First : Natural; ! procedure Check_Cb (Switch : String); -- Comment required ??? ! procedure Remove_Cb (Switch : String); -- Comment required ??? -------------- -- Check_Cb -- -------------- ! procedure Check_Cb (Switch : String) is begin if Found then for E in Result'Range loop if Result (E) /= null ! and then Params (E) = null -- Ignore if has a param and then Result (E).all = Switch then return; --- 2075,2099 ---- Found : Boolean; First : Natural; ! procedure Check_Cb (Switch : String; Param : String); -- Comment required ??? ! procedure Remove_Cb (Switch : String; Param : String); -- Comment required ??? -------------- -- Check_Cb -- -------------- ! procedure Check_Cb (Switch : String; Param : String) is begin if Found then for E in Result'Range loop if Result (E) /= null ! and then ! (Params (E) = null ! or else Params (E) (Params (E)'First + 1 ! .. Params (E)'Last) = Param) and then Result (E).all = Switch then return; *************** package body GNAT.Command_Line is *** 1558,1571 **** -- Remove_Cb -- --------------- ! procedure Remove_Cb (Switch : String) is begin for E in Result'Range loop ! if Result (E) /= null and then Result (E).all = Switch then if First > E then First := E; end if; Free (Result (E)); return; end if; end loop; --- 2108,2128 ---- -- Remove_Cb -- --------------- ! procedure Remove_Cb (Switch : String; Param : String) is begin for E in Result'Range loop ! if Result (E) /= null ! and then ! (Params (E) = null ! or else Params (E) (Params (E)'First + 1 ! .. Params (E)'Last) = Param) ! and then Result (E).all = Switch ! then if First > E then First := E; end if; Free (Result (E)); + Free (Params (E)); return; end if; end loop; *************** package body GNAT.Command_Line is *** 1600,1605 **** --- 2157,2226 ---- end loop; end Alias_Switches; + ------------------- + -- Sort_Sections -- + ------------------- + + procedure Sort_Sections + (Line : GNAT.OS_Lib.Argument_List_Access; + Sections : GNAT.OS_Lib.Argument_List_Access; + Params : GNAT.OS_Lib.Argument_List_Access) + is + Sections_List : Argument_List_Access := + new Argument_List'(1 .. 1 => null); + Found : Boolean; + Old_Line : constant Argument_List := Line.all; + Old_Sections : constant Argument_List := Sections.all; + Old_Params : constant Argument_List := Params.all; + Index : Natural; + + begin + if Line = null then + return; + end if; + + -- First construct a list of all sections + + for E in Line'Range loop + if Sections (E) /= null then + Found := False; + for S in Sections_List'Range loop + if (Sections_List (S) = null and then Sections (E) = null) + or else + (Sections_List (S) /= null + and then Sections (E) /= null + and then Sections_List (S).all = Sections (E).all) + then + Found := True; + exit; + end if; + end loop; + + if not Found then + Add (Sections_List, Sections (E)); + end if; + end if; + end loop; + + Index := Line'First; + + for S in Sections_List'Range loop + for E in Old_Line'Range loop + if (Sections_List (S) = null and then Old_Sections (E) = null) + or else + (Sections_List (S) /= null + and then Old_Sections (E) /= null + and then Sections_List (S).all = Old_Sections (E).all) + then + Line (Index) := Old_Line (E); + Sections (Index) := Old_Sections (E); + Params (Index) := Old_Params (E); + Index := Index + 1; + end if; + end loop; + end loop; + end Sort_Sections; + ----------- -- Start -- ----------- *************** package body GNAT.Command_Line is *** 1615,1620 **** --- 2236,2245 ---- return; end if; + -- Reorder the expanded line so that sections are grouped + + Sort_Sections (Cmd.Expanded, Cmd.Sections, Cmd.Params); + -- Coalesce the switches as much as possible if not Expanded *************** package body GNAT.Command_Line is *** 1625,1649 **** Cmd.Coalesce (E) := new String'(Cmd.Expanded (E).all); end loop; -- Not a clone, since we will not modify the parameters anyway ! Cmd.Coalesce_Params := Cmd.Params; ! Alias_Switches (Cmd, Cmd.Coalesce, Cmd.Params); ! Group_Switches (Cmd, Cmd.Coalesce, Cmd.Params); end if; if Expanded then ! Iter.List := Cmd.Expanded; ! Iter.Params := Cmd.Params; else ! Iter.List := Cmd.Coalesce; ! Iter.Params := Cmd.Coalesce_Params; end if; if Iter.List = null then Iter.Current := Integer'Last; else Iter.Current := Iter.List'First; while Iter.Current <= Iter.List'Last and then Iter.List (Iter.Current) = null loop --- 2250,2295 ---- Cmd.Coalesce (E) := new String'(Cmd.Expanded (E).all); end loop; + Cmd.Coalesce_Sections := new Argument_List (Cmd.Sections'Range); + for E in Cmd.Sections'Range loop + if Cmd.Sections (E) = null then + Cmd.Coalesce_Sections (E) := null; + else + Cmd.Coalesce_Sections (E) := new String'(Cmd.Sections (E).all); + end if; + end loop; + + Cmd.Coalesce_Params := new Argument_List (Cmd.Params'Range); + for E in Cmd.Params'Range loop + if Cmd.Params (E) = null then + Cmd.Coalesce_Params (E) := null; + else + Cmd.Coalesce_Params (E) := new String'(Cmd.Params (E).all); + end if; + end loop; + -- Not a clone, since we will not modify the parameters anyway ! Alias_Switches (Cmd, Cmd.Coalesce, Cmd.Coalesce_Params); ! Group_Switches ! (Cmd, Cmd.Coalesce, Cmd.Coalesce_Sections, Cmd.Coalesce_Params); end if; if Expanded then ! Iter.List := Cmd.Expanded; ! Iter.Params := Cmd.Params; ! Iter.Sections := Cmd.Sections; else ! Iter.List := Cmd.Coalesce; ! Iter.Params := Cmd.Coalesce_Params; ! Iter.Sections := Cmd.Coalesce_Sections; end if; if Iter.List = null then Iter.Current := Integer'Last; else Iter.Current := Iter.List'First; + while Iter.Current <= Iter.List'Last and then Iter.List (Iter.Current) = null loop *************** package body GNAT.Command_Line is *** 1661,1666 **** --- 2307,2346 ---- return Iter.List (Iter.Current).all; end Current_Switch; + -------------------- + -- Is_New_Section -- + -------------------- + + function Is_New_Section (Iter : Command_Line_Iterator) return Boolean is + Section : constant String := Current_Section (Iter); + begin + if Iter.Sections = null then + return False; + elsif Iter.Current = Iter.Sections'First + or else Iter.Sections (Iter.Current - 1) = null + then + return Section /= ""; + end if; + + return Section /= Iter.Sections (Iter.Current - 1).all; + end Is_New_Section; + + --------------------- + -- Current_Section -- + --------------------- + + function Current_Section (Iter : Command_Line_Iterator) return String is + begin + if Iter.Sections = null + or else Iter.Current > Iter.Sections'Last + or else Iter.Sections (Iter.Current) = null + then + return ""; + end if; + + return Iter.Sections (Iter.Current).all; + end Current_Section; + ----------------------- -- Current_Separator -- ----------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/g-comlin.ads gcc-4.4.0/gcc/ada/g-comlin.ads *** gcc-4.3.3/gcc/ada/g-comlin.ads Wed Sep 26 10:44:07 2007 --- gcc-4.4.0/gcc/ada/g-comlin.ads Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- 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- -- *************** *** 42,48 **** -- (special command line arguments starting with '-' by default) and their -- parameters, and then the rest of the command line arguments. ! -- This package is flexible enough to accomodate various needs: optional -- switch parameters, various characters to separate a switch and its -- parameter, whether to stop the parsing at the first non-switch argument -- encountered, etc. --- 42,48 ---- -- (special command line arguments starting with '-' by default) and their -- parameters, and then the rest of the command line arguments. ! -- This package is flexible enough to accommodate various needs: optional -- switch parameters, various characters to separate a switch and its -- parameter, whether to stop the parsing at the first non-switch argument -- encountered, etc. *************** *** 84,90 **** -- A more complicated example would involve the use of sections for the -- switches, as for instance in gnatmake. The same command line is used to -- provide switches for several tools. Each tool recognizes its switches by ! -- separating them with special switches, chosen by the programer. -- Each section acts as a command line of its own. -- begin --- 84,90 ---- -- A more complicated example would involve the use of sections for the -- switches, as for instance in gnatmake. The same command line is used to -- provide switches for several tools. Each tool recognizes its switches by ! -- separating them with special switches, chosen by the programmer. -- Each section acts as a command line of its own. -- begin *************** package GNAT.Command_Line is *** 401,407 **** -- matching switch is returned. -- -- Arbitrary characters are allowed for switches, although it is ! -- strongly recommanded to use only letters and digits for portability -- reasons. -- -- When Concatenate is False, individual switches need to be separated by --- 401,407 ---- -- matching switch is returned. -- -- Arbitrary characters are allowed for switches, although it is ! -- strongly recommended to use only letters and digits for portability -- reasons. -- -- When Concatenate is False, individual switches need to be separated by *************** package GNAT.Command_Line is *** 513,518 **** --- 513,539 ---- -- characters whose order is irrelevant. In fact, this package will sort -- them alphabetically. + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Switch : String); + -- Indicates a new switch. The format of this switch follows the getopt + -- format (trailing ':', '?', etc for defining a switch with parameters). + -- The switches defined in the command_line_configuration object are used + -- when ungrouping switches with more that one character after the prefix. + + procedure Define_Section + (Config : in out Command_Line_Configuration; + Section : String); + -- Indicates a new switch section. Every switch belonging to the same + -- section are ordered together, preceded by the section. They are placed + -- at the end of the command line (as in 'gnatmake somefile.adb -cargs -g') + + function Get_Switches + (Config : Command_Line_Configuration; + Switch_Char : Character) return String; + -- Get the switches list as expected by getopt. This list is built using + -- all switches defined previously via Define_Switch above. + procedure Free (Config : in out Command_Line_Configuration); -- Free the memory used by Config *************** package GNAT.Command_Line is *** 523,532 **** type Command_Line is private; procedure Set_Configuration ! (Cmd : in out Command_Line; ! Config : Command_Line_Configuration); -- Set the configuration for this command line procedure Set_Command_Line (Cmd : in out Command_Line; Switches : String; --- 544,557 ---- type Command_Line is private; procedure Set_Configuration ! (Cmd : in out Command_Line; ! Config : Command_Line_Configuration); -- Set the configuration for this command line + function Get_Configuration + (Cmd : Command_Line) return Command_Line_Configuration; + -- Return the configuration used for that command line + procedure Set_Command_Line (Cmd : in out Command_Line; Switches : String; *************** package GNAT.Command_Line is *** 545,557 **** -- Command_Line_Iterator (which might be fine depending on your -- application). -- -- This function can be used to reset Cmd by passing an empty string. procedure Add_Switch ! (Cmd : in out Command_Line; ! Switch : String; ! Parameter : String := ""; ! Separator : Character := ' '); -- Add a new switch to the command line, and combine/group it with existing -- switches if possible. Nothing is done if the switch already exists with -- the same parameter. --- 570,587 ---- -- Command_Line_Iterator (which might be fine depending on your -- application). -- + -- If the command line has sections (such as -bargs -largs -cargs), then + -- they should be listed in the Sections parameter (as "-bargs -cargs") + -- -- This function can be used to reset Cmd by passing an empty string. procedure Add_Switch ! (Cmd : in out Command_Line; ! Switch : String; ! Parameter : String := ""; ! Separator : Character := ' '; ! Section : String := ""; ! Add_Before : Boolean := False); -- Add a new switch to the command line, and combine/group it with existing -- switches if possible. Nothing is done if the switch already exists with -- the same parameter. *************** package GNAT.Command_Line is *** 574,584 **** -- Separator is the character that goes between the switches and its -- parameter on the command line. If it is set to ASCII.NUL, then no -- separator is applied, and they are concatenated ! procedure Remove_Switch (Cmd : in out Command_Line; Switch : String; ! Remove_All : Boolean := False); -- Remove Switch from the command line, and ungroup existing switches if -- necessary. -- --- 604,635 ---- -- Separator is the character that goes between the switches and its -- parameter on the command line. If it is set to ASCII.NUL, then no -- separator is applied, and they are concatenated + -- + -- If the switch is part of a section, then it should be specified so that + -- the switch is correctly placed in the command line, and the section + -- added if not already present. For example, to add the -g switch into the + -- -cargs section, you need to call (Cmd, "-g", Section => "-cargs") + -- + -- Add_Before allows insertion of the switch at the beginning of the + -- command line. ! procedure Add_Switch (Cmd : in out Command_Line; Switch : String; ! Parameter : String := ""; ! Separator : Character := ' '; ! Section : String := ""; ! Add_Before : Boolean := False; ! Success : out Boolean); ! -- Same as above, returning the status of ! -- the operation ! ! procedure Remove_Switch ! (Cmd : in out Command_Line; ! Switch : String; ! Remove_All : Boolean := False; ! Has_Parameter : Boolean := False; ! Section : String := ""); -- Remove Switch from the command line, and ungroup existing switches if -- necessary. -- *************** package GNAT.Command_Line is *** 588,603 **** -- -- If Remove_All is True, then all matching switches are removed, otherwise -- only the first matching one is removed. procedure Remove_Switch (Cmd : in out Command_Line; Switch : String; ! Parameter : String); -- Remove a switch with a specific parameter. If Parameter is the empty -- string, then only a switch with no parameter will be removed. --------------- ! -- Iterating -- --------------- type Command_Line_Iterator is private; --- 639,674 ---- -- -- If Remove_All is True, then all matching switches are removed, otherwise -- only the first matching one is removed. + -- + -- If Has_Parameter is set to True, then only switches having a parameter + -- are removed. + -- + -- If the switch belongs to a section, then this section should be + -- specified: Remove_Switch (Cmd_Line, "-g", Section => "-cargs") called + -- on the command line "-g -cargs -g" will result in "-g", while if + -- called with (Cmd_Line, "-g") this will result in "-cargs -g". + -- If Remove_All is set, then both "-g" will be removed. + + procedure Remove_Switch + (Cmd : in out Command_Line; + Switch : String; + Remove_All : Boolean := False; + Has_Parameter : Boolean := False; + Section : String := ""; + Success : out Boolean); + -- Same as above, reporting the success of the operation (Success is False + -- if no switch was removed). procedure Remove_Switch (Cmd : in out Command_Line; Switch : String; ! Parameter : String; ! Section : String := ""); -- Remove a switch with a specific parameter. If Parameter is the empty -- string, then only a switch with no parameter will be removed. --------------- ! -- Iteration -- --------------- type Command_Line_Iterator is private; *************** package GNAT.Command_Line is *** 614,619 **** --- 685,692 ---- -- call to Add_Switch, Remove_Switch or Set_Command_Line. function Current_Switch (Iter : Command_Line_Iterator) return String; + function Is_New_Section (Iter : Command_Line_Iterator) return Boolean; + function Current_Section (Iter : Command_Line_Iterator) return String; function Current_Separator (Iter : Command_Line_Iterator) return String; function Current_Parameter (Iter : Command_Line_Iterator) return String; -- Return the current switch and its parameter (or the empty string if *************** private *** 738,746 **** Prefixes : GNAT.OS_Lib.Argument_List_Access; -- The list of prefixes Aliases : GNAT.OS_Lib.Argument_List_Access; Expansions : GNAT.OS_Lib.Argument_List_Access; ! -- The aliases. Both arrays have the same indices end record; type Command_Line_Configuration is access Command_Line_Configuration_Record; --- 811,825 ---- Prefixes : GNAT.OS_Lib.Argument_List_Access; -- The list of prefixes + Sections : GNAT.OS_Lib.Argument_List_Access; + -- The list of sections + Aliases : GNAT.OS_Lib.Argument_List_Access; Expansions : GNAT.OS_Lib.Argument_List_Access; ! -- The aliases (Both arrays have the same bounds) ! ! Switches : GNAT.OS_Lib.Argument_List_Access; ! -- List of expected switches (Used when expanding switch groups) end record; type Command_Line_Configuration is access Command_Line_Configuration_Record; *************** private *** 750,768 **** Params : GNAT.OS_Lib.Argument_List_Access; -- Parameter for the corresponding switch in Expanded. The first ! -- character is the separator (or ASCII.NUL if there is no separator) ! Coalesce : GNAT.OS_Lib.Argument_List_Access; ! Coalesce_Params : GNAT.OS_Lib.Argument_List_Access; ! -- Cached version of the command line. This is recomputed every time the ! -- command line changes. Switches are grouped as much as possible, and ! -- aliases are used to reduce the length of the command line. ! -- The parameters are not allocated, they point into Params, so must not ! -- be freed. end record; type Command_Line_Iterator is record List : GNAT.OS_Lib.Argument_List_Access; Params : GNAT.OS_Lib.Argument_List_Access; Current : Natural; end record; --- 829,852 ---- Params : GNAT.OS_Lib.Argument_List_Access; -- Parameter for the corresponding switch in Expanded. The first ! -- character is the separator (or ASCII.NUL if there is no separator). ! Sections : GNAT.OS_Lib.Argument_List_Access; ! -- The list of sections ! ! Coalesce : GNAT.OS_Lib.Argument_List_Access; ! Coalesce_Params : GNAT.OS_Lib.Argument_List_Access; ! Coalesce_Sections : GNAT.OS_Lib.Argument_List_Access; ! -- Cached version of the command line. This is recomputed every time ! -- the command line changes. Switches are grouped as much as possible, ! -- and aliases are used to reduce the length of the command line. The ! -- parameters are not allocated, they point into Params, so they must ! -- not be freed. end record; type Command_Line_Iterator is record List : GNAT.OS_Lib.Argument_List_Access; + Sections : GNAT.OS_Lib.Argument_List_Access; Params : GNAT.OS_Lib.Argument_List_Access; Current : Natural; end record; diff -Nrcpad gcc-4.3.3/gcc/ada/g-comver.adb gcc-4.4.0/gcc/ada/g-comver.adb *** gcc-4.3.3/gcc/ada/g-comver.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/g-comver.adb Fri Feb 20 15:20:38 2009 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2005,2008 AdaCore -- -- -- -- 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,43 **** package body GNAT.Compiler_Version is ! Ver_Len_Max : constant := 32; -- This is logically a reference to Gnatvsn.Ver_Len_Max but we cannot -- import this directly since run-time units cannot WITH compiler units. --- 37,43 ---- package body GNAT.Compiler_Version is ! Ver_Len_Max : constant := 64; -- This is logically a reference to Gnatvsn.Ver_Len_Max but we cannot -- import this directly since run-time units cannot WITH compiler units. *************** package body GNAT.Compiler_Version is *** 53,67 **** function Version return String is begin ! -- Search for terminating right paren for J in Ver_Prefix'Length + 1 .. GNAT_Version'Last loop if GNAT_Version (J) = ')' then return GNAT_Version (Ver_Prefix'Length + 1 .. J); end if; end loop; ! -- This should not happen (no right paren found) return GNAT_Version; end Version; --- 53,70 ---- function Version return String is begin ! -- Search for terminating right paren or NUL ending the string for J in Ver_Prefix'Length + 1 .. GNAT_Version'Last loop if GNAT_Version (J) = ')' then return GNAT_Version (Ver_Prefix'Length + 1 .. J); end if; + if GNAT_Version (J) = Character'Val (0) then + return GNAT_Version (Ver_Prefix'Length + 1 .. J - 1); + end if; end loop; ! -- This should not happen (no right paren or NUL found) return GNAT_Version; end Version; diff -Nrcpad gcc-4.3.3/gcc/ada/g-curexc.ads gcc-4.4.0/gcc/ada/g-curexc.ads *** gcc-4.3.3/gcc/ada/g-curexc.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/g-curexc.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2008, AdaCore -- -- -- -- 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- -- *************** package GNAT.Current_Exception is *** 50,56 **** -- Subprograms -- ----------------- ! -- Note: the lower bound of returnd String values is always one function Exception_Information return String; -- Returns the result of calling Ada.Exceptions.Exception_Information --- 50,56 ---- -- Subprograms -- ----------------- ! -- Note: the lower bound of returned String values is always one function Exception_Information return String; -- Returns the result of calling Ada.Exceptions.Exception_Information *************** package GNAT.Current_Exception is *** 95,101 **** -- For greater compatibility with existing legacy software, library -- level renaming may be used to create a function with a name matching -- one that is in use. For example, some versions of VADS Ada provided ! -- a functin called Current_Exception whose semantics was identical to -- that of GNAT. The following library level renaming declaration: -- with GNAT.Current_Exception; --- 95,101 ---- -- For greater compatibility with existing legacy software, library -- level renaming may be used to create a function with a name matching -- one that is in use. For example, some versions of VADS Ada provided ! -- a function called Current_Exception whose semantics was identical to -- that of GNAT. The following library level renaming declaration: -- with GNAT.Current_Exception; diff -Nrcpad gcc-4.3.3/gcc/ada/g-debpoo.adb gcc-4.4.0/gcc/ada/g-debpoo.adb *** gcc-4.3.3/gcc/ada/g-debpoo.adb Wed Jun 6 10:29:21 2007 --- gcc-4.4.0/gcc/ada/g-debpoo.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body GNAT.Debug_Pools is *** 49,55 **** Default_Alignment : constant := Standard'Maximum_Alignment; -- Alignment used for the memory chunks returned by Allocate. Using this ! -- value garantees that this alignment will be compatible with all types -- and at the same time makes it easy to find the location of the extra -- header allocated for each chunk. --- 47,53 ---- Default_Alignment : constant := Standard'Maximum_Alignment; -- Alignment used for the memory chunks returned by Allocate. Using this ! -- value guarantees that this alignment will be compatible with all types -- and at the same time makes it easy to find the location of the extra -- header allocated for each chunk. *************** package body GNAT.Debug_Pools is *** 286,295 **** Ignored_Frame_Start : System.Address; Ignored_Frame_End : System.Address); -- Set Start .. Len to the range of values from Trace that should be output ! -- to the user. This range of values exludes any address prior to the first ! -- one in Ignored_Frame_Start .. Ignored_Frame_End (basically addresses ! -- internal to this package). Depth is the number of levels that the user ! -- is interested in. --------------- -- Header_Of -- --- 284,293 ---- Ignored_Frame_Start : System.Address; Ignored_Frame_End : System.Address); -- Set Start .. Len to the range of values from Trace that should be output ! -- to the user. This range of values excludes any address prior to the ! -- first one in Ignored_Frame_Start .. Ignored_Frame_End (basically ! -- addresses internal to this package). Depth is the number of levels that ! -- the user is interested in. --------------- -- Header_Of -- *************** package body GNAT.Debug_Pools is *** 579,585 **** begin -- The pool only returns addresses aligned on Default_Alignment so -- anything off cannot be a valid block address and we can return ! -- early in this case. We actually have to since our datastructures -- map validity bits for such aligned addresses only. if Int_Storage mod Default_Alignment /= 0 then --- 577,583 ---- begin -- The pool only returns addresses aligned on Default_Alignment so -- anything off cannot be a valid block address and we can return ! -- early in this case. We actually have to since our data structures -- map validity bits for such aligned addresses only. if Int_Storage mod Default_Alignment /= 0 then *************** package body GNAT.Debug_Pools is *** 692,698 **** Free_Physically (Pool); end if; ! -- Use standard (ie through malloc) allocations. This automatically -- raises Storage_Error if needed. We also try once more to physically -- release memory, so that even marked blocks, in the advanced scanning, -- are freed. --- 690,696 ---- Free_Physically (Pool); end if; ! -- Use standard (i.e. through malloc) allocations. This automatically -- raises Storage_Error if needed. We also try once more to physically -- release memory, so that even marked blocks, in the advanced scanning, -- are freed. *************** package body GNAT.Debug_Pools is *** 1388,1394 **** if Pool.Marked_Blocks_Deallocated then Put_Line ("Marked blocks were physically deallocated. This is"); ! Put_Line ("potentially dangereous, and you might want to run"); Put_Line ("again with a lower value of Minimum_To_Free"); end if; --- 1386,1392 ---- if Pool.Marked_Blocks_Deallocated then Put_Line ("Marked blocks were physically deallocated. This is"); ! Put_Line ("potentially dangerous, and you might want to run"); Put_Line ("again with a lower value of Minimum_To_Free"); end if; diff -Nrcpad gcc-4.3.3/gcc/ada/g-debpoo.ads gcc-4.4.0/gcc/ada/g-debpoo.ads *** gcc-4.3.3/gcc/ada/g-debpoo.ads Wed Jun 6 10:29:21 2007 --- gcc-4.4.0/gcc/ada/g-debpoo.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package GNAT.Debug_Pools is *** 253,259 **** -- the Debug_Pool). -- -- The information includes the stacktrace for the allocation or ! -- deallocation of that memory chunck, its current status (allocated or -- logically freed), etc. private --- 251,257 ---- -- the Debug_Pool). -- -- The information includes the stacktrace for the allocation or ! -- deallocation of that memory chunk, its current status (allocated or -- logically freed), etc. private *************** private *** 288,294 **** Storage_Address : System.Address; Size_In_Storage_Elements : Storage_Count; Alignment : Storage_Count); ! -- Check whether a derefence statement is valid, ie whether the pointer -- was allocated through Pool. As documented above, errors will be -- reported either by a special error message or an exception, depending -- on the setup of the storage pool. --- 286,292 ---- Storage_Address : System.Address; Size_In_Storage_Elements : Storage_Count; Alignment : Storage_Count); ! -- Check whether a dereference statement is valid, i.e. whether the pointer -- was allocated through Pool. As documented above, errors will be -- reported either by a special error message or an exception, depending -- on the setup of the storage pool. *************** private *** 296,302 **** type Byte_Count is mod System.Max_Binary_Modulus; -- Type used for maintaining byte counts, needs to be large enough ! -- to accomodate counts allowing for repeated use of the same memory. type Debug_Pool is new System.Checked_Pools.Checked_Pool with record Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth; --- 294,300 ---- type Byte_Count is mod System.Max_Binary_Modulus; -- Type used for maintaining byte counts, needs to be large enough ! -- to accommodate counts allowing for repeated use of the same memory. type Debug_Pool is new System.Checked_Pools.Checked_Pool with record Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth; *************** private *** 322,328 **** Marked_Blocks_Deallocated : Boolean := False; -- Set to true if some mark blocks had to be deallocated in the advanced ! -- scanning scheme. Since this is potentially dangereous, this is -- reported to the user, who might want to rerun his program with a -- lower Minimum_To_Free value. --- 320,326 ---- Marked_Blocks_Deallocated : Boolean := False; -- Set to true if some mark blocks had to be deallocated in the advanced ! -- scanning scheme. Since this is potentially dangerous, this is -- reported to the user, who might want to rerun his program with a -- lower Minimum_To_Free value. diff -Nrcpad gcc-4.3.3/gcc/ada/g-decstr.adb gcc-4.4.0/gcc/ada/g-decstr.adb *** gcc-4.3.3/gcc/ada/g-decstr.adb Thu Dec 13 10:29:24 2007 --- gcc-4.4.0/gcc/ada/g-decstr.adb Tue Apr 8 06:57:39 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Decode_String is *** 391,397 **** end if; end UTF8; ! -- Non-UTF-8 cass else declare --- 391,397 ---- end if; end UTF8; ! -- Non-UTF-8 case else declare *************** package body GNAT.Decode_String is *** 502,508 **** end if; end UTF8; ! -- Non-UTF-8 cass else declare --- 502,508 ---- end if; end UTF8; ! -- Non-UTF-8 case else declare *************** package body GNAT.Decode_String is *** 923,929 **** end loop; exception ! when Constraint_Error => Bad; end Non_UTF8_Brackets; end if; --- 923,929 ---- end loop; exception ! when Constraint_Error => Bad; end Non_UTF8_Brackets; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/g-diopit.adb gcc-4.4.0/gcc/ada/g-diopit.adb *** gcc-4.3.3/gcc/ada/g-diopit.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/g-diopit.adb Fri Feb 20 15:20:38 2009 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Directory_Operations.I *** 376,382 **** end; -- Exit if Quit set by call to Action, either at this level ! -- or at at some lower recursive call to Next_Level. exit Dir_Iterator when Quit; end loop Dir_Iterator; --- 376,382 ---- end; -- Exit if Quit set by call to Action, either at this level ! -- or at some lower recursive call to Next_Level. exit Dir_Iterator when Quit; end loop Dir_Iterator; diff -Nrcpad gcc-4.3.3/gcc/ada/g-dirope.adb gcc-4.4.0/gcc/ada/g-dirope.adb *** gcc-4.3.3/gcc/ada/g-dirope.adb Thu Dec 13 10:27:07 2007 --- gcc-4.4.0/gcc/ada/g-dirope.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Directory_Operations i *** 46,55 **** use Ada; - type Dir_Type_Value is new System.Address; - -- This is the low-level address directory structure as returned by the C - -- opendir routine. - Filename_Max : constant Integer := 1024; -- 1024 is the value of FILENAME_MAX in stdio.h --- 46,51 ---- *************** package body GNAT.Directory_Operations i *** 419,425 **** E := K; ! -- Check that first chartacter is a letter if Characters.Handling.Is_Letter (Path (E)) then E := E + 1; --- 415,421 ---- E := K; ! -- Check that first character is a letter if Characters.Handling.Is_Letter (Path (E)) then E := E + 1; diff -Nrcpad gcc-4.3.3/gcc/ada/g-dirope.ads gcc-4.4.0/gcc/ada/g-dirope.ads *** gcc-4.3.3/gcc/ada/g-dirope.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/g-dirope.ads Tue Apr 8 06:57:39 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2008, AdaCore -- -- -- -- 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,48 **** --- 43,49 ---- -- directory names (OpenVMS native directory format is not supported). -- Read individual entries for more specific notes on OpenVMS support. + with System; with Ada.Strings.Maps; package GNAT.Directory_Operations is *************** package GNAT.Directory_Operations is *** 131,137 **** -- is equivalent to the UNIX basename command. The following rule is -- always true: -- ! -- 'Path' and 'Dir_Name (Path) & Directory_Separator & Base_Name (Path)' -- represent the same file. -- -- The comparison of Suffix is case-insensitive on systems such as Windows --- 132,138 ---- -- is equivalent to the UNIX basename command. The following rule is -- always true: -- ! -- 'Path' and 'Dir_Name (Path) & Dir_Separator & Base_Name (Path)' -- represent the same file. -- -- The comparison of Suffix is case-insensitive on systems such as Windows *************** package GNAT.Directory_Operations is *** 222,228 **** -- Dir will be set to Null_Dir. procedure Close (Dir : in out Dir_Type); ! -- Closes the directory stream refered to by Dir. After calling Close -- Is_Open will return False. Dir will be set to Null_Dir. -- Raises Directory_Error if Dir has not be opened (Dir = Null_Dir). --- 223,229 ---- -- Dir will be set to Null_Dir. procedure Close (Dir : in out Dir_Type); ! -- Closes the directory stream referred to by Dir. After calling Close -- Is_Open will return False. Dir will be set to Null_Dir. -- Raises Directory_Error if Dir has not be opened (Dir = Null_Dir). *************** package GNAT.Directory_Operations is *** 254,260 **** private ! type Dir_Type_Value; type Dir_Type is access Dir_Type_Value; Null_Dir : constant Dir_Type := null; --- 255,269 ---- private ! type Dir_Type_Value is new System.Address; ! -- Low-level address directory structure as returned by opendir in C ! -- ! -- Note that we used to define this type in the body of this package, ! -- but this was causing troubles in the context of .NET code generation ! -- (because Taft amendment types are not fully implemented and cause ! -- undefined references to the class), so we moved the type declaration ! -- to the spec's private part, which is no problem in any case here. ! type Dir_Type is access Dir_Type_Value; Null_Dir : constant Dir_Type := null; diff -Nrcpad gcc-4.3.3/gcc/ada/g-dynhta.ads gcc-4.4.0/gcc/ada/g-dynhta.ads *** gcc-4.3.3/gcc/ada/g-dynhta.ads Mon Sep 5 08:07:00 2005 --- gcc-4.4.0/gcc/ada/g-dynhta.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- 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- -- *************** package GNAT.Dynamic_HTables is *** 130,136 **** function Get_Next (T : Instance) return Elmt_Ptr; -- Returns a non-specified element that has not been returned by the -- same function since the last call to Get_First or Null_Ptr if ! -- there is no such element or Get_First has bever been called. If -- there is no call to 'Set' in between Get_Next calls, all the -- elements of the Htable will be traversed. --- 130,136 ---- function Get_Next (T : Instance) return Elmt_Ptr; -- Returns a non-specified element that has not been returned by the -- same function since the last call to Get_First or Null_Ptr if ! -- there is no such element or Get_First has never been called. If -- there is no call to 'Set' in between Get_Next calls, all the -- elements of the Htable will be traversed. diff -Nrcpad gcc-4.3.3/gcc/ada/g-dyntab.adb gcc-4.4.0/gcc/ada/g-dyntab.adb *** gcc-4.3.3/gcc/ada/g-dyntab.adb Thu Aug 16 12:19:02 2007 --- gcc-4.4.0/gcc/ada/g-dyntab.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Dynamic_Tables is *** 257,263 **** -- checks are suppressed because this unit uses direct calls to -- System.Memory for allocation, and this can yield misaligned storage -- (and we cannot rely on the bootstrap compiler supporting specifically ! -- disabling alignment cheks, so we need to suppress all range checks). -- It is safe to suppress this check here because we know that a -- (possibly misaligned) object of that type does actually exist at that -- address. --- 257,263 ---- -- checks are suppressed because this unit uses direct calls to -- System.Memory for allocation, and this can yield misaligned storage -- (and we cannot rely on the bootstrap compiler supporting specifically ! -- disabling alignment checks, so we need to suppress all range checks). -- It is safe to suppress this check here because we know that a -- (possibly misaligned) object of that type does actually exist at that -- address. *************** package body GNAT.Dynamic_Tables is *** 269,275 **** -- involve moving table contents around). begin ! -- If we're going to reallocate, check wheter Item references an -- element of the currently allocated table. if Need_Realloc --- 269,275 ---- -- involve moving table contents around). begin ! -- If we're going to reallocate, check whether Item references an -- element of the currently allocated table. if Need_Realloc diff -Nrcpad gcc-4.3.3/gcc/ada/g-dyntab.ads gcc-4.4.0/gcc/ada/g-dyntab.ads *** gcc-4.3.3/gcc/ada/g-dyntab.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/g-dyntab.ads Tue Apr 8 06:48:30 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2006, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2008, AdaCore -- -- -- -- 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- -- *************** package GNAT.Dynamic_Tables is *** 91,107 **** type Table_Type is array (Table_Index_Type range <>) of Table_Component_Type; - subtype Big_Table_Type is Table_Type (Table_Low_Bound .. Table_Index_Type'Last); ! -- We work with pointers to a bogus array type that is constrained ! -- with the maximum possible range bound. This means that the pointer ! -- is a thin pointer, which is more efficient. Since subscript checks ! -- in any case must be on the logical, rather than physical bounds, ! -- safety is not compromised by this approach. type Table_Ptr is access all Big_Table_Type; ! -- The table is actually represented as a pointer to allow reallocation type Table_Private is private; -- Table private data that is not exported in Instance --- 91,109 ---- type Table_Type is array (Table_Index_Type range <>) of Table_Component_Type; subtype Big_Table_Type is Table_Type (Table_Low_Bound .. Table_Index_Type'Last); ! -- We work with pointers to a bogus array type that is constrained with ! -- the maximum possible range bound. This means that the pointer is a thin ! -- pointer, which is more efficient. Since subscript checks in any case ! -- must be on the logical, rather than physical bounds, safety is not ! -- compromised by this approach. These types should not be used by the ! -- client. type Table_Ptr is access all Big_Table_Type; ! for Table_Ptr'Storage_Size use 0; ! -- The table is actually represented as a pointer to allow reallocation. ! -- This type should not be used by the client. type Table_Private is private; -- Table private data that is not exported in Instance diff -Nrcpad gcc-4.3.3/gcc/ada/g-eacodu-vms.adb gcc-4.4.0/gcc/ada/g-eacodu-vms.adb *** gcc-4.3.3/gcc/ada/g-eacodu-vms.adb Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/g-eacodu-vms.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-eacodu.adb gcc-4.4.0/gcc/ada/g-eacodu.adb *** gcc-4.3.3/gcc/ada/g-eacodu.adb Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/g-eacodu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-enblsp-vms-alpha.adb gcc-4.4.0/gcc/ada/g-enblsp-vms-alpha.adb *** gcc-4.3.3/gcc/ada/g-enblsp-vms-alpha.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/g-enblsp-vms-alpha.adb Tue Apr 8 06:44:39 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2008, AdaCore -- -- -- -- 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- -- *************** begin *** 91,103 **** Arg := new String (1 .. Command_With_Path'Length + 1); Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; ! Arg (Arg'Last) := ASCII.Nul; Arg_List (1) := Arg.all'Address; for J in Args'Range loop Arg := new String (1 .. Args (J)'Length + 1); Arg (1 .. Args (J)'Length) := Args (J).all; ! Arg (Arg'Last) := ASCII.Nul; Arg_List (J + 2 - Args'First) := Arg.all'Address; end loop; --- 91,103 ---- Arg := new String (1 .. Command_With_Path'Length + 1); Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; ! Arg (Arg'Last) := ASCII.NUL; Arg_List (1) := Arg.all'Address; for J in Args'Range loop Arg := new String (1 .. Args (J)'Length + 1); Arg (1 .. Args (J)'Length) := Args (J).all; ! Arg (Arg'Last) := ASCII.NUL; Arg_List (J + 2 - Args'First) := Arg.all'Address; end loop; diff -Nrcpad gcc-4.3.3/gcc/ada/g-enblsp-vms-ia64.adb gcc-4.4.0/gcc/ada/g-enblsp-vms-ia64.adb *** gcc-4.3.3/gcc/ada/g-enblsp-vms-ia64.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/g-enblsp-vms-ia64.adb Tue Apr 8 06:44:39 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2008, AdaCore -- -- -- -- 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- -- *************** begin *** 89,101 **** Arg := new String (1 .. Command_With_Path'Length + 1); Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; ! Arg (Arg'Last) := ASCII.Nul; Arg_List (1) := Arg.all'Address; for J in Args'Range loop Arg := new String (1 .. Args (J)'Length + 1); Arg (1 .. Args (J)'Length) := Args (J).all; ! Arg (Arg'Last) := ASCII.Nul; Arg_List (J + 2 - Args'First) := Arg.all'Address; end loop; --- 89,101 ---- Arg := new String (1 .. Command_With_Path'Length + 1); Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; ! Arg (Arg'Last) := ASCII.NUL; Arg_List (1) := Arg.all'Address; for J in Args'Range loop Arg := new String (1 .. Args (J)'Length + 1); Arg (1 .. Args (J)'Length) := Args (J).all; ! Arg (Arg'Last) := ASCII.NUL; Arg_List (J + 2 - Args'First) := Arg.all'Address; end loop; diff -Nrcpad gcc-4.3.3/gcc/ada/g-encstr.ads gcc-4.4.0/gcc/ada/g-encstr.ads *** gcc-4.3.3/gcc/ada/g-encstr.ads Thu Dec 13 10:29:24 2007 --- gcc-4.4.0/gcc/ada/g-encstr.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007-2008, AdaCore -- -- -- -- 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- -- *************** *** 35,41 **** -- Wide_String or Wide_Wide_String to encoded String using a specified -- encoding convention, which is supplied as the generic parameter. If -- this parameter is a known at compile time constant (e.g. a constant ! -- definned in System.WCh_Con), the instantiation is specialized so that -- it applies only to this specified coding. -- Note: this package is only about encoding sequences of 16- or 32-bit --- 35,41 ---- -- Wide_String or Wide_Wide_String to encoded String using a specified -- encoding convention, which is supplied as the generic parameter. If -- this parameter is a known at compile time constant (e.g. a constant ! -- defined in System.WCh_Con), the instantiation is specialized so that -- it applies only to this specified coding. -- Note: this package is only about encoding sequences of 16- or 32-bit *************** package GNAT.Encode_String is *** 66,72 **** pragma Inline (Encode_Wide_String); -- Encode the given Wide_String, returning a String encoded using the -- given encoding method. Constraint_Error will be raised if the encoding ! -- method cannot accomodate the input data. procedure Encode_Wide_String (S : Wide_String; --- 66,72 ---- pragma Inline (Encode_Wide_String); -- Encode the given Wide_String, returning a String encoded using the -- given encoding method. Constraint_Error will be raised if the encoding ! -- method cannot accommodate the input data. procedure Encode_Wide_String (S : Wide_String; *************** package GNAT.Encode_String is *** 78,84 **** -- in System.WCh_Con: WC_Longest_Sequence, WC_Longest_Sequences). If the -- length of Result is insufficient Constraint_Error will be raised. -- Constraint_Error will also be raised if the encoding method cannot ! -- accomodate the input data. function Encode_Wide_Wide_String (S : Wide_Wide_String) return String; pragma Inline (Encode_Wide_Wide_String); --- 78,84 ---- -- in System.WCh_Con: WC_Longest_Sequence, WC_Longest_Sequences). If the -- length of Result is insufficient Constraint_Error will be raised. -- Constraint_Error will also be raised if the encoding method cannot ! -- accommodate the input data. function Encode_Wide_Wide_String (S : Wide_Wide_String) return String; pragma Inline (Encode_Wide_Wide_String); *************** package GNAT.Encode_String is *** 98,105 **** -- This is a lower level procedure that encodes the single character Char. -- The output is stored in Result starting at Result (Ptr), and Ptr is -- updated past the stored value. Constraint_Error is raised if Result ! -- is not long enough to accomodate the result, or if the encoding method ! -- specified does not accomodate the input character value, or if Ptr is -- outside the bounds of the Result string. procedure Encode_Wide_Wide_Character --- 98,105 ---- -- This is a lower level procedure that encodes the single character Char. -- The output is stored in Result starting at Result (Ptr), and Ptr is -- updated past the stored value. Constraint_Error is raised if Result ! -- is not long enough to accommodate the result, or if the encoding method ! -- specified does not accommodate the input character value, or if Ptr is -- outside the bounds of the Result string. procedure Encode_Wide_Wide_Character diff -Nrcpad gcc-4.3.3/gcc/ada/g-excact.adb gcc-4.4.0/gcc/ada/g-excact.adb *** gcc-4.3.3/gcc/ada/g-excact.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/g-excact.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-excact.ads gcc-4.4.0/gcc/ada/g-excact.ads *** gcc-4.3.3/gcc/ada/g-excact.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/g-excact.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 35,41 **** -- These callbacks are called immediately when either a specific exception, -- or any exception, is raised, before any other actions taken by raise, in ! -- particular before any unwinding of the stack occcurs. -- Callbacks for specific exceptions are registered through calls to -- Register_Id_Action. Here is an example of code that uses this package to --- 33,39 ---- -- These callbacks are called immediately when either a specific exception, -- or any exception, is raised, before any other actions taken by raise, in ! -- particular before any unwinding of the stack occurs. -- Callbacks for specific exceptions are registered through calls to -- Register_Id_Action. Here is an example of code that uses this package to diff -Nrcpad gcc-4.3.3/gcc/ada/g-except.ads gcc-4.4.0/gcc/ada/g-except.ads *** gcc-4.3.3/gcc/ada/g-except.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/g-except.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2008, AdaCore -- -- -- -- 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- -- *************** *** 39,45 **** -- However, it is not normally possible to raise an exception with a -- message because the routine Ada.Exceptions.Raise_Exception is not in ! -- a Pure unit. This is an annoying and unnecessary restrictiona and this -- package allows for raising the standard predefined exceptions at least. package GNAT.Exceptions is --- 39,45 ---- -- However, it is not normally possible to raise an exception with a -- message because the routine Ada.Exceptions.Raise_Exception is not in ! -- a Pure unit. This is an annoying and unnecessary restriction and this -- package allows for raising the standard predefined exceptions at least. package GNAT.Exceptions is diff -Nrcpad gcc-4.3.3/gcc/ada/g-exctra.ads gcc-4.4.0/gcc/ada/g-exctra.ads *** gcc-4.3.3/gcc/ada/g-exctra.ads Fri Dec 9 17:22:27 2005 --- gcc-4.4.0/gcc/ada/g-exctra.ads Tue Apr 8 06:57:39 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2008, AdaCore -- -- -- -- 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- -- *************** *** 48,53 **** --- 48,54 ---- -- The backtrace output can also be customized by way of a "decorator" which -- may return any string output in association with a provided call chain. + -- The decorator replaces the default backtrace mentioned above. with GNAT.Traceback; use GNAT.Traceback; *************** package GNAT.Exception_Traces is *** 89,93 **** --- 90,98 ---- -- Set the decorator to be used for future automatic outputs. Restore -- the default behavior (output of raw addresses) if the provided -- access value is null. + -- + -- Note: GNAT.Traceback.Symbolic.Symbolic_Traceback may be used as the + -- Decorator, to get a symbolic traceback. This will cause a significant + -- cpu and memory overhead. end GNAT.Exception_Traces; diff -Nrcpad gcc-4.3.3/gcc/ada/g-expect-vms.adb gcc-4.4.0/gcc/ada/g-expect-vms.adb *** gcc-4.3.3/gcc/ada/g-expect-vms.adb Wed Dec 19 16:22:02 2007 --- gcc-4.4.0/gcc/ada/g-expect-vms.adb Tue Apr 8 06:44:39 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Expect is *** 1109,1115 **** Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); ! Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.Nul, Args); end Set_Up_Child_Communications; --------------------------- --- 1109,1115 ---- Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); ! Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.NUL, Args); end Set_Up_Child_Communications; --------------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/g-expect.adb gcc-4.4.0/gcc/ada/g-expect.adb *** gcc-4.3.3/gcc/ada/g-expect.adb Wed Dec 19 16:22:02 2007 --- gcc-4.4.0/gcc/ada/g-expect.adb Tue Apr 8 06:44:39 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Expect is *** 1220,1226 **** Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); ! Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.Nul, Args); -- The following commands are not executed on Unix systems, and are -- only required for Windows systems. We are now in the parent process. --- 1220,1226 ---- Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); ! Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.NUL, Args); -- The following commands are not executed on Unix systems, and are -- only required for Windows systems. We are now in the parent process. diff -Nrcpad gcc-4.3.3/gcc/ada/g-expect.ads gcc-4.4.0/gcc/ada/g-expect.ads *** gcc-4.3.3/gcc/ada/g-expect.ads Wed Jun 6 10:14:25 2007 --- gcc-4.4.0/gcc/ada/g-expect.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2008, AdaCore -- -- -- -- 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- -- *************** package GNAT.Expect is *** 176,182 **** -- this buffer is full. Beware that if the buffer is too big, this could -- slow down the Expect calls if not output is matched, since Expect has -- to match all the regexp against all the characters in the buffer. ! -- If Buffer_Size is 0, there is no limit (ie all the characters are kept -- till Expect matches), but this is slower. -- -- If Err_To_Out is True, then the standard error of the spawned process is --- 176,182 ---- -- this buffer is full. Beware that if the buffer is too big, this could -- slow down the Expect calls if not output is matched, since Expect has -- to match all the regexp against all the characters in the buffer. ! -- If Buffer_Size is 0, there is no limit (i.e. all the characters are kept -- till Expect matches), but this is slower. -- -- If Err_To_Out is True, then the standard error of the spawned process is *************** package GNAT.Expect is *** 221,227 **** function Get_Pid (Descriptor : Process_Descriptor) return Process_Id; ! -- Return the process id assocated with a given process descriptor function Get_Command_Output (Command : String; --- 221,227 ---- function Get_Pid (Descriptor : Process_Descriptor) return Process_Id; ! -- Return the process id associated with a given process descriptor function Get_Command_Output (Command : String; *************** package GNAT.Expect is *** 410,416 **** return Pattern_Matcher_Access; -- Allocate some memory for the pattern matcher. -- This is only a convenience function to help create the array of ! -- compiled regular expressoins. procedure Expect (Descriptor : in out Process_Descriptor; --- 410,416 ---- return Pattern_Matcher_Access; -- Allocate some memory for the pattern matcher. -- This is only a convenience function to help create the array of ! -- compiled regular expressions. procedure Expect (Descriptor : in out Process_Descriptor; diff -Nrcpad gcc-4.3.3/gcc/ada/g-heasor.adb gcc-4.4.0/gcc/ada/g-heasor.adb *** gcc-4.3.3/gcc/ada/g-heasor.adb Mon Sep 5 08:07:00 2005 --- gcc-4.4.0/gcc/ada/g-heasor.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Heap_Sort is *** 74,80 **** -- we assume that the current node will be less than the larger -- son, and unconditionally sift up. Then when we get to the bottom -- of the tree, we check parents to make sure that we did not make ! -- a mistake. This roughly cuts the number of comparisions in half, -- since it is almost always the case that our assumption is correct. -- Loop to pull up larger sons --- 74,80 ---- -- we assume that the current node will be less than the larger -- son, and unconditionally sift up. Then when we get to the bottom -- of the tree, we check parents to make sure that we did not make ! -- a mistake. This roughly cuts the number of comparisons in half, -- since it is almost always the case that our assumption is correct. -- Loop to pull up larger sons diff -Nrcpad gcc-4.3.3/gcc/ada/g-heasor.ads gcc-4.4.0/gcc/ada/g-heasor.ads *** gcc-4.3.3/gcc/ada/g-heasor.ads Wed Jun 6 10:28:31 2007 --- gcc-4.4.0/gcc/ada/g-heasor.ads Mon May 26 09:40:55 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2006, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- 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,51 **** -- See also GNAT.Heap_Sort_G which is a generic version that will be faster -- since the overhead of the indirect calls is avoided, at the expense of ! -- generic code duplication and less convenient interface. The generic version ! -- also has the advantage of being Pure, while this unit can only be ! -- Preelaborate, because of the access types. -- Note: GNAT.Heap_Sort replaces and obsoletes GNAT.Heap_Sort_A, which is -- retained in the GNAT library for backwards compatibility. --- 43,49 ---- -- See also GNAT.Heap_Sort_G which is a generic version that will be faster -- since the overhead of the indirect calls is avoided, at the expense of ! -- generic code duplication and less convenient interface. -- Note: GNAT.Heap_Sort replaces and obsoletes GNAT.Heap_Sort_A, which is -- retained in the GNAT library for backwards compatibility. diff -Nrcpad gcc-4.3.3/gcc/ada/g-hesora.adb gcc-4.4.0/gcc/ada/g-hesora.adb *** gcc-4.3.3/gcc/ada/g-hesora.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/g-hesora.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Heap_Sort_A is *** 76,82 **** -- we assume that the current node will be less than the larger -- son, and unconditionally sift up. Then when we get to the bottom -- of the tree, we check parents to make sure that we did not make ! -- a mistake. This roughly cuts the number of comparisions in half, -- since it is almost always the case that our assumption is correct. -- Loop to pull up larger sons --- 76,82 ---- -- we assume that the current node will be less than the larger -- son, and unconditionally sift up. Then when we get to the bottom -- of the tree, we check parents to make sure that we did not make ! -- a mistake. This roughly cuts the number of comparisons in half, -- since it is almost always the case that our assumption is correct. -- Loop to pull up larger sons diff -Nrcpad gcc-4.3.3/gcc/ada/g-hesorg.adb gcc-4.4.0/gcc/ada/g-hesorg.adb *** gcc-4.3.3/gcc/ada/g-hesorg.adb Mon Sep 5 08:07:00 2005 --- gcc-4.4.0/gcc/ada/g-hesorg.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Heap_Sort_G is *** 79,85 **** -- we assume that the current node will be less than the larger -- son, and unconditionally sift up. Then when we get to the bottom -- of the tree, we check parents to make sure that we did not make ! -- a mistake. This roughly cuts the number of comparisions in half, -- since it is almost always the case that our assumption is correct. -- Loop to pull up larger sons --- 79,85 ---- -- we assume that the current node will be less than the larger -- son, and unconditionally sift up. Then when we get to the bottom -- of the tree, we check parents to make sure that we did not make ! -- a mistake. This roughly cuts the number of comparisons in half, -- since it is almost always the case that our assumption is correct. -- Loop to pull up larger sons diff -Nrcpad gcc-4.3.3/gcc/ada/g-htable.ads gcc-4.4.0/gcc/ada/g-htable.ads *** gcc-4.3.3/gcc/ada/g-htable.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/g-htable.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- 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- -- *************** package GNAT.HTable is *** 196,202 **** -- function Get_Next return Elmt_Ptr; -- -- Returns a non-specified element that has not been returned by -- -- the same function since the last call to Get_First or Null_Ptr ! -- -- if there is no such element or Get_First has bever been called. -- -- If there is no call to 'Set' in between Get_Next calls, all -- -- the elements of the HTable will be traversed. --- 196,202 ---- -- function Get_Next return Elmt_Ptr; -- -- Returns a non-specified element that has not been returned by -- -- the same function since the last call to Get_First or Null_Ptr ! -- -- if there is no such element or Get_First has never been called. -- -- If there is no call to 'Set' in between Get_Next calls, all -- -- the elements of the HTable will be traversed. diff -Nrcpad gcc-4.3.3/gcc/ada/g-locfil.adb gcc-4.4.0/gcc/ada/g-locfil.adb *** gcc-4.3.3/gcc/ada/g-locfil.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/g-locfil.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2001 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body GNAT.Lock_Files is *** 61,67 **** if Directory (Directory'Last) = Dir_Separator or else Directory (Directory'Last) = '/' then ! Dir (Dir'Last - 1) := ASCII.Nul; end if; -- Try to lock the file Retries times --- 59,65 ---- if Directory (Directory'Last) = Dir_Separator or else Directory (Directory'Last) = '/' then ! Dir (Dir'Last - 1) := ASCII.NUL; end if; -- Try to lock the file Retries times diff -Nrcpad gcc-4.3.3/gcc/ada/g-locfil.ads gcc-4.4.0/gcc/ada/g-locfil.ads *** gcc-4.3.3/gcc/ada/g-locfil.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/g-locfil.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- 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- -- *************** *** 32,38 **** ------------------------------------------------------------------------------ -- This package contains the necessary routines for using files for the ! -- purpose of providing realiable system wide locking capability. package GNAT.Lock_Files is pragma Preelaborate; --- 32,38 ---- ------------------------------------------------------------------------------ -- This package contains the necessary routines for using files for the ! -- purpose of providing reliable system wide locking capability. package GNAT.Lock_Files is pragma Preelaborate; diff -Nrcpad gcc-4.3.3/gcc/ada/g-md5.adb gcc-4.4.0/gcc/ada/g-md5.adb *** gcc-4.3.3/gcc/ada/g-md5.adb Fri Apr 6 09:22:29 2007 --- gcc-4.4.0/gcc/ada/g-md5.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2006, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.MD5 is *** 46,52 **** -- Look-up table for each hex digit of the Message-Digest. -- Used by function Digest (Context). ! -- The sixten values used to rotate the context words. -- Four for each rounds. Used in procedure Transform. -- Round 1 --- 46,52 ---- -- Look-up table for each hex digit of the Message-Digest. -- Used by function Digest (Context). ! -- The sixteen values used to rotate the context words. -- Four for each rounds. Used in procedure Transform. -- Round 1 diff -Nrcpad gcc-4.3.3/gcc/ada/g-md5.ads gcc-4.4.0/gcc/ada/g-md5.ads *** gcc-4.3.3/gcc/ada/g-md5.ads Fri Apr 6 09:22:29 2007 --- gcc-4.4.0/gcc/ada/g-md5.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2006, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2008, AdaCore -- -- -- -- 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- -- *************** *** 36,42 **** -- -- http://www.ietf.org/rfc/rfc1321.txt -- ! -- The implementation is derived from the RSA Data Secutity, Inc. MD5 -- Message-Digest Algorithm, as described in RFC 1321. with Ada.Streams; --- 36,42 ---- -- -- http://www.ietf.org/rfc/rfc1321.txt -- ! -- The implementation is derived from the RSA Data Security, Inc. MD5 -- Message-Digest Algorithm, as described in RFC 1321. with Ada.Streams; diff -Nrcpad gcc-4.3.3/gcc/ada/g-memdum.ads gcc-4.4.0/gcc/ada/g-memdum.ads *** gcc-4.3.3/gcc/ada/g-memdum.ads Mon Sep 5 08:07:00 2005 --- gcc-4.4.0/gcc/ada/g-memdum.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2008, AdaCore -- -- -- -- 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- -- *************** package GNAT.Memory_Dump is *** 46,52 **** -- case of a byte addressable machine (and is therefore inapplicable to -- machines like the AAMP, where the storage unit is not 8 bits). The -- output is one or more lines in the following format, which is for the ! -- case of 32-bit addresses (64-bit addressea are handled appropriately): -- -- 0234_3368: 66 67 68 . . . 73 74 75 "fghijklmnopqstuv" -- --- 46,52 ---- -- case of a byte addressable machine (and is therefore inapplicable to -- machines like the AAMP, where the storage unit is not 8 bits). The -- output is one or more lines in the following format, which is for the ! -- case of 32-bit addresses (64-bit addresses are handled appropriately): -- -- 0234_3368: 66 67 68 . . . 73 74 75 "fghijklmnopqstuv" -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-moreex.ads gcc-4.4.0/gcc/ada/g-moreex.ads *** gcc-4.3.3/gcc/ada/g-moreex.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/g-moreex.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2008, AdaCore -- -- -- -- 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- -- *************** *** 33,39 **** -- This package provides routines for accessing the most recently raised -- exception. This may be useful for certain logging activities. It may ! -- also be useful for mimicing implementation dependent capabilities in -- Ada 83 compilers, but see also GNAT.Current_Exceptions for this usage. with Ada.Exceptions; --- 33,39 ---- -- This package provides routines for accessing the most recently raised -- exception. This may be useful for certain logging activities. It may ! -- also be useful for mimicking implementation dependent capabilities in -- Ada 83 compilers, but see also GNAT.Current_Exceptions for this usage. with Ada.Exceptions; diff -Nrcpad gcc-4.3.3/gcc/ada/g-os_lib.adb gcc-4.4.0/gcc/ada/g-os_lib.adb *** gcc-4.3.3/gcc/ada/g-os_lib.adb Wed Jun 6 10:30:30 2007 --- gcc-4.4.0/gcc/ada/g-os_lib.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- 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- -- *************** *** 33,38 **** -- This package does not require a body, since it is a package renaming. We -- provide a dummy file containing a No_Body pragma so that previous versions ! -- of the body (which did exist) will not intefere. pragma No_Body; --- 33,38 ---- -- This package does not require a body, since it is a package renaming. We -- provide a dummy file containing a No_Body pragma so that previous versions ! -- of the body (which did exist) will not interfere. pragma No_Body; diff -Nrcpad gcc-4.3.3/gcc/ada/g-os_lib.ads gcc-4.4.0/gcc/ada/g-os_lib.ads *** gcc-4.3.3/gcc/ada/g-os_lib.ads Wed Jun 6 10:30:30 2007 --- gcc-4.4.0/gcc/ada/g-os_lib.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-pehage.adb gcc-4.4.0/gcc/ada/g-pehage.adb *** gcc-4.3.3/gcc/ada/g-pehage.adb Thu Dec 13 10:23:29 2007 --- gcc-4.4.0/gcc/ada/g-pehage.adb Thu Jul 31 10:25:50 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2008, AdaCore -- -- -- -- 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- -- *************** *** 31,37 **** -- -- ------------------------------------------------------------------------------ - with Ada.Exceptions; use Ada.Exceptions; with Ada.IO_Exceptions; use Ada.IO_Exceptions; with GNAT.Heap_Sort_G; --- 31,36 ---- *************** package body GNAT.Perfect_Hash_Generator *** 50,59 **** -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m ! -- where f1 and f2 are functions that map strings into integers, and g is a ! -- function that maps integers into [0, m-1]. h can be order preserving. ! -- For instance, let W = {w_0, ..., w_i, ..., ! -- w_m-1}, h can be defined such that h (w_i) = i. -- This algorithm defines two possible constructions of f1 and f2. Method -- b) stores the hash function in less memory space at the expense of --- 49,58 ---- -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m ! -- where f1 and f2 are functions that map strings into integers, and g is ! -- a function that maps integers into [0, m-1]. h can be order preserving. ! -- For instance, let W = {w_0, ..., w_i, ..., w_m-1}, h can be defined ! -- such that h (w_i) = i. -- This algorithm defines two possible constructions of f1 and f2. Method -- b) stores the hash function in less memory space at the expense of *************** package body GNAT.Perfect_Hash_Generator *** 75,81 **** -- Random graphs are frequently used to solve difficult problems that do -- not have polynomial solutions. This algorithm is based on a weighted ! -- undirected graph. It comprises two steps: mapping and assigment. -- In the mapping step, a graph G = (V, E) is constructed, where = {0, 1, -- ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the --- 74,80 ---- -- Random graphs are frequently used to solve difficult problems that do -- not have polynomial solutions. This algorithm is based on a weighted ! -- undirected graph. It comprises two steps: mapping and assignment. -- In the mapping step, a graph G = (V, E) is constructed, where = {0, 1, -- ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the *************** package body GNAT.Perfect_Hash_Generator *** 83,92 **** -- probability of generating an acyclic graph, n >= 2m. If it is not -- acyclic, Tk have to be regenerated. ! -- In the assignment step, the algorithm builds function g. As is acyclic, ! -- there is a vertex v1 with only one neighbor v2. Let w_i be the word such ! -- that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by construction and ! -- g (v2) = (i - g (v1)) mod n (or to be general, (h (i) - g (v1) mod n). -- If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j - -- g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no -- neighbor, then another vertex is selected. The algorithm traverses G to --- 82,91 ---- -- probability of generating an acyclic graph, n >= 2m. If it is not -- acyclic, Tk have to be regenerated. ! -- In the assignment step, the algorithm builds function g. As G is ! -- acyclic, there is a vertex v1 with only one neighbor v2. Let w_i be ! -- the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by ! -- construction and g (v2) = (i - g (v1)) mod n (or h (i) - g (v1) mod n). -- If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j - -- g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no -- neighbor, then another vertex is selected. The algorithm traverses G to *************** package body GNAT.Perfect_Hash_Generator *** 103,113 **** No_Edge : constant Edge_Id := -1; No_Table : constant Table_Id := -1; ! Max_Word_Length : constant := 32; ! subtype Word_Type is String (1 .. Max_Word_Length); ! Null_Word : constant Word_Type := (others => ASCII.NUL); ! -- Store keyword in a word. Note that the length of word is limited to 32 ! -- characters. type Key_Type is record Edge : Edge_Id; --- 102,113 ---- No_Edge : constant Edge_Id := -1; No_Table : constant Table_Id := -1; ! type Word_Type is new String_Access; ! procedure Free_Word (W : in out Word_Type); ! function New_Word (S : String) return Word_Type; ! ! procedure Resize_Word (W : in out Word_Type; Len : Natural); ! -- Resize string W to have a length Len type Key_Type is record Edge : Edge_Id; *************** package body GNAT.Perfect_Hash_Generator *** 131,138 **** package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32); package IT is new GNAT.Table (Integer, Integer, 0, 32, 32); ! -- The two main tables. IT is used to store several tables of components ! -- containing only integers. function Image (Int : Integer; W : Natural := 0) return String; function Image (Str : String; W : Natural := 0) return String; --- 131,142 ---- package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32); package IT is new GNAT.Table (Integer, Integer, 0, 32, 32); ! -- The two main tables. WT is used to store the words in their initial ! -- version and in their reduced version (that is words reduced to their ! -- significant characters). As an instance of GNAT.Table, WT does not ! -- initialize string pointers to null. This initialization has to be done ! -- manually when the table is allocated. IT is used to store several ! -- tables of components containing only integers. function Image (Int : Integer; W : Natural := 0) return String; function Image (Str : String; W : Natural := 0) return String; *************** package body GNAT.Perfect_Hash_Generator *** 299,307 **** function Allocate (N : Natural; S : Natural := 1) return Table_Id; -- Allocate N * S ints from IT table - procedure Free_Tmp_Tables; - -- Deallocate the tables used by the algorithm (but not the keys table) - ---------- -- Keys -- ---------- --- 303,308 ---- *************** package body GNAT.Perfect_Hash_Generator *** 409,415 **** -- Optimization mode (memory vs CPU) Max_Key_Len : Natural := 0; ! Min_Key_Len : Natural := Max_Word_Length; -- Maximum and minimum of all the word length S : Natural; --- 410,416 ---- -- Optimization mode (memory vs CPU) Max_Key_Len : Natural := 0; ! Min_Key_Len : Natural := 0; -- Maximum and minimum of all the word length S : Natural; *************** package body GNAT.Perfect_Hash_Generator *** 531,556 **** procedure Apply_Position_Selection is begin - WT.Set_Last (2 * NK); for J in 0 .. NK - 1 loop declare ! I_Word : constant Word_Type := WT.Table (Initial (J)); ! R_Word : Word_Type := Null_Word; ! Index : Natural := I_Word'First - 1; begin -- Select the characters of Word included in the position -- selection. for C in 0 .. Char_Pos_Set_Len - 1 loop ! exit when I_Word (Get_Char_Pos (C)) = ASCII.NUL; ! Index := Index + 1; ! R_Word (Index) := I_Word (Get_Char_Pos (C)); end loop; ! -- Build the new table with the reduced word ! WT.Table (Reduced (J)) := R_Word; Set_Key (J, (Edge => No_Edge)); end; end loop; --- 532,558 ---- procedure Apply_Position_Selection is begin for J in 0 .. NK - 1 loop declare ! IW : constant String := WT.Table (Initial (J)).all; ! RW : String (1 .. IW'Length) := (others => ASCII.NUL); ! N : Natural := IW'First - 1; begin -- Select the characters of Word included in the position -- selection. for C in 0 .. Char_Pos_Set_Len - 1 loop ! exit when IW (Get_Char_Pos (C)) = ASCII.NUL; ! N := N + 1; ! RW (N) := IW (Get_Char_Pos (C)); end loop; ! -- Build the new table with the reduced word. Be careful ! -- to deallocate the old version to avoid memory leaks. ! Free_Word (WT.Table (Reduced (J))); ! WT.Table (Reduced (J)) := New_Word (RW); Set_Key (J, (Edge => No_Edge)); end; end loop; *************** package body GNAT.Perfect_Hash_Generator *** 589,595 **** -- Start of processing for Assign_Values_To_Vertices begin ! -- Value -1 denotes an unitialized value as it is supposed to -- be in the range 0 .. NK. if G = No_Table then --- 591,597 ---- -- Start of processing for Assign_Values_To_Vertices begin ! -- Value -1 denotes an uninitialized value as it is supposed to -- be in the range 0 .. NK. if G = No_Table then *************** package body GNAT.Perfect_Hash_Generator *** 629,637 **** Success : Boolean := False; begin ! NV := Natural (K2V * Float (NK)); ! ! Keys := Allocate (NK); if Verbose then Put_Initial_Keys (Output, "Initial Key Table"); --- 631,639 ---- Success : Boolean := False; begin ! if NK = 0 then ! raise Program_Error with "keywords set cannot be empty"; ! end if; if Verbose then Put_Initial_Keys (Output, "Initial Key Table"); *************** package body GNAT.Perfect_Hash_Generator *** 862,884 **** procedure Finalize is begin ! Free_Tmp_Tables; WT.Release; IT.Release; ! NK := 0; ! Max_Key_Len := 0; ! Min_Key_Len := Max_Word_Length; ! end Finalize; ! ! --------------------- ! -- Free_Tmp_Tables -- ! --------------------- ! ! procedure Free_Tmp_Tables is ! begin ! IT.Init; Keys := No_Table; --- 864,879 ---- procedure Finalize is begin ! -- Deallocate all the WT components (both initial and reduced ! -- ones) to avoid memory leaks. + for W in 0 .. WT.Last loop + Free_Word (WT.Table (W)); + end loop; WT.Release; IT.Release; ! -- Reset all variables for next usage Keys := No_Table; *************** package body GNAT.Perfect_Hash_Generator *** 902,908 **** Vertices := No_Table; NV := 0; ! end Free_Tmp_Tables; ---------------------------- -- Generate_Mapping_Table -- --- 897,918 ---- Vertices := No_Table; NV := 0; ! ! NK := 0; ! Max_Key_Len := 0; ! Min_Key_Len := 0; ! end Finalize; ! ! --------------- ! -- Free_Word -- ! --------------- ! ! procedure Free_Word (W : in out Word_Type) is ! begin ! if W /= null then ! Free (W); ! end if; ! end Free_Word; ---------------------------- -- Generate_Mapping_Table -- *************** package body GNAT.Perfect_Hash_Generator *** 1131,1150 **** Tries : Positive := Default_Tries) is begin ! -- Free previous tables (the settings may have changed between two runs) ! Free_Tmp_Tables; ! if K_To_V <= 2.0 then ! Put (Output, "K to V ratio cannot be lower than 2.0"); ! New_Line (Output); ! raise Program_Error; ! end if; S := Seed; K2V := K_To_V; Opt := Optim; NT := Tries; end Initialize; ------------ --- 1141,1215 ---- Tries : Positive := Default_Tries) is begin ! -- Deallocate the part of the table concerning the reduced words. ! -- Initial words are already present in the table. We may have reduced ! -- words already there because a previous computation failed. We are ! -- currently retrying and the reduced words have to be deallocated. ! for W in NK .. WT.Last loop ! Free_Word (WT.Table (W)); ! end loop; ! IT.Init; ! -- Initialize of computation variables ! ! Keys := No_Table; ! ! Char_Pos_Set := No_Table; ! Char_Pos_Set_Len := 0; ! ! Used_Char_Set := No_Table; ! Used_Char_Set_Len := 0; ! ! T1 := No_Table; ! T2 := No_Table; ! ! T1_Len := 0; ! T2_Len := 0; ! ! G := No_Table; ! G_Len := 0; ! ! Edges := No_Table; ! Edges_Len := 0; ! ! Vertices := No_Table; ! NV := 0; S := Seed; K2V := K_To_V; Opt := Optim; NT := Tries; + + if K2V <= 2.0 then + raise Program_Error with "K to V ratio cannot be lower than 2.0"; + end if; + + -- Do not accept a value of K2V too close to 2.0 such that once + -- rounded up, NV = 2 * NK because the algorithm would not converge. + + NV := Natural (Float (NK) * K2V); + if NV <= 2 * NK then + NV := 2 * NK + 1; + end if; + + Keys := Allocate (NK); + + -- Resize initial words to have all of them at the same size + -- (so the size of the largest one). + + for K in 0 .. NK - 1 loop + Resize_Word (WT.Table (Initial (K)), Max_Key_Len); + end loop; + + -- Allocated the table to store the reduced words. As WT is a + -- GNAT.Table (using C memory management), pointers have to be + -- explicitly initialized to null. + + WT.Set_Last (Reduced (NK - 1)); + for W in 0 .. NK - 1 loop + WT.Table (Reduced (W)) := null; + end loop; end Initialize; ------------ *************** package body GNAT.Perfect_Hash_Generator *** 1152,1179 **** ------------ procedure Insert (Value : String) is - Word : Word_Type := Null_Word; Len : constant Natural := Value'Length; begin - Word (1 .. Len) := Value (Value'First .. Value'First + Len - 1); WT.Set_Last (NK); ! WT.Table (NK) := Word; NK := NK + 1; - NV := Natural (Float (NK) * K2V); - - -- Do not accept a value of K2V too close to 2.0 such that once rounded - -- up, NV = 2 * NK because the algorithm would not converge. - - if NV <= 2 * NK then - NV := 2 * NK + 1; - end if; if Max_Key_Len < Len then Max_Key_Len := Len; end if; ! if Len < Min_Key_Len then Min_Key_Len := Len; end if; end Insert; --- 1217,1234 ---- ------------ procedure Insert (Value : String) is Len : constant Natural := Value'Length; begin WT.Set_Last (NK); ! WT.Table (NK) := New_Word (Value); NK := NK + 1; if Max_Key_Len < Len then Max_Key_Len := Len; end if; ! if Min_Key_Len = 0 or else Len < Min_Key_Len then Min_Key_Len := Len; end if; end Insert; *************** package body GNAT.Perfect_Hash_Generator *** 1189,1194 **** --- 1244,1258 ---- end if; end New_Line; + -------------- + -- New_Word -- + -------------- + + function New_Word (S : String) return Word_Type is + begin + return new String'(S); + end New_Word; + ------------------------------ -- Parse_Position_Selection -- ------------------------------ *************** package body GNAT.Perfect_Hash_Generator *** 1218,1225 **** end if; if C not in '0' .. '9' then ! Raise_Exception ! (Program_Error'Identity, "cannot read position argument"); end if; while C in '0' .. '9' loop --- 1282,1288 ---- end if; if C not in '0' .. '9' then ! raise Program_Error with "cannot read position argument"; end if; while C in '0' .. '9' loop *************** package body GNAT.Perfect_Hash_Generator *** 1271,1278 **** exit when L < N; if Argument (N) /= ',' then ! Raise_Exception ! (Program_Error'Identity, "cannot read position argument"); end if; N := N + 1; --- 1334,1340 ---- exit when L < N; if Argument (N) /= ',' then ! raise Program_Error with "cannot read position argument"; end if; N := N + 1; *************** package body GNAT.Perfect_Hash_Generator *** 1764,1770 **** K := Get_Key (J); Put (File, Image (J, M), F1, L1, J, 1, 3, 1); Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); ! Put (File, WT.Table (Initial (J)), F1, L1, J, 1, 3, 3); end loop; end Put_Initial_Keys; --- 1826,1832 ---- K := Get_Key (J); Put (File, Image (J, M), F1, L1, J, 1, 3, 1); Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); ! Put (File, WT.Table (Initial (J)).all, F1, L1, J, 1, 3, 3); end loop; end Put_Initial_Keys; *************** package body GNAT.Perfect_Hash_Generator *** 1845,1851 **** K := Get_Key (J); Put (File, Image (J, M), F1, L1, J, 1, 3, 1); Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); ! Put (File, WT.Table (Reduced (J)), F1, L1, J, 1, 3, 3); end loop; end Put_Reduced_Keys; --- 1907,1913 ---- K := Get_Key (J); Put (File, Image (J, M), F1, L1, J, 1, 3, 1); Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); ! Put (File, WT.Table (Reduced (J)).all, F1, L1, J, 1, 3, 3); end loop; end Put_Reduced_Keys; *************** package body GNAT.Perfect_Hash_Generator *** 1923,1928 **** --- 1985,2006 ---- return K + NK + 1; end Reduced; + ----------------- + -- Resize_Word -- + ----------------- + + procedure Resize_Word (W : in out Word_Type; Len : Natural) is + S1 : constant String := W.all; + S2 : String (1 .. Len) := (others => ASCII.NUL); + L : constant Natural := S1'Length; + begin + if L /= Len then + Free_Word (W); + S2 (1 .. L) := S1; + W := New_Word (S2); + end if; + end Resize_Word; + -------------------------- -- Select_Char_Position -- -------------------------- *************** package body GNAT.Perfect_Hash_Generator *** 1988,1998 **** begin if L = 0 then ! Left := Reduced (0) - 1; Right := Offset + R; elsif R = 0 then Left := Offset + L; ! Right := Reduced (0) - 1; else Left := Offset + L; Right := Offset + R; --- 2066,2076 ---- begin if L = 0 then ! Left := NK; Right := Offset + R; elsif R = 0 then Left := Offset + L; ! Right := NK; else Left := Offset + L; Right := Offset + R; *************** package body GNAT.Perfect_Hash_Generator *** 2010,2026 **** begin if From = 0 then ! Source := Reduced (0) - 1; Target := Offset + To; elsif To = 0 then Source := Offset + From; ! Target := Reduced (0) - 1; else Source := Offset + From; Target := Offset + To; end if; WT.Table (Target) := WT.Table (Source); end Move; package Sorting is new GNAT.Heap_Sort_G (Move, Lt); --- 2088,2105 ---- begin if From = 0 then ! Source := NK; Target := Offset + To; elsif To = 0 then Source := Offset + From; ! Target := NK; else Source := Offset + From; Target := Offset + To; end if; WT.Table (Target) := WT.Table (Source); + WT.Table (Source) := null; end Move; package Sorting is new GNAT.Heap_Sort_G (Move, Lt); *************** package body GNAT.Perfect_Hash_Generator *** 2123,2131 **** begin -- Initialize the reduced words set - WT.Set_Last (2 * NK); for K in 0 .. NK - 1 loop ! WT.Table (Reduced (K)) := WT.Table (Initial (K)); end loop; declare --- 2202,2209 ---- begin -- Initialize the reduced words set for K in 0 .. NK - 1 loop ! WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all); end loop; declare *************** package body GNAT.Perfect_Hash_Generator *** 2147,2153 **** loop -- Preserve maximum number of different keys and check later on -- that this value is strictly incrementing. Otherwise, it means ! -- that two keys are stricly identical. Old_Differences := Max_Differences; --- 2225,2231 ---- loop -- Preserve maximum number of different keys and check later on -- that this value is strictly incrementing. Otherwise, it means ! -- that two keys are strictly identical. Old_Differences := Max_Differences; *************** package body GNAT.Perfect_Hash_Generator *** 2184,2191 **** end loop; if Old_Differences = Max_Differences then ! Raise_Exception ! (Program_Error'Identity, "some keys are identical"); end if; -- Insert selected position and sort Sel_Position table --- 2262,2268 ---- end loop; if Old_Differences = Max_Differences then ! raise Program_Error with "some keys are identical"; end if; -- Insert selected position and sort Sel_Position table *************** package body GNAT.Perfect_Hash_Generator *** 2224,2230 **** Same_Keys_Sets_Table (J).First .. Same_Keys_Sets_Table (J).Last loop ! Put (Output, WT.Table (Reduced (K))); New_Line (Output); end loop; Put (Output, "--"); --- 2301,2307 ---- Same_Keys_Sets_Table (J).First .. Same_Keys_Sets_Table (J).Last loop ! Put (Output, WT.Table (Reduced (K)).all); New_Line (Output); end loop; Put (Output, "--"); diff -Nrcpad gcc-4.3.3/gcc/ada/g-pehage.ads gcc-4.4.0/gcc/ada/g-pehage.ads *** gcc-4.3.3/gcc/ada/g-pehage.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/g-pehage.ads Thu Jul 31 07:51:32 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2008, AdaCore -- -- -- -- 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- -- *************** *** 60,68 **** -- The hash table size corresponds to the exact size of W and *no larger*. -- This represents the "minimal" property. ! -- The functions generated by this package require the key set to be known in -- advance (they are "static" hash functions). The hash functions are also ! -- order preservering. If w2 is inserted after w1 in the generator, then (w1) -- < f (w2). These hashing functions are convenient for use with realtime -- applications. --- 60,68 ---- -- The hash table size corresponds to the exact size of W and *no larger*. -- This represents the "minimal" property. ! -- The functions generated by this package require the words to be known in -- advance (they are "static" hash functions). The hash functions are also ! -- order preserving. If w2 is inserted after w1 in the generator, then (w1) -- < f (w2). These hashing functions are convenient for use with realtime -- applications. *************** package GNAT.Perfect_Hash_Generators is *** 71,77 **** Default_K_To_V : constant Float := 2.05; -- Default ratio for the algorithm. When K is the number of keys, V = -- (K_To_V) * K is the size of the main table of the hash function. To ! -- converge, the algorithm requires K_To_V to be stricly greater than 2.0. Default_Pkg_Name : constant String := "Perfect_Hash"; -- Default package name in which the hash function is defined --- 71,77 ---- Default_K_To_V : constant Float := 2.05; -- Default ratio for the algorithm. When K is the number of keys, V = -- (K_To_V) * K is the size of the main table of the hash function. To ! -- converge, the algorithm requires K_To_V to be strictly greater than 2.0. Default_Pkg_Name : constant String := "Perfect_Hash"; -- Default package name in which the hash function is defined *************** package GNAT.Perfect_Hash_Generators is *** 101,125 **** Tries : Positive := Default_Tries); -- Initialize the generator and its internal structures. Set the ratio of -- vertices over keys in the random graphs. This value has to be greater ! -- than 2.0 in order for the algorithm to succeed. The key set is not -- modified (in particular when it is already set). For instance, it is -- possible to run several times the generator with different settings on ! -- the same key set. procedure Finalize; ! -- Deallocate the internal structures and the key table procedure Insert (Value : String); ! -- Insert a new key in the table Too_Many_Tries : exception; ! -- Raised after Tries unsuccessfull runs procedure Compute (Position : String := Default_Position); -- Compute the hash function. Position allows to define selection of ! -- character positions used in the keywords hash function. Positions can be -- separated by commas and range like x-y may be used. Character '$' ! -- represents the final character of a key. With an empty position, the -- generator automatically produces positions to reduce the memory usage. -- Raise Too_Many_Tries in case that the algorithm does not succeed in less -- than Tries attempts (see Initialize). --- 101,131 ---- Tries : Positive := Default_Tries); -- Initialize the generator and its internal structures. Set the ratio of -- vertices over keys in the random graphs. This value has to be greater ! -- than 2.0 in order for the algorithm to succeed. The word set is not -- modified (in particular when it is already set). For instance, it is -- possible to run several times the generator with different settings on ! -- the same words. ! -- ! -- A classical way of doing is to Insert all the words and then to invoke ! -- Initialize and Compute. If Compute fails to find a perfect hash ! -- function, invoke Initialize another time with other configuration ! -- parameters (probably with a greater K_To_V ratio). Once successful, ! -- invoke Produce and Finalize. procedure Finalize; ! -- Deallocate the internal structures and the words table procedure Insert (Value : String); ! -- Insert a new word in the table Too_Many_Tries : exception; ! -- Raised after Tries unsuccessful runs procedure Compute (Position : String := Default_Position); -- Compute the hash function. Position allows to define selection of ! -- character positions used in the word hash function. Positions can be -- separated by commas and range like x-y may be used. Character '$' ! -- represents the final character of a word. With an empty position, the -- generator automatically produces positions to reduce the memory usage. -- Raise Too_Many_Tries in case that the algorithm does not succeed in less -- than Tries attempts (see Initialize). *************** package GNAT.Perfect_Hash_Generators is *** 144,150 **** -- F1 and F2 are two functions based on two function tables T1 and T2. -- Their definition depends on the chosen optimization mode. ! -- Only some character positions are used in the keys because they are -- significant. They are listed in a character position table (P in the -- pseudo-code below). For instance, in {"jan", "feb", "mar", "apr", "jun", -- "jul", "aug", "sep", "oct", "nov", "dec"}, only positions 2 and 3 are --- 150,156 ---- -- F1 and F2 are two functions based on two function tables T1 and T2. -- Their definition depends on the chosen optimization mode. ! -- Only some character positions are used in the words because they are -- significant. They are listed in a character position table (P in the -- pseudo-code below). For instance, in {"jan", "feb", "mar", "apr", "jun", -- "jul", "aug", "sep", "oct", "nov", "dec"}, only positions 2 and 3 are *************** package GNAT.Perfect_Hash_Generators is *** 152,158 **** -- {2, 3} -- When Optimization is CPU_Time, the first dimension of T1 and T2 ! -- corresponds to the character position in the key and the second to the -- character set. As all the character set is not used, we define a used -- character table which associates a distinct index to each used character -- (unused characters are mapped to zero). In this case, the second --- 158,164 ---- -- {2, 3} -- When Optimization is CPU_Time, the first dimension of T1 and T2 ! -- corresponds to the character position in the word and the second to the -- character set. As all the character set is not used, we define a used -- character table which associates a distinct index to each used character -- (unused characters are mapped to zero). In this case, the second *************** package GNAT.Perfect_Hash_Generators is *** 177,183 **** -- end Hash; -- When Optimization is Memory_Space, the first dimension of T1 and T2 ! -- corresponds to the character position in the key and the second -- dimension is ignored. T1 and T2 are no longer matrices but vectors. -- Therefore, the used character table is not available. The hash function -- has the following form: --- 183,189 ---- -- end Hash; -- When Optimization is Memory_Space, the first dimension of T1 and T2 ! -- corresponds to the character position in the word and the second -- dimension is ignored. T1 and T2 are no longer matrices but vectors. -- Therefore, the used character table is not available. The hash function -- has the following form: *************** package GNAT.Perfect_Hash_Generators is *** 213,220 **** Length_2 : out Natural); -- Return the definition of the table Name. This includes the length of -- dimensions 1 and 2 and the size of an unsigned integer item. When ! -- Length_2 is zero, the table has only one dimension. All the ranges start ! -- from zero. function Value (Name : Table_Name; --- 219,226 ---- Length_2 : out Natural); -- Return the definition of the table Name. This includes the length of -- dimensions 1 and 2 and the size of an unsigned integer item. When ! -- Length_2 is zero, the table has only one dimension. All the ranges ! -- start from zero. function Value (Name : Table_Name; diff -Nrcpad gcc-4.3.3/gcc/ada/g-rannum.adb gcc-4.4.0/gcc/ada/g-rannum.adb *** gcc-4.3.3/gcc/ada/g-rannum.adb Tue Aug 14 08:48:27 2007 --- gcc-4.4.0/gcc/ada/g-rannum.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-rannum.ads gcc-4.4.0/gcc/ada/g-rannum.ads *** gcc-4.3.3/gcc/ada/g-rannum.ads Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/g-rannum.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-regexp.adb gcc-4.4.0/gcc/ada/g-regexp.adb *** gcc-4.3.3/gcc/ada/g-regexp.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/g-regexp.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- 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- -- *************** *** 33,38 **** -- This package does not require a body, since it is a package renaming. We -- provide a dummy file containing a No_Body pragma so that previous versions ! -- of the body (which did exist) will not intefere. pragma No_Body; --- 33,38 ---- -- This package does not require a body, since it is a package renaming. We -- provide a dummy file containing a No_Body pragma so that previous versions ! -- of the body (which did exist) will not interfere. pragma No_Body; diff -Nrcpad gcc-4.3.3/gcc/ada/g-regexp.ads gcc-4.4.0/gcc/ada/g-regexp.ads *** gcc-4.3.3/gcc/ada/g-regexp.ads Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/g-regexp.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2008, AdaCore -- -- -- -- 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,49 **** -- Summary of Pattern Matching Packages in GNAT Hierarchy -- ------------------------------------------------------------ ! -- There are three related packages that perform pattern maching functions. -- the following is an outline of these packages, to help you determine -- which is best for your needs. --- 43,49 ---- -- Summary of Pattern Matching Packages in GNAT Hierarchy -- ------------------------------------------------------------ ! -- There are three related packages that perform pattern matching functions. -- the following is an outline of these packages, to help you determine -- which is best for your needs. *************** *** 62,68 **** -- stored in a binary compatible manner. -- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb) ! -- This is a completely general patterm matching package based on the -- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern -- language is modeled on context free grammars, with context sensitive -- extensions that provide full (type 0) computational capabilities. --- 62,68 ---- -- stored in a binary compatible manner. -- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb) ! -- This is a completely general pattern matching package based on the -- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern -- language is modeled on context free grammars, with context sensitive -- extensions that provide full (type 0) computational capabilities. diff -Nrcpad gcc-4.3.3/gcc/ada/g-regist.adb gcc-4.4.0/gcc/ada/g-regist.adb *** gcc-4.3.3/gcc/ada/g-regist.adb Thu Dec 13 10:27:42 2007 --- gcc-4.4.0/gcc/ada/g-regist.adb Thu Apr 9 23:23:07 2009 *************** *** 6,43 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ - with Ada.Exceptions; with Interfaces.C; with System; with GNAT.Directory_Operations; package body GNAT.Registry is - use Ada; use System; ------------------------------ --- 6,39 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Interfaces.C; with System; with GNAT.Directory_Operations; package body GNAT.Registry is use System; ------------------------------ *************** package body GNAT.Registry is *** 156,164 **** use type LONG; begin if Result /= ERROR_SUCCESS then ! Exceptions.Raise_Exception ! (Registry_Error'Identity, ! Message & " (" & LONG'Image (Result) & ')'); end if; end Check_Result; --- 152,159 ---- use type LONG; begin if Result /= ERROR_SUCCESS then ! raise Registry_Error with ! Message & " (" & LONG'Image (Result) & ')'; end if; end Check_Result; *************** package body GNAT.Registry is *** 187,194 **** REG_OPTION_NON_VOLATILE : constant := 16#0#; ! C_Sub_Key : constant String := Sub_Key & ASCII.Nul; ! C_Class : constant String := "" & ASCII.Nul; C_Mode : constant REGSAM := To_C_Mode (Mode); New_Key : aliased HKEY; --- 182,189 ---- REG_OPTION_NON_VOLATILE : constant := 16#0#; ! C_Sub_Key : constant String := Sub_Key & ASCII.NUL; ! C_Class : constant String := "" & ASCII.NUL; C_Mode : constant REGSAM := To_C_Mode (Mode); New_Key : aliased HKEY; *************** package body GNAT.Registry is *** 217,223 **** ---------------- procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is ! C_Sub_Key : constant String := Sub_Key & ASCII.Nul; Result : LONG; begin Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address); --- 212,218 ---- ---------------- procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is ! C_Sub_Key : constant String := Sub_Key & ASCII.NUL; Result : LONG; begin Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address); *************** package body GNAT.Registry is *** 229,235 **** ------------------ procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is ! C_Sub_Key : constant String := Sub_Key & ASCII.Nul; Result : LONG; begin Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address); --- 224,230 ---- ------------------ procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is ! C_Sub_Key : constant String := Sub_Key & ASCII.NUL; Result : LONG; begin Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address); *************** package body GNAT.Registry is *** 342,348 **** is use type REGSAM; ! C_Sub_Key : constant String := Sub_Key & ASCII.Nul; C_Mode : constant REGSAM := To_C_Mode (Mode); New_Key : aliased HKEY; --- 337,343 ---- is use type REGSAM; ! C_Sub_Key : constant String := Sub_Key & ASCII.NUL; C_Mode : constant REGSAM := To_C_Mode (Mode); New_Key : aliased HKEY; *************** package body GNAT.Registry is *** 380,386 **** Size_Value : aliased ULONG; Type_Value : aliased DWORD; ! C_Sub_Key : constant String := Sub_Key & ASCII.Nul; Result : LONG; begin --- 375,381 ---- Size_Value : aliased ULONG; Type_Value : aliased DWORD; ! C_Sub_Key : constant String := Sub_Key & ASCII.NUL; Result : LONG; begin *************** package body GNAT.Registry is *** 415,422 **** Value : String; Expand : Boolean := False) is ! C_Sub_Key : constant String := Sub_Key & ASCII.Nul; ! C_Value : constant String := Value & ASCII.Nul; Value_Type : DWORD; Result : LONG; --- 410,417 ---- Value : String; Expand : Boolean := False) is ! C_Sub_Key : constant String := Sub_Key & ASCII.NUL; ! C_Value : constant String := Value & ASCII.NUL; Value_Type : DWORD; Result : LONG; diff -Nrcpad gcc-4.3.3/gcc/ada/g-regist.ads gcc-4.4.0/gcc/ada/g-regist.ads *** gcc-4.3.3/gcc/ada/g-regist.ads Thu Dec 13 10:27:42 2007 --- gcc-4.4.0/gcc/ada/g-regist.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-regpat.adb gcc-4.4.0/gcc/ada/g-regpat.adb *** gcc-4.3.3/gcc/ada/g-regpat.adb Wed Jun 6 10:30:52 2007 --- gcc-4.4.0/gcc/ada/g-regpat.adb Wed Aug 20 13:55:20 2008 *************** *** 7,13 **** -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- 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- -- --- 7,13 ---- -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- 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- -- *************** *** 34,39 **** -- This package does not require a body, since it is a package renaming. We -- provide a dummy file containing a No_Body pragma so that previous versions ! -- of the body (which did exist) will not intefere. pragma No_Body; --- 34,39 ---- -- This package does not require a body, since it is a package renaming. We -- provide a dummy file containing a No_Body pragma so that previous versions ! -- of the body (which did exist) will not interfere. pragma No_Body; diff -Nrcpad gcc-4.3.3/gcc/ada/g-regpat.ads gcc-4.4.0/gcc/ada/g-regpat.ads *** gcc-4.3.3/gcc/ada/g-regpat.ads Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/g-regpat.ads Wed Aug 20 13:55:20 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1986 by University of Toronto. -- ! -- Copyright (C) 1996-2007, AdaCore -- -- -- -- 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1986 by University of Toronto. -- ! -- Copyright (C) 1996-2008, AdaCore -- -- -- -- 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- -- *************** *** 46,52 **** -- Summary of Pattern Matching Packages in GNAT Hierarchy -- ------------------------------------------------------------ ! -- There are three related packages that perform pattern maching functions. -- the following is an outline of these packages, to help you determine -- which is best for your needs. --- 46,52 ---- -- Summary of Pattern Matching Packages in GNAT Hierarchy -- ------------------------------------------------------------ ! -- There are three related packages that perform pattern matching functions. -- the following is an outline of these packages, to help you determine -- which is best for your needs. diff -Nrcpad gcc-4.3.3/gcc/ada/g-sercom-linux.adb gcc-4.4.0/gcc/ada/g-sercom-linux.adb *** gcc-4.3.3/gcc/ada/g-sercom-linux.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-sercom-linux.adb Tue Aug 5 09:28:44 2008 *************** *** 0 **** --- 1,301 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2007-2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the GNU/Linux implementation of this package + + with Ada.Streams; use Ada.Streams; + with Ada; use Ada; + with Ada.Unchecked_Deallocation; + + with System.CRTL; use System, System.CRTL; + + with GNAT.OS_Lib; use GNAT.OS_Lib; + + package body GNAT.Serial_Communications is + + use type Interfaces.C.unsigned; + + type Port_Data is new int; + + subtype unsigned is Interfaces.C.unsigned; + subtype char is Interfaces.C.char; + subtype unsigned_char is Interfaces.C.unsigned_char; + + function fcntl (fd : int; cmd : int; value : int) return int; + pragma Import (C, fcntl, "fcntl"); + + O_RDWR : constant := 8#02#; + O_NOCTTY : constant := 8#0400#; + O_NDELAY : constant := 8#04000#; + FNDELAY : constant := O_NDELAY; + F_SETFL : constant := 4; + TCSANOW : constant := 0; + TCIFLUSH : constant := 0; + CLOCAL : constant := 8#04000#; + CREAD : constant := 8#0200#; + CSTOPB : constant := 8#0100#; + CRTSCTS : constant := 8#020000000000#; + PARENB : constant := 8#00400#; + PARODD : constant := 8#01000#; + + -- c_cc indexes + + VTIME : constant := 5; + VMIN : constant := 6; + + C_Data_Rate : constant array (Data_Rate) of unsigned := + (B1200 => 8#000011#, + B2400 => 8#000013#, + B4800 => 8#000014#, + B9600 => 8#000015#, + B19200 => 8#000016#, + B38400 => 8#000017#, + B57600 => 8#010001#, + B115200 => 8#010002#); + + C_Bits : constant array (Data_Bits) of unsigned := + (CS7 => 8#040#, CS8 => 8#060#); + + C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned := + (One => 0, Two => CSTOPB); + + C_Parity : constant array (Parity_Check) of unsigned := + (None => 0, Odd => PARENB or PARODD, Even => PARENB); + + procedure Raise_Error (Message : String; Error : Integer := Errno); + pragma No_Return (Raise_Error); + + ---------- + -- Name -- + ---------- + + function Name (Number : Positive) return Port_Name is + N : constant Natural := Number - 1; + N_Img : constant String := Natural'Image (N); + begin + return Port_Name ("/dev/ttyS" & N_Img (N_Img'First + 1 .. N_Img'Last)); + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (Port : out Serial_Port; + Name : Port_Name) + is + C_Name : constant String := String (Name) & ASCII.NUL; + Res : int; + + begin + if Port.H = null then + Port.H := new Port_Data; + end if; + + Port.H.all := Port_Data (open + (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY))); + + if Port.H.all = -1 then + Raise_Error ("open: open failed"); + end if; + + -- By default we are in blocking mode + + Res := fcntl (int (Port.H.all), F_SETFL, 0); + + if Res = -1 then + Raise_Error ("open: fcntl failed"); + end if; + end Open; + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error (Message : String; Error : Integer := Errno) is + begin + raise Serial_Error with Message & " (" & Integer'Image (Error) & ')'; + end Raise_Error; + + ---------- + -- Read -- + ---------- + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Len : constant int := Buffer'Length; + Res : int; + + begin + if Port.H = null then + Raise_Error ("read: port not opened", 0); + end if; + + Res := read (Integer (Port.H.all), Buffer'Address, Len); + + if Res = -1 then + Last := 0; + Raise_Error ("read failed"); + else + Last := Buffer'First + Stream_Element_Offset (Res) - 1; + end if; + end Read; + + --------- + -- Set -- + --------- + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := CS8; + Stop_Bits : Stop_Bits_Number := One; + Parity : Parity_Check := None; + Block : Boolean := True; + Timeout : Duration := 10.0) + is + type termios is record + c_iflag : unsigned; + c_oflag : unsigned; + c_cflag : unsigned; + c_lflag : unsigned; + c_line : unsigned_char; + c_cc : Interfaces.C.char_array (0 .. 31); + c_ispeed : unsigned; + c_ospeed : unsigned; + end record; + pragma Convention (C, termios); + + function tcgetattr (fd : int; termios_p : Address) return int; + pragma Import (C, tcgetattr, "tcgetattr"); + + function tcsetattr + (fd : int; action : int; termios_p : Address) return int; + pragma Import (C, tcsetattr, "tcsetattr"); + + function tcflush (fd : int; queue_selector : int) return int; + pragma Import (C, tcflush, "tcflush"); + + Current : termios; + Res : int; + + begin + if Port.H = null then + Raise_Error ("set: port not opened", 0); + end if; + + -- Get current port settings + + Res := tcgetattr (int (Port.H.all), Current'Address); + + -- Change settings now + + Current.c_cflag := C_Data_Rate (Rate) + or C_Bits (Bits) + or C_Stop_Bits (Stop_Bits) + or C_Parity (Parity) + or CLOCAL + or CREAD + or CRTSCTS; + Current.c_lflag := 0; + Current.c_iflag := 0; + Current.c_oflag := 0; + Current.c_ispeed := Data_Rate_Value (Rate); + Current.c_ospeed := Data_Rate_Value (Rate); + Current.c_cc (VMIN) := char'Val (0); + Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10)); + + -- Set port settings + + Res := tcflush (int (Port.H.all), TCIFLUSH); + Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address); + + -- Block + + if Block then + Res := fcntl (int (Port.H.all), F_SETFL, 0); + else + Res := fcntl (int (Port.H.all), F_SETFL, FNDELAY); + end if; + + if Res = -1 then + Raise_Error ("set: fcntl failed"); + end if; + end Set; + + ----------- + -- Write -- + ----------- + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Stream_Element_Array) + is + Len : constant int := Buffer'Length; + Res : int; + + begin + if Port.H = null then + Raise_Error ("write: port not opened", 0); + end if; + + Res := write (int (Port.H.all), Buffer'Address, Len); + pragma Assert (Res = Len); + + if Res = -1 then + Raise_Error ("write failed"); + end if; + end Write; + + ----------- + -- Close -- + ----------- + + procedure Close (Port : in out Serial_Port) is + procedure Unchecked_Free is + new Unchecked_Deallocation (Port_Data, Port_Data_Access); + + Res : int; + pragma Unreferenced (Res); + + begin + if Port.H /= null then + Res := close (int (Port.H.all)); + Unchecked_Free (Port.H); + end if; + end Close; + + end GNAT.Serial_Communications; diff -Nrcpad gcc-4.3.3/gcc/ada/g-sercom-mingw.adb gcc-4.4.0/gcc/ada/g-sercom-mingw.adb *** gcc-4.3.3/gcc/ada/g-sercom-mingw.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-sercom-mingw.adb Tue Aug 5 09:28:44 2008 *************** *** 0 **** --- 1,268 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2007-2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the Windows implementation of this package + + with Ada.Unchecked_Deallocation; use Ada; + with Ada.Streams; use Ada.Streams; + with System.Win32.Ext; use System, System.Win32, System.Win32.Ext; + + package body GNAT.Serial_Communications is + + -- Common types + + type Port_Data is new HANDLE; + + C_Bits : constant array (Data_Bits) of Interfaces.C.unsigned := (8, 7); + C_Parity : constant array (Parity_Check) of Interfaces.C.unsigned := + (None => NOPARITY, Odd => ODDPARITY, Even => EVENPARITY); + C_Stop_Bits : constant array (Stop_Bits_Number) of Interfaces.C.unsigned := + (One => ONESTOPBIT, Two => TWOSTOPBITS); + + ----------- + -- Files -- + ----------- + + procedure Raise_Error (Message : String; Error : DWORD := GetLastError); + pragma No_Return (Raise_Error); + + ----------- + -- Close -- + ----------- + + procedure Close (Port : in out Serial_Port) is + procedure Unchecked_Free is + new Unchecked_Deallocation (Port_Data, Port_Data_Access); + + Success : BOOL; + + begin + if Port.H /= null then + Success := CloseHandle (HANDLE (Port.H.all)); + Unchecked_Free (Port.H); + + if Success = Win32.FALSE then + Raise_Error ("error closing the port"); + end if; + end if; + end Close; + + ---------- + -- Name -- + ---------- + + function Name (Number : Positive) return Port_Name is + N_Img : constant String := Positive'Image (Number); + begin + return Port_Name ("COM" & N_Img (N_Img'First + 1 .. N_Img'Last) & ':'); + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (Port : out Serial_Port; + Name : Port_Name) + is + C_Name : constant String := String (Name) & ASCII.NUL; + Success : BOOL; + pragma Unreferenced (Success); + + begin + if Port.H = null then + Port.H := new Port_Data; + else + Success := CloseHandle (HANDLE (Port.H.all)); + end if; + + Port.H.all := CreateFile + (lpFileName => C_Name (C_Name'First)'Address, + dwDesiredAccess => GENERIC_READ or GENERIC_WRITE, + dwShareMode => 0, + lpSecurityAttributes => null, + dwCreationDisposition => OPEN_EXISTING, + dwFlagsAndAttributes => 0, + hTemplateFile => 0); + + if Port.H.all = 0 then + Raise_Error ("cannot open com port"); + end if; + end Open; + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is + begin + raise Serial_Error with Message & " (" & DWORD'Image (Error) & ')'; + end Raise_Error; + + ---------- + -- Read -- + ---------- + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Success : BOOL; + Read_Last : aliased DWORD; + + begin + if Port.H = null then + Raise_Error ("read: port not opened", 0); + end if; + + Success := + ReadFile + (hFile => HANDLE (Port.H.all), + lpBuffer => Buffer (Buffer'First)'Address, + nNumberOfBytesToRead => DWORD (Buffer'Length), + lpNumberOfBytesRead => Read_Last'Access, + lpOverlapped => null); + + if Success = Win32.FALSE then + Raise_Error ("read error"); + end if; + + Last := Buffer'First - 1 + Stream_Element_Offset (Read_Last); + end Read; + + --------- + -- Set -- + --------- + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := CS8; + Stop_Bits : Stop_Bits_Number := One; + Parity : Parity_Check := None; + Block : Boolean := True; + Timeout : Duration := 10.0) + is + Success : BOOL; + Com_Time_Out : aliased COMMTIMEOUTS; + Com_Settings : aliased DCB; + + begin + if Port.H = null then + Raise_Error ("set: port not opened", 0); + end if; + + Success := GetCommState (HANDLE (Port.H.all), Com_Settings'Access); + + if Success = Win32.FALSE then + Success := CloseHandle (HANDLE (Port.H.all)); + Port.H.all := 0; + Raise_Error ("set: cannot get comm state"); + end if; + + Com_Settings.BaudRate := DWORD (Data_Rate_Value (Rate)); + Com_Settings.fParity := 1; + Com_Settings.fBinary := Bits1 (System.Win32.TRUE); + Com_Settings.fOutxCtsFlow := 0; + Com_Settings.fOutxDsrFlow := 0; + Com_Settings.fDsrSensitivity := 0; + Com_Settings.fDtrControl := DTR_CONTROL_DISABLE; + Com_Settings.fOutX := 0; + Com_Settings.fInX := 0; + Com_Settings.fRtsControl := RTS_CONTROL_DISABLE; + Com_Settings.fAbortOnError := 0; + Com_Settings.ByteSize := BYTE (C_Bits (Bits)); + Com_Settings.Parity := BYTE (C_Parity (Parity)); + Com_Settings.StopBits := BYTE (C_Stop_Bits (Stop_Bits)); + + Success := SetCommState (HANDLE (Port.H.all), Com_Settings'Access); + + if Success = Win32.FALSE then + Success := CloseHandle (HANDLE (Port.H.all)); + Port.H.all := 0; + Raise_Error ("cannot set comm state"); + end if; + + -- Set the timeout status + + if Block then + Com_Time_Out := (others => 0); + else + Com_Time_Out := + (ReadTotalTimeoutConstant => DWORD (1000 * Timeout), + others => 0); + end if; + + Success := + SetCommTimeouts + (hFile => HANDLE (Port.H.all), + lpCommTimeouts => Com_Time_Out'Access); + + if Success = Win32.FALSE then + Raise_Error ("cannot set the timeout"); + end if; + end Set; + + ----------- + -- Write -- + ----------- + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Stream_Element_Array) + is + Success : BOOL; + Temp_Last : aliased DWORD; + + begin + if Port.H = null then + Raise_Error ("write: port not opened", 0); + end if; + + Success := + WriteFile + (hFile => HANDLE (Port.H.all), + lpBuffer => Buffer'Address, + nNumberOfBytesToWrite => DWORD (Buffer'Length), + lpNumberOfBytesWritten => Temp_Last'Access, + lpOverlapped => null); + + if Success = Win32.FALSE + or else Stream_Element_Offset (Temp_Last) /= Buffer'Length + then + Raise_Error ("failed to write data"); + end if; + end Write; + + end GNAT.Serial_Communications; diff -Nrcpad gcc-4.3.3/gcc/ada/g-sercom.adb gcc-4.4.0/gcc/ada/g-sercom.adb *** gcc-4.3.3/gcc/ada/g-sercom.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-sercom.adb Tue Aug 5 09:28:44 2008 *************** *** 0 **** --- 1,132 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2007-2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- Default version of this package + + with Ada.Streams; use Ada.Streams; + + package body GNAT.Serial_Communications is + + pragma Warnings (Off); + -- Kill warnings on unreferenced formals + + type Port_Data is new Integer; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Unimplemented; + pragma No_Return (Unimplemented); + -- This procedure raises a Program_Error with an appropriate message + -- indicating that an unimplemented feature has been used. + + ---------- + -- Name -- + ---------- + + function Name (Number : Positive) return Port_Name is + begin + Unimplemented; + return ""; + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (Port : out Serial_Port; + Name : Port_Name) is + begin + Unimplemented; + end Open; + + --------- + -- Set -- + --------- + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := CS8; + Stop_Bits : Stop_Bits_Number := One; + Parity : Parity_Check := None; + Block : Boolean := True; + Timeout : Duration := 10.0) is + begin + Unimplemented; + end Set; + + ---------- + -- Read -- + ---------- + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Stream_Element_Array; + Last : out Stream_Element_Offset) is + begin + Unimplemented; + end Read; + + ----------- + -- Write -- + ----------- + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Stream_Element_Array) is + begin + Unimplemented; + end Write; + + ----------- + -- Close -- + ----------- + + procedure Close (Port : in out Serial_Port) is + begin + Unimplemented; + end Close; + + ------------------- + -- Unimplemented; -- + ------------------- + + procedure Unimplemented is + begin + raise Program_Error with "Serial_Communications not implemented"; + end Unimplemented; + + end GNAT.Serial_Communications; diff -Nrcpad gcc-4.3.3/gcc/ada/g-sercom.ads gcc-4.4.0/gcc/ada/g-sercom.ads *** gcc-4.3.3/gcc/ada/g-sercom.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-sercom.ads Fri Aug 8 12:37:51 2008 *************** *** 0 **** --- 1,123 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2007-2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- Serial communications package, implemented on Windows and GNU/Linux + + with Ada.Streams; + with Interfaces.C; + + package GNAT.Serial_Communications is + + Serial_Error : exception; + -- Raised when a communication problem occurs + + type Port_Name is new String; + -- A serial com port name + + function Name (Number : Positive) return Port_Name; + -- Returns a possible port name for the given legacy PC architecture serial + -- port number (COM: on Windows, ttyS on Linux). + -- Note that this function does not support other kinds of serial ports + -- nor operating systems other than Windows and Linux. For all other + -- cases, an explicit port name can be passed directly to Open. + + type Data_Rate is + (B1200, B2400, B4800, B9600, B19200, B38400, B57600, B115200); + -- Speed of the communication + + type Data_Bits is (CS8, CS7); + -- Communication bits + + type Stop_Bits_Number is (One, Two); + -- One or two stop bits + + type Parity_Check is (None, Even, Odd); + -- Either no parity check or an even or odd parity + + type Serial_Port is new Ada.Streams.Root_Stream_Type with private; + + procedure Open + (Port : out Serial_Port; + Name : Port_Name); + -- Open the given port name. Raises Serial_Error if the port cannot be + -- opened. + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := CS8; + Stop_Bits : Stop_Bits_Number := One; + Parity : Parity_Check := None; + Block : Boolean := True; + Timeout : Duration := 10.0); + -- The communication port settings. If Block is set then a read call + -- will wait for the whole buffer to be filed. If Block is not set then + -- the given Timeout (in seconds) is used. Note that the timeout precision + -- may be limited on some implementation (e.g. on GNU/Linux the maximum + -- precision is a tenth of seconds). + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Read a set of bytes, put result into Buffer and set Last accordingly. + -- Last is set to 0 if no byte has been read. + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Ada.Streams.Stream_Element_Array); + -- Write buffer into the port + + procedure Close (Port : in out Serial_Port); + -- Close port + + private + + type Port_Data; + type Port_Data_Access is access Port_Data; + + type Serial_Port is new Ada.Streams.Root_Stream_Type with record + H : Port_Data_Access; + end record; + + Data_Rate_Value : constant array (Data_Rate) of Interfaces.C.unsigned := + (B1200 => 1_200, + B2400 => 2_400, + B4800 => 4_800, + B9600 => 9_600, + B19200 => 19_200, + B38400 => 38_400, + B57600 => 57_600, + B115200 => 115_200); + + end GNAT.Serial_Communications; diff -Nrcpad gcc-4.3.3/gcc/ada/g-signal.adb gcc-4.4.0/gcc/ada/g-signal.adb *** gcc-4.3.3/gcc/ada/g-signal.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/g-signal.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-signal.ads gcc-4.4.0/gcc/ada/g-signal.ads *** gcc-4.3.3/gcc/ada/g-signal.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/g-signal.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-aix.ads gcc-4.4.0/gcc/ada/g-soccon-aix.ads *** gcc-4.3.3/gcc/ada/g-soccon-aix.ads Wed Jun 6 10:13:25 2007 --- gcc-4.4.0/gcc/ada/g-soccon-aix.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for powerpc-ibm-aix5.3.0.0 - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 24; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 67; -- Address already in use - EADDRNOTAVAIL : constant := 68; -- Cannot assign address - EAFNOSUPPORT : constant := 66; -- Addr family not supported - EALREADY : constant := 56; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 72; -- Connection aborted - ECONNREFUSED : constant := 79; -- Connection refused - ECONNRESET : constant := 73; -- Connection reset by peer - EDESTADDRREQ : constant := 58; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 80; -- Host is down - EHOSTUNREACH : constant := 81; -- No route to host - EINPROGRESS : constant := 55; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 75; -- Socket already connected - ELOOP : constant := 85; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 59; -- Message too long - ENAMETOOLONG : constant := 86; -- Name too long - ENETDOWN : constant := 69; -- Network is down - ENETRESET : constant := 71; -- Disconn. on network reset - ENETUNREACH : constant := 70; -- Network is unreachable - ENOBUFS : constant := 74; -- No buffer space available - ENOPROTOOPT : constant := 61; -- Protocol not available - ENOTCONN : constant := 76; -- Socket not connected - ENOTSOCK : constant := 57; -- Operation on non socket - EOPNOTSUPP : constant := 64; -- Operation not supported - EPFNOSUPPORT : constant := 65; -- Unknown protocol family - EPROTONOSUPPORT : constant := 62; -- Unknown protocol - EPROTOTYPE : constant := 60; -- Unknown protocol type - ESHUTDOWN : constant := 77; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 63; -- Socket type not supported - ETIMEDOUT : constant := 78; -- Connection timed out - ETOOMANYREFS : constant := 115; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 16; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-darwin.ads gcc-4.4.0/gcc/ada/g-soccon-darwin.ads *** gcc-4.3.3/gcc/ada/g-soccon-darwin.ads Wed Jun 6 10:48:51 2007 --- gcc-4.4.0/gcc/ada/g-soccon-darwin.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for powerpc-apple-darwin8.8.0 - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 30; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 37; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 39; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 64; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 36; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 62; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 40; -- Message too long - ENAMETOOLONG : constant := 63; -- Name too long - ENETDOWN : constant := 50; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 38; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 35; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 1024; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-freebsd.ads gcc-4.4.0/gcc/ada/g-soccon-freebsd.ads *** gcc-4.3.3/gcc/ada/g-soccon-freebsd.ads Wed Jun 6 10:13:25 2007 --- gcc-4.4.0/gcc/ada/g-soccon-freebsd.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for i386-unknown-freebsd6.1 - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 28; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 37; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 39; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 64; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 36; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 62; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 40; -- Message too long - ENAMETOOLONG : constant := 63; -- Name too long - ENETDOWN : constant := 50; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 38; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 35; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := 131072; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 1024; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-hpux-ia64.ads gcc-4.4.0/gcc/ada/g-soccon-hpux-ia64.ads *** gcc-4.3.3/gcc/ada/g-soccon-hpux-ia64.ads Wed Sep 12 11:59:17 2007 --- gcc-4.4.0/gcc/ada/g-soccon-hpux-ia64.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for ia64-hp-hpux11.23 - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 22; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 226; -- Address already in use - EADDRNOTAVAIL : constant := 227; -- Cannot assign address - EAFNOSUPPORT : constant := 225; -- Addr family not supported - EALREADY : constant := 244; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 231; -- Connection aborted - ECONNREFUSED : constant := 239; -- Connection refused - ECONNRESET : constant := 232; -- Connection reset by peer - EDESTADDRREQ : constant := 217; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 241; -- Host is down - EHOSTUNREACH : constant := 242; -- No route to host - EINPROGRESS : constant := 245; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 234; -- Socket already connected - ELOOP : constant := 249; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 218; -- Message too long - ENAMETOOLONG : constant := 248; -- Name too long - ENETDOWN : constant := 228; -- Network is down - ENETRESET : constant := 230; -- Disconn. on network reset - ENETUNREACH : constant := 229; -- Network is unreachable - ENOBUFS : constant := 233; -- No buffer space available - ENOPROTOOPT : constant := 220; -- Protocol not available - ENOTCONN : constant := 235; -- Socket not connected - ENOTSOCK : constant := 216; -- Operation on non socket - EOPNOTSUPP : constant := 223; -- Operation not supported - EPFNOSUPPORT : constant := 224; -- Unknown protocol family - EPROTONOSUPPORT : constant := 221; -- Unknown protocol - EPROTOTYPE : constant := 219; -- Unknown protocol type - ESHUTDOWN : constant := 236; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 222; -- Socket type not supported - ETIMEDOUT : constant := 238; -- Connection timed out - ETOOMANYREFS : constant := 237; -- Too many references - EWOULDBLOCK : constant := 246; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 2; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 16; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 8; -- tv_sec - SIZEOF_tv_usec : constant := 8; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-hpux.ads gcc-4.4.0/gcc/ada/g-soccon-hpux.ads *** gcc-4.3.3/gcc/ada/g-soccon-hpux.ads Wed Jun 6 10:13:25 2007 --- gcc-4.4.0/gcc/ada/g-soccon-hpux.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for hppa1.1-hp-hpux11.00 - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := -1; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 226; -- Address already in use - EADDRNOTAVAIL : constant := 227; -- Cannot assign address - EAFNOSUPPORT : constant := 225; -- Addr family not supported - EALREADY : constant := 244; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 231; -- Connection aborted - ECONNREFUSED : constant := 239; -- Connection refused - ECONNRESET : constant := 232; -- Connection reset by peer - EDESTADDRREQ : constant := 217; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 241; -- Host is down - EHOSTUNREACH : constant := 242; -- No route to host - EINPROGRESS : constant := 245; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 234; -- Socket already connected - ELOOP : constant := 249; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 218; -- Message too long - ENAMETOOLONG : constant := 248; -- Name too long - ENETDOWN : constant := 228; -- Network is down - ENETRESET : constant := 230; -- Disconn. on network reset - ENETUNREACH : constant := 229; -- Network is unreachable - ENOBUFS : constant := 233; -- No buffer space available - ENOPROTOOPT : constant := 220; -- Protocol not available - ENOTCONN : constant := 235; -- Socket not connected - ENOTSOCK : constant := 216; -- Operation on non socket - EOPNOTSUPP : constant := 223; -- Operation not supported - EPFNOSUPPORT : constant := 224; -- Unknown protocol family - EPROTONOSUPPORT : constant := 221; -- Unknown protocol - EPROTOTYPE : constant := 219; -- Unknown protocol type - ESHUTDOWN : constant := 236; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 222; -- Socket type not supported - ETIMEDOUT : constant := 238; -- Connection timed out - ETOOMANYREFS : constant := 237; -- Too many references - EWOULDBLOCK : constant := 246; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 2; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 16; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-irix.ads gcc-4.4.0/gcc/ada/g-soccon-irix.ads *** gcc-4.3.3/gcc/ada/g-soccon-irix.ads Wed Jun 6 10:13:25 2007 --- gcc-4.4.0/gcc/ada/g-soccon-irix.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for mips-sgi-irix6.5 - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 24; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 2; -- Stream socket - SOCK_DGRAM : constant := 1; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 125; -- Address already in use - EADDRNOTAVAIL : constant := 126; -- Cannot assign address - EAFNOSUPPORT : constant := 124; -- Addr family not supported - EALREADY : constant := 149; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 130; -- Connection aborted - ECONNREFUSED : constant := 146; -- Connection refused - ECONNRESET : constant := 131; -- Connection reset by peer - EDESTADDRREQ : constant := 96; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 147; -- Host is down - EHOSTUNREACH : constant := 148; -- No route to host - EINPROGRESS : constant := 150; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 133; -- Socket already connected - ELOOP : constant := 90; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 97; -- Message too long - ENAMETOOLONG : constant := 78; -- Name too long - ENETDOWN : constant := 127; -- Network is down - ENETRESET : constant := 129; -- Disconn. on network reset - ENETUNREACH : constant := 128; -- Network is unreachable - ENOBUFS : constant := 132; -- No buffer space available - ENOPROTOOPT : constant := 99; -- Protocol not available - ENOTCONN : constant := 134; -- Socket not connected - ENOTSOCK : constant := 95; -- Operation on non socket - EOPNOTSUPP : constant := 122; -- Operation not supported - EPFNOSUPPORT : constant := 123; -- Unknown protocol family - EPROTONOSUPPORT : constant := 120; -- Unknown protocol - EPROTOTYPE : constant := 98; -- Unknown protocol type - ESHUTDOWN : constant := 143; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported - ETIMEDOUT : constant := 145; -- Connection timed out - ETOOMANYREFS : constant := 144; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 20; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 21; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 22; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 23; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 24; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-linux-64.ads gcc-4.4.0/gcc/ada/g-soccon-linux-64.ads *** gcc-4.3.3/gcc/ada/g-soccon-linux-64.ads Wed Jun 6 10:54:04 2007 --- gcc-4.4.0/gcc/ada/g-soccon-linux-64.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for ia64-hp-linux-gnu - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 10; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 98; -- Address already in use - EADDRNOTAVAIL : constant := 99; -- Cannot assign address - EAFNOSUPPORT : constant := 97; -- Addr family not supported - EALREADY : constant := 114; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 103; -- Connection aborted - ECONNREFUSED : constant := 111; -- Connection refused - ECONNRESET : constant := 104; -- Connection reset by peer - EDESTADDRREQ : constant := 89; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 112; -- Host is down - EHOSTUNREACH : constant := 113; -- No route to host - EINPROGRESS : constant := 115; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 106; -- Socket already connected - ELOOP : constant := 40; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 90; -- Message too long - ENAMETOOLONG : constant := 36; -- Name too long - ENETDOWN : constant := 100; -- Network is down - ENETRESET : constant := 102; -- Disconn. on network reset - ENETUNREACH : constant := 101; -- Network is unreachable - ENOBUFS : constant := 105; -- No buffer space available - ENOPROTOOPT : constant := 92; -- Protocol not available - ENOTCONN : constant := 107; -- Socket not connected - ENOTSOCK : constant := 88; -- Operation on non socket - EOPNOTSUPP : constant := 95; -- Operation not supported - EPFNOSUPPORT : constant := 96; -- Unknown protocol family - EPROTONOSUPPORT : constant := 93; -- Unknown protocol - EPROTOTYPE : constant := 91; -- Unknown protocol type - ESHUTDOWN : constant := 108; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported - ETIMEDOUT : constant := 110; -- Connection timed out - ETOOMANYREFS : constant := 109; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := 21537; -- Set/clear non-blocking io - FIONREAD : constant := 21531; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 1; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 128; -- Send end of record - MSG_WAITALL : constant := 256; -- Wait for full reception - MSG_NOSIGNAL : constant := 16384; -- No SIGPIPE on send - MSG_Forced_Flags : constant := MSG_NOSIGNAL; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 2; -- Bind reuse local address - SO_KEEPALIVE : constant := 9; -- Enable keep-alive msgs - SO_LINGER : constant := 13; -- Defer close to flush data - SO_BROADCAST : constant := 6; -- Can send broadcast msgs - SO_SNDBUF : constant := 7; -- Set/get send buffer size - SO_RCVBUF : constant := 8; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 21; -- Emission timeout - SO_RCVTIMEO : constant := 20; -- Reception timeout - SO_ERROR : constant := 4; -- Get/clear error status - IP_MULTICAST_IF : constant := 32; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 8; -- tv_sec - SIZEOF_tv_usec : constant := 8; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-linux-ppc.ads gcc-4.4.0/gcc/ada/g-soccon-linux-ppc.ads *** gcc-4.3.3/gcc/ada/g-soccon-linux-ppc.ads Wed Jun 6 10:54:04 2007 --- gcc-4.4.0/gcc/ada/g-soccon-linux-ppc.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for powerpc-linux - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 10; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 98; -- Address already in use - EADDRNOTAVAIL : constant := 99; -- Cannot assign address - EAFNOSUPPORT : constant := 97; -- Addr family not supported - EALREADY : constant := 114; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 103; -- Connection aborted - ECONNREFUSED : constant := 111; -- Connection refused - ECONNRESET : constant := 104; -- Connection reset by peer - EDESTADDRREQ : constant := 89; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 112; -- Host is down - EHOSTUNREACH : constant := 113; -- No route to host - EINPROGRESS : constant := 115; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 106; -- Socket already connected - ELOOP : constant := 40; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 90; -- Message too long - ENAMETOOLONG : constant := 36; -- Name too long - ENETDOWN : constant := 100; -- Network is down - ENETRESET : constant := 102; -- Disconn. on network reset - ENETUNREACH : constant := 101; -- Network is unreachable - ENOBUFS : constant := 105; -- No buffer space available - ENOPROTOOPT : constant := 92; -- Protocol not available - ENOTCONN : constant := 107; -- Socket not connected - ENOTSOCK : constant := 88; -- Operation on non socket - EOPNOTSUPP : constant := 95; -- Operation not supported - EPFNOSUPPORT : constant := 96; -- Unknown protocol family - EPROTONOSUPPORT : constant := 93; -- Unknown protocol - EPROTOTYPE : constant := 91; -- Unknown protocol type - ESHUTDOWN : constant := 108; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported - ETIMEDOUT : constant := 110; -- Connection timed out - ETOOMANYREFS : constant := 109; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 1; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 128; -- Send end of record - MSG_WAITALL : constant := 256; -- Wait for full reception - MSG_NOSIGNAL : constant := 16384; -- No SIGPIPE on send - MSG_Forced_Flags : constant := MSG_NOSIGNAL; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 2; -- Bind reuse local address - SO_KEEPALIVE : constant := 9; -- Enable keep-alive msgs - SO_LINGER : constant := 13; -- Defer close to flush data - SO_BROADCAST : constant := 6; -- Can send broadcast msgs - SO_SNDBUF : constant := 7; -- Set/get send buffer size - SO_RCVBUF : constant := 8; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 19; -- Emission timeout - SO_RCVTIMEO : constant := 18; -- Reception timeout - SO_ERROR : constant := 4; -- Get/clear error status - IP_MULTICAST_IF : constant := 32; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-linux-x86.ads gcc-4.4.0/gcc/ada/g-soccon-linux-x86.ads *** gcc-4.3.3/gcc/ada/g-soccon-linux-x86.ads Wed Jun 6 10:54:04 2007 --- gcc-4.4.0/gcc/ada/g-soccon-linux-x86.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for i686-pc-linux-gnu - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 10; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 98; -- Address already in use - EADDRNOTAVAIL : constant := 99; -- Cannot assign address - EAFNOSUPPORT : constant := 97; -- Addr family not supported - EALREADY : constant := 114; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 103; -- Connection aborted - ECONNREFUSED : constant := 111; -- Connection refused - ECONNRESET : constant := 104; -- Connection reset by peer - EDESTADDRREQ : constant := 89; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 112; -- Host is down - EHOSTUNREACH : constant := 113; -- No route to host - EINPROGRESS : constant := 115; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 106; -- Socket already connected - ELOOP : constant := 40; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 90; -- Message too long - ENAMETOOLONG : constant := 36; -- Name too long - ENETDOWN : constant := 100; -- Network is down - ENETRESET : constant := 102; -- Disconn. on network reset - ENETUNREACH : constant := 101; -- Network is unreachable - ENOBUFS : constant := 105; -- No buffer space available - ENOPROTOOPT : constant := 92; -- Protocol not available - ENOTCONN : constant := 107; -- Socket not connected - ENOTSOCK : constant := 88; -- Operation on non socket - EOPNOTSUPP : constant := 95; -- Operation not supported - EPFNOSUPPORT : constant := 96; -- Unknown protocol family - EPROTONOSUPPORT : constant := 93; -- Unknown protocol - EPROTOTYPE : constant := 91; -- Unknown protocol type - ESHUTDOWN : constant := 108; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported - ETIMEDOUT : constant := 110; -- Connection timed out - ETOOMANYREFS : constant := 109; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := 21537; -- Set/clear non-blocking io - FIONREAD : constant := 21531; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 1; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 128; -- Send end of record - MSG_WAITALL : constant := 256; -- Wait for full reception - MSG_NOSIGNAL : constant := 16384; -- No SIGPIPE on send - MSG_Forced_Flags : constant := MSG_NOSIGNAL; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 2; -- Bind reuse local address - SO_KEEPALIVE : constant := 9; -- Enable keep-alive msgs - SO_LINGER : constant := 13; -- Defer close to flush data - SO_BROADCAST : constant := 6; -- Can send broadcast msgs - SO_SNDBUF : constant := 7; -- Set/get send buffer size - SO_RCVBUF : constant := 8; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 21; -- Emission timeout - SO_RCVTIMEO : constant := 20; -- Reception timeout - SO_ERROR : constant := 4; -- Get/clear error status - IP_MULTICAST_IF : constant := 32; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-lynxos.ads gcc-4.4.0/gcc/ada/g-soccon-lynxos.ads *** gcc-4.3.3/gcc/ada/g-soccon-lynxos.ads Wed Jun 6 10:54:04 2007 --- gcc-4.4.0/gcc/ada/g-soccon-lynxos.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for i386-elf-lynxos - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 28; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 98; -- Address already in use - EADDRNOTAVAIL : constant := 99; -- Cannot assign address - EAFNOSUPPORT : constant := 97; -- Addr family not supported - EALREADY : constant := 114; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 103; -- Connection aborted - ECONNREFUSED : constant := 111; -- Connection refused - ECONNRESET : constant := 104; -- Connection reset by peer - EDESTADDRREQ : constant := 89; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 112; -- Host is down - EHOSTUNREACH : constant := 113; -- No route to host - EINPROGRESS : constant := 115; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 106; -- Socket already connected - ELOOP : constant := 40; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 90; -- Message too long - ENAMETOOLONG : constant := 36; -- Name too long - ENETDOWN : constant := 100; -- Network is down - ENETRESET : constant := 102; -- Disconn. on network reset - ENETUNREACH : constant := 101; -- Network is unreachable - ENOBUFS : constant := 105; -- No buffer space available - ENOPROTOOPT : constant := 92; -- Protocol not available - ENOTCONN : constant := 107; -- Socket not connected - ENOTSOCK : constant := 88; -- Operation on non socket - EOPNOTSUPP : constant := 95; -- Operation not supported - EPFNOSUPPORT : constant := 96; -- Unknown protocol family - EPROTONOSUPPORT : constant := 93; -- Unknown protocol - EPROTOTYPE : constant := 91; -- Unknown protocol type - ESHUTDOWN : constant := 108; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported - ETIMEDOUT : constant := 110; -- Connection timed out - ETOOMANYREFS : constant := 109; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := 21537; -- Set/clear non-blocking io - FIONREAD : constant := 21531; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 128; -- Send end of record - MSG_WAITALL : constant := 256; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-mingw.ads gcc-4.4.0/gcc/ada/g-soccon-mingw.ads *** gcc-4.3.3/gcc/ada/g-soccon-mingw.ads Wed Jun 6 10:13:25 2007 --- gcc-4.4.0/gcc/ada/g-soccon-mingw.ads Thu Jan 1 00:00:00 1970 *************** *** 1,206 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for pentium-mingw32msv - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 23; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 10013; -- Permission denied - EADDRINUSE : constant := 10048; -- Address already in use - EADDRNOTAVAIL : constant := 10049; -- Cannot assign address - EAFNOSUPPORT : constant := 10047; -- Addr family not supported - EALREADY : constant := 10037; -- Operation in progress - EBADF : constant := 10009; -- Bad file descriptor - ECONNABORTED : constant := 10053; -- Connection aborted - ECONNREFUSED : constant := 10061; -- Connection refused - ECONNRESET : constant := 10054; -- Connection reset by peer - EDESTADDRREQ : constant := 10039; -- Destination addr required - EFAULT : constant := 10014; -- Bad address - EHOSTDOWN : constant := 10064; -- Host is down - EHOSTUNREACH : constant := 10065; -- No route to host - EINPROGRESS : constant := 10036; -- Operation now in progress - EINTR : constant := 10004; -- Interrupted system call - EINVAL : constant := 10022; -- Invalid argument - EIO : constant := 10101; -- Input output error - EISCONN : constant := 10056; -- Socket already connected - ELOOP : constant := 10062; -- Too many symbolic lynks - EMFILE : constant := 10024; -- Too many open files - EMSGSIZE : constant := 10040; -- Message too long - ENAMETOOLONG : constant := 10063; -- Name too long - ENETDOWN : constant := 10050; -- Network is down - ENETRESET : constant := 10052; -- Disconn. on network reset - ENETUNREACH : constant := 10051; -- Network is unreachable - ENOBUFS : constant := 10055; -- No buffer space available - ENOPROTOOPT : constant := 10042; -- Protocol not available - ENOTCONN : constant := 10057; -- Socket not connected - ENOTSOCK : constant := 10038; -- Operation on non socket - EOPNOTSUPP : constant := 10045; -- Operation not supported - EPFNOSUPPORT : constant := 10046; -- Unknown protocol family - EPROTONOSUPPORT : constant := 10043; -- Unknown protocol - EPROTOTYPE : constant := 10041; -- Unknown protocol type - ESHUTDOWN : constant := 10058; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 10044; -- Socket type not supported - ETIMEDOUT : constant := 10060; -- Connection timed out - ETOOMANYREFS : constant := 10059; -- Too many references - EWOULDBLOCK : constant := 10035; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 11001; -- Unknown host - TRY_AGAIN : constant := 11002; -- Host name lookup failure - NO_DATA : constant := 11004; -- No data record for name - NO_RECOVERY : constant := 11003; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := -1; -- Send end of record - MSG_WAITALL : constant := -1; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - ------------------------------ - -- MinGW-specific constants -- - ------------------------------ - - -- These constants may be used only within the MinGW version of - -- GNAT.Sockets.Thin. - - WSASYSNOTREADY : constant := 10091; -- System not ready - WSAVERNOTSUPPORTED : constant := 10092; -- Version not supported - WSANOTINITIALISED : constant := 10093; -- Winsock not intialized - WSAEDISCON : constant := 10101; -- Disconnected - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-rtems.ads gcc-4.4.0/gcc/ada/g-soccon-rtems.ads *** gcc-4.3.3/gcc/ada/g-soccon-rtems.ads Wed Feb 13 19:04:53 2008 --- gcc-4.4.0/gcc/ada/g-soccon-rtems.ads Thu Jan 1 00:00:00 1970 *************** *** 1,195 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for RTEMS - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 28; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 112; -- Address already in use - EADDRNOTAVAIL : constant := 125; -- Cannot assign address - EAFNOSUPPORT : constant := 106; -- Addr family not supported - EALREADY : constant := 120; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 113; -- Connection aborted - ECONNREFUSED : constant := 111; -- Connection refused - ECONNRESET : constant := 104; -- Connection reset by peer - EDESTADDRREQ : constant := 121; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 117; -- Host is down - EHOSTUNREACH : constant := 118; -- No route to host - EINPROGRESS : constant := 119; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 127; -- Socket already connected - ELOOP : constant := 92; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 122; -- Message too long - ENAMETOOLONG : constant := 91; -- Name too long - ENETDOWN : constant := 115; -- Network is down - ENETRESET : constant := 126; -- Disconn. on network reset - ENETUNREACH : constant := 114; -- Network is unreachable - ENOBUFS : constant := 105; -- No buffer space available - ENOPROTOOPT : constant := 109; -- Protocol not available - ENOTCONN : constant := 128; -- Socket not connected - ENOTSOCK : constant := 108; -- Operation on non socket - EOPNOTSUPP : constant := 95; -- Operation not supported - EPFNOSUPPORT : constant := 96; -- Unknown protocol family - EPROTONOSUPPORT : constant := 123; -- Unknown protocol - EPROTOTYPE : constant := 107; -- Unknown protocol type - ESHUTDOWN : constant := 110; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 124; -- Socket type not supported - ETIMEDOUT : constant := 116; -- Connection timed out - ETOOMANYREFS : constant := 129; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := -1; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 1024; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-solaris-64.ads gcc-4.4.0/gcc/ada/g-soccon-solaris-64.ads *** gcc-4.3.3/gcc/ada/g-soccon-solaris-64.ads Wed Sep 12 11:59:17 2007 --- gcc-4.4.0/gcc/ada/g-soccon-solaris-64.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for sparc-sun-solaris2.8/64 - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 26; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 2; -- Stream socket - SOCK_DGRAM : constant := 1; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 125; -- Address already in use - EADDRNOTAVAIL : constant := 126; -- Cannot assign address - EAFNOSUPPORT : constant := 124; -- Addr family not supported - EALREADY : constant := 149; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 130; -- Connection aborted - ECONNREFUSED : constant := 146; -- Connection refused - ECONNRESET : constant := 131; -- Connection reset by peer - EDESTADDRREQ : constant := 96; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 147; -- Host is down - EHOSTUNREACH : constant := 148; -- No route to host - EINPROGRESS : constant := 150; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 133; -- Socket already connected - ELOOP : constant := 90; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 97; -- Message too long - ENAMETOOLONG : constant := 78; -- Name too long - ENETDOWN : constant := 127; -- Network is down - ENETRESET : constant := 129; -- Disconn. on network reset - ENETUNREACH : constant := 128; -- Network is unreachable - ENOBUFS : constant := 132; -- No buffer space available - ENOPROTOOPT : constant := 99; -- Protocol not available - ENOTCONN : constant := 134; -- Socket not connected - ENOTSOCK : constant := 95; -- Operation on non socket - EOPNOTSUPP : constant := 122; -- Operation not supported - EPFNOSUPPORT : constant := 123; -- Unknown protocol family - EPROTONOSUPPORT : constant := 120; -- Unknown protocol - EPROTOTYPE : constant := 98; -- Unknown protocol type - ESHUTDOWN : constant := 143; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported - ETIMEDOUT : constant := 145; -- Connection timed out - ETOOMANYREFS : constant := 144; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 16; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 17; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 18; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 19; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 20; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 16; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 8; -- tv_sec - SIZEOF_tv_usec : constant := 8; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-solaris.ads gcc-4.4.0/gcc/ada/g-soccon-solaris.ads *** gcc-4.3.3/gcc/ada/g-soccon-solaris.ads Wed Jun 6 10:13:25 2007 --- gcc-4.4.0/gcc/ada/g-soccon-solaris.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for sparc-sun-solaris2.8 - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 26; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 2; -- Stream socket - SOCK_DGRAM : constant := 1; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 125; -- Address already in use - EADDRNOTAVAIL : constant := 126; -- Cannot assign address - EAFNOSUPPORT : constant := 124; -- Addr family not supported - EALREADY : constant := 149; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 130; -- Connection aborted - ECONNREFUSED : constant := 146; -- Connection refused - ECONNRESET : constant := 131; -- Connection reset by peer - EDESTADDRREQ : constant := 96; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 147; -- Host is down - EHOSTUNREACH : constant := 148; -- No route to host - EINPROGRESS : constant := 150; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 133; -- Socket already connected - ELOOP : constant := 90; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 97; -- Message too long - ENAMETOOLONG : constant := 78; -- Name too long - ENETDOWN : constant := 127; -- Network is down - ENETRESET : constant := 129; -- Disconn. on network reset - ENETUNREACH : constant := 128; -- Network is unreachable - ENOBUFS : constant := 132; -- No buffer space available - ENOPROTOOPT : constant := 99; -- Protocol not available - ENOTCONN : constant := 134; -- Socket not connected - ENOTSOCK : constant := 95; -- Operation on non socket - EOPNOTSUPP : constant := 122; -- Operation not supported - EPFNOSUPPORT : constant := 123; -- Unknown protocol family - EPROTONOSUPPORT : constant := 120; -- Unknown protocol - EPROTOTYPE : constant := 98; -- Unknown protocol type - ESHUTDOWN : constant := 143; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported - ETIMEDOUT : constant := 145; -- Connection timed out - ETOOMANYREFS : constant := 144; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 16; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 17; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 18; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 19; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 20; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 16; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-tru64.ads gcc-4.4.0/gcc/ada/g-soccon-tru64.ads *** gcc-4.3.3/gcc/ada/g-soccon-tru64.ads Wed Jun 6 10:13:25 2007 --- gcc-4.4.0/gcc/ada/g-soccon-tru64.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for alphaev56-dec-osf5.1 - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 26; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 37; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 39; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 64; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 36; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 62; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 40; -- Message too long - ENAMETOOLONG : constant := 63; -- Name too long - ENETDOWN : constant := 50; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 38; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 35; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 1024; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-vms.ads gcc-4.4.0/gcc/ada/g-soccon-vms.ads *** gcc-4.3.3/gcc/ada/g-soccon-vms.ads Mon Oct 15 13:58:10 2007 --- gcc-4.4.0/gcc/ada/g-soccon-vms.ads Thu Jan 1 00:00:00 1970 *************** *** 1,194 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for OpenVMS - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 26; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 37; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 39; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 64; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 36; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 62; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 40; -- Message too long - ENAMETOOLONG : constant := 63; -- Name too long - ENETDOWN : constant := 50; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 38; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 35; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 128; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 1024; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon-vxworks.ads gcc-4.4.0/gcc/ada/g-soccon-vxworks.ads *** gcc-4.3.3/gcc/ada/g-soccon-vxworks.ads Wed Jun 6 10:13:25 2007 --- gcc-4.4.0/gcc/ada/g-soccon-vxworks.ads Thu Jan 1 00:00:00 1970 *************** *** 1,204 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2000-2007, 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This package provides target dependent definitions of constant for use - -- by the GNAT.Sockets package (g-socket.ads). This package should not be - -- directly with'ed by an applications program. - - -- This is the version for powerpc-wrs-vxworks - -- This file is generated automatically, do not modify it by hand! Instead, - -- make changes to gen-soccon.c and re-run it on each target. - - package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := -1; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 69; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 40; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 67; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 68; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 64; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 36; -- Message too long - ENAMETOOLONG : constant := 26; -- Name too long - ENETDOWN : constant := 62; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 50; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 70; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := 16; -- Set/clear non-blocking io - FIONREAD : constant := 1; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - -- Flags set on all send(2) calls - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - - ------------------- - -- System limits -- - ------------------- - - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt - - ---------------------- - -- Type definitions -- - ---------------------- - - -- Sizes (in bytes) of the components of struct timeval - - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec - - ---------------------------------------- - -- Properties of supported interfaces -- - ---------------------------------------- - - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking - - -------------------------------- - -- VxWorks-specific constants -- - -------------------------------- - - -- These constants may be used only within the VxWorks version of - -- GNAT.Sockets.Thin. - - OK : constant := 0; -- VxWorks generic success - ERROR : constant := -1; -- VxWorks generic error - - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soccon.ads gcc-4.4.0/gcc/ada/g-soccon.ads *** gcc-4.3.3/gcc/ada/g-soccon.ads Wed Jun 6 10:31:06 2007 --- gcc-4.4.0/gcc/ada/g-soccon.ads Thu Apr 9 23:23:07 2009 *************** *** 6,201 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package provides target dependent definitions of constant for use ! -- by the GNAT.Sockets package (g-socket.ads). This package should not be ! -- directly with'ed by an applications program. ! ! -- WARNING! This file is a default version that must be replaced for ! -- each platform by running gen-soccon.c which automatically generates ! -- the appropriate target specific values. ! ! -- The values below were computed from a i686-pc-linux-gnu environment, ! -- but are for illustration purposes only. As noted above, part of a port ! -- to a new target is to replace this file appropriately. ! ! -- This file is generated automatically, do not modify it by hand! Instead, ! -- make changes to gen-soccon.c and re-run it on each target. ! ! package GNAT.Sockets.Constants is ! ! -------------- ! -- Families -- ! -------------- ! ! AF_INET : constant := 2; -- IPv4 address family ! AF_INET6 : constant := 10; -- IPv6 address family ! ! ----------- ! -- Modes -- ! ----------- ! ! SOCK_STREAM : constant := 1; -- Stream socket ! SOCK_DGRAM : constant := 2; -- Datagram socket ! ! ------------------- ! -- Socket errors -- ! ------------------- ! ! EACCES : constant := 13; -- Permission denied ! EADDRINUSE : constant := 98; -- Address already in use ! EADDRNOTAVAIL : constant := 99; -- Cannot assign address ! EAFNOSUPPORT : constant := 97; -- Addr family not supported ! EALREADY : constant := 114; -- Operation in progress ! EBADF : constant := 9; -- Bad file descriptor ! ECONNABORTED : constant := 103; -- Connection aborted ! ECONNREFUSED : constant := 111; -- Connection refused ! ECONNRESET : constant := 104; -- Connection reset by peer ! EDESTADDRREQ : constant := 89; -- Destination addr required ! EFAULT : constant := 14; -- Bad address ! EHOSTDOWN : constant := 112; -- Host is down ! EHOSTUNREACH : constant := 113; -- No route to host ! EINPROGRESS : constant := 115; -- Operation now in progress ! EINTR : constant := 4; -- Interrupted system call ! EINVAL : constant := 22; -- Invalid argument ! EIO : constant := 5; -- Input output error ! EISCONN : constant := 106; -- Socket already connected ! ELOOP : constant := 40; -- Too many symbolic lynks ! EMFILE : constant := 24; -- Too many open files ! EMSGSIZE : constant := 90; -- Message too long ! ENAMETOOLONG : constant := 36; -- Name too long ! ENETDOWN : constant := 100; -- Network is down ! ENETRESET : constant := 102; -- Disconn. on network reset ! ENETUNREACH : constant := 101; -- Network is unreachable ! ENOBUFS : constant := 105; -- No buffer space available ! ENOPROTOOPT : constant := 92; -- Protocol not available ! ENOTCONN : constant := 107; -- Socket not connected ! ENOTSOCK : constant := 88; -- Operation on non socket ! EOPNOTSUPP : constant := 95; -- Operation not supported ! EPFNOSUPPORT : constant := 96; -- Unknown protocol family ! EPROTONOSUPPORT : constant := 93; -- Unknown protocol ! EPROTOTYPE : constant := 91; -- Unknown protocol type ! ESHUTDOWN : constant := 108; -- Cannot send once shutdown ! ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported ! ETIMEDOUT : constant := 110; -- Connection timed out ! ETOOMANYREFS : constant := 109; -- Too many references ! EWOULDBLOCK : constant := 11; -- Operation would block ! ! ----------------- ! -- Host errors -- ! ----------------- ! ! HOST_NOT_FOUND : constant := 1; -- Unknown host ! TRY_AGAIN : constant := 2; -- Host name lookup failure ! NO_DATA : constant := 4; -- No data record for name ! NO_RECOVERY : constant := 3; -- Non recoverable errors ! ! ------------------- ! -- Control flags -- ! ------------------- ! ! FIONBIO : constant := 21537; -- Set/clear non-blocking io ! FIONREAD : constant := 21531; -- How many bytes to read ! ! -------------------- ! -- Shutdown modes -- ! -------------------- ! ! SHUT_RD : constant := 0; -- No more recv ! SHUT_WR : constant := 1; -- No more send ! SHUT_RDWR : constant := 2; -- No more recv/send ! ! --------------------- ! -- Protocol levels -- ! --------------------- ! ! SOL_SOCKET : constant := 1; -- Options for socket level ! IPPROTO_IP : constant := 0; -- Dummy protocol for IP ! IPPROTO_UDP : constant := 17; -- UDP ! IPPROTO_TCP : constant := 6; -- TCP ! ! ------------------- ! -- Request flags -- ! ------------------- ! ! MSG_OOB : constant := 1; -- Process out-of-band data ! MSG_PEEK : constant := 2; -- Peek at incoming data ! MSG_EOR : constant := 128; -- Send end of record ! MSG_WAITALL : constant := 256; -- Wait for full reception ! MSG_NOSIGNAL : constant := 16384; -- No SIGPIPE on send ! MSG_Forced_Flags : constant := MSG_NOSIGNAL; ! -- Flags set on all send(2) calls ! ! -------------------- ! -- Socket options -- ! -------------------- ! ! TCP_NODELAY : constant := 1; -- Do not coalesce packets ! SO_REUSEADDR : constant := 2; -- Bind reuse local address ! SO_KEEPALIVE : constant := 9; -- Enable keep-alive msgs ! SO_LINGER : constant := 13; -- Defer close to flush data ! SO_BROADCAST : constant := 6; -- Can send broadcast msgs ! SO_SNDBUF : constant := 7; -- Set/get send buffer size ! SO_RCVBUF : constant := 8; -- Set/get recv buffer size ! SO_SNDTIMEO : constant := 21; -- Emission timeout ! SO_RCVTIMEO : constant := 20; -- Reception timeout ! SO_ERROR : constant := 4; -- Get/clear error status ! IP_MULTICAST_IF : constant := 32; -- Set/get mcast interface ! IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL ! IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback ! IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group ! IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group ! ! ------------------- ! -- System limits -- ! ------------------- ! ! IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt ! ! ---------------------- ! -- Type definitions -- ! ---------------------- ! ! -- Sizes (in bytes) of the components of struct timeval ! ! SIZEOF_tv_sec : constant := 4; -- tv_sec ! SIZEOF_tv_usec : constant := 4; -- tv_usec ! ! ---------------------------------------- ! -- Properties of supported interfaces -- ! ---------------------------------------- ! ! Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops ! ! ---------------------- ! -- Additional flags -- ! ---------------------- ! Thread_Blocking_IO : constant Boolean := True; ! -- Set False for contexts where socket i/o are process blocking ! end GNAT.Sockets.Constants; --- 6,40 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package provides a temporary compatibility renaming for deprecated ! -- internal package GNAT.Sockets.Constants. ! -- This package should not be directly used by an applications program. ! -- It is a compatibility artefact to help building legacy code with newer ! -- compilers, and will be removed at some point in the future. ! with System.OS_Constants; ! package GNAT.Sockets.Constants renames System.OS_Constants; diff -Nrcpad gcc-4.3.3/gcc/ada/g-socket-dummy.adb gcc-4.4.0/gcc/ada/g-socket-dummy.adb *** gcc-4.3.3/gcc/ada/g-socket-dummy.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-socket-dummy.adb Wed Aug 6 08:57:21 2008 *************** *** 0 **** --- 1,34 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2001-2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + pragma No_Body; diff -Nrcpad gcc-4.3.3/gcc/ada/g-socket-dummy.ads gcc-4.4.0/gcc/ada/g-socket-dummy.ads *** gcc-4.3.3/gcc/ada/g-socket-dummy.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-socket-dummy.ads Wed Aug 6 08:57:21 2008 *************** *** 0 **** --- 1,39 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2001-2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package is a placeholder for the sockets binding for platforms where + -- it is not implemented. + + package GNAT.Sockets is + pragma Unimplemented_Unit; + end GNAT.Sockets; diff -Nrcpad gcc-4.3.3/gcc/ada/g-socket.adb gcc-4.4.0/gcc/ada/g-socket.adb *** gcc-4.3.3/gcc/ada/g-socket.adb Thu Dec 13 10:59:30 2007 --- gcc-4.4.0/gcc/ada/g-socket.adb Wed Aug 20 12:07:22 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** with Ada.Exceptions; use Ada.E *** 36,42 **** with Ada.Unchecked_Conversion; with Interfaces.C.Strings; ! with GNAT.Sockets.Constants; with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; with GNAT.Sockets.Thin.Task_Safe_NetDB; use GNAT.Sockets.Thin.Task_Safe_NetDB; --- 36,43 ---- with Ada.Unchecked_Conversion; with Interfaces.C.Strings; ! ! with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common; with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; with GNAT.Sockets.Thin.Task_Safe_NetDB; use GNAT.Sockets.Thin.Task_Safe_NetDB; *************** with System; use System; *** 48,53 **** --- 49,56 ---- package body GNAT.Sockets is + package C renames Interfaces.C; + use type C.int; Finalized : Boolean := False; *************** package body GNAT.Sockets is *** 55,113 **** ENOERROR : constant := 0; ! Netdb_Buffer_Size : constant := Constants.Need_Netdb_Buffer * 1024; -- The network database functions gethostbyname, gethostbyaddr, -- getservbyname and getservbyport can either be guaranteed task safe by -- the operating system, or else return data through a user-provided buffer -- to ensure concurrent uses do not interfere. ! -- Correspondance tables ! ! Families : constant array (Family_Type) of C.int := ! (Family_Inet => Constants.AF_INET, ! Family_Inet6 => Constants.AF_INET6); Levels : constant array (Level_Type) of C.int := ! (Socket_Level => Constants.SOL_SOCKET, ! IP_Protocol_For_IP_Level => Constants.IPPROTO_IP, ! IP_Protocol_For_UDP_Level => Constants.IPPROTO_UDP, ! IP_Protocol_For_TCP_Level => Constants.IPPROTO_TCP); Modes : constant array (Mode_Type) of C.int := ! (Socket_Stream => Constants.SOCK_STREAM, ! Socket_Datagram => Constants.SOCK_DGRAM); Shutmodes : constant array (Shutmode_Type) of C.int := ! (Shut_Read => Constants.SHUT_RD, ! Shut_Write => Constants.SHUT_WR, ! Shut_Read_Write => Constants.SHUT_RDWR); Requests : constant array (Request_Name) of C.int := ! (Non_Blocking_IO => Constants.FIONBIO, ! N_Bytes_To_Read => Constants.FIONREAD); Options : constant array (Option_Name) of C.int := ! (Keep_Alive => Constants.SO_KEEPALIVE, ! Reuse_Address => Constants.SO_REUSEADDR, ! Broadcast => Constants.SO_BROADCAST, ! Send_Buffer => Constants.SO_SNDBUF, ! Receive_Buffer => Constants.SO_RCVBUF, ! Linger => Constants.SO_LINGER, ! Error => Constants.SO_ERROR, ! No_Delay => Constants.TCP_NODELAY, ! Add_Membership => Constants.IP_ADD_MEMBERSHIP, ! Drop_Membership => Constants.IP_DROP_MEMBERSHIP, ! Multicast_If => Constants.IP_MULTICAST_IF, ! Multicast_TTL => Constants.IP_MULTICAST_TTL, ! Multicast_Loop => Constants.IP_MULTICAST_LOOP, ! Send_Timeout => Constants.SO_SNDTIMEO, ! Receive_Timeout => Constants.SO_RCVTIMEO); Flags : constant array (0 .. 3) of C.int := ! (0 => Constants.MSG_OOB, -- Process_Out_Of_Band_Data ! 1 => Constants.MSG_PEEK, -- Peek_At_Incoming_Data ! 2 => Constants.MSG_WAITALL, -- Wait_For_A_Full_Reception ! 3 => Constants.MSG_EOR); -- Send_End_Of_Record Socket_Error_Id : constant Exception_Id := Socket_Error'Identity; Host_Error_Id : constant Exception_Id := Host_Error'Identity; --- 58,115 ---- ENOERROR : constant := 0; ! Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024; -- The network database functions gethostbyname, gethostbyaddr, -- getservbyname and getservbyport can either be guaranteed task safe by -- the operating system, or else return data through a user-provided buffer -- to ensure concurrent uses do not interfere. ! -- Correspondence tables Levels : constant array (Level_Type) of C.int := ! (Socket_Level => SOSC.SOL_SOCKET, ! IP_Protocol_For_IP_Level => SOSC.IPPROTO_IP, ! IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP, ! IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP); Modes : constant array (Mode_Type) of C.int := ! (Socket_Stream => SOSC.SOCK_STREAM, ! Socket_Datagram => SOSC.SOCK_DGRAM); Shutmodes : constant array (Shutmode_Type) of C.int := ! (Shut_Read => SOSC.SHUT_RD, ! Shut_Write => SOSC.SHUT_WR, ! Shut_Read_Write => SOSC.SHUT_RDWR); Requests : constant array (Request_Name) of C.int := ! (Non_Blocking_IO => SOSC.FIONBIO, ! N_Bytes_To_Read => SOSC.FIONREAD); Options : constant array (Option_Name) of C.int := ! (Keep_Alive => SOSC.SO_KEEPALIVE, ! Reuse_Address => SOSC.SO_REUSEADDR, ! Broadcast => SOSC.SO_BROADCAST, ! Send_Buffer => SOSC.SO_SNDBUF, ! Receive_Buffer => SOSC.SO_RCVBUF, ! Linger => SOSC.SO_LINGER, ! Error => SOSC.SO_ERROR, ! No_Delay => SOSC.TCP_NODELAY, ! Add_Membership => SOSC.IP_ADD_MEMBERSHIP, ! Drop_Membership => SOSC.IP_DROP_MEMBERSHIP, ! Multicast_If => SOSC.IP_MULTICAST_IF, ! Multicast_TTL => SOSC.IP_MULTICAST_TTL, ! Multicast_Loop => SOSC.IP_MULTICAST_LOOP, ! Receive_Packet_Info => SOSC.IP_PKTINFO, ! Send_Timeout => SOSC.SO_SNDTIMEO, ! Receive_Timeout => SOSC.SO_RCVTIMEO); ! -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO, ! -- but for Linux compatibility this constant is the same as IP_PKTINFO. Flags : constant array (0 .. 3) of C.int := ! (0 => SOSC.MSG_OOB, -- Process_Out_Of_Band_Data ! 1 => SOSC.MSG_PEEK, -- Peek_At_Incoming_Data ! 2 => SOSC.MSG_WAITALL, -- Wait_For_A_Full_Reception ! 3 => SOSC.MSG_EOR); -- Send_End_Of_Record Socket_Error_Id : constant Exception_Id := Socket_Error'Identity; Host_Error_Id : constant Exception_Id := Host_Error'Identity; *************** package body GNAT.Sockets is *** 115,123 **** Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF"; -- Use to print in hexadecimal format - function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); - function To_Int is new Ada.Unchecked_Conversion (In_Addr, C.int); - function Err_Code_Image (E : Integer) return String; -- Return the value of E surrounded with brackets --- 117,122 ---- *************** package body GNAT.Sockets is *** 139,145 **** -- Return the int value corresponding to the specified flags combination function Set_Forced_Flags (F : C.int) return C.int; ! -- Return F with the bits from Constants.MSG_Forced_Flags forced set function Short_To_Network (S : C.unsigned_short) return C.unsigned_short; --- 138,144 ---- -- Return the int value corresponding to the specified flags combination function Set_Forced_Flags (F : C.int) return C.int; ! -- Return F with the bits from SOSC.MSG_Forced_Flags forced set function Short_To_Network (S : C.unsigned_short) return C.unsigned_short; *************** package body GNAT.Sockets is *** 149,155 **** function Network_To_Short (S : C.unsigned_short) return C.unsigned_short renames Short_To_Network; ! -- Symetric operation function Image (Val : Inet_Addr_VN_Type; --- 148,154 ---- function Network_To_Short (S : C.unsigned_short) return C.unsigned_short renames Short_To_Network; ! -- Symmetric operation function Image (Val : Inet_Addr_VN_Type; *************** package body GNAT.Sockets is *** 159,165 **** function Is_IP_Address (Name : String) return Boolean; -- Return true when Name is an IP address in standard dot notation ! function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr; procedure To_Inet_Addr (Addr : In_Addr; Result : out Inet_Addr_Type); --- 158,164 ---- function Is_IP_Address (Name : String) return Boolean; -- Return true when Name is an IP address in standard dot notation ! function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr; procedure To_Inet_Addr (Addr : In_Addr; Result : out Inet_Addr_Type); *************** package body GNAT.Sockets is *** 227,232 **** --- 226,243 ---- (Stream : in out Stream_Socket_Stream_Type; Item : Ada.Streams.Stream_Element_Array); + procedure Wait_On_Socket + (Socket : Socket_Type; + For_Read : Boolean; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status); + -- Common code for variants of socket operations supporting a timeout: + -- block in Check_Selector on Socket for at most the indicated timeout. + -- If For_Read is True, Socket is added to the read set for this call, else + -- it is added to the write set. If no selector is provided, a local one is + -- created for this call and destroyed prior to returning. + --------- -- "+" -- --------- *************** package body GNAT.Sockets is *** 279,284 **** --- 290,326 ---- Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); end Accept_Socket; + ------------------- + -- Accept_Socket -- + ------------------- + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) + is + begin + -- Wait for socket to become available for reading + + Wait_On_Socket + (Socket => Server, + For_Read => True, + Timeout => Timeout, + Selector => Selector, + Status => Status); + + -- Accept connection if available + + if Status = Completed then + Accept_Socket (Server, Socket, Address); + else + Socket := No_Socket; + end if; + end Accept_Socket; + --------------- -- Addresses -- --------------- *************** package body GNAT.Sockets is *** 353,366 **** Res : C.int; Sin : aliased Sockaddr_In; Len : constant C.int := Sin'Size / 8; begin if Address.Family = Family_Inet6 then ! raise Socket_Error; end if; ! Set_Length (Sin'Unchecked_Access, Len); ! Set_Family (Sin'Unchecked_Access, Families (Address.Family)); Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr)); Set_Port (Sin'Unchecked_Access, --- 395,408 ---- Res : C.int; Sin : aliased Sockaddr_In; Len : constant C.int := Sin'Size / 8; + -- This assumes that Address.Family = Family_Inet??? begin if Address.Family = Family_Inet6 then ! raise Socket_Error with "IPv6 not supported"; end if; ! Set_Family (Sin.Sin_Family, Address.Family); Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr)); Set_Port (Sin'Unchecked_Access, *************** package body GNAT.Sockets is *** 384,395 **** Status : out Selector_Status; Timeout : Selector_Duration := Forever) is ! E_Socket_Set : Socket_Set_Type; -- (No_Socket, No_Socket_Set) begin Check_Selector (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout); end Check_Selector; procedure Check_Selector (Selector : in out Selector_Type; R_Socket_Set : in out Socket_Set_Type; --- 426,441 ---- Status : out Selector_Status; Timeout : Selector_Duration := Forever) is ! E_Socket_Set : Socket_Set_Type; -- (No_Socket, No_Fd_Set_Access) begin Check_Selector (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout); end Check_Selector; + -------------------- + -- Check_Selector -- + -------------------- + procedure Check_Selector (Selector : in out Selector_Type; R_Socket_Set : in out Socket_Set_Type; *************** package body GNAT.Sockets is *** 544,550 **** Signalling_Fds.Close (C.int (Selector.W_Sig_Socket)); -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any ! -- (errneous) subsequent attempt to use this selector properly fails. Selector.R_Sig_Socket := No_Socket; Selector.W_Sig_Socket := No_Socket; --- 590,596 ---- Signalling_Fds.Close (C.int (Selector.W_Sig_Socket)); -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any ! -- (erroneous) subsequent attempt to use this selector properly fails. Selector.R_Sig_Socket := No_Socket; Selector.W_Sig_Socket := No_Socket; *************** package body GNAT.Sockets is *** 571,591 **** procedure Connect_Socket (Socket : Socket_Type; ! Server : in out Sock_Addr_Type) is - pragma Warnings (Off, Server); - Res : C.int; Sin : aliased Sockaddr_In; Len : constant C.int := Sin'Size / 8; begin if Server.Family = Family_Inet6 then ! raise Socket_Error; end if; ! Set_Length (Sin'Unchecked_Access, Len); ! Set_Family (Sin'Unchecked_Access, Families (Server.Family)); Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr)); Set_Port (Sin'Unchecked_Access, --- 617,634 ---- procedure Connect_Socket (Socket : Socket_Type; ! Server : Sock_Addr_Type) is Res : C.int; Sin : aliased Sockaddr_In; Len : constant C.int := Sin'Size / 8; begin if Server.Family = Family_Inet6 then ! raise Socket_Error with "IPv6 not supported"; end if; ! Set_Family (Sin.Sin_Family, Server.Family); Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr)); Set_Port (Sin'Unchecked_Access, *************** package body GNAT.Sockets is *** 599,604 **** --- 642,696 ---- end Connect_Socket; -------------------- + -- Connect_Socket -- + -------------------- + + procedure Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) + is + Req : Request_Type; + -- Used to set Socket to non-blocking I/O + + begin + -- Set the socket to non-blocking I/O + + Req := (Name => Non_Blocking_IO, Enabled => True); + Control_Socket (Socket, Request => Req); + + -- Start operation (non-blocking), will raise Socket_Error with + -- EINPROGRESS. + + begin + Connect_Socket (Socket, Server); + exception + when E : Socket_Error => + if Resolve_Exception (E) = Operation_Now_In_Progress then + null; + else + raise; + end if; + end; + + -- Wait for socket to become available for writing + + Wait_On_Socket + (Socket => Socket, + For_Read => False, + Timeout => Timeout, + Selector => Selector, + Status => Status); + + -- Reset the socket to blocking I/O + + Req := (Name => Non_Blocking_IO, Enabled => False); + Control_Socket (Socket, Request => Req); + end Connect_Socket; + + -------------------- -- Control_Socket -- -------------------- *************** package body GNAT.Sockets is *** 703,711 **** procedure Empty (Item : in out Socket_Set_Type) is begin ! if Item.Set /= No_Socket_Set then Free_Socket_Set (Item.Set); ! Item.Set := No_Socket_Set; end if; Item.Last := No_Socket; --- 795,803 ---- procedure Empty (Item : in out Socket_Set_Type) is begin ! if Item.Set /= No_Fd_Set_Access then Free_Socket_Set (Item.Set); ! Item.Set := No_Fd_Set_Access; end if; Item.Last := No_Socket; *************** package body GNAT.Sockets is *** 762,772 **** -- Get_Address -- ----------------- ! function Get_Address (Stream : Stream_Access) return Sock_Addr_Type is begin ! if Stream = null then ! raise Socket_Error; ! elsif Stream.all in Datagram_Socket_Stream_Type then return Datagram_Socket_Stream_Type (Stream.all).From; else return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket); --- 854,864 ---- -- Get_Address -- ----------------- ! function Get_Address ! (Stream : not null Stream_Access) return Sock_Addr_Type ! is begin ! if Stream.all in Datagram_Socket_Stream_Type then return Datagram_Socket_Stream_Type (Stream.all).From; else return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket); *************** package body GNAT.Sockets is *** 790,796 **** Err : aliased C.int; begin ! if Safe_Gethostbyaddr (HA'Address, HA'Size / 8, Constants.AF_INET, Res'Access, Buf'Address, Buflen, Err'Access) /= 0 then Raise_Host_Error (Integer (Err)); --- 882,888 ---- Err : aliased C.int; begin ! if Safe_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET, Res'Access, Buf'Address, Buflen, Err'Access) /= 0 then Raise_Host_Error (Integer (Err)); *************** package body GNAT.Sockets is *** 865,872 **** begin if Safe_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then ! Ada.Exceptions.Raise_Exception ! (Service_Error'Identity, "Service not found"); end if; -- Translate from the C format to the API format --- 957,963 ---- begin if Safe_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then ! raise Service_Error with "Service not found"; end if; -- Translate from the C format to the API format *************** package body GNAT.Sockets is *** 892,899 **** (C.int (Short_To_Network (C.unsigned_short (Port))), SP, Res'Access, Buf'Address, Buflen) /= 0 then ! Ada.Exceptions.Raise_Exception ! (Service_Error'Identity, "Service not found"); end if; -- Translate from the C format to the API format --- 983,989 ---- (C.int (Short_To_Network (C.unsigned_short (Port))), SP, Res'Access, Buf'Address, Buflen) /= 0 then ! raise Service_Error with "Service not found"; end if; -- Translate from the C format to the API format *************** package body GNAT.Sockets is *** 946,953 **** begin case Name is ! when Multicast_Loop | ! Multicast_TTL => Len := V1'Size / 8; Add := V1'Address; --- 1036,1044 ---- begin case Name is ! when Multicast_Loop | ! Multicast_TTL | ! Receive_Packet_Info => Len := V1'Size / 8; Add := V1'Address; *************** package body GNAT.Sockets is *** 1015,1021 **** when Multicast_TTL => Opt.Time_To_Live := Integer (V1); ! when Multicast_Loop => Opt.Enabled := (V1 /= 0); when Send_Timeout | --- 1106,1113 ---- when Multicast_TTL => Opt.Time_To_Live := Integer (V1); ! when Multicast_Loop | ! Receive_Packet_Info => Opt.Enabled := (V1 /= 0); when Send_Timeout | *************** package body GNAT.Sockets is *** 1168,1174 **** -- calling Inet_Addr("") will not return an error. elsif Image = "" then ! Raise_Socket_Error (Constants.EINVAL); end if; Img := New_String (Image); --- 1260,1266 ---- -- calling Inet_Addr("") will not return an error. elsif Image = "" then ! Raise_Socket_Error (SOSC.EINVAL); end if; Img := New_String (Image); *************** package body GNAT.Sockets is *** 1176,1182 **** Free (Img); if Res = Failure then ! Raise_Socket_Error (Constants.EINVAL); end if; To_Inet_Addr (To_In_Addr (Res), Result); --- 1268,1274 ---- Free (Img); if Res = Failure then ! Raise_Socket_Error (SOSC.EINVAL); end if; To_Inet_Addr (To_In_Addr (Res), Result); *************** package body GNAT.Sockets is *** 1188,1194 **** ---------------- procedure Initialize (Process_Blocking_IO : Boolean) is ! Expected : constant Boolean := not Constants.Thread_Blocking_IO; begin if Process_Blocking_IO /= Expected then raise Socket_Error with --- 1280,1287 ---- ---------------- procedure Initialize (Process_Blocking_IO : Boolean) is ! Expected : constant Boolean := not SOSC.Thread_Blocking_IO; ! begin if Process_Blocking_IO /= Expected then raise Socket_Error with *************** package body GNAT.Sockets is *** 1256,1262 **** procedure Listen_Socket (Socket : Socket_Type; ! Length : Positive := 15) is Res : constant C.int := C_Listen (C.int (Socket), C.int (Length)); begin --- 1349,1355 ---- procedure Listen_Socket (Socket : Socket_Type; ! Length : Natural := 15) is Res : constant C.int := C_Listen (C.int (Socket), C.int (Length)); begin *************** package body GNAT.Sockets is *** 1272,1278 **** procedure Narrow (Item : in out Socket_Set_Type) is Last : aliased C.int := C.int (Item.Last); begin ! if Item.Set /= No_Socket_Set then Last_Socket_In_Set (Item.Set, Last'Unchecked_Access); Item.Last := Socket_Type (Last); end if; --- 1365,1371 ---- procedure Narrow (Item : in out Socket_Set_Type) is Last : aliased C.int := C.int (Item.Last); begin ! if Item.Set /= No_Fd_Set_Access then Last_Socket_In_Set (Item.Set, Last'Unchecked_Access); Item.Last := Socket_Type (Last); end if; *************** package body GNAT.Sockets is *** 1296,1301 **** --- 1389,1451 ---- return To_String (S.Official); end Official_Name; + -------------------- + -- Wait_On_Socket -- + -------------------- + + procedure Wait_On_Socket + (Socket : Socket_Type; + For_Read : Boolean; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) + is + type Local_Selector_Access is access Selector_Type; + for Local_Selector_Access'Storage_Size use Selector_Type'Size; + + S : Selector_Access; + -- Selector to use for waiting + + R_Fd_Set : Socket_Set_Type; + W_Fd_Set : Socket_Set_Type; + -- Socket sets, empty at elaboration + + begin + -- Create selector if not provided by the user + + if Selector = null then + declare + Local_S : constant Local_Selector_Access := new Selector_Type; + begin + S := Local_S.all'Unchecked_Access; + Create_Selector (S.all); + end; + + else + S := Selector.all'Access; + end if; + + if For_Read then + Set (R_Fd_Set, Socket); + else + Set (W_Fd_Set, Socket); + end if; + + Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout); + + -- Cleanup actions (required in all cases to avoid memory leaks) + + if For_Read then + Empty (R_Fd_Set); + else + Empty (W_Fd_Set); + end if; + + if Selector = null then + Close_Selector (S.all); + end if; + end Wait_On_Socket; + ----------------- -- Port_Number -- ----------------- *************** package body GNAT.Sockets is *** 1320,1328 **** procedure Raise_Host_Error (H_Error : Integer) is begin ! Ada.Exceptions.Raise_Exception (Host_Error'Identity, Err_Code_Image (H_Error) ! & C.Strings.Value (Host_Error_Messages.Host_Error_Message (H_Error))); end Raise_Host_Error; ------------------------ --- 1470,1478 ---- procedure Raise_Host_Error (H_Error : Integer) is begin ! raise Host_Error with Err_Code_Image (H_Error) ! & C.Strings.Value (Host_Error_Messages.Host_Error_Message (H_Error)); end Raise_Host_Error; ------------------------ *************** package body GNAT.Sockets is *** 1332,1340 **** procedure Raise_Socket_Error (Error : Integer) is use type C.Strings.chars_ptr; begin ! Ada.Exceptions.Raise_Exception (Socket_Error'Identity, Err_Code_Image (Error) ! & C.Strings.Value (Socket_Error_Message (Error))); end Raise_Socket_Error; ---------- --- 1482,1490 ---- procedure Raise_Socket_Error (Error : Integer) is use type C.Strings.chars_ptr; begin ! raise Socket_Error with Err_Code_Image (Error) ! & C.Strings.Value (Socket_Error_Message (Error)); end Raise_Socket_Error; ---------- *************** package body GNAT.Sockets is *** 1464,1479 **** (Error_Value : Integer; From_Errno : Boolean := True) return Error_Type is ! use GNAT.Sockets.Constants; begin if not From_Errno then case Error_Value is ! when Constants.HOST_NOT_FOUND => return Unknown_Host; ! when Constants.TRY_AGAIN => return Host_Name_Lookup_Failure; ! when Constants.NO_RECOVERY => return Non_Recoverable_Error; ! when Constants.NO_DATA => return Unknown_Server_Error; ! when others => return Cannot_Resolve_Error; end case; end if; --- 1614,1629 ---- (Error_Value : Integer; From_Errno : Boolean := True) return Error_Type is ! use GNAT.Sockets.SOSC; begin if not From_Errno then case Error_Value is ! when SOSC.HOST_NOT_FOUND => return Unknown_Host; ! when SOSC.TRY_AGAIN => return Host_Name_Lookup_Failure; ! when SOSC.NO_RECOVERY => return Non_Recoverable_Error; ! when SOSC.NO_DATA => return Unknown_Server_Error; ! when others => return Cannot_Resolve_Error; end case; end if; *************** package body GNAT.Sockets is *** 1637,1644 **** Len : constant C.int := Sin'Size / 8; begin ! Set_Length (Sin'Unchecked_Access, Len); ! Set_Family (Sin'Unchecked_Access, Families (To.Family)); Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr)); Set_Port (Sin'Unchecked_Access, --- 1787,1793 ---- Len : constant C.int := Sin'Size / 8; begin ! Set_Family (Sin.Sin_Family, To.Family); Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr)); Set_Port (Sin'Unchecked_Access, *************** package body GNAT.Sockets is *** 1680,1687 **** pragma Warnings (Off); -- Following test may be compile time known on some targets ! if Vector'Length - Iov_Count > Constants.IOV_MAX then ! This_Iov_Count := Constants.IOV_MAX; else This_Iov_Count := Vector'Length - Iov_Count; end if; --- 1829,1836 ---- pragma Warnings (Off); -- Following test may be compile time known on some targets ! if Vector'Length - Iov_Count > SOSC.IOV_MAX then ! This_Iov_Count := SOSC.IOV_MAX; else This_Iov_Count := Vector'Length - Iov_Count; end if; *************** package body GNAT.Sockets is *** 1709,1716 **** procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is begin ! if Item.Set = No_Socket_Set then ! Item.Set := New_Socket_Set (No_Socket_Set); Item.Last := Socket; elsif Item.Last < Socket then --- 1858,1865 ---- procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is begin ! if Item.Set = No_Fd_Set_Access then ! Item.Set := New_Socket_Set (No_Fd_Set_Access); Item.Last := Socket; elsif Item.Last < Socket then *************** package body GNAT.Sockets is *** 1731,1737 **** function To_int is new Ada.Unchecked_Conversion (C.unsigned, C.int); begin ! return To_int (To_unsigned (F) or Constants.MSG_Forced_Flags); end Set_Forced_Flags; ----------------------- --- 1880,1886 ---- function To_int is new Ada.Unchecked_Conversion (C.unsigned, C.int); begin ! return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags); end Set_Forced_Flags; ----------------------- *************** package body GNAT.Sockets is *** 1795,1801 **** Len := V1'Size / 8; Add := V1'Address; ! when Multicast_Loop => V1 := C.unsigned_char (Boolean'Pos (Option.Enabled)); Len := V1'Size / 8; Add := V1'Address; --- 1944,1951 ---- Len := V1'Size / 8; Add := V1'Address; ! when Multicast_Loop | ! Receive_Packet_Info => V1 := C.unsigned_char (Boolean'Pos (Option.Enabled)); Len := V1'Size / 8; Add := V1'Address; *************** package body GNAT.Sockets is *** 1970,1976 **** -- To_In_Addr -- ---------------- ! function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr is begin if Addr.Family = Family_Inet then return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)), --- 2120,2126 ---- -- To_In_Addr -- ---------------- ! function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is begin if Addr.Family = Family_Inet then return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)), *************** package body GNAT.Sockets is *** 1979,1985 **** S_B4 => C.unsigned_char (Addr.Sin_V4 (4))); end if; ! raise Socket_Error; end To_In_Addr; ------------------ --- 2129,2135 ---- S_B4 => C.unsigned_char (Addr.Sin_V4 (4))); end if; ! raise Socket_Error with "IPv6 not supported"; end To_In_Addr; ------------------ *************** package body GNAT.Sockets is *** 2011,2017 **** if Current mod 2 /= 0 then if Flags (J) = -1 then ! Raise_Socket_Error (Constants.EOPNOTSUPP); end if; Result := Result + Flags (J); --- 2161,2167 ---- if Current mod 2 /= 0 then if Flags (J) = -1 then ! Raise_Socket_Error (SOSC.EOPNOTSUPP); end if; Result := Result + Flags (J); diff -Nrcpad gcc-4.3.3/gcc/ada/g-socket.ads gcc-4.4.0/gcc/ada/g-socket.ads *** gcc-4.3.3/gcc/ada/g-socket.ads Tue Aug 14 08:50:51 2007 --- gcc-4.4.0/gcc/ada/g-socket.ads Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** *** 39,46 **** -- Multicast is available only on systems which provide support for this -- feature, so it is not available if Multicast is not supported, or not ! -- installed. In particular Multicast is not available with the Windows ! -- version. -- The VMS implementation was implemented using the DECC RTL Socket API, -- and is thus subject to limitations in the implementation of this API. --- 39,45 ---- -- Multicast is available only on systems which provide support for this -- feature, so it is not available if Multicast is not supported, or not ! -- installed. -- The VMS implementation was implemented using the DECC RTL Socket API, -- and is thus subject to limitations in the implementation of this API. *************** with Ada.Exceptions; *** 53,65 **** with Ada.Streams; with Ada.Unchecked_Deallocation; ! with System; package GNAT.Sockets is -- Sockets are designed to provide a consistent communication facility ! -- between applications. This package provides an Ada-like interface ! -- similar to that proposed as part of the BSD socket layer. -- GNAT.Sockets has been designed with several ideas in mind --- 52,69 ---- with Ada.Streams; with Ada.Unchecked_Deallocation; ! with System.OS_Constants; package GNAT.Sockets is -- Sockets are designed to provide a consistent communication facility ! -- between applications. This package provides an Ada binding to the ! -- the de-facto standard BSD sockets API. The documentation below covers ! -- only the specific binding provided by this package. It assumes that ! -- the reader is already familiar with general network programming and ! -- sockets usage. A useful reference on this matter is W. Richard Stevens' ! -- "UNIX Network Programming: The Sockets Networking API" ! -- (ISBN: 0131411551). -- GNAT.Sockets has been designed with several ideas in mind *************** package GNAT.Sockets is *** 78,84 **** -- notification of an asynchronous connect failure is delivered in the -- write socket set (POSIX) instead of the exception socket set (NT). ! -- Here is a typical example of what you can do: -- with GNAT.Sockets; use GNAT.Sockets; --- 82,88 ---- -- notification of an asynchronous connect failure is delivered in the -- write socket set (POSIX) instead of the exception socket set (NT). ! -- The example below demonstrates various features of GNAT.Sockets: -- with GNAT.Sockets; use GNAT.Sockets; *************** package GNAT.Sockets is *** 365,370 **** --- 369,380 ---- -- Finalize; -- end PingPong; + package SOSC renames System.OS_Constants; + -- Renaming used to provide short-hand notations throughout the sockets + -- binding. Note that System.OS_Constants is an internal unit, and the + -- entities declared therein are not meant for direct access by users, + -- including through this renaming. + procedure Initialize; -- Initialize must be called before using any other socket routines. -- Note that this operation is a no-op on UNIX platforms, but applications *************** package GNAT.Sockets is *** 393,398 **** --- 403,435 ---- No_Socket : constant Socket_Type; + type Selector_Type is limited private; + type Selector_Access is access all Selector_Type; + -- Selector objects are used to wait for i/o events to occur on sockets + + -- Timeval_Duration is a subtype of Standard.Duration because the full + -- range of Standard.Duration cannot be represented in the equivalent C + -- structure. Moreover, negative values are not allowed to avoid system + -- incompatibilities. + + Immediate : constant Duration := 0.0; + + Timeval_Forever : constant := 2.0 ** (SOSC.SIZEOF_tv_sec * 8 - 1) - 1.0; + Forever : constant Duration := + Duration'Min (Duration'Last, Timeval_Forever); + + subtype Timeval_Duration is Duration range Immediate .. Forever; + + subtype Selector_Duration is Timeval_Duration; + -- Timeout value for selector operations + + type Selector_Status is (Completed, Expired, Aborted); + -- Completion status of a selector operation, indicated as follows: + -- Complete: one of the expected events occurred + -- Expired: no event occurred before the expiration of the timeout + -- Aborted: an external action cancelled the wait operation before + -- any event occurred. + Socket_Error : exception; -- There is only one exception in this package to deal with an error during -- a socket routine. Once raised, its message contains a string describing *************** package GNAT.Sockets is *** 431,440 **** No_Port : constant Port_Type; type Inet_Addr_Type (Family : Family_Type := Family_Inet) is private; ! -- An Internet address depends on an address family (IPv4 contains 4 ! -- octets and Ipv6 contains 16 octets). Any_Inet_Addr is a special value ! -- treated like a wildcard enabling all addresses. No_Inet_Addr provides a ! -- special value to denote uninitialized inet addresses. Any_Inet_Addr : constant Inet_Addr_Type; No_Inet_Addr : constant Inet_Addr_Type; --- 468,477 ---- No_Port : constant Port_Type; type Inet_Addr_Type (Family : Family_Type := Family_Inet) is private; ! -- An Internet address depends on an address family (IPv4 contains 4 octets ! -- and IPv6 contains 16 octets). Any_Inet_Addr is a special value treated ! -- like a wildcard enabling all addresses. No_Inet_Addr provides a special ! -- value to denote uninitialized inet addresses. Any_Inet_Addr : constant Inet_Addr_Type; No_Inet_Addr : constant Inet_Addr_Type; *************** package GNAT.Sockets is *** 504,511 **** function Get_Host_By_Name (Name : String) return Host_Entry_Type; -- Return host entry structure for the given host name. Here name is ! -- either a host name, or an IP address. If Name is an IP address, this is ! -- equivalent to Get_Host_By_Address (Inet_Addr (Name)). function Host_Name return String; -- Return the name of the current host --- 541,548 ---- function Get_Host_By_Name (Name : String) return Host_Entry_Type; -- Return host entry structure for the given host name. Here name is ! -- either a host name, or an IP address. If Name is an IP address, this ! -- is equivalent to Get_Host_By_Address (Inet_Addr (Name)). function Host_Name return String; -- Return the name of the current host *************** package GNAT.Sockets is *** 545,554 **** Service_Error : exception; -- Comment required ??? ! -- Errors are described by an enumeration type. There is only one ! -- exception Socket_Error in this package to deal with an error during a ! -- socket routine. Once raised, its message contains the error code ! -- between brackets and a string describing the error code. -- The name of the enumeration constant documents the error condition --- 582,591 ---- Service_Error : exception; -- Comment required ??? ! -- Errors are described by an enumeration type. There is only one exception ! -- Socket_Error in this package to deal with an error during a socket ! -- routine. Once raised, its message contains the error code between ! -- brackets and a string describing the error code. -- The name of the enumeration constant documents the error condition *************** package GNAT.Sockets is *** 598,613 **** Unknown_Server_Error, Cannot_Resolve_Error); - -- Timeval_Duration is a subtype of Standard.Duration because the full - -- range of Standard.Duration cannot be represented in the equivalent C - -- structure. Moreover, negative values are not allowed to avoid system - -- incompatibilities. - - Immediate : constant := 0.0; - Forever : constant := Duration (Integer'Last) * 1.0; - - subtype Timeval_Duration is Duration range Immediate .. Forever; - -- Get_Socket_Options and Set_Socket_Options manipulate options associated -- with a socket. Options may exist at multiple protocol levels in the -- communication stack. Socket_Level is the uppermost socket level. --- 635,640 ---- *************** package GNAT.Sockets is *** 623,652 **** -- a boolean to enable or disable this option. type Option_Name is ( ! Keep_Alive, -- Enable sending of keep-alive messages ! Reuse_Address, -- Allow bind to reuse local address ! Broadcast, -- Enable datagram sockets to recv/send broadcasts ! Send_Buffer, -- Set/get the maximum socket send buffer in bytes ! Receive_Buffer, -- Set/get the maximum socket recv buffer in bytes ! Linger, -- Shutdown wait for msg to be sent or timeout occur ! Error, -- Get and clear the pending socket error ! No_Delay, -- Do not delay send to coalesce packets (TCP_NODELAY) ! Add_Membership, -- Join a multicast group ! Drop_Membership, -- Leave a multicast group ! Multicast_If, -- Set default outgoing interface for multicast packets ! Multicast_TTL, -- Indicate the time-to-live of sent multicast packets ! Multicast_Loop, -- Sent multicast packets are looped to local socket ! Send_Timeout, -- Set timeout value for output ! Receive_Timeout); -- Set timeout value for input type Option_Type (Name : Option_Name := Keep_Alive) is record case Name is ! when Keep_Alive | ! Reuse_Address | ! Broadcast | ! Linger | ! No_Delay | ! Multicast_Loop => Enabled : Boolean; case Name is --- 650,681 ---- -- a boolean to enable or disable this option. type Option_Name is ( ! Keep_Alive, -- Enable sending of keep-alive messages ! Reuse_Address, -- Allow bind to reuse local address ! Broadcast, -- Enable datagram sockets to recv/send broadcasts ! Send_Buffer, -- Set/get the maximum socket send buffer in bytes ! Receive_Buffer, -- Set/get the maximum socket recv buffer in bytes ! Linger, -- Shutdown wait for msg to be sent or timeout occur ! Error, -- Get and clear the pending socket error ! No_Delay, -- Do not delay send to coalesce data (TCP_NODELAY) ! Add_Membership, -- Join a multicast group ! Drop_Membership, -- Leave a multicast group ! Multicast_If, -- Set default out interface for multicast packets ! Multicast_TTL, -- Set the time-to-live of sent multicast packets ! Multicast_Loop, -- Sent multicast packets are looped to local socket ! Receive_Packet_Info, -- Receive low level packet info as ancillary data ! Send_Timeout, -- Set timeout value for output ! Receive_Timeout); -- Set timeout value for input type Option_Type (Name : Option_Name := Keep_Alive) is record case Name is ! when Keep_Alive | ! Reuse_Address | ! Broadcast | ! Linger | ! No_Delay | ! Receive_Packet_Info | ! Multicast_Loop => Enabled : Boolean; case Name is *************** package GNAT.Sockets is *** 716,724 **** -- Socket_Stream). Peek_At_Incoming_Data : constant Request_Flag_Type; ! -- This flag causes the receive operation to return data from the ! -- beginning of the receive queue without removing that data from the ! -- queue. A subsequent receive call will return the same data. Wait_For_A_Full_Reception : constant Request_Flag_Type; -- This flag requests that the operation block until the full request is --- 745,753 ---- -- Socket_Stream). Peek_At_Incoming_Data : constant Request_Flag_Type; ! -- This flag causes the receive operation to return data from the beginning ! -- of the receive queue without removing that data from the queue. A ! -- subsequent receive call will return the same data. Wait_For_A_Full_Reception : constant Request_Flag_Type; -- This flag requests that the operation block until the full request is *************** package GNAT.Sockets is *** 760,765 **** --- 789,808 ---- -- is filled in with the address of the connection. Raises Socket_Error on -- error. + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status); + -- Accept a new connection on Server using Accept_Socket, waiting no longer + -- than the given timeout duration. Status is set to indicate whether the + -- operation completed successfully, timed out, or was aborted. If Selector + -- is not null, the designated selector is used to wait for the socket to + -- become available, else a private selector object is created by this + -- procedure and destroyed before it returns. + procedure Bind_Socket (Socket : Socket_Type; Address : Sock_Addr_Type); *************** package GNAT.Sockets is *** 771,786 **** procedure Connect_Socket (Socket : Socket_Type; ! Server : in out Sock_Addr_Type); ! -- Make a connection to another socket which has the address of ! -- Server. Raises Socket_Error on error. procedure Control_Socket (Socket : Socket_Type; Request : in out Request_Type); -- Obtain or set parameter values that control the socket. This control ! -- differs from the socket options in that they are not specific to ! -- sockets but are available for any device. function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type; -- Return the peer or remote socket address of a socket. Raise --- 814,842 ---- procedure Connect_Socket (Socket : Socket_Type; ! Server : Sock_Addr_Type); ! -- Make a connection to another socket which has the address of Server. ! -- Raises Socket_Error on error. ! ! procedure Connect_Socket ! (Socket : Socket_Type; ! Server : Sock_Addr_Type; ! Timeout : Selector_Duration; ! Selector : access Selector_Type := null; ! Status : out Selector_Status); ! -- Connect Socket to the given Server address using Connect_Socket, waiting ! -- no longer than the given timeout duration. Status is set to indicate ! -- whether the operation completed successfully, timed out, or was aborted. ! -- If Selector is not null, the designated selector is used to wait for the ! -- socket to become available, else a private selector object is created ! -- by this procedure and destroyed before it returns. procedure Control_Socket (Socket : Socket_Type; Request : in out Request_Type); -- Obtain or set parameter values that control the socket. This control ! -- differs from the socket options in that they are not specific to sockets ! -- but are available for any device. function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type; -- Return the peer or remote socket address of a socket. Raise *************** package GNAT.Sockets is *** 788,809 **** function Get_Socket_Name (Socket : Socket_Type) return Sock_Addr_Type; -- Return the local or current socket address of a socket. Return ! -- No_Sock_Addr on error (for instance, socket closed or not locally ! -- bound). function Get_Socket_Option (Socket : Socket_Type; Level : Level_Type := Socket_Level; Name : Option_Name) return Option_Type; ! -- Get the options associated with a socket. Raises Socket_Error ! -- on error. procedure Listen_Socket (Socket : Socket_Type; ! Length : Positive := 15); -- To accept connections, a socket is first created with Create_Socket, -- a willingness to accept incoming connections and a queue Length for -- incoming connections are specified. Raise Socket_Error on error. procedure Receive_Socket (Socket : Socket_Type; --- 844,866 ---- function Get_Socket_Name (Socket : Socket_Type) return Sock_Addr_Type; -- Return the local or current socket address of a socket. Return ! -- No_Sock_Addr on error (e.g. socket closed or not locally bound). function Get_Socket_Option (Socket : Socket_Type; Level : Level_Type := Socket_Level; Name : Option_Name) return Option_Type; ! -- Get the options associated with a socket. Raises Socket_Error on error procedure Listen_Socket (Socket : Socket_Type; ! Length : Natural := 15); -- To accept connections, a socket is first created with Create_Socket, -- a willingness to accept incoming connections and a queue Length for -- incoming connections are specified. Raise Socket_Error on error. + -- The queue length of 15 is an example value that should be appropriate + -- in usual cases. It can be adjusted according to each application's + -- particular requirements. procedure Receive_Socket (Socket : Socket_Type; *************** package GNAT.Sockets is *** 894,900 **** -- Create a stream associated with a datagram-based socket that is already -- bound. Send_To is the socket address to which messages are being sent. ! function Get_Address (Stream : Stream_Access) return Sock_Addr_Type; -- Return the socket address from which the last message was received procedure Free is new Ada.Unchecked_Deallocation --- 951,958 ---- -- Create a stream associated with a datagram-based socket that is already -- bound. Send_To is the socket address to which messages are being sent. ! function Get_Address ! (Stream : not null Stream_Access) return Sock_Addr_Type; -- Return the socket address from which the last message was received procedure Free is new Ada.Unchecked_Deallocation *************** package GNAT.Sockets is *** 952,962 **** -- operation is typically to add a socket in one of the socket sets when -- the timeout is set to forever. - type Selector_Type is limited private; - type Selector_Access is access all Selector_Type; - - subtype Selector_Duration is Timeval_Duration; - procedure Create_Selector (Selector : out Selector_Type); -- Create a new selector --- 1010,1015 ---- *************** package GNAT.Sockets is *** 966,973 **** -- no other task still using Selector (i.e. still executing Check_Selector -- or Abort_Selector on this Selector). - type Selector_Status is (Completed, Expired, Aborted); - procedure Check_Selector (Selector : in out Selector_Type; R_Socket_Set : in out Socket_Set_Type; --- 1019,1024 ---- *************** package GNAT.Sockets is *** 1002,1007 **** --- 1053,1068 ---- procedure Abort_Selector (Selector : Selector_Type); -- Send an abort signal to the selector + type Fd_Set_Access is private; + No_Fd_Set_Access : constant Fd_Set_Access; + -- ??? This type must not be used directly, it needs to be visible because + -- it is used in the visible part of GNAT.Sockets.Thin_Common. This is + -- really an inversion of abstraction. The private part of GNAT.Sockets + -- needs to have visibility on this type, but since Thin_Common is a child + -- of Sockets, the type can't be declared there. The correct fix would + -- be to move the thin sockets binding outside of GNAT.Sockets altogether, + -- e.g. by renaming it to GNAT.Sockets_Thin. + private type Socket_Type is new Integer; *************** private *** 1010,1027 **** type Selector_Type is limited record R_Sig_Socket : Socket_Type := No_Socket; W_Sig_Socket : Socket_Type := No_Socket; end record; pragma Volatile (Selector_Type); ! -- The two signalling sockets are used to abort a select operation ! ! subtype Socket_Set_Access is System.Address; ! No_Socket_Set : constant Socket_Set_Access := System.Null_Address; type Socket_Set_Type is record Last : Socket_Type := No_Socket; ! Set : Socket_Set_Access := No_Socket_Set; end record; subtype Inet_Addr_Comp_Type is Natural range 0 .. 255; --- 1071,1089 ---- type Selector_Type is limited record R_Sig_Socket : Socket_Type := No_Socket; W_Sig_Socket : Socket_Type := No_Socket; + -- Signalling sockets used to abort a select operation end record; pragma Volatile (Selector_Type); ! type Fd_Set is null record; ! type Fd_Set_Access is access all Fd_Set; ! pragma Convention (C, Fd_Set_Access); ! No_Fd_Set_Access : constant Fd_Set_Access := null; type Socket_Set_Type is record Last : Socket_Type := No_Socket; ! Set : Fd_Set_Access; end record; subtype Inet_Addr_Comp_Type is Natural range 0 .. 255; diff -Nrcpad gcc-4.3.3/gcc/ada/g-socthi-dummy.adb gcc-4.4.0/gcc/ada/g-socthi-dummy.adb *** gcc-4.3.3/gcc/ada/g-socthi-dummy.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-socthi-dummy.adb Wed Aug 6 08:57:21 2008 *************** *** 0 **** --- 1,34 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . T H I N -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2001-2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + pragma No_Body; diff -Nrcpad gcc-4.3.3/gcc/ada/g-socthi-dummy.ads gcc-4.4.0/gcc/ada/g-socthi-dummy.ads *** gcc-4.3.3/gcc/ada/g-socthi-dummy.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-socthi-dummy.ads Wed Aug 6 08:57:21 2008 *************** *** 0 **** --- 1,39 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . T H I N -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2001-2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package is a placeholder for the sockets binding for platforms where + -- it is not implemented. + + package GNAT.Sockets.Thin is + pragma Unimplemented_Unit; + end GNAT.Sockets.Thin; diff -Nrcpad gcc-4.3.3/gcc/ada/g-socthi-mingw.adb gcc-4.4.0/gcc/ada/g-socthi-mingw.adb *** gcc-4.3.3/gcc/ada/g-socthi-mingw.adb Wed Sep 26 10:41:24 2007 --- gcc-4.4.0/gcc/ada/g-socthi-mingw.adb Wed Aug 20 12:07:36 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** with System; use System; *** 43,48 **** --- 43,49 ---- package body GNAT.Sockets.Thin is use type C.unsigned; + use type C.int; WSAData_Dummy : array (1 .. 512) of C.int; *************** package body GNAT.Sockets.Thin is *** 238,245 **** Res := Standard_Connect (S, Name, Namelen); if Res = -1 then ! if Socket_Errno = Constants.EWOULDBLOCK then ! Set_Socket_Errno (Constants.EINPROGRESS); end if; end if; --- 239,246 ---- Res := Standard_Connect (S, Name, Namelen); if Res = -1 then ! if Socket_Errno = SOSC.EWOULDBLOCK then ! Set_Socket_Errno (SOSC.EINPROGRESS); end if; end if; *************** package body GNAT.Sockets.Thin is *** 294,300 **** RFS : constant Fd_Set_Access := Readfds; WFS : constant Fd_Set_Access := Writefds; ! WFSC : Fd_Set_Access := No_Fd_Set; EFS : Fd_Set_Access := Exceptfds; Res : C.int; S : aliased C.int; --- 295,301 ---- RFS : constant Fd_Set_Access := Readfds; WFS : constant Fd_Set_Access := Writefds; ! WFSC : Fd_Set_Access := No_Fd_Set_Access; EFS : Fd_Set_Access := Exceptfds; Res : C.int; S : aliased C.int; *************** package body GNAT.Sockets.Thin is *** 303,319 **** begin -- Asynchronous connection failures are notified in the -- exception fd set instead of the write fd set. To ensure ! -- POSIX compatitibility, copy write fd set into exception fd -- set. Once select() returns, check any socket present in the -- exception fd set and peek at incoming out-of-band data. If -- the test is not successful, and the socket is present in -- the initial write fd set, then move the socket from the -- exception fd set to the write fd set. ! if WFS /= No_Fd_Set then -- Add any socket present in write fd set into exception fd set ! if EFS = No_Fd_Set then EFS := New_Socket_Set (WFS); else --- 304,320 ---- begin -- Asynchronous connection failures are notified in the -- exception fd set instead of the write fd set. To ensure ! -- POSIX compatibility, copy write fd set into exception fd -- set. Once select() returns, check any socket present in the -- exception fd set and peek at incoming out-of-band data. If -- the test is not successful, and the socket is present in -- the initial write fd set, then move the socket from the -- exception fd set to the write fd set. ! if WFS /= No_Fd_Set_Access then -- Add any socket present in write fd set into exception fd set ! if EFS = No_Fd_Set_Access then EFS := New_Socket_Set (WFS); else *************** package body GNAT.Sockets.Thin is *** 337,346 **** Res := Standard_Select (Nfds, RFS, WFS, EFS, Timeout); ! if EFS /= No_Fd_Set then declare EFSC : constant Fd_Set_Access := New_Socket_Set (EFS); ! Flag : constant C.int := Constants.MSG_PEEK + Constants.MSG_OOB; Buffer : Character; Length : C.int; Fromlen : aliased C.int; --- 338,347 ---- Res := Standard_Select (Nfds, RFS, WFS, EFS, Timeout); ! if EFS /= No_Fd_Set_Access then declare EFSC : constant Fd_Set_Access := New_Socket_Set (EFS); ! Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB; Buffer : Character; Length : C.int; Fromlen : aliased C.int; *************** package body GNAT.Sockets.Thin is *** 372,378 **** -- set. Otherwise, ignore this event since the user -- is not watching for it. ! if WFSC /= No_Fd_Set and then (Is_Socket_In_Set (WFSC, S) /= 0) then Insert_Socket_In_Set (WFS, S); --- 373,379 ---- -- set. Otherwise, ignore this event since the user -- is not watching for it. ! if WFSC /= No_Fd_Set_Access and then (Is_Socket_In_Set (WFSC, S) /= 0) then Insert_Socket_In_Set (WFS, S); *************** package body GNAT.Sockets.Thin is *** 383,396 **** Free_Socket_Set (EFSC); end; ! if Exceptfds = No_Fd_Set then Free_Socket_Set (EFS); end if; end if; -- Free any copy of write fd set ! if WFSC /= No_Fd_Set then Free_Socket_Set (WFSC); end if; --- 384,397 ---- Free_Socket_Set (EFSC); end; ! if Exceptfds = No_Fd_Set_Access then Free_Socket_Set (EFS); end if; end if; -- Free any copy of write fd set ! if WFSC /= No_Fd_Set_Access then Free_Socket_Set (WFSC); end if; *************** package body GNAT.Sockets.Thin is *** 473,529 **** end if; end Initialize; - ----------------- - -- Set_Address -- - ----------------- - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr) - is - begin - Sin.Sin_Addr := Address; - end Set_Address; - - ---------------- - -- Set_Family -- - ---------------- - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int) - is - begin - Sin.Sin_Family := C.unsigned_short (Family); - end Set_Family; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int) - is - pragma Unreferenced (Sin); - pragma Unreferenced (Len); - - begin - null; - end Set_Length; - - -------------- - -- Set_Port -- - -------------- - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short) - is - begin - Sin.Sin_Port := Port; - end Set_Port; - -------------------- -- Signalling_Fds -- -------------------- --- 474,479 ---- *************** package body GNAT.Sockets.Thin is *** 537,543 **** function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr is ! use GNAT.Sockets.Constants; begin case Errno is when EINTR => return Error_Messages (N_EINTR); --- 487,494 ---- function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr is ! use GNAT.Sockets.SOSC; ! begin case Errno is when EINTR => return Error_Messages (N_EINTR); diff -Nrcpad gcc-4.3.3/gcc/ada/g-socthi-mingw.ads gcc-4.4.0/gcc/ada/g-socthi-mingw.ads *** gcc-4.3.3/gcc/ada/g-socthi-mingw.ads Wed Jun 6 10:54:04 2007 --- gcc-4.4.0/gcc/ada/g-socthi-mingw.ads Tue May 20 12:43:29 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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,58 **** -- This version is for NT - with Interfaces.C.Pointers; with Interfaces.C.Strings; ! with GNAT.Sockets.Constants; with System; package GNAT.Sockets.Thin is ! package C renames Interfaces.C; ! ! use type C.int; ! -- So that we can declare the Failure constant below ! Success : constant C.int := 0; ! Failure : constant C.int := -1; function Socket_Errno return Integer; -- Returns last socket error number --- 37,53 ---- -- This version is for NT with Interfaces.C.Strings; ! with GNAT.Sockets.Thin_Common; with System; package GNAT.Sockets.Thin is ! use Thin_Common; ! package C renames Interfaces.C; function Socket_Errno return Integer; -- Returns last socket error number *************** package GNAT.Sockets.Thin is *** 77,234 **** end Host_Error_Messages; - subtype Fd_Set_Access is System.Address; - No_Fd_Set : constant Fd_Set_Access := System.Null_Address; - - type time_t is - range -2 ** (8 * Constants.SIZEOF_tv_sec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_sec - 1) - 1; - for time_t'Size use 8 * Constants.SIZEOF_tv_sec; - pragma Convention (C, time_t); - - type suseconds_t is - range -2 ** (8 * Constants.SIZEOF_tv_usec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_usec - 1) - 1; - for suseconds_t'Size use 8 * Constants.SIZEOF_tv_usec; - pragma Convention (C, suseconds_t); - - type Timeval is record - Tv_Sec : time_t; - Tv_Usec : suseconds_t; - end record; - pragma Convention (C, Timeval); - - type Timeval_Access is access all Timeval; - pragma Convention (C, Timeval_Access); - - Immediat : constant Timeval := (0, 0); - - type Int_Access is access all C.int; - pragma Convention (C, Int_Access); - -- Access to C integers - - type Chars_Ptr_Array is array (C.size_t range <>) of - aliased C.Strings.chars_ptr; - - package Chars_Ptr_Pointers is - new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, - C.Strings.Null_Ptr); - -- Arrays of C (char *) - - type In_Addr is record - S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; - end record; - for In_Addr'Alignment use C.int'Alignment; - pragma Convention (C, In_Addr); - -- IPv4 address, represented as a network-order C.int. Note that the - -- underlying operating system may assume that values of this type have - -- C.int alignment, so we need to provide a suitable alignment clause here. - - type In_Addr_Access is access all In_Addr; - pragma Convention (C, In_Addr_Access); - -- Access to internet address - - Inaddr_Any : aliased constant In_Addr := (others => 0); - -- Any internet address (all the interfaces) - - type In_Addr_Access_Array is array (C.size_t range <>) - of aliased In_Addr_Access; - pragma Convention (C, In_Addr_Access_Array); - - package In_Addr_Access_Pointers is - new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); - -- Array of internet addresses - - type Sockaddr is record - Sa_Family : C.unsigned_short; - Sa_Data : C.char_array (1 .. 14); - end record; - pragma Convention (C, Sockaddr); - -- Socket address - - type Sockaddr_Access is access all Sockaddr; - pragma Convention (C, Sockaddr_Access); - -- Access to socket address - - type Sockaddr_In is record - Sin_Family : C.unsigned_short := Constants.AF_INET; - Sin_Port : C.unsigned_short := 0; - Sin_Addr : In_Addr := Inaddr_Any; - Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); - end record; - pragma Convention (C, Sockaddr_In); - -- Internet socket address - - type Sockaddr_In_Access is access all Sockaddr_In; - pragma Convention (C, Sockaddr_In_Access); - -- Access to internet socket address - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int); - pragma Inline (Set_Length); - -- Set Sin.Sin_Length to Len. - -- On this platform, nothing is done as there is no such field. - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int); - pragma Inline (Set_Family); - -- Set Sin.Sin_Family to Family - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short); - pragma Inline (Set_Port); - -- Set Sin.Sin_Port to Port - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr); - pragma Inline (Set_Address); - -- Set Sin.Sin_Addr to Address - - type Hostent is record - H_Name : C.Strings.chars_ptr; - H_Aliases : Chars_Ptr_Pointers.Pointer; - H_Addrtype : C.short; - H_Length : C.short; - H_Addr_List : In_Addr_Access_Pointers.Pointer; - end record; - pragma Convention (C, Hostent); - -- Host entry - - type Hostent_Access is access all Hostent; - pragma Convention (C, Hostent_Access); - -- Access to host entry - - type Servent is record - S_Name : C.Strings.chars_ptr; - S_Aliases : Chars_Ptr_Pointers.Pointer; - S_Port : C.int; - S_Proto : C.Strings.chars_ptr; - end record; - pragma Convention (C, Servent); - -- Service entry - - type Servent_Access is access all Servent; - pragma Convention (C, Servent_Access); - -- Access to service entry - - type Two_Ints is array (0 .. 1) of C.int; - pragma Convention (C, Two_Ints); - -- Container for two int values - - subtype Fd_Pair is Two_Ints; - -- Two_Ints as used for Create_Signalling_Fds: a pair of connected file - -- descriptors, one of which (the "read end" of the connection) being used - -- for reading, the other one (the "write end") being used for writing. - - Read_End : constant := 0; - Write_End : constant := 1; - -- Indices into an Fd_Pair value providing access to each of the connected - -- file descriptors. - -------------------------------- -- Standard library functions -- -------------------------------- --- 72,77 ---- *************** package GNAT.Sockets.Thin is *** 382,436 **** end Signalling_Fds; - ---------------------------- - -- Socket sets management -- - ---------------------------- - - procedure Free_Socket_Set - (Set : Fd_Set_Access); - -- Free system-dependent socket set - - procedure Get_Socket_From_Set - (Set : Fd_Set_Access; - Socket : Int_Access; - Last : Int_Access); - -- Get last socket in Socket and remove it from the socket set. The - -- parameter Last is a maximum value of the largest socket. This hint is - -- used to avoid scanning very large socket sets. After a call to - -- Get_Socket_From_Set, Last is set back to the real largest socket in the - -- socket set. - - procedure Insert_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Insert socket in the socket set - - function Is_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int) return C.int; - -- Check whether Socket is in the socket set, return a non-zero - -- value if it is, zero if it is not. - - procedure Last_Socket_In_Set - (Set : Fd_Set_Access; - Last : Int_Access); - -- Find the largest socket in the socket set. This is needed for select(). - -- When Last_Socket_In_Set is called, parameter Last is a maximum value of - -- the largest socket. This hint is used to avoid scanning very large - -- socket sets. After the call, Last is set back to the real largest socket - -- in the socket set. - - function New_Socket_Set - (Set : Fd_Set_Access) return Fd_Set_Access; - -- Allocate a new socket set which is a system-dependent structure and - -- initialize by copying Set if it is non-null, by making it empty - -- otherwise. - - procedure Remove_Socket_From_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Remove socket from the socket set - procedure WSACleanup; procedure Initialize; --- 225,230 ---- *************** private *** 461,472 **** pragma Import (Stdcall, WSAStartup, "WSAStartup"); pragma Import (Stdcall, WSACleanup, "WSACleanup"); - pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); - pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); - pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); - pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); - pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); - pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); - pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); - end GNAT.Sockets.Thin; --- 255,258 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-socthi-vms.adb gcc-4.4.0/gcc/ada/g-socthi-vms.adb *** gcc-4.3.3/gcc/ada/g-socthi-vms.adb Wed Jun 6 10:13:25 2007 --- gcc-4.4.0/gcc/ada/g-socthi-vms.adb Fri Aug 8 12:59:28 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** with Interfaces.C; use Interfaces.C; *** 41,47 **** package body GNAT.Sockets.Thin is Non_Blocking_Sockets : constant Fd_Set_Access := ! New_Socket_Set (No_Socket_Set); -- When this package is initialized with Process_Blocking_IO set -- to True, sockets are set in non-blocking mode to avoid blocking -- the whole process when a thread wants to perform a blocking IO --- 41,47 ---- package body GNAT.Sockets.Thin is Non_Blocking_Sockets : constant Fd_Set_Access := ! New_Socket_Set (No_Fd_Set_Access); -- When this package is initialized with Process_Blocking_IO set -- to True, sockets are set in non-blocking mode to avoid blocking -- the whole process when a thread wants to perform a blocking IO *************** package body GNAT.Sockets.Thin is *** 52,58 **** -- been set in non-blocking mode by the user. Quantum : constant Duration := 0.2; ! -- When Constants.Thread_Blocking_IO is False, we set sockets in -- non-blocking mode and we spend a period of time Quantum between -- two attempts on a blocking operation. --- 52,58 ---- -- been set in non-blocking mode by the user. Quantum : constant Duration := 0.2; ! -- When SOSC.Thread_Blocking_IO is False, we set sockets in -- non-blocking mode and we spend a period of time Quantum between -- two attempts on a blocking operation. *************** package body GNAT.Sockets.Thin is *** 134,155 **** begin loop R := Syscall_Accept (S, Addr, Addrlen); ! exit when Constants.Thread_Blocking_IO or else R /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; ! if not Constants.Thread_Blocking_IO and then R /= Failure then ! -- A socket inherits the properties ot its server especially -- the FIONBIO flag. Do not use C_Ioctl as this subprogram -- tracks sockets set in non-blocking mode by user. Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); ! Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); end if; return R; --- 134,155 ---- begin loop R := Syscall_Accept (S, Addr, Addrlen); ! exit when SOSC.Thread_Blocking_IO or else R /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; ! if not SOSC.Thread_Blocking_IO and then R /= Failure then ! -- A socket inherits the properties of its server, especially -- the FIONBIO flag. Do not use C_Ioctl as this subprogram -- tracks sockets set in non-blocking mode by user. Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); ! Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Unchecked_Access); end if; return R; *************** package body GNAT.Sockets.Thin is *** 169,178 **** begin Res := Syscall_Connect (S, Name, Namelen); ! if Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EINPROGRESS then return Res; end if; --- 169,178 ---- begin Res := Syscall_Connect (S, Name, Namelen); ! if SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EINPROGRESS then return Res; end if; *************** package body GNAT.Sockets.Thin is *** 182,196 **** Now : aliased Timeval; begin ! WSet := New_Socket_Set (No_Socket_Set); loop Insert_Socket_In_Set (WSet, S); Now := Immediat; Res := C_Select (S + 1, ! No_Fd_Set, WSet, ! No_Fd_Set, Now'Unchecked_Access); exit when Res > 0; --- 182,196 ---- Now : aliased Timeval; begin ! WSet := New_Socket_Set (No_Fd_Set_Access); loop Insert_Socket_In_Set (WSet, S); Now := Immediat; Res := C_Select (S + 1, ! No_Fd_Set_Access, WSet, ! No_Fd_Set_Access, Now'Unchecked_Access); exit when Res > 0; *************** package body GNAT.Sockets.Thin is *** 208,217 **** Res := Syscall_Connect (S, Name, Namelen); ! if Res = Failure ! and then Errno = Constants.EISCONN ! then ! return Thin.Success; else return Res; end if; --- 208,216 ---- Res := Syscall_Connect (S, Name, Namelen); ! if Res = Failure and then Errno = SOSC.EISCONN then ! return Thin_Common.Success; ! else return Res; end if; *************** package body GNAT.Sockets.Thin is *** 227,234 **** Arg : Int_Access) return C.int is begin ! if not Constants.Thread_Blocking_IO ! and then Req = Constants.FIONBIO then if Arg.all /= 0 then Set_Non_Blocking_Socket (S, True); --- 226,233 ---- Arg : Int_Access) return C.int is begin ! if not SOSC.Thread_Blocking_IO ! and then Req = SOSC.FIONBIO then if Arg.all /= 0 then Set_Non_Blocking_Socket (S, True); *************** package body GNAT.Sockets.Thin is *** 253,262 **** begin loop Res := Syscall_Recv (S, Msg, Len, Flags); ! exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; --- 252,261 ---- begin loop Res := Syscall_Recv (S, Msg, Len, Flags); ! exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; *************** package body GNAT.Sockets.Thin is *** 280,289 **** begin loop Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); ! exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; --- 279,288 ---- begin loop Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); ! exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; *************** package body GNAT.Sockets.Thin is *** 305,314 **** begin loop Res := Syscall_Send (S, Msg, Len, Flags); ! exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; --- 304,313 ---- begin loop Res := Syscall_Send (S, Msg, Len, Flags); ! exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; *************** package body GNAT.Sockets.Thin is *** 332,341 **** begin loop Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); ! exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; --- 331,340 ---- begin loop Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); ! exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; *************** package body GNAT.Sockets.Thin is *** 360,372 **** begin R := Syscall_Socket (Domain, Typ, Protocol); ! if not Constants.Thread_Blocking_IO and then R /= Failure then -- Do not use C_Ioctl as this subprogram tracks sockets set -- in non-blocking mode by user. ! Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); Set_Non_Blocking_Socket (R, False); end if; --- 359,371 ---- begin R := Syscall_Socket (Domain, Typ, Protocol); ! if not SOSC.Thread_Blocking_IO and then R /= Failure then -- Do not use C_Ioctl as this subprogram tracks sockets set -- in non-blocking mode by user. ! Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Unchecked_Access); Set_Non_Blocking_Socket (R, False); end if; *************** package body GNAT.Sockets.Thin is *** 410,444 **** return R; end Non_Blocking_Socket; - ----------------- - -- Set_Address -- - ----------------- - - procedure Set_Address (Sin : Sockaddr_In_Access; Address : In_Addr) is - begin - Sin.Sin_Addr := Address; - end Set_Address; - - ---------------- - -- Set_Family -- - ---------------- - - procedure Set_Family (Sin : Sockaddr_In_Access; Family : C.int) is - begin - Sin.Sin_Family := C.unsigned_short (Family); - end Set_Family; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length (Sin : Sockaddr_In_Access; Len : C.int) is - pragma Unreferenced (Sin); - pragma Unreferenced (Len); - begin - null; - end Set_Length; - ----------------------------- -- Set_Non_Blocking_Socket -- ----------------------------- --- 409,414 ---- *************** package body GNAT.Sockets.Thin is *** 456,470 **** Task_Lock.Unlock; end Set_Non_Blocking_Socket; - -------------- - -- Set_Port -- - -------------- - - procedure Set_Port (Sin : Sockaddr_In_Access; Port : C.unsigned_short) is - begin - Sin.Sin_Port := Port; - end Set_Port; - -------------------- -- Signalling_Fds -- -------------------- --- 426,431 ---- *************** package body GNAT.Sockets.Thin is *** 547,553 **** (Fd, Iovec (J).Base.all'Address, Interfaces.C.int (Iovec (J).Length), ! Constants.MSG_Forced_Flags); if Res < 0 then return Res; --- 508,514 ---- (Fd, Iovec (J).Base.all'Address, Interfaces.C.int (Iovec (J).Length), ! SOSC.MSG_Forced_Flags); if Res < 0 then return Res; diff -Nrcpad gcc-4.3.3/gcc/ada/g-socthi-vms.ads gcc-4.4.0/gcc/ada/g-socthi-vms.ads *** gcc-4.3.3/gcc/ada/g-socthi-vms.ads Thu Dec 13 10:44:32 2007 --- gcc-4.4.0/gcc/ada/g-socthi-vms.ads Tue May 20 12:43:29 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2008, AdaCore -- -- -- -- 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,62 **** -- This is the Alpha/VMS version - with Interfaces.C.Pointers; with Interfaces.C.Strings; with GNAT.OS_Lib; ! with GNAT.Sockets.Constants; with System; - with System.Aux_DEC; package GNAT.Sockets.Thin is -- ??? more comments needed ??? ! package C renames Interfaces.C; ! ! use type C.int; ! -- This is so we can declare the Failure constant below ! Success : constant C.int := 0; ! Failure : constant C.int := -1; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number --- 37,56 ---- -- This is the Alpha/VMS version with Interfaces.C.Strings; with GNAT.OS_Lib; ! with GNAT.Sockets.Thin_Common; with System; package GNAT.Sockets.Thin is -- ??? more comments needed ??? ! use Thin_Common; ! package C renames Interfaces.C; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number *************** package GNAT.Sockets.Thin is *** 81,238 **** end Host_Error_Messages; - subtype Fd_Set_Access is System.Aux_DEC.Short_Address; - No_Fd_Set : constant Fd_Set_Access := System.Null_Address; - - type time_t is - range -2 ** (8 * Constants.SIZEOF_tv_sec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_sec - 1) - 1; - for time_t'Size use 8 * Constants.SIZEOF_tv_sec; - pragma Convention (C, time_t); - - type suseconds_t is - range -2 ** (8 * Constants.SIZEOF_tv_usec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_usec - 1) - 1; - for suseconds_t'Size use 8 * Constants.SIZEOF_tv_usec; - pragma Convention (C, suseconds_t); - - type Timeval is record - Tv_Sec : time_t; - Tv_Usec : suseconds_t; - end record; - pragma Convention (C, Timeval); - - type Timeval_Access is access all Timeval; - pragma Convention (C, Timeval_Access); - - Immediat : constant Timeval := (0, 0); - - type Int_Access is access all C.int; - pragma Convention (C, Int_Access); - -- Access to C integers - - type Chars_Ptr_Array is array (C.size_t range <>) of - aliased C.Strings.chars_ptr; - - package Chars_Ptr_Pointers is - new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, - C.Strings.Null_Ptr); - -- Arrays of C (char *) - - type In_Addr is record - S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; - end record; - for In_Addr'Alignment use C.int'Alignment; - pragma Convention (C, In_Addr); - -- IPv4 address, represented as a network-order C.int. Note that the - -- underlying operating system may assume that values of this type have - -- C.int alignment, so we need to provide a suitable alignment clause here. - - type In_Addr_Access is access all In_Addr; - pragma Convention (C, In_Addr_Access); - -- Access to internet address - - Inaddr_Any : aliased constant In_Addr := (others => 0); - -- Any internet address (all the interfaces) - - type In_Addr_Access_Array is array (C.size_t range <>) - of aliased In_Addr_Access; - pragma Convention (C, In_Addr_Access_Array); - - package In_Addr_Access_Pointers is - new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); - -- Array of internet addresses - - type Sockaddr is record - Sa_Family : C.unsigned_short; - Sa_Data : C.char_array (1 .. 14); - end record; - pragma Convention (C, Sockaddr); - -- Socket address - - type Sockaddr_Access is access all Sockaddr; - pragma Convention (C, Sockaddr_Access); - -- Access to socket address - - type Sockaddr_In is record - Sin_Family : C.unsigned_short := Constants.AF_INET; - Sin_Port : C.unsigned_short := 0; - Sin_Addr : In_Addr := Inaddr_Any; - Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); - end record; - pragma Convention (C, Sockaddr_In); - -- Internet socket address - - type Sockaddr_In_Access is access all Sockaddr_In; - pragma Convention (C, Sockaddr_In_Access); - -- Access to internet socket address - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int); - pragma Inline (Set_Length); - -- Set Sin.Sin_Length to Len. - -- On this platform, nothing is done as there is no such field. - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int); - pragma Inline (Set_Family); - -- Set Sin.Sin_Family to Family - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short); - pragma Inline (Set_Port); - -- Set Sin.Sin_Port to Port - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr); - pragma Inline (Set_Address); - -- Set Sin.Sin_Addr to Address - - type Hostent is record - H_Name : C.Strings.chars_ptr; - H_Aliases : Chars_Ptr_Pointers.Pointer; - H_Addrtype : C.int; - H_Length : C.int; - H_Addr_List : In_Addr_Access_Pointers.Pointer; - end record; - pragma Convention (C, Hostent); - -- Host entry - - type Hostent_Access is access all Hostent; - pragma Convention (C, Hostent_Access); - -- Access to host entry - - type Servent is record - S_Name : C.Strings.chars_ptr; - S_Aliases : Chars_Ptr_Pointers.Pointer; - S_Port : C.int; - S_Proto : C.Strings.chars_ptr; - end record; - pragma Convention (C, Servent); - -- Service entry - - type Servent_Access is access all Servent; - pragma Convention (C, Servent_Access); - -- Access to service entry - - type Two_Ints is array (0 .. 1) of C.int; - pragma Convention (C, Two_Ints); - -- Container for two int values - - subtype Fd_Pair is Two_Ints; - -- Two_Ints as used for Create_Signalling_Fds: a pair of connected file - -- descriptors, one of which (the "read end" of the connection) being used - -- for reading, the other one (the "write end") being used for writing. - - Read_End : constant := 0; - Write_End : constant := 1; - -- Indices into an Fd_Pair value providing access to each of the connected - -- file descriptors. - -------------------------------- -- Standard library functions -- -------------------------------- --- 75,80 ---- *************** package GNAT.Sockets.Thin is *** 382,436 **** end Signalling_Fds; - ---------------------------- - -- Socket sets management -- - ---------------------------- - - procedure Free_Socket_Set - (Set : Fd_Set_Access); - -- Free system-dependent socket set - - procedure Get_Socket_From_Set - (Set : Fd_Set_Access; - Socket : Int_Access; - Last : Int_Access); - -- Get last socket in Socket and remove it from the socket set. The - -- parameter Last is a maximum value of the largest socket. This hint is - -- used to avoid scanning very large socket sets. After a call to - -- Get_Socket_From_Set, Last is set back to the real largest socket in the - -- socket set. - - procedure Insert_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Insert socket in the socket set - - function Is_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int) return C.int; - -- Check whether Socket is in the socket set, return a non-zero - -- value if it is, zero if it is not. - - procedure Last_Socket_In_Set - (Set : Fd_Set_Access; - Last : Int_Access); - -- Find the largest socket in the socket set. This is needed for select(). - -- When Last_Socket_In_Set is called, parameter Last is a maximum value of - -- the largest socket. This hint is used to avoid scanning very large - -- socket sets. After the call, Last is set back to the real largest socket - -- in the socket set. - - function New_Socket_Set - (Set : Fd_Set_Access) return Fd_Set_Access; - -- Allocate a new socket set which is a system-dependent structure and - -- initialize by copying Set if it is non-null, by making it empty - -- otherwise. - - procedure Remove_Socket_From_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Remove socket from the socket set - ------------------------------------------- -- Nonreentrant network databases access -- ------------------------------------------- --- 224,229 ---- *************** private *** 470,483 **** pragma Import (C, C_Strerror, "DECC$STRERROR"); pragma Import (C, C_System, "DECC$SYSTEM"); - pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); - pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); - pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); - pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); - pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); - pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); - pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); - pragma Import (C, Nonreentrant_Gethostbyname, "DECC$GETHOSTBYNAME"); pragma Import (C, Nonreentrant_Gethostbyaddr, "DECC$GETHOSTBYADDR"); pragma Import (C, Nonreentrant_Getservbyname, "DECC$GETSERVBYNAME"); --- 263,268 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-socthi-vxworks.adb gcc-4.4.0/gcc/ada/g-socthi-vxworks.adb *** gcc-4.3.3/gcc/ada/g-socthi-vxworks.adb Wed Jun 6 10:13:25 2007 --- gcc-4.4.0/gcc/ada/g-socthi-vxworks.adb Fri Aug 8 12:59:28 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2008, AdaCore -- -- -- -- 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- -- *************** with Interfaces.C; use Interfaces.C; *** 45,51 **** package body GNAT.Sockets.Thin is Non_Blocking_Sockets : constant Fd_Set_Access := ! New_Socket_Set (No_Socket_Set); -- When this package is initialized with Process_Blocking_IO set -- to True, sockets are set in non-blocking mode to avoid blocking -- the whole process when a thread wants to perform a blocking IO --- 45,51 ---- package body GNAT.Sockets.Thin is Non_Blocking_Sockets : constant Fd_Set_Access := ! New_Socket_Set (No_Fd_Set_Access); -- When this package is initialized with Process_Blocking_IO set -- to True, sockets are set in non-blocking mode to avoid blocking -- the whole process when a thread wants to perform a blocking IO *************** package body GNAT.Sockets.Thin is *** 56,62 **** -- been set in non-blocking mode by the user. Quantum : constant Duration := 0.2; ! -- When Constants.Thread_Blocking_IO is False, we set sockets in -- non-blocking mode and we spend a period of time Quantum between -- two attempts on a blocking operation. --- 56,62 ---- -- been set in non-blocking mode by the user. Quantum : constant Duration := 0.2; ! -- When SOSC.Thread_Blocking_IO is False, we set sockets in -- non-blocking mode and we spend a period of time Quantum between -- two attempts on a blocking operation. *************** package body GNAT.Sockets.Thin is *** 146,167 **** begin loop R := Syscall_Accept (S, Addr, Addrlen); ! exit when Constants.Thread_Blocking_IO or else R /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; ! if not Constants.Thread_Blocking_IO and then R /= Failure then ! -- A socket inherits the properties ot its server especially -- the FIONBIO flag. Do not use C_Ioctl as this subprogram -- tracks sockets set in non-blocking mode by user. Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); ! Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); -- Is it OK to ignore result ??? end if; --- 146,167 ---- begin loop R := Syscall_Accept (S, Addr, Addrlen); ! exit when SOSC.Thread_Blocking_IO or else R /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; ! if not SOSC.Thread_Blocking_IO and then R /= Failure then ! -- A socket inherits the properties of its server especially -- the FIONBIO flag. Do not use C_Ioctl as this subprogram -- tracks sockets set in non-blocking mode by user. Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); ! Res := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Unchecked_Access); -- Is it OK to ignore result ??? end if; *************** package body GNAT.Sockets.Thin is *** 182,191 **** begin Res := Syscall_Connect (S, Name, Namelen); ! if Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EINPROGRESS then return Res; end if; --- 182,191 ---- begin Res := Syscall_Connect (S, Name, Namelen); ! if SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EINPROGRESS then return Res; end if; *************** package body GNAT.Sockets.Thin is *** 195,210 **** Now : aliased Timeval; begin ! WSet := New_Socket_Set (No_Socket_Set); loop Insert_Socket_In_Set (WSet, S); Now := Immediat; Res := C_Select (S + 1, ! No_Fd_Set, WSet, ! No_Fd_Set, Now'Unchecked_Access); exit when Res > 0; --- 195,210 ---- Now : aliased Timeval; begin ! WSet := New_Socket_Set (No_Fd_Set_Access); loop Insert_Socket_In_Set (WSet, S); Now := Immediat; Res := C_Select (S + 1, ! No_Fd_Set_Access, WSet, ! No_Fd_Set_Access, Now'Unchecked_Access); exit when Res > 0; *************** package body GNAT.Sockets.Thin is *** 223,231 **** Res := Syscall_Connect (S, Name, Namelen); if Res = Failure ! and then Errno = Constants.EISCONN then ! return Thin.Success; else return Res; end if; --- 223,231 ---- Res := Syscall_Connect (S, Name, Namelen); if Res = Failure ! and then Errno = SOSC.EISCONN then ! return Thin_Common.Success; else return Res; end if; *************** package body GNAT.Sockets.Thin is *** 241,248 **** Arg : Int_Access) return C.int is begin ! if not Constants.Thread_Blocking_IO ! and then Req = Constants.FIONBIO then if Arg.all /= 0 then Set_Non_Blocking_Socket (S, True); --- 241,248 ---- Arg : Int_Access) return C.int is begin ! if not SOSC.Thread_Blocking_IO ! and then Req = SOSC.FIONBIO then if Arg.all /= 0 then Set_Non_Blocking_Socket (S, True); *************** package body GNAT.Sockets.Thin is *** 267,276 **** begin loop Res := Syscall_Recv (S, Msg, Len, Flags); ! exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; --- 267,276 ---- begin loop Res := Syscall_Recv (S, Msg, Len, Flags); ! exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; *************** package body GNAT.Sockets.Thin is *** 294,303 **** begin loop Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); ! exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; --- 294,303 ---- begin loop Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); ! exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; *************** package body GNAT.Sockets.Thin is *** 319,328 **** begin loop Res := Syscall_Send (S, Msg, Len, Flags); ! exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; --- 319,328 ---- begin loop Res := Syscall_Send (S, Msg, Len, Flags); ! exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; *************** package body GNAT.Sockets.Thin is *** 346,355 **** begin loop Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); ! exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; --- 346,355 ---- begin loop Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); ! exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; *************** package body GNAT.Sockets.Thin is *** 374,386 **** begin R := Syscall_Socket (Domain, Typ, Protocol); ! if not Constants.Thread_Blocking_IO and then R /= Failure then -- Do not use C_Ioctl as this subprogram tracks sockets set -- in non-blocking mode by user. ! Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); -- Is it OK to ignore result ??? Set_Non_Blocking_Socket (R, False); end if; --- 374,386 ---- begin R := Syscall_Socket (Domain, Typ, Protocol); ! if not SOSC.Thread_Blocking_IO and then R /= Failure then -- Do not use C_Ioctl as this subprogram tracks sockets set -- in non-blocking mode by user. ! Res := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Unchecked_Access); -- Is it OK to ignore result ??? Set_Non_Blocking_Socket (R, False); end if; *************** package body GNAT.Sockets.Thin is *** 425,466 **** return R; end Non_Blocking_Socket; - ----------------- - -- Set_Address -- - ----------------- - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr) - is - begin - Sin.Sin_Addr := Address; - end Set_Address; - - ---------------- - -- Set_Family -- - ---------------- - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int) - is - begin - Sin.Sin_Family := C.unsigned_char (Family); - end Set_Family; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int) - is - begin - Sin.Sin_Length := C.unsigned_char (Len); - end Set_Length; - ----------------------------- -- Set_Non_Blocking_Socket -- ----------------------------- --- 425,430 ---- *************** package body GNAT.Sockets.Thin is *** 477,494 **** Task_Lock.Unlock; end Set_Non_Blocking_Socket; - -------------- - -- Set_Port -- - -------------- - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short) - is - begin - Sin.Sin_Port := Port; - end Set_Port; - -------------------- -- Signalling_Fds -- -------------------- --- 441,446 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-socthi-vxworks.ads gcc-4.4.0/gcc/ada/g-socthi-vxworks.ads *** gcc-4.3.3/gcc/ada/g-socthi-vxworks.ads Wed Jun 6 10:13:25 2007 --- gcc-4.4.0/gcc/ada/g-socthi-vxworks.ads Tue May 20 12:59:41 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2008, AdaCore -- -- -- -- 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,61 **** -- This is the version for VxWorks - with Interfaces.C.Pointers; with Interfaces.C.Strings; - with Ada.Unchecked_Conversion; - with GNAT.OS_Lib; ! with GNAT.Sockets.Constants; with System; package GNAT.Sockets.Thin is ! package C renames Interfaces.C; ! ! use type C.int; ! -- This is so we can declare the Failure constant below ! Success : constant C.int := 0; ! Failure : constant C.int := -1; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number --- 37,54 ---- -- This is the version for VxWorks with Interfaces.C.Strings; with GNAT.OS_Lib; ! with GNAT.Sockets.Thin_Common; with System; package GNAT.Sockets.Thin is ! use Thin_Common; ! package C renames Interfaces.C; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number *************** package GNAT.Sockets.Thin is *** 80,240 **** end Host_Error_Messages; - subtype Fd_Set_Access is System.Address; - No_Fd_Set : constant Fd_Set_Access := System.Null_Address; - - type time_t is - range -2 ** (8 * Constants.SIZEOF_tv_sec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_sec - 1) - 1; - for time_t'Size use 8 * Constants.SIZEOF_tv_sec; - pragma Convention (C, time_t); - - type suseconds_t is - range -2 ** (8 * Constants.SIZEOF_tv_usec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_usec - 1) - 1; - for suseconds_t'Size use 8 * Constants.SIZEOF_tv_usec; - pragma Convention (C, suseconds_t); - - type Timeval is record - Tv_Sec : time_t; - Tv_Usec : suseconds_t; - end record; - pragma Convention (C, Timeval); - - type Timeval_Access is access all Timeval; - pragma Convention (C, Timeval_Access); - - Immediat : constant Timeval := (0, 0); - - type Int_Access is access all C.int; - pragma Convention (C, Int_Access); - -- Access to C integers - - type Chars_Ptr_Array is array (C.size_t range <>) of - aliased C.Strings.chars_ptr; - - package Chars_Ptr_Pointers is - new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, - C.Strings.Null_Ptr); - -- Arrays of C (char *) - - type In_Addr is record - S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; - end record; - for In_Addr'Alignment use C.int'Alignment; - pragma Convention (C, In_Addr); - -- IPv4 address, represented as a network-order C.int. Note that the - -- underlying operating system may assume that values of this type have - -- C.int alignment, so we need to provide a suitable alignment clause here. - - function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); - - type In_Addr_Access is access all In_Addr; - pragma Convention (C, In_Addr_Access); - -- Access to internet address - - Inaddr_Any : aliased constant In_Addr := (others => 0); - -- Any internet address (all the interfaces) - - type In_Addr_Access_Array is array (C.size_t range <>) - of aliased In_Addr_Access; - pragma Convention (C, In_Addr_Access_Array); - - package In_Addr_Access_Pointers is - new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); - -- Array of internet addresses - - type Sockaddr is record - Sa_Length : C.unsigned_char; - Sa_Family : C.unsigned_char; - Sa_Data : C.char_array (1 .. 14); - end record; - pragma Convention (C, Sockaddr); - -- Socket address - - type Sockaddr_Access is access all Sockaddr; - pragma Convention (C, Sockaddr_Access); - -- Access to socket address - - type Sockaddr_In is record - Sin_Length : C.unsigned_char := 0; - Sin_Family : C.unsigned_char := Constants.AF_INET; - Sin_Port : C.unsigned_short := 0; - Sin_Addr : In_Addr := Inaddr_Any; - Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); - end record; - pragma Convention (C, Sockaddr_In); - -- Internet socket address - - type Sockaddr_In_Access is access all Sockaddr_In; - pragma Convention (C, Sockaddr_In_Access); - -- Access to internet socket address - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int); - pragma Inline (Set_Length); - -- Set Sin.Sin_Length to Len - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int); - pragma Inline (Set_Family); - -- Set Sin.Sin_Family to Family - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short); - pragma Inline (Set_Port); - -- Set Sin.Sin_Port to Port - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr); - pragma Inline (Set_Address); - -- Set Sin.Sin_Addr to Address - - type Hostent is record - H_Name : C.Strings.chars_ptr; - H_Aliases : Chars_Ptr_Pointers.Pointer; - H_Addrtype : C.int; - H_Length : C.int; - H_Addr_List : In_Addr_Access_Pointers.Pointer; - end record; - pragma Convention (C, Hostent); - -- Host entry - - type Hostent_Access is access all Hostent; - pragma Convention (C, Hostent_Access); - -- Access to host entry - - type Servent is record - S_Name : C.Strings.chars_ptr; - S_Aliases : Chars_Ptr_Pointers.Pointer; - S_Port : C.int; - S_Proto : C.Strings.chars_ptr; - end record; - pragma Convention (C, Servent); - -- Service entry - - type Servent_Access is access all Servent; - pragma Convention (C, Servent_Access); - -- Access to service entry - - type Two_Ints is array (0 .. 1) of C.int; - pragma Convention (C, Two_Ints); - -- Container for two int values - - subtype Fd_Pair is Two_Ints; - -- Two_Ints as used for Create_Signalling_Fds: a pair of connected file - -- descriptors, one of which (the "read end" of the connection) being used - -- for reading, the other one (the "write end") being used for writing. - - Read_End : constant := 0; - Write_End : constant := 1; - -- Indices into an Fd_Pair value providing access to each of the connected - -- file descriptors. - -------------------------------- -- Standard library functions -- -------------------------------- --- 73,78 ---- *************** package GNAT.Sockets.Thin is *** 384,438 **** end Signalling_Fds; - ---------------------------- - -- Socket sets management -- - ---------------------------- - - procedure Free_Socket_Set - (Set : Fd_Set_Access); - -- Free system-dependent socket set - - procedure Get_Socket_From_Set - (Set : Fd_Set_Access; - Socket : Int_Access; - Last : Int_Access); - -- Get last socket in Socket and remove it from the socket set. The - -- parameter Last is a maximum value of the largest socket. This hint is - -- used to avoid scanning very large socket sets. After a call to - -- Get_Socket_From_Set, Last is set back to the real largest socket in the - -- socket set. - - procedure Insert_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Insert socket in the socket set - - function Is_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int) return C.int; - -- Check whether Socket is in the socket set, return a non-zero - -- value if it is, zero if it is not. - - procedure Last_Socket_In_Set - (Set : Fd_Set_Access; - Last : Int_Access); - -- Find the largest socket in the socket set. This is needed for select(). - -- When Last_Socket_In_Set is called, parameter Last is a maximum value of - -- the largest socket. This hint is used to avoid scanning very large - -- socket sets. After the call, Last is set back to the real largest socket - -- in the socket set. - - function New_Socket_Set - (Set : Fd_Set_Access) return Fd_Set_Access; - -- Allocate a new socket set which is a system-dependent structure and - -- initialize by copying Set if it is non-null, by making it empty - -- otherwise. - - procedure Remove_Socket_From_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Remove socket from the socket set - procedure Initialize; procedure Finalize; --- 222,227 ---- *************** private *** 452,464 **** pragma Import (C, C_Strerror, "strerror"); pragma Import (C, C_System, "system"); pragma Import (C, C_Writev, "writev"); - - pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); - pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); - pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); - pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); - pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); - pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); - pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); - end GNAT.Sockets.Thin; --- 241,244 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-socthi.adb gcc-4.4.0/gcc/ada/g-socthi.adb *** gcc-4.3.3/gcc/ada/g-socthi.adb Wed Jun 6 10:31:06 2007 --- gcc-4.4.0/gcc/ada/g-socthi.adb Fri Aug 8 12:59:28 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** with Interfaces.C; use Interfaces.C; *** 45,51 **** package body GNAT.Sockets.Thin is Non_Blocking_Sockets : constant Fd_Set_Access := ! New_Socket_Set (No_Socket_Set); -- When this package is initialized with Process_Blocking_IO set -- to True, sockets are set in non-blocking mode to avoid blocking -- the whole process when a thread wants to perform a blocking IO --- 45,51 ---- package body GNAT.Sockets.Thin is Non_Blocking_Sockets : constant Fd_Set_Access := ! New_Socket_Set (No_Fd_Set_Access); -- When this package is initialized with Process_Blocking_IO set -- to True, sockets are set in non-blocking mode to avoid blocking -- the whole process when a thread wants to perform a blocking IO *************** package body GNAT.Sockets.Thin is *** 56,62 **** -- been set in non-blocking mode by the user. Quantum : constant Duration := 0.2; ! -- When Constants.Thread_Blocking_IO is False, we set sockets in -- non-blocking mode and we spend a period of time Quantum between -- two attempts on a blocking operation. --- 56,62 ---- -- been set in non-blocking mode by the user. Quantum : constant Duration := 0.2; ! -- When SOSC.Thread_Blocking_IO is False, we set sockets in -- non-blocking mode and we spend a period of time Quantum between -- two attempts on a blocking operation. *************** package body GNAT.Sockets.Thin is *** 150,163 **** begin loop R := Syscall_Accept (S, Addr, Addrlen); ! exit when Constants.Thread_Blocking_IO or else R /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; ! if not Constants.Thread_Blocking_IO and then R /= Failure then -- A socket inherits the properties ot its server especially --- 150,163 ---- begin loop R := Syscall_Accept (S, Addr, Addrlen); ! exit when SOSC.Thread_Blocking_IO or else R /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; ! if not SOSC.Thread_Blocking_IO and then R /= Failure then -- A socket inherits the properties ot its server especially *************** package body GNAT.Sockets.Thin is *** 165,171 **** -- tracks sockets set in non-blocking mode by user. Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); ! Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); end if; Disable_SIGPIPE (R); --- 165,171 ---- -- tracks sockets set in non-blocking mode by user. Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); ! Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Unchecked_Access); end if; Disable_SIGPIPE (R); *************** package body GNAT.Sockets.Thin is *** 186,195 **** begin Res := Syscall_Connect (S, Name, Namelen); ! if Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EINPROGRESS then return Res; end if; --- 186,195 ---- begin Res := Syscall_Connect (S, Name, Namelen); ! if SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EINPROGRESS then return Res; end if; *************** package body GNAT.Sockets.Thin is *** 199,213 **** Now : aliased Timeval; begin ! WSet := New_Socket_Set (No_Socket_Set); loop Insert_Socket_In_Set (WSet, S); Now := Immediat; Res := C_Select (S + 1, ! No_Fd_Set, WSet, ! No_Fd_Set, Now'Unchecked_Access); exit when Res > 0; --- 199,213 ---- Now : aliased Timeval; begin ! WSet := New_Socket_Set (No_Fd_Set_Access); loop Insert_Socket_In_Set (WSet, S); Now := Immediat; Res := C_Select (S + 1, ! No_Fd_Set_Access, WSet, ! No_Fd_Set_Access, Now'Unchecked_Access); exit when Res > 0; *************** package body GNAT.Sockets.Thin is *** 226,234 **** Res := Syscall_Connect (S, Name, Namelen); if Res = Failure ! and then Errno = Constants.EISCONN then ! return Thin.Success; else return Res; end if; --- 226,234 ---- Res := Syscall_Connect (S, Name, Namelen); if Res = Failure ! and then Errno = SOSC.EISCONN then ! return Thin_Common.Success; else return Res; end if; *************** package body GNAT.Sockets.Thin is *** 244,251 **** Arg : Int_Access) return C.int is begin ! if not Constants.Thread_Blocking_IO ! and then Req = Constants.FIONBIO then if Arg.all /= 0 then Set_Non_Blocking_Socket (S, True); --- 244,251 ---- Arg : Int_Access) return C.int is begin ! if not SOSC.Thread_Blocking_IO ! and then Req = SOSC.FIONBIO then if Arg.all /= 0 then Set_Non_Blocking_Socket (S, True); *************** package body GNAT.Sockets.Thin is *** 270,279 **** begin loop Res := Syscall_Recv (S, Msg, Len, Flags); ! exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; --- 270,279 ---- begin loop Res := Syscall_Recv (S, Msg, Len, Flags); ! exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; *************** package body GNAT.Sockets.Thin is *** 297,306 **** begin loop Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); ! exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; --- 297,306 ---- begin loop Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); ! exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; *************** package body GNAT.Sockets.Thin is *** 322,331 **** begin loop Res := Syscall_Send (S, Msg, Len, Flags); ! exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; --- 322,331 ---- begin loop Res := Syscall_Send (S, Msg, Len, Flags); ! exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; *************** package body GNAT.Sockets.Thin is *** 349,358 **** begin loop Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); ! exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; --- 349,358 ---- begin loop Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); ! exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) ! or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; *************** package body GNAT.Sockets.Thin is *** 377,389 **** begin R := Syscall_Socket (Domain, Typ, Protocol); ! if not Constants.Thread_Blocking_IO and then R /= Failure then -- Do not use C_Ioctl as this subprogram tracks sockets set -- in non-blocking mode by user. ! Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); Set_Non_Blocking_Socket (R, False); end if; Disable_SIGPIPE (R); --- 377,389 ---- begin R := Syscall_Socket (Domain, Typ, Protocol); ! if not SOSC.Thread_Blocking_IO and then R /= Failure then -- Do not use C_Ioctl as this subprogram tracks sockets set -- in non-blocking mode by user. ! Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Unchecked_Access); Set_Non_Blocking_Socket (R, False); end if; Disable_SIGPIPE (R); *************** package body GNAT.Sockets.Thin is *** 427,471 **** return R; end Non_Blocking_Socket; - ----------------- - -- Set_Address -- - ----------------- - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr) - is - begin - Sin.Sin_Addr := Address; - end Set_Address; - - ---------------- - -- Set_Family -- - ---------------- - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int) - is - begin - Sin.Sin_Family := C.unsigned_short (Family); - end Set_Family; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int) - is - pragma Unreferenced (Sin); - pragma Unreferenced (Len); - - begin - null; - end Set_Length; - ----------------------------- -- Set_Non_Blocking_Socket -- ----------------------------- --- 427,432 ---- *************** package body GNAT.Sockets.Thin is *** 483,500 **** Task_Lock.Unlock; end Set_Non_Blocking_Socket; - -------------- - -- Set_Port -- - -------------- - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short) - is - begin - Sin.Sin_Port := Port; - end Set_Port; - -------------------- -- Signalling_Fds -- -------------------- --- 444,449 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-socthi.ads gcc-4.4.0/gcc/ada/g-socthi.ads *** gcc-4.3.3/gcc/ada/g-socthi.ads Wed Jun 6 10:31:06 2007 --- gcc-4.4.0/gcc/ada/g-socthi.ads Tue May 20 12:43:29 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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,47 **** -- This is the default version - with Interfaces.C.Pointers; with Interfaces.C.Strings; with GNAT.OS_Lib; ! with GNAT.Sockets.Constants; with System; --- 37,46 ---- -- This is the default version with Interfaces.C.Strings; with GNAT.OS_Lib; ! with GNAT.Sockets.Thin_Common; with System; *************** package GNAT.Sockets.Thin is *** 51,63 **** -- standard interface. It will be used as a default for all the platforms -- that do not have a specific version of this file. ! package C renames Interfaces.C; ! ! use type C.int; ! -- This is so we can declare the Failure constant below ! Success : constant C.int := 0; ! Failure : constant C.int := -1; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number --- 50,58 ---- -- standard interface. It will be used as a default for all the platforms -- that do not have a specific version of this file. ! use Thin_Common; ! package C renames Interfaces.C; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number *************** package GNAT.Sockets.Thin is *** 79,236 **** end Host_Error_Messages; - subtype Fd_Set_Access is System.Address; - No_Fd_Set : constant Fd_Set_Access := System.Null_Address; - - type time_t is - range -2 ** (8 * Constants.SIZEOF_tv_sec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_sec - 1) - 1; - for time_t'Size use 8 * Constants.SIZEOF_tv_sec; - pragma Convention (C, time_t); - - type suseconds_t is - range -2 ** (8 * Constants.SIZEOF_tv_usec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_usec - 1) - 1; - for suseconds_t'Size use 8 * Constants.SIZEOF_tv_usec; - pragma Convention (C, suseconds_t); - - type Timeval is record - Tv_Sec : time_t; - Tv_Usec : suseconds_t; - end record; - pragma Convention (C, Timeval); - - type Timeval_Access is access all Timeval; - pragma Convention (C, Timeval_Access); - - Immediat : constant Timeval := (0, 0); - - type Int_Access is access all C.int; - pragma Convention (C, Int_Access); - -- Access to C integers - - type Chars_Ptr_Array is array (C.size_t range <>) of - aliased C.Strings.chars_ptr; - - package Chars_Ptr_Pointers is - new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, - C.Strings.Null_Ptr); - -- Arrays of C (char *) - - type In_Addr is record - S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; - end record; - for In_Addr'Alignment use C.int'Alignment; - pragma Convention (C, In_Addr); - -- IPv4 address, represented as a network-order C.int. Note that the - -- underlying operating system may assume that values of this type have - -- C.int alignment, so we need to provide a suitable alignment clause here. - - type In_Addr_Access is access all In_Addr; - pragma Convention (C, In_Addr_Access); - -- Access to internet address - - Inaddr_Any : aliased constant In_Addr := (others => 0); - -- Any internet address (all the interfaces) - - type In_Addr_Access_Array is array (C.size_t range <>) - of aliased In_Addr_Access; - pragma Convention (C, In_Addr_Access_Array); - - package In_Addr_Access_Pointers is - new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); - -- Array of internet addresses - - type Sockaddr is record - Sa_Family : C.unsigned_short; - Sa_Data : C.char_array (1 .. 14); - end record; - pragma Convention (C, Sockaddr); - -- Socket address - - type Sockaddr_Access is access all Sockaddr; - pragma Convention (C, Sockaddr_Access); - -- Access to socket address - - type Sockaddr_In is record - Sin_Family : C.unsigned_short := Constants.AF_INET; - Sin_Port : C.unsigned_short := 0; - Sin_Addr : In_Addr := Inaddr_Any; - Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); - end record; - pragma Convention (C, Sockaddr_In); - -- Internet socket address - - type Sockaddr_In_Access is access all Sockaddr_In; - pragma Convention (C, Sockaddr_In_Access); - -- Access to internet socket address - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int); - pragma Inline (Set_Length); - -- Set Sin.Sin_Length to Len. - -- On this platform, nothing is done as there is no such field. - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int); - pragma Inline (Set_Family); - -- Set Sin.Sin_Family to Family - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short); - pragma Inline (Set_Port); - -- Set Sin.Sin_Port to Port - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr); - pragma Inline (Set_Address); - -- Set Sin.Sin_Addr to Address - - type Hostent is record - H_Name : C.Strings.chars_ptr; - H_Aliases : Chars_Ptr_Pointers.Pointer; - H_Addrtype : C.int; - H_Length : C.int; - H_Addr_List : In_Addr_Access_Pointers.Pointer; - end record; - pragma Convention (C, Hostent); - -- Host entry - - type Hostent_Access is access all Hostent; - pragma Convention (C, Hostent_Access); - -- Access to host entry - - type Servent is record - S_Name : C.Strings.chars_ptr; - S_Aliases : Chars_Ptr_Pointers.Pointer; - S_Port : C.int; - S_Proto : C.Strings.chars_ptr; - end record; - pragma Convention (C, Servent); - -- Service entry - - type Servent_Access is access all Servent; - pragma Convention (C, Servent_Access); - -- Access to service entry - - type Two_Ints is array (0 .. 1) of C.int; - pragma Convention (C, Two_Ints); - -- Container for two int values - - subtype Fd_Pair is Two_Ints; - -- Two_Ints as used for Create_Signalling_Fds: a pair of connected file - -- descriptors, one of which (the "read end" of the connection) being used - -- for reading, the other one (the "write end") being used for writing. - - Read_End : constant := 0; - Write_End : constant := 1; - -- Indices into an Fd_Pair value providing access to each of the connected - -- file descriptors. - -------------------------------- -- Standard library functions -- -------------------------------- --- 74,79 ---- *************** package GNAT.Sockets.Thin is *** 380,434 **** end Signalling_Fds; - ---------------------------- - -- Socket sets management -- - ---------------------------- - - procedure Free_Socket_Set - (Set : Fd_Set_Access); - -- Free system-dependent socket set - - procedure Get_Socket_From_Set - (Set : Fd_Set_Access; - Socket : Int_Access; - Last : Int_Access); - -- Get last socket in Socket and remove it from the socket set. The - -- parameter Last is a maximum value of the largest socket. This hint is - -- used to avoid scanning very large socket sets. After a call to - -- Get_Socket_From_Set, Last is set back to the real largest socket in the - -- socket set. - - procedure Insert_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Insert socket in the socket set - - function Is_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int) return C.int; - -- Check whether Socket is in the socket set, return a non-zero - -- value if it is, zero if it is not. - - procedure Last_Socket_In_Set - (Set : Fd_Set_Access; - Last : Int_Access); - -- Find the largest socket in the socket set. This is needed for select(). - -- When Last_Socket_In_Set is called, parameter Last is a maximum value of - -- the largest socket. This hint is used to avoid scanning very large - -- socket sets. After the call, Last is set back to the real largest socket - -- in the socket set. - - function New_Socket_Set - (Set : Fd_Set_Access) return Fd_Set_Access; - -- Allocate a new socket set which is a system-dependent structure and - -- initialize by copying Set if it is non-null, by making it empty - -- otherwise. - - procedure Remove_Socket_From_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Remove socket from the socket set - ------------------------------------------- -- Nonreentrant network databases access -- ------------------------------------------- --- 223,228 ---- *************** private *** 473,486 **** pragma Import (C, C_System, "system"); pragma Import (C, C_Writev, "writev"); - pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); - pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); - pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); - pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); - pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); - pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); - pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); - pragma Import (C, Nonreentrant_Gethostbyname, "gethostbyname"); pragma Import (C, Nonreentrant_Gethostbyaddr, "gethostbyaddr"); pragma Import (C, Nonreentrant_Getservbyname, "getservbyname"); --- 267,272 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/g-soliop-mingw.ads gcc-4.4.0/gcc/ada/g-soliop-mingw.ads *** gcc-4.3.3/gcc/ada/g-soliop-mingw.ads Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/g-soliop-mingw.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** *** 32,38 **** ------------------------------------------------------------------------------ -- This package is used to provide target specific linker_options for the ! -- support of scokets as required by the package GNAT.Sockets. -- This is the Windows/NT version of this package --- 32,38 ---- ------------------------------------------------------------------------------ -- This package is used to provide target specific linker_options for the ! -- support of sockets as required by the package GNAT.Sockets. -- This is the Windows/NT version of this package diff -Nrcpad gcc-4.3.3/gcc/ada/g-soliop-solaris.ads gcc-4.4.0/gcc/ada/g-soliop-solaris.ads *** gcc-4.3.3/gcc/ada/g-soliop-solaris.ads Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/g-soliop-solaris.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** *** 32,38 **** ------------------------------------------------------------------------------ -- This package is used to provide target specific linker_options for the ! -- support of scokets as required by the package GNAT.Sockets. -- This is the Solaris version of this package --- 32,38 ---- ------------------------------------------------------------------------------ -- This package is used to provide target specific linker_options for the ! -- support of sockets as required by the package GNAT.Sockets. -- This is the Solaris version of this package diff -Nrcpad gcc-4.3.3/gcc/ada/g-soliop.ads gcc-4.4.0/gcc/ada/g-soliop.ads *** gcc-4.3.3/gcc/ada/g-soliop.ads Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/g-soliop.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** *** 32,38 **** ------------------------------------------------------------------------------ -- This package is used to provide target specific linker_options for the ! -- support of scokets as required by the package GNAT.Sockets. -- This is an empty version for default use where no additional libraries -- are required. On some targets a target specific version of this unit --- 32,38 ---- ------------------------------------------------------------------------------ -- This package is used to provide target specific linker_options for the ! -- support of sockets as required by the package GNAT.Sockets. -- This is an empty version for default use where no additional libraries -- are required. On some targets a target specific version of this unit diff -Nrcpad gcc-4.3.3/gcc/ada/g-sothco-dummy.adb gcc-4.4.0/gcc/ada/g-sothco-dummy.adb *** gcc-4.3.3/gcc/ada/g-sothco-dummy.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-sothco-dummy.adb Wed Aug 6 08:57:21 2008 *************** *** 0 **** --- 1,34 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . T H I N _ C O M M O N -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + pragma No_Body; diff -Nrcpad gcc-4.3.3/gcc/ada/g-sothco-dummy.ads gcc-4.4.0/gcc/ada/g-sothco-dummy.ads *** gcc-4.3.3/gcc/ada/g-sothco-dummy.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-sothco-dummy.ads Wed Aug 6 08:57:21 2008 *************** *** 0 **** --- 1,39 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . T H I N _ C O M M O N -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package is a placeholder for the sockets binding for platforms where + -- it is not implemented. + + package GNAT.Sockets.Thin_Common is + pragma Unimplemented_Unit; + end GNAT.Sockets.Thin_Common; diff -Nrcpad gcc-4.3.3/gcc/ada/g-sothco.adb gcc-4.4.0/gcc/ada/g-sothco.adb *** gcc-4.3.3/gcc/ada/g-sothco.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-sothco.adb Fri Aug 8 12:59:28 2008 *************** *** 0 **** --- 1,79 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . T H I N _ C O M M O N -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package body GNAT.Sockets.Thin_Common is + + ----------------- + -- Set_Address -- + ----------------- + + procedure Set_Address + (Sin : Sockaddr_In_Access; + Address : In_Addr) + is + begin + Sin.Sin_Addr := Address; + end Set_Address; + + ---------------- + -- Set_Family -- + ---------------- + + procedure Set_Family + (Length_And_Family : out Sockaddr_Length_And_Family; + Family : Family_Type) + is + C_Family : C.int renames Families (Family); + Has_Sockaddr_Len : constant Boolean := SOSC.Has_Sockaddr_Len /= 0; + begin + if Has_Sockaddr_Len then + Length_And_Family.Length := Lengths (Family); + Length_And_Family.Char_Family := C.unsigned_char (C_Family); + else + Length_And_Family.Short_Family := C.unsigned_short (C_Family); + end if; + end Set_Family; + + -------------- + -- Set_Port -- + -------------- + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short) + is + begin + Sin.Sin_Port := Port; + end Set_Port; + + end GNAT.Sockets.Thin_Common; diff -Nrcpad gcc-4.3.3/gcc/ada/g-sothco.ads gcc-4.4.0/gcc/ada/g-sothco.ads *** gcc-4.3.3/gcc/ada/g-sothco.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-sothco.ads Fri Aug 8 12:59:28 2008 *************** *** 0 **** --- 1,324 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . T H I N _ C O M M O N -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the target-independent part of the thin sockets mapping. + -- This package should not be directly with'ed by an applications program. + + with Ada.Unchecked_Conversion; + + with Interfaces.C; + with Interfaces.C.Pointers; + with Interfaces.C.Strings; + + package GNAT.Sockets.Thin_Common is + + package C renames Interfaces.C; + + use type C.int; + -- This is so we can declare the Failure constant below + + Success : constant C.int := 0; + Failure : constant C.int := -1; + + type time_t is + range -2 ** (8 * SOSC.SIZEOF_tv_sec - 1) + .. 2 ** (8 * SOSC.SIZEOF_tv_sec - 1) - 1; + for time_t'Size use 8 * SOSC.SIZEOF_tv_sec; + pragma Convention (C, time_t); + + type suseconds_t is + range -2 ** (8 * SOSC.SIZEOF_tv_usec - 1) + .. 2 ** (8 * SOSC.SIZEOF_tv_usec - 1) - 1; + for suseconds_t'Size use 8 * SOSC.SIZEOF_tv_usec; + pragma Convention (C, suseconds_t); + + type Timeval is record + Tv_Sec : time_t; + Tv_Usec : suseconds_t; + end record; + pragma Convention (C, Timeval); + + type Timeval_Access is access all Timeval; + pragma Convention (C, Timeval_Access); + + Immediat : constant Timeval := (0, 0); + + ------------------------------------------- + -- Mapping tables to low level constants -- + ------------------------------------------- + + Families : constant array (Family_Type) of C.int := + (Family_Inet => SOSC.AF_INET, + Family_Inet6 => SOSC.AF_INET6); + + Lengths : constant array (Family_Type) of C.unsigned_char := + (Family_Inet => SOSC.SIZEOF_sockaddr_in, + Family_Inet6 => SOSC.SIZEOF_sockaddr_in6); + + ---------------------------- + -- Generic socket address -- + ---------------------------- + + -- Common header + + -- All socket address types (struct sockaddr, struct sockaddr_storage, + -- and protocol specific address types) start with the same 2-byte header, + -- which is either a length and a family (one byte each) or just a two-byte + -- family. The following unchecked union describes the two possible layouts + -- and is meant to be constrained with SOSC.Have_Sockaddr_Len. + + type Sockaddr_Length_And_Family + (Has_Sockaddr_Len : Boolean := False) + is record + case Has_Sockaddr_Len is + when True => + Length : C.unsigned_char; + Char_Family : C.unsigned_char; + + when False => + Short_Family : C.unsigned_short; + end case; + end record; + pragma Unchecked_Union (Sockaddr_Length_And_Family); + pragma Convention (C, Sockaddr_Length_And_Family); + + procedure Set_Family + (Length_And_Family : out Sockaddr_Length_And_Family; + Family : Family_Type); + -- Set the family component to the appropriate value for Family, and also + -- set Length accordingly if applicable on this platform. + + type Sockaddr is record + Sa_Family : Sockaddr_Length_And_Family; + -- Address family (and address length on some platforms) + + Sa_Data : C.char_array (1 .. 14) := (others => C.nul); + -- Family-specific data + -- Note that some platforms require that all unused (reserved) bytes + -- in addresses be initialized to 0 (e.g. VxWorks). + end record; + pragma Convention (C, Sockaddr); + -- Generic socket address + + type Sockaddr_Access is access all Sockaddr; + pragma Convention (C, Sockaddr_Access); + -- Access to socket address + + ---------------------------- + -- AF_INET socket address -- + ---------------------------- + + type In_Addr is record + S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; + end record; + for In_Addr'Alignment use C.int'Alignment; + pragma Convention (C, In_Addr); + -- IPv4 address, represented as a network-order C.int. Note that the + -- underlying operating system may assume that values of this type have + -- C.int alignment, so we need to provide a suitable alignment clause here. + + function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); + function To_Int is new Ada.Unchecked_Conversion (In_Addr, C.int); + + type In_Addr_Access is access all In_Addr; + pragma Convention (C, In_Addr_Access); + -- Access to internet address + + Inaddr_Any : aliased constant In_Addr := (others => 0); + -- Any internet address (all the interfaces) + + type In_Addr_Access_Array is array (C.size_t range <>) + of aliased In_Addr_Access; + pragma Convention (C, In_Addr_Access_Array); + + package In_Addr_Access_Pointers is new C.Pointers + (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); + -- Array of internet addresses + + type Sockaddr_In is record + Sin_Family : Sockaddr_Length_And_Family; + -- Address family (and address length on some platforms) + + Sin_Port : C.unsigned_short; + -- Port in network byte order + + Sin_Addr : In_Addr; + -- IPv4 address + + Sin_Zero : C.char_array (1 .. 8) := (others => C.nul); + -- Padding + -- Note that some platforms require that all unused (reserved) bytes + -- in addresses be initialized to 0 (e.g. VxWorks). + end record; + pragma Convention (C, Sockaddr_In); + -- Internet socket address + + type Sockaddr_In_Access is access all Sockaddr_In; + pragma Convention (C, Sockaddr_In_Access); + -- Access to internet socket address + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short); + pragma Inline (Set_Port); + -- Set Sin.Sin_Port to Port + + procedure Set_Address + (Sin : Sockaddr_In_Access; + Address : In_Addr); + pragma Inline (Set_Address); + -- Set Sin.Sin_Addr to Address + + --------------------- + -- Service entries -- + --------------------- + + type Chars_Ptr_Array is array (C.size_t range <>) of + aliased C.Strings.chars_ptr; + + package Chars_Ptr_Pointers is + new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, + C.Strings.Null_Ptr); + -- Arrays of C (char *) + + type Servent is record + S_Name : C.Strings.chars_ptr; + S_Aliases : Chars_Ptr_Pointers.Pointer; + S_Port : C.int; + S_Proto : C.Strings.chars_ptr; + end record; + pragma Convention (C, Servent); + -- Service entry + + type Servent_Access is access all Servent; + pragma Convention (C, Servent_Access); + -- Access to service entry + + ------------------ + -- Host entries -- + ------------------ + + type Hostent is record + H_Name : C.Strings.chars_ptr; + H_Aliases : Chars_Ptr_Pointers.Pointer; + H_Addrtype : SOSC.H_Addrtype_T; + H_Length : SOSC.H_Length_T; + H_Addr_List : In_Addr_Access_Pointers.Pointer; + end record; + pragma Convention (C, Hostent); + -- Host entry + + type Hostent_Access is access all Hostent; + pragma Convention (C, Hostent_Access); + -- Access to host entry + + ---------------------------- + -- Socket sets management -- + ---------------------------- + + type Int_Access is access all C.int; + pragma Convention (C, Int_Access); + -- Access to C integers + + procedure Free_Socket_Set (Set : Fd_Set_Access); + -- Free system-dependent socket set + + procedure Get_Socket_From_Set + (Set : Fd_Set_Access; + Socket : Int_Access; + Last : Int_Access); + -- Get last socket in Socket and remove it from the socket set. The + -- parameter Last is a maximum value of the largest socket. This hint is + -- used to avoid scanning very large socket sets. After a call to + -- Get_Socket_From_Set, Last is set back to the real largest socket in the + -- socket set. + + procedure Insert_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Insert socket in the socket set + + function Is_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int) return C.int; + -- Check whether Socket is in the socket set, return a non-zero + -- value if it is, zero if it is not. + + procedure Last_Socket_In_Set + (Set : Fd_Set_Access; + Last : Int_Access); + -- Find the largest socket in the socket set. This is needed for select(). + -- When Last_Socket_In_Set is called, parameter Last is a maximum value of + -- the largest socket. This hint is used to avoid scanning very large + -- socket sets. After the call, Last is set back to the real largest socket + -- in the socket set. + + function New_Socket_Set + (Set : Fd_Set_Access) return Fd_Set_Access; + -- Allocate a new socket set which is a system-dependent structure and + -- initialize by copying Set if it is non-null, by making it empty + -- otherwise. + + procedure Remove_Socket_From_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Remove socket from the socket set + + ------------------------------------------ + -- Pairs of signalling file descriptors -- + ------------------------------------------ + + type Two_Ints is array (0 .. 1) of C.int; + pragma Convention (C, Two_Ints); + -- Container for two int values + + subtype Fd_Pair is Two_Ints; + -- Two_Ints as used for Create_Signalling_Fds: a pair of connected file + -- descriptors, one of which (the "read end" of the connection) being used + -- for reading, the other one (the "write end") being used for writing. + + Read_End : constant := 0; + Write_End : constant := 1; + -- Indices into an Fd_Pair value providing access to each of the connected + -- file descriptors. + + private + + pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); + pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); + pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); + pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); + pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); + pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); + pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); + end GNAT.Sockets.Thin_Common; diff -Nrcpad gcc-4.3.3/gcc/ada/g-spipat.adb gcc-4.4.0/gcc/ada/g-spipat.adb *** gcc-4.3.3/gcc/ada/g-spipat.adb Thu Dec 13 10:28:10 2007 --- gcc-4.4.0/gcc/ada/g-spipat.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2008, AdaCore -- -- -- -- 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- -- *************** *** 36,42 **** -- a direct translation, but the approach is followed closely. In particular, -- we use the one stack approach developed in the SPITBOL implementation. - with Ada.Exceptions; use Ada.Exceptions; with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux; with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; --- 36,41 ---- *************** package body GNAT.Spitbol.Patterns is *** 103,109 **** -- I parameter(s) I -- +------------------------------------+ ! -- Pcode is a code value indicating the type of the patterm node. This -- code is used both as the discriminant value for the record, and as -- the case index in the main match routine that branches to the proper -- match code for the given element. --- 102,108 ---- -- I parameter(s) I -- +------------------------------------+ ! -- Pcode is a code value indicating the type of the pattern node. This -- code is used both as the discriminant value for the record, and as -- the case index in the main match routine that branches to the proper -- match code for the given element. *************** package body GNAT.Spitbol.Patterns is *** 114,120 **** -- Pthen is a pointer to the successor node, i.e the node to be matched -- if the attempt to match the node succeeds. If this is the last node -- of the pattern to be matched, then Pthen points to a dummy node ! -- of kind PC_EOP (end of pattern), which initiales pattern exit. -- The parameter or parameters are present for certain node types, -- and the type varies with the pattern code. --- 113,119 ---- -- Pthen is a pointer to the successor node, i.e the node to be matched -- if the attempt to match the node succeeds. If this is the last node -- of the pattern to be matched, then Pthen points to a dummy node ! -- of kind PC_EOP (end of pattern), which initializes pattern exit. -- The parameter or parameters are present for certain node types, -- and the type varies with the pattern code. *************** package body GNAT.Spitbol.Patterns is *** 432,438 **** --------------------------------------------------- -- The serial index numbers for the pattern elements are assigned as ! -- a pattern is consructed from its constituent elements. Note that there -- is never any sharing of pattern elements between patterns (copies are -- always made), so the serial index numbers are unique to a particular -- pattern as referenced from the P field of a value of type Pattern. --- 431,437 ---- --------------------------------------------------- -- The serial index numbers for the pattern elements are assigned as ! -- a pattern is constructed from its constituent elements. Note that there -- is never any sharing of pattern elements between patterns (copies are -- always made), so the serial index numbers are unique to a particular -- pattern as referenced from the P field of a value of type Pattern. *************** package body GNAT.Spitbol.Patterns is *** 450,456 **** -- pattern (e.g. copy and finalization processing). Once constructed -- patterns are strictly read only. This is necessary to allow sharing -- of patterns between tasks. This means that we cannot go marking the ! -- pattern (e.g. with a visited bit). Instead we cosntuct a separate -- vector that contains the necessary information indexed by the Index -- values in the pattern elements. For this purpose the only requirement -- is that they be uniquely assigned. --- 449,455 ---- -- pattern (e.g. copy and finalization processing). Once constructed -- patterns are strictly read only. This is necessary to allow sharing -- of patterns between tasks. This means that we cannot go marking the ! -- pattern (e.g. with a visited bit). Instead we construct a separate -- vector that contains the necessary information indexed by the Index -- values in the pattern elements. For this purpose the only requirement -- is that they be uniquely assigned. *************** package body GNAT.Spitbol.Patterns is *** 470,476 **** -- Third, as compound pattern structures are constructed, the way in which -- constituent parts of the pattern are constructed is stylized. This is ! -- an automatic consequence of the way that these compounjd structures -- are constructed, and basically what we are doing is simply documenting -- and specifying the natural result of the pattern construction. The -- section describing compound pattern structures gives details of the --- 469,475 ---- -- Third, as compound pattern structures are constructed, the way in which -- constituent parts of the pattern are constructed is stylized. This is ! -- an automatic consequence of the way that these compound structures -- are constructed, and basically what we are doing is simply documenting -- and specifying the natural result of the pattern construction. The -- section describing compound pattern structures gives details of the *************** package body GNAT.Spitbol.Patterns is *** 589,595 **** -- stack is used to control the backtracking. Finally, it notes the -- way in which the Index numbers are assigned to the structure. ! -- In all diagrams, solid lines (built witth minus signs or vertical -- bars, represent successor pointers (Pthen fields) with > or V used -- to indicate the direction of the pointer. The initial node of the -- structure is in the upper left of the diagram. A dotted line is an --- 588,594 ---- -- stack is used to control the backtracking. Finally, it notes the -- way in which the Index numbers are assigned to the structure. ! -- In all diagrams, solid lines (built with minus signs or vertical -- bars, represent successor pointers (Pthen fields) with > or V used -- to indicate the direction of the pointer. The initial node of the -- structure is in the upper left of the diagram. A dotted line is an *************** package body GNAT.Spitbol.Patterns is *** 601,607 **** ------------------- -- In the pattern structures listed in this section, a line that looks ! -- lile ----> with nothing to the right indicates an end of pattern -- (EOP) pointer that represents the end of the match. -- When a pattern concatenation (L & R) occurs, the resulting structure --- 600,606 ---- ------------------- -- In the pattern structures listed in this section, a line that looks ! -- like ----> with nothing to the right indicates an end of pattern -- (EOP) pointer that represents the end of the match. -- When a pattern concatenation (L & R) occurs, the resulting structure *************** package body GNAT.Spitbol.Patterns is *** 610,616 **** -- occurs in constructing a pattern, and it means that the pattern -- matching circuitry does not have to keep track of the structure -- of a pattern with respect to concatenation, since the appropriate ! -- succesor is always at hand. -- Concatenation itself generates no additional possibilities for -- backtracking, but the constituent patterns of the concatenated --- 609,615 ---- -- occurs in constructing a pattern, and it means that the pattern -- matching circuitry does not have to keep track of the structure -- of a pattern with respect to concatenation, since the appropriate ! -- successor is always at hand. -- Concatenation itself generates no additional possibilities for -- backtracking, but the constituent patterns of the concatenated *************** package body GNAT.Spitbol.Patterns is *** 644,650 **** -- it stacks a pointer to the leading element of R on the history stack -- so that on subsequent failure, a match of R is attempted. ! -- The A node is the higest numbered element in the pattern. The -- original index numbers of R are unchanged, but the index numbers -- of the L pattern are adjusted up by the count of elements in R. --- 643,649 ---- -- it stacks a pointer to the leading element of R on the history stack -- so that on subsequent failure, a match of R is attempted. ! -- The A node is the highest numbered element in the pattern. The -- original index numbers of R are unchanged, but the index numbers -- of the L pattern are adjusted up by the count of elements in R. *************** package body GNAT.Spitbol.Patterns is *** 942,948 **** -- described below. -- It then stores a pointer to itself in the special entry node field. ! -- This was otherwise unused, and is now used to retrive the address -- of the variable to be assigned at the end of the pattern. -- After that the inner region is terminated in the usual manner, --- 941,947 ---- -- described below. -- It then stores a pointer to itself in the special entry node field. ! -- This was otherwise unused, and is now used to retrieve the address -- of the variable to be assigned at the end of the pattern. -- After that the inner region is terminated in the usual manner, *************** package body GNAT.Spitbol.Patterns is *** 1000,1006 **** -- string, starting at the current cursor position. It then updates -- the cursor past this matched string, and stacks a pointer to itself -- with this updated cursor value on the history stack, to extend the ! -- matched string on a subequent failure. -- Since this is a single node it is numbered 1 (the reason we include -- it in the compound patterns section is that it backtracks). --- 999,1005 ---- -- string, starting at the current cursor position. It then updates -- the cursor past this matched string, and stacks a pointer to itself -- with this updated cursor value on the history stack, to extend the ! -- matched string on a subsequent failure. -- Since this is a single node it is numbered 1 (the reason we include -- it in the compound patterns section is that it backtracks). *************** package body GNAT.Spitbol.Patterns is *** 1175,1181 **** -- The following pattern elements are referenced only from the pattern -- history stack. In each case the processing for the pattern element ! -- results in pattern match abort, or futher failure, so there is no -- need for a successor and no need for a node number CP_Assign : aliased PE := (PC_Assign, 0, N); --- 1174,1180 ---- -- The following pattern elements are referenced only from the pattern -- history stack. In each case the processing for the pattern element ! -- results in pattern match abort, or further failure, so there is no -- need for a successor and no need for a node number CP_Assign : aliased PE := (PC_Assign, 0, N); *************** package body GNAT.Spitbol.Patterns is *** 1209,1219 **** -- understand a typical use of this function). function BreakX_Make (B : PE_Ptr) return Pattern; ! -- Given a pattern element for a Break patternx, returns the -- corresponding BreakX compound pattern structure. function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr; ! -- Creates a pattern eelement that represents a concatenation of the -- two given pattern elements (i.e. the pattern L followed by R). -- The result returned is always the same as L, but the pattern -- referenced by L is modified to have R as a successor. This --- 1208,1218 ---- -- understand a typical use of this function). function BreakX_Make (B : PE_Ptr) return Pattern; ! -- Given a pattern element for a Break pattern, returns the -- corresponding BreakX compound pattern structure. function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr; ! -- Creates a pattern element that represents a concatenation of the -- two given pattern elements (i.e. the pattern L followed by R). -- The result returned is always the same as L, but the pattern -- referenced by L is modified to have R as a successor. This *************** package body GNAT.Spitbol.Patterns is *** 1305,1311 **** Start : out Natural; Stop : out Natural); -- Identical in all respects to XMatch, except that trace information is ! -- output on Standard_Ouput during execution of the match. This is the -- version that is called if the original Match call has Debug => True. --------- --- 1304,1310 ---- Start : out Natural; Stop : out Natural); -- Identical in all respects to XMatch, except that trace information is ! -- output on Standard_Output during execution of the match. This is the -- version that is called if the original Match call has Debug => True. --------- *************** package body GNAT.Spitbol.Patterns is *** 1591,1597 **** return new PE'(PC_Alt, R.Index + 1, EOP, R); -- If the left pattern is non-null, then build a reference vector ! -- for its elements, and adjust their index values to acccomodate -- the right hand elements. Then add the alternation node. else --- 1590,1596 ---- return new PE'(PC_Alt, R.Index + 1, EOP, R); -- If the left pattern is non-null, then build a reference vector ! -- for its elements, and adjust their index values to accommodate -- the right hand elements. Then add the alternation node. else *************** package body GNAT.Spitbol.Patterns is *** 2782,2790 **** procedure Logic_Error is begin ! Raise_Exception ! (Program_Error'Identity, ! "Internal logic error in GNAT.Spitbol.Patterns"); end Logic_Error; ----------- --- 2781,2788 ---- procedure Logic_Error is begin ! raise Program_Error with ! "Internal logic error in GNAT.Spitbol.Patterns"; end Logic_Error; ----------- *************** package body GNAT.Spitbol.Patterns is *** 3644,3652 **** procedure Uninitialized_Pattern is begin ! Raise_Exception ! (Program_Error'Identity, ! "uninitialized value of type GNAT.Spitbol.Patterns.Pattern"); end Uninitialized_Pattern; ------------ --- 3642,3649 ---- procedure Uninitialized_Pattern is begin ! raise Program_Error with ! "uninitialized value of type GNAT.Spitbol.Patterns.Pattern"; end Uninitialized_Pattern; ------------ *************** package body GNAT.Spitbol.Patterns is *** 3710,3723 **** procedure Pop_Region; pragma Inline (Pop_Region); ! -- Used at the end of processing of an inner region. if the inner -- region left no stack entries, then all trace of it is removed. -- Otherwise a PC_Restore_Region entry is pushed to ensure proper -- handling of alternatives in the inner region. procedure Push (Node : PE_Ptr); pragma Inline (Push); ! -- Make entry in pattern matching stack with current cursor valeu procedure Push_Region; pragma Inline (Push_Region); --- 3707,3720 ---- procedure Pop_Region; pragma Inline (Pop_Region); ! -- Used at the end of processing of an inner region. If the inner -- region left no stack entries, then all trace of it is removed. -- Otherwise a PC_Restore_Region entry is pushed to ensure proper -- handling of alternatives in the inner region. procedure Push (Node : PE_Ptr); pragma Inline (Push); ! -- Make entry in pattern matching stack with current cursor value procedure Push_Region; pragma Inline (Push_Region); *************** package body GNAT.Spitbol.Patterns is *** 5025,5038 **** procedure Pop_Region; pragma Inline (Pop_Region); ! -- Used at the end of processing of an inner region. if the inner -- region left no stack entries, then all trace of it is removed. -- Otherwise a PC_Restore_Region entry is pushed to ensure proper -- handling of alternatives in the inner region. procedure Push (Node : PE_Ptr); pragma Inline (Push); ! -- Make entry in pattern matching stack with current cursor valeu procedure Push_Region; pragma Inline (Push_Region); --- 5022,5035 ---- procedure Pop_Region; pragma Inline (Pop_Region); ! -- Used at the end of processing of an inner region. If the inner -- region left no stack entries, then all trace of it is removed. -- Otherwise a PC_Restore_Region entry is pushed to ensure proper -- handling of alternatives in the inner region. procedure Push (Node : PE_Ptr); pragma Inline (Push); ! -- Make entry in pattern matching stack with current cursor value procedure Push_Region; pragma Inline (Push_Region); diff -Nrcpad gcc-4.3.3/gcc/ada/g-spipat.ads gcc-4.4.0/gcc/ada/g-spipat.ads *** gcc-4.3.3/gcc/ada/g-spipat.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/g-spipat.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2006, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2008, AdaCore -- -- -- -- 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- -- *************** *** 41,47 **** -- Summary of Pattern Matching Packages in GNAT Hierarchy -- ------------------------------------------------------------ ! -- There are three related packages that perform pattern maching functions. -- the following is an outline of these packages, to help you determine -- which is best for your needs. --- 41,47 ---- -- Summary of Pattern Matching Packages in GNAT Hierarchy -- ------------------------------------------------------------ ! -- There are three related packages that perform pattern matching functions. -- the following is an outline of these packages, to help you determine -- which is best for your needs. *************** package GNAT.Spitbol.Patterns is *** 154,160 **** -- ("ABC" or "AB") & ("DEF" or "CDE") & ("GH" or "IJ") ! -- would succeed, afer two anchor point moves: -- "ABABCDEIJKL" -- ^^^^^^^ --- 154,160 ---- -- ("ABC" or "AB") & ("DEF" or "CDE") & ("GH" or "IJ") ! -- would succeed, after two anchor point moves: -- "ABABCDEIJKL" -- ^^^^^^^ *************** package GNAT.Spitbol.Patterns is *** 226,232 **** -- of the pattern, starting with zero occurrences. It is -- thus equivalent to ("" or (P & ("" or (P & ("" ....)))). -- The pattern P may contain any number of pattern elements ! -- including the use of alternatiion and concatenation. -- Break(S) Where S is a string, matches a string of zero or more -- characters up to but not including a break character --- 226,232 ---- -- of the pattern, starting with zero occurrences. It is -- thus equivalent to ("" or (P & ("" or (P & ("" ....)))). -- The pattern P may contain any number of pattern elements ! -- including the use of alternation and concatenation. -- Break(S) Where S is a string, matches a string of zero or more -- characters up to but not including a break character *************** package GNAT.Spitbol.Patterns is *** 237,243 **** -- BreakX(S) Where S is a string, behaves exactly like Break(S) when -- it first matches, but if a string is successfully matched, ! -- then a susequent failure causes an attempt to extend the -- matched string. -- Fence(P) Where P is a pattern, attempts to match the pattern P --- 237,243 ---- -- BreakX(S) Where S is a string, behaves exactly like Break(S) when -- it first matches, but if a string is successfully matched, ! -- then a subsequent failure causes an attempt to extend the -- matched string. -- Fence(P) Where P is a pattern, attempts to match the pattern P *************** package GNAT.Spitbol.Patterns is *** 247,253 **** -- match proceeds, but on a subsequent failure, no attempt -- is made to search for alternative matches of P. The -- pattern P may contain any number of pattern elements ! -- including the use of alternatiion and concatenation. -- Len(N) Where N is a natural number, matches the given number of -- characters. For example, Len(10) matches any string that --- 247,253 ---- -- match proceeds, but on a subsequent failure, no attempt -- is made to search for alternative matches of P. The -- pattern P may contain any number of pattern elements ! -- including the use of alternation and concatenation. -- Len(N) Where N is a natural number, matches the given number of -- characters. For example, Len(10) matches any string that *************** package GNAT.Spitbol.Patterns is *** 255,261 **** -- NotAny(S) Where S is a string, matches a single character that is -- not one of the characters of S. Fails if the current ! -- characer is one of the given set of characters. -- NSpan(S) Where S is a string, matches a string of zero or more -- characters that is among the characters given in the --- 255,261 ---- -- NotAny(S) Where S is a string, matches a single character that is -- not one of the characters of S. Fails if the current ! -- character is one of the given set of characters. -- NSpan(S) Where S is a string, matches a string of zero or more -- characters that is among the characters given in the *************** package GNAT.Spitbol.Patterns is *** 690,698 **** -- if the language allowed, we would use in out parameters, but we are -- not allowed to have in out parameters for functions. Instead we pass -- actuals which must be variables, and with a bit of trickery in the ! -- body, manage to interprete them properly as though they were indeed -- in out parameters. -------------------------------- -- Basic Pattern Construction -- -------------------------------- --- 690,704 ---- -- if the language allowed, we would use in out parameters, but we are -- not allowed to have in out parameters for functions. Instead we pass -- actuals which must be variables, and with a bit of trickery in the ! -- body, manage to interpret them properly as though they were indeed -- in out parameters. + pragma Warnings (Off, VString_Var); + pragma Warnings (Off, Pattern_Var); + -- We turn off warnings for these two types so that when variables are used + -- as arguments in this context, warnings about them not being assigned in + -- the source program will be suppressed. + -------------------------------- -- Basic Pattern Construction -- -------------------------------- *************** package GNAT.Spitbol.Patterns is *** 826,832 **** -- causes the entire match to be aborted if a subsequent failure occurs. function Fence (P : Pattern) return Pattern; ! -- Constructs a pattern that first matches P. if P fails, then the -- constructed pattern fails. If P succeeds, then the match proceeds, -- but if subsequent failure occurs, alternatives in P are not sought. -- The idea of Fence is that each time the pattern is matched, just --- 832,838 ---- -- causes the entire match to be aborted if a subsequent failure occurs. function Fence (P : Pattern) return Pattern; ! -- Constructs a pattern that first matches P. If P fails, then the -- constructed pattern fails. If P succeeds, then the match proceeds, -- but if subsequent failure occurs, alternatives in P are not sought. -- The idea of Fence is that each time the pattern is matched, just *************** package GNAT.Spitbol.Patterns is *** 1048,1054 **** -- if the language allowed, we would use an in out parameter, but we are -- not allowed to have in out parameters for functions. Instead we pass -- actuals which must be variables, and with a bit of trickery in the ! -- body, manage to interprete them properly as though they were indeed -- in out parameters. function Match --- 1054,1060 ---- -- if the language allowed, we would use an in out parameter, but we are -- not allowed to have in out parameters for functions. Instead we pass -- actuals which must be variables, and with a bit of trickery in the ! -- body, manage to interpret them properly as though they were indeed -- in out parameters. function Match *************** package GNAT.Spitbol.Patterns is *** 1136,1143 **** private type PE; ! -- Pattern element, a pattern is a plex structure of PE's. This type ! -- is defined and sdescribed in the body of this package. type PE_Ptr is access all PE; -- Pattern reference. PE's use PE_Ptr values to reference other PE's --- 1142,1149 ---- private type PE; ! -- Pattern element, a pattern is a complex structure of PE's. This type ! -- is defined and described in the body of this package. type PE_Ptr is access all PE; -- Pattern reference. PE's use PE_Ptr values to reference other PE's diff -Nrcpad gcc-4.3.3/gcc/ada/g-stheme.adb gcc-4.4.0/gcc/ada/g-stheme.adb *** gcc-4.3.3/gcc/ada/g-stheme.adb Wed Jun 6 10:13:25 2007 --- gcc-4.4.0/gcc/ada/g-stheme.adb Wed Aug 20 12:07:45 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007-2008, AdaCore -- -- -- -- 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- -- *************** package body Host_Error_Messages is *** 51,72 **** use Interfaces.C.Strings; function TCP (P : char_array_access; Nul_Check : Boolean := False) return chars_ptr ! renames To_Chars_Ptr; begin case H_Errno is ! when Constants.HOST_NOT_FOUND => return TCP (Messages.HOST_NOT_FOUND'Access); ! when Constants.TRY_AGAIN => return TCP (Messages.TRY_AGAIN'Access); ! when Constants.NO_RECOVERY => return TCP (Messages.NO_RECOVERY'Access); ! when Constants.NO_DATA => return TCP (Messages.NO_DATA'Access); ! when others => return TCP (Messages.Unknown_Error'Access); end case; --- 51,73 ---- use Interfaces.C.Strings; function TCP (P : char_array_access; Nul_Check : Boolean := False) return chars_ptr ! renames To_Chars_Ptr; ! begin case H_Errno is ! when SOSC.HOST_NOT_FOUND => return TCP (Messages.HOST_NOT_FOUND'Access); ! when SOSC.TRY_AGAIN => return TCP (Messages.TRY_AGAIN'Access); ! when SOSC.NO_RECOVERY => return TCP (Messages.NO_RECOVERY'Access); ! when SOSC.NO_DATA => return TCP (Messages.NO_DATA'Access); ! when others => return TCP (Messages.Unknown_Error'Access); end case; diff -Nrcpad gcc-4.3.3/gcc/ada/g-string.adb gcc-4.4.0/gcc/ada/g-string.adb *** gcc-4.3.3/gcc/ada/g-string.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/g-string.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 33,38 **** -- This package does not require a body, since it is a package renaming. We -- provide a dummy file containing a No_Body pragma so that previous versions ! -- of the body (which did exist) will not intefere. pragma No_Body; --- 31,36 ---- -- This package does not require a body, since it is a package renaming. We -- provide a dummy file containing a No_Body pragma so that previous versions ! -- of the body (which did exist) will not interfere. pragma No_Body; diff -Nrcpad gcc-4.3.3/gcc/ada/g-string.ads gcc-4.4.0/gcc/ada/g-string.ads *** gcc-4.3.3/gcc/ada/g-string.ads Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/g-string.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-strspl.ads gcc-4.4.0/gcc/ada/g-strspl.ads *** gcc-4.3.3/gcc/ada/g-strspl.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/g-strspl.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2003 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-stsifd-sockets.adb gcc-4.4.0/gcc/ada/g-stsifd-sockets.adb *** gcc-4.3.3/gcc/ada/g-stsifd-sockets.adb Mon Jun 11 06:41:43 2007 --- gcc-4.4.0/gcc/ada/g-stsifd-sockets.adb Tue Aug 12 05:42:28 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** package body Signalling_Fds is *** 82,88 **** -- Create a listening socket ! L_Sock := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0); if L_Sock = Failure then goto Fail; --- 82,88 ---- -- Create a listening socket ! L_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0); if L_Sock = Failure then goto Fail; *************** package body Signalling_Fds is *** 90,104 **** -- Bind the socket to an available port on localhost ! Len := Sin'Size / 8; ! Set_Length (Sin'Unchecked_Access, Len); ! Sin.Sin_Family := Constants.AF_INET; Sin.Sin_Addr.S_B1 := 127; Sin.Sin_Addr.S_B2 := 0; Sin.Sin_Addr.S_B3 := 0; Sin.Sin_Addr.S_B4 := 1; Sin.Sin_Port := 0; Res := C_Bind (L_Sock, Sin'Address, Len); if Res = Failure then --- 90,103 ---- -- Bind the socket to an available port on localhost ! Set_Family (Sin.Sin_Family, Family_Inet); Sin.Sin_Addr.S_B1 := 127; Sin.Sin_Addr.S_B2 := 0; Sin.Sin_Addr.S_B3 := 0; Sin.Sin_Addr.S_B4 := 1; Sin.Sin_Port := 0; + Len := C.int (Lengths (Family_Inet)); Res := C_Bind (L_Sock, Sin'Address, Len); if Res = Failure then *************** package body Signalling_Fds is *** 123,129 **** -- Create read end (client) socket ! R_Sock := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0); if R_Sock = Failure then goto Fail; --- 122,128 ---- -- Create read end (client) socket ! R_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0); if R_Sock = Failure then goto Fail; *************** package body Signalling_Fds is *** 135,141 **** exit when Res /= Failure; ! if Socket_Errno /= Constants.EADDRINUSE then goto Fail; end if; --- 134,140 ---- exit when Res /= Failure; ! if Socket_Errno /= SOSC.EADDRINUSE then goto Fail; end if; *************** package body Signalling_Fds is *** 143,149 **** -- marked "in use", even though it has been closed (perhaps by some -- other process that has already exited). This causes the above -- C_Connect to fail with EADDRINUSE. In this case, we close the ! -- ports, and loop back to try again. This mysterious windows -- behavior is documented. See, for example: -- http://msdn2.microsoft.com/en-us/library/ms737625.aspx -- In an experiment with 2000 calls, 21 required exactly one retry, 7 --- 142,148 ---- -- marked "in use", even though it has been closed (perhaps by some -- other process that has already exited). This causes the above -- C_Connect to fail with EADDRINUSE. In this case, we close the ! -- ports, and loop back to try again. This mysterious Windows -- behavior is documented. See, for example: -- http://msdn2.microsoft.com/en-us/library/ms737625.aspx -- In an experiment with 2000 calls, 21 required exactly one retry, 7 *************** package body Signalling_Fds is *** 153,159 **** pragma Assert (Res = Failure and then ! Socket_Errno = Constants.EADDRINUSE); pragma Warnings (Off); -- useless assignment to "Res" Res := C_Close (W_Sock); pragma Warnings (On); --- 152,158 ---- pragma Assert (Res = Failure and then ! Socket_Errno = SOSC.EADDRINUSE); pragma Warnings (Off); -- useless assignment to "Res" Res := C_Close (W_Sock); pragma Warnings (On); *************** package body Signalling_Fds is *** 162,168 **** R_Sock := Failure; end loop; ! -- Since the call to connect(2) has suceeded and the backlog limit on -- the listening socket is 1, we know that there is now exactly one -- pending connection on L_Sock, which is the one from R_Sock. --- 161,167 ---- R_Sock := Failure; end loop; ! -- Since the call to connect(2) has succeeded and the backlog limit on -- the listening socket is 1, we know that there is now exactly one -- pending connection on L_Sock, which is the one from R_Sock. *************** package body Signalling_Fds is *** 186,192 **** Fds.all := (Read_End => R_Sock, Write_End => W_Sock); ! return Success; <> declare --- 185,191 ---- Fds.all := (Read_End => R_Sock, Write_End => W_Sock); ! return Thin_Common.Success; <> declare *************** package body Signalling_Fds is *** 218,224 **** function Read (Rsig : C.int) return C.int is Buf : aliased Character; begin ! return C_Recv (Rsig, Buf'Address, 1, Constants.MSG_Forced_Flags); end Read; ----------- --- 217,223 ---- function Read (Rsig : C.int) return C.int is Buf : aliased Character; begin ! return C_Recv (Rsig, Buf'Address, 1, SOSC.MSG_Forced_Flags); end Read; ----------- *************** package body Signalling_Fds is *** 228,234 **** function Write (Wsig : C.int) return C.int is Buf : aliased Character := ASCII.NUL; begin ! return C_Send (Wsig, Buf'Address, 1, Constants.MSG_Forced_Flags); end Write; end Signalling_Fds; --- 227,233 ---- function Write (Wsig : C.int) return C.int is Buf : aliased Character := ASCII.NUL; begin ! return C_Send (Wsig, Buf'Address, 1, SOSC.MSG_Forced_Flags); end Write; end Signalling_Fds; diff -Nrcpad gcc-4.3.3/gcc/ada/g-sttsne-dummy.ads gcc-4.4.0/gcc/ada/g-sttsne-dummy.ads *** gcc-4.3.3/gcc/ada/g-sttsne-dummy.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-sttsne-dummy.ads Fri Feb 20 15:20:38 2009 *************** *** 0 **** --- 1,39 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . T H I N . T A S K _ S A F E _ N E T D B -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2007-2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package is a placeholder for the sockets binding for platforms where + -- it is not implemented. + + package GNAT.Sockets.Thin.Task_Safe_NetDB is + pragma Unimplemented_Unit; + end GNAT.Sockets.Thin.Task_Safe_NetDB; diff -Nrcpad gcc-4.3.3/gcc/ada/g-sttsne-vxworks.adb gcc-4.4.0/gcc/ada/g-sttsne-vxworks.adb *** gcc-4.3.3/gcc/ada/g-sttsne-vxworks.adb Tue Aug 14 08:50:51 2007 --- gcc-4.4.0/gcc/ada/g-sttsne-vxworks.adb Fri Aug 8 12:59:28 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007-2008, AdaCore -- -- -- -- 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- -- *************** *** 34,39 **** --- 34,40 ---- -- This version is used on VxWorks. Note that the corresponding spec is in -- g-sttsne-locking.ads. + with Ada.Unchecked_Conversion; with Interfaces.C; use Interfaces.C; package body GNAT.Sockets.Thin.Task_Safe_NetDB is *************** package body GNAT.Sockets.Thin.Task_Safe *** 80,86 **** -- VxWorks does not provide h_errno begin ! pragma Assert (Addr_Type = Constants.AF_INET); pragma Assert (Addr_Len = In_Addr'Size / 8); -- Check that provided buffer is sufficiently large to hold the --- 81,87 ---- -- VxWorks does not provide h_errno begin ! pragma Assert (Addr_Type = SOSC.AF_INET); pragma Assert (Addr_Len = In_Addr'Size / 8); -- Check that provided buffer is sufficiently large to hold the *************** package body GNAT.Sockets.Thin.Task_Safe *** 92,98 **** if VxWorks_hostGetByAddr (To_Pointer (Addr).all, Netdb_Data.Name'Address) ! /= Constants.OK then return -1; end if; --- 93,99 ---- if VxWorks_hostGetByAddr (To_Pointer (Addr).all, Netdb_Data.Name'Address) ! /= SOSC.OK then return -1; end if; *************** package body GNAT.Sockets.Thin.Task_Safe *** 105,111 **** Ret.H_Name := C.Strings.To_Chars_Ptr (Netdb_Data.Name'Unrestricted_Access); Ret.H_Aliases := Alias_Access; ! Ret.H_Addrtype := Constants.AF_INET; Ret.H_Length := 4; Ret.H_Addr_List := Netdb_Data.Addr_List (Netdb_Data.Addr_List'First)'Unchecked_Access; --- 106,112 ---- Ret.H_Name := C.Strings.To_Chars_Ptr (Netdb_Data.Name'Unrestricted_Access); Ret.H_Aliases := Alias_Access; ! Ret.H_Addrtype := SOSC.AF_INET; Ret.H_Length := 4; Ret.H_Addr_List := Netdb_Data.Addr_List (Netdb_Data.Addr_List'First)'Unchecked_Access; *************** package body GNAT.Sockets.Thin.Task_Safe *** 134,140 **** begin Addr := VxWorks_hostGetByName (Name); ! if Addr = Constants.ERROR then return -1; end if; --- 135,141 ---- begin Addr := VxWorks_hostGetByName (Name); ! if Addr = SOSC.ERROR then return -1; end if; *************** package body GNAT.Sockets.Thin.Task_Safe *** 160,166 **** Ret.H_Name := C.Strings.To_Chars_Ptr (Netdb_Data.Name'Unrestricted_Access); Ret.H_Aliases := Alias_Access; ! Ret.H_Addrtype := Constants.AF_INET; Ret.H_Length := 4; Ret.H_Addr_List := Netdb_Data.Addr_List (Netdb_Data.Addr_List'First)'Unchecked_Access; --- 161,167 ---- Ret.H_Name := C.Strings.To_Chars_Ptr (Netdb_Data.Name'Unrestricted_Access); Ret.H_Aliases := Alias_Access; ! Ret.H_Addrtype := SOSC.AF_INET; Ret.H_Length := 4; Ret.H_Addr_List := Netdb_Data.Addr_List (Netdb_Data.Addr_List'First)'Unchecked_Access; diff -Nrcpad gcc-4.3.3/gcc/ada/g-table.adb gcc-4.4.0/gcc/ada/g-table.adb *** gcc-4.3.3/gcc/ada/g-table.adb Thu Aug 16 12:19:02 2007 --- gcc-4.4.0/gcc/ada/g-table.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Table is *** 256,262 **** -- current allocation). Range checks are suppressed because this unit -- uses direct calls to System.Memory for allocation, and this can -- yield misaligned storage (and we cannot rely on the bootstrap ! -- compiler supporting specifically disabling alignment cheks, so we -- need to suppress all range checks). It is safe to suppress this check -- here because we know that a (possibly misaligned) object of that type -- does actually exist at that address. --- 256,262 ---- -- current allocation). Range checks are suppressed because this unit -- uses direct calls to System.Memory for allocation, and this can -- yield misaligned storage (and we cannot rely on the bootstrap ! -- compiler supporting specifically disabling alignment checks, so we -- need to suppress all range checks). It is safe to suppress this check -- here because we know that a (possibly misaligned) object of that type -- does actually exist at that address. *************** package body GNAT.Table is *** 268,274 **** -- involve moving table contents around). begin ! -- If we're going to reallocate, check wheter Item references an -- element of the currently allocated table. if Need_Realloc --- 268,274 ---- -- involve moving table contents around). begin ! -- If we're going to reallocate, check whether Item references an -- element of the currently allocated table. if Need_Realloc diff -Nrcpad gcc-4.3.3/gcc/ada/g-table.ads gcc-4.4.0/gcc/ada/g-table.ads *** gcc-4.3.3/gcc/ada/g-table.ads Tue Aug 14 09:05:23 2007 --- gcc-4.4.0/gcc/ada/g-table.ads Tue Apr 8 06:48:30 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2008, AdaCore -- -- -- -- 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- -- *************** package GNAT.Table is *** 105,121 **** type Table_Type is array (Table_Index_Type range <>) of Table_Component_Type; - subtype Big_Table_Type is Table_Type (Table_Low_Bound .. Table_Index_Type'Last); -- We work with pointers to a bogus array type that is constrained -- with the maximum possible range bound. This means that the pointer -- is a thin pointer, which is more efficient. Since subscript checks -- in any case must be on the logical, rather than physical bounds, ! -- safety is not compromised by this approach. type Table_Ptr is access all Big_Table_Type; ! -- The table is actually represented as a pointer to allow reallocation Table : aliased Table_Ptr := null; -- The table itself. The lower bound is the value of Low_Bound. --- 105,123 ---- type Table_Type is array (Table_Index_Type range <>) of Table_Component_Type; subtype Big_Table_Type is Table_Type (Table_Low_Bound .. Table_Index_Type'Last); -- We work with pointers to a bogus array type that is constrained -- with the maximum possible range bound. This means that the pointer -- is a thin pointer, which is more efficient. Since subscript checks -- in any case must be on the logical, rather than physical bounds, ! -- safety is not compromised by this approach. These types should never ! -- be used by the client. type Table_Ptr is access all Big_Table_Type; ! for Table_Ptr'Storage_Size use 0; ! -- The table is actually represented as a pointer to allow reallocation. ! -- This type should never be used by the client. Table : aliased Table_Ptr := null; -- The table itself. The lower bound is the value of Low_Bound. diff -Nrcpad gcc-4.3.3/gcc/ada/g-tasloc.adb gcc-4.4.0/gcc/ada/g-tasloc.adb *** gcc-4.3.3/gcc/ada/g-tasloc.adb Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/g-tasloc.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2008, AdaCore -- -- -- -- 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- -- *************** *** 33,38 **** -- This package does not require a body, since it is a package renaming. We -- provide a dummy file containing a No_Body pragma so that previous versions ! -- of the body (which did exist) will not intefere. pragma No_Body; --- 33,38 ---- -- This package does not require a body, since it is a package renaming. We -- provide a dummy file containing a No_Body pragma so that previous versions ! -- of the body (which did exist) will not interfere. pragma No_Body; diff -Nrcpad gcc-4.3.3/gcc/ada/g-timsta.adb gcc-4.4.0/gcc/ada/g-timsta.adb *** gcc-4.3.3/gcc/ada/g-timsta.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-timsta.adb Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,59 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- G N A T . T I M E _ S T A M P -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2008-2009 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + with Interfaces.C; use Interfaces.C; + + package body GNAT.Time_Stamp is + + subtype time_stamp is char_array (0 .. 22); + type time_stamp_ptr is access all time_stamp; + -- The desired ISO 8601 string format has exactly 22 characters. We add + -- one additional character for '\0'. The indexing starts from zero to + -- accommodate the C layout. + + procedure gnat_current_time_string (Value : time_stamp_ptr); + pragma Import (C, gnat_current_time_string, "__gnat_current_time_string"); + + ------------------ + -- Current_Time -- + ------------------ + + function Current_Time return String is + Result : aliased time_stamp; + + begin + gnat_current_time_string (Result'Unchecked_Access); + Result (22) := nul; + + return To_Ada (Result); + end Current_Time; + + end GNAT.Time_Stamp; diff -Nrcpad gcc-4.3.3/gcc/ada/g-timsta.ads gcc-4.4.0/gcc/ada/g-timsta.ads *** gcc-4.3.3/gcc/ada/g-timsta.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/g-timsta.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,40 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- G N A T . T I M E _ S T A M P -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2008-2009 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides a lightweight mechanism for obtaining time stamps + + package GNAT.Time_Stamp is + + function Current_Time return String; + -- Return the current local time in the following ISO 8601 string format: + -- YYYY-MM-DD HH:MM:SS.SS + + end GNAT.Time_Stamp; diff -Nrcpad gcc-4.3.3/gcc/ada/g-traceb.ads gcc-4.4.0/gcc/ada/g-traceb.ads *** gcc-4.3.3/gcc/ada/g-traceb.ads Wed Jun 6 10:31:28 2007 --- gcc-4.4.0/gcc/ada/g-traceb.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- 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,49 **** -- using the external addr2line utility, or from within GDB. -- In order to use this facility, in some cases the binder must be invoked ! -- with -E switch (store the backtrace with exception occurence). Please -- refer to gnatbind documentation for more information. -- To analyze the code locations later using addr2line or gdb, the necessary --- 43,49 ---- -- using the external addr2line utility, or from within GDB. -- In order to use this facility, in some cases the binder must be invoked ! -- with -E switch (store the backtrace with exception occurrence). Please -- refer to gnatbind documentation for more information. -- To analyze the code locations later using addr2line or gdb, the necessary diff -Nrcpad gcc-4.3.3/gcc/ada/g-trasym-vms-alpha.adb gcc-4.4.0/gcc/ada/g-trasym-vms-alpha.adb *** gcc-4.3.3/gcc/ada/g-trasym-vms-alpha.adb Thu Dec 13 10:36:42 2007 --- gcc-4.4.0/gcc/ada/g-trasym-vms-alpha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-trasym-vms-ia64.adb gcc-4.4.0/gcc/ada/g-trasym-vms-ia64.adb *** gcc-4.3.3/gcc/ada/g-trasym-vms-ia64.adb Tue Aug 14 08:50:30 2007 --- gcc-4.4.0/gcc/ada/g-trasym-vms-ia64.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-trasym.adb gcc-4.4.0/gcc/ada/g-trasym.adb *** gcc-4.3.3/gcc/ada/g-trasym.adb Fri Apr 6 09:15:36 2007 --- gcc-4.4.0/gcc/ada/g-trasym.adb Fri Aug 22 15:47:50 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2006, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- 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- -- *************** package body GNAT.Traceback.Symbolic is *** 102,108 **** -- The symbolic translation of an empty set of addresses is the -- the empty string. ! if Traceback'Length <= 0 then return ""; end if; --- 102,108 ---- -- The symbolic translation of an empty set of addresses is the -- the empty string. ! if Traceback'Length = 0 then return ""; end if; *************** package body GNAT.Traceback.Symbolic is *** 114,120 **** -- be found. If the executable file name resolution fails, we have no -- sensible basis to invoke the symbolizer at all. ! -- Protect all this against concurrent accesses explicitely, as the -- underlying services are potentially thread unsafe. TSL.Lock_Task.all; --- 114,120 ---- -- be found. If the executable file name resolution fails, we have no -- sensible basis to invoke the symbolizer at all. ! -- Protect all this against concurrent accesses explicitly, as the -- underlying services are potentially thread unsafe. TSL.Lock_Task.all; diff -Nrcpad gcc-4.3.3/gcc/ada/g-trasym.ads gcc-4.4.0/gcc/ada/g-trasym.ads *** gcc-4.3.3/gcc/ada/g-trasym.ads Tue Aug 14 08:50:51 2007 --- gcc-4.4.0/gcc/ada/g-trasym.ads Tue Apr 8 06:57:39 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- 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- -- *************** with Ada.Exceptions; use Ada.Exceptions; *** 84,95 **** package GNAT.Traceback.Symbolic is pragma Elaborate_Body; - ------------------------ - -- Symbolic_Traceback -- - ------------------------ - function Symbolic_Traceback (Traceback : Tracebacks_Array) return String; -- Build a string containing a symbolic traceback of the given call chain function Symbolic_Traceback (E : Exception_Occurrence) return String; -- Build string containing symbolic traceback of given exception occurrence --- 84,94 ---- package GNAT.Traceback.Symbolic is pragma Elaborate_Body; function Symbolic_Traceback (Traceback : Tracebacks_Array) return String; -- Build a string containing a symbolic traceback of the given call chain + -- + -- Note: This procedure may be installed by Set_Trace_Decorator, to get a + -- symbolic traceback on all exceptions raised (see GNAT.Exception_Traces). function Symbolic_Traceback (E : Exception_Occurrence) return String; -- Build string containing symbolic traceback of given exception occurrence diff -Nrcpad gcc-4.3.3/gcc/ada/g-utf_32.adb gcc-4.4.0/gcc/ada/g-utf_32.adb *** gcc-4.3.3/gcc/ada/g-utf_32.adb Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/g-utf_32.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 33,38 **** -- This package does not require a body, since it is a package renaming. We -- provide a dummy file containing a No_Body pragma so that previous versions ! -- of the body (which did exist) will not intefere. pragma No_Body; --- 31,36 ---- -- This package does not require a body, since it is a package renaming. We -- provide a dummy file containing a No_Body pragma so that previous versions ! -- of the body (which did exist) will not interfere. pragma No_Body; diff -Nrcpad gcc-4.3.3/gcc/ada/g-utf_32.ads gcc-4.4.0/gcc/ada/g-utf_32.ads *** gcc-4.3.3/gcc/ada/g-utf_32.ads Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/g-utf_32.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-wistsp.ads gcc-4.4.0/gcc/ada/g-wistsp.ads *** gcc-4.3.3/gcc/ada/g-wistsp.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/g-wistsp.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2003 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/g-zstspl.ads gcc-4.4.0/gcc/ada/g-zstspl.ads *** gcc-4.3.3/gcc/ada/g-zstspl.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/g-zstspl.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/Make-lang.in gcc-4.4.0/gcc/ada/gcc-interface/Make-lang.in *** gcc-4.3.3/gcc/ada/gcc-interface/Make-lang.in Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/Make-lang.in Fri Dec 5 08:01:58 2008 *************** *** 0 **** --- 1,4357 ---- + # Top level -*- makefile -*- fragment for GNU Ada (GNAT). + # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, + # 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + + #This file is part of GCC. + + #GCC is free software; you can redistribute it and/or modify + #it under the terms of the GNU General Public License as published by + #the Free Software Foundation; either version 3, or (at your option) + #any later version. + + #GCC is distributed in the hope that it will be useful, + #but WITHOUT ANY WARRANTY; without even the implied warranty of + #MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + #GNU General Public License for more details. + + #You should have received a copy of the GNU General Public License + #along with GCC; see the file COPYING3. If not see + #. + + # This file provides the language dependent support in the main Makefile. + # Each language makefile fragment must provide the following targets: + # + # foo.all.cross, foo.start.encap, foo.rest.encap, + # foo.install-common, foo.install-man, foo.install-info, foo.install-pdf, + # foo.info, foo.dvi, foo.pdf, foo.html, foo.uninstall, + # foo.mostlyclean, foo.clean, foo.distclean, + # foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4 + # + # where `foo' is the name of the language. + # + # It should also provide rules for: + # + # - making any compiler driver (eg: g++) + # - the compiler proper (eg: cc1plus) + # - define the names for selecting the language in LANGUAGES. + # tool definitions + CP = cp -p + ECHO = echo + MV = mv + MKDIR = mkdir -p + RM = rm -f + RMDIR = rm -rf + + + # Extra flags to pass to recursive makes. + COMMON_ADAFLAGS= -gnatpg -gnata + BOOT_ADAFLAGS= $(COMMON_ADAFLAGS) + + ifeq ($(CROSS),) + # If not in cross context we are probably doing a bootstrap + # so disable warnings during stage1 + ADAFLAGS= $(COMMON_ADAFLAGS) -gnatwns + else + ADAFLAGS= $(COMMON_ADAFLAGS) + endif + + ALL_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) + FORCE_DEBUG_ADAFLAGS = -g + ADA_CFLAGS = + ADA_INCLUDES = -nostdinc -I- -I. -Iada -I$(srcdir)/ada -I$(srcdir)/ada/gcc-interface + ADA_INCLUDE_DIR = $(libsubdir)/adainclude + ADA_RTL_OBJ_DIR = $(libsubdir)/adalib + ADA_FLAGS_TO_PASS = \ + "ADA_FOR_BUILD=$(ADA_FOR_BUILD)" \ + "ADA_INCLUDE_DIR=$(ADA_INCLUDE_DIR)" \ + "ADA_RTL_OBJ_DIR=$(ADA_RTL_OBJ_DIR)" \ + "ADAFLAGS=$(ADAFLAGS)" \ + "ADA_FOR_TARGET=$(ADA_FOR_TARGET)" \ + "INSTALL=$(INSTALL)" \ + "INSTALL_DATA=$(INSTALL_DATA)" \ + "INSTALL_PROGRAM=$(INSTALL_PROGRAM)" + + # Say how to compile Ada programs. + .SUFFIXES: .ada .adb .ads + + # FIXME: need to add $(ADA_CFLAGS) to .c.o suffix rule + # Use loose warnings for this front end, but add some special flags + ada-warn = $(ADA_CFLAGS) $(WERROR) + # unresolved warnings in a couple of files + ada/tracebak.o-warn = -Wno-error + ada/b_gnat1.o-warn = -Wno-error + ada/b_gnatb.o-warn = -Wno-error + + .adb.o: + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + .ads.o: + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + + # Define the names for selecting Ada in LANGUAGES. + ada: gnat1$(exeext) gnatbind$(exeext) + + # Tell GNU Make to ignore these, if they exist. + .PHONY: ada + + # There are too many Ada sources to check against here. Let's + # always force the recursive make. + ADA_TOOLS_FLAGS_TO_PASS=\ + "CC=../../xgcc -B../../" \ + "CFLAGS=$(CFLAGS)" \ + "exeext=$(exeext)" \ + "ADAFLAGS=$(ADAFLAGS)" \ + "ADA_INCLUDES=-I../rts" \ + "GNATMAKE=../../gnatmake" \ + "GNATLINK=../../gnatlink" \ + "GNATBIND=../../gnatbind" + + GCC_LINK=$(CC) -static-libgcc $(LDFLAGS) + + # Lists of files for various purposes. + + # Languages-specific object files for Ada. + # Object files for gnat1 from C sources. + GNAT1_C_OBJS = ada/b_gnat1.o ada/adadecode.o ada/adaint.o ada/cstreams.o \ + ada/cio.o ada/targtyps.o ada/decl.o ada/misc.o ada/utils.o ada/utils2.o \ + ada/trans.o ada/cuintp.o ada/argv.o ada/raise.o ada/init.o ada/tracebak.o \ + ada/initialize.o ada/env.o + + # Object files from Ada sources that are used by gnat1 + + GNAT_ADA_OBJS = ada/ada.o ada/a-charac.o ada/a-chlat1.o ada/a-except.o \ + ada/a-elchha.o ada/a-ioexce.o \ + ada/s-memory.o ada/s-carun8.o ada/s-casuti.o ada/s-strcom.o ada/s-purexc.o \ + ada/s-htable.o ada/s-traceb.o ada/s-mastop.o ada/ali.o \ + ada/alloc.o ada/atree.o ada/butil.o ada/casing.o ada/checks.o ada/comperr.o \ + ada/csets.o ada/cstand.o ada/debug.o ada/debug_a.o ada/einfo.o ada/elists.o \ + ada/errout.o ada/erroutc.o ada/err_vars.o ada/eval_fat.o ada/exp_attr.o \ + ada/exp_ch11.o ada/exp_ch12.o ada/exp_ch13.o ada/exp_ch2.o ada/exp_ch3.o \ + ada/exp_ch4.o ada/exp_ch5.o ada/exp_ch6.o ada/exp_ch7.o ada/exp_ch8.o \ + ada/exp_ch9.o ada/exp_code.o ada/exp_dbug.o ada/exp_disp.o ada/exp_atag.o \ + ada/exp_dist.o ada/exp_fixd.o ada/exp_aggr.o ada/exp_imgv.o ada/exp_intr.o \ + ada/exp_pakd.o ada/exp_prag.o ada/exp_sel.o ada/exp_smem.o ada/exp_strm.o \ + ada/exp_tss.o ada/exp_util.o ada/exp_vfpt.o ada/expander.o ada/fname.o \ + ada/fname-uf.o ada/fmap.o ada/freeze.o ada/frontend.o ada/gnat.o \ + ada/g-byorma.o \ + ada/g-hesora.o ada/g-htable.o ada/s-os_lib.o \ + ada/g-speche.o ada/g-spchge.o ada/g-u3spch.o ada/s-string.o \ + ada/s-utf_32.o ada/s-crc32.o ada/get_targ.o \ + ada/gnatvsn.o ada/hlo.o ada/hostparm.o ada/impunit.o ada/interfac.o \ + ada/itypes.o ada/inline.o ada/krunch.o ada/lib.o ada/layout.o \ + ada/lib-load.o ada/lib-util.o ada/lib-xref.o ada/lib-writ.o ada/live.o \ + ada/namet.o ada/namet-sp.o \ + ada/nlists.o ada/nmake.o ada/opt.o ada/osint.o ada/osint-c.o \ + ada/output.o \ + ada/par.o ada/prep.o ada/prepcomp.o ada/repinfo.o ada/restrict.o \ + ada/rident.o ada/rtsfind.o \ + ada/s-addope.o ada/s-assert.o ada/s-parame.o ada/s-stache.o \ + ada/s-stalib.o ada/s-imgenu.o ada/s-imenne.o ada/s-stoele.o ada/s-soflin.o \ + ada/s-except.o ada/s-exctab.o \ + ada/s-secsta.o ada/s-strops.o ada/s-sopco3.o ada/s-sopco4.o ada/s-sopco5.o \ + ada/s-traent.o ada/s-wchcnv.o ada/s-wchcon.o ada/s-wchjis.o \ + ada/s-unstyp.o ada/scans.o ada/scng.o ada/scn.o ada/sdefault.o ada/sem.o \ + ada/sem_aggr.o ada/sem_attr.o ada/sem_aux.o \ + ada/sem_cat.o ada/sem_ch10.o ada/sem_ch11.o \ + ada/sem_ch12.o ada/sem_ch13.o ada/sem_ch2.o ada/sem_ch3.o ada/sem_ch4.o \ + ada/sem_ch5.o ada/sem_ch6.o ada/sem_ch7.o ada/sem_ch8.o ada/sem_ch9.o \ + ada/sem_case.o ada/sem_disp.o ada/sem_dist.o ada/sem_elab.o ada/sem_elim.o \ + ada/sem_eval.o ada/sem_intr.o ada/sem_maps.o ada/sem_mech.o ada/sem_prag.o \ + ada/sem_res.o ada/sem_smem.o ada/sem_type.o ada/sem_util.o ada/sem_vfpt.o \ + ada/sem_warn.o ada/sinfo-cn.o ada/sinfo.o ada/sinput.o ada/sinput-d.o \ + ada/sinput-l.o ada/snames.o ada/sprint.o ada/stand.o ada/stringt.o \ + ada/style.o ada/styleg.o ada/styleg-c.o ada/switch.o ada/switch-c.o \ + ada/stylesw.o ada/validsw.o ada/system.o ada/table.o ada/targparm.o \ + ada/tbuild.o ada/tree_gen.o ada/tree_in.o \ + ada/tree_io.o ada/treepr.o ada/treeprs.o \ + ada/ttypef.o ada/ttypes.o ada/types.o ada/uintp.o ada/uname.o ada/urealp.o \ + ada/usage.o ada/widechar.o ada/s-crtl.o ada/seh_init.o ada/targext.o \ + ada/s-restri.o + + # Object files for gnat executables + GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o + + GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) $(EXTRA_GNAT1_OBJS) + + GNATBIND_OBJS = \ + ada/adaint.o \ + ada/argv.o \ + ada/exit.o \ + ada/cio.o \ + ada/cstreams.o \ + ada/env.o \ + ada/final.o \ + ada/init.o \ + ada/initialize.o \ + ada/seh_init.o \ + ada/link.o \ + ada/targext.o \ + ada/raise.o \ + ada/tracebak.o \ + ada/ada.o \ + ada/a-clrefi.o \ + ada/a-comlin.o \ + ada/a-elchha.o \ + ada/a-except.o \ + ada/ali-util.o \ + ada/ali.o \ + ada/alloc.o \ + ada/atree.o \ + ada/bcheck.o \ + ada/binde.o \ + ada/binderr.o \ + ada/bindgen.o \ + ada/bindusg.o \ + ada/butil.o \ + ada/casing.o \ + ada/csets.o \ + ada/debug.o \ + ada/einfo.o \ + ada/elists.o \ + ada/err_vars.o \ + ada/errout.o \ + ada/erroutc.o \ + ada/fmap.o \ + ada/fname.o \ + ada/g-hesora.o \ + ada/g-htable.o \ + ada/s-os_lib.o \ + ada/s-string.o \ + ada/gnat.o \ + ada/gnatbind.o \ + ada/gnatvsn.o \ + ada/hostparm.o \ + ada/interfac.o \ + ada/lib.o \ + ada/namet.o \ + ada/nlists.o \ + ada/opt.o \ + ada/osint-b.o \ + ada/osint.o \ + ada/output.o \ + ada/rident.o \ + ada/s-addope.o \ + ada/s-assert.o \ + ada/s-carun8.o \ + ada/s-casuti.o \ + ada/s-crc32.o \ + ada/s-crtl.o \ + ada/s-except.o \ + ada/s-exctab.o \ + ada/s-htable.o \ + ada/s-imenne.o \ + ada/s-imgenu.o \ + ada/s-mastop.o \ + ada/s-memory.o \ + ada/s-parame.o \ + ada/s-restri.o \ + ada/s-secsta.o \ + ada/s-soflin.o \ + ada/s-sopco3.o \ + ada/s-sopco4.o \ + ada/s-sopco5.o \ + ada/s-stache.o \ + ada/s-stalib.o \ + ada/s-stoele.o \ + ada/s-strops.o \ + ada/s-traceb.o \ + ada/s-traent.o \ + ada/s-unstyp.o \ + ada/s-utf_32.o \ + ada/s-wchcnv.o \ + ada/s-wchcon.o \ + ada/s-wchjis.o \ + ada/scng.o \ + ada/scans.o \ + ada/sdefault.o \ + ada/sinfo.o \ + ada/sinput.o \ + ada/sinput-c.o \ + ada/snames.o \ + ada/stand.o \ + ada/stringt.o \ + ada/switch-b.o \ + ada/switch.o \ + ada/style.o \ + ada/styleg.o \ + ada/stylesw.o \ + ada/system.o \ + ada/table.o \ + ada/targparm.o \ + ada/tree_io.o \ + ada/types.o \ + ada/uintp.o \ + ada/uname.o \ + ada/urealp.o \ + ada/widechar.o \ + $(EXTRA_GNATBIND_OBJS) + + # List of extra object files linked in with various programs. + EXTRA_GNAT1_OBJS = prefix.o + EXTRA_GNATBIND_OBJS = prefix.o version.o + + # Language-independent object files. + ADA_BACKEND = $(BACKEND) attribs.o + + # List of target dependent sources, overridden below as necessary + TARGET_ADA_SRCS = + + # Needs to be built with CC=gcc + # Since the RTL should be built with the latest compiler, remove the + # stamp target in the parent directory whenever gnat1 is rebuilt + gnat1$(exeext): $(TARGET_ADA_SRCS) $(GNAT1_OBJS) $(ADA_BACKEND) $(LIBDEPS) + $(GCC_LINK) -o $@ $(GNAT1_OBJS) $(ADA_BACKEND) $(LIBS) $(SYSLIBS) $(BACKENDLIBS) $(CFLAGS) + $(RM) stamp-gnatlib2-rts stamp-tools + + gnatbind$(exeext): ada/b_gnatb.o $(CONFIG_H) $(GNATBIND_OBJS) + $(GCC_LINK) -o $@ ada/b_gnatb.o $(GNATBIND_OBJS) $(ALL_CFLAGS) $(LIBS) $(SYSLIBS) + + # use cross-gcc + gnat-cross: force + make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp" \ + $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) HOST_CFLAGS= HOST_CC=cc + + # Build hooks: + + ada.all.cross: + -if [ -f gnatbind$(exeext) ] ; \ + then \ + $(MV) gnatbind$(exeext) gnatbind-cross$(exeext); \ + fi + -if [ -f gnatchop$(exeext) ] ; \ + then \ + $(MV) gnatchop$(exeext) gnatchop-cross$(exeext); \ + fi + -if [ -f gnat$(exeext) ] ; \ + then \ + $(MV) gnat$(exeext) gnat-cross$(exeext); \ + fi + -if [ -f gnatkr$(exeext) ] ; \ + then \ + $(MV) gnatkr$(exeext) gnatkr-cross$(exeext); \ + fi + -if [ -f gnatlink$(exeext) ] ; \ + then \ + $(MV) gnatlink$(exeext) gnatlink-cross$(exeext); \ + fi + -if [ -f gnatls$(exeext) ] ; \ + then \ + $(MV) gnatls$(exeext) gnatls-cross$(exeext); \ + fi + -if [ -f gnatmake$(exeext) ] ; \ + then \ + $(MV) gnatmake$(exeext) gnatmake-cross$(exeext); \ + fi + -if [ -f gnatname$(exeext) ] ; \ + then \ + $(MV) gnatname$(exeext) gnatname-cross$(exeext); \ + fi + -if [ -f gnatprep$(exeext) ] ; \ + then \ + $(MV) gnatprep$(exeext) gnatprep-cross$(exeext); \ + fi + -if [ -f gnatxref$(exeext) ] ; \ + then \ + $(MV) gnatxref$(exeext) gnatxref-cross$(exeext); \ + fi + -if [ -f gnatfind$(exeext) ] ; \ + then \ + $(MV) gnatfind$(exeext) gnatfind-cross$(exeext); \ + fi + -if [ -f gnatclean$(exeext) ] ; \ + then \ + $(MV) gnatclean$(exeext) gnatclean-cross$(exeext); \ + fi + -if [ -f gnatsym$(exeext) ] ; \ + then \ + $(MV) gnatsym$(exeext) gnatsym-cross$(exeext); \ + fi + + ada.start.encap: + ada.rest.encap: + ada.man: + ada.srcextra: + ada.srcman: + + ada.tags: force + cd $(srcdir)/ada && etags -o TAGS.sub *.c *.h *.ads *.adb && \ + etags --include TAGS.sub --include ../TAGS.sub + + + # Generate documentation. + + ada/doctools/xgnatugn$(build_exeext): ada/xgnatugn.adb + -$(MKDIR) ada/doctools + $(CP) $^ ada/doctools + cd ada/doctools && $(GNATMAKE) -q xgnatugn + + # Note that doc/gnat_ugn.texi does not depend on xgnatugn + # being built so we can distribute a pregenerated doc/gnat_ugn.info + + doc/gnat_ugn.texi: $(srcdir)/ada/gnat_ugn.texi $(srcdir)/ada/ug_words \ + $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + $(MAKE) ada/doctools/xgnatugn$(build_exeext) + ada/doctools/xgnatugn unw $(srcdir)/ada/gnat_ugn.texi \ + $(srcdir)/ada/ug_words doc/gnat_ugn.texi + + doc/gnat_ugn.info: doc/gnat_ugn.texi \ + $(gcc_docdir)/include/fdl.texi $(gcc_docdir)/include/gcc-common.texi \ + gcc-vers.texi + if [ x$(BUILD_INFO) = xinfo ]; then \ + rm -f $(@)*; \ + $(MAKEINFO) $(MAKEINFOFLAGS) -I$(gcc_docdir)/include \ + -I$(srcdir)/ada -o $@ $<; \ + else true; fi + + doc/gnat_rm.info: ada/gnat_rm.texi $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + if [ x$(BUILD_INFO) = xinfo ]; then \ + rm -f $(@)*; \ + $(MAKEINFO) $(MAKEINFOFLAGS) -I$(gcc_docdir)/include \ + -I$(srcdir)/ada -o $@ $<; \ + else true; fi + + doc/gnat-style.info: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + if [ x$(BUILD_INFO) = xinfo ]; then \ + rm -f $(@)*; \ + $(MAKEINFO) $(MAKEINFOFLAGS) -I$(gcc_docdir)/include \ + -I$(srcdir)/ada -o $@ $<; \ + else true; fi + + ADA_INFOFILES = doc/gnat_ugn.info doc/gnat_ugn.texi \ + doc/gnat_rm.info doc/gnat-style.info + + ada.info: $(ADA_INFOFILES) + + ada.srcinfo: $(ADA_INFOFILES) + -$(CP) $^ $(srcdir)/doc + + ada.install-info: $(DESTDIR)$(infodir)/gnat_ugn.info \ + $(DESTDIR)$(infodir)/gnat_rm.info \ + $(DESTDIR)$(infodir)/gnat-style.info + + ada.dvi: doc/gnat_ugn.dvi \ + doc/gnat_rm.dvi doc/gnat-style.dvi + + ADA_PDFFILES = doc/gnat_ugn.pdf \ + doc/gnat_rm.pdf doc/gnat-style.pdf + + ada.pdf: $(ADA_PDFFILES) + + ada.install-pdf: $(ADA_PDFFILES) + @$(NORMAL_INSTALL) + test -z "$(pdfdir)/gcc" || $(mkinstalldirs) "$(DESTDIR)$(pdfdir)/gcc" + @list='$(ADA_PDFFILES)'; for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + f=$(pdf__strip_dir) \ + echo " $(INSTALL_DATA) '$$d$$p' '$(DESTDIR)$(pdfdir)/gcc/$$f'"; \ + $(INSTALL_DATA) "$$d$$p" "$(DESTDIR)$(pdfdir)/gcc/$$f"; \ + done + + ada.html: + + doc/gnat_ugn.dvi: doc/gnat_ugn.texi $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + $(TEXI2DVI) -c -I $(abs_docdir)/include -o $@ $< + + doc/gnat_rm.dvi: ada/gnat_rm.texi $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + $(TEXI2DVI) -c -I $(abs_docdir)/include -o $@ $< + + doc/gnat-style.dvi: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi + $(TEXI2DVI) -c -I $(abs_docdir)/include -o $@ $< + + doc/gnat_ugn.pdf: doc/gnat_ugn.texi $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + $(TEXI2PDF) -c -I $(abs_docdir)/include -o $@ $< + + doc/gnat_rm.pdf: ada/gnat_rm.texi $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + $(TEXI2PDF) -c -I $(abs_docdir)/include -o $@ $< + + doc/gnat-style.pdf: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi + $(TEXI2PDF) -c -I $(abs_docdir)/include -o $@ $< + + + # Install hooks: + # gnat1 is installed elsewhere as part of $(COMPILERS). + + # Install the binder program as $(target_noncanonical)-gnatbind + # and also as either gnatbind (if native) or $(tooldir)/bin/gnatbind + # likewise for gnatf, gnatchop, and gnatlink, gnatkr, gnatmake, gnat, + # gnatprep, gnatls, gnatxref, gnatfind, gnatname, gnatclean, + # gnatsym + ada.install-common: + $(MKDIR) $(DESTDIR)$(bindir) + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatbind-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbind$(exeext); \ + $(INSTALL_PROGRAM) gnatbind-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbind$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatbind$(exeext); \ + $(INSTALL_PROGRAM) gnatbind-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatbind$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatbind$(exeext); \ + $(INSTALL_PROGRAM) gnatbind$(exeext) $(DESTDIR)$(bindir)/gnatbind$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatchop-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatchop$(exeext); \ + $(INSTALL_PROGRAM) gnatchop-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatchop$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatchop$(exeext); \ + $(INSTALL_PROGRAM) gnatchop-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatchop$(exeext); \ + fi ; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatchop$(exeext); \ + $(INSTALL_PROGRAM) gnatchop$(exeext) $(DESTDIR)$(bindir)/gnatchop$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnat-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnat$(exeext); \ + $(INSTALL_PROGRAM) gnat-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnat$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnat$(exeext); \ + $(INSTALL_PROGRAM) gnat-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnat$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnat$(exeext); \ + $(INSTALL_PROGRAM) gnat$(exeext) $(DESTDIR)$(bindir)/gnat$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatkr-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatkr$(exeext); \ + $(INSTALL_PROGRAM) gnatkr-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatkr$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatkr$(exeext); \ + $(INSTALL_PROGRAM) gnatkr-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatkr$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatkr$(exeext); \ + $(INSTALL_PROGRAM) gnatkr$(exeext) $(DESTDIR)$(bindir)/gnatkr$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatlink-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatlink$(exeext); \ + $(INSTALL_PROGRAM) gnatlink-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatlink$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatlink$(exeext); \ + $(INSTALL_PROGRAM) gnatlink-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatlink$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatlink$(exeext); \ + $(INSTALL_PROGRAM) gnatlink$(exeext) $(DESTDIR)$(bindir)/gnatlink$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatls-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatls$(exeext); \ + $(INSTALL_PROGRAM) gnatls-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatls$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatls$(exeext); \ + $(INSTALL_PROGRAM) gnatls-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatls$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatls$(exeext); \ + $(INSTALL_PROGRAM) gnatls$(exeext) $(DESTDIR)$(bindir)/gnatls$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatmake-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatmake$(exeext); \ + $(INSTALL_PROGRAM) gnatmake-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatmake$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatmake$(exeext); \ + $(INSTALL_PROGRAM) gnatmake-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatmake$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatmake$(exeext); \ + $(INSTALL_PROGRAM) gnatmake$(exeext) $(DESTDIR)$(bindir)/gnatmake$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatname-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatname$(exeext); \ + $(INSTALL_PROGRAM) gnatname-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatname$(exeext); \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatname$(exeext); \ + $(INSTALL_PROGRAM) gnatname$(exeext) $(DESTDIR)$(bindir)/gnatname$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatprep-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatprep$(exeext); \ + $(INSTALL_PROGRAM) gnatprep-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatprep$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatprep$(exeext); \ + $(INSTALL_PROGRAM) gnatprep-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatprep$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatprep$(exeext); \ + $(INSTALL_PROGRAM) gnatprep$(exeext) $(DESTDIR)$(bindir)/gnatprep$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatxref-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatxref$(exeext); \ + $(INSTALL_PROGRAM) gnatxref-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatxref$(exeext); \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatxref$(exeext); \ + $(INSTALL_PROGRAM) gnatxref$(exeext) $(DESTDIR)$(bindir)/gnatxref$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatfind-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatfind$(exeext); \ + $(INSTALL_PROGRAM) gnatfind-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatfind$(exeext); \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatfind$(exeext); \ + $(INSTALL_PROGRAM) gnatfind$(exeext) $(DESTDIR)$(bindir)/gnatfind$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatclean-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatclean$(exeext); \ + $(INSTALL_PROGRAM) gnatclean-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatclean$(exeext); \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatclean$(exeext); \ + $(INSTALL_PROGRAM) gnatclean$(exeext) $(DESTDIR)$(bindir)/gnatclean$(exeext); \ + fi ; \ + fi + # + # Gnatsym is only built on some platforms, including VMS + # + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatsym$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/gnatsym$(exeext); \ + $(INSTALL_PROGRAM) gnatsym$(exeext) $(DESTDIR)$(bindir)/gnatsym$(exeext); \ + fi ; \ + fi + # + # Gnatlbr is only used on VMS. + # + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatlbr$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/gnatlbr$(exeext); \ + $(INSTALL_PROGRAM) gnatlbr$(exeext) $(DESTDIR)$(bindir)/gnatlbr$(exeext); \ + fi ; \ + fi + # + # Gnatdll is only used on Windows. + # + -if [ -f gnat1$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/gnatdll$(exeext); \ + $(INSTALL_PROGRAM) gnatdll$(exeext) $(DESTDIR)$(bindir)/gnatdll$(exeext); \ + fi + # + # vxaddr2line is only used for cross ports (it calls the underlying cross + # addr2line). + # + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f vxaddr2line$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/vxaddr2line$(exeext); \ + $(INSTALL_PROGRAM) vxaddr2line$(exeext) $(DESTDIR)$(bindir)/vxaddr2line$(exeext); \ + fi ; \ + fi + + # + # Finally, install the library + # + -if [ -f gnat1$(exeext) ] ; \ + then \ + $(MAKE) $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib; \ + fi + + install-gnatlib: + $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib$(LIBGNAT_TARGET) + + install-gnatlib-obj: + $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib-obj + + ada.install-man: + + ada.uninstall: + -$(RM) $(DESTDIR)$(bindir)/gnatbind$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatchop$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnat$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatfind$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatdll$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatkr$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatlbr$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatlink$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatls$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatmake$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatname$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatprep$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatxref$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatclean$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatsym$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbind$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatchop$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnat$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatfind$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatdll$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatkr$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatlbr$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatlink$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatls$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatmake$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatname$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatprep$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatxref$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatclean$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatsym$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatbind$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatchop$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnat$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatfind$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatdll$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatkr$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatlbr$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatlink$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatls$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatmake$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatname$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatprep$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatxref$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatclean$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatsym$(exeext) + # Gnatlbr and Gnatchop are only used on VMS + -$(RM) $(DESTDIR)$(bindir)/gnatlbr$(exeext) $(DESTDIR)$(bindir)/gnatchop$(exeext) + + # Clean hooks: + # A lot of the ancillary files are deleted by the main makefile. + # We just have to delete files specific to us. + + ada.mostlyclean: + -$(RM) ada/*$(objext) ada/*.ali ada/b_*.c + -$(RM) ada/*$(coverageexts) + -$(RM) ada/sdefault.adb ada/stamp-sdefault + -$(RMDIR) ada/tools + ada.clean: + ada.distclean: + -$(RM) ada/Makefile + -$(RM) gnatchop$(exeext) + -$(RM) gnat$(exeext) + -$(RM) gnatdll$(exeext) + -$(RM) gnatkr$(exeext) + -$(RM) gnatlink$(exeext) + -$(RM) gnatls$(exeext) + -$(RM) gnatmake$(exeext) + -$(RM) gnatname$(exeext) + -$(RM) gnatprep$(exeext) + -$(RM) gnatfind$(exeext) + -$(RM) gnatxref$(exeext) + -$(RM) gnatclean$(exeext) + -$(RM) gnatsym$(exeext) + # Gnatlbr is only used on VMS + -$(RM) gnatlbr$(exeext) + -$(RM) ada/rts/* + -$(RMDIR) ada/rts + -$(RM) ada/tools/* + -$(RMDIR) ada/tools + ada.maintainer-clean: + -$(RM) ada/sinfo.h + -$(RM) ada/einfo.h + -$(RM) ada/nmake.adb + -$(RM) ada/nmake.ads + -$(RM) ada/treeprs.ads + + # Stage hooks: + # The main makefile has already created stage?/ada + + ada.stage1: stage1-start + -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage1/ada + -$(MV) ada/stamp-* stage1/ada + ada.stage2: stage2-start + -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage2/ada + -$(MV) ada/stamp-* stage2/ada + ada.stage3: stage3-start + -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage3/ada + -$(MV) ada/stamp-* stage3/ada + ada.stage4: stage4-start + -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage4/ada + -$(MV) ada/stamp-* stage4/ada + ada.stageprofile: stageprofile-start + -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stageprofile/ada + -$(MV) ada/stamp-* stageprofile/ada + ada.stagefeedback: stagefeedback-start + -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stagefeedback/ada + -$(MV) ada/stamp-* stagefeedback/ada + + lang_checks += check-gnat + + check-ada: check-acats check-gnat + check-ada-subtargets: check-acats-subtargets check-gnat-subtargets + + ACATSDIR = $(TESTSUITEDIR)/ada/acats + + check_acats_targets = $(patsubst %,check-acats%, 0 1 2) + + check-acats: + @test -d $(ACATSDIR) || mkdir -p $(ACATSDIR); \ + if [ -z "$(CHAPTERS)" ] && [ "$(filter -j, $(MFLAGS))" = "-j" ]; \ + then \ + $(MAKE) $(check_acats_targets); \ + for idx in 0 1 2; do \ + mv -f $(ACATSDIR)$$idx/acats.sum $(ACATSDIR)$$idx/acats.sum.sep; \ + mv -f $(ACATSDIR)$$idx/acats.log $(ACATSDIR)$$idx/acats.log.sep; \ + done; \ + $(SHELL) $(srcdir)/../contrib/dg-extract-results.sh \ + $(ACATSDIR)0/acats.sum.sep $(ACATSDIR)1/acats.sum.sep \ + $(ACATSDIR)2/acats.sum.sep > $(ACATSDIR)/acats.sum; \ + $(SHELL) $(srcdir)/../contrib/dg-extract-results.sh -L \ + $(ACATSDIR)0/acats.log.sep $(ACATSDIR)1/acats.log.sep \ + $(ACATSDIR)2/acats.log.sep > $(ACATSDIR)/acats.log; \ + exit 0; \ + fi; \ + testdir=`cd ${srcdir}/${ACATSDIR} && ${PWD_COMMAND}`; \ + export testdir; cd $(ACATSDIR) && $(SHELL) $${testdir}/run_acats $(CHAPTERS) + + check-acats-subtargets: + @echo $(check_acats_targets) + + # Parallelized check-acats + $(check_acats_targets): check-acats%: + test -d $(ACATSDIR)$* || mkdir -p $(ACATSDIR)$*; \ + testdir=`cd ${srcdir}/${ACATSDIR} && ${PWD_COMMAND}`; \ + case "$*" in \ + 0) chapters="`cd $$testdir/tests; echo [a-b]* c[0-4]*`";; \ + 1) chapters="`cd $$testdir/tests; echo c[5-9ab]*`";; \ + 2) chapters="`cd $$testdir/tests; echo c[c-z]* [d-z]*`";; \ + esac; \ + export testdir; cd $(ACATSDIR)$* && $(SHELL) $${testdir}/run_acats $$chapters + + .PHONY: check-acats $(check_acats_targets) + + + # Bootstrapping targets for just GNAT - use the same stage directories + gnatboot: force + -$(RM) gnatboot3 + $(MAKE) gnat1$(exeext) gnatbind$(exeext) CC="$(CC)" \ + CFLAGS="$(CFLAGS)" + $(MAKE) gnatboot2 BOOT_CFLAGS="$(BOOT_CFLAGS)" \ + BOOT_ADAFLAGS="$(BOOT_ADAFLAGS)" \ + LDFLAGS="$(BOOT_LDFLAGS)" + + gnatboot2: force + $(MAKE) gnatstage1 + $(MAKE) gnat1$(exeext) gnatbind$(exeext) CC="gcc -B../stage1/"\ + CFLAGS="$(BOOT_CFLAGS)" \ + ADAFLAGS="$(BOOT_ADAFLAGS)"\ + LDFLAGS="$(BOOT_LDFLAGS)" \ + GNATBIND="../stage1/gnatbind" + $(MAKE) gnatboot3 BOOT_CFLAGS="$(BOOT_CFLAGS)" \ + BOOT_ADAFLAGS="$(BOOT_ADAFLAGS)" \ + LDFLAGS="$(BOOT_LDFLAGS)" + + gnatboot3: + $(MAKE) gnatstage2 + $(MAKE) gnat1$(exeext) gnatbind$(exeext) CC="gcc -B../stage2/"\ + CFLAGS="$(BOOT_CFLAGS)" \ + ADAFLAGS="$(BOOT_ADAFLAGS)"\ + LDFLAGS="$(BOOT_LDFLAGS)" \ + GNATBIND="../stage2/gnatbind" + + gnatstage1: force + -$(MKDIR) stage1 + -$(MKDIR) stage1/ada + -$(MV) gnat1$(exeext) gnatbind$(exeext) stage1 + -$(MV) ada/*$(objext) ada/*.ali stage1/ada + -$(MV) ada/stamp-* stage1/ada + + gnatstage2: force + -$(MKDIR) stage2 + -$(MKDIR) stage2/ada + -$(MV) gnat1$(exeext) gnatbind$(exeext) stage2 + -$(MV) ada/*$(objext) ada/*.ali stage2/ada + -$(MV) ada/stamp-* stage2/ada + + # Compiling object files from source files. + + # Note that dependencies on obstack.h are not written + # because that file is not part of GCC. + # Dependencies on gvarargs.h are not written + # because all that file does, when not compiling with GCC, + # is include the system varargs.h. + + # Ada language specific files. + + ada_extra_files : ada/treeprs.ads ada/einfo.h ada/sinfo.h ada/nmake.adb \ + ada/nmake.ads + + ada/b_gnat1.c : $(GNAT1_ADA_OBJS) + $(GNATBIND) -C $(ADA_INCLUDES) -o ada/b_gnat1.c -n ada/gnat1drv.ali + ada/b_gnat1.o : ada/b_gnat1.c + + ada/b_gnatb.c : $(GNATBIND_OBJS) ada/gnatbind.o ada/interfac.o + $(GNATBIND) -C $(ADA_INCLUDES) -o ada/b_gnatb.c ada/gnatbind.ali + ada/b_gnatb.o : ada/b_gnatb.c + + # We delete the files before copying, below, in case they are read-only. + ada/treeprs.ads : ada/treeprs.adt ada/sinfo.ads ada/xtreeprs.adb + -$(MKDIR) ada/bldtools/treeprs + $(RM) $(addprefix ada/bldtools/treeprs/,$(notdir $^)) + $(CP) $^ ada/bldtools/treeprs + (cd ada/bldtools/treeprs && $(GNATMAKE) -q xtreeprs && ./xtreeprs ../../treeprs.ads ) + + ada/einfo.h : ada/einfo.ads ada/einfo.adb ada/xeinfo.adb + -$(MKDIR) ada/bldtools/einfo + $(RM) $(addprefix ada/bldtools/einfo/,$(notdir $^)) + $(CP) $^ ada/bldtools/einfo + (cd ada/bldtools/einfo && $(GNATMAKE) -q xeinfo && ./xeinfo ../../einfo.h ) + + ada/sinfo.h : ada/sinfo.ads ada/xsinfo.adb + -$(MKDIR) ada/bldtools/sinfo + $(RM) $(addprefix ada/bldtools/sinfo/,$(notdir $^)) + $(CP) $^ ada/bldtools/sinfo + (cd ada/bldtools/sinfo && $(GNATMAKE) -q xsinfo && ./xsinfo ../../sinfo.h ) + + ada/nmake.adb : ada/sinfo.ads ada/nmake.adt ada/xnmake.adb ada/xutil.ads ada/xutil.adb + -$(MKDIR) ada/bldtools/nmake_b + $(RM) $(addprefix ada/bldtools/nmake_b/,$(notdir $^)) + $(CP) $^ ada/bldtools/nmake_b + (cd ada/bldtools/nmake_b && $(GNATMAKE) -q xnmake && ./xnmake -b ../../nmake.adb ) + + ada/nmake.ads : ada/sinfo.ads ada/nmake.adt ada/xnmake.adb ada/nmake.adb ada/xutil.ads ada/xutil.adb + -$(MKDIR) ada/bldtools/nmake_s + $(RM) $(addprefix ada/bldtools/nmake_s/,$(notdir $^)) + $(CP) $^ ada/bldtools/nmake_s + (cd ada/bldtools/nmake_s && $(GNATMAKE) -q xnmake && ./xnmake -s ../../nmake.ads ) + + ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(subst -, ,$(host)))),) + OSCONS_CPP=../../../$(DECC) -E /comment=as_is -DNATIVE \ + -DTARGET='""$(target)""' s-oscons-tmplt.c + + OSCONS_EXTRACT=../../../$(DECC) -DNATIVE \ + -DTARGET='""$(target)""' s-oscons-tmplt.c ; \ + ld -o s-oscons-tmplt.exe s-oscons-tmplt.obj; \ + ./s-oscons-tmplt.exe > s-oscons-tmplt.s + + else + OSCONS_CC=`echo "$(GCC_FOR_TARGET)" \ + | sed -e 's^\./xgcc^../../../xgcc^' -e 's^-B./^-B../../../^'` + OSCONS_CPP=$(OSCONS_CC) $(CFLAGS_FOR_TARGET) -E -C \ + -DTARGET=\"$(target)\" s-oscons-tmplt.c > s-oscons-tmplt.i + OSCONS_EXTRACT=$(OSCONS_CC) $(CFLAGS_FOR_TARGET) -S s-oscons-tmplt.i + endif + + ada/s-oscons.ads : ada/s-oscons-tmplt.c ada/gsocket.h ada/xoscons.adb ada/xutil.ads ada/xutil.adb + -$(MKDIR) ada/bldtools/oscons + $(RM) $(addprefix ada/bldtools/oscons/,$(notdir $^)) + $(CP) $^ ada/bldtools/oscons + (cd ada/bldtools/oscons ; gnatmake -q xoscons ; \ + $(RM) s-oscons-tmplt.i s-oscons-tmplt.s ; \ + $(OSCONS_CPP) ; \ + $(OSCONS_EXTRACT) ; \ + ./xoscons ; \ + $(RM) ../../s-oscons.ads ; \ + $(CP) s-oscons.ads ../../s-oscons.ads) + + update-sources : ada/treeprs.ads ada/einfo.h ada/sinfo.h ada/nmake.adb \ + ada/nmake.ads + $(RM) $(addprefix $(srcdir)/ada/,$(notdir $^)) + $(CP) $^ $(srcdir)/ada + + ada/sdefault.adb: ada/stamp-sdefault ; @true + ada/stamp-sdefault : $(srcdir)/version.c Makefile + $(ECHO) "pragma Style_Checks (Off);" >tmp-sdefault.adb + $(ECHO) "with Osint; use Osint;" >>tmp-sdefault.adb + $(ECHO) "package body Sdefault is" >>tmp-sdefault.adb + $(ECHO) " S0 : constant String := \"$(prefix)/\";" >>tmp-sdefault.adb + $(ECHO) " S1 : constant String := \"$(ADA_INCLUDE_DIR)/\";" >>tmp-sdefault.adb + $(ECHO) " S2 : constant String := \"$(ADA_RTL_OBJ_DIR)/\";" >>tmp-sdefault.adb + $(ECHO) " S3 : constant String := \"$(target)/\";" >>tmp-sdefault.adb + $(ECHO) " S4 : constant String := \"$(libsubdir)/\";" >>tmp-sdefault.adb + $(ECHO) " function Include_Dir_Default_Name return String_Ptr is" >>tmp-sdefault.adb + $(ECHO) " begin" >>tmp-sdefault.adb + $(ECHO) " return Relocate_Path (S0, S1);" >>tmp-sdefault.adb + $(ECHO) " end Include_Dir_Default_Name;" >>tmp-sdefault.adb + $(ECHO) " function Object_Dir_Default_Name return String_Ptr is" >>tmp-sdefault.adb + $(ECHO) " begin" >>tmp-sdefault.adb + $(ECHO) " return Relocate_Path (S0, S2);" >>tmp-sdefault.adb + $(ECHO) " end Object_Dir_Default_Name;" >>tmp-sdefault.adb + $(ECHO) " function Target_Name return String_Ptr is" >>tmp-sdefault.adb + $(ECHO) " begin" >>tmp-sdefault.adb + $(ECHO) " return new String'(S3);" >>tmp-sdefault.adb + $(ECHO) " end Target_Name;" >>tmp-sdefault.adb + $(ECHO) " function Search_Dir_Prefix return String_Ptr is" >>tmp-sdefault.adb + $(ECHO) " begin" >>tmp-sdefault.adb + $(ECHO) " return Relocate_Path (S0, S4);" >>tmp-sdefault.adb + $(ECHO) " end Search_Dir_Prefix;" >>tmp-sdefault.adb + $(ECHO) "end Sdefault;" >> tmp-sdefault.adb + $(srcdir)/../move-if-change tmp-sdefault.adb ada/sdefault.adb + touch ada/stamp-sdefault + + ada/sdefault.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads ada/namet.ads \ + ada/opt.ads ada/osint.ads ada/output.ads ada/sdefault.ads ada/sdefault.adb \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/system.ads ada/table.adb ada/table.ads ada/tree_io.ads \ + ada/types.ads ada/unchdeal.ads ada/unchconv.ads + + ADA_TREE_H = ada/gcc-interface/ada-tree.h + + # force debugging information on s-tasdeb.o so that it is always + # possible to set conditional breakpoints on tasks. + + ada/s-tasdeb.o : ada/s-tasdeb.adb ada/s-tasdeb.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) + + # force debugging information on s-vaflop.o so that it is always + # possible to call the VAX float debug print routines. + # force at least -O so that the inline assembly works. + + ada/s-vaflop.o : ada/s-vaflop.adb ada/s-vaflop.ads + $(CC) -c -O $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ + $(OUTPUT_OPTION) $< + + # force debugging information on a-except.o so that it is always + # possible to set conditional breakpoints on exceptions. + # use -O1 otherwise gdb isn't able to get a full backtrace on mips targets. + + ada/a-except.o : ada/a-except.adb ada/a-except.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \ + $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + + # compile s-except.o without optimization and with debug info to let the + # debugger set breakpoints and inspect subprogram parameters on exception + # related events. + + ada/s-except.o : ada/s-except.adb ada/s-except.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ + $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + + # force debugging information on s-assert.o so that it is always + # possible to set breakpoint on assert failures. + + ada/s-assert.o : ada/s-assert.adb ada/s-assert.ads ada/a-except.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 \ + $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + + # dependencies for windows specific tool (mdll) + + ada/mdll.o : ada/mdll.adb ada/mdll.ads ada/mdll-fil.ads ada/mdll-utl.ads + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + + ada/mdll-fil.o : ada/mdll-fil.adb ada/mdll.ads ada/mdll-fil.ads + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + + ada/mdll-utl.o : ada/mdll-utl.adb ada/mdll.ads ada/mdll-utl.ads ada/sdefault.ads ada/types.ads + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + + # force debugging information and no optimization on s-memory.o so that it + # is always possible to set breakpoint on __gnat_malloc and __gnat_free + # this is important for gnatmem using GDB. memtrack.o is built from + # memtrack.adb, and used by the post-mortem analysis with gnatmem. + + ada/s-memory.o : ada/s-memory.adb ada/s-memory.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ + $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + + ada/memtrack.o : ada/memtrack.adb ada/s-memory.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ + $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + + ada/adadecode.o : ada/adadecode.c $(CONFIG_H) $(SYSTEM_H) ada/adadecode.h + ada/adaint.o : ada/adaint.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h + ada/argv.o : ada/argv.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h + ada/cstreams.o : ada/cstreams.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h + ada/exit.o : ada/exit.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h + ada/final.o : ada/final.c $(CONFIG_H) $(SYSTEM_H) ada/raise.h + ada/link.o : ada/link.c + + + ada/targext.o : ada/targext.c $(SYSTEM_H) coretypes.h $(TM_H) + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ + $< $(OUTPUT_OPTION) + + ada/cio.o : ada/cio.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + + ada/init.o : ada/init.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h ada/raise.h + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + + ada/initialize.o : ada/initialize.c + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + + ada/raise.o : ada/raise.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h ada/raise.h + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + + # Need to keep the frame pointer in this file to pop the stack properly on + # some targets. + ada/tracebak.o : ada/tracebak.c $(CONFIG_H) $(SYSTEM_H) + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ + -fno-omit-frame-pointer $< $(OUTPUT_OPTION) + + ada/cuintp.o : ada/gcc-interface/cuintp.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ + $(TREE_H) ada/gcc-interface/ada.h ada/types.h ada/uintp.h ada/atree.h ada/stringt.h \ + ada/elists.h ada/nlists.h ada/fe.h ada/gcc-interface/gigi.h + $(CC) -c $(ALL_CFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + + ada/decl.o : ada/gcc-interface/decl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) $(FLAGS_H) toplev.h convert.h $(TARGET_H) \ + ada/gcc-interface/ada.h ada/types.h ada/atree.h \ + ada/nlists.h ada/elists.h ada/uintp.h ada/sinfo.h ada/einfo.h ada/snames.h \ + ada/namet.h ada/stringt.h ada/repinfo.h ada/fe.h $(ADA_TREE_H) \ + ada/gcc-interface/gigi.h \ + $(EXPR_H) gt-ada-decl.h + $(CC) -c $(ALL_CFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + + ada/misc.o : ada/gcc-interface/misc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) \ + $(RTL_H) $(EXPR_H) insn-codes.h insn-flags.h insn-config.h recog.h \ + $(FLAGS_H) $(DIAGNOSTIC_H) output.h except.h $(TM_P_H) langhooks.h debug.h \ + $(LANGHOOKS_DEF_H) libfuncs.h $(OPTABS_H) ada/gcc-interface/ada.h \ + ada/types.h \ + ada/atree.h ada/nlists.h ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h \ + ada/stringt.h ada/uintp.h ada/fe.h $(ADA_TREE_H) ada/gcc-interface/gigi.h \ + ada/adadecode.h opts.h options.h $(TARGET_H) $(REAL_H) + $(CC) -c $(ALL_CFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + + ada/targtyps.o : ada/gcc-interface/targtyps.c $(CONFIG_H) $(SYSTEM_H) \ + coretypes.h $(TM_H) \ + $(TREE_H) ada/gcc-interface/ada.h ada/types.h ada/atree.h ada/nlists.h \ + ada/elists.h \ + ada/uintp.h ada/sinfo.h ada/einfo.h ada/namet.h ada/snames.h ada/stringt.h \ + ada/urealp.h ada/fe.h $(ADA_TREE_H) ada/gcc-interface/gigi.h + $(CC) -c $(ALL_CFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + + ada/trans.o : ada/gcc-interface/trans.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) \ + $(TREE_H) $(RTL_H) $(EXPR_H) $(FLAGS_H) $(FUNCTION_H) \ + ada/gcc-interface/ada.h except.h \ + ada/types.h ada/atree.h ada/nlists.h ada/elists.h ada/uintp.h ada/sinfo.h \ + ada/einfo.h ada/namet.h ada/snames.h ada/stringt.h ada/urealp.h ada/fe.h \ + $(ADA_TREE_H) ada/gcc-interface/gigi.h gt-ada-trans.h tree-iterator.h + $(CC) -c $(ALL_CFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + + ada/utils.o : ada/gcc-interface/utils.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) \ + $(TREE_H) $(FLAGS_H) $(EXPR_H) convert.h defaults.h langhooks.h \ + ada/gcc-interface/ada.h ada/types.h \ + ada/atree.h ada/nlists.h ada/elists.h ada/sinfo.h \ + ada/einfo.h ada/namet.h ada/stringt.h ada/uintp.h ada/fe.h $(ADA_TREE_H) \ + ada/gcc-interface/gigi.h gt-ada-utils.h \ + gtype-ada.h $(TARGET_H) tree-iterator.h + $(CC) -c $(ALL_CFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + + ada/utils2.o : ada/gcc-interface/utils2.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) $(FLAGS_H) ada/gcc-interface/ada.h ada/types.h \ + ada/atree.h ada/nlists.h ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h \ + ada/snames.h ada/stringt.h ada/uintp.h ada/fe.h $(ADA_TREE_H) \ + ada/gcc-interface/gigi.h + $(CC) -c $(ALL_CFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + + # + # DO NOT PUT SPECIAL RULES BELOW, THIS SECTION IS UPDATED AUTOMATICALLY + # + # GNAT DEPENDENCIES + # regular dependencies + ada/a-charac.o : ada/ada.ads ada/a-charac.ads ada/system.ads + + ada/a-chlat1.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \ + ada/system.ads + + ada/a-clrefi.o : ada/ada.ads ada/a-comlin.ads ada/a-clrefi.ads \ + ada/a-clrefi.adb ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads + + ada/a-comlin.o : ada/ada.ads ada/a-comlin.ads ada/a-comlin.adb \ + ada/a-unccon.ads ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \ + ada/s-stoele.adb + + ada/a-elchha.o : ada/ada.ads ada/a-except.ads ada/a-elchha.ads \ + ada/a-elchha.adb ada/a-unccon.ads ada/system.ads ada/s-parame.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-traent.ads + + ada/a-except.o : ada/ada.ads ada/a-except.ads ada/a-except.adb \ + ada/a-exexda.adb ada/a-exextr.adb ada/a-elchha.ads ada/a-excpol.adb \ + ada/a-exstat.adb ada/a-unccon.ads ada/system.ads ada/s-exctab.ads \ + ada/s-except.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-traent.ads + + ada/a-ioexce.o : ada/ada.ads ada/a-except.ads ada/a-ioexce.ads \ + ada/a-unccon.ads ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads + + ada/ada.o : ada/ada.ads ada/system.ads + + ada/ali-util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/ali.ads ada/ali-util.ads ada/ali-util.adb \ + ada/alloc.ads ada/binderr.ads ada/casing.ads ada/csets.ads \ + ada/debug.ads ada/err_vars.ads ada/gnat.ads ada/g-htable.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ + ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ + ada/scans.ads ada/scng.ads ada/scng.adb ada/sinput.ads ada/sinput.adb \ + ada/sinput-c.ads ada/snames.ads ada/stringt.ads ada/stringt.adb \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ + ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-utf_32.adb ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/widechar.ads + + ada/ali.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/ali.ads ada/ali.adb ada/alloc.ads ada/butil.ads ada/casing.ads \ + ada/debug.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ + ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ + ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-htable.adb ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/widechar.ads + + ada/alloc.o : ada/alloc.ads ada/system.ads + + ada/atree.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/interfac.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/back_end.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/back_end.ads ada/back_end.adb ada/casing.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/fname.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/osint.ads ada/osint-c.ads \ + ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/switch.ads ada/switch-c.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/bcheck.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/ali.ads ada/ali-util.ads ada/ali-util.adb \ + ada/alloc.ads ada/bcheck.ads ada/bcheck.adb ada/binderr.ads \ + ada/butil.ads ada/casing.ads ada/csets.ads ada/debug.ads \ + ada/err_vars.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ + ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ + ada/scans.ads ada/scng.ads ada/scng.adb ada/sinput.ads ada/sinput-c.ads \ + ada/snames.ads ada/stringt.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + + ada/binde.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/ali.ads ada/alloc.ads ada/binde.ads ada/binde.adb \ + ada/binderr.ads ada/butil.ads ada/casing.ads ada/debug.ads \ + ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads \ + ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ + ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads ada/system.ads \ + ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/widechar.ads + + ada/binderr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/binderr.ads ada/binderr.adb \ + ada/butil.ads ada/debug.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \ + ada/output.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + + ada/bindgen.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/ali.ads ada/alloc.ads ada/binde.ads \ + ada/bindgen.ads ada/bindgen.adb ada/casing.ads ada/debug.ads \ + ada/fname.ads ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \ + ada/osint.ads ada/osint-b.ads ada/output.ads ada/rident.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/bindusg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/bindusg.ads ada/bindusg.adb \ + ada/debug.ads ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads \ + ada/output.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + + ada/butil.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/butil.ads ada/butil.adb \ + ada/debug.ads ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ + ada/rident.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/casing.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/casing.adb \ + ada/csets.ads ada/csets.adb ada/debug.ads ada/hostparm.ads \ + ada/namet.ads ada/opt.ads ada/output.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads + + ada/checks.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ + ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ + ada/sem.ads ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads + + ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/comperr.ads ada/comperr.adb ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/fname.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/osint.ads ada/output.ads \ + ada/output.adb ada/rident.ads ada/sdefault.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/treepr.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + + ada/csets.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/csets.ads \ + ada/csets.adb ada/debug.ads ada/hostparm.ads ada/opt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/cstand.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/cstand.ads \ + ada/cstand.adb ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/layout.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads \ + ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads + + ada/debug.o : ada/debug.ads ada/debug.adb ada/system.ads + + ada/debug_a.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/debug_a.ads ada/debug_a.adb \ + ada/einfo.ads ada/elists.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + + ada/einfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/snames.adb \ + ada/stand.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + + ada/elists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/elists.ads \ + ada/elists.adb ada/hostparm.ads ada/opt.ads ada/output.ads \ + ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/err_vars.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/err_vars.ads \ + ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ + ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads + + ada/errout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/err_vars.ads ada/errout.ads ada/errout.adb \ + ada/erroutc.ads ada/fname.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/scans.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/erroutc.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ + ada/err_vars.ads ada/erroutc.ads ada/erroutc.adb ada/hostparm.ads \ + ada/namet.ads ada/opt.ads ada/output.ads ada/output.adb ada/rident.ads \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads + + ada/eval_fat.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/eval_fat.adb ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads \ + ada/output.ads ada/rident.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/ttypef.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb + + ada/exp_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_aggr.ads ada/exp_aggr.adb ada/exp_ch11.ads ada/exp_ch2.ads \ + ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads \ + ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/expander.ads ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ + ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads ada/widechar.ads + + ada/exp_atag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ + ada/exp_atag.adb ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dist.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ + ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads \ + ada/lib-load.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/sem.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + + ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ + ada/exp_attr.ads ada/exp_attr.adb ada/exp_ch2.ads ada/exp_ch3.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_imgv.ads \ + ada/exp_pakd.ads ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/exp_vfpt.ads ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ + ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads + + ada/exp_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/casing.adb ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_ch11.adb \ + ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ + ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_ch8.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/exp_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/exp_ch12.ads ada/exp_ch12.adb ada/exp_tss.ads \ + ada/exp_util.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + + ada/exp_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/exp_ch13.ads ada/exp_ch13.adb ada/exp_ch3.ads \ + ada/exp_ch6.ads ada/exp_imgv.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + + ada/exp_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_ch2.ads ada/exp_ch2.adb ada/exp_smem.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_vfpt.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/rtsfind.ads \ + ada/sem.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ + ada/exp_ch3.ads ada/exp_ch3.adb ada/exp_ch4.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads ada/exp_dist.ads \ + ada/exp_pakd.ads ada/exp_smem.ads ada/exp_strm.ads ada/exp_tss.ads \ + ada/exp_tss.adb ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ + ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads + + ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ + ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch4.adb ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads ada/exp_dist.ads \ + ada/exp_fixd.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/exp_vfpt.ads ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads \ + ada/lib-load.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ + ada/sem.ads ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_dist.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/urealp.adb ada/validsw.ads + + ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ + ada/exp_ch5.ads ada/exp_ch5.adb ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_dbug.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_attr.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + + ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ + ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch6.adb ada/exp_ch7.ads \ + ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_disp.ads ada/exp_dist.ads \ + ada/exp_intr.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_ch12.ads \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \ + ada/sem_mech.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads + + ada/exp_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_ch7.adb ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_disp.ads \ + ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_ch3.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + + ada/exp_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_aggr.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch8.ads \ + ada/exp_ch8.adb ada/exp_dbug.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ + ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/sem.ads ada/sem_ch8.ads ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + + ada/exp_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_ch11.ads \ + ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads \ + ada/exp_ch9.adb ada/exp_dbug.ads ada/exp_sel.ads ada/exp_smem.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_attr.ads ada/sem_ch11.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads + + ada/exp_code.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/eval_fat.ads ada/exp_code.ads ada/exp_code.adb \ + ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ + ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/widechar.ads + + ada/exp_dbug.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/exp_dbug.ads ada/exp_dbug.adb ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/widechar.ads + + ada/exp_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_disp.ads \ + ada/exp_disp.adb ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads \ + ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_attr.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + + ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/exp_atag.ads ada/exp_dist.ads ada/exp_dist.adb \ + ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads \ + ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/exp_fixd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_fixd.ads ada/exp_fixd.adb ada/exp_tss.ads \ + ada/exp_util.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb + + ada/exp_imgv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_dist.ads ada/exp_imgv.ads ada/exp_imgv.adb \ + ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/fname-uf.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-load.ads ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ + ada/sem.ads ada/sem_ch7.ads ada/sem_dist.ads ada/sem_res.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + + ada/exp_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads \ + ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_code.ads \ + ada/exp_fixd.ads ada/exp_intr.ads ada/exp_intr.adb ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads + + ada/exp_pakd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads \ + ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_dbug.ads ada/exp_pakd.ads ada/exp_pakd.adb ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/itypes.ads ada/layout.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads + + ada/exp_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/casing.adb ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_ch11.ads ada/exp_prag.ads ada/exp_prag.adb \ + ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ + ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/exp_sel.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/exp_sel.ads ada/exp_sel.adb ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/exp_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/exp_smem.ads ada/exp_smem.adb ada/exp_tss.ads ada/exp_util.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + + ada/exp_strm.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/exp_strm.ads ada/exp_strm.adb ada/exp_tss.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/exp_tss.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads ada/fname.ads \ + ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/exp_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ + ada/fname.ads ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads + + ada/exp_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/exp_vfpt.ads ada/exp_vfpt.adb ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/rtsfind.ads \ + ada/sem_res.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tree_io.ads ada/ttypef.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/urealp.adb + + ada/expander.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/debug_a.ads ada/debug_a.adb \ + ada/einfo.ads ada/elists.ads ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_aggr.ads ada/exp_attr.ads ada/exp_ch11.ads \ + ada/exp_ch12.ads ada/exp_ch13.ads ada/exp_ch2.ads ada/exp_ch3.ads \ + ada/exp_ch4.ads ada/exp_ch5.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_ch8.ads ada/exp_ch9.ads ada/exp_prag.ads ada/expander.ads \ + ada/expander.adb ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads \ + ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch8.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + + ada/fmap.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fmap.ads ada/fmap.adb \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ + ada/opt.ads ada/osint.ads ada/output.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/fname-uf.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ + ada/fmap.ads ada/fname.ads ada/fname-uf.ads ada/fname-uf.adb \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/krunch.ads \ + ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads + + ada/fname.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fname.ads \ + ada/fname.adb ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ + ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/freeze.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_aggr.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ + ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ + ada/expander.ads ada/fname.ads ada/freeze.ads ada/freeze.adb \ + ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/interfac.ads ada/itypes.ads ada/layout.ads \ + ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch4.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_intr.ads \ + ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_res.adb \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads + + ada/frontend.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/cstand.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_dbug.ads \ + ada/fmap.ads ada/fname.ads ada/fname-uf.ads ada/frontend.ads \ + ada/frontend.adb ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb \ + ada/live.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/osint.ads ada/output.ads ada/par.ads \ + ada/prepcomp.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_aux.ads ada/sem_ch8.ads ada/sem_elab.ads ada/sem_prag.ads \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/sinput-l.ads ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/g-byorma.o : ada/gnat.ads ada/g-byorma.ads ada/g-byorma.adb \ + ada/system.ads + + ada/g-hesora.o : ada/gnat.ads ada/g-hesora.ads ada/g-hesora.adb \ + ada/system.ads + + ada/g-htable.o : ada/gnat.ads ada/g-htable.ads ada/g-htable.adb \ + ada/system.ads ada/s-htable.ads + + ada/g-spchge.o : ada/gnat.ads ada/g-spchge.ads ada/g-spchge.adb \ + ada/system.ads + + ada/g-speche.o : ada/gnat.ads ada/g-speche.ads ada/g-speche.adb \ + ada/g-spchge.ads ada/g-spchge.adb ada/system.ads + + ada/g-u3spch.o : ada/gnat.ads ada/g-spchge.ads ada/g-spchge.adb \ + ada/g-u3spch.ads ada/g-u3spch.adb ada/system.ads ada/s-wchcnv.ads \ + ada/s-wchcon.ads + + ada/get_targ.o : ada/ada.ads ada/a-unccon.ads ada/get_targ.ads \ + ada/get_targ.adb ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \ + ada/s-unstyp.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/gnat.o : ada/gnat.ads ada/system.ads + + ada/gnat1drv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/back_end.ads ada/casing.ads ada/comperr.ads ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fmap.ads \ + ada/fname.ads ada/fname-uf.ads ada/frontend.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/gnat1drv.ads \ + ada/gnat1drv.adb ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/osint.ads ada/output.ads \ + ada/prepcomp.ads ada/repinfo.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/sem.ads ada/sem_ch12.ads ada/sem_ch13.ads \ + ada/sem_ch8.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_type.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/sinput-l.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_gen.ads \ + ada/tree_io.ads ada/treepr.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/usage.ads ada/widechar.ads + + ada/gnatbind.o : ada/ada.ads ada/a-comlin.ads ada/a-clrefi.ads \ + ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads ada/ali.ads \ + ada/ali-util.ads ada/alloc.ads ada/bcheck.ads ada/binde.ads \ + ada/binderr.ads ada/bindgen.ads ada/bindusg.ads ada/butil.ads \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/fmap.ads ada/fname.ads \ + ada/gnat.ads ada/g-htable.ads ada/gnatbind.ads ada/gnatbind.adb \ + ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \ + ada/osint.ads ada/osint-b.ads ada/output.ads ada/rident.ads \ + ada/snames.ads ada/switch.ads ada/switch.adb ada/switch-b.ads \ + ada/system.ads ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ + ada/unchconv.ads ada/unchdeal.ads + + ada/gnatvsn.o : ada/ada.ads ada/a-unccon.ads ada/gnatvsn.ads \ + ada/gnatvsn.adb ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \ + ada/s-stoele.adb + + ada/hlo.o : ada/ada.ads ada/a-unccon.ads ada/hlo.ads ada/hlo.adb \ + ada/hostparm.ads ada/output.ads ada/system.ads ada/s-exctab.ads \ + ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-unstyp.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + + ada/hostparm.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \ + ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-unstyp.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/impunit.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/impunit.ads ada/impunit.adb \ + ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/inline.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_ch7.ads ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads \ + ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/inline.adb \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch8.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/instpar.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/instpar.ads ada/instpar.adb \ + ada/interfac.ads ada/namet.ads ada/opt.ads ada/output.ads \ + ada/sdefault.ads ada/sinput.ads ada/sinput.adb ada/sinput-l.ads \ + ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/widechar.ads + + ada/interfac.o : ada/interfac.ads ada/system.ads + + ada/itypes.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/itypes.ads \ + ada/itypes.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads ada/sem.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + + ada/krunch.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \ + ada/krunch.ads ada/krunch.adb ada/system.ads ada/s-exctab.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-unstyp.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/layout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_ch3.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/layout.ads \ + ada/layout.adb ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/repinfo.ads ada/repinfo.adb ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_ch13.ads \ + ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/lib-load.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib-load.ads \ + ada/lib-load.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/osint.ads ada/osint-c.ads \ + ada/output.ads ada/par.ads ada/restrict.ads ada/rident.ads \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/sinput-l.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/lib-util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ + ada/lib.ads ada/lib-util.ads ada/lib-util.adb ada/namet.ads ada/opt.ads \ + ada/osint.ads ada/osint-c.ads ada/output.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + + ada/lib-writ.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/ali.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib-util.ads ada/lib-util.adb ada/lib-writ.ads ada/lib-writ.adb \ + ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/osint.ads ada/osint-c.ads \ + ada/output.ads ada/par.ads ada/restrict.ads ada/rident.ads \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ + ada/system.ads ada/s-casuti.ads ada/s-carun8.ads ada/s-crc32.ads \ + ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \ + ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/lib-xref.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/gnat.ads ada/g-hesorg.ads ada/g-hesorg.adb \ + ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/lib-util.ads \ + ada/lib-util.adb ada/lib-xref.ads ada/lib-xref.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/osint.ads \ + ada/osint-c.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/sem.ads ada/sem_prag.ads ada/sem_util.ads ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/lib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/fname.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-hesorg.adb ada/g-htable.ads ada/hostparm.ads \ + ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + + ada/live.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/live.ads ada/live.adb ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/namet-sp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ + ada/g-u3spch.ads ada/hostparm.ads ada/namet.ads ada/namet-sp.ads \ + ada/namet-sp.adb ada/opt.ads ada/output.ads ada/system.ads \ + ada/s-carun8.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcnv.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb \ + ada/unchconv.ads ada/unchdeal.ads + + ada/namet.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ + ada/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \ + ada/system.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/types.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/widechar.ads + + ada/nlists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + + ada/nmake.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/opt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/debug.ads ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads ada/opt.adb \ + ada/system.ads ada/s-exctab.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/tree_io.ads ada/types.ads \ + ada/unchconv.ads ada/unchdeal.ads + + ada/osint-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ + ada/namet.ads ada/opt.ads ada/osint.ads ada/osint-b.ads ada/osint-b.adb \ + ada/output.ads ada/rident.ads ada/system.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + + ada/osint-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ + ada/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads \ + ada/osint-c.ads ada/osint-c.adb ada/output.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/widechar.ads + + ada/osint.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fmap.ads ada/gnat.ads \ + ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \ + ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads ada/osint.adb \ + ada/output.ads ada/rident.ads ada/sdefault.ads ada/system.ads \ + ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/widechar.ads + + ada/output.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/hostparm.ads ada/output.ads ada/output.adb ada/system.ads \ + ada/s-exctab.ads ada/s-os_lib.ads ada/s-stalib.ads ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-unstyp.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/par.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ + ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/g-speche.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb \ + ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/osint.ads \ + ada/output.ads ada/par.ads ada/par.adb ada/par-ch10.adb \ + ada/par-ch11.adb ada/par-ch12.adb ada/par-ch13.adb ada/par-ch2.adb \ + ada/par-ch3.adb ada/par-ch4.adb ada/par-ch5.adb ada/par-ch6.adb \ + ada/par-ch7.adb ada/par-ch8.adb ada/par-ch9.adb ada/par-endh.adb \ + ada/par-labl.adb ada/par-load.adb ada/par-prag.adb ada/par-sync.adb \ + ada/par-tchk.adb ada/par-util.adb ada/restrict.ads ada/rident.ads \ + ada/scans.ads ada/scans.adb ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ + ada/sinput.adb ada/sinput-l.ads ada/snames.ads ada/snames.adb \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ + ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb \ + ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads + + ada/prep.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \ + ada/debug.ads ada/err_vars.ads ada/gnat.ads ada/g-dyntab.ads \ + ada/g-dyntab.adb ada/g-hesorg.ads ada/g-hesorg.adb ada/hostparm.ads \ + ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/prep.ads \ + ada/prep.adb ada/scans.ads ada/sinput.ads ada/snames.ads \ + ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-carun8.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + + ada/prepcomp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \ + ada/debug.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/gnat.ads ada/g-dyntab.ads ada/g-dyntab.adb ada/g-hesorg.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib-writ.ads \ + ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/prep.ads \ + ada/prepcomp.ads ada/prepcomp.adb ada/scans.ads ada/scn.ads \ + ada/scng.ads ada/scng.adb ada/sinput.ads ada/sinput.adb \ + ada/sinput-l.ads ada/snames.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-crc32.adb \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/repinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/opt.ads ada/output.ads ada/output.adb ada/repinfo.ads \ + ada/repinfo.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/restrict.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ + ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/rident.o : ada/rident.ads ada/system.ads ada/s-rident.ads + + ada/rtsfind.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_dist.ads ada/fname.ads ada/fname-uf.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-load.ads ada/lib-sort.adb ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ + ada/rtsfind.adb ada/sem.ads ada/sem_ch7.ads ada/sem_dist.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + + ada/s-addope.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-addope.ads ada/s-addope.adb + + ada/s-assert.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/system.ads ada/s-assert.ads ada/s-assert.adb ada/s-exctab.ads \ + ada/s-exctab.adb ada/s-except.ads ada/s-htable.ads ada/s-parame.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-traent.ads + + ada/s-carun8.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-addope.ads ada/s-addope.adb ada/s-carun8.ads ada/s-carun8.adb \ + ada/s-stoele.ads ada/s-stoele.adb + + ada/s-casuti.o : ada/system.ads ada/s-casuti.ads ada/s-casuti.adb + + ada/s-crc32.o : ada/interfac.ads ada/system.ads ada/s-crc32.ads \ + ada/s-crc32.adb + + ada/s-crtl.o : ada/system.ads ada/s-crtl.ads ada/s-parame.ads + + ada/s-except.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-except.ads ada/s-except.adb ada/s-stalib.ads + + ada/s-exctab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-htable.adb ada/s-parame.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-traent.ads + + ada/s-htable.o : ada/ada.ads ada/a-uncdea.ads ada/system.ads \ + ada/s-htable.ads ada/s-htable.adb + + ada/s-imenne.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-imenne.ads ada/s-imenne.adb ada/s-stoele.ads ada/s-stoele.adb + + ada/s-imgenu.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-imgenu.ads ada/s-imgenu.adb ada/s-secsta.ads ada/s-stoele.ads \ + ada/s-stoele.adb + + ada/s-mastop.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-mastop.ads ada/s-mastop.adb ada/s-stoele.ads ada/s-stoele.adb + + ada/s-memory.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/system.ads ada/s-crtl.ads ada/s-memory.ads ada/s-memory.adb \ + ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads + + ada/s-os_lib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/system.ads ada/s-casuti.ads ada/s-crtl.ads \ + ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-os_lib.ads \ + ada/s-os_lib.adb ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads + + ada/s-parame.o : ada/system.ads ada/s-parame.ads ada/s-parame.adb + + ada/s-purexc.o : ada/system.ads ada/s-purexc.ads + + ada/s-restri.o : ada/system.ads ada/s-restri.ads ada/s-restri.adb \ + ada/s-rident.ads + + ada/s-secsta.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/system.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-secsta.adb ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads + + ada/s-soflin.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/system.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-soflin.adb ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-traent.ads + + ada/s-sopco3.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco3.adb ada/s-sopco4.ads ada/s-sopco5.ads + + ada/s-sopco4.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco4.adb ada/s-sopco5.ads + + ada/s-sopco5.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-sopco5.adb + + ada/s-stache.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-stache.ads ada/s-stache.adb ada/s-stoele.ads ada/s-stoele.adb + + ada/s-stalib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/system.ads ada/s-memory.ads ada/s-parame.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stalib.adb ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-traent.ads + + ada/s-stoele.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-stoele.ads ada/s-stoele.adb + + ada/s-strcom.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-strcom.ads ada/s-strcom.adb + + ada/s-string.o : ada/ada.ads ada/a-uncdea.ads ada/system.ads \ + ada/s-string.ads ada/s-string.adb + + ada/s-strops.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-strops.adb + + ada/s-traceb.o : ada/system.ads ada/s-traceb.ads ada/s-traceb.adb + + ada/s-traent.o : ada/system.ads ada/s-traent.ads ada/s-traent.adb + + ada/s-unstyp.o : ada/system.ads ada/s-unstyp.ads + + ada/s-utf_32.o : ada/system.ads ada/s-utf_32.ads ada/s-utf_32.adb + + ada/s-wchcnv.o : ada/interfac.ads ada/system.ads ada/s-wchcnv.ads \ + ada/s-wchcnv.adb ada/s-wchcon.ads ada/s-wchjis.ads + + ada/s-wchcon.o : ada/system.ads ada/s-wchcon.ads ada/s-wchcon.adb + + ada/s-wchjis.o : ada/system.ads ada/s-wchjis.ads ada/s-wchjis.adb + + ada/scans.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ + ada/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \ + ada/scans.ads ada/scans.adb ada/snames.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/scn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/elists.ads ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/gnat.ads ada/g-byorma.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/scans.ads ada/scn.ads ada/scn.adb \ + ada/scng.ads ada/scng.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ + ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ + ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-utf_32.adb ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/urealp.adb ada/widechar.ads + + ada/scng.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \ + ada/debug.ads ada/err_vars.ads ada/hostparm.ads ada/interfac.ads \ + ada/namet.ads ada/opt.ads ada/output.ads ada/scans.ads ada/scng.ads \ + ada/scng.adb ada/sinput.ads ada/snames.ads ada/stringt.ads \ + ada/styleg.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/sem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/debug.ads \ + ada/debug_a.ads ada/debug_a.adb ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_tss.ads ada/expander.ads ada/fname.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hlo.ads ada/hostparm.ads \ + ada/inline.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-load.ads ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/sem.ads ada/sem.adb \ + ada/sem_attr.ads ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads \ + ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch2.adb ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_prag.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + + ada/sem_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/fname.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ + ada/sem_aggr.adb ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch13.ads \ + ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads ada/widechar.ads + + ada/sem_attr.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \ + ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads ada/alloc.ads \ + ada/atree.ads ada/atree.adb ada/casing.ads ada/checks.ads \ + ada/checks.adb ada/csets.ads ada/debug.ads ada/debug_a.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads \ + ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads \ + ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sdefault.ads \ + ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_attr.adb \ + ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads \ + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/snames.adb ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ + ada/s-carun8.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypef.ads ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/validsw.ads ada/widechar.ads + + ada/sem_aux.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ + ada/opt.ads ada/output.ads ada/sem_aux.ads ada/sem_aux.adb \ + ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/sem_case.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-hesorg.adb ada/g-htable.ads ada/hostparm.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/sem.ads ada/sem_case.ads \ + ada/sem_case.adb ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/sem_cat.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_cat.adb \ + ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/sem_ch10.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/impunit.ads ada/inline.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_ch10.ads \ + ada/sem_ch10.adb ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/sem_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_code.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ + ada/sem.ads ada/sem_aux.ads ada/sem_ch11.ads ada/sem_ch11.adb \ + ada/sem_ch5.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_util.ads ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/sem_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_dist.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/expander.ads ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ + ada/rtsfind.adb ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch10.ads \ + ada/sem_ch12.ads ada/sem_ch12.adb ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ + ada/sinput.ads ada/sinput-l.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-htable.adb \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads + + ada/sem_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-hesorg.adb ada/g-htable.ads ada/hostparm.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ + ada/sem.ads ada/sem_ch13.ads ada/sem_ch13.adb ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb + + ada/sem_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/sem_ch2.ads ada/sem_ch2.adb ada/sem_ch8.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/sem_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch3.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dist.ads ada/exp_pakd.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ + ada/sem_case.ads ada/sem_case.adb ada/sem_cat.ads ada/sem_cat.adb \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch3.adb ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_mech.ads \ + ada/sem_res.ads ada/sem_smem.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/urealp.adb ada/validsw.ads ada/widechar.ads + + ada/sem_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/expander.ads ada/fname.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch4.ads \ + ada/sem_ch4.adb ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_intr.ads \ + ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ + ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_code.ads ada/exp_disp.ads ada/exp_pakd.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_case.ads ada/sem_case.adb \ + ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ + ada/sem_ch5.adb ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + + ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_ch9.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch10.ads \ + ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ + ada/sem_ch6.ads ada/sem_ch6.adb ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_mech.ads \ + ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/snames.adb ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ + ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads + + ada/sem_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_dbug.ads ada/exp_disp.ads \ + ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_cat.ads \ + ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch7.adb ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/snames.adb ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + + ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/expander.ads ada/fname.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/impunit.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \ + ada/sem_cat.ads ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch4.ads \ + ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_ch8.adb ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_intr.ads \ + ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ + ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads ada/exp_pakd.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/sem_ch9.ads ada/sem_ch9.adb ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_elab.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_res.ads \ + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads + + ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_disp.ads \ + ada/exp_disp.adb ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_disp.adb ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + + ada/sem_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_dist.ads \ + ada/exp_tss.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_dist.adb ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/system.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tbuild.ads ada/tree_io.ads ada/types.ads \ + ada/types.adb ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + + ada/sem_elab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ + ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/sem_elab.ads ada/sem_elab.adb ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + + ada/sem_elim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/output.ads ada/sem_elim.ads \ + ada/sem_elim.adb ada/sem_prag.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch4.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads \ + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/widechar.ads + + ada/sem_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/rident.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_intr.adb \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + + ada/sem_maps.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ + ada/sem_maps.ads ada/sem_maps.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/sem_mech.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads \ + ada/sem.ads ada/sem_mech.ads ada/sem_mech.adb ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/sem_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ + ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_mech.ads \ + ada/sem_prag.ads ada/sem_prag.adb ada/sem_res.ads ada/sem_res.adb \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_vfpt.ads \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ + ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/validsw.ads ada/widechar.ads + + ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ + ada/debug.ads ada/debug_a.ads ada/debug_a.adb ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads \ + ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ + ada/widechar.ads + + ada/sem_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/output.ads ada/sem_smem.ads \ + ada/sem_smem.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/sem_type.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_ch12.ads \ + ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_type.adb \ + ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/sem_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/casing.adb ada/checks.ads ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ + ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ + ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads + + ada/sem_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/cstand.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ + ada/rident.ads ada/sem_vfpt.ads ada/sem_vfpt.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/ttypef.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/sem_warn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_code.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + + ada/sinfo-cn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads \ + ada/sinfo-cn.ads ada/sinfo-cn.adb ada/sinput.ads ada/snames.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/sinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/sinput-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ + ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ + ada/sinput.ads ada/sinput-c.ads ada/sinput-c.adb ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + + ada/sinput-d.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ + ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads \ + ada/osint-c.ads ada/output.ads ada/sinput.ads ada/sinput-d.ads \ + ada/sinput-d.adb ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + + ada/sinput-l.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ + ada/g-dyntab.ads ada/g-dyntab.adb ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/osint.ads ada/output.ads ada/prep.ads \ + ada/prepcomp.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput-l.ads \ + ada/sinput-l.adb ada/snames.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/sinput.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ + ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ + ada/opt.ads ada/output.ads ada/sinput.ads ada/sinput.adb ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads + + ada/snames.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ + ada/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \ + ada/snames.ads ada/snames.adb ada/system.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/widechar.ads + + ada/sprint.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/fname.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads \ + ada/output.ads ada/output.adb ada/rtsfind.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/sinput-d.ads ada/snames.ads ada/sprint.ads ada/sprint.adb \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/widechar.ads + + ada/stand.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ + ada/namet.ads ada/opt.ads ada/output.ads ada/stand.ads ada/stand.adb \ + ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/stringt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ + ada/namet.ads ada/opt.ads ada/output.ads ada/stringt.ads \ + ada/stringt.adb ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/types.adb ada/unchconv.ads \ + ada/unchdeal.ads + + ada/style.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ + ada/scans.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/styleg-c.ads ada/styleg-c.adb ada/stylesw.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/styleg-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/casing.ads \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/err_vars.ads \ + ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads ada/sinfo.ads \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/styleg.ads \ + ada/styleg-c.ads ada/styleg-c.adb ada/stylesw.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + + ada/styleg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \ + ada/debug.ads ada/err_vars.ads ada/hostparm.ads ada/namet.ads \ + ada/opt.ads ada/output.ads ada/scans.ads ada/sinput.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/stylesw.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/debug.ads ada/hostparm.ads ada/opt.ads \ + ada/stylesw.ads ada/stylesw.adb ada/system.ads ada/s-exctab.ads \ + ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/types.ads \ + ada/unchconv.ads ada/unchdeal.ads + + ada/switch-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \ + ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \ + ada/switch.ads ada/switch-b.ads ada/switch-b.adb ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/switch-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \ + ada/hostparm.ads ada/lib.ads ada/namet.ads ada/opt.ads ada/osint.ads \ + ada/output.ads ada/prepcomp.ads ada/sem_warn.ads ada/stylesw.ads \ + ada/switch.ads ada/switch-c.ads ada/switch-c.adb ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/validsw.ads + + ada/switch.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \ + ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \ + ada/switch.ads ada/switch.adb ada/system.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/system.o : ada/system.ads + + ada/table.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/debug.ads \ + ada/hostparm.ads ada/opt.ads ada/output.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-stalib.ads \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + + ada/targparm.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/csets.ads ada/debug.ads \ + ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ + ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads ada/system.ads \ + ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/targparm.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/widechar.ads + + ada/tbuild.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/fname.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/tree_gen.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/casing.ads \ + ada/debug.ads ada/einfo.ads ada/elists.ads ada/fname.ads \ + ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ + ada/osint.ads ada/osint-c.ads ada/output.ads ada/repinfo.ads \ + ada/sem_aux.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_gen.ads ada/tree_gen.adb \ + ada/tree_in.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/tree_in.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/casing.ads \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/fname.ads \ + ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ + ada/output.ads ada/repinfo.ads ada/sem_aux.ads ada/sinfo.ads \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_in.ads ada/tree_in.adb ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + + ada/tree_io.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/debug.ads ada/hostparm.ads ada/output.ads \ + ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/tree_io.ads ada/tree_io.adb \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/treepr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/fname.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/output.adb \ + ada/sem_mech.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/treepr.ads \ + ada/treepr.adb ada/treeprs.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + + ada/treeprs.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ + ada/namet.ads ada/opt.ads ada/output.ads ada/sinfo.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/treeprs.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + + ada/ttypef.o : ada/system.ads ada/ttypef.ads + + ada/ttypes.o : ada/ada.ads ada/a-unccon.ads ada/get_targ.ads \ + ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \ + ada/ttypes.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + + ada/types.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/system.ads \ + ada/s-carun8.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \ + ada/types.ads ada/types.adb ada/unchconv.ads ada/unchdeal.ads + + ada/uintp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/opt.ads ada/output.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads + + ada/uname.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/uname.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + + ada/urealp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/opt.ads ada/output.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb + + ada/usage.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ + ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ + ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/usage.ads ada/usage.adb + + ada/validsw.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/debug.ads ada/hostparm.ads ada/opt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/validsw.ads ada/validsw.adb + + ada/widechar.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/debug.ads ada/hostparm.ads ada/interfac.ads \ + ada/opt.ads ada/system.ads ada/s-exctab.ads ada/s-parame.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcnv.ads ada/s-wchcnv.adb ada/s-wchcon.ads ada/s-wchjis.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads \ + ada/widechar.adb + + # end of regular dependencies diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/Makefile.in gcc-4.4.0/gcc/ada/gcc-interface/Makefile.in *** gcc-4.3.3/gcc/ada/gcc-interface/Makefile.in Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/Makefile.in Sat Feb 28 17:29:55 2009 *************** *** 0 **** --- 1,2371 ---- + # Makefile for GNU Ada Compiler (GNAT). + # Copyright (C) 1994-2009 Free Software Foundation, Inc. + + #This file is part of GCC. + + #GCC is free software; you can redistribute it and/or modify + #it under the terms of the GNU General Public License as published by + #the Free Software Foundation; either version 3, or (at your option) + #any later version. + + #GCC is distributed in the hope that it will be useful, + #but WITHOUT ANY WARRANTY; without even the implied warranty of + #MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + #GNU General Public License for more details. + + #You should have received a copy of the GNU General Public License + #along with GCC; see the file COPYING3. If not see + #. + + # The makefile built from this file lives in the language subdirectory. + # Its purpose is to provide support for: + # + # 1) recursion where necessary, and only then (building .o's), and + # 2) building and debugging cc1 from the language subdirectory, and + # 3) nothing else. + # + # The parent makefile handles all other chores, with help from the + # language makefile fragment, of course. + # + # The targets for external use are: + # all, TAGS, ???mostlyclean, ???clean. + + # This makefile will only work with Gnu make. + # The rules are written assuming a minimum subset of tools are available: + # + # Required: + # MAKE: Only Gnu make will work. + # MV: Must accept (at least) one, maybe wildcard, source argument, + # a file or directory destination, and support creation/ + # modification date preservation. Gnu mv -f works. + # RM: Must accept an arbitrary number of space separated file + # arguments, or one wildcard argument. Gnu rm works. + # RMDIR: Must delete a directory and all its contents. Gnu rm -rf works. + # ECHO: Must support command line redirection. Any Unix-like + # shell will typically provide this, otherwise a custom version + # is trivial to write. + # AR: Gnu ar works. + # MKDIR: Gnu mkdir works. + # CHMOD: Gnu chmod works. + # true: Does nothing and returns a normal successful return code. + # pwd: Prints the current directory on stdout. + # cd: Change directory. + # + # Optional: + # BISON: Gnu bison works. + # FLEX: Gnu flex works. + # Other miscellaneous tools for obscure targets. + + # Suppress smart makes who think they know how to automake Yacc files + .y.c: + + # Variables that exist for you to override. + # See below for how to change them for certain systems. + + # Various ways of specifying flags for compilations: + # CFLAGS is for the user to override to, e.g., do a bootstrap with -O2. + # BOOT_CFLAGS is the value of CFLAGS to pass + # to the stage2 and stage3 compilations + CFLAGS = -g + BOOT_CFLAGS = -O $(CFLAGS) + # These exists to be overridden by the t-* files, respectively. + T_CFLAGS = + + CC = cc + BISON = bison + BISONFLAGS = + ECHO = echo + LEX = flex + LEXFLAGS = + CHMOD = chmod + LN = ln + LN_S = ln -s + CP = cp -p + MV = mv -f + RM = rm -f + RMDIR = rm -rf + MKDIR = mkdir -p + AR = ar + AR_FLAGS = rc + LS = ls + RANLIB = @RANLIB@ + RANLIB_FLAGS = @ranlib_flags@ + AWK = @AWK@ + + SHELL = @SHELL@ + PWD_COMMAND = $${PWDCMD-pwd} + # How to copy preserving the date + INSTALL_DATA_DATE = cp -p + MAKEINFO = makeinfo + TEXI2DVI = texi2dvi + TEXI2PDF = texi2pdf + GNATBIND_FLAGS = -static -x + ADA_CFLAGS = + ADAFLAGS = -W -Wall -gnatpg -gnata + SOME_ADAFLAGS =-gnata + FORCE_DEBUG_ADAFLAGS = -g + GNATLIBFLAGS = -gnatpg -nostdinc + GNATLIBCFLAGS = -g -O2 + GNATLIBCFLAGS_FOR_C = $(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS) -fexceptions \ + -DIN_RTS + ALL_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) + MOST_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(SOME_ADAFLAGS) + THREAD_KIND = native + THREADSLIB = + GMEM_LIB = + MISCLIB = + SYMDEPS = $(LIBINTL_DEP) + OUTPUT_OPTION = @OUTPUT_OPTION@ + + objext = .o + exeext = + arext = .a + soext = .so + shext = + hyphen = - + + # Define this as & to perform parallel make on a Sequent. + # Note that this has some bugs, and it seems currently necessary + # to compile all the gen* files first by hand to avoid erroneous results. + P = + + # This is used instead of ALL_CFLAGS when compiling with GCC_FOR_TARGET. + # It specifies -B./. + # It also specifies -B$(tooldir)/ to find as and ld for a cross compiler. + GCC_CFLAGS = $(INTERNAL_CFLAGS) $(T_CFLAGS) $(CFLAGS) + + # Tools to use when building a cross-compiler. + # These are used because `configure' appends `cross-make' + # to the makefile when making a cross-compiler. + + # We don't use cross-make. Instead we use the tools from the build tree, + # if they are available. + # program_transform_name and objdir are set by configure.in. + program_transform_name = + objdir = . + + target_alias=@target_alias@ + target=@target@ + xmake_file = @xmake_file@ + tmake_file = @tmake_file@ + host_canonical=@host@ + target_cpu_default=@target_cpu_default@ + #version=`sed -e 's/.*\"\([^ \"]*\)[ \"].*/\1/' < $(srcdir)/version.c` + #mainversion=`sed -e 's/.*\"\([0-9]*\.[0-9]*\).*/\1/' < $(srcdir)/version.c` + + # Directory where sources are, from where we are. + VPATH = $(srcdir)/ada + + fsrcdir := $(shell cd $(srcdir);${PWD_COMMAND}) + fsrcpfx := $(shell cd $(srcdir);${PWD_COMMAND})/ + fcurdir := $(shell ${PWD_COMMAND}) + fcurpfx := $(shell ${PWD_COMMAND})/ + + # Top build directory, relative to here. + top_builddir = ../.. + + # Internationalization library. + LIBINTL = @LIBINTL@ + LIBINTL_DEP = @LIBINTL_DEP@ + + # Any system libraries needed just for GNAT. + SYSLIBS = @GNAT_LIBEXC@ + + # List of extra object files linked in with various programs. + EXTRA_GNATTOOLS_OBJS = ../../prefix.o ../../version.o + + # List of target dependent sources, overridden below as necessary + TARGET_ADA_SRCS = + + # Type of tools build we are doing; default is not compiling tools. + TOOLSCASE = + + # Multilib handling + MULTISUBDIR = + RTSDIR = rts$(subst /,_,$(MULTISUBDIR)) + + # End of variables for you to override. + + all: all.indirect + + # This tells GNU Make version 3 not to put all variables in the environment. + .NOEXPORT: + + # target overrides + ifneq ($(tmake_file),) + include $(tmake_file) + endif + + # host overrides + ifneq ($(xmake_file),) + include $(xmake_file) + endif + + # Now figure out from those variables how to compile and link. + + all.indirect: Makefile ../gnat1$(exeext) + + # IN_GCC distinguishes between code compiled into GCC itself and other + # programs built during a bootstrap. + # autoconf inserts -DCROSS_DIRECTORY_STRUCTURE if we are building a cross + # compiler which does not use the native libraries and headers. + INTERNAL_CFLAGS = @CROSS@ -DIN_GCC + + # This is the variable actually used when we compile. + LOOSE_CFLAGS = `echo $(CFLAGS) $(WARN2_CFLAGS)|sed -e 's/-pedantic//g' -e 's/-Wtraditional//g'` + ALL_CFLAGS = $(INTERNAL_CFLAGS) $(T_CFLAGS) $(LOOSE_CFLAGS) + + # Likewise. + ALL_CPPFLAGS = $(CPPFLAGS) + + # This is where we get libiberty.a from. + LIBIBERTY = ../../libiberty/libiberty.a + + # How to link with both our special library facilities + # and the system's installed libraries. + LIBS = $(LIBINTL) $(LIBIBERTY) $(SYSLIBS) + LIBDEPS = $(LIBINTL_DEP) $(LIBIBERTY) + # Default is no TGT_LIB; one might be passed down or something + TGT_LIB = + TOOLS_LIBS = $(EXTRA_GNATTOOLS_OBJS) targext.o link.o $(LIBGNAT) ../../../libiberty/libiberty.a $(SYSLIBS) $(TGT_LIB) + + # Specify the directories to be searched for header files. + # Both . and srcdir are used, in that order, + # so that tm.h and config.h will be found in the compilation + # subdirectory rather than in the source directory. + INCLUDES = -I- -I. -I.. -I$(srcdir)/ada -I$(srcdir) -I$(srcdir)/config \ + -I$(srcdir)/../include + + ADA_INCLUDES = -I- -I. -I$(srcdir)/ada + + INCLUDES_FOR_SUBDIR = -I. -I.. -I../.. -I$(fsrcdir)/ada -I$(fsrcdir)/config \ + -I$(fsrcdir)/../include -I$(fsrcdir) + ADA_INCLUDES_FOR_SUBDIR = -I. -I$(fsrcdir)/ada + + # Avoid a lot of time thinking about remaking Makefile.in and *.def. + .SUFFIXES: .in .def + + # Say how to compile Ada programs. + .SUFFIXES: .ada .adb .ads .asm + + # Always use -I$(srcdir)/config when compiling. + .asm.o: + $(CC) -c -x assembler $< $(OUTPUT_OPTION) + + .c.o: + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $< \ + $(OUTPUT_OPTION) + + .adb.o: + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + + .ads.o: + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + + # how to regenerate this file + Makefile: ../config.status $(srcdir)/ada/gcc-interface/Makefile.in $(srcdir)/ada/Makefile.in $(srcdir)/version.c + cd ..; \ + LANGUAGES="$(CONFIG_LANGUAGES)" \ + CONFIG_HEADERS= \ + CONFIG_FILES="ada/gcc-interface/Makefile ada/Makefile" $(SHELL) config.status + + # This tells GNU make version 3 not to export all the variables + # defined in this file into the environment. + .NOEXPORT: + + # Lists of files for various purposes. + + GNATLINK_OBJS = gnatlink.o \ + a-except.o ali.o alloc.o butil.o casing.o csets.o debug.o fmap.o fname.o \ + gnatvsn.o hostparm.o indepsw.o interfac.o i-c.o i-cstrin.o namet.o opt.o \ + osint.o output.o rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \ + sdefault.o snames.o stylesw.o switch.o system.o table.o targparm.o tree_io.o \ + types.o validsw.o widechar.o + + GNATMAKE_OBJS = a-except.o ali.o ali-util.o s-casuti.o \ + alloc.o atree.o binderr.o butil.o casing.o csets.o debug.o elists.o einfo.o\ + erroutc.o errutil.o err_vars.o fmap.o fname.o fname-uf.o fname-sf.o \ + gnatmake.o gnatvsn.o hostparm.o interfac.o i-c.o i-cstrin.o krunch.o lib.o \ + make.o makeusg.o makeutl.o mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o \ + mlib-tgt-specific.o mlib-utl.o namet.o nlists.o opt.o osint.o osint-m.o output.o \ + prj.o prj-attr.o prj-attr-pm.o prj-com.o prj-dect.o prj-env.o prj-err.o prj-ext.o prj-nmsc.o \ + prj-pars.o prj-part.o prj-proc.o prj-strt.o prj-tree.o prj-util.o \ + rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \ + scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o \ + sinfo.o sinput.o sinput-c.o sinput-p.o \ + snames.o stand.o stringt.o styleg.o stylesw.o system.o validsw.o switch.o switch-m.o \ + table.o targparm.o tempdir.o tree_io.o types.o \ + uintp.o uname.o urealp.o usage.o widechar.o \ + $(EXTRA_GNATMAKE_OBJS) + + # Convert the target variable into a space separated list of architecture, + # manufacturer, and operating system and assign each of those to its own + # variable. + + host:=$(subst -, ,$(host_canonical)) + targ:=$(subst -, ,$(target)) + arch:=$(word 1,$(targ)) + ifeq ($(words $(targ)),2) + manu:= + osys:=$(word 2,$(targ)) + else + manu:=$(word 2,$(targ)) + osys:=$(word 3,$(targ)) + endif + + # Make arch match the current multilib so that the RTS selection code + # picks up the right files. For a given target this must be coherent + # with MULTILIB_DIRNAMES defined in gcc/config/target/t-*. + + ifeq ($(strip $(filter-out %x86_64, $(arch))),) + ifeq ($(strip $(MULTISUBDIR)),/32) + arch:=i686 + endif + endif + + # ???: handle more multilib targets + + # LIBGNAT_TARGET_PAIRS is a list of pairs of filenames. + # The members of each pair must be separated by a '<' and no whitespace. + # Each pair must be separated by some amount of whitespace from the following + # pair. + + # Non-tasking case: + + LIBGNAT_TARGET_PAIRS = \ + a-intnam.ads $(RTSDIR)/s.ads + $(MV) $(RTSDIR)/s.ads $(RTSDIR)/system.ads + $(MAKE) $(FLAGS_TO_PASS) \ + EH_MECHANISM="" \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + MULTISUBDIR="$(MULTISUBDIR)" \ + THREAD_KIND="$(THREAD_KIND)" \ + TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib + + gnatlib-zcx: + $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="-gcc" ../stamp-gnatlib1-$(RTSDIR) + sed -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := True;/' $(RTSDIR)/system.ads > $(RTSDIR)/s.ads + $(MV) $(RTSDIR)/s.ads $(RTSDIR)/system.ads + $(MAKE) $(FLAGS_TO_PASS) \ + EH_MECHANISM="-gcc" \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + MULTISUBDIR="$(MULTISUBDIR)" \ + THREAD_KIND="$(THREAD_KIND)" \ + TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib + + # .s files for cross-building + gnat-cross: force + make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp" + + # Compiling object files from source files. + + # Note that dependencies on obstack.h are not written + # because that file is not part of GCC. + # Dependencies on gvarargs.h are not written + # because all that file does, when not compiling with GCC, + # is include the system varargs.h. + + b_gnatl.c : $(GNATLINK_OBJS) + $(GNATBIND) -C $(ADA_INCLUDES) -o b_gnatl.c gnatlink.ali + b_gnatl.o : b_gnatl.c + + b_gnatm.c : $(GNATMAKE_OBJS) + $(GNATBIND) -C $(ADA_INCLUDES) -o b_gnatm.c gnatmake.ali + b_gnatm.o : b_gnatm.c + + ADA_INCLUDE_DIR = $(libsubdir)/adainclude + ADA_RTL_OBJ_DIR = $(libsubdir)/adalib + + # force no sibling call optimization on s-traceb.o so the number of stack + # frames to be skipped when computing a call chain is not modified by + # optimization. However we can do that only when building the runtime + # (not the compiler) because the -fno-optimize-sibling-calls option exists + # only in GCC 3 and above. + + ifneq (,$(findstring xgcc,$(CC))) + NO_SIBLING_ADAFLAGS=-fno-optimize-sibling-calls + else + NO_SIBLING_ADAFLAGS= + endif + + s-traceb.o : s-traceb.adb + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) \ + $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) + + # force debugging information on s-tasdeb.o so that it is always + # possible to set conditional breakpoints on tasks. + + s-tasdeb.o : s-tasdeb.adb s-tasdeb.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) + + # force no function reordering on a-except.o because of the exclusion bounds + # mechanism (see the source file for more detailed information). However we + # can do that only when building the runtime (not the compiler) because the + # -fno-toplevel-reorder option exists only in GCC 4.2 and above. + + ifneq (,$(findstring xgcc,$(CC))) + NO_REORDER_ADAFLAGS=-fno-toplevel-reorder + else + NO_REORDER_ADAFLAGS= + endif + + # force debugging information on a-except.o so that it is always + # possible to set conditional breakpoints on exceptions. + # use -O1 otherwise gdb isn't able to get a full backtrace on mips targets. + + a-except.o : a-except.adb a-except.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \ + $(NO_REORDER_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + + # compile s-except.o without optimization and with debug info to let the + # debugger set breakpoints and inspect subprogram parameters on exception + # related events. + + s-except.o : s-except.adb s-except.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) + + # force debugging information on s-assert.o so that it is always + # possible to set breakpoint on assert failures. + + s-assert.o : s-assert.adb s-assert.ads a-except.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) + + adadecode.o : adadecode.c adadecode.h + aux-io.o : aux-io.c + argv.o : argv.c + cal.o : cal.c + deftarg.o : deftarg.c + errno.o : errno.c + exit.o : adaint.h exit.c + expect.o : expect.c + final.o : final.c + gmem.o : gmem.c + link.o : link.c + mkdir.o : mkdir.c + socket.o : socket.c gsocket.h + sysdep.o : sysdep.c + raise-gcc.o : raise-gcc.c raise.h + raise.o : raise.c raise.h + vx_stack_info.o : vx_stack_info.c + + cio.o : cio.c + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + + init.o : init.c adaint.h raise.h + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + + initialize.o : initialize.c raise.h + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + + targext.o : targext.c + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES_FOR_SUBDIR) \ + $< $(OUTPUT_OPTION) + + # No optimization to compile this file as optimizations (-O1 or above) breaks + # the SEH handling on Windows. The reasons are not clear. + seh_init.o : seh_init.c raise.h + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) -O0 \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + + # Need to keep the frame pointer in this file to pop the stack properly on + # some targets. + tracebak.o : tracebak.c tb-alvms.c tb-alvxw.c tb-gcc.c + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ + -fno-omit-frame-pointer $< $(OUTPUT_OPTION) + + # In GNU Make, ignore whether `stage*' exists. + .PHONY: stage1 stage2 stage3 stage4 clean realclean TAGS bootstrap + .PHONY: risky-stage1 risky-stage2 risky-stage3 risky-stage4 + + force: + + # Gnatlbr, Vms_help, and Gnat.hlp are only used on VMS + + ../../gnatlbr$(exeext): ../../prefix.o + $(GNATMAKE) -c $(ADA_INCLUDES) gnatlbr --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatlbr + $(GNATLINK) -v gnatlbr -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) + + ../../vms_help$(exeext): + $(GNATMAKE) -c $(ADA_INCLUDES) vms_help --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) vms_help + $(GNATLINK) -v vms_help -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) + + ../../gnat.hlp: ../../vms_help$(exeext) + ../../vms_help$(exeext) $(fsrcdir)/ada/gnat.help_in \ + $(fsrcdir)/ada/vms_data.ads ../../gnat.hlp diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/ada-tree.def gcc-4.4.0/gcc/ada/gcc-interface/ada-tree.def *** gcc-4.3.3/gcc/ada/gcc-interface/ada-tree.def Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/ada-tree.def Fri Feb 20 15:20:38 2009 *************** *** 0 **** --- 1,89 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * GNAT-SPECIFIC GCC TREE CODES * + * * + * Specification * + * * + * Copyright (C) 1992-2008, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + /* A type that is an unconstrained array itself. This node is never passed + to GCC. TREE_TYPE is the type of the fat pointer and TYPE_OBJECT_RECORD_TYPE + is the type of a record containing the template and data. */ + + DEFTREECODE (UNCONSTRAINED_ARRAY_TYPE, "unconstrained_array_type", tcc_type, 0) + + /* A reference to an unconstrained array. This node only exists as an + intermediate node during the translation of a GNAT tree to a GCC tree; + it is never passed to GCC. The only field used is operand 0, which + is the fat pointer object. */ + + DEFTREECODE (UNCONSTRAINED_ARRAY_REF, "unconstrained_array_ref", + tcc_reference, 1) + + /* An expression that returns an RTL suitable for its type. Operand 0 + is an expression to be evaluated for side effects only. */ + DEFTREECODE (NULL_EXPR, "null_expr", tcc_expression, 1) + + /* Same as PLUS_EXPR, except that no modulo reduction is applied. + This is used for loops and never shows up in the tree. */ + DEFTREECODE (PLUS_NOMOD_EXPR, "plus_nomod_expr", tcc_binary, 2) + + /* Same as MINUS_EXPR, except that no modulo reduction is applied. + This is used for loops and never shows up in the tree. */ + DEFTREECODE (MINUS_NOMOD_EXPR, "minus_nomod_expr", tcc_binary, 2) + + /* Same as ADDR_EXPR, except that if the operand represents a bit field, + return the address of the byte containing the bit. This is used + for the 'Address attribute and never shows up in the tree. */ + DEFTREECODE (ATTR_ADDR_EXPR, "attr_addr_expr", tcc_reference, 1) + + /* Here are the tree codes for the statement types known to Ada. These + must be at the end of this file to allow IS_ADA_STMT to work. */ + + /* This is how record_code_position and insert_code_for work. The former + makes this tree node, whose operand is a statement. The latter inserts + the actual statements into this node. Gimplification consists of + just returning the inner statement. */ + DEFTREECODE (STMT_STMT, "stmt_stmt", tcc_statement, 1) + + /* A loop. LOOP_STMT_TOP_COND and LOOP_STMT_BOT_COND are the tests to exit a + loop at the top and bottom, respectively. LOOP_STMT_UPDATE is the statement + to update the loop iterator at the continue point. LOOP_STMT_BODY are the + statements in the body of the loop. LOOP_STMT_LABEL points to the LABEL_DECL + of the end label of the loop. */ + DEFTREECODE (LOOP_STMT, "loop_stmt", tcc_statement, 5) + + /* Conditionally exit a loop. EXIT_STMT_COND is the condition, which, if + true, will cause the loop to be exited. If no condition is specified, + the loop is unconditionally exited. EXIT_STMT_LABEL is the end label + corresponding to the loop to exit. */ + DEFTREECODE (EXIT_STMT, "exit_stmt", tcc_statement, 2) + + /* A exception region. REGION_STMT_BODY is the statement to be executed + inside the region. REGION_STMT_HANDLE is a statement that represents + the exception handlers (usually a BLOCK_STMT of HANDLE_STMTs). + REGION_STMT_BLOCK is the BLOCK node for the declarative region, if any. */ + DEFTREECODE (REGION_STMT, "region_stmt", tcc_statement, 3) + + /* An exception handler. HANDLER_STMT_ARG is the value to pass to + expand_start_catch, HANDLER_STMT_LIST is the list of statements for the + handler itself, and HANDLER_STMT_BLOCK is the BLOCK node for this + binding. */ + DEFTREECODE (HANDLER_STMT, "handler_stmt", tcc_statement, 3) diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/ada-tree.h gcc-4.4.0/gcc/ada/gcc-interface/ada-tree.h *** gcc-4.3.3/gcc/ada/gcc-interface/ada-tree.h Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/ada-tree.h Fri Aug 1 14:02:10 2008 *************** *** 0 **** --- 1,327 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A D A - T R E E * + * * + * C Header File * + * * + * Copyright (C) 1992-2008, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + /* Ada uses the lang_decl and lang_type fields to hold a tree. */ + union lang_tree_node + GTY((desc ("0"), + chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.t)"))) + { + union tree_node GTY((tag ("0"))) t; + }; + struct lang_decl GTY(()) {tree t; }; + struct lang_type GTY(()) {tree t; }; + + /* Define macros to get and set the tree in TYPE_ and DECL_LANG_SPECIFIC. */ + #define GET_TYPE_LANG_SPECIFIC(NODE) \ + (TYPE_LANG_SPECIFIC (NODE) ? TYPE_LANG_SPECIFIC (NODE)->t : NULL_TREE) + #define SET_TYPE_LANG_SPECIFIC(NODE, X) \ + (TYPE_LANG_SPECIFIC (NODE) \ + = (TYPE_LANG_SPECIFIC (NODE) \ + ? TYPE_LANG_SPECIFIC (NODE) : GGC_NEW (struct lang_type))) \ + ->t = X; + + #define GET_DECL_LANG_SPECIFIC(NODE) \ + (DECL_LANG_SPECIFIC (NODE) ? DECL_LANG_SPECIFIC (NODE)->t : NULL_TREE) + #define SET_DECL_LANG_SPECIFIC(NODE, VALUE) \ + (DECL_LANG_SPECIFIC (NODE) \ + = (DECL_LANG_SPECIFIC (NODE) \ + ? DECL_LANG_SPECIFIC (NODE) : GGC_NEW (struct lang_decl))) \ + ->t = VALUE; + + /* Flags added to GCC type nodes. */ + + /* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is a + record being used as a fat pointer (only true for RECORD_TYPE). */ + #define TYPE_IS_FAT_POINTER_P(NODE) \ + TYPE_LANG_FLAG_0 (RECORD_OR_UNION_CHECK (NODE)) + + #define TYPE_FAT_POINTER_P(NODE) \ + (TREE_CODE (NODE) == RECORD_TYPE && TYPE_IS_FAT_POINTER_P (NODE)) + + /* For integral types and array types, nonzero if this is a packed array type + used for bit-packed types. Such types should not be extended to a larger + size or validated against a specified size. */ + #define TYPE_PACKED_ARRAY_TYPE_P(NODE) TYPE_LANG_FLAG_0 (NODE) + + #define TYPE_IS_PACKED_ARRAY_TYPE_P(NODE) \ + ((TREE_CODE (NODE) == INTEGER_TYPE || TREE_CODE (NODE) == ARRAY_TYPE) \ + && TYPE_PACKED_ARRAY_TYPE_P (NODE)) + + /* For INTEGER_TYPE, nonzero if this is a modular type with a modulus that + is not equal to two to the power of its mode's size. */ + #define TYPE_MODULAR_P(NODE) TYPE_LANG_FLAG_1 (INTEGER_TYPE_CHECK (NODE)) + + /* For ARRAY_TYPE, nonzero if this type corresponds to a dimension of + an Ada array other than the first. */ + #define TYPE_MULTI_ARRAY_P(NODE) TYPE_LANG_FLAG_1 (ARRAY_TYPE_CHECK (NODE)) + + /* For FUNCTION_TYPE, nonzero if this denotes a function returning an + unconstrained array or record. */ + #define TYPE_RETURNS_UNCONSTRAINED_P(NODE) \ + TYPE_LANG_FLAG_1 (FUNCTION_TYPE_CHECK (NODE)) + + /* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this denotes + a justified modular type (will only be true for RECORD_TYPE). */ + #define TYPE_JUSTIFIED_MODULAR_P(NODE) \ + TYPE_LANG_FLAG_1 (RECORD_OR_UNION_CHECK (NODE)) + + /* Nonzero in an arithmetic subtype if this is a subtype not known to the + front-end. */ + #define TYPE_EXTRA_SUBTYPE_P(NODE) TYPE_LANG_FLAG_2 (NODE) + + /* Nonzero for composite types if this is a by-reference type. */ + #define TYPE_BY_REFERENCE_P(NODE) TYPE_LANG_FLAG_2 (NODE) + + /* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is the + type for an object whose type includes its template in addition to + its value (only true for RECORD_TYPE). */ + #define TYPE_CONTAINS_TEMPLATE_P(NODE) \ + TYPE_LANG_FLAG_3 (RECORD_OR_UNION_CHECK (NODE)) + + /* For INTEGER_TYPE, nonzero if this really represents a VAX + floating-point type. */ + #define TYPE_VAX_FLOATING_POINT_P(NODE) \ + TYPE_LANG_FLAG_3 (INTEGER_TYPE_CHECK (NODE)) + + /* True if NODE is a thin pointer. */ + #define TYPE_THIN_POINTER_P(NODE) \ + (POINTER_TYPE_P (NODE) \ + && TREE_CODE (TREE_TYPE (NODE)) == RECORD_TYPE \ + && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (NODE))) + + /* True if TYPE is either a fat or thin pointer to an unconstrained + array. */ + #define TYPE_FAT_OR_THIN_POINTER_P(NODE) \ + (TYPE_FAT_POINTER_P (NODE) || TYPE_THIN_POINTER_P (NODE)) + + /* For INTEGER_TYPEs, nonzero if the type has a biased representation. */ + #define TYPE_BIASED_REPRESENTATION_P(NODE) \ + TYPE_LANG_FLAG_4 (INTEGER_TYPE_CHECK (NODE)) + + /* For ARRAY_TYPEs, nonzero if the array type has Convention_Fortran. */ + #define TYPE_CONVENTION_FORTRAN_P(NODE) \ + TYPE_LANG_FLAG_4 (ARRAY_TYPE_CHECK (NODE)) + + /* For FUNCTION_TYPEs, nonzero if the function returns by reference. */ + #define TYPE_RETURNS_BY_REF_P(NODE) \ + TYPE_LANG_FLAG_4 (FUNCTION_TYPE_CHECK (NODE)) + + /* For VOID_TYPE, ENUMERAL_TYPE, UNION_TYPE, and RECORD_TYPE, nonzero if this + is a dummy type, made to correspond to a private or incomplete type. */ + #define TYPE_DUMMY_P(NODE) TYPE_LANG_FLAG_4 (NODE) + + /* True if TYPE is such a dummy type. */ + #define TYPE_IS_DUMMY_P(NODE) \ + ((TREE_CODE (NODE) == VOID_TYPE || TREE_CODE (NODE) == RECORD_TYPE \ + || TREE_CODE (NODE) == UNION_TYPE || TREE_CODE (NODE) == ENUMERAL_TYPE) \ + && TYPE_DUMMY_P (NODE)) + + /* For FUNCTION_TYPEs, nonzero if function returns by being passed a pointer + to a place to store its result. */ + #define TYPE_RETURNS_BY_TARGET_PTR_P(NODE) \ + TYPE_LANG_FLAG_5 (FUNCTION_TYPE_CHECK (NODE)) + + /* For an INTEGER_TYPE, nonzero if TYPE_ACTUAL_BOUNDS is present. */ + #define TYPE_HAS_ACTUAL_BOUNDS_P(NODE) \ + TYPE_LANG_FLAG_5 (INTEGER_TYPE_CHECK (NODE)) + + /* For a RECORD_TYPE, nonzero if this was made just to supply needed + padding or alignment. */ + #define TYPE_IS_PADDING_P(NODE) TYPE_LANG_FLAG_5 (RECORD_TYPE_CHECK (NODE)) + + /* True if TYPE can alias any other types. */ + #define TYPE_UNIVERSAL_ALIASING_P(NODE) TYPE_LANG_FLAG_6 (NODE) + + /* This field is only defined for FUNCTION_TYPE nodes. If the Ada + subprogram contains no parameters passed by copy in/copy out then this + field is 0. Otherwise it points to a list of nodes used to specify the + return values of the out (or in out) parameters that qualify to be passed + by copy in copy out. It is a CONSTRUCTOR. For a full description of the + cico parameter passing mechanism refer to the routine gnat_to_gnu_entity. */ + #define TYPE_CI_CO_LIST(NODE) TYPE_LANG_SLOT_1 (FUNCTION_TYPE_CHECK (NODE)) + + /* For an INTEGER_TYPE with TYPE_MODULAR_P, this is the value of the + modulus. */ + #define TYPE_MODULUS(NODE) GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) + #define SET_TYPE_MODULUS(NODE, X) \ + SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X) + + /* For an INTEGER_TYPE that is the TYPE_DOMAIN of some ARRAY_TYPE, points to + the type corresponding to the Ada index type. */ + #define TYPE_INDEX_TYPE(NODE) \ + GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) + #define SET_TYPE_INDEX_TYPE(NODE, X) \ + SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X) + + /* For an INTEGER_TYPE with TYPE_VAX_FLOATING_POINT_P, stores the + Digits_Value. */ + #define TYPE_DIGITS_VALUE(NODE) \ + GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) + #define SET_TYPE_DIGITS_VALUE(NODE, X) \ + SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X) + + /* For numeric types, stores the RM_Size of the type. */ + #define TYPE_RM_SIZE_NUM(NODE) TYPE_LANG_SLOT_1 (NUMERICAL_TYPE_CHECK (NODE)) + + #define TYPE_RM_SIZE(NODE) \ + (INTEGRAL_TYPE_P (NODE) || TREE_CODE (NODE) == REAL_TYPE \ + ? TYPE_RM_SIZE_NUM (NODE) : 0) + + /* For a RECORD_TYPE that is a fat pointer, point to the type for the + unconstrained object. Likewise for a RECORD_TYPE that is pointed + to by a thin pointer. */ + #define TYPE_UNCONSTRAINED_ARRAY(NODE) \ + GET_TYPE_LANG_SPECIFIC (RECORD_TYPE_CHECK (NODE)) + #define SET_TYPE_UNCONSTRAINED_ARRAY(NODE, X) \ + SET_TYPE_LANG_SPECIFIC (RECORD_TYPE_CHECK (NODE), X) + + /* For other RECORD_TYPEs and all UNION_TYPEs and QUAL_UNION_TYPEs, the Ada + size of the object. This differs from the GCC size in that it does not + include any rounding up to the alignment of the type. */ + #define TYPE_ADA_SIZE(NODE) \ + GET_TYPE_LANG_SPECIFIC (RECORD_OR_UNION_CHECK (NODE)) + #define SET_TYPE_ADA_SIZE(NODE, X) \ + SET_TYPE_LANG_SPECIFIC (RECORD_OR_UNION_CHECK (NODE), X) + + /* For an INTEGER_TYPE with TYPE_HAS_ACTUAL_BOUNDS_P or an ARRAY_TYPE, this is + the index type that should be used when the actual bounds are required for + a template. This is used in the case of packed arrays. */ + #define TYPE_ACTUAL_BOUNDS(NODE) \ + GET_TYPE_LANG_SPECIFIC (TREE_CHECK2 (NODE, INTEGER_TYPE, ARRAY_TYPE)) + #define SET_TYPE_ACTUAL_BOUNDS(NODE, X) \ + SET_TYPE_LANG_SPECIFIC (TREE_CHECK2 (NODE, INTEGER_TYPE, ARRAY_TYPE), X) + + /* In an UNCONSTRAINED_ARRAY_TYPE, points to the record containing both + the template and object. + + ??? We also put this on an ENUMERAL_TYPE that's dummy. Technically, + this is a conflict on the minval field, but there doesn't seem to be + simple fix, so we'll live with this kludge for now. */ + #define TYPE_OBJECT_RECORD_TYPE(NODE) \ + (TREE_CHECK2 ((NODE), UNCONSTRAINED_ARRAY_TYPE, ENUMERAL_TYPE)->type.minval) + + /* Nonzero in a FUNCTION_DECL that represents a stubbed function + discriminant. */ + #define DECL_STUBBED_P(NODE) DECL_LANG_FLAG_0 (FUNCTION_DECL_CHECK (NODE)) + + /* Nonzero in a VAR_DECL if it is guaranteed to be constant after having + been elaborated and TREE_READONLY is not set on it. */ + #define DECL_READONLY_ONCE_ELAB(NODE) DECL_LANG_FLAG_0 (VAR_DECL_CHECK (NODE)) + + /* Nonzero if this decl is always used by reference; i.e., an INDIRECT_REF + is needed to access the object. */ + #define DECL_BY_REF_P(NODE) DECL_LANG_FLAG_1 (NODE) + + /* Nonzero in a FIELD_DECL that is a dummy built for some internal reason. */ + #define DECL_INTERNAL_P(NODE) DECL_LANG_FLAG_3 (FIELD_DECL_CHECK (NODE)) + + /* Nonzero if this decl is a PARM_DECL for an Ada array being passed to a + foreign convention subprogram. */ + #define DECL_BY_COMPONENT_PTR_P(NODE) DECL_LANG_FLAG_3 (PARM_DECL_CHECK (NODE)) + + /* Nonzero in a FUNCTION_DECL that corresponds to an elaboration procedure. */ + #define DECL_ELABORATION_PROC_P(NODE) \ + DECL_LANG_FLAG_3 (FUNCTION_DECL_CHECK (NODE)) + + /* Nonzero if this is a decl for a pointer that points to something which + is readonly. Used mostly for fat pointers. */ + #define DECL_POINTS_TO_READONLY_P(NODE) DECL_LANG_FLAG_4 (NODE) + + /* Nonzero in a FIELD_DECL if there was a record rep clause. */ + #define DECL_HAS_REP_P(NODE) DECL_LANG_FLAG_5 (FIELD_DECL_CHECK (NODE)) + + /* Nonzero in a PARM_DECL if we are to pass by descriptor. */ + #define DECL_BY_DESCRIPTOR_P(NODE) DECL_LANG_FLAG_5 (PARM_DECL_CHECK (NODE)) + + /* Nonzero in a VAR_DECL if it is a pointer renaming a global object. */ + #define DECL_RENAMING_GLOBAL_P(NODE) DECL_LANG_FLAG_5 (VAR_DECL_CHECK (NODE)) + + /* In a CONST_DECL, points to a VAR_DECL that is allocatable to + memory. Used when a scalar constant is aliased or has its + address taken. */ + #define DECL_CONST_CORRESPONDING_VAR(NODE) \ + GET_DECL_LANG_SPECIFIC (CONST_DECL_CHECK (NODE)) + #define SET_DECL_CONST_CORRESPONDING_VAR(NODE, X) \ + SET_DECL_LANG_SPECIFIC (CONST_DECL_CHECK (NODE), X) + + /* In a FIELD_DECL, points to the FIELD_DECL that was the ultimate + source of the decl. */ + #define DECL_ORIGINAL_FIELD(NODE) \ + GET_DECL_LANG_SPECIFIC (FIELD_DECL_CHECK (NODE)) + #define SET_DECL_ORIGINAL_FIELD(NODE, X) \ + SET_DECL_LANG_SPECIFIC (FIELD_DECL_CHECK (NODE), X) + + /* In a VAR_DECL, points to the object being renamed if the VAR_DECL is a + renaming pointer, otherwise 0. Note that this object is guaranteed to + be protected against multiple evaluations. */ + #define DECL_RENAMED_OBJECT(NODE) \ + GET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE)) + #define SET_DECL_RENAMED_OBJECT(NODE, X) \ + SET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE), X) + + /* In a TYPE_DECL, points to the parallel type if any, otherwise 0. */ + #define DECL_PARALLEL_TYPE(NODE) \ + GET_DECL_LANG_SPECIFIC (TYPE_DECL_CHECK (NODE)) + #define SET_DECL_PARALLEL_TYPE(NODE, X) \ + SET_DECL_LANG_SPECIFIC (TYPE_DECL_CHECK (NODE), X) + + /* In a FUNCTION_DECL, points to the stub associated with the function + if any, otherwise 0. */ + #define DECL_FUNCTION_STUB(NODE) \ + GET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE)) + #define SET_DECL_FUNCTION_STUB(NODE, X) \ + SET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE), X) + + /* In a PARM_DECL, points to the alternate TREE_TYPE. */ + #define DECL_PARM_ALT_TYPE(NODE) \ + GET_DECL_LANG_SPECIFIC (PARM_DECL_CHECK (NODE)) + #define SET_DECL_PARM_ALT_TYPE(NODE, X) \ + SET_DECL_LANG_SPECIFIC (PARM_DECL_CHECK (NODE), X) + + /* In a FIELD_DECL corresponding to a discriminant, contains the + discriminant number. */ + #define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE)) + + /* Define fields and macros for statements. + + Start by defining which tree codes are used for statements. */ + #define IS_STMT(NODE) (STATEMENT_CLASS_P (NODE)) + #define IS_ADA_STMT(NODE) (IS_STMT (NODE) \ + && TREE_CODE (NODE) >= STMT_STMT) + + #define STMT_STMT_STMT(NODE) TREE_OPERAND_CHECK_CODE (NODE, STMT_STMT, 0) + #define LOOP_STMT_TOP_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 0) + #define LOOP_STMT_BOT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 1) + #define LOOP_STMT_UPDATE(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 2) + #define LOOP_STMT_BODY(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 3) + #define LOOP_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 4) + #define EXIT_STMT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 0) + #define EXIT_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 1) + #define REGION_STMT_BODY(NODE) TREE_OPERAND_CHECK_CODE (NODE, REGION_STMT, 0) + #define REGION_STMT_HANDLE(NODE) TREE_OPERAND_CHECK_CODE (NODE, REGION_STMT, 1) + #define REGION_STMT_BLOCK(NODE) TREE_OPERAND_CHECK_CODE (NODE, REGION_STMT, 2) + #define HANDLER_STMT_ARG(NODE) TREE_OPERAND_CHECK_CODE (NODE, HANDLER_STMT, 0) + #define HANDLER_STMT_LIST(NODE) TREE_OPERAND_CHECK_CODE (NODE, HANDLER_STMT, 1) + #define HANDLER_STMT_BLOCK(NODE) TREE_OPERAND_CHECK_CODE(NODE, HANDLER_STMT, 2) diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/ada.h gcc-4.4.0/gcc/ada/gcc-interface/ada.h *** gcc-4.3.3/gcc/ada/gcc-interface/ada.h Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/ada.h Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,73 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A D A * + * * + * C Header File * + * * + * Copyright (C) 1992-2009, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + /* This file contains some standard macros for performing Ada-like + operations. These are used to aid in the translation of other headers. */ + + #ifndef GCC_ADA_H + #define GCC_ADA_H + + /* Inlined functions in header are preceded by INLINE, which is normally set + to extern inline for GCC, but may be set to static for use in standard + ANSI-C. */ + + #ifndef INLINE + #ifdef __GNUC__ + #define INLINE static inline + #else + #define INLINE static + #endif + #endif + + /* Define a macro to concatenate two strings. Write it for ANSI C and + for traditional C. */ + + #ifdef __STDC__ + #define CAT(A,B) A##B + #else + #define _ECHO(A) A + #define CAT(A,B) ECHO(A)B + #endif + + /* The following macro definition simulates the effect of a declaration of + a subtype, where the first two parameters give the name of the type and + subtype, and the third and fourth parameters give the subtype range. The + effect is to compile a typedef defining the subtype as a synonym for the + type, together with two constants defining the end points. */ + + #define SUBTYPE(SUBTYPE,TYPE,FIRST,LAST) \ + typedef TYPE SUBTYPE; \ + enum { CAT (SUBTYPE,__First) = FIRST, \ + CAT (SUBTYPE,__Last) = LAST }; + + /* The following definitions provide the equivalent of the Ada IN and NOT IN + operators, assuming that the subtype involved has been defined using the + SUBTYPE macro defined above. */ + + #define IN(VALUE,SUBTYPE) \ + (((VALUE) >= (SUBTYPE) CAT (SUBTYPE,__First)) \ + && ((VALUE) <= (SUBTYPE) CAT (SUBTYPE,__Last))) + + #endif diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/config-lang.in gcc-4.4.0/gcc/ada/gcc-interface/config-lang.in *** gcc-4.3.3/gcc/ada/gcc-interface/config-lang.in Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/config-lang.in Fri Nov 7 10:03:21 2008 *************** *** 0 **** --- 1,43 ---- + # Top level configure fragment for GNU Ada (GNAT). + # Copyright (C) 1994-2008 Free Software Foundation, Inc. + + #This file is part of GCC. + + #GCC is free software; you can redistribute it and/or modify + #it under the terms of the GNU General Public License as published by + #the Free Software Foundation; either version 3, or (at your option) + #any later version. + + #GCC is distributed in the hope that it will be useful, + #but WITHOUT ANY WARRANTY; without even the implied warranty of + #MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + #GNU General Public License for more details. + + #You should have received a copy of the GNU General Public License + #along with GCC; see the file COPYING3. If not see + #. + + # Configure looks for the existence of this file to auto-config each language. + # We define several parameters used by configure: + # + # language - name of language as it would appear in $(LANGUAGES) + # boot_language - "yes" if we need to build this language in stage1 + # compilers - value to add to $(COMPILERS) + + language="ada" + gcc_subdir="ada/gcc-interface" + + boot_language=yes + boot_language_boot_flags='ADAFLAGS="$(BOOT_ADAFLAGS)"' + + compilers="gnat1\$(exeext)" + + gtfiles="\$(srcdir)/ada/gcc-interface/ada-tree.h \$(srcdir)/ada/gcc-interface/gigi.h \$(srcdir)/ada/gcc-interface/decl.c \$(srcdir)/ada/gcc-interface/trans.c \$(srcdir)/ada/gcc-interface/utils.c" + + outputs="ada/gcc-interface/Makefile ada/Makefile" + + target_libs="target-libada" + lang_dirs="gnattools" + + # Ada is not enabled by default for the time being. + build_by_default=no diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/cuintp.c gcc-4.4.0/gcc/ada/gcc-interface/cuintp.c *** gcc-4.3.3/gcc/ada/gcc-interface/cuintp.c Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/cuintp.c Tue Jul 29 15:46:37 2008 *************** *** 0 **** --- 1,142 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * C U I N T P * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2008, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + /* This file corresponds to the Ada package body Uintp. It was created + manually from the files uintp.ads and uintp.adb. */ + + #include "config.h" + #include "system.h" + #include "coretypes.h" + #include "tm.h" + #include "tree.h" + #include "ada.h" + #include "types.h" + #include "uintp.h" + #include "atree.h" + #include "elists.h" + #include "nlists.h" + #include "stringt.h" + #include "fe.h" + #include "gigi.h" + #include "ada-tree.h" + + /* Universal integers are represented by the Uint type which is an index into + the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an + index and length for getting the "digits" of the universal integer from the + Udigits_Ptr table. + + For efficiency, this method is used only for integer values larger than the + constant Uint_Bias. If a Uint is less than this constant, then it contains + the integer value itself. The origin of the Uints_Ptr table is adjusted so + that a Uint value of Uint_Bias indexes the first element. + + First define a utility function that operates like build_int_cst for + integral types and does a conversion to floating-point for real types. */ + + static tree + build_cst_from_int (tree type, HOST_WIDE_INT low) + { + if (TREE_CODE (type) == REAL_TYPE) + return convert (type, build_int_cst (NULL_TREE, low)); + else + return build_int_cst_type (type, low); + } + + /* Similar to UI_To_Int, but return a GCC INTEGER_CST or REAL_CST node, + depending on whether TYPE is an integral or real type. Overflow is tested + by the constant-folding used to build the node. TYPE is the GCC type of + the resulting node. */ + + tree + UI_To_gnu (Uint Input, tree type) + { + tree gnu_ret; + + /* We might have a TYPE with biased representation and be passed an + unbiased value that doesn't fit. We always use an unbiased type able + to hold any such possible value for intermediate computations, and + then rely on a conversion back to TYPE to perform the bias adjustment + when need be. */ + + int biased_type_p + = (TREE_CODE (type) == INTEGER_TYPE + && TYPE_BIASED_REPRESENTATION_P (type)); + + tree comp_type = biased_type_p ? get_base_type (type) : type; + + if (Input <= Uint_Direct_Last) + gnu_ret = build_cst_from_int (comp_type, Input - Uint_Direct_Bias); + else + { + Int Idx = Uints_Ptr[Input].Loc; + Pos Length = Uints_Ptr[Input].Length; + Int First = Udigits_Ptr[Idx]; + tree gnu_base; + + gcc_assert (Length > 0); + + /* The computations we perform below always require a type at least as + large as an integer not to overflow. REAL types are always fine, but + INTEGER or ENUMERAL types we are handed may be too short. We use a + base integer type node for the computations in this case and will + convert the final result back to the incoming type later on. + The base integer precision must be superior than 16. */ + + if (TREE_CODE (comp_type) != REAL_TYPE + && TYPE_PRECISION (comp_type) < TYPE_PRECISION (long_integer_type_node)) + { + comp_type = long_integer_type_node; + gcc_assert (TYPE_PRECISION (comp_type) > 16); + } + + gnu_base = build_cst_from_int (comp_type, Base); + + gnu_ret = build_cst_from_int (comp_type, First); + if (First < 0) + for (Idx++, Length--; Length; Idx++, Length--) + gnu_ret = fold_build2 (MINUS_EXPR, comp_type, + fold_build2 (MULT_EXPR, comp_type, + gnu_ret, gnu_base), + build_cst_from_int (comp_type, + Udigits_Ptr[Idx])); + else + for (Idx++, Length--; Length; Idx++, Length--) + gnu_ret = fold_build2 (PLUS_EXPR, comp_type, + fold_build2 (MULT_EXPR, comp_type, + gnu_ret, gnu_base), + build_cst_from_int (comp_type, + Udigits_Ptr[Idx])); + } + + gnu_ret = convert (type, gnu_ret); + + /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RET. */ + while ((TREE_CODE (gnu_ret) == NOP_EXPR + || TREE_CODE (gnu_ret) == NON_LVALUE_EXPR) + && TREE_TYPE (TREE_OPERAND (gnu_ret, 0)) == TREE_TYPE (gnu_ret)) + gnu_ret = TREE_OPERAND (gnu_ret, 0); + + return gnu_ret; + } diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/decl.c gcc-4.4.0/gcc/ada/gcc-interface/decl.c *** gcc-4.3.3/gcc/ada/gcc-interface/decl.c Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/decl.c Tue Mar 31 07:19:11 2009 *************** *** 0 **** --- 1,7842 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * D E C L * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2009, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + #include "config.h" + #include "system.h" + #include "coretypes.h" + #include "tm.h" + #include "tree.h" + #include "flags.h" + #include "toplev.h" + #include "convert.h" + #include "ggc.h" + #include "obstack.h" + #include "target.h" + #include "expr.h" + + #include "ada.h" + #include "types.h" + #include "atree.h" + #include "elists.h" + #include "namet.h" + #include "nlists.h" + #include "repinfo.h" + #include "snames.h" + #include "stringt.h" + #include "uintp.h" + #include "fe.h" + #include "sinfo.h" + #include "einfo.h" + #include "hashtab.h" + #include "ada-tree.h" + #include "gigi.h" + + #ifndef MAX_FIXED_MODE_SIZE + #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode) + #endif + + /* Convention_Stdcall should be processed in a specific way on Windows targets + only. The macro below is a helper to avoid having to check for a Windows + specific attribute throughout this unit. */ + + #if TARGET_DLLIMPORT_DECL_ATTRIBUTES + #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall) + #else + #define Has_Stdcall_Convention(E) (0) + #endif + + /* Stack realignment for functions with foreign conventions is provided on a + per back-end basis now, as it is handled by the prologue expanders and not + as part of the function's body any more. It might be requested by way of a + dedicated function type attribute on the targets that support it. + + We need a way to avoid setting the attribute on the targets that don't + support it and use FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN for this purpose. + + It is defined on targets where the circuitry is available, and indicates + whether the realignment is needed for 'main'. We use this to decide for + foreign subprograms as well. + + It is not defined on targets where the circuitry is not implemented, and + we just never set the attribute in these cases. + + Whether it is defined on all targets that would need it in theory is + not entirely clear. We currently trust the base GCC settings for this + purpose. */ + + #ifndef FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN + #define FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN 0 + #endif + + struct incomplete + { + struct incomplete *next; + tree old_type; + Entity_Id full_type; + }; + + /* These variables are used to defer recursively expanding incomplete types + while we are processing an array, a record or a subprogram type. */ + static int defer_incomplete_level = 0; + static struct incomplete *defer_incomplete_list; + + /* This variable is used to delay expanding From_With_Type types until the + end of the spec. */ + static struct incomplete *defer_limited_with; + + /* These variables are used to defer finalizing types. The element of the + list is the TYPE_DECL associated with the type. */ + static int defer_finalize_level = 0; + static VEC (tree,heap) *defer_finalize_list; + + /* A hash table used to cache the result of annotate_value. */ + static GTY ((if_marked ("tree_int_map_marked_p"), + param_is (struct tree_int_map))) htab_t annotate_value_cache; + + enum alias_set_op + { + ALIAS_SET_COPY, + ALIAS_SET_SUBSET, + ALIAS_SET_SUPERSET + }; + + static void relate_alias_sets (tree, tree, enum alias_set_op); + + static tree substitution_list (Entity_Id, Entity_Id, tree, bool); + static bool allocatable_size_p (tree, bool); + static void prepend_one_attribute_to (struct attrib **, + enum attr_type, tree, tree, Node_Id); + static void prepend_attributes (Entity_Id, struct attrib **); + static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool); + static bool is_variable_size (tree); + static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree, + bool, bool); + static tree make_packable_type (tree, bool); + static tree gnat_to_gnu_field (Entity_Id, tree, int, bool); + static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool, + bool *); + static bool same_discriminant_p (Entity_Id, Entity_Id); + static bool array_type_has_nonaliased_component (Entity_Id, tree); + static void components_to_record (tree, Node_Id, tree, int, bool, tree *, + bool, bool, bool, bool); + static Uint annotate_value (tree); + static void annotate_rep (Entity_Id, tree); + static tree compute_field_positions (tree, tree, tree, tree, unsigned int); + static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool); + static void set_rm_size (Uint, tree, Entity_Id); + static tree make_type_from_size (tree, tree, bool); + static unsigned int validate_alignment (Uint, Entity_Id, unsigned int); + static unsigned int ceil_alignment (unsigned HOST_WIDE_INT); + static void check_ok_for_atomic (tree, Entity_Id, bool); + static int compatible_signatures_p (tree ftype1, tree ftype2); + static void rest_of_type_decl_compilation_no_defer (tree); + + /* Return true if GNAT_ADDRESS is a compile time known value. + In particular catch System'To_Address. */ + + static bool + compile_time_known_address_p (Node_Id gnat_address) + { + return ((Nkind (gnat_address) == N_Unchecked_Type_Conversion + && Compile_Time_Known_Value (Expression (gnat_address))) + || Compile_Time_Known_Value (gnat_address)); + } + + /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a + GCC type corresponding to that entity. GNAT_ENTITY is assumed to + refer to an Ada type. */ + + tree + gnat_to_gnu_type (Entity_Id gnat_entity) + { + tree gnu_decl; + + /* The back end never attempts to annotate generic types */ + if (Is_Generic_Type (gnat_entity) && type_annotate_only) + return void_type_node; + + /* Convert the ada entity type into a GCC TYPE_DECL node. */ + gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); + gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL); + return TREE_TYPE (gnu_decl); + } + + /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada + entity, this routine returns the equivalent GCC tree for that entity + (an ..._DECL node) and associates the ..._DECL node with the input GNAT + defining identifier. + + If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its + initial value (in GCC tree form). This is optional for variables. + For renamed entities, GNU_EXPR gives the object being renamed. + + DEFINITION is nonzero if this call is intended for a definition. This is + used for separate compilation where it necessary to know whether an + external declaration or a definition should be created if the GCC equivalent + was not created previously. The value of 1 is normally used for a nonzero + DEFINITION, but a value of 2 is used in special circumstances, defined in + the code. */ + + tree + gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) + { + Entity_Id gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity); + tree gnu_entity_id; + tree gnu_type = NULL_TREE; + /* Contains the gnu XXXX_DECL tree node which is equivalent to the input + GNAT tree. This node will be associated with the GNAT node by calling + the save_gnu_tree routine at the end of the `switch' statement. */ + tree gnu_decl = NULL_TREE; + /* true if we have already saved gnu_decl as a gnat association. */ + bool saved = false; + /* Nonzero if we incremented defer_incomplete_level. */ + bool this_deferred = false; + /* Nonzero if we incremented force_global. */ + bool this_global = false; + /* Nonzero if we should check to see if elaborated during processing. */ + bool maybe_present = false; + /* Nonzero if we made GNU_DECL and its type here. */ + bool this_made_decl = false; + struct attrib *attr_list = NULL; + bool debug_info_p = (Needs_Debug_Info (gnat_entity) + || debug_info_level == DINFO_LEVEL_VERBOSE); + Entity_Kind kind = Ekind (gnat_entity); + Entity_Id gnat_temp; + unsigned int esize + = ((Known_Esize (gnat_entity) + && UI_Is_In_Int_Range (Esize (gnat_entity))) + ? MIN (UI_To_Int (Esize (gnat_entity)), + IN (kind, Float_Kind) + ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE) + : IN (kind, Access_Kind) ? POINTER_SIZE * 2 + : LONG_LONG_TYPE_SIZE) + : LONG_LONG_TYPE_SIZE); + tree gnu_size = 0; + bool imported_p + = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity))); + unsigned int align = 0; + + /* Since a use of an Itype is a definition, process it as such if it + is not in a with'ed unit. */ + + if (!definition && Is_Itype (gnat_entity) + && !present_gnu_tree (gnat_entity) + && In_Extended_Main_Code_Unit (gnat_entity)) + { + /* Ensure that we are in a subprogram mentioned in the Scope + chain of this entity, our current scope is global, + or that we encountered a task or entry (where we can't currently + accurately check scoping). */ + if (!current_function_decl + || DECL_ELABORATION_PROC_P (current_function_decl)) + { + process_type (gnat_entity); + return get_gnu_tree (gnat_entity); + } + + for (gnat_temp = Scope (gnat_entity); + Present (gnat_temp); gnat_temp = Scope (gnat_temp)) + { + if (Is_Type (gnat_temp)) + gnat_temp = Underlying_Type (gnat_temp); + + if (Ekind (gnat_temp) == E_Subprogram_Body) + gnat_temp + = Corresponding_Spec (Parent (Declaration_Node (gnat_temp))); + + if (IN (Ekind (gnat_temp), Subprogram_Kind) + && Present (Protected_Body_Subprogram (gnat_temp))) + gnat_temp = Protected_Body_Subprogram (gnat_temp); + + if (Ekind (gnat_temp) == E_Entry + || Ekind (gnat_temp) == E_Entry_Family + || Ekind (gnat_temp) == E_Task_Type + || (IN (Ekind (gnat_temp), Subprogram_Kind) + && present_gnu_tree (gnat_temp) + && (current_function_decl + == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0)))) + { + process_type (gnat_entity); + return get_gnu_tree (gnat_entity); + } + } + + /* This abort means the entity "gnat_entity" has an incorrect scope, + i.e. that its scope does not correspond to the subprogram in which + it is declared */ + gcc_unreachable (); + } + + /* If this is entity 0, something went badly wrong. */ + gcc_assert (Present (gnat_entity)); + + /* If we've already processed this entity, return what we got last time. + If we are defining the node, we should not have already processed it. + In that case, we will abort below when we try to save a new GCC tree for + this object. We also need to handle the case of getting a dummy type + when a Full_View exists. */ + + if (present_gnu_tree (gnat_entity) + && (!definition || (Is_Type (gnat_entity) && imported_p))) + { + gnu_decl = get_gnu_tree (gnat_entity); + + if (TREE_CODE (gnu_decl) == TYPE_DECL + && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)) + && IN (kind, Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity))) + { + gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), + NULL_TREE, 0); + + save_gnu_tree (gnat_entity, NULL_TREE, false); + save_gnu_tree (gnat_entity, gnu_decl, false); + } + + return gnu_decl; + } + + /* If this is a numeric or enumeral type, or an access type, a nonzero + Esize must be specified unless it was specified by the programmer. */ + gcc_assert (!Unknown_Esize (gnat_entity) + || Has_Size_Clause (gnat_entity) + || (!IN (kind, Numeric_Kind) && !IN (kind, Enumeration_Kind) + && (!IN (kind, Access_Kind) + || kind == E_Access_Protected_Subprogram_Type + || kind == E_Anonymous_Access_Protected_Subprogram_Type + || kind == E_Access_Subtype))); + + /* Likewise, RM_Size must be specified for all discrete and fixed-point + types. */ + gcc_assert (!IN (kind, Discrete_Or_Fixed_Point_Kind) + || !Unknown_RM_Size (gnat_entity)); + + /* Get the name of the entity and set up the line number and filename of + the original definition for use in any decl we make. */ + gnu_entity_id = get_entity_name (gnat_entity); + Sloc_to_locus (Sloc (gnat_entity), &input_location); + + /* If we get here, it means we have not yet done anything with this + entity. If we are not defining it here, it must be external, + otherwise we should have defined it already. */ + gcc_assert (definition || Is_Public (gnat_entity) || type_annotate_only + || kind == E_Discriminant || kind == E_Component + || kind == E_Label + || (kind == E_Constant && Present (Full_View (gnat_entity))) + || IN (kind, Type_Kind)); + + /* For cases when we are not defining (i.e., we are referencing from + another compilation unit) Public entities, show we are at global level + for the purpose of computing scopes. Don't do this for components or + discriminants since the relevant test is whether or not the record is + being defined. But do this for Imported functions or procedures in + all cases. */ + if ((!definition && Is_Public (gnat_entity) + && !Is_Statically_Allocated (gnat_entity) + && kind != E_Discriminant && kind != E_Component) + || (Is_Imported (gnat_entity) + && (kind == E_Function || kind == E_Procedure))) + force_global++, this_global = true; + + /* Handle any attributes directly attached to the entity. */ + if (Has_Gigi_Rep_Item (gnat_entity)) + prepend_attributes (gnat_entity, &attr_list); + + /* Machine_Attributes on types are expected to be propagated to subtypes. + The corresponding Gigi_Rep_Items are only attached to the first subtype + though, so we handle the propagation here. */ + if (Is_Type (gnat_entity) && Base_Type (gnat_entity) != gnat_entity + && !Is_First_Subtype (gnat_entity) + && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity)))) + prepend_attributes (First_Subtype (Base_Type (gnat_entity)), &attr_list); + + switch (kind) + { + case E_Constant: + /* If this is a use of a deferred constant without address clause, + get its full definition. */ + if (!definition + && No (Address_Clause (gnat_entity)) + && Present (Full_View (gnat_entity))) + { + gnu_decl + = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0); + saved = true; + break; + } + + /* If we have an external constant that we are not defining, get the + expression that is was defined to represent. We may throw that + expression away later if it is not a constant. Do not retrieve the + expression if it is an aggregate or allocator, because in complex + instantiation contexts it may not be expanded */ + if (!definition + && Present (Expression (Declaration_Node (gnat_entity))) + && !No_Initialization (Declaration_Node (gnat_entity)) + && (Nkind (Expression (Declaration_Node (gnat_entity))) + != N_Aggregate) + && (Nkind (Expression (Declaration_Node (gnat_entity))) + != N_Allocator)) + gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity))); + + /* Ignore deferred constant definitions without address clause since + they are processed fully in the front-end. If No_Initialization + is set, this is not a deferred constant but a constant whose value + is built manually. And constants that are renamings are handled + like variables. */ + if (definition + && !gnu_expr + && No (Address_Clause (gnat_entity)) + && !No_Initialization (Declaration_Node (gnat_entity)) + && No (Renamed_Object (gnat_entity))) + { + gnu_decl = error_mark_node; + saved = true; + break; + } + + /* Ignore constant definitions already marked with the error node. See + the N_Object_Declaration case of gnat_to_gnu for the rationale. */ + if (definition + && gnu_expr + && present_gnu_tree (gnat_entity) + && get_gnu_tree (gnat_entity) == error_mark_node) + { + maybe_present = true; + break; + } + + goto object; + + case E_Exception: + /* We used to special case VMS exceptions here to directly map them to + their associated condition code. Since this code had to be masked + dynamically to strip off the severity bits, this caused trouble in + the GCC/ZCX case because the "type" pointers we store in the tables + have to be static. We now don't special case here anymore, and let + the regular processing take place, which leaves us with a regular + exception data object for VMS exceptions too. The condition code + mapping is taken care of by the front end and the bitmasking by the + runtime library. */ + goto object; + + case E_Discriminant: + case E_Component: + { + /* The GNAT record where the component was defined. */ + Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity)); + + /* If the variable is an inherited record component (in the case of + extended record types), just return the inherited entity, which + must be a FIELD_DECL. Likewise for discriminants. + For discriminants of untagged records which have explicit + stored discriminants, return the entity for the corresponding + stored discriminant. Also use Original_Record_Component + if the record has a private extension. */ + + if (Present (Original_Record_Component (gnat_entity)) + && Original_Record_Component (gnat_entity) != gnat_entity) + { + gnu_decl + = gnat_to_gnu_entity (Original_Record_Component (gnat_entity), + gnu_expr, definition); + saved = true; + break; + } + + /* If the enclosing record has explicit stored discriminants, + then it is an untagged record. If the Corresponding_Discriminant + is not empty then this must be a renamed discriminant and its + Original_Record_Component must point to the corresponding explicit + stored discriminant (i.e., we should have taken the previous + branch). */ + + else if (Present (Corresponding_Discriminant (gnat_entity)) + && Is_Tagged_Type (gnat_record)) + { + /* A tagged record has no explicit stored discriminants. */ + + gcc_assert (First_Discriminant (gnat_record) + == First_Stored_Discriminant (gnat_record)); + gnu_decl + = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity), + gnu_expr, definition); + saved = true; + break; + } + + else if (Present (CR_Discriminant (gnat_entity)) + && type_annotate_only) + { + gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity), + gnu_expr, definition); + saved = true; + break; + } + + /* If the enclosing record has explicit stored discriminants, then + it is an untagged record. If the Corresponding_Discriminant + is not empty then this must be a renamed discriminant and its + Original_Record_Component must point to the corresponding explicit + stored discriminant (i.e., we should have taken the first + branch). */ + + else if (Present (Corresponding_Discriminant (gnat_entity)) + && (First_Discriminant (gnat_record) + != First_Stored_Discriminant (gnat_record))) + gcc_unreachable (); + + /* Otherwise, if we are not defining this and we have no GCC type + for the containing record, make one for it. Then we should + have made our own equivalent. */ + else if (!definition && !present_gnu_tree (gnat_record)) + { + /* ??? If this is in a record whose scope is a protected + type and we have an Original_Record_Component, use it. + This is a workaround for major problems in protected type + handling. */ + Entity_Id Scop = Scope (Scope (gnat_entity)); + if ((Is_Protected_Type (Scop) + || (Is_Private_Type (Scop) + && Present (Full_View (Scop)) + && Is_Protected_Type (Full_View (Scop)))) + && Present (Original_Record_Component (gnat_entity))) + { + gnu_decl + = gnat_to_gnu_entity (Original_Record_Component + (gnat_entity), + gnu_expr, 0); + saved = true; + break; + } + + gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0); + gnu_decl = get_gnu_tree (gnat_entity); + saved = true; + break; + } + + else + /* Here we have no GCC type and this is a reference rather than a + definition. This should never happen. Most likely the cause is + reference before declaration in the gnat tree for gnat_entity. */ + gcc_unreachable (); + } + + case E_Loop_Parameter: + case E_Out_Parameter: + case E_Variable: + + /* Simple variables, loop variables, Out parameters, and exceptions. */ + object: + { + bool used_by_ref = false; + bool const_flag + = ((kind == E_Constant || kind == E_Variable) + && Is_True_Constant (gnat_entity) + && !Treat_As_Volatile (gnat_entity) + && (((Nkind (Declaration_Node (gnat_entity)) + == N_Object_Declaration) + && Present (Expression (Declaration_Node (gnat_entity)))) + || Present (Renamed_Object (gnat_entity)))); + bool inner_const_flag = const_flag; + bool static_p = Is_Statically_Allocated (gnat_entity); + bool mutable_p = false; + tree gnu_ext_name = NULL_TREE; + tree renamed_obj = NULL_TREE; + tree gnu_object_size; + + if (Present (Renamed_Object (gnat_entity)) && !definition) + { + if (kind == E_Exception) + gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity), + NULL_TREE, 0); + else + gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity)); + } + + /* Get the type after elaborating the renamed object. */ + gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); + + /* For a debug renaming declaration, build a pure debug entity. */ + if (Present (Debug_Renaming_Link (gnat_entity))) + { + rtx addr; + gnu_decl = build_decl (VAR_DECL, gnu_entity_id, gnu_type); + /* The (MEM (CONST (0))) pattern is prescribed by STABS. */ + if (global_bindings_p ()) + addr = gen_rtx_CONST (VOIDmode, const0_rtx); + else + addr = stack_pointer_rtx; + SET_DECL_RTL (gnu_decl, gen_rtx_MEM (Pmode, addr)); + gnat_pushdecl (gnu_decl, gnat_entity); + break; + } + + /* If this is a loop variable, its type should be the base type. + This is because the code for processing a loop determines whether + a normal loop end test can be done by comparing the bounds of the + loop against those of the base type, which is presumed to be the + size used for computation. But this is not correct when the size + of the subtype is smaller than the type. */ + if (kind == E_Loop_Parameter) + gnu_type = get_base_type (gnu_type); + + /* Reject non-renamed objects whose types are unconstrained arrays or + any object whose type is a dummy type or VOID_TYPE. */ + + if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE + && No (Renamed_Object (gnat_entity))) + || TYPE_IS_DUMMY_P (gnu_type) + || TREE_CODE (gnu_type) == VOID_TYPE) + { + gcc_assert (type_annotate_only); + if (this_global) + force_global--; + return error_mark_node; + } + + /* If an alignment is specified, use it if valid. Note that + exceptions are objects but don't have alignments. We must do this + before we validate the size, since the alignment can affect the + size. */ + if (kind != E_Exception && Known_Alignment (gnat_entity)) + { + gcc_assert (Present (Alignment (gnat_entity))); + align = validate_alignment (Alignment (gnat_entity), gnat_entity, + TYPE_ALIGN (gnu_type)); + gnu_type = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity, + "PAD", false, definition, true); + } + + /* If we are defining the object, see if it has a Size value and + validate it if so. If we are not defining the object and a Size + clause applies, simply retrieve the value. We don't want to ignore + the clause and it is expected to have been validated already. Then + get the new type, if any. */ + if (definition) + gnu_size = validate_size (Esize (gnat_entity), gnu_type, + gnat_entity, VAR_DECL, false, + Has_Size_Clause (gnat_entity)); + else if (Has_Size_Clause (gnat_entity)) + gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype); + + if (gnu_size) + { + gnu_type + = make_type_from_size (gnu_type, gnu_size, + Has_Biased_Representation (gnat_entity)); + + if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)) + gnu_size = NULL_TREE; + } + + /* If this object has self-referential size, it must be a record with + a default value. We are supposed to allocate an object of the + maximum size in this case unless it is a constant with an + initializing expression, in which case we can get the size from + that. Note that the resulting size may still be a variable, so + this may end up with an indirect allocation. */ + if (No (Renamed_Object (gnat_entity)) + && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) + { + if (gnu_expr && kind == E_Constant) + { + tree size = TYPE_SIZE (TREE_TYPE (gnu_expr)); + if (CONTAINS_PLACEHOLDER_P (size)) + { + /* If the initializing expression is itself a constant, + despite having a nominal type with self-referential + size, we can get the size directly from it. */ + if (TREE_CODE (gnu_expr) == COMPONENT_REF + && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) + == RECORD_TYPE + && TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) + && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL + && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0)) + || DECL_READONLY_ONCE_ELAB + (TREE_OPERAND (gnu_expr, 0)))) + gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0)); + else + gnu_size + = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr); + } + else + gnu_size = size; + } + /* We may have no GNU_EXPR because No_Initialization is + set even though there's an Expression. */ + else if (kind == E_Constant + && (Nkind (Declaration_Node (gnat_entity)) + == N_Object_Declaration) + && Present (Expression (Declaration_Node (gnat_entity)))) + gnu_size + = TYPE_SIZE (gnat_to_gnu_type + (Etype + (Expression (Declaration_Node (gnat_entity))))); + else + { + gnu_size = max_size (TYPE_SIZE (gnu_type), true); + mutable_p = true; + } + } + + /* If the size is zero bytes, make it one byte since some linkers have + trouble with zero-sized objects. If the object will have a + template, that will make it nonzero so don't bother. Also avoid + doing that for an object renaming or an object with an address + clause, as we would lose useful information on the view size + (e.g. for null array slices) and we are not allocating the object + here anyway. */ + if (((gnu_size + && integer_zerop (gnu_size) + && !TREE_OVERFLOW (gnu_size)) + || (TYPE_SIZE (gnu_type) + && integer_zerop (TYPE_SIZE (gnu_type)) + && !TREE_OVERFLOW (TYPE_SIZE (gnu_type)))) + && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) + || !Is_Array_Type (Etype (gnat_entity))) + && !Present (Renamed_Object (gnat_entity)) + && !Present (Address_Clause (gnat_entity))) + gnu_size = bitsize_unit_node; + + /* If this is an object with no specified size and alignment, and + if either it is atomic or we are not optimizing alignment for + space and it is composite and not an exception, an Out parameter + or a reference to another object, and the size of its type is a + constant, set the alignment to the smallest one which is not + smaller than the size, with an appropriate cap. */ + if (!gnu_size && align == 0 + && (Is_Atomic (gnat_entity) + || (!Optimize_Alignment_Space (gnat_entity) + && kind != E_Exception + && kind != E_Out_Parameter + && Is_Composite_Type (Etype (gnat_entity)) + && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) + && !imported_p + && No (Renamed_Object (gnat_entity)) + && No (Address_Clause (gnat_entity)))) + && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST) + { + /* No point in jumping through all the hoops needed in order + to support BIGGEST_ALIGNMENT if we don't really have to. + So we cap to the smallest alignment that corresponds to + a known efficient memory access pattern of the target. */ + unsigned int align_cap = Is_Atomic (gnat_entity) + ? BIGGEST_ALIGNMENT + : get_mode_alignment (ptr_mode); + + if (!host_integerp (TYPE_SIZE (gnu_type), 1) + || compare_tree_int (TYPE_SIZE (gnu_type), align_cap) >= 0) + align = align_cap; + else + align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1)); + + /* But make sure not to under-align the object. */ + if (align <= TYPE_ALIGN (gnu_type)) + align = 0; + + /* And honor the minimum valid atomic alignment, if any. */ + #ifdef MINIMUM_ATOMIC_ALIGNMENT + else if (align < MINIMUM_ATOMIC_ALIGNMENT) + align = MINIMUM_ATOMIC_ALIGNMENT; + #endif + } + + /* If the object is set to have atomic components, find the component + type and validate it. + + ??? Note that we ignore Has_Volatile_Components on objects; it's + not at all clear what to do in that case. */ + + if (Has_Atomic_Components (gnat_entity)) + { + tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE + ? TREE_TYPE (gnu_type) : gnu_type); + + while (TREE_CODE (gnu_inner) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (gnu_inner)) + gnu_inner = TREE_TYPE (gnu_inner); + + check_ok_for_atomic (gnu_inner, gnat_entity, true); + } + + /* Now check if the type of the object allows atomic access. Note + that we must test the type, even if this object has size and + alignment to allow such access, because we will be going + inside the padded record to assign to the object. We could fix + this by always copying via an intermediate value, but it's not + clear it's worth the effort. */ + if (Is_Atomic (gnat_entity)) + check_ok_for_atomic (gnu_type, gnat_entity, false); + + /* If this is an aliased object with an unconstrained nominal subtype, + make a type that includes the template. */ + if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) + && Is_Array_Type (Etype (gnat_entity)) + && !type_annotate_only) + { + tree gnu_fat + = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity)))); + + gnu_type + = build_unc_object_type_from_ptr (gnu_fat, gnu_type, + concat_id_with_name (gnu_entity_id, + "UNC")); + } + + #ifdef MINIMUM_ATOMIC_ALIGNMENT + /* If the size is a constant and no alignment is specified, force + the alignment to be the minimum valid atomic alignment. The + restriction on constant size avoids problems with variable-size + temporaries; if the size is variable, there's no issue with + atomic access. Also don't do this for a constant, since it isn't + necessary and can interfere with constant replacement. Finally, + do not do it for Out parameters since that creates an + size inconsistency with In parameters. */ + if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type) + && !FLOAT_TYPE_P (gnu_type) + && !const_flag && No (Renamed_Object (gnat_entity)) + && !imported_p && No (Address_Clause (gnat_entity)) + && kind != E_Out_Parameter + && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST + : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)) + align = MINIMUM_ATOMIC_ALIGNMENT; + #endif + + /* Make a new type with the desired size and alignment, if needed. + But do not take into account alignment promotions to compute the + size of the object. */ + gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type); + if (gnu_size || align > 0) + gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity, + "PAD", false, definition, + gnu_size ? true : false); + + /* If this is a renaming, avoid as much as possible to create a new + object. However, in several cases, creating it is required. + This processing needs to be applied to the raw expression so + as to make it more likely to rename the underlying object. */ + if (Present (Renamed_Object (gnat_entity))) + { + bool create_normal_object = false; + + /* If the renamed object had padding, strip off the reference + to the inner object and reset our type. */ + if ((TREE_CODE (gnu_expr) == COMPONENT_REF + && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) + == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) + /* Strip useless conversions around the object. */ + || (TREE_CODE (gnu_expr) == NOP_EXPR + && gnat_types_compatible_p + (TREE_TYPE (gnu_expr), + TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))) + { + gnu_expr = TREE_OPERAND (gnu_expr, 0); + gnu_type = TREE_TYPE (gnu_expr); + } + + /* Case 1: If this is a constant renaming stemming from a function + call, treat it as a normal object whose initial value is what + is being renamed. RM 3.3 says that the result of evaluating a + function call is a constant object. As a consequence, it can + be the inner object of a constant renaming. In this case, the + renaming must be fully instantiated, i.e. it cannot be a mere + reference to (part of) an existing object. */ + if (const_flag) + { + tree inner_object = gnu_expr; + while (handled_component_p (inner_object)) + inner_object = TREE_OPERAND (inner_object, 0); + if (TREE_CODE (inner_object) == CALL_EXPR) + create_normal_object = true; + } + + /* Otherwise, see if we can proceed with a stabilized version of + the renamed entity or if we need to make a new object. */ + if (!create_normal_object) + { + tree maybe_stable_expr = NULL_TREE; + bool stable = false; + + /* Case 2: If the renaming entity need not be materialized and + the renamed expression is something we can stabilize, use + that for the renaming. At the global level, we can only do + this if we know no SAVE_EXPRs need be made, because the + expression we return might be used in arbitrary conditional + branches so we must force the SAVE_EXPRs evaluation + immediately and this requires a function context. */ + if (!Materialize_Entity (gnat_entity) + && (!global_bindings_p () + || (staticp (gnu_expr) + && !TREE_SIDE_EFFECTS (gnu_expr)))) + { + maybe_stable_expr + = maybe_stabilize_reference (gnu_expr, true, &stable); + + if (stable) + { + gnu_decl = maybe_stable_expr; + /* ??? No DECL_EXPR is created so we need to mark + the expression manually lest it is shared. */ + if (global_bindings_p ()) + mark_visited (&gnu_decl); + save_gnu_tree (gnat_entity, gnu_decl, true); + saved = true; + break; + } + + /* The stabilization failed. Keep maybe_stable_expr + untouched here to let the pointer case below know + about that failure. */ + } + + /* Case 3: If this is a constant renaming and creating a + new object is allowed and cheap, treat it as a normal + object whose initial value is what is being renamed. */ + if (const_flag && Is_Elementary_Type (Etype (gnat_entity))) + ; + + /* Case 4: Make this into a constant pointer to the object we + are to rename and attach the object to the pointer if it is + something we can stabilize. + + From the proper scope, attached objects will be referenced + directly instead of indirectly via the pointer to avoid + subtle aliasing problems with non-addressable entities. + They have to be stable because we must not evaluate the + variables in the expression every time the renaming is used. + The pointer is called a "renaming" pointer in this case. + + In the rare cases where we cannot stabilize the renamed + object, we just make a "bare" pointer, and the renamed + entity is always accessed indirectly through it. */ + else + { + gnu_type = build_reference_type (gnu_type); + inner_const_flag = TREE_READONLY (gnu_expr); + const_flag = true; + + /* If the previous attempt at stabilizing failed, there + is no point in trying again and we reuse the result + without attaching it to the pointer. In this case it + will only be used as the initializing expression of + the pointer and thus needs no special treatment with + regard to multiple evaluations. */ + if (maybe_stable_expr) + ; + + /* Otherwise, try to stabilize and attach the expression + to the pointer if the stabilization succeeds. + + Note that this might introduce SAVE_EXPRs and we don't + check whether we're at the global level or not. This + is fine since we are building a pointer initializer and + neither the pointer nor the initializing expression can + be accessed before the pointer elaboration has taken + place in a correct program. + + These SAVE_EXPRs will be evaluated at the right place + by either the evaluation of the initializer for the + non-global case or the elaboration code for the global + case, and will be attached to the elaboration procedure + in the latter case. */ + else + { + maybe_stable_expr + = maybe_stabilize_reference (gnu_expr, true, &stable); + + if (stable) + renamed_obj = maybe_stable_expr; + + /* Attaching is actually performed downstream, as soon + as we have a VAR_DECL for the pointer we make. */ + } + + gnu_expr + = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr); + + gnu_size = NULL_TREE; + used_by_ref = true; + } + } + } + + /* Make a volatile version of this object's type if we are to make + the object volatile. We also interpret 13.3(19) conservatively + and disallow any optimizations for an object covered by it. */ + if ((Treat_As_Volatile (gnat_entity) + || (Is_Exported (gnat_entity) + /* Exclude exported constants created by the compiler, + which should boil down to static dispatch tables and + make it possible to put them in read-only memory. */ + && (Comes_From_Source (gnat_entity) || !const_flag)) + || Is_Imported (gnat_entity) + || Present (Address_Clause (gnat_entity))) + && !TYPE_VOLATILE (gnu_type)) + gnu_type = build_qualified_type (gnu_type, + (TYPE_QUALS (gnu_type) + | TYPE_QUAL_VOLATILE)); + + /* If we are defining an aliased object whose nominal subtype is + unconstrained, the object is a record that contains both the + template and the object. If there is an initializer, it will + have already been converted to the right type, but we need to + create the template if there is no initializer. */ + if (definition + && !gnu_expr + && TREE_CODE (gnu_type) == RECORD_TYPE + && (TYPE_CONTAINS_TEMPLATE_P (gnu_type) + /* Beware that padding might have been introduced + via maybe_pad_type above. */ + || (TYPE_IS_PADDING_P (gnu_type) + && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) + == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P + (TREE_TYPE (TYPE_FIELDS (gnu_type)))))) + { + tree template_field + = TYPE_IS_PADDING_P (gnu_type) + ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type))) + : TYPE_FIELDS (gnu_type); + + gnu_expr + = gnat_build_constructor + (gnu_type, + tree_cons + (template_field, + build_template (TREE_TYPE (template_field), + TREE_TYPE (TREE_CHAIN (template_field)), + NULL_TREE), + NULL_TREE)); + } + + /* Convert the expression to the type of the object except in the + case where the object's type is unconstrained or the object's type + is a padded record whose field is of self-referential size. In + the former case, converting will generate unnecessary evaluations + of the CONSTRUCTOR to compute the size and in the latter case, we + want to only copy the actual data. */ + if (gnu_expr + && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE + && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) + && !(TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_type) + && (CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))) + gnu_expr = convert (gnu_type, gnu_expr); + + /* If this is a pointer and it does not have an initializing + expression, initialize it to NULL, unless the object is + imported. */ + if (definition + && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type)) + && !Is_Imported (gnat_entity) && !gnu_expr) + gnu_expr = integer_zero_node; + + /* If we are defining the object and it has an Address clause, we must + either get the address expression from the saved GCC tree for the + object if it has a Freeze node, or elaborate the address expression + here since the front-end has guaranteed that the elaboration has no + effects in this case. */ + if (definition && Present (Address_Clause (gnat_entity))) + { + tree gnu_address + = present_gnu_tree (gnat_entity) + ? get_gnu_tree (gnat_entity) + : gnat_to_gnu (Expression (Address_Clause (gnat_entity))); + + save_gnu_tree (gnat_entity, NULL_TREE, false); + + /* Ignore the size. It's either meaningless or was handled + above. */ + gnu_size = NULL_TREE; + /* Convert the type of the object to a reference type that can + alias everything as per 13.3(19). */ + gnu_type + = build_reference_type_for_mode (gnu_type, ptr_mode, true); + gnu_address = convert (gnu_type, gnu_address); + used_by_ref = true; + const_flag = !Is_Public (gnat_entity) + || compile_time_known_address_p (Expression (Address_Clause + (gnat_entity))); + + /* If this is a deferred constant, the initializer is attached to + the full view. */ + if (kind == E_Constant && Present (Full_View (gnat_entity))) + gnu_expr + = gnat_to_gnu + (Expression (Declaration_Node (Full_View (gnat_entity)))); + + /* If we don't have an initializing expression for the underlying + variable, the initializing expression for the pointer is the + specified address. Otherwise, we have to make a COMPOUND_EXPR + to assign both the address and the initial value. */ + if (!gnu_expr) + gnu_expr = gnu_address; + else + gnu_expr + = build2 (COMPOUND_EXPR, gnu_type, + build_binary_op + (MODIFY_EXPR, NULL_TREE, + build_unary_op (INDIRECT_REF, NULL_TREE, + gnu_address), + gnu_expr), + gnu_address); + } + + /* If it has an address clause and we are not defining it, mark it + as an indirect object. Likewise for Stdcall objects that are + imported. */ + if ((!definition && Present (Address_Clause (gnat_entity))) + || (Is_Imported (gnat_entity) + && Has_Stdcall_Convention (gnat_entity))) + { + /* Convert the type of the object to a reference type that can + alias everything as per 13.3(19). */ + gnu_type + = build_reference_type_for_mode (gnu_type, ptr_mode, true); + gnu_size = NULL_TREE; + + /* No point in taking the address of an initializing expression + that isn't going to be used. */ + gnu_expr = NULL_TREE; + + /* If it has an address clause whose value is known at compile + time, make the object a CONST_DECL. This will avoid a + useless dereference. */ + if (Present (Address_Clause (gnat_entity))) + { + Node_Id gnat_address + = Expression (Address_Clause (gnat_entity)); + + if (compile_time_known_address_p (gnat_address)) + { + gnu_expr = gnat_to_gnu (gnat_address); + const_flag = true; + } + } + + used_by_ref = true; + } + + /* If we are at top level and this object is of variable size, + make the actual type a hidden pointer to the real type and + make the initializer be a memory allocation and initialization. + Likewise for objects we aren't defining (presumed to be + external references from other packages), but there we do + not set up an initialization. + + If the object's size overflows, make an allocator too, so that + Storage_Error gets raised. Note that we will never free + such memory, so we presume it never will get allocated. */ + + if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type), + global_bindings_p () || !definition + || static_p) + || (gnu_size + && ! allocatable_size_p (gnu_size, + global_bindings_p () || !definition + || static_p))) + { + gnu_type = build_reference_type (gnu_type); + gnu_size = NULL_TREE; + used_by_ref = true; + const_flag = true; + + /* In case this was a aliased object whose nominal subtype is + unconstrained, the pointer above will be a thin pointer and + build_allocator will automatically make the template. + + If we have a template initializer only (that we made above), + pretend there is none and rely on what build_allocator creates + again anyway. Otherwise (if we have a full initializer), get + the data part and feed that to build_allocator. + + If we are elaborating a mutable object, tell build_allocator to + ignore a possibly simpler size from the initializer, if any, as + we must allocate the maximum possible size in this case. */ + + if (definition) + { + tree gnu_alloc_type = TREE_TYPE (gnu_type); + + if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type)) + { + gnu_alloc_type + = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type))); + + if (TREE_CODE (gnu_expr) == CONSTRUCTOR + && 1 == VEC_length (constructor_elt, + CONSTRUCTOR_ELTS (gnu_expr))) + gnu_expr = 0; + else + gnu_expr + = build_component_ref + (gnu_expr, NULL_TREE, + TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), + false); + } + + if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST + && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type)) + && !Is_Imported (gnat_entity)) + post_error ("?Storage_Error will be raised at run-time!", + gnat_entity); + + gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, gnu_type, + 0, 0, gnat_entity, mutable_p); + } + else + { + gnu_expr = NULL_TREE; + const_flag = false; + } + } + + /* If this object would go into the stack and has an alignment larger + than the largest stack alignment the back-end can honor, resort to + a variable of "aligning type". */ + if (!global_bindings_p () && !static_p && definition + && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT) + { + /* Create the new variable. No need for extra room before the + aligned field as this is in automatic storage. */ + tree gnu_new_type + = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type), + TYPE_SIZE_UNIT (gnu_type), + BIGGEST_ALIGNMENT, 0); + tree gnu_new_var + = create_var_decl (create_concat_name (gnat_entity, "ALIGN"), + NULL_TREE, gnu_new_type, NULL_TREE, false, + false, false, false, NULL, gnat_entity); + + /* Initialize the aligned field if we have an initializer. */ + if (gnu_expr) + add_stmt_with_node + (build_binary_op (MODIFY_EXPR, NULL_TREE, + build_component_ref + (gnu_new_var, NULL_TREE, + TYPE_FIELDS (gnu_new_type), false), + gnu_expr), + gnat_entity); + + /* And setup this entity as a reference to the aligned field. */ + gnu_type = build_reference_type (gnu_type); + gnu_expr + = build_unary_op + (ADDR_EXPR, gnu_type, + build_component_ref (gnu_new_var, NULL_TREE, + TYPE_FIELDS (gnu_new_type), false)); + + gnu_size = NULL_TREE; + used_by_ref = true; + const_flag = true; + } + + if (const_flag) + gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type) + | TYPE_QUAL_CONST)); + + /* Convert the expression to the type of the object except in the + case where the object's type is unconstrained or the object's type + is a padded record whose field is of self-referential size. In + the former case, converting will generate unnecessary evaluations + of the CONSTRUCTOR to compute the size and in the latter case, we + want to only copy the actual data. */ + if (gnu_expr + && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE + && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) + && !(TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_type) + && (CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))) + gnu_expr = convert (gnu_type, gnu_expr); + + /* If this name is external or there was a name specified, use it, + unless this is a VMS exception object since this would conflict + with the symbol we need to export in addition. Don't use the + Interface_Name if there is an address clause (see CD30005). */ + if (!Is_VMS_Exception (gnat_entity) + && ((Present (Interface_Name (gnat_entity)) + && No (Address_Clause (gnat_entity))) + || (Is_Public (gnat_entity) + && (!Is_Imported (gnat_entity) + || Is_Exported (gnat_entity))))) + gnu_ext_name = create_concat_name (gnat_entity, 0); + + /* If this is constant initialized to a static constant and the + object has an aggregate type, force it to be statically + allocated. This will avoid an initialization copy. */ + if (!static_p && const_flag + && gnu_expr && TREE_CONSTANT (gnu_expr) + && AGGREGATE_TYPE_P (gnu_type) + && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1) + && !(TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_type) + && !host_integerp (TYPE_SIZE_UNIT + (TREE_TYPE (TYPE_FIELDS (gnu_type))), 1))) + static_p = true; + + gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, + gnu_expr, const_flag, + Is_Public (gnat_entity), + imported_p || !definition, + static_p, attr_list, gnat_entity); + DECL_BY_REF_P (gnu_decl) = used_by_ref; + DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag; + if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj) + { + SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj); + if (global_bindings_p ()) + { + DECL_RENAMING_GLOBAL_P (gnu_decl) = 1; + record_global_renaming_pointer (gnu_decl); + } + } + + if (definition && DECL_SIZE_UNIT (gnu_decl) + && get_block_jmpbuf_decl () + && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST + || (flag_stack_check == GENERIC_STACK_CHECK + && compare_tree_int (DECL_SIZE_UNIT (gnu_decl), + STACK_CHECK_MAX_VAR_SIZE) > 0))) + add_stmt_with_node (build_call_1_expr + (update_setjmp_buf_decl, + build_unary_op (ADDR_EXPR, NULL_TREE, + get_block_jmpbuf_decl ())), + gnat_entity); + + /* If we are defining an Out parameter and we're not optimizing, + create a fake PARM_DECL for debugging purposes and make it + point to the VAR_DECL. Suppress debug info for the latter + but make sure it will still live on the stack so it can be + accessed from within the debugger through the PARM_DECL. */ + if (kind == E_Out_Parameter && definition && !optimize) + { + tree param = create_param_decl (gnu_entity_id, gnu_type, false); + gnat_pushdecl (param, gnat_entity); + SET_DECL_VALUE_EXPR (param, gnu_decl); + DECL_HAS_VALUE_EXPR_P (param) = 1; + if (debug_info_p) + debug_info_p = false; + else + DECL_IGNORED_P (param) = 1; + TREE_ADDRESSABLE (gnu_decl) = 1; + } + + /* If this is a public constant or we're not optimizing and we're not + making a VAR_DECL for it, make one just for export or debugger use. + Likewise if the address is taken or if either the object or type is + aliased. Make an external declaration for a reference, unless this + is a Standard entity since there no real symbol at the object level + for these. */ + if (TREE_CODE (gnu_decl) == CONST_DECL + && (definition || Sloc (gnat_entity) > Standard_Location) + && ((Is_Public (gnat_entity) + && !Present (Address_Clause (gnat_entity))) + || !optimize + || Address_Taken (gnat_entity) + || Is_Aliased (gnat_entity) + || Is_Aliased (Etype (gnat_entity)))) + { + tree gnu_corr_var + = create_true_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, + gnu_expr, true, Is_Public (gnat_entity), + !definition, static_p, NULL, + gnat_entity); + + SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var); + + /* As debugging information will be generated for the variable, + do not generate information for the constant. */ + DECL_IGNORED_P (gnu_decl) = 1; + } + + /* If this is declared in a block that contains a block with an + exception handler, we must force this variable in memory to + suppress an invalid optimization. */ + if (Has_Nested_Block_With_Handler (Scope (gnat_entity)) + && Exception_Mechanism != Back_End_Exceptions) + TREE_ADDRESSABLE (gnu_decl) = 1; + + gnu_type = TREE_TYPE (gnu_decl); + + /* Back-annotate Alignment and Esize of the object if not already + known, except for when the object is actually a pointer to the + real object, since alignment and size of a pointer don't have + anything to do with those of the designated object. Note that + we pick the values of the type, not those of the object, to + shield ourselves from low-level platform-dependent adjustments + like alignment promotion. This is both consistent with all the + treatment above, where alignment and size are set on the type of + the object and not on the object directly, and makes it possible + to support confirming representation clauses in all cases. */ + + if (!used_by_ref && Unknown_Alignment (gnat_entity)) + Set_Alignment (gnat_entity, + UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); + + if (!used_by_ref && Unknown_Esize (gnat_entity)) + { + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) + gnu_object_size + = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))); + + Set_Esize (gnat_entity, annotate_value (gnu_object_size)); + } + } + break; + + case E_Void: + /* Return a TYPE_DECL for "void" that we previously made. */ + gnu_decl = void_type_decl_node; + break; + + case E_Enumeration_Type: + /* A special case, for the types Character and Wide_Character in + Standard, we do not list all the literals. So if the literals + are not specified, make this an unsigned type. */ + if (No (First_Literal (gnat_entity))) + { + gnu_type = make_unsigned_type (esize); + TYPE_NAME (gnu_type) = gnu_entity_id; + + /* Set TYPE_STRING_FLAG for Ada Character and Wide_Character types. + This is needed by the DWARF-2 back-end to distinguish between + unsigned integer types and character types. */ + TYPE_STRING_FLAG (gnu_type) = 1; + break; + } + + /* Normal case of non-character type, or non-Standard character type */ + { + /* Here we have a list of enumeral constants in First_Literal. + We make a CONST_DECL for each and build into GNU_LITERAL_LIST + the list to be places into TYPE_FIELDS. Each node in the list + is a TREE_LIST node whose TREE_VALUE is the literal name + and whose TREE_PURPOSE is the value of the literal. + + Esize contains the number of bits needed to represent the enumeral + type, Type_Low_Bound also points to the first literal and + Type_High_Bound points to the last literal. */ + + Entity_Id gnat_literal; + tree gnu_literal_list = NULL_TREE; + + if (Is_Unsigned_Type (gnat_entity)) + gnu_type = make_unsigned_type (esize); + else + gnu_type = make_signed_type (esize); + + TREE_SET_CODE (gnu_type, ENUMERAL_TYPE); + + for (gnat_literal = First_Literal (gnat_entity); + Present (gnat_literal); + gnat_literal = Next_Literal (gnat_literal)) + { + tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal), + gnu_type); + tree gnu_literal + = create_var_decl (get_entity_name (gnat_literal), NULL_TREE, + gnu_type, gnu_value, true, false, false, + false, NULL, gnat_literal); + + save_gnu_tree (gnat_literal, gnu_literal, false); + gnu_literal_list = tree_cons (DECL_NAME (gnu_literal), + gnu_value, gnu_literal_list); + } + + TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list); + + /* Note that the bounds are updated at the end of this function + because to avoid an infinite recursion when we get the bounds of + this type, since those bounds are objects of this type. */ + } + break; + + case E_Signed_Integer_Type: + case E_Ordinary_Fixed_Point_Type: + case E_Decimal_Fixed_Point_Type: + /* For integer types, just make a signed type the appropriate number + of bits. */ + gnu_type = make_signed_type (esize); + break; + + case E_Modular_Integer_Type: + /* For modular types, make the unsigned type of the proper number of + bits and then set up the modulus, if required. */ + { + enum machine_mode mode; + tree gnu_modulus; + tree gnu_high = 0; + + if (Is_Packed_Array_Type (gnat_entity)) + esize = UI_To_Int (RM_Size (gnat_entity)); + + /* Find the smallest mode at least ESIZE bits wide and make a class + using that mode. */ + + for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); + GET_MODE_BITSIZE (mode) < esize; + mode = GET_MODE_WIDER_MODE (mode)) + ; + + gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode)); + TYPE_PACKED_ARRAY_TYPE_P (gnu_type) + = (Is_Packed_Array_Type (gnat_entity) + && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))); + + /* Get the modulus in this type. If it overflows, assume it is because + it is equal to 2**Esize. Note that there is no overflow checking + done on unsigned type, so we detect the overflow by looking for + a modulus of zero, which is otherwise invalid. */ + gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type); + + if (!integer_zerop (gnu_modulus)) + { + TYPE_MODULAR_P (gnu_type) = 1; + SET_TYPE_MODULUS (gnu_type, gnu_modulus); + gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus, + convert (gnu_type, integer_one_node)); + } + + /* If we have to set TYPE_PRECISION different from its natural value, + make a subtype to do do. Likewise if there is a modulus and + it is not one greater than TYPE_MAX_VALUE. */ + if (TYPE_PRECISION (gnu_type) != esize + || (TYPE_MODULAR_P (gnu_type) + && !tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high))) + { + tree gnu_subtype = make_node (INTEGER_TYPE); + + TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT"); + TREE_TYPE (gnu_subtype) = gnu_type; + TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type); + TYPE_MAX_VALUE (gnu_subtype) + = TYPE_MODULAR_P (gnu_type) + ? gnu_high : TYPE_MAX_VALUE (gnu_type); + TYPE_PRECISION (gnu_subtype) = esize; + TYPE_UNSIGNED (gnu_subtype) = 1; + TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1; + TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype) + = (Is_Packed_Array_Type (gnat_entity) + && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))); + layout_type (gnu_subtype); + + gnu_type = gnu_subtype; + } + } + break; + + case E_Signed_Integer_Subtype: + case E_Enumeration_Subtype: + case E_Modular_Integer_Subtype: + case E_Ordinary_Fixed_Point_Subtype: + case E_Decimal_Fixed_Point_Subtype: + + /* For integral subtypes, we make a new INTEGER_TYPE. Note + that we do not want to call build_range_type since we would + like each subtype node to be distinct. This will be important + when memory aliasing is implemented. + + The TREE_TYPE field of the INTEGER_TYPE we make points to the + parent type; this fact is used by the arithmetic conversion + functions. + + We elaborate the Ancestor_Subtype if it is not in the current + unit and one of our bounds is non-static. We do this to ensure + consistent naming in the case where several subtypes share the same + bounds by always elaborating the first such subtype first, thus + using its name. */ + + if (!definition + && Present (Ancestor_Subtype (gnat_entity)) + && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) + && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) + || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) + gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), + gnu_expr, 0); + + gnu_type = make_node (INTEGER_TYPE); + TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); + + /* Set the precision to the Esize except for bit-packed arrays and + subtypes of Standard.Boolean. */ + if (Is_Packed_Array_Type (gnat_entity) + && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))) + { + esize = UI_To_Int (RM_Size (gnat_entity)); + TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1; + } + else if (TREE_CODE (TREE_TYPE (gnu_type)) == BOOLEAN_TYPE) + esize = 1; + + TYPE_PRECISION (gnu_type) = esize; + + TYPE_MIN_VALUE (gnu_type) + = convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_Low_Bound (gnat_entity), + gnat_entity, + get_identifier ("L"), definition, 1, + Needs_Debug_Info (gnat_entity))); + + TYPE_MAX_VALUE (gnu_type) + = convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_High_Bound (gnat_entity), + gnat_entity, + get_identifier ("U"), definition, 1, + Needs_Debug_Info (gnat_entity))); + + /* One of the above calls might have caused us to be elaborated, + so don't blow up if so. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = true; + break; + } + + TYPE_BIASED_REPRESENTATION_P (gnu_type) + = Has_Biased_Representation (gnat_entity); + + /* This should be an unsigned type if the lower bound is constant + and non-negative or if the base type is unsigned; a signed type + otherwise. */ + TYPE_UNSIGNED (gnu_type) + = (TYPE_UNSIGNED (TREE_TYPE (gnu_type)) + || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST + && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0) + || TYPE_BIASED_REPRESENTATION_P (gnu_type) + || Is_Unsigned_Type (gnat_entity)); + + layout_type (gnu_type); + + /* Inherit our alias set from what we're a subtype of. Subtypes + are not different types and a pointer can designate any instance + within a subtype hierarchy. */ + relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY); + + /* If the type we are dealing with is to represent a packed array, + we need to have the bits left justified on big-endian targets + and right justified on little-endian targets. We also need to + ensure that when the value is read (e.g. for comparison of two + such values), we only get the good bits, since the unused bits + are uninitialized. Both goals are accomplished by wrapping the + modular value in an enclosing struct. */ + if (Is_Packed_Array_Type (gnat_entity) + && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))) + { + tree gnu_field_type = gnu_type; + tree gnu_field; + + TYPE_RM_SIZE_NUM (gnu_field_type) + = UI_To_gnu (RM_Size (gnat_entity), bitsizetype); + gnu_type = make_node (RECORD_TYPE); + TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM"); + + /* Propagate the alignment of the modular type to the record. + This means that bitpacked arrays have "ceil" alignment for + their size, which may seem counter-intuitive but makes it + possible to easily overlay them on modular types. */ + TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type); + TYPE_PACKED (gnu_type) = 1; + + /* Create a stripped-down declaration of the original type, mainly + for debugging. */ + create_type_decl (get_entity_name (gnat_entity), gnu_field_type, + NULL, true, debug_info_p, gnat_entity); + + /* Don't notify the field as "addressable", since we won't be taking + it's address and it would prevent create_field_decl from making a + bitfield. */ + gnu_field = create_field_decl (get_identifier ("OBJECT"), + gnu_field_type, gnu_type, 1, 0, 0, 0); + + finish_record_type (gnu_type, gnu_field, 0, false); + TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1; + SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize)); + + relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY); + } + + /* If the type we are dealing with has got a smaller alignment than the + natural one, we need to wrap it up in a record type and under-align + the latter. We reuse the padding machinery for this purpose. */ + else if (Known_Alignment (gnat_entity) + && UI_Is_In_Int_Range (Alignment (gnat_entity)) + && (align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT) + && align < TYPE_ALIGN (gnu_type)) + { + tree gnu_field_type = gnu_type; + tree gnu_field; + + gnu_type = make_node (RECORD_TYPE); + TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD"); + + TYPE_ALIGN (gnu_type) = align; + TYPE_PACKED (gnu_type) = 1; + + /* Create a stripped-down declaration of the original type, mainly + for debugging. */ + create_type_decl (get_entity_name (gnat_entity), gnu_field_type, + NULL, true, debug_info_p, gnat_entity); + + /* Don't notify the field as "addressable", since we won't be taking + it's address and it would prevent create_field_decl from making a + bitfield. */ + gnu_field = create_field_decl (get_identifier ("OBJECT"), + gnu_field_type, gnu_type, 1, 0, 0, 0); + + finish_record_type (gnu_type, gnu_field, 0, false); + TYPE_IS_PADDING_P (gnu_type) = 1; + SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize)); + + relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY); + } + + /* Otherwise reset the alignment lest we computed it above. */ + else + align = 0; + + break; + + case E_Floating_Point_Type: + /* If this is a VAX floating-point type, use an integer of the proper + size. All the operations will be handled with ASM statements. */ + if (Vax_Float (gnat_entity)) + { + gnu_type = make_signed_type (esize); + TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1; + SET_TYPE_DIGITS_VALUE (gnu_type, + UI_To_gnu (Digits_Value (gnat_entity), + sizetype)); + break; + } + + /* The type of the Low and High bounds can be our type if this is + a type from Standard, so set them at the end of the function. */ + gnu_type = make_node (REAL_TYPE); + TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize); + layout_type (gnu_type); + break; + + case E_Floating_Point_Subtype: + if (Vax_Float (gnat_entity)) + { + gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); + break; + } + + { + if (!definition + && Present (Ancestor_Subtype (gnat_entity)) + && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) + && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) + || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) + gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), + gnu_expr, 0); + + gnu_type = make_node (REAL_TYPE); + TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); + TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize); + + TYPE_MIN_VALUE (gnu_type) + = convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_Low_Bound (gnat_entity), + gnat_entity, get_identifier ("L"), + definition, 1, + Needs_Debug_Info (gnat_entity))); + + TYPE_MAX_VALUE (gnu_type) + = convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_High_Bound (gnat_entity), + gnat_entity, get_identifier ("U"), + definition, 1, + Needs_Debug_Info (gnat_entity))); + + /* One of the above calls might have caused us to be elaborated, + so don't blow up if so. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = true; + break; + } + + layout_type (gnu_type); + + /* Inherit our alias set from what we're a subtype of, as for + integer subtypes. */ + relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY); + } + break; + + /* Array and String Types and Subtypes + + Unconstrained array types are represented by E_Array_Type and + constrained array types are represented by E_Array_Subtype. There + are no actual objects of an unconstrained array type; all we have + are pointers to that type. + + The following fields are defined on array types and subtypes: + + Component_Type Component type of the array. + Number_Dimensions Number of dimensions (an int). + First_Index Type of first index. */ + + case E_String_Type: + case E_Array_Type: + { + tree gnu_template_fields = NULL_TREE; + tree gnu_template_type = make_node (RECORD_TYPE); + tree gnu_ptr_template = build_pointer_type (gnu_template_type); + tree gnu_fat_type = make_node (RECORD_TYPE); + int ndim = Number_Dimensions (gnat_entity); + int firstdim + = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0; + int nextdim + = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1; + int index; + tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *)); + tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *)); + tree gnu_comp_size = 0; + tree gnu_max_size = size_one_node; + tree gnu_max_size_unit; + Entity_Id gnat_ind_subtype; + Entity_Id gnat_ind_base_subtype; + tree gnu_template_reference; + tree tem; + + TYPE_NAME (gnu_template_type) + = create_concat_name (gnat_entity, "XUB"); + + /* Make a node for the array. If we are not defining the array + suppress expanding incomplete types. */ + gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE); + + if (!definition) + defer_incomplete_level++, this_deferred = true; + + /* Build the fat pointer type. Use a "void *" object instead of + a pointer to the array type since we don't have the array type + yet (it will reference the fat pointer via the bounds). */ + tem = chainon (chainon (NULL_TREE, + create_field_decl (get_identifier ("P_ARRAY"), + ptr_void_type_node, + gnu_fat_type, 0, 0, 0, 0)), + create_field_decl (get_identifier ("P_BOUNDS"), + gnu_ptr_template, + gnu_fat_type, 0, 0, 0, 0)); + + /* Make sure we can put this into a register. */ + TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); + + /* Do not finalize this record type since the types of its fields + are still incomplete at this point. */ + finish_record_type (gnu_fat_type, tem, 0, true); + TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1; + + /* Build a reference to the template from a PLACEHOLDER_EXPR that + is the fat pointer. This will be used to access the individual + fields once we build them. */ + tem = build3 (COMPONENT_REF, gnu_ptr_template, + build0 (PLACEHOLDER_EXPR, gnu_fat_type), + TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE); + gnu_template_reference + = build_unary_op (INDIRECT_REF, gnu_template_type, tem); + TREE_READONLY (gnu_template_reference) = 1; + + /* Now create the GCC type for each index and add the fields for + that index to the template. */ + for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity), + gnat_ind_base_subtype + = First_Index (Implementation_Base_Type (gnat_entity)); + index < ndim && index >= 0; + index += nextdim, + gnat_ind_subtype = Next_Index (gnat_ind_subtype), + gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype)) + { + char field_name[10]; + tree gnu_ind_subtype + = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype))); + tree gnu_base_subtype + = get_unpadded_type (Etype (gnat_ind_base_subtype)); + tree gnu_base_min + = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype)); + tree gnu_base_max + = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype)); + tree gnu_min_field, gnu_max_field, gnu_min, gnu_max; + + /* Make the FIELD_DECLs for the minimum and maximum of this + type and then make extractions of that field from the + template. */ + sprintf (field_name, "LB%d", index); + gnu_min_field = create_field_decl (get_identifier (field_name), + gnu_ind_subtype, + gnu_template_type, 0, 0, 0, 0); + field_name[0] = 'U'; + gnu_max_field = create_field_decl (get_identifier (field_name), + gnu_ind_subtype, + gnu_template_type, 0, 0, 0, 0); + + Sloc_to_locus (Sloc (gnat_entity), + &DECL_SOURCE_LOCATION (gnu_min_field)); + Sloc_to_locus (Sloc (gnat_entity), + &DECL_SOURCE_LOCATION (gnu_max_field)); + gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field); + + /* We can't use build_component_ref here since the template + type isn't complete yet. */ + gnu_min = build3 (COMPONENT_REF, gnu_ind_subtype, + gnu_template_reference, gnu_min_field, + NULL_TREE); + gnu_max = build3 (COMPONENT_REF, gnu_ind_subtype, + gnu_template_reference, gnu_max_field, + NULL_TREE); + TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1; + + /* Make a range type with the new ranges, but using + the Ada subtype. Then we convert to sizetype. */ + gnu_index_types[index] + = create_index_type (convert (sizetype, gnu_min), + convert (sizetype, gnu_max), + build_range_type (gnu_ind_subtype, + gnu_min, gnu_max), + gnat_entity); + /* Update the maximum size of the array, in elements. */ + gnu_max_size + = size_binop (MULT_EXPR, gnu_max_size, + size_binop (PLUS_EXPR, size_one_node, + size_binop (MINUS_EXPR, gnu_base_max, + gnu_base_min))); + + TYPE_NAME (gnu_index_types[index]) + = create_concat_name (gnat_entity, field_name); + } + + for (index = 0; index < ndim; index++) + gnu_template_fields + = chainon (gnu_template_fields, gnu_temp_fields[index]); + + /* Install all the fields into the template. */ + finish_record_type (gnu_template_type, gnu_template_fields, 0, false); + TYPE_READONLY (gnu_template_type) = 1; + + /* Now make the array of arrays and update the pointer to the array + in the fat pointer. Note that it is the first field. */ + tem = gnat_to_gnu_type (Component_Type (gnat_entity)); + + /* Try to get a smaller form of the component if needed. */ + if ((Is_Packed (gnat_entity) + || Has_Component_Size_Clause (gnat_entity)) + && !Is_Bit_Packed_Array (gnat_entity) + && !Has_Aliased_Components (gnat_entity) + && !Strict_Alignment (Component_Type (gnat_entity)) + && TREE_CODE (tem) == RECORD_TYPE + && !TYPE_IS_FAT_POINTER_P (tem) + && host_integerp (TYPE_SIZE (tem), 1)) + tem = make_packable_type (tem, false); + + if (Has_Atomic_Components (gnat_entity)) + check_ok_for_atomic (tem, gnat_entity, true); + + /* Get and validate any specified Component_Size, but if Packed, + ignore it since the front end will have taken care of it. */ + gnu_comp_size + = validate_size (Component_Size (gnat_entity), tem, + gnat_entity, + (Is_Bit_Packed_Array (gnat_entity) + ? TYPE_DECL : VAR_DECL), + true, Has_Component_Size_Clause (gnat_entity)); + + /* If the component type is a RECORD_TYPE that has a self-referential + size, use the maximum size. */ + if (!gnu_comp_size && TREE_CODE (tem) == RECORD_TYPE + && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem))) + gnu_comp_size = max_size (TYPE_SIZE (tem), true); + + if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_entity)) + { + tree orig_tem; + tem = make_type_from_size (tem, gnu_comp_size, false); + orig_tem = tem; + tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity, + "C_PAD", false, definition, true); + /* If a padding record was made, declare it now since it will + never be declared otherwise. This is necessary to ensure + that its subtrees are properly marked. */ + if (tem != orig_tem) + create_type_decl (TYPE_NAME (tem), tem, NULL, true, + debug_info_p, gnat_entity); + } + + if (Has_Volatile_Components (gnat_entity)) + tem = build_qualified_type (tem, + TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE); + + /* If Component_Size is not already specified, annotate it with the + size of the component. */ + if (Unknown_Component_Size (gnat_entity)) + Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem))); + + gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node, + size_binop (MULT_EXPR, gnu_max_size, + TYPE_SIZE_UNIT (tem))); + gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node, + size_binop (MULT_EXPR, + convert (bitsizetype, + gnu_max_size), + TYPE_SIZE (tem))); + + for (index = ndim - 1; index >= 0; index--) + { + tem = build_array_type (tem, gnu_index_types[index]); + TYPE_MULTI_ARRAY_P (tem) = (index > 0); + if (array_type_has_nonaliased_component (gnat_entity, tem)) + TYPE_NONALIASED_COMPONENT (tem) = 1; + } + + /* If an alignment is specified, use it if valid. But ignore it for + types that represent the unpacked base type for packed arrays. If + the alignment was requested with an explicit user alignment clause, + state so. */ + if (No (Packed_Array_Type (gnat_entity)) + && Known_Alignment (gnat_entity)) + { + gcc_assert (Present (Alignment (gnat_entity))); + TYPE_ALIGN (tem) + = validate_alignment (Alignment (gnat_entity), gnat_entity, + TYPE_ALIGN (tem)); + if (Present (Alignment_Clause (gnat_entity))) + TYPE_USER_ALIGN (tem) = 1; + } + + TYPE_CONVENTION_FORTRAN_P (tem) + = (Convention (gnat_entity) == Convention_Fortran); + TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem); + + /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the + corresponding fat pointer. */ + TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) + = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type; + SET_TYPE_MODE (gnu_type, BLKmode); + TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem); + SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type); + + /* If the maximum size doesn't overflow, use it. */ + if (TREE_CODE (gnu_max_size) == INTEGER_CST + && !TREE_OVERFLOW (gnu_max_size)) + TYPE_SIZE (tem) + = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem)); + if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST + && !TREE_OVERFLOW (gnu_max_size_unit)) + TYPE_SIZE_UNIT (tem) + = size_binop (MIN_EXPR, gnu_max_size_unit, + TYPE_SIZE_UNIT (tem)); + + create_type_decl (create_concat_name (gnat_entity, "XUA"), + tem, NULL, !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + + /* Give the fat pointer type a name. */ + create_type_decl (create_concat_name (gnat_entity, "XUP"), + gnu_fat_type, NULL, !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + + /* Create the type to be used as what a thin pointer designates: an + record type for the object and its template with the field offsets + shifted to have the template at a negative offset. */ + tem = build_unc_object_type (gnu_template_type, tem, + create_concat_name (gnat_entity, "XUT")); + shift_unc_components_for_thin_pointers (tem); + + SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type); + TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem; + + /* Give the thin pointer type a name. */ + create_type_decl (create_concat_name (gnat_entity, "XUX"), + build_pointer_type (tem), NULL, + !Comes_From_Source (gnat_entity), debug_info_p, + gnat_entity); + } + break; + + case E_String_Subtype: + case E_Array_Subtype: + + /* This is the actual data type for array variables. Multidimensional + arrays are implemented in the gnu tree as arrays of arrays. Note + that for the moment arrays which have sparse enumeration subtypes as + index components create sparse arrays, which is obviously space + inefficient but so much easier to code for now. + + Also note that the subtype never refers to the unconstrained + array type, which is somewhat at variance with Ada semantics. + + First check to see if this is simply a renaming of the array + type. If so, the result is the array type. */ + + gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); + if (!Is_Constrained (gnat_entity)) + break; + else + { + int index; + int array_dim = Number_Dimensions (gnat_entity); + int first_dim + = ((Convention (gnat_entity) == Convention_Fortran) + ? array_dim - 1 : 0); + int next_dim + = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1; + Entity_Id gnat_ind_subtype; + Entity_Id gnat_ind_base_subtype; + tree gnu_base_type = gnu_type; + tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *)); + tree gnu_comp_size = NULL_TREE; + tree gnu_max_size = size_one_node; + tree gnu_max_size_unit; + bool need_index_type_struct = false; + bool max_overflow = false; + + /* First create the gnu types for each index. Create types for + debugging information to point to the index types if the + are not integer types, have variable bounds, or are + wider than sizetype. */ + + for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity), + gnat_ind_base_subtype + = First_Index (Implementation_Base_Type (gnat_entity)); + index < array_dim && index >= 0; + index += next_dim, + gnat_ind_subtype = Next_Index (gnat_ind_subtype), + gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype)) + { + tree gnu_index_subtype + = get_unpadded_type (Etype (gnat_ind_subtype)); + tree gnu_min + = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype)); + tree gnu_max + = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype)); + tree gnu_base_subtype + = get_unpadded_type (Etype (gnat_ind_base_subtype)); + tree gnu_base_min + = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype)); + tree gnu_base_max + = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype)); + tree gnu_base_type = get_base_type (gnu_base_subtype); + tree gnu_base_base_min + = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type)); + tree gnu_base_base_max + = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type)); + tree gnu_high; + tree gnu_this_max; + + /* If the minimum and maximum values both overflow in + SIZETYPE, but the difference in the original type + does not overflow in SIZETYPE, ignore the overflow + indications. */ + if ((TYPE_PRECISION (gnu_index_subtype) + > TYPE_PRECISION (sizetype) + || TYPE_UNSIGNED (gnu_index_subtype) + != TYPE_UNSIGNED (sizetype)) + && TREE_CODE (gnu_min) == INTEGER_CST + && TREE_CODE (gnu_max) == INTEGER_CST + && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max) + && (!TREE_OVERFLOW + (fold_build2 (MINUS_EXPR, gnu_index_subtype, + TYPE_MAX_VALUE (gnu_index_subtype), + TYPE_MIN_VALUE (gnu_index_subtype))))) + { + TREE_OVERFLOW (gnu_min) = 0; + TREE_OVERFLOW (gnu_max) = 0; + } + + /* Similarly, if the range is null, use bounds of 1..0 for + the sizetype bounds. */ + else if ((TYPE_PRECISION (gnu_index_subtype) + > TYPE_PRECISION (sizetype) + || TYPE_UNSIGNED (gnu_index_subtype) + != TYPE_UNSIGNED (sizetype)) + && TREE_CODE (gnu_min) == INTEGER_CST + && TREE_CODE (gnu_max) == INTEGER_CST + && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max)) + && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype), + TYPE_MIN_VALUE (gnu_index_subtype))) + gnu_min = size_one_node, gnu_max = size_zero_node; + + /* Now compute the size of this bound. We need to provide + GCC with an upper bound to use but have to deal with the + "superflat" case. There are three ways to do this. If we + can prove that the array can never be superflat, we can + just use the high bound of the index subtype. If we can + prove that the low bound minus one can't overflow, we + can do this as MAX (hb, lb - 1). Otherwise, we have to use + the expression hb >= lb ? hb : lb - 1. */ + gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node); + + /* See if the base array type is already flat. If it is, we + are probably compiling an ACVC test, but it will cause the + code below to malfunction if we don't handle it specially. */ + if (TREE_CODE (gnu_base_min) == INTEGER_CST + && TREE_CODE (gnu_base_max) == INTEGER_CST + && !TREE_OVERFLOW (gnu_base_min) + && !TREE_OVERFLOW (gnu_base_max) + && tree_int_cst_lt (gnu_base_max, gnu_base_min)) + gnu_high = size_zero_node, gnu_min = size_one_node; + + /* If gnu_high is now an integer which overflowed, the array + cannot be superflat. */ + else if (TREE_CODE (gnu_high) == INTEGER_CST + && TREE_OVERFLOW (gnu_high)) + gnu_high = gnu_max; + else if (TYPE_UNSIGNED (gnu_base_subtype) + || TREE_CODE (gnu_high) == INTEGER_CST) + gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high); + else + gnu_high + = build_cond_expr + (sizetype, build_binary_op (GE_EXPR, integer_type_node, + gnu_max, gnu_min), + gnu_max, gnu_high); + + gnu_index_type[index] + = create_index_type (gnu_min, gnu_high, gnu_index_subtype, + gnat_entity); + + /* Also compute the maximum size of the array. Here we + see if any constraint on the index type of the base type + can be used in the case of self-referential bound on + the index type of the subtype. We look for a non-"infinite" + and non-self-referential bound from any type involved and + handle each bound separately. */ + + if ((TREE_CODE (gnu_min) == INTEGER_CST + && !TREE_OVERFLOW (gnu_min) + && !operand_equal_p (gnu_min, gnu_base_base_min, 0)) + || !CONTAINS_PLACEHOLDER_P (gnu_min) + || !(TREE_CODE (gnu_base_min) == INTEGER_CST + && !TREE_OVERFLOW (gnu_base_min))) + gnu_base_min = gnu_min; + + if ((TREE_CODE (gnu_max) == INTEGER_CST + && !TREE_OVERFLOW (gnu_max) + && !operand_equal_p (gnu_max, gnu_base_base_max, 0)) + || !CONTAINS_PLACEHOLDER_P (gnu_max) + || !(TREE_CODE (gnu_base_max) == INTEGER_CST + && !TREE_OVERFLOW (gnu_base_max))) + gnu_base_max = gnu_max; + + if ((TREE_CODE (gnu_base_min) == INTEGER_CST + && TREE_OVERFLOW (gnu_base_min)) + || operand_equal_p (gnu_base_min, gnu_base_base_min, 0) + || (TREE_CODE (gnu_base_max) == INTEGER_CST + && TREE_OVERFLOW (gnu_base_max)) + || operand_equal_p (gnu_base_max, gnu_base_base_max, 0)) + max_overflow = true; + + gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min); + gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max); + + gnu_this_max + = size_binop (MAX_EXPR, + size_binop (PLUS_EXPR, size_one_node, + size_binop (MINUS_EXPR, gnu_base_max, + gnu_base_min)), + size_zero_node); + + if (TREE_CODE (gnu_this_max) == INTEGER_CST + && TREE_OVERFLOW (gnu_this_max)) + max_overflow = true; + + gnu_max_size + = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max); + + if (!integer_onep (TYPE_MIN_VALUE (gnu_index_subtype)) + || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype)) + != INTEGER_CST) + || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE + || (TREE_TYPE (gnu_index_subtype) + && (TREE_CODE (TREE_TYPE (gnu_index_subtype)) + != INTEGER_TYPE)) + || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype) + || (TYPE_PRECISION (gnu_index_subtype) + > TYPE_PRECISION (sizetype))) + need_index_type_struct = true; + } + + /* Then flatten: create the array of arrays. For an array type + used to implement a packed array, get the component type from + the original array type since the representation clauses that + can affect it are on the latter. */ + if (Is_Packed_Array_Type (gnat_entity) + && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))) + { + gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity)); + for (index = array_dim - 1; index >= 0; index--) + gnu_type = TREE_TYPE (gnu_type); + + /* One of the above calls might have caused us to be elaborated, + so don't blow up if so. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = true; + break; + } + } + else + { + gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity)); + + /* One of the above calls might have caused us to be elaborated, + so don't blow up if so. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = true; + break; + } + + /* Try to get a smaller form of the component if needed. */ + if ((Is_Packed (gnat_entity) + || Has_Component_Size_Clause (gnat_entity)) + && !Is_Bit_Packed_Array (gnat_entity) + && !Has_Aliased_Components (gnat_entity) + && !Strict_Alignment (Component_Type (gnat_entity)) + && TREE_CODE (gnu_type) == RECORD_TYPE + && !TYPE_IS_FAT_POINTER_P (gnu_type) + && host_integerp (TYPE_SIZE (gnu_type), 1)) + gnu_type = make_packable_type (gnu_type, false); + + /* Get and validate any specified Component_Size, but if Packed, + ignore it since the front end will have taken care of it. */ + gnu_comp_size + = validate_size (Component_Size (gnat_entity), gnu_type, + gnat_entity, + (Is_Bit_Packed_Array (gnat_entity) + ? TYPE_DECL : VAR_DECL), true, + Has_Component_Size_Clause (gnat_entity)); + + /* If the component type is a RECORD_TYPE that has a + self-referential size, use the maximum size. */ + if (!gnu_comp_size + && TREE_CODE (gnu_type) == RECORD_TYPE + && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) + gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true); + + if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_entity)) + { + tree orig_gnu_type; + gnu_type + = make_type_from_size (gnu_type, gnu_comp_size, false); + orig_gnu_type = gnu_type; + gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, + gnat_entity, "C_PAD", false, + definition, true); + /* If a padding record was made, declare it now since it + will never be declared otherwise. This is necessary + to ensure that its subtrees are properly marked. */ + if (gnu_type != orig_gnu_type) + create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, + true, debug_info_p, gnat_entity); + } + + if (Has_Volatile_Components (Base_Type (gnat_entity))) + gnu_type = build_qualified_type (gnu_type, + (TYPE_QUALS (gnu_type) + | TYPE_QUAL_VOLATILE)); + } + + gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size, + TYPE_SIZE_UNIT (gnu_type)); + gnu_max_size = size_binop (MULT_EXPR, + convert (bitsizetype, gnu_max_size), + TYPE_SIZE (gnu_type)); + + for (index = array_dim - 1; index >= 0; index --) + { + gnu_type = build_array_type (gnu_type, gnu_index_type[index]); + TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0); + if (array_type_has_nonaliased_component (gnat_entity, gnu_type)) + TYPE_NONALIASED_COMPONENT (gnu_type) = 1; + } + + /* If we are at file level and this is a multi-dimensional array, we + need to make a variable corresponding to the stride of the + inner dimensions. */ + if (global_bindings_p () && array_dim > 1) + { + tree gnu_str_name = get_identifier ("ST"); + tree gnu_arr_type; + + for (gnu_arr_type = TREE_TYPE (gnu_type); + TREE_CODE (gnu_arr_type) == ARRAY_TYPE; + gnu_arr_type = TREE_TYPE (gnu_arr_type), + gnu_str_name = concat_id_with_name (gnu_str_name, "ST")) + { + tree eltype = TREE_TYPE (gnu_arr_type); + + TYPE_SIZE (gnu_arr_type) + = elaborate_expression_1 (gnat_entity, gnat_entity, + TYPE_SIZE (gnu_arr_type), + gnu_str_name, definition, 0); + + /* ??? For now, store the size as a multiple of the + alignment of the element type in bytes so that we + can see the alignment from the tree. */ + TYPE_SIZE_UNIT (gnu_arr_type) + = build_binary_op + (MULT_EXPR, sizetype, + elaborate_expression_1 + (gnat_entity, gnat_entity, + build_binary_op (EXACT_DIV_EXPR, sizetype, + TYPE_SIZE_UNIT (gnu_arr_type), + size_int (TYPE_ALIGN (eltype) + / BITS_PER_UNIT)), + concat_id_with_name (gnu_str_name, "A_U"), + definition, 0), + size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT)); + + /* ??? create_type_decl is not invoked on the inner types so + the MULT_EXPR node built above will never be marked. */ + mark_visited (&TYPE_SIZE_UNIT (gnu_arr_type)); + } + } + + /* If we need to write out a record type giving the names of + the bounds, do it now. */ + if (need_index_type_struct && debug_info_p) + { + tree gnu_bound_rec_type = make_node (RECORD_TYPE); + tree gnu_field_list = NULL_TREE; + tree gnu_field; + + TYPE_NAME (gnu_bound_rec_type) + = create_concat_name (gnat_entity, "XA"); + + for (index = array_dim - 1; index >= 0; index--) + { + tree gnu_type_name + = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index])); + + if (TREE_CODE (gnu_type_name) == TYPE_DECL) + gnu_type_name = DECL_NAME (gnu_type_name); + + gnu_field = create_field_decl (gnu_type_name, + integer_type_node, + gnu_bound_rec_type, + 0, NULL_TREE, NULL_TREE, 0); + TREE_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + } + + finish_record_type (gnu_bound_rec_type, gnu_field_list, + 0, false); + + TYPE_STUB_DECL (gnu_type) + = build_decl (TYPE_DECL, NULL_TREE, gnu_type); + + add_parallel_type + (TYPE_STUB_DECL (gnu_type), gnu_bound_rec_type); + } + + TYPE_CONVENTION_FORTRAN_P (gnu_type) + = (Convention (gnat_entity) == Convention_Fortran); + TYPE_PACKED_ARRAY_TYPE_P (gnu_type) + = (Is_Packed_Array_Type (gnat_entity) + && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))); + + /* If our size depends on a placeholder and the maximum size doesn't + overflow, use it. */ + if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) + && !(TREE_CODE (gnu_max_size) == INTEGER_CST + && TREE_OVERFLOW (gnu_max_size)) + && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST + && TREE_OVERFLOW (gnu_max_size_unit)) + && !max_overflow) + { + TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size, + TYPE_SIZE (gnu_type)); + TYPE_SIZE_UNIT (gnu_type) + = size_binop (MIN_EXPR, gnu_max_size_unit, + TYPE_SIZE_UNIT (gnu_type)); + } + + /* Set our alias set to that of our base type. This gives all + array subtypes the same alias set. */ + relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY); + } + + /* If this is a packed type, make this type the same as the packed + array type, but do some adjusting in the type first. */ + + if (Present (Packed_Array_Type (gnat_entity))) + { + Entity_Id gnat_index; + tree gnu_inner_type; + + /* First finish the type we had been making so that we output + debugging information for it */ + gnu_type + = build_qualified_type (gnu_type, + (TYPE_QUALS (gnu_type) + | (TYPE_QUAL_VOLATILE + * Treat_As_Volatile (gnat_entity)))); + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + if (!Comes_From_Source (gnat_entity)) + DECL_ARTIFICIAL (gnu_decl) = 1; + + /* Save it as our equivalent in case the call below elaborates + this type again. */ + save_gnu_tree (gnat_entity, gnu_decl, false); + + gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity), + NULL_TREE, 0); + this_made_decl = true; + gnu_type = TREE_TYPE (gnu_decl); + save_gnu_tree (gnat_entity, NULL_TREE, false); + + gnu_inner_type = gnu_type; + while (TREE_CODE (gnu_inner_type) == RECORD_TYPE + && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner_type) + || TYPE_IS_PADDING_P (gnu_inner_type))) + gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type)); + + /* We need to point the type we just made to our index type so + the actual bounds can be put into a template. */ + + if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE + && !TYPE_ACTUAL_BOUNDS (gnu_inner_type)) + || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE + && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type))) + { + if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE) + { + /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus. + If it is, we need to make another type. */ + if (TYPE_MODULAR_P (gnu_inner_type)) + { + tree gnu_subtype; + + gnu_subtype = make_node (INTEGER_TYPE); + + TREE_TYPE (gnu_subtype) = gnu_inner_type; + TYPE_MIN_VALUE (gnu_subtype) + = TYPE_MIN_VALUE (gnu_inner_type); + TYPE_MAX_VALUE (gnu_subtype) + = TYPE_MAX_VALUE (gnu_inner_type); + TYPE_PRECISION (gnu_subtype) + = TYPE_PRECISION (gnu_inner_type); + TYPE_UNSIGNED (gnu_subtype) + = TYPE_UNSIGNED (gnu_inner_type); + TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1; + layout_type (gnu_subtype); + + gnu_inner_type = gnu_subtype; + } + + TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1; + } + + SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE); + + for (gnat_index = First_Index (gnat_entity); + Present (gnat_index); gnat_index = Next_Index (gnat_index)) + SET_TYPE_ACTUAL_BOUNDS + (gnu_inner_type, + tree_cons (NULL_TREE, + get_unpadded_type (Etype (gnat_index)), + TYPE_ACTUAL_BOUNDS (gnu_inner_type))); + + if (Convention (gnat_entity) != Convention_Fortran) + SET_TYPE_ACTUAL_BOUNDS + (gnu_inner_type, + nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type))); + + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (gnu_type)) + TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type; + } + } + + /* Abort if packed array with no packed array type field set. */ + else + gcc_assert (!Is_Packed (gnat_entity)); + + break; + + case E_String_Literal_Subtype: + /* Create the type for a string literal. */ + { + Entity_Id gnat_full_type + = (IN (Ekind (Etype (gnat_entity)), Private_Kind) + && Present (Full_View (Etype (gnat_entity))) + ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity)); + tree gnu_string_type = get_unpadded_type (gnat_full_type); + tree gnu_string_array_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type)))); + tree gnu_string_index_type + = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE + (TYPE_DOMAIN (gnu_string_array_type)))); + tree gnu_lower_bound + = convert (gnu_string_index_type, + gnat_to_gnu (String_Literal_Low_Bound (gnat_entity))); + int length = UI_To_Int (String_Literal_Length (gnat_entity)); + tree gnu_length = ssize_int (length - 1); + tree gnu_upper_bound + = build_binary_op (PLUS_EXPR, gnu_string_index_type, + gnu_lower_bound, + convert (gnu_string_index_type, gnu_length)); + tree gnu_range_type + = build_range_type (gnu_string_index_type, + gnu_lower_bound, gnu_upper_bound); + tree gnu_index_type + = create_index_type (convert (sizetype, + TYPE_MIN_VALUE (gnu_range_type)), + convert (sizetype, + TYPE_MAX_VALUE (gnu_range_type)), + gnu_range_type, gnat_entity); + + gnu_type + = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)), + gnu_index_type); + if (array_type_has_nonaliased_component (gnat_entity, gnu_type)) + TYPE_NONALIASED_COMPONENT (gnu_type) = 1; + relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY); + } + break; + + /* Record Types and Subtypes + + The following fields are defined on record types: + + Has_Discriminants True if the record has discriminants + First_Discriminant Points to head of list of discriminants + First_Entity Points to head of list of fields + Is_Tagged_Type True if the record is tagged + + Implementation of Ada records and discriminated records: + + A record type definition is transformed into the equivalent of a C + struct definition. The fields that are the discriminants which are + found in the Full_Type_Declaration node and the elements of the + Component_List found in the Record_Type_Definition node. The + Component_List can be a recursive structure since each Variant of + the Variant_Part of the Component_List has a Component_List. + + Processing of a record type definition comprises starting the list of + field declarations here from the discriminants and the calling the + function components_to_record to add the rest of the fields from the + component list and return the gnu type node. The function + components_to_record will call itself recursively as it traverses + the tree. */ + + case E_Record_Type: + if (Has_Complex_Representation (gnat_entity)) + { + gnu_type + = build_complex_type + (get_unpadded_type + (Etype (Defining_Entity + (First (Component_Items + (Component_List + (Type_Definition + (Declaration_Node (gnat_entity))))))))); + + break; + } + + { + Node_Id full_definition = Declaration_Node (gnat_entity); + Node_Id record_definition = Type_Definition (full_definition); + Entity_Id gnat_field; + tree gnu_field; + tree gnu_field_list = NULL_TREE; + tree gnu_get_parent; + /* Set PACKED in keeping with gnat_to_gnu_field. */ + int packed + = Is_Packed (gnat_entity) + ? 1 + : Component_Alignment (gnat_entity) == Calign_Storage_Unit + ? -1 + : (Known_Alignment (gnat_entity) + || (Strict_Alignment (gnat_entity) + && Known_Static_Esize (gnat_entity))) + ? -2 + : 0; + bool has_rep = Has_Specified_Layout (gnat_entity); + bool all_rep = has_rep; + bool is_extension + = (Is_Tagged_Type (gnat_entity) + && Nkind (record_definition) == N_Derived_Type_Definition); + + /* See if all fields have a rep clause. Stop when we find one + that doesn't. */ + for (gnat_field = First_Entity (gnat_entity); + Present (gnat_field) && all_rep; + gnat_field = Next_Entity (gnat_field)) + if ((Ekind (gnat_field) == E_Component + || Ekind (gnat_field) == E_Discriminant) + && No (Component_Clause (gnat_field))) + all_rep = false; + + /* If this is a record extension, go a level further to find the + record definition. Also, verify we have a Parent_Subtype. */ + if (is_extension) + { + if (!type_annotate_only + || Present (Record_Extension_Part (record_definition))) + record_definition = Record_Extension_Part (record_definition); + + gcc_assert (type_annotate_only + || Present (Parent_Subtype (gnat_entity))); + } + + /* Make a node for the record. If we are not defining the record, + suppress expanding incomplete types. */ + gnu_type = make_node (tree_code_for_record_type (gnat_entity)); + TYPE_NAME (gnu_type) = gnu_entity_id; + TYPE_PACKED (gnu_type) = (packed != 0) || has_rep; + + if (!definition) + defer_incomplete_level++, this_deferred = true; + + /* If both a size and rep clause was specified, put the size in + the record type now so that it can get the proper mode. */ + if (has_rep && Known_Esize (gnat_entity)) + TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype); + + /* Always set the alignment here so that it can be used to + set the mode, if it is making the alignment stricter. If + it is invalid, it will be checked again below. If this is to + be Atomic, choose a default alignment of a word unless we know + the size and it's smaller. */ + if (Known_Alignment (gnat_entity)) + TYPE_ALIGN (gnu_type) + = validate_alignment (Alignment (gnat_entity), gnat_entity, 0); + else if (Is_Atomic (gnat_entity)) + TYPE_ALIGN (gnu_type) + = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize); + /* If a type needs strict alignment, the minimum size will be the + type size instead of the RM size (see validate_size). Cap the + alignment, lest it causes this type size to become too large. */ + else if (Strict_Alignment (gnat_entity) + && Known_Static_Esize (gnat_entity)) + { + unsigned int raw_size = UI_To_Int (Esize (gnat_entity)); + unsigned int raw_align = raw_size & -raw_size; + if (raw_align < BIGGEST_ALIGNMENT) + TYPE_ALIGN (gnu_type) = raw_align; + } + else + TYPE_ALIGN (gnu_type) = 0; + + /* If we have a Parent_Subtype, make a field for the parent. If + this record has rep clauses, force the position to zero. */ + if (Present (Parent_Subtype (gnat_entity))) + { + Entity_Id gnat_parent = Parent_Subtype (gnat_entity); + tree gnu_parent; + + /* A major complexity here is that the parent subtype will + reference our discriminants in its Discriminant_Constraint + list. But those must reference the parent component of this + record which is of the parent subtype we have not built yet! + To break the circle we first build a dummy COMPONENT_REF which + represents the "get to the parent" operation and initialize + each of those discriminants to a COMPONENT_REF of the above + dummy parent referencing the corresponding discriminant of the + base type of the parent subtype. */ + gnu_get_parent = build3 (COMPONENT_REF, void_type_node, + build0 (PLACEHOLDER_EXPR, gnu_type), + build_decl (FIELD_DECL, NULL_TREE, + void_type_node), + NULL_TREE); + + if (Has_Discriminants (gnat_entity)) + for (gnat_field = First_Stored_Discriminant (gnat_entity); + Present (gnat_field); + gnat_field = Next_Stored_Discriminant (gnat_field)) + if (Present (Corresponding_Discriminant (gnat_field))) + save_gnu_tree + (gnat_field, + build3 (COMPONENT_REF, + get_unpadded_type (Etype (gnat_field)), + gnu_get_parent, + gnat_to_gnu_field_decl (Corresponding_Discriminant + (gnat_field)), + NULL_TREE), + true); + + /* Then we build the parent subtype. */ + gnu_parent = gnat_to_gnu_type (gnat_parent); + + /* Finally we fix up both kinds of twisted COMPONENT_REF we have + initially built. The discriminants must reference the fields + of the parent subtype and not those of its base type for the + placeholder machinery to properly work. */ + if (Has_Discriminants (gnat_entity)) + for (gnat_field = First_Stored_Discriminant (gnat_entity); + Present (gnat_field); + gnat_field = Next_Stored_Discriminant (gnat_field)) + if (Present (Corresponding_Discriminant (gnat_field))) + { + Entity_Id field = Empty; + for (field = First_Stored_Discriminant (gnat_parent); + Present (field); + field = Next_Stored_Discriminant (field)) + if (same_discriminant_p (gnat_field, field)) + break; + gcc_assert (Present (field)); + TREE_OPERAND (get_gnu_tree (gnat_field), 1) + = gnat_to_gnu_field_decl (field); + } + + /* The "get to the parent" COMPONENT_REF must be given its + proper type... */ + TREE_TYPE (gnu_get_parent) = gnu_parent; + + /* ...and reference the _parent field of this record. */ + gnu_field_list + = create_field_decl (get_identifier + (Get_Name_String (Name_uParent)), + gnu_parent, gnu_type, 0, + has_rep ? TYPE_SIZE (gnu_parent) : 0, + has_rep ? bitsize_zero_node : 0, 1); + DECL_INTERNAL_P (gnu_field_list) = 1; + TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list; + } + + /* Make the fields for the discriminants and put them into the record + unless it's an Unchecked_Union. */ + if (Has_Discriminants (gnat_entity)) + for (gnat_field = First_Stored_Discriminant (gnat_entity); + Present (gnat_field); + gnat_field = Next_Stored_Discriminant (gnat_field)) + { + /* If this is a record extension and this discriminant + is the renaming of another discriminant, we've already + handled the discriminant above. */ + if (Present (Parent_Subtype (gnat_entity)) + && Present (Corresponding_Discriminant (gnat_field))) + continue; + + gnu_field + = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition); + + /* Make an expression using a PLACEHOLDER_EXPR from the + FIELD_DECL node just created and link that with the + corresponding GNAT defining identifier. Then add to the + list of fields. */ + save_gnu_tree (gnat_field, + build3 (COMPONENT_REF, TREE_TYPE (gnu_field), + build0 (PLACEHOLDER_EXPR, + DECL_CONTEXT (gnu_field)), + gnu_field, NULL_TREE), + true); + + if (!Is_Unchecked_Union (gnat_entity)) + { + TREE_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + } + } + + /* Put the discriminants into the record (backwards), so we can + know the appropriate discriminant to use for the names of the + variants. */ + TYPE_FIELDS (gnu_type) = gnu_field_list; + + /* Add the listed fields into the record and finish it up. */ + components_to_record (gnu_type, Component_List (record_definition), + gnu_field_list, packed, definition, NULL, + false, all_rep, false, + Is_Unchecked_Union (gnat_entity)); + + /* We used to remove the associations of the discriminants and + _Parent for validity checking, but we may need them if there's + Freeze_Node for a subtype used in this record. */ + TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity); + TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity); + + /* If it is a tagged record force the type to BLKmode to insure + that these objects will always be placed in memory. Do the + same thing for limited record types. */ + if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity)) + SET_TYPE_MODE (gnu_type, BLKmode); + + /* Fill in locations of fields. */ + annotate_rep (gnat_entity, gnu_type); + + /* If there are any entities in the chain corresponding to + components that we did not elaborate, ensure we elaborate their + types if they are Itypes. */ + for (gnat_temp = First_Entity (gnat_entity); + Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp)) + if ((Ekind (gnat_temp) == E_Component + || Ekind (gnat_temp) == E_Discriminant) + && Is_Itype (Etype (gnat_temp)) + && !present_gnu_tree (gnat_temp)) + gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); + } + break; + + case E_Class_Wide_Subtype: + /* If an equivalent type is present, that is what we should use. + Otherwise, fall through to handle this like a record subtype + since it may have constraints. */ + if (gnat_equiv_type != gnat_entity) + { + gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0); + maybe_present = true; + break; + } + + /* ... fall through ... */ + + case E_Record_Subtype: + + /* If Cloned_Subtype is Present it means this record subtype has + identical layout to that type or subtype and we should use + that GCC type for this one. The front end guarantees that + the component list is shared. */ + if (Present (Cloned_Subtype (gnat_entity))) + { + gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity), + NULL_TREE, 0); + maybe_present = true; + } + + /* Otherwise, first ensure the base type is elaborated. Then, if we are + changing the type, make a new type with each field having the + type of the field in the new subtype but having the position + computed by transforming every discriminant reference according + to the constraints. We don't see any difference between + private and nonprivate type here since derivations from types should + have been deferred until the completion of the private type. */ + else + { + Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity); + tree gnu_base_type; + tree gnu_orig_type; + + if (!definition) + defer_incomplete_level++, this_deferred = true; + + /* Get the base type initially for its alignment and sizes. But + if it is a padded type, we do all the other work with the + unpadded type. */ + gnu_base_type = gnat_to_gnu_type (gnat_base_type); + + if (TREE_CODE (gnu_base_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_base_type)) + gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type)); + else + gnu_type = gnu_orig_type = gnu_base_type; + + if (present_gnu_tree (gnat_entity)) + { + maybe_present = true; + break; + } + + /* When the type has discriminants, and these discriminants + affect the shape of what it built, factor them in. + + If we are making a subtype of an Unchecked_Union (must be an + Itype), just return the type. + + We can't just use Is_Constrained because private subtypes without + discriminants of full types with discriminants with default + expressions are Is_Constrained but aren't constrained! */ + + if (IN (Ekind (gnat_base_type), Record_Kind) + && !Is_For_Access_Subtype (gnat_entity) + && !Is_Unchecked_Union (gnat_base_type) + && Is_Constrained (gnat_entity) + && Stored_Constraint (gnat_entity) != No_Elist + && Present (Discriminant_Constraint (gnat_entity))) + { + Entity_Id gnat_field; + tree gnu_field_list = 0; + tree gnu_pos_list + = compute_field_positions (gnu_orig_type, NULL_TREE, + size_zero_node, bitsize_zero_node, + BIGGEST_ALIGNMENT); + tree gnu_subst_list + = substitution_list (gnat_entity, gnat_base_type, NULL_TREE, + definition); + tree gnu_temp; + + gnu_type = make_node (RECORD_TYPE); + TYPE_NAME (gnu_type) = gnu_entity_id; + TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity); + + /* Set the size, alignment and alias set of the new type to + match that of the old one, doing required substitutions. + We do it this early because we need the size of the new + type below to discard old fields if necessary. */ + TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type); + TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type); + SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type)); + TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type); + relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY); + + if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) + for (gnu_temp = gnu_subst_list; + gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) + TYPE_SIZE (gnu_type) + = substitute_in_expr (TYPE_SIZE (gnu_type), + TREE_PURPOSE (gnu_temp), + TREE_VALUE (gnu_temp)); + + if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type))) + for (gnu_temp = gnu_subst_list; + gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) + TYPE_SIZE_UNIT (gnu_type) + = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type), + TREE_PURPOSE (gnu_temp), + TREE_VALUE (gnu_temp)); + + if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type))) + for (gnu_temp = gnu_subst_list; + gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) + SET_TYPE_ADA_SIZE + (gnu_type, substitute_in_expr (TYPE_ADA_SIZE (gnu_type), + TREE_PURPOSE (gnu_temp), + TREE_VALUE (gnu_temp))); + + for (gnat_field = First_Entity (gnat_entity); + Present (gnat_field); gnat_field = Next_Entity (gnat_field)) + if ((Ekind (gnat_field) == E_Component + || Ekind (gnat_field) == E_Discriminant) + && (Underlying_Type (Scope (Original_Record_Component + (gnat_field))) + == gnat_base_type) + && (No (Corresponding_Discriminant (gnat_field)) + || !Is_Tagged_Type (gnat_base_type))) + { + tree gnu_old_field + = gnat_to_gnu_field_decl (Original_Record_Component + (gnat_field)); + tree gnu_offset + = TREE_VALUE (purpose_member (gnu_old_field, + gnu_pos_list)); + tree gnu_pos = TREE_PURPOSE (gnu_offset); + tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset)); + tree gnu_field_type + = gnat_to_gnu_type (Etype (gnat_field)); + tree gnu_size = TYPE_SIZE (gnu_field_type); + tree gnu_new_pos = NULL_TREE; + unsigned int offset_align + = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)), + 1); + tree gnu_field; + + /* If there was a component clause, the field types must be + the same for the type and subtype, so copy the data from + the old field to avoid recomputation here. Also if the + field is justified modular and the optimization in + gnat_to_gnu_field was applied. */ + if (Present (Component_Clause + (Original_Record_Component (gnat_field))) + || (TREE_CODE (gnu_field_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type) + && TREE_TYPE (TYPE_FIELDS (gnu_field_type)) + == TREE_TYPE (gnu_old_field))) + { + gnu_size = DECL_SIZE (gnu_old_field); + gnu_field_type = TREE_TYPE (gnu_old_field); + } + + /* If the old field was packed and of constant size, we + have to get the old size here, as it might differ from + what the Etype conveys and the latter might overlap + onto the following field. Try to arrange the type for + possible better packing along the way. */ + else if (DECL_PACKED (gnu_old_field) + && TREE_CODE (DECL_SIZE (gnu_old_field)) + == INTEGER_CST) + { + gnu_size = DECL_SIZE (gnu_old_field); + if (TREE_CODE (gnu_field_type) == RECORD_TYPE + && !TYPE_IS_FAT_POINTER_P (gnu_field_type) + && host_integerp (TYPE_SIZE (gnu_field_type), 1)) + gnu_field_type + = make_packable_type (gnu_field_type, true); + } + + if (CONTAINS_PLACEHOLDER_P (gnu_pos)) + for (gnu_temp = gnu_subst_list; + gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) + gnu_pos = substitute_in_expr (gnu_pos, + TREE_PURPOSE (gnu_temp), + TREE_VALUE (gnu_temp)); + + /* If the position is now a constant, we can set it as the + position of the field when we make it. Otherwise, we need + to deal with it specially below. */ + if (TREE_CONSTANT (gnu_pos)) + { + gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos); + + /* Discard old fields that are outside the new type. + This avoids confusing code scanning it to decide + how to pass it to functions on some platforms. */ + if (TREE_CODE (gnu_new_pos) == INTEGER_CST + && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST + && !integer_zerop (gnu_size) + && !tree_int_cst_lt (gnu_new_pos, + TYPE_SIZE (gnu_type))) + continue; + } + + gnu_field + = create_field_decl + (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type, + DECL_PACKED (gnu_old_field), gnu_size, gnu_new_pos, + !DECL_NONADDRESSABLE_P (gnu_old_field)); + + if (!TREE_CONSTANT (gnu_pos)) + { + normalize_offset (&gnu_pos, &gnu_bitpos, offset_align); + DECL_FIELD_OFFSET (gnu_field) = gnu_pos; + DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos; + SET_DECL_OFFSET_ALIGN (gnu_field, offset_align); + DECL_SIZE (gnu_field) = gnu_size; + DECL_SIZE_UNIT (gnu_field) + = convert (sizetype, + size_binop (CEIL_DIV_EXPR, gnu_size, + bitsize_unit_node)); + layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field)); + } + + DECL_INTERNAL_P (gnu_field) + = DECL_INTERNAL_P (gnu_old_field); + SET_DECL_ORIGINAL_FIELD + (gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field) + ? DECL_ORIGINAL_FIELD (gnu_old_field) + : gnu_old_field)); + DECL_DISCRIMINANT_NUMBER (gnu_field) + = DECL_DISCRIMINANT_NUMBER (gnu_old_field); + TREE_THIS_VOLATILE (gnu_field) + = TREE_THIS_VOLATILE (gnu_old_field); + + /* To match the layout crafted in components_to_record, if + this is the _Tag field, put it before any discriminants + instead of after them as for all other fields. */ + if (Chars (gnat_field) == Name_uTag) + gnu_field_list = chainon (gnu_field_list, gnu_field); + else + { + TREE_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + } + + save_gnu_tree (gnat_field, gnu_field, false); + } + + /* Now go through the entities again looking for Itypes that + we have not elaborated but should (e.g., Etypes of fields + that have Original_Components). */ + for (gnat_field = First_Entity (gnat_entity); + Present (gnat_field); gnat_field = Next_Entity (gnat_field)) + if ((Ekind (gnat_field) == E_Discriminant + || Ekind (gnat_field) == E_Component) + && !present_gnu_tree (Etype (gnat_field))) + gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0); + + /* Do not finalize it since we're going to modify it below. */ + gnu_field_list = nreverse (gnu_field_list); + finish_record_type (gnu_type, gnu_field_list, 2, true); + + /* Finalize size and mode. */ + TYPE_SIZE (gnu_type) = variable_size (TYPE_SIZE (gnu_type)); + TYPE_SIZE_UNIT (gnu_type) + = variable_size (TYPE_SIZE_UNIT (gnu_type)); + + compute_record_mode (gnu_type); + + /* Fill in locations of fields. */ + annotate_rep (gnat_entity, gnu_type); + + /* We've built a new type, make an XVS type to show what this + is a subtype of. Some debuggers require the XVS type to be + output first, so do it in that order. */ + if (debug_info_p) + { + tree gnu_subtype_marker = make_node (RECORD_TYPE); + tree gnu_orig_name = TYPE_NAME (gnu_orig_type); + + if (TREE_CODE (gnu_orig_name) == TYPE_DECL) + gnu_orig_name = DECL_NAME (gnu_orig_name); + + TYPE_NAME (gnu_subtype_marker) + = create_concat_name (gnat_entity, "XVS"); + finish_record_type (gnu_subtype_marker, + create_field_decl (gnu_orig_name, + integer_type_node, + gnu_subtype_marker, + 0, NULL_TREE, + NULL_TREE, 0), + 0, false); + + add_parallel_type (TYPE_STUB_DECL (gnu_type), + gnu_subtype_marker); + } + + /* Now we can finalize it. */ + rest_of_record_type_compilation (gnu_type); + } + + /* Otherwise, go down all the components in the new type and + make them equivalent to those in the base type. */ + else + for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp); + gnat_temp = Next_Entity (gnat_temp)) + if ((Ekind (gnat_temp) == E_Discriminant + && !Is_Unchecked_Union (gnat_base_type)) + || Ekind (gnat_temp) == E_Component) + save_gnu_tree (gnat_temp, + gnat_to_gnu_field_decl + (Original_Record_Component (gnat_temp)), false); + } + break; + + case E_Access_Subprogram_Type: + /* Use the special descriptor type for dispatch tables if needed, + that is to say for the Prim_Ptr of a-tags.ads and its clones. + Note that we are only required to do so for static tables in + order to be compatible with the C++ ABI, but Ada 2005 allows + to extend library level tagged types at the local level so + we do it in the non-static case as well. */ + if (TARGET_VTABLE_USES_DESCRIPTORS + && Is_Dispatch_Table_Entity (gnat_entity)) + { + gnu_type = fdesc_type_node; + gnu_size = TYPE_SIZE (gnu_type); + break; + } + + /* ... fall through ... */ + + case E_Anonymous_Access_Subprogram_Type: + /* If we are not defining this entity, and we have incomplete + entities being processed above us, make a dummy type and + fill it in later. */ + if (!definition && defer_incomplete_level != 0) + { + struct incomplete *p + = (struct incomplete *) xmalloc (sizeof (struct incomplete)); + + gnu_type + = build_pointer_type + (make_dummy_type (Directly_Designated_Type (gnat_entity))); + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + this_made_decl = true; + gnu_type = TREE_TYPE (gnu_decl); + save_gnu_tree (gnat_entity, gnu_decl, false); + saved = true; + + p->old_type = TREE_TYPE (gnu_type); + p->full_type = Directly_Designated_Type (gnat_entity); + p->next = defer_incomplete_list; + defer_incomplete_list = p; + break; + } + + /* ... fall through ... */ + + case E_Allocator_Type: + case E_Access_Type: + case E_Access_Attribute_Type: + case E_Anonymous_Access_Type: + case E_General_Access_Type: + { + Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity); + Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type); + bool is_from_limited_with + = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind) + && From_With_Type (gnat_desig_equiv)); + + /* Get the "full view" of this entity. If this is an incomplete + entity from a limited with, treat its non-limited view as the full + view. Otherwise, if this is an incomplete or private type, use the + full view. In the former case, we might point to a private type, + in which case, we need its full view. Also, we want to look at the + actual type used for the representation, so this takes a total of + three steps. */ + Entity_Id gnat_desig_full_direct_first + = (is_from_limited_with ? Non_Limited_View (gnat_desig_equiv) + : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind) + ? Full_View (gnat_desig_equiv) : Empty)); + Entity_Id gnat_desig_full_direct + = ((is_from_limited_with + && Present (gnat_desig_full_direct_first) + && IN (Ekind (gnat_desig_full_direct_first), Private_Kind)) + ? Full_View (gnat_desig_full_direct_first) + : gnat_desig_full_direct_first); + Entity_Id gnat_desig_full + = Gigi_Equivalent_Type (gnat_desig_full_direct); + + /* This the type actually used to represent the designated type, + either gnat_desig_full or gnat_desig_equiv. */ + Entity_Id gnat_desig_rep; + + /* Nonzero if this is a pointer to an unconstrained array. */ + bool is_unconstrained_array; + + /* We want to know if we'll be seeing the freeze node for any + incomplete type we may be pointing to. */ + bool in_main_unit + = (Present (gnat_desig_full) + ? In_Extended_Main_Code_Unit (gnat_desig_full) + : In_Extended_Main_Code_Unit (gnat_desig_type)); + + /* Nonzero if we make a dummy type here. */ + bool got_fat_p = false; + /* Nonzero if the dummy is a fat pointer. */ + bool made_dummy = false; + tree gnu_desig_type = NULL_TREE; + enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0); + + if (!targetm.valid_pointer_mode (p_mode)) + p_mode = ptr_mode; + + /* If either the designated type or its full view is an unconstrained + array subtype, replace it with the type it's a subtype of. This + avoids problems with multiple copies of unconstrained array types. + Likewise, if the designated type is a subtype of an incomplete + record type, use the parent type to avoid order of elaboration + issues. This can lose some code efficiency, but there is no + alternative. */ + if (Ekind (gnat_desig_equiv) == E_Array_Subtype + && ! Is_Constrained (gnat_desig_equiv)) + gnat_desig_equiv = Etype (gnat_desig_equiv); + if (Present (gnat_desig_full) + && ((Ekind (gnat_desig_full) == E_Array_Subtype + && ! Is_Constrained (gnat_desig_full)) + || (Ekind (gnat_desig_full) == E_Record_Subtype + && Ekind (Etype (gnat_desig_full)) == E_Record_Type))) + gnat_desig_full = Etype (gnat_desig_full); + + /* Now set the type that actually marks the representation of + the designated type and also flag whether we have a unconstrained + array. */ + gnat_desig_rep = gnat_desig_full ? gnat_desig_full : gnat_desig_equiv; + is_unconstrained_array + = (Is_Array_Type (gnat_desig_rep) + && ! Is_Constrained (gnat_desig_rep)); + + /* If we are pointing to an incomplete type whose completion is an + unconstrained array, make a fat pointer type. The two types in our + fields will be pointers to dummy nodes and will be replaced in + update_pointer_to. Similarly, if the type itself is a dummy type or + an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE + in case we have any thin pointers to it. */ + if (is_unconstrained_array + && (Present (gnat_desig_full) + || (present_gnu_tree (gnat_desig_equiv) + && TYPE_IS_DUMMY_P (TREE_TYPE + (get_gnu_tree (gnat_desig_equiv)))) + || (No (gnat_desig_full) && ! in_main_unit + && defer_incomplete_level != 0 + && ! present_gnu_tree (gnat_desig_equiv)) + || (in_main_unit && is_from_limited_with + && Present (Freeze_Node (gnat_desig_rep))))) + { + tree gnu_old + = (present_gnu_tree (gnat_desig_rep) + ? TREE_TYPE (get_gnu_tree (gnat_desig_rep)) + : make_dummy_type (gnat_desig_rep)); + tree fields; + + /* Show the dummy we get will be a fat pointer. */ + got_fat_p = made_dummy = true; + + /* If the call above got something that has a pointer, that + pointer is our type. This could have happened either + because the type was elaborated or because somebody + else executed the code below. */ + gnu_type = TYPE_POINTER_TO (gnu_old); + if (!gnu_type) + { + tree gnu_template_type = make_node (ENUMERAL_TYPE); + tree gnu_ptr_template = build_pointer_type (gnu_template_type); + tree gnu_array_type = make_node (ENUMERAL_TYPE); + tree gnu_ptr_array = build_pointer_type (gnu_array_type); + + TYPE_NAME (gnu_template_type) + = concat_id_with_name (get_entity_name (gnat_desig_equiv), + "XUB"); + TYPE_DUMMY_P (gnu_template_type) = 1; + + TYPE_NAME (gnu_array_type) + = concat_id_with_name (get_entity_name (gnat_desig_equiv), + "XUA"); + TYPE_DUMMY_P (gnu_array_type) = 1; + + gnu_type = make_node (RECORD_TYPE); + SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old); + TYPE_POINTER_TO (gnu_old) = gnu_type; + + Sloc_to_locus (Sloc (gnat_entity), &input_location); + fields + = chainon (chainon (NULL_TREE, + create_field_decl + (get_identifier ("P_ARRAY"), + gnu_ptr_array, + gnu_type, 0, 0, 0, 0)), + create_field_decl (get_identifier ("P_BOUNDS"), + gnu_ptr_template, + gnu_type, 0, 0, 0, 0)); + + /* Make sure we can place this into a register. */ + TYPE_ALIGN (gnu_type) + = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); + TYPE_IS_FAT_POINTER_P (gnu_type) = 1; + + /* Do not finalize this record type since the types of + its fields are incomplete. */ + finish_record_type (gnu_type, fields, 0, true); + + TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE); + TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old)) + = concat_id_with_name (get_entity_name (gnat_desig_equiv), + "XUT"); + TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1; + } + } + + /* If we already know what the full type is, use it. */ + else if (Present (gnat_desig_full) + && present_gnu_tree (gnat_desig_full)) + gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full)); + + /* Get the type of the thing we are to point to and build a pointer + to it. If it is a reference to an incomplete or private type with a + full view that is a record, make a dummy type node and get the + actual type later when we have verified it is safe. */ + else if ((! in_main_unit + && ! present_gnu_tree (gnat_desig_equiv) + && Present (gnat_desig_full) + && ! present_gnu_tree (gnat_desig_full) + && Is_Record_Type (gnat_desig_full)) + /* Likewise if we are pointing to a record or array and we + are to defer elaborating incomplete types. We do this + since this access type may be the full view of some + private type. Note that the unconstrained array case is + handled above. */ + || ((! in_main_unit || imported_p) + && defer_incomplete_level != 0 + && ! present_gnu_tree (gnat_desig_equiv) + && ((Is_Record_Type (gnat_desig_rep) + || Is_Array_Type (gnat_desig_rep)))) + /* If this is a reference from a limited_with type back to our + main unit and there's a Freeze_Node for it, either we have + already processed the declaration and made the dummy type, + in which case we just reuse the latter, or we have not yet, + in which case we make the dummy type and it will be reused + when the declaration is processed. In both cases, the + pointer eventually created below will be automatically + adjusted when the Freeze_Node is processed. Note that the + unconstrained array case is handled above. */ + || (in_main_unit && is_from_limited_with + && Present (Freeze_Node (gnat_desig_rep)))) + { + gnu_desig_type = make_dummy_type (gnat_desig_equiv); + made_dummy = true; + } + + /* Otherwise handle the case of a pointer to itself. */ + else if (gnat_desig_equiv == gnat_entity) + { + gnu_type + = build_pointer_type_for_mode (void_type_node, p_mode, + No_Strict_Aliasing (gnat_entity)); + TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type; + } + + /* If expansion is disabled, the equivalent type of a concurrent + type is absent, so build a dummy pointer type. */ + else if (type_annotate_only && No (gnat_desig_equiv)) + gnu_type = ptr_void_type_node; + + /* Finally, handle the straightforward case where we can just + elaborate our designated type and point to it. */ + else + gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv); + + /* It is possible that a call to gnat_to_gnu_type above resolved our + type. If so, just return it. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = true; + break; + } + + /* If we have a GCC type for the designated type, possibly modify it + if we are pointing only to constant objects and then make a pointer + to it. Don't do this for unconstrained arrays. */ + if (!gnu_type && gnu_desig_type) + { + if (Is_Access_Constant (gnat_entity) + && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE) + { + gnu_desig_type + = build_qualified_type + (gnu_desig_type, + TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST); + + /* Some extra processing is required if we are building a + pointer to an incomplete type (in the GCC sense). We might + have such a type if we just made a dummy, or directly out + of the call to gnat_to_gnu_type above if we are processing + an access type for a record component designating the + record type itself. */ + if (TYPE_MODE (gnu_desig_type) == VOIDmode) + { + /* We must ensure that the pointer to variant we make will + be processed by update_pointer_to when the initial type + is completed. Pretend we made a dummy and let further + processing act as usual. */ + made_dummy = true; + + /* We must ensure that update_pointer_to will not retrieve + the dummy variant when building a properly qualified + version of the complete type. We take advantage of the + fact that get_qualified_type is requiring TYPE_NAMEs to + match to influence build_qualified_type and then also + update_pointer_to here. */ + TYPE_NAME (gnu_desig_type) + = create_concat_name (gnat_desig_type, "INCOMPLETE_CST"); + } + } + + gnu_type + = build_pointer_type_for_mode (gnu_desig_type, p_mode, + No_Strict_Aliasing (gnat_entity)); + } + + /* If we are not defining this object and we made a dummy pointer, + save our current definition, evaluate the actual type, and replace + the tentative type we made with the actual one. If we are to defer + actually looking up the actual type, make an entry in the + deferred list. If this is from a limited with, we have to defer + to the end of the current spec in two cases: first if the + designated type is in the current unit and second if the access + type is. */ + if ((! in_main_unit || is_from_limited_with) && made_dummy) + { + tree gnu_old_type + = TYPE_FAT_POINTER_P (gnu_type) + ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type); + + if (esize == POINTER_SIZE + && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type))) + gnu_type + = build_pointer_type + (TYPE_OBJECT_RECORD_TYPE + (TYPE_UNCONSTRAINED_ARRAY (gnu_type))); + + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + this_made_decl = true; + gnu_type = TREE_TYPE (gnu_decl); + save_gnu_tree (gnat_entity, gnu_decl, false); + saved = true; + + if (defer_incomplete_level == 0 + && ! (is_from_limited_with + && (in_main_unit + || In_Extended_Main_Code_Unit (gnat_entity)))) + update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type), + gnat_to_gnu_type (gnat_desig_equiv)); + + /* Note that the call to gnat_to_gnu_type here might have + updated gnu_old_type directly, in which case it is not a + dummy type any more when we get into update_pointer_to. + + This may happen for instance when the designated type is a + record type, because their elaboration starts with an + initial node from make_dummy_type, which may yield the same + node as the one we got. + + Besides, variants of this non-dummy type might have been + created along the way. update_pointer_to is expected to + properly take care of those situations. */ + else + { + struct incomplete *p + = (struct incomplete *) xmalloc (sizeof + (struct incomplete)); + struct incomplete **head + = (is_from_limited_with + && (in_main_unit + || In_Extended_Main_Code_Unit (gnat_entity)) + ? &defer_limited_with : &defer_incomplete_list); + + p->old_type = gnu_old_type; + p->full_type = gnat_desig_equiv; + p->next = *head; + *head = p; + } + } + } + break; + + case E_Access_Protected_Subprogram_Type: + case E_Anonymous_Access_Protected_Subprogram_Type: + if (type_annotate_only && No (gnat_equiv_type)) + gnu_type = ptr_void_type_node; + else + { + /* The runtime representation is the equivalent type. */ + gnu_type = gnat_to_gnu_type (gnat_equiv_type); + maybe_present = true; + } + + if (Is_Itype (Directly_Designated_Type (gnat_entity)) + && !present_gnu_tree (Directly_Designated_Type (gnat_entity)) + && No (Freeze_Node (Directly_Designated_Type (gnat_entity))) + && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity)))) + gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity), + NULL_TREE, 0); + + break; + + case E_Access_Subtype: + + /* We treat this as identical to its base type; any constraint is + meaningful only to the front end. + + The designated type must be elaborated as well, if it does + not have its own freeze node. Designated (sub)types created + for constrained components of records with discriminants are + not frozen by the front end and thus not elaborated by gigi, + because their use may appear before the base type is frozen, + and because it is not clear that they are needed anywhere in + Gigi. With the current model, there is no correct place where + they could be elaborated. */ + + gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); + if (Is_Itype (Directly_Designated_Type (gnat_entity)) + && !present_gnu_tree (Directly_Designated_Type (gnat_entity)) + && Is_Frozen (Directly_Designated_Type (gnat_entity)) + && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))) + { + /* If we are not defining this entity, and we have incomplete + entities being processed above us, make a dummy type and + elaborate it later. */ + if (!definition && defer_incomplete_level != 0) + { + struct incomplete *p + = (struct incomplete *) xmalloc (sizeof (struct incomplete)); + tree gnu_ptr_type + = build_pointer_type + (make_dummy_type (Directly_Designated_Type (gnat_entity))); + + p->old_type = TREE_TYPE (gnu_ptr_type); + p->full_type = Directly_Designated_Type (gnat_entity); + p->next = defer_incomplete_list; + defer_incomplete_list = p; + } + else if (!IN (Ekind (Base_Type + (Directly_Designated_Type (gnat_entity))), + Incomplete_Or_Private_Kind)) + gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity), + NULL_TREE, 0); + } + + maybe_present = true; + break; + + /* Subprogram Entities + + The following access functions are defined for subprograms (functions + or procedures): + + First_Formal The first formal parameter. + Is_Imported Indicates that the subprogram has appeared in + an INTERFACE or IMPORT pragma. For now we + assume that the external language is C. + Is_Exported Likewise but for an EXPORT pragma. + Is_Inlined True if the subprogram is to be inlined. + + In addition for function subprograms we have: + + Etype Return type of the function. + + Each parameter is first checked by calling must_pass_by_ref on its + type to determine if it is passed by reference. For parameters which + are copied in, if they are Ada In Out or Out parameters, their return + value becomes part of a record which becomes the return type of the + function (C function - note that this applies only to Ada procedures + so there is no Ada return type). Additional code to store back the + parameters will be generated on the caller side. This transformation + is done here, not in the front-end. + + The intended result of the transformation can be seen from the + equivalent source rewritings that follow: + + struct temp {int a,b}; + procedure P (A,B: In Out ...) is temp P (int A,B) + begin { + .. .. + end P; return {A,B}; + } + + temp t; + P(X,Y); t = P(X,Y); + X = t.a , Y = t.b; + + For subprogram types we need to perform mainly the same conversions to + GCC form that are needed for procedures and function declarations. The + only difference is that at the end, we make a type declaration instead + of a function declaration. */ + + case E_Subprogram_Type: + case E_Function: + case E_Procedure: + { + /* The first GCC parameter declaration (a PARM_DECL node). The + PARM_DECL nodes are chained through the TREE_CHAIN field, so this + actually is the head of this parameter list. */ + tree gnu_param_list = NULL_TREE; + /* Likewise for the stub associated with an exported procedure. */ + tree gnu_stub_param_list = NULL_TREE; + /* The type returned by a function. If the subprogram is a procedure + this type should be void_type_node. */ + tree gnu_return_type = void_type_node; + /* List of fields in return type of procedure with copy-in copy-out + parameters. */ + tree gnu_field_list = NULL_TREE; + /* Non-null for subprograms containing parameters passed by copy-in + copy-out (Ada In Out or Out parameters not passed by reference), + in which case it is the list of nodes used to specify the values of + the in out/out parameters that are returned as a record upon + procedure return. The TREE_PURPOSE of an element of this list is + a field of the record and the TREE_VALUE is the PARM_DECL + corresponding to that field. This list will be saved in the + TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */ + tree gnu_return_list = NULL_TREE; + /* If an import pragma asks to map this subprogram to a GCC builtin, + this is the builtin DECL node. */ + tree gnu_builtin_decl = NULL_TREE; + /* For the stub associated with an exported procedure. */ + tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE; + tree gnu_ext_name = create_concat_name (gnat_entity, NULL); + Entity_Id gnat_param; + bool inline_flag = Is_Inlined (gnat_entity); + bool public_flag = Is_Public (gnat_entity) || imported_p; + bool extern_flag + = (Is_Public (gnat_entity) && !definition) || imported_p; + + /* The semantics of "pure" in Ada essentially matches that of "const" + in the back-end. In particular, both properties are orthogonal to + the "nothrow" property if the EH circuitry is explicit in the + internal representation of the back-end. If we are to completely + hide the EH circuitry from it, we need to declare that calls to pure + Ada subprograms that can throw have side effects since they can + trigger an "abnormal" transfer of control flow; thus they can be + neither "const" nor "pure" in the back-end sense. */ + bool const_flag + = (Exception_Mechanism == Back_End_Exceptions + && Is_Pure (gnat_entity)); + + bool volatile_flag = No_Return (gnat_entity); + bool returns_by_ref = false; + bool returns_unconstrained = false; + bool returns_by_target_ptr = false; + bool has_copy_in_out = false; + bool has_stub = false; + int parmnum; + + if (kind == E_Subprogram_Type && !definition) + /* A parameter may refer to this type, so defer completion + of any incomplete types. */ + defer_incomplete_level++, this_deferred = true; + + /* If the subprogram has an alias, it is probably inherited, so + we can use the original one. If the original "subprogram" + is actually an enumeration literal, it may be the first use + of its type, so we must elaborate that type now. */ + if (Present (Alias (gnat_entity))) + { + if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal) + gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0); + + gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), + gnu_expr, 0); + + /* Elaborate any Itypes in the parameters of this entity. */ + for (gnat_temp = First_Formal_With_Extras (gnat_entity); + Present (gnat_temp); + gnat_temp = Next_Formal_With_Extras (gnat_temp)) + if (Is_Itype (Etype (gnat_temp))) + gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); + + break; + } + + /* If this subprogram is expectedly bound to a GCC builtin, fetch the + corresponding DECL node. + + We still want the parameter associations to take place because the + proper generation of calls depends on it (a GNAT parameter without + a corresponding GCC tree has a very specific meaning), so we don't + just break here. */ + if (Convention (gnat_entity) == Convention_Intrinsic) + gnu_builtin_decl = builtin_decl_for (gnu_ext_name); + + /* ??? What if we don't find the builtin node above ? warn ? err ? + In the current state we neither warn nor err, and calls will just + be handled as for regular subprograms. */ + + if (kind == E_Function || kind == E_Subprogram_Type) + gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity)); + + /* If this function returns by reference, make the actual + return type of this function the pointer and mark the decl. */ + if (Returns_By_Ref (gnat_entity)) + { + returns_by_ref = true; + gnu_return_type = build_pointer_type (gnu_return_type); + } + + /* If the Mechanism is By_Reference, ensure the return type uses + the machine's by-reference mechanism, which may not the same + as above (e.g., it might be by passing a fake parameter). */ + else if (kind == E_Function + && Mechanism (gnat_entity) == By_Reference) + { + TREE_ADDRESSABLE (gnu_return_type) = 1; + + /* We expect this bit to be reset by gigi shortly, so can avoid a + type node copy here. This actually also prevents troubles with + the generation of debug information for the function, because + we might have issued such info for this type already, and would + be attaching a distinct type node to the function if we made a + copy here. */ + } + + /* If we are supposed to return an unconstrained array, + actually return a fat pointer and make a note of that. Return + a pointer to an unconstrained record of variable size. */ + else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE) + { + gnu_return_type = TREE_TYPE (gnu_return_type); + returns_unconstrained = true; + } + + /* If the type requires a transient scope, the result is allocated + on the secondary stack, so the result type of the function is + just a pointer. */ + else if (Requires_Transient_Scope (Etype (gnat_entity))) + { + gnu_return_type = build_pointer_type (gnu_return_type); + returns_unconstrained = true; + } + + /* If the type is a padded type and the underlying type would not + be passed by reference or this function has a foreign convention, + return the underlying type. */ + else if (TREE_CODE (gnu_return_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_return_type) + && (!default_pass_by_ref (TREE_TYPE + (TYPE_FIELDS (gnu_return_type))) + || Has_Foreign_Convention (gnat_entity))) + gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type)); + + /* If the return type has a non-constant size, we convert the function + into a procedure and its caller will pass a pointer to an object as + the first parameter when we call the function. This can happen for + an unconstrained type with a maximum size or a constrained type with + a size not known at compile time. */ + if (TYPE_SIZE_UNIT (gnu_return_type) + && !TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))) + { + returns_by_target_ptr = true; + gnu_param_list + = create_param_decl (get_identifier ("TARGET"), + build_reference_type (gnu_return_type), + true); + gnu_return_type = void_type_node; + } + + /* If the return type has a size that overflows, we cannot have + a function that returns that type. This usage doesn't make + sense anyway, so give an error here. */ + if (TYPE_SIZE_UNIT (gnu_return_type) + && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type)) + && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type))) + { + post_error ("cannot return type whose size overflows", + gnat_entity); + gnu_return_type = copy_node (gnu_return_type); + TYPE_SIZE (gnu_return_type) = bitsize_zero_node; + TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node; + TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type; + TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE; + } + + /* Look at all our parameters and get the type of + each. While doing this, build a copy-out structure if + we need one. */ + + /* Loop over the parameters and get their associated GCC tree. + While doing this, build a copy-out structure if we need one. */ + for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0; + Present (gnat_param); + gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++) + { + tree gnu_param_name = get_entity_name (gnat_param); + tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param)); + tree gnu_param, gnu_field; + bool copy_in_copy_out = false; + Mechanism_Type mech = Mechanism (gnat_param); + + /* Builtins are expanded inline and there is no real call sequence + involved. So the type expected by the underlying expander is + always the type of each argument "as is". */ + if (gnu_builtin_decl) + mech = By_Copy; + /* Handle the first parameter of a valued procedure specially. */ + else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0) + mech = By_Copy_Return; + /* Otherwise, see if a Mechanism was supplied that forced this + parameter to be passed one way or another. */ + else if (mech == Default + || mech == By_Copy || mech == By_Reference) + ; + else if (By_Descriptor_Last <= mech && mech <= By_Descriptor) + mech = By_Descriptor; + + else if (By_Short_Descriptor_Last <= mech && + mech <= By_Short_Descriptor) + mech = By_Short_Descriptor; + + else if (mech > 0) + { + if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE + || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST + || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type), + mech)) + mech = By_Reference; + else + mech = By_Copy; + } + else + { + post_error ("unsupported mechanism for&", gnat_param); + mech = Default; + } + + gnu_param + = gnat_to_gnu_param (gnat_param, mech, gnat_entity, + Has_Foreign_Convention (gnat_entity), + ©_in_copy_out); + + /* We are returned either a PARM_DECL or a type if no parameter + needs to be passed; in either case, adjust the type. */ + if (DECL_P (gnu_param)) + gnu_param_type = TREE_TYPE (gnu_param); + else + { + gnu_param_type = gnu_param; + gnu_param = NULL_TREE; + } + + if (gnu_param) + { + /* If it's an exported subprogram, we build a parameter list + in parallel, in case we need to emit a stub for it. */ + if (Is_Exported (gnat_entity)) + { + gnu_stub_param_list + = chainon (gnu_param, gnu_stub_param_list); + /* Change By_Descriptor parameter to By_Reference for + the internal version of an exported subprogram. */ + if (mech == By_Descriptor || mech == By_Short_Descriptor) + { + gnu_param + = gnat_to_gnu_param (gnat_param, By_Reference, + gnat_entity, false, + ©_in_copy_out); + has_stub = true; + } + else + gnu_param = copy_node (gnu_param); + } + + gnu_param_list = chainon (gnu_param, gnu_param_list); + Sloc_to_locus (Sloc (gnat_param), + &DECL_SOURCE_LOCATION (gnu_param)); + save_gnu_tree (gnat_param, gnu_param, false); + + /* If a parameter is a pointer, this function may modify + memory through it and thus shouldn't be considered + a const function. Also, the memory may be modified + between two calls, so they can't be CSE'ed. The latter + case also handles by-ref parameters. */ + if (POINTER_TYPE_P (gnu_param_type) + || TYPE_FAT_POINTER_P (gnu_param_type)) + const_flag = false; + } + + if (copy_in_copy_out) + { + if (!has_copy_in_out) + { + gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE); + gnu_return_type = make_node (RECORD_TYPE); + TYPE_NAME (gnu_return_type) = get_identifier ("RETURN"); + has_copy_in_out = true; + } + + gnu_field = create_field_decl (gnu_param_name, gnu_param_type, + gnu_return_type, 0, 0, 0, 0); + Sloc_to_locus (Sloc (gnat_param), + &DECL_SOURCE_LOCATION (gnu_field)); + TREE_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + gnu_return_list = tree_cons (gnu_field, gnu_param, + gnu_return_list); + } + } + + /* Do not compute record for out parameters if subprogram is + stubbed since structures are incomplete for the back-end. */ + if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed) + finish_record_type (gnu_return_type, nreverse (gnu_field_list), + 0, false); + + /* If we have a CICO list but it has only one entry, we convert + this function into a function that simply returns that one + object. */ + if (list_length (gnu_return_list) == 1) + gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list)); + + if (Has_Stdcall_Convention (gnat_entity)) + prepend_one_attribute_to + (&attr_list, ATTR_MACHINE_ATTRIBUTE, + get_identifier ("stdcall"), NULL_TREE, + gnat_entity); + + /* If we are on a target where stack realignment is needed for 'main' + to honor GCC's implicit expectations (stack alignment greater than + what the base ABI guarantees), ensure we do the same for foreign + convention subprograms as they might be used as callbacks from code + breaking such expectations. Note that this applies to task entry + points in particular. */ + if (FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN + && Has_Foreign_Convention (gnat_entity)) + prepend_one_attribute_to + (&attr_list, ATTR_MACHINE_ATTRIBUTE, + get_identifier ("force_align_arg_pointer"), NULL_TREE, + gnat_entity); + + /* The lists have been built in reverse. */ + gnu_param_list = nreverse (gnu_param_list); + if (has_stub) + gnu_stub_param_list = nreverse (gnu_stub_param_list); + gnu_return_list = nreverse (gnu_return_list); + + if (Ekind (gnat_entity) == E_Function) + Set_Mechanism (gnat_entity, + (returns_by_ref || returns_unconstrained + ? By_Reference : By_Copy)); + gnu_type + = create_subprog_type (gnu_return_type, gnu_param_list, + gnu_return_list, returns_unconstrained, + returns_by_ref, returns_by_target_ptr); + + if (has_stub) + gnu_stub_type + = create_subprog_type (gnu_return_type, gnu_stub_param_list, + gnu_return_list, returns_unconstrained, + returns_by_ref, returns_by_target_ptr); + + /* A subprogram (something that doesn't return anything) shouldn't + be considered const since there would be no reason for such a + subprogram. Note that procedures with Out (or In Out) parameters + have already been converted into a function with a return type. */ + if (TREE_CODE (gnu_return_type) == VOID_TYPE) + const_flag = false; + + gnu_type + = build_qualified_type (gnu_type, + TYPE_QUALS (gnu_type) + | (TYPE_QUAL_CONST * const_flag) + | (TYPE_QUAL_VOLATILE * volatile_flag)); + + Sloc_to_locus (Sloc (gnat_entity), &input_location); + + if (has_stub) + gnu_stub_type + = build_qualified_type (gnu_stub_type, + TYPE_QUALS (gnu_stub_type) + | (TYPE_QUAL_CONST * const_flag) + | (TYPE_QUAL_VOLATILE * volatile_flag)); + + /* If we have a builtin decl for that function, check the signatures + compatibilities. If the signatures are compatible, use the builtin + decl. If they are not, we expect the checker predicate to have + posted the appropriate errors, and just continue with what we have + so far. */ + if (gnu_builtin_decl) + { + tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl); + + if (compatible_signatures_p (gnu_type, gnu_builtin_type)) + { + gnu_decl = gnu_builtin_decl; + gnu_type = gnu_builtin_type; + break; + } + } + + /* If there was no specified Interface_Name and the external and + internal names of the subprogram are the same, only use the + internal name to allow disambiguation of nested subprograms. */ + if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id) + gnu_ext_name = NULL_TREE; + + /* If we are defining the subprogram and it has an Address clause + we must get the address expression from the saved GCC tree for the + subprogram if it has a Freeze_Node. Otherwise, we elaborate + the address expression here since the front-end has guaranteed + in that case that the elaboration has no effects. If there is + an Address clause and we are not defining the object, just + make it a constant. */ + if (Present (Address_Clause (gnat_entity))) + { + tree gnu_address = NULL_TREE; + + if (definition) + gnu_address + = (present_gnu_tree (gnat_entity) + ? get_gnu_tree (gnat_entity) + : gnat_to_gnu (Expression (Address_Clause (gnat_entity)))); + + save_gnu_tree (gnat_entity, NULL_TREE, false); + + /* Convert the type of the object to a reference type that can + alias everything as per 13.3(19). */ + gnu_type + = build_reference_type_for_mode (gnu_type, ptr_mode, true); + if (gnu_address) + gnu_address = convert (gnu_type, gnu_address); + + gnu_decl + = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, + gnu_address, false, Is_Public (gnat_entity), + extern_flag, false, NULL, gnat_entity); + DECL_BY_REF_P (gnu_decl) = 1; + } + + else if (kind == E_Subprogram_Type) + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + else + { + if (has_stub) + { + gnu_stub_name = gnu_ext_name; + gnu_ext_name = create_concat_name (gnat_entity, "internal"); + public_flag = false; + } + + gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name, + gnu_type, gnu_param_list, + inline_flag, public_flag, + extern_flag, attr_list, + gnat_entity); + if (has_stub) + { + tree gnu_stub_decl + = create_subprog_decl (gnu_entity_id, gnu_stub_name, + gnu_stub_type, gnu_stub_param_list, + inline_flag, true, + extern_flag, attr_list, + gnat_entity); + SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl); + } + + /* This is unrelated to the stub built right above. */ + DECL_STUBBED_P (gnu_decl) + = Convention (gnat_entity) == Convention_Stubbed; + } + } + break; + + case E_Incomplete_Type: + case E_Incomplete_Subtype: + case E_Private_Type: + case E_Private_Subtype: + case E_Limited_Private_Type: + case E_Limited_Private_Subtype: + case E_Record_Type_With_Private: + case E_Record_Subtype_With_Private: + { + /* Get the "full view" of this entity. If this is an incomplete + entity from a limited with, treat its non-limited view as the + full view. Otherwise, use either the full view or the underlying + full view, whichever is present. This is used in all the tests + below. */ + Entity_Id full_view + = (IN (Ekind (gnat_entity), Incomplete_Kind) + && From_With_Type (gnat_entity)) + ? Non_Limited_View (gnat_entity) + : Present (Full_View (gnat_entity)) + ? Full_View (gnat_entity) + : Underlying_Full_View (gnat_entity); + + /* If this is an incomplete type with no full view, it must be a Taft + Amendment type, in which case we return a dummy type. Otherwise, + just get the type from its Etype. */ + if (No (full_view)) + { + if (kind == E_Incomplete_Type) + gnu_type = make_dummy_type (gnat_entity); + else + { + gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity), + NULL_TREE, 0); + maybe_present = true; + } + break; + } + + /* If we already made a type for the full view, reuse it. */ + else if (present_gnu_tree (full_view)) + { + gnu_decl = get_gnu_tree (full_view); + break; + } + + /* Otherwise, if we are not defining the type now, get the type + from the full view. But always get the type from the full view + for define on use types, since otherwise we won't see them! */ + else if (!definition + || (Is_Itype (full_view) + && No (Freeze_Node (gnat_entity))) + || (Is_Itype (gnat_entity) + && No (Freeze_Node (full_view)))) + { + gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0); + maybe_present = true; + break; + } + + /* For incomplete types, make a dummy type entry which will be + replaced later. */ + gnu_type = make_dummy_type (gnat_entity); + + /* Save this type as the full declaration's type so we can do any + needed updates when we see it. */ + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + save_gnu_tree (full_view, gnu_decl, 0); + break; + } + + /* Simple class_wide types are always viewed as their root_type + by Gigi unless an Equivalent_Type is specified. */ + case E_Class_Wide_Type: + gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0); + maybe_present = true; + break; + + case E_Task_Type: + case E_Task_Subtype: + case E_Protected_Type: + case E_Protected_Subtype: + if (type_annotate_only && No (gnat_equiv_type)) + gnu_type = void_type_node; + else + gnu_type = gnat_to_gnu_type (gnat_equiv_type); + + maybe_present = true; + break; + + case E_Label: + gnu_decl = create_label_decl (gnu_entity_id); + break; + + case E_Block: + case E_Loop: + /* Nothing at all to do here, so just return an ERROR_MARK and claim + we've already saved it, so we don't try to. */ + gnu_decl = error_mark_node; + saved = true; + break; + + default: + gcc_unreachable (); + } + + /* If we had a case where we evaluated another type and it might have + defined this one, handle it here. */ + if (maybe_present && present_gnu_tree (gnat_entity)) + { + gnu_decl = get_gnu_tree (gnat_entity); + saved = true; + } + + /* If we are processing a type and there is either no decl for it or + we just made one, do some common processing for the type, such as + handling alignment and possible padding. */ + + if ((!gnu_decl || this_made_decl) && IN (kind, Type_Kind)) + { + if (Is_Tagged_Type (gnat_entity) + || Is_Class_Wide_Equivalent_Type (gnat_entity)) + TYPE_ALIGN_OK (gnu_type) = 1; + + if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity)) + TYPE_BY_REFERENCE_P (gnu_type) = 1; + + /* ??? Don't set the size for a String_Literal since it is either + confirming or we don't handle it properly (if the low bound is + non-constant). */ + if (!gnu_size && kind != E_String_Literal_Subtype) + gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity, + TYPE_DECL, false, + Has_Size_Clause (gnat_entity)); + + /* If a size was specified, see if we can make a new type of that size + by rearranging the type, for example from a fat to a thin pointer. */ + if (gnu_size) + { + gnu_type + = make_type_from_size (gnu_type, gnu_size, + Has_Biased_Representation (gnat_entity)); + + if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0) + && operand_equal_p (rm_size (gnu_type), gnu_size, 0)) + gnu_size = 0; + } + + /* If the alignment hasn't already been processed and this is + not an unconstrained array, see if an alignment is specified. + If not, we pick a default alignment for atomic objects. */ + if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + ; + else if (Known_Alignment (gnat_entity)) + { + align = validate_alignment (Alignment (gnat_entity), gnat_entity, + TYPE_ALIGN (gnu_type)); + + /* Warn on suspiciously large alignments. This should catch + errors about the (alignment,byte)/(size,bit) discrepancy. */ + if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity)) + { + tree size; + + /* If a size was specified, take it into account. Otherwise + use the RM size for records as the type size has already + been adjusted to the alignment. */ + if (gnu_size) + size = gnu_size; + else if ((TREE_CODE (gnu_type) == RECORD_TYPE + || TREE_CODE (gnu_type) == UNION_TYPE + || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) + && !TYPE_IS_FAT_POINTER_P (gnu_type)) + size = rm_size (gnu_type); + else + size = TYPE_SIZE (gnu_type); + + /* Consider an alignment as suspicious if the alignment/size + ratio is greater or equal to the byte/bit ratio. */ + if (host_integerp (size, 1) + && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT) + post_error_ne ("?suspiciously large alignment specified for&", + Expression (Alignment_Clause (gnat_entity)), + gnat_entity); + } + } + else if (Is_Atomic (gnat_entity) && !gnu_size + && host_integerp (TYPE_SIZE (gnu_type), 1) + && integer_pow2p (TYPE_SIZE (gnu_type))) + align = MIN (BIGGEST_ALIGNMENT, + tree_low_cst (TYPE_SIZE (gnu_type), 1)); + else if (Is_Atomic (gnat_entity) && gnu_size + && host_integerp (gnu_size, 1) + && integer_pow2p (gnu_size)) + align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1)); + + /* See if we need to pad the type. If we did, and made a record, + the name of the new type may be changed. So get it back for + us when we make the new TYPE_DECL below. */ + if (gnu_size || align > 0) + gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity, + "PAD", true, definition, false); + + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_type)) + { + gnu_entity_id = TYPE_NAME (gnu_type); + if (TREE_CODE (gnu_entity_id) == TYPE_DECL) + gnu_entity_id = DECL_NAME (gnu_entity_id); + } + + set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity); + + /* If we are at global level, GCC will have applied variable_size to + the type, but that won't have done anything. So, if it's not + a constant or self-referential, call elaborate_expression_1 to + make a variable for the size rather than calculating it each time. + Handle both the RM size and the actual size. */ + if (global_bindings_p () + && TYPE_SIZE (gnu_type) + && !TREE_CONSTANT (TYPE_SIZE (gnu_type)) + && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) + { + if (TREE_CODE (gnu_type) == RECORD_TYPE + && operand_equal_p (TYPE_ADA_SIZE (gnu_type), + TYPE_SIZE (gnu_type), 0)) + { + TYPE_SIZE (gnu_type) + = elaborate_expression_1 (gnat_entity, gnat_entity, + TYPE_SIZE (gnu_type), + get_identifier ("SIZE"), + definition, 0); + SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type)); + } + else + { + TYPE_SIZE (gnu_type) + = elaborate_expression_1 (gnat_entity, gnat_entity, + TYPE_SIZE (gnu_type), + get_identifier ("SIZE"), + definition, 0); + + /* ??? For now, store the size as a multiple of the alignment + in bytes so that we can see the alignment from the tree. */ + TYPE_SIZE_UNIT (gnu_type) + = build_binary_op + (MULT_EXPR, sizetype, + elaborate_expression_1 + (gnat_entity, gnat_entity, + build_binary_op (EXACT_DIV_EXPR, sizetype, + TYPE_SIZE_UNIT (gnu_type), + size_int (TYPE_ALIGN (gnu_type) + / BITS_PER_UNIT)), + get_identifier ("SIZE_A_UNIT"), + definition, 0), + size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); + + if (TREE_CODE (gnu_type) == RECORD_TYPE) + SET_TYPE_ADA_SIZE + (gnu_type, + elaborate_expression_1 (gnat_entity, + gnat_entity, + TYPE_ADA_SIZE (gnu_type), + get_identifier ("RM_SIZE"), + definition, 0)); + } + } + + /* If this is a record type or subtype, call elaborate_expression_1 on + any field position. Do this for both global and local types. + Skip any fields that we haven't made trees for to avoid problems with + class wide types. */ + if (IN (kind, Record_Kind)) + for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp); + gnat_temp = Next_Entity (gnat_temp)) + if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp)) + { + tree gnu_field = get_gnu_tree (gnat_temp); + + /* ??? Unfortunately, GCC needs to be able to prove the + alignment of this offset and if it's a variable, it can't. + In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but + right now, we have to put in an explicit multiply and + divide by that value. */ + if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field))) + { + DECL_FIELD_OFFSET (gnu_field) + = build_binary_op + (MULT_EXPR, sizetype, + elaborate_expression_1 + (gnat_temp, gnat_temp, + build_binary_op (EXACT_DIV_EXPR, sizetype, + DECL_FIELD_OFFSET (gnu_field), + size_int (DECL_OFFSET_ALIGN (gnu_field) + / BITS_PER_UNIT)), + get_identifier ("OFFSET"), + definition, 0), + size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT)); + + /* ??? The context of gnu_field is not necessarily gnu_type so + the MULT_EXPR node built above may not be marked by the call + to create_type_decl below. */ + if (global_bindings_p ()) + mark_visited (&DECL_FIELD_OFFSET (gnu_field)); + } + } + + gnu_type = build_qualified_type (gnu_type, + (TYPE_QUALS (gnu_type) + | (TYPE_QUAL_VOLATILE + * Treat_As_Volatile (gnat_entity)))); + + if (Is_Atomic (gnat_entity)) + check_ok_for_atomic (gnu_type, gnat_entity, false); + + if (Present (Alignment_Clause (gnat_entity))) + TYPE_USER_ALIGN (gnu_type) = 1; + + if (Universal_Aliasing (gnat_entity)) + TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1; + + if (!gnu_decl) + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + else + TREE_TYPE (gnu_decl) = gnu_type; + } + + if (IN (kind, Type_Kind) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))) + { + gnu_type = TREE_TYPE (gnu_decl); + + /* If this is a derived type, relate its alias set to that of its parent + to avoid troubles when a call to an inherited primitive is inlined in + a context where a derived object is accessed. The inlined code works + on the parent view so the resulting code may access the same object + using both the parent and the derived alias sets, which thus have to + conflict. As the same issue arises with component references, the + parent alias set also has to conflict with composite types enclosing + derived components. For instance, if we have: + + type D is new T; + type R is record + Component : D; + end record; + + we want T to conflict with both D and R, in addition to R being a + superset of D by record/component construction. + + One way to achieve this is to perform an alias set copy from the + parent to the derived type. This is not quite appropriate, though, + as we don't want separate derived types to conflict with each other: + + type I1 is new Integer; + type I2 is new Integer; + + We want I1 and I2 to both conflict with Integer but we do not want + I1 to conflict with I2, and an alias set copy on derivation would + have that effect. + + The option chosen is to make the alias set of the derived type a + superset of that of its parent type. It trivially fulfills the + simple requirement for the Integer derivation example above, and + the component case as well by superset transitivity: + + superset superset + R ----------> D ----------> T + + The language rules ensure the parent type is already frozen here. */ + if (Is_Derived_Type (gnat_entity)) + { + tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity)); + relate_alias_sets (gnu_type, gnu_parent_type, ALIAS_SET_SUPERSET); + } + + /* Back-annotate the Alignment of the type if not already in the + tree. Likewise for sizes. */ + if (Unknown_Alignment (gnat_entity)) + Set_Alignment (gnat_entity, + UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); + + if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type)) + { + /* If the size is self-referential, we annotate the maximum + value of that size. */ + tree gnu_size = TYPE_SIZE (gnu_type); + + if (CONTAINS_PLACEHOLDER_P (gnu_size)) + gnu_size = max_size (gnu_size, true); + + Set_Esize (gnat_entity, annotate_value (gnu_size)); + + if (type_annotate_only && Is_Tagged_Type (gnat_entity)) + { + /* In this mode the tag and the parent components are not + generated by the front-end, so the sizes must be adjusted + explicitly now. */ + int size_offset, new_size; + + if (Is_Derived_Type (gnat_entity)) + { + size_offset + = UI_To_Int (Esize (Etype (Base_Type (gnat_entity)))); + Set_Alignment (gnat_entity, + Alignment (Etype (Base_Type (gnat_entity)))); + } + else + size_offset = POINTER_SIZE; + + new_size = UI_To_Int (Esize (gnat_entity)) + size_offset; + Set_Esize (gnat_entity, + UI_From_Int (((new_size + (POINTER_SIZE - 1)) + / POINTER_SIZE) * POINTER_SIZE)); + Set_RM_Size (gnat_entity, Esize (gnat_entity)); + } + } + + if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type)) + Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type))); + } + + if (!Comes_From_Source (gnat_entity) && DECL_P (gnu_decl)) + DECL_ARTIFICIAL (gnu_decl) = 1; + + if (!debug_info_p && DECL_P (gnu_decl) + && TREE_CODE (gnu_decl) != FUNCTION_DECL + && No (Renamed_Object (gnat_entity))) + DECL_IGNORED_P (gnu_decl) = 1; + + /* If we haven't already, associate the ..._DECL node that we just made with + the input GNAT entity node. */ + if (!saved) + save_gnu_tree (gnat_entity, gnu_decl, false); + + /* If this is an enumeral or floating-point type, we were not able to set + the bounds since they refer to the type. These bounds are always static. + + For enumeration types, also write debugging information and declare the + enumeration literal table, if needed. */ + + if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity))) + || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity))) + { + tree gnu_scalar_type = gnu_type; + + /* If this is a padded type, we need to use the underlying type. */ + if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_scalar_type)) + gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type)); + + /* If this is a floating point type and we haven't set a floating + point type yet, use this in the evaluation of the bounds. */ + if (!longest_float_type_node && kind == E_Floating_Point_Type) + longest_float_type_node = gnu_type; + + TYPE_MIN_VALUE (gnu_scalar_type) + = gnat_to_gnu (Type_Low_Bound (gnat_entity)); + TYPE_MAX_VALUE (gnu_scalar_type) + = gnat_to_gnu (Type_High_Bound (gnat_entity)); + + if (TREE_CODE (gnu_scalar_type) == ENUMERAL_TYPE) + { + /* Since this has both a typedef and a tag, avoid outputting + the name twice. */ + DECL_ARTIFICIAL (gnu_decl) = 1; + rest_of_type_decl_compilation (gnu_decl); + } + } + + /* If we deferred processing of incomplete types, re-enable it. If there + were no other disables and we have some to process, do so. */ + if (this_deferred && --defer_incomplete_level == 0) + { + if (defer_incomplete_list) + { + struct incomplete *incp, *next; + + /* We are back to level 0 for the deferring of incomplete types. + But processing these incomplete types below may itself require + deferring, so preserve what we have and restart from scratch. */ + incp = defer_incomplete_list; + defer_incomplete_list = NULL; + + /* For finalization, however, all types must be complete so we + cannot do the same because deferred incomplete types may end up + referencing each other. Process them all recursively first. */ + defer_finalize_level++; + + for (; incp; incp = next) + { + next = incp->next; + + if (incp->old_type) + update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type), + gnat_to_gnu_type (incp->full_type)); + free (incp); + } + + defer_finalize_level--; + } + + /* All the deferred incomplete types have been processed so we can + now proceed with the finalization of the deferred types. */ + if (defer_finalize_level == 0 && defer_finalize_list) + { + unsigned int i; + tree t; + + for (i = 0; VEC_iterate (tree, defer_finalize_list, i, t); i++) + rest_of_type_decl_compilation_no_defer (t); + + VEC_free (tree, heap, defer_finalize_list); + } + } + + /* If we are not defining this type, see if it's in the incomplete list. + If so, handle that list entry now. */ + else if (!definition) + { + struct incomplete *incp; + + for (incp = defer_incomplete_list; incp; incp = incp->next) + if (incp->old_type && incp->full_type == gnat_entity) + { + update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type), + TREE_TYPE (gnu_decl)); + incp->old_type = NULL_TREE; + } + } + + if (this_global) + force_global--; + + if (Is_Packed_Array_Type (gnat_entity) + && Is_Itype (Associated_Node_For_Itype (gnat_entity)) + && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity))) + && !present_gnu_tree (Associated_Node_For_Itype (gnat_entity))) + gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0); + + return gnu_decl; + } + + /* Similar, but if the returned value is a COMPONENT_REF, return the + FIELD_DECL. */ + + tree + gnat_to_gnu_field_decl (Entity_Id gnat_entity) + { + tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); + + if (TREE_CODE (gnu_field) == COMPONENT_REF) + gnu_field = TREE_OPERAND (gnu_field, 1); + + return gnu_field; + } + + /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it. + Every TYPE_DECL generated for a type definition must be passed + to this function once everything else has been done for it. */ + + void + rest_of_type_decl_compilation (tree decl) + { + /* We need to defer finalizing the type if incomplete types + are being deferred or if they are being processed. */ + if (defer_incomplete_level || defer_finalize_level) + VEC_safe_push (tree, heap, defer_finalize_list, decl); + else + rest_of_type_decl_compilation_no_defer (decl); + } + + /* Same as above but without deferring the compilation. This + function should not be invoked directly on a TYPE_DECL. */ + + static void + rest_of_type_decl_compilation_no_defer (tree decl) + { + const int toplev = global_bindings_p (); + tree t = TREE_TYPE (decl); + + rest_of_decl_compilation (decl, toplev, 0); + + /* Now process all the variants. This is needed for STABS. */ + for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t)) + { + if (t == TREE_TYPE (decl)) + continue; + + if (!TYPE_STUB_DECL (t)) + { + TYPE_STUB_DECL (t) = build_decl (TYPE_DECL, DECL_NAME (decl), t); + DECL_ARTIFICIAL (TYPE_STUB_DECL (t)) = 1; + } + + rest_of_type_compilation (t, toplev); + } + } + + /* Finalize any From_With_Type incomplete types. We do this after processing + our compilation unit and after processing its spec, if this is a body. */ + + void + finalize_from_with_types (void) + { + struct incomplete *incp = defer_limited_with; + struct incomplete *next; + + defer_limited_with = 0; + for (; incp; incp = next) + { + next = incp->next; + + if (incp->old_type != 0) + update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type), + gnat_to_gnu_type (incp->full_type)); + free (incp); + } + } + + /* Return the equivalent type to be used for GNAT_ENTITY, if it's a + kind of type (such E_Task_Type) that has a different type which Gigi + uses for its representation. If the type does not have a special type + for its representation, return GNAT_ENTITY. If a type is supposed to + exist, but does not, abort unless annotating types, in which case + return Empty. If GNAT_ENTITY is Empty, return Empty. */ + + Entity_Id + Gigi_Equivalent_Type (Entity_Id gnat_entity) + { + Entity_Id gnat_equiv = gnat_entity; + + if (No (gnat_entity)) + return gnat_entity; + + switch (Ekind (gnat_entity)) + { + case E_Class_Wide_Subtype: + if (Present (Equivalent_Type (gnat_entity))) + gnat_equiv = Equivalent_Type (gnat_entity); + break; + + case E_Access_Protected_Subprogram_Type: + case E_Anonymous_Access_Protected_Subprogram_Type: + gnat_equiv = Equivalent_Type (gnat_entity); + break; + + case E_Class_Wide_Type: + gnat_equiv = ((Present (Equivalent_Type (gnat_entity))) + ? Equivalent_Type (gnat_entity) + : Root_Type (gnat_entity)); + break; + + case E_Task_Type: + case E_Task_Subtype: + case E_Protected_Type: + case E_Protected_Subtype: + gnat_equiv = Corresponding_Record_Type (gnat_entity); + break; + + default: + break; + } + + gcc_assert (Present (gnat_equiv) || type_annotate_only); + return gnat_equiv; + } + + /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and + using MECH as its passing mechanism, to be placed in the parameter + list built for GNAT_SUBPROG. Assume a foreign convention for the + latter if FOREIGN is true. Also set CICO to true if the parameter + must use the copy-in copy-out implementation mechanism. + + The returned tree is a PARM_DECL, except for those cases where no + parameter needs to be actually passed to the subprogram; the type + of this "shadow" parameter is then returned instead. */ + + static tree + gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, + Entity_Id gnat_subprog, bool foreign, bool *cico) + { + tree gnu_param_name = get_entity_name (gnat_param); + tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param)); + tree gnu_param_type_alt = NULL_TREE; + bool in_param = (Ekind (gnat_param) == E_In_Parameter); + /* The parameter can be indirectly modified if its address is taken. */ + bool ro_param = in_param && !Address_Taken (gnat_param); + bool by_return = false, by_component_ptr = false, by_ref = false; + tree gnu_param; + + /* Copy-return is used only for the first parameter of a valued procedure. + It's a copy mechanism for which a parameter is never allocated. */ + if (mech == By_Copy_Return) + { + gcc_assert (Ekind (gnat_param) == E_Out_Parameter); + mech = By_Copy; + by_return = true; + } + + /* If this is either a foreign function or if the underlying type won't + be passed by reference, strip off possible padding type. */ + if (TREE_CODE (gnu_param_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_param_type)) + { + tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type)); + + if (mech == By_Reference + || foreign + || (!must_pass_by_ref (unpadded_type) + && (mech == By_Copy || !default_pass_by_ref (unpadded_type)))) + gnu_param_type = unpadded_type; + } + + /* If this is a read-only parameter, make a variant of the type that is + read-only. ??? However, if this is an unconstrained array, that type + can be very complex, so skip it for now. Likewise for any other + self-referential type. */ + if (ro_param + && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE + && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type))) + gnu_param_type = build_qualified_type (gnu_param_type, + (TYPE_QUALS (gnu_param_type) + | TYPE_QUAL_CONST)); + + /* For foreign conventions, pass arrays as pointers to the element type. + First check for unconstrained array and get the underlying array. */ + if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_param_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type)))); + + /* VMS descriptors are themselves passed by reference. */ + if (mech == By_Short_Descriptor || + (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64)) + gnu_param_type + = build_pointer_type (build_vms_descriptor32 (gnu_param_type, + Mechanism (gnat_param), + gnat_subprog)); + else if (mech == By_Descriptor) + { + /* Build both a 32-bit and 64-bit descriptor, one of which will be + chosen in fill_vms_descriptor. */ + gnu_param_type_alt + = build_pointer_type (build_vms_descriptor32 (gnu_param_type, + Mechanism (gnat_param), + gnat_subprog)); + gnu_param_type + = build_pointer_type (build_vms_descriptor (gnu_param_type, + Mechanism (gnat_param), + gnat_subprog)); + } + + /* Arrays are passed as pointers to element type for foreign conventions. */ + else if (foreign + && mech != By_Copy + && TREE_CODE (gnu_param_type) == ARRAY_TYPE) + { + /* Strip off any multi-dimensional entries, then strip + off the last array to get the component type. */ + while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type))) + gnu_param_type = TREE_TYPE (gnu_param_type); + + by_component_ptr = true; + gnu_param_type = TREE_TYPE (gnu_param_type); + + if (ro_param) + gnu_param_type = build_qualified_type (gnu_param_type, + (TYPE_QUALS (gnu_param_type) + | TYPE_QUAL_CONST)); + + gnu_param_type = build_pointer_type (gnu_param_type); + } + + /* Fat pointers are passed as thin pointers for foreign conventions. */ + else if (foreign && TYPE_FAT_POINTER_P (gnu_param_type)) + gnu_param_type + = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0); + + /* If we must pass or were requested to pass by reference, do so. + If we were requested to pass by copy, do so. + Otherwise, for foreign conventions, pass In Out or Out parameters + or aggregates by reference. For COBOL and Fortran, pass all + integer and FP types that way too. For Convention Ada, use + the standard Ada default. */ + else if (must_pass_by_ref (gnu_param_type) + || mech == By_Reference + || (mech != By_Copy + && ((foreign + && (!in_param || AGGREGATE_TYPE_P (gnu_param_type))) + || (foreign + && (Convention (gnat_subprog) == Convention_Fortran + || Convention (gnat_subprog) == Convention_COBOL) + && (INTEGRAL_TYPE_P (gnu_param_type) + || FLOAT_TYPE_P (gnu_param_type))) + || (!foreign + && default_pass_by_ref (gnu_param_type))))) + { + gnu_param_type = build_reference_type (gnu_param_type); + by_ref = true; + } + + /* Pass In Out or Out parameters using copy-in copy-out mechanism. */ + else if (!in_param) + *cico = true; + + if (mech == By_Copy && (by_ref || by_component_ptr)) + post_error ("?cannot pass & by copy", gnat_param); + + /* If this is an Out parameter that isn't passed by reference and isn't + a pointer or aggregate, we don't make a PARM_DECL for it. Instead, + it will be a VAR_DECL created when we process the procedure, so just + return its type. For the special parameter of a valued procedure, + never pass it in. + + An exception is made to cover the RM-6.4.1 rule requiring "by copy" + Out parameters with discriminants or implicit initial values to be + handled like In Out parameters. These type are normally built as + aggregates, hence passed by reference, except for some packed arrays + which end up encoded in special integer types. + + The exception we need to make is then for packed arrays of records + with discriminants or implicit initial values. We have no light/easy + way to check for the latter case, so we merely check for packed arrays + of records. This may lead to useless copy-in operations, but in very + rare cases only, as these would be exceptions in a set of already + exceptional situations. */ + if (Ekind (gnat_param) == E_Out_Parameter + && !by_ref + && (by_return + || (mech != By_Descriptor + && mech != By_Short_Descriptor + && !POINTER_TYPE_P (gnu_param_type) + && !AGGREGATE_TYPE_P (gnu_param_type))) + && !(Is_Array_Type (Etype (gnat_param)) + && Is_Packed (Etype (gnat_param)) + && Is_Composite_Type (Component_Type (Etype (gnat_param))))) + return gnu_param_type; + + gnu_param = create_param_decl (gnu_param_name, gnu_param_type, + ro_param || by_ref || by_component_ptr); + DECL_BY_REF_P (gnu_param) = by_ref; + DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr; + DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor || + mech == By_Short_Descriptor); + DECL_POINTS_TO_READONLY_P (gnu_param) + = (ro_param && (by_ref || by_component_ptr)); + + /* Save the alternate descriptor type, if any. */ + if (gnu_param_type_alt) + SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt); + + /* If no Mechanism was specified, indicate what we're using, then + back-annotate it. */ + if (mech == Default) + mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy; + + Set_Mechanism (gnat_param, mech); + return gnu_param; + } + + /* Return true if DISCR1 and DISCR2 represent the same discriminant. */ + + static bool + same_discriminant_p (Entity_Id discr1, Entity_Id discr2) + { + while (Present (Corresponding_Discriminant (discr1))) + discr1 = Corresponding_Discriminant (discr1); + + while (Present (Corresponding_Discriminant (discr2))) + discr2 = Corresponding_Discriminant (discr2); + + return + Original_Record_Component (discr1) == Original_Record_Component (discr2); + } + + /* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has + a non-aliased component in the back-end sense. */ + + static bool + array_type_has_nonaliased_component (Entity_Id gnat_type, tree gnu_type) + { + /* If the type below this is a multi-array type, then + this does not have aliased components. */ + if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) + return true; + + if (Has_Aliased_Components (gnat_type)) + return false; + + return type_for_nonaliased_component_p (TREE_TYPE (gnu_type)); + } + + /* Given GNAT_ENTITY, elaborate all expressions that are required to + be elaborated at the point of its definition, but do nothing else. */ + + void + elaborate_entity (Entity_Id gnat_entity) + { + switch (Ekind (gnat_entity)) + { + case E_Signed_Integer_Subtype: + case E_Modular_Integer_Subtype: + case E_Enumeration_Subtype: + case E_Ordinary_Fixed_Point_Subtype: + case E_Decimal_Fixed_Point_Subtype: + case E_Floating_Point_Subtype: + { + Node_Id gnat_lb = Type_Low_Bound (gnat_entity); + Node_Id gnat_hb = Type_High_Bound (gnat_entity); + + /* ??? Tests for avoiding static constraint error expression + is needed until the front stops generating bogus conversions + on bounds of real types. */ + + if (!Raises_Constraint_Error (gnat_lb)) + elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"), + 1, 0, Needs_Debug_Info (gnat_entity)); + if (!Raises_Constraint_Error (gnat_hb)) + elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"), + 1, 0, Needs_Debug_Info (gnat_entity)); + break; + } + + case E_Record_Type: + { + Node_Id full_definition = Declaration_Node (gnat_entity); + Node_Id record_definition = Type_Definition (full_definition); + + /* If this is a record extension, go a level further to find the + record definition. */ + if (Nkind (record_definition) == N_Derived_Type_Definition) + record_definition = Record_Extension_Part (record_definition); + } + break; + + case E_Record_Subtype: + case E_Private_Subtype: + case E_Limited_Private_Subtype: + case E_Record_Subtype_With_Private: + if (Is_Constrained (gnat_entity) + && Has_Discriminants (Base_Type (gnat_entity)) + && Present (Discriminant_Constraint (gnat_entity))) + { + Node_Id gnat_discriminant_expr; + Entity_Id gnat_field; + + for (gnat_field = First_Discriminant (Base_Type (gnat_entity)), + gnat_discriminant_expr + = First_Elmt (Discriminant_Constraint (gnat_entity)); + Present (gnat_field); + gnat_field = Next_Discriminant (gnat_field), + gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr)) + /* ??? For now, ignore access discriminants. */ + if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr)))) + elaborate_expression (Node (gnat_discriminant_expr), + gnat_entity, + get_entity_name (gnat_field), 1, 0, 0); + } + break; + + } + } + + /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark + any entities on its entity chain similarly. */ + + void + mark_out_of_scope (Entity_Id gnat_entity) + { + Entity_Id gnat_sub_entity; + unsigned int kind = Ekind (gnat_entity); + + /* If this has an entity list, process all in the list. */ + if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind) + || IN (kind, Private_Kind) + || kind == E_Block || kind == E_Entry || kind == E_Entry_Family + || kind == E_Function || kind == E_Generic_Function + || kind == E_Generic_Package || kind == E_Generic_Procedure + || kind == E_Loop || kind == E_Operator || kind == E_Package + || kind == E_Package_Body || kind == E_Procedure + || kind == E_Record_Type || kind == E_Record_Subtype + || kind == E_Subprogram_Body || kind == E_Subprogram_Type) + for (gnat_sub_entity = First_Entity (gnat_entity); + Present (gnat_sub_entity); + gnat_sub_entity = Next_Entity (gnat_sub_entity)) + if (Scope (gnat_sub_entity) == gnat_entity + && gnat_sub_entity != gnat_entity) + mark_out_of_scope (gnat_sub_entity); + + /* Now clear this if it has been defined, but only do so if it isn't + a subprogram or parameter. We could refine this, but it isn't + worth it. If this is statically allocated, it is supposed to + hang around out of cope. */ + if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity) + && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind)) + { + save_gnu_tree (gnat_entity, NULL_TREE, true); + save_gnu_tree (gnat_entity, error_mark_node, true); + } + } + + /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP. + If this is a multi-dimensional array type, do this recursively. + + OP may be + - ALIAS_SET_COPY: the new set is made a copy of the old one. + - ALIAS_SET_SUPERSET: the new set is made a superset of the old one. + - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */ + + static void + relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op) + { + /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case + of a one-dimensional array, since the padding has the same alias set + as the field type, but if it's a multi-dimensional array, we need to + see the inner types. */ + while (TREE_CODE (gnu_old_type) == RECORD_TYPE + && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type) + || TYPE_IS_PADDING_P (gnu_old_type))) + gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type)); + + /* Unconstrained array types are deemed incomplete and would thus be given + alias set 0. Retrieve the underlying array type. */ + if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_old_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type)))); + if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_new_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type)))); + + if (TREE_CODE (gnu_new_type) == ARRAY_TYPE + && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type))) + relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op); + + switch (op) + { + case ALIAS_SET_COPY: + /* The alias set shouldn't be copied between array types with different + aliasing settings because this can break the aliasing relationship + between the array type and its element type. */ + #ifndef ENABLE_CHECKING + if (flag_strict_aliasing) + #endif + gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE + && TREE_CODE (gnu_old_type) == ARRAY_TYPE + && TYPE_NONALIASED_COMPONENT (gnu_new_type) + != TYPE_NONALIASED_COMPONENT (gnu_old_type))); + + TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type); + break; + + case ALIAS_SET_SUBSET: + case ALIAS_SET_SUPERSET: + { + alias_set_type old_set = get_alias_set (gnu_old_type); + alias_set_type new_set = get_alias_set (gnu_new_type); + + /* Do nothing if the alias sets conflict. This ensures that we + never call record_alias_subset several times for the same pair + or at all for alias set 0. */ + if (!alias_sets_conflict_p (old_set, new_set)) + { + if (op == ALIAS_SET_SUBSET) + record_alias_subset (old_set, new_set); + else + record_alias_subset (new_set, old_set); + } + } + break; + + default: + gcc_unreachable (); + } + + record_component_aliases (gnu_new_type); + } + + /* Return a TREE_LIST describing the substitutions needed to reflect + discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add + them to GNU_LIST. If GNAT_TYPE is not specified, use the base type + of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE + gives the tree for the discriminant and TREE_VALUES is the replacement + value. They are in the form of operands to substitute_in_expr. + DEFINITION is as in gnat_to_gnu_entity. */ + + static tree + substitution_list (Entity_Id gnat_subtype, Entity_Id gnat_type, + tree gnu_list, bool definition) + { + Entity_Id gnat_discrim; + Node_Id gnat_value; + + if (No (gnat_type)) + gnat_type = Implementation_Base_Type (gnat_subtype); + + if (Has_Discriminants (gnat_type)) + for (gnat_discrim = First_Stored_Discriminant (gnat_type), + gnat_value = First_Elmt (Stored_Constraint (gnat_subtype)); + Present (gnat_discrim); + gnat_discrim = Next_Stored_Discriminant (gnat_discrim), + gnat_value = Next_Elmt (gnat_value)) + /* Ignore access discriminants. */ + if (!Is_Access_Type (Etype (Node (gnat_value)))) + gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim), + elaborate_expression + (Node (gnat_value), gnat_subtype, + get_entity_name (gnat_discrim), definition, + 1, 0), + gnu_list); + + return gnu_list; + } + + /* Return true if the size represented by GNU_SIZE can be handled by an + allocation. If STATIC_P is true, consider only what can be done with a + static allocation. */ + + static bool + allocatable_size_p (tree gnu_size, bool static_p) + { + HOST_WIDE_INT our_size; + + /* If this is not a static allocation, the only case we want to forbid + is an overflowing size. That will be converted into a raise a + Storage_Error. */ + if (!static_p) + return !(TREE_CODE (gnu_size) == INTEGER_CST + && TREE_OVERFLOW (gnu_size)); + + /* Otherwise, we need to deal with both variable sizes and constant + sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT + since assemblers may not like very large sizes. */ + if (!host_integerp (gnu_size, 1)) + return false; + + our_size = tree_low_cst (gnu_size, 1); + return (int) our_size == our_size; + } + + /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE, + NAME, ARGS and ERROR_POINT. */ + + static void + prepend_one_attribute_to (struct attrib ** attr_list, + enum attr_type attr_type, + tree attr_name, + tree attr_args, + Node_Id attr_error_point) + { + struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib)); + + attr->type = attr_type; + attr->name = attr_name; + attr->args = attr_args; + attr->error_point = attr_error_point; + + attr->next = *attr_list; + *attr_list = attr; + } + + /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */ + + static void + prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list) + { + Node_Id gnat_temp; + + for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp); + gnat_temp = Next_Rep_Item (gnat_temp)) + if (Nkind (gnat_temp) == N_Pragma) + { + tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE; + Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp); + enum attr_type etype; + + if (Present (gnat_assoc) && Present (First (gnat_assoc)) + && Present (Next (First (gnat_assoc))) + && (Nkind (Expression (Next (First (gnat_assoc)))) + == N_String_Literal)) + { + gnu_arg0 = get_identifier (TREE_STRING_POINTER + (gnat_to_gnu + (Expression (Next + (First (gnat_assoc)))))); + if (Present (Next (Next (First (gnat_assoc)))) + && (Nkind (Expression (Next (Next (First (gnat_assoc))))) + == N_String_Literal)) + gnu_arg1 = get_identifier (TREE_STRING_POINTER + (gnat_to_gnu + (Expression + (Next (Next + (First (gnat_assoc))))))); + } + + switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp)))) + { + case Pragma_Machine_Attribute: + etype = ATTR_MACHINE_ATTRIBUTE; + break; + + case Pragma_Linker_Alias: + etype = ATTR_LINK_ALIAS; + break; + + case Pragma_Linker_Section: + etype = ATTR_LINK_SECTION; + break; + + case Pragma_Linker_Constructor: + etype = ATTR_LINK_CONSTRUCTOR; + break; + + case Pragma_Linker_Destructor: + etype = ATTR_LINK_DESTRUCTOR; + break; + + case Pragma_Weak_External: + etype = ATTR_WEAK_EXTERNAL; + break; + + default: + continue; + } + + + /* Prepend to the list now. Make a list of the argument we might + have, as GCC expects it. */ + prepend_one_attribute_to + (attr_list, + etype, gnu_arg0, + (gnu_arg1 != NULL_TREE) + ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE, + Present (Next (First (gnat_assoc))) + ? Expression (Next (First (gnat_assoc))) : gnat_temp); + } + } + + /* Get the unpadded version of a GNAT type. */ + + tree + get_unpadded_type (Entity_Id gnat_entity) + { + tree type = gnat_to_gnu_type (gnat_entity); + + if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + type = TREE_TYPE (TYPE_FIELDS (type)); + + return type; + } + + /* Called when we need to protect a variable object using a save_expr. */ + + tree + maybe_variable (tree gnu_operand) + { + if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand) + || TREE_CODE (gnu_operand) == SAVE_EXPR + || TREE_CODE (gnu_operand) == NULL_EXPR) + return gnu_operand; + + if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF) + { + tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF, + TREE_TYPE (gnu_operand), + variable_size (TREE_OPERAND (gnu_operand, 0))); + + TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) + = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand))); + return gnu_result; + } + else + return variable_size (gnu_operand); + } + + /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a + type definition (either a bound or a discriminant value) for GNAT_ENTITY, + return the GCC tree to use for that expression. GNU_NAME is the + qualification to use if an external name is appropriate and DEFINITION is + nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero, + we need a result. Otherwise, we are just elaborating this for + side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging + purposes even if it isn't needed for code generation. */ + + static tree + elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, + tree gnu_name, bool definition, bool need_value, + bool need_debug) + { + tree gnu_expr; + + /* If we already elaborated this expression (e.g., it was involved + in the definition of a private type), use the old value. */ + if (present_gnu_tree (gnat_expr)) + return get_gnu_tree (gnat_expr); + + /* If we don't need a value and this is static or a discriminant, we + don't need to do anything. */ + else if (!need_value + && (Is_OK_Static_Expression (gnat_expr) + || (Nkind (gnat_expr) == N_Identifier + && Ekind (Entity (gnat_expr)) == E_Discriminant))) + return 0; + + /* Otherwise, convert this tree to its GCC equivalent. */ + gnu_expr + = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr), + gnu_name, definition, need_debug); + + /* Save the expression in case we try to elaborate this entity again. Since + it's not a DECL, don't check it. Don't save if it's a discriminant. */ + if (!CONTAINS_PLACEHOLDER_P (gnu_expr)) + save_gnu_tree (gnat_expr, gnu_expr, true); + + return need_value ? gnu_expr : error_mark_node; + } + + /* Similar, but take a GNU expression. */ + + static tree + elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity, + tree gnu_expr, tree gnu_name, bool definition, + bool need_debug) + { + tree gnu_decl = NULL_TREE; + /* Skip any conversions and simple arithmetics to see if the expression + is a read-only variable. + ??? This really should remain read-only, but we have to think about + the typing of the tree here. */ + tree gnu_inner_expr + = skip_simple_arithmetic (remove_conversions (gnu_expr, true)); + bool expr_global = Is_Public (gnat_entity) || global_bindings_p (); + bool expr_variable; + + /* In most cases, we won't see a naked FIELD_DECL here because a + discriminant reference will have been replaced with a COMPONENT_REF + when the type is being elaborated. However, there are some cases + involving child types where we will. So convert it to a COMPONENT_REF + here. We have to hope it will be at the highest level of the + expression in these cases. */ + if (TREE_CODE (gnu_expr) == FIELD_DECL) + gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr), + build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)), + gnu_expr, NULL_TREE); + + /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable + that is read-only, make a variable that is initialized to contain the + bound when the package containing the definition is elaborated. If + this entity is defined at top level and a bound or discriminant value + isn't a constant or a reference to a discriminant, replace the bound + by the variable; otherwise use a SAVE_EXPR if needed. Note that we + rely here on the fact that an expression cannot contain both the + discriminant and some other variable. */ + + expr_variable = (!CONSTANT_CLASS_P (gnu_expr) + && !(TREE_CODE (gnu_inner_expr) == VAR_DECL + && (TREE_READONLY (gnu_inner_expr) + || DECL_READONLY_ONCE_ELAB (gnu_inner_expr))) + && !CONTAINS_PLACEHOLDER_P (gnu_expr)); + + /* If this is a static expression or contains a discriminant, we don't + need the variable for debugging (and can't elaborate anyway if a + discriminant). */ + if (need_debug + && (Is_OK_Static_Expression (gnat_expr) + || CONTAINS_PLACEHOLDER_P (gnu_expr))) + need_debug = false; + + /* Now create the variable if we need it. */ + if (need_debug || (expr_variable && expr_global)) + gnu_decl + = create_var_decl (create_concat_name (gnat_entity, + IDENTIFIER_POINTER (gnu_name)), + NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, + !need_debug, Is_Public (gnat_entity), + !definition, false, NULL, gnat_entity); + + /* We only need to use this variable if we are in global context since GCC + can do the right thing in the local case. */ + if (expr_global && expr_variable) + return gnu_decl; + else if (!expr_variable) + return gnu_expr; + else + return maybe_variable (gnu_expr); + } + + /* Create a record type that contains a SIZE bytes long field of TYPE with a + starting bit position so that it is aligned to ALIGN bits, and leaving at + least ROOM bytes free before the field. BASE_ALIGN is the alignment the + record is guaranteed to get. */ + + tree + make_aligning_type (tree type, unsigned int align, tree size, + unsigned int base_align, int room) + { + /* We will be crafting a record type with one field at a position set to be + the next multiple of ALIGN past record'address + room bytes. We use a + record placeholder to express record'address. */ + + tree record_type = make_node (RECORD_TYPE); + tree record = build0 (PLACEHOLDER_EXPR, record_type); + + tree record_addr_st + = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record)); + + /* The diagram below summarizes the shape of what we manipulate: + + <--------- pos ----------> + { +------------+-------------+-----------------+ + record =>{ |############| ... | field (type) | + { +------------+-------------+-----------------+ + |<-- room -->|<- voffset ->|<---- size ----->| + o o + | | + record_addr vblock_addr + + Every length is in sizetype bytes there, except "pos" which has to be + set as a bit position in the GCC tree for the record. */ + + tree room_st = size_int (room); + tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st); + tree voffset_st, pos, field; + + tree name = TYPE_NAME (type); + + if (TREE_CODE (name) == TYPE_DECL) + name = DECL_NAME (name); + + TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN"); + + /* Compute VOFFSET and then POS. The next byte position multiple of some + alignment after some address is obtained by "and"ing the alignment minus + 1 with the two's complement of the address. */ + + voffset_st = size_binop (BIT_AND_EXPR, + size_diffop (size_zero_node, vblock_addr_st), + ssize_int ((align / BITS_PER_UNIT) - 1)); + + /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */ + + pos = size_binop (MULT_EXPR, + convert (bitsizetype, + size_binop (PLUS_EXPR, room_st, voffset_st)), + bitsize_unit_node); + + /* Craft the GCC record representation. We exceptionally do everything + manually here because 1) our generic circuitry is not quite ready to + handle the complex position/size expressions we are setting up, 2) we + have a strong simplifying factor at hand: we know the maximum possible + value of voffset, and 3) we have to set/reset at least the sizes in + accordance with this maximum value anyway, as we need them to convey + what should be "alloc"ated for this type. + + Use -1 as the 'addressable' indication for the field to prevent the + creation of a bitfield. We don't need one, it would have damaging + consequences on the alignment computation, and create_field_decl would + make one without this special argument, for instance because of the + complex position expression. */ + + field = create_field_decl (get_identifier ("F"), type, record_type, + 1, size, pos, -1); + TYPE_FIELDS (record_type) = field; + + TYPE_ALIGN (record_type) = base_align; + TYPE_USER_ALIGN (record_type) = 1; + + TYPE_SIZE (record_type) + = size_binop (PLUS_EXPR, + size_binop (MULT_EXPR, convert (bitsizetype, size), + bitsize_unit_node), + bitsize_int (align + room * BITS_PER_UNIT)); + TYPE_SIZE_UNIT (record_type) + = size_binop (PLUS_EXPR, size, + size_int (room + align / BITS_PER_UNIT)); + + SET_TYPE_MODE (record_type, BLKmode); + + relate_alias_sets (record_type, type, ALIAS_SET_COPY); + return record_type; + } + + /* Return the result of rounding T up to ALIGN. */ + + static inline unsigned HOST_WIDE_INT + round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align) + { + t += align - 1; + t /= align; + t *= align; + return t; + } + + /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used + as the field type of a packed record if IN_RECORD is true, or as the + component type of a packed array if IN_RECORD is false. See if we can + rewrite it either as a type that has a non-BLKmode, which we can pack + tighter in the packed record case, or as a smaller type. If so, return + the new type. If not, return the original type. */ + + static tree + make_packable_type (tree type, bool in_record) + { + unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1); + unsigned HOST_WIDE_INT new_size; + tree new_type, old_field, field_list = NULL_TREE; + + /* No point in doing anything if the size is zero. */ + if (size == 0) + return type; + + new_type = make_node (TREE_CODE (type)); + + /* Copy the name and flags from the old type to that of the new. + Note that we rely on the pointer equality created here for + TYPE_NAME to look through conversions in various places. */ + TYPE_NAME (new_type) = TYPE_NAME (type); + TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type); + TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type); + if (TREE_CODE (type) == RECORD_TYPE) + TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type); + + /* If we are in a record and have a small size, set the alignment to + try for an integral mode. Otherwise set it to try for a smaller + type with BLKmode. */ + if (in_record && size <= MAX_FIXED_MODE_SIZE) + { + TYPE_ALIGN (new_type) = ceil_alignment (size); + new_size = round_up_to_align (size, TYPE_ALIGN (new_type)); + } + else + { + unsigned HOST_WIDE_INT align; + + /* Do not try to shrink the size if the RM size is not constant. */ + if (TYPE_CONTAINS_TEMPLATE_P (type) + || !host_integerp (TYPE_ADA_SIZE (type), 1)) + return type; + + /* Round the RM size up to a unit boundary to get the minimal size + for a BLKmode record. Give up if it's already the size. */ + new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type)); + new_size = round_up_to_align (new_size, BITS_PER_UNIT); + if (new_size == size) + return type; + + align = new_size & -new_size; + TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align); + } + + TYPE_USER_ALIGN (new_type) = 1; + + /* Now copy the fields, keeping the position and size as we don't want + to change the layout by propagating the packedness downwards. */ + for (old_field = TYPE_FIELDS (type); old_field; + old_field = TREE_CHAIN (old_field)) + { + tree new_field_type = TREE_TYPE (old_field); + tree new_field, new_size; + + if ((TREE_CODE (new_field_type) == RECORD_TYPE + || TREE_CODE (new_field_type) == UNION_TYPE + || TREE_CODE (new_field_type) == QUAL_UNION_TYPE) + && !TYPE_IS_FAT_POINTER_P (new_field_type) + && host_integerp (TYPE_SIZE (new_field_type), 1)) + new_field_type = make_packable_type (new_field_type, true); + + /* However, for the last field in a not already packed record type + that is of an aggregate type, we need to use the RM_Size in the + packable version of the record type, see finish_record_type. */ + if (!TREE_CHAIN (old_field) + && !TYPE_PACKED (type) + && (TREE_CODE (new_field_type) == RECORD_TYPE + || TREE_CODE (new_field_type) == UNION_TYPE + || TREE_CODE (new_field_type) == QUAL_UNION_TYPE) + && !TYPE_IS_FAT_POINTER_P (new_field_type) + && !TYPE_CONTAINS_TEMPLATE_P (new_field_type) + && TYPE_ADA_SIZE (new_field_type)) + new_size = TYPE_ADA_SIZE (new_field_type); + else + new_size = DECL_SIZE (old_field); + + new_field = create_field_decl (DECL_NAME (old_field), new_field_type, + new_type, TYPE_PACKED (type), new_size, + bit_position (old_field), + !DECL_NONADDRESSABLE_P (old_field)); + + DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field); + SET_DECL_ORIGINAL_FIELD + (new_field, (DECL_ORIGINAL_FIELD (old_field) + ? DECL_ORIGINAL_FIELD (old_field) : old_field)); + + if (TREE_CODE (new_type) == QUAL_UNION_TYPE) + DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field); + + TREE_CHAIN (new_field) = field_list; + field_list = new_field; + } + + finish_record_type (new_type, nreverse (field_list), 2, true); + relate_alias_sets (new_type, type, ALIAS_SET_COPY); + + /* If this is a padding record, we never want to make the size smaller + than what was specified. For QUAL_UNION_TYPE, also copy the size. */ + if ((TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + || TREE_CODE (type) == QUAL_UNION_TYPE) + { + TYPE_SIZE (new_type) = TYPE_SIZE (type); + TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type); + } + else + { + TYPE_SIZE (new_type) = bitsize_int (new_size); + TYPE_SIZE_UNIT (new_type) + = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT); + } + + if (!TYPE_CONTAINS_TEMPLATE_P (type)) + SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type)); + + compute_record_mode (new_type); + + /* Try harder to get a packable type if necessary, for example + in case the record itself contains a BLKmode field. */ + if (in_record && TYPE_MODE (new_type) == BLKmode) + SET_TYPE_MODE (new_type, + mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1)); + + /* If neither the mode nor the size has shrunk, return the old type. */ + if (TYPE_MODE (new_type) == BLKmode && new_size >= size) + return type; + + return new_type; + } + + /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type + if needed. We have already verified that SIZE and TYPE are large enough. + + GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and + to issue a warning. + + IS_USER_TYPE is true if we must complete the original type. + + DEFINITION is true if this type is being defined. + + SAME_RM_SIZE is true if the RM_Size of the resulting type is to be set + to SIZE too; otherwise, it's set to the RM_Size of the original type. */ + + tree + maybe_pad_type (tree type, tree size, unsigned int align, + Entity_Id gnat_entity, const char *name_trailer, + bool is_user_type, bool definition, bool same_rm_size) + { + tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type); + tree orig_size = TYPE_SIZE (type); + unsigned int orig_align = align; + tree record, field; + + /* If TYPE is a padded type, see if it agrees with any size and alignment + we were given. If so, return the original type. Otherwise, strip + off the padding, since we will either be returning the inner type + or repadding it. If no size or alignment is specified, use that of + the original padded type. */ + if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + { + if ((!size + || operand_equal_p (round_up (size, + MAX (align, TYPE_ALIGN (type))), + round_up (TYPE_SIZE (type), + MAX (align, TYPE_ALIGN (type))), + 0)) + && (align == 0 || align == TYPE_ALIGN (type))) + return type; + + if (!size) + size = TYPE_SIZE (type); + if (align == 0) + align = TYPE_ALIGN (type); + + type = TREE_TYPE (TYPE_FIELDS (type)); + orig_size = TYPE_SIZE (type); + } + + /* If the size is either not being changed or is being made smaller (which + is not done here (and is only valid for bitfields anyway), show the size + isn't changing. Likewise, clear the alignment if it isn't being + changed. Then return if we aren't doing anything. */ + if (size + && (operand_equal_p (size, orig_size, 0) + || (TREE_CODE (orig_size) == INTEGER_CST + && tree_int_cst_lt (size, orig_size)))) + size = NULL_TREE; + + if (align == TYPE_ALIGN (type)) + align = 0; + + if (align == 0 && !size) + return type; + + /* If requested, complete the original type and give it a name. */ + if (is_user_type) + create_type_decl (get_entity_name (gnat_entity), type, + NULL, !Comes_From_Source (gnat_entity), + !(TYPE_NAME (type) + && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL + && DECL_IGNORED_P (TYPE_NAME (type))), + gnat_entity); + + /* We used to modify the record in place in some cases, but that could + generate incorrect debugging information. So make a new record + type and name. */ + record = make_node (RECORD_TYPE); + TYPE_IS_PADDING_P (record) = 1; + + if (Present (gnat_entity)) + TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer); + + TYPE_VOLATILE (record) + = Present (gnat_entity) && Treat_As_Volatile (gnat_entity); + + TYPE_ALIGN (record) = align; + if (orig_align) + TYPE_USER_ALIGN (record) = align; + + TYPE_SIZE (record) = size ? size : orig_size; + TYPE_SIZE_UNIT (record) + = convert (sizetype, + size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record), + bitsize_unit_node)); + + /* If we are changing the alignment and the input type is a record with + BLKmode and a small constant size, try to make a form that has an + integral mode. This might allow the padding record to also have an + integral mode, which will be much more efficient. There is no point + in doing so if a size is specified unless it is also a small constant + size and it is incorrect to do so if we cannot guarantee that the mode + will be naturally aligned since the field must always be addressable. + + ??? This might not always be a win when done for a stand-alone object: + since the nominal and the effective type of the object will now have + different modes, a VIEW_CONVERT_EXPR will be required for converting + between them and it might be hard to overcome afterwards, including + at the RTL level when the stand-alone object is accessed as a whole. */ + if (align != 0 + && TREE_CODE (type) == RECORD_TYPE + && TYPE_MODE (type) == BLKmode + && TREE_CODE (orig_size) == INTEGER_CST + && !TREE_OVERFLOW (orig_size) + && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0 + && (!size + || (TREE_CODE (size) == INTEGER_CST + && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0))) + { + tree packable_type = make_packable_type (type, true); + if (TYPE_MODE (packable_type) != BLKmode + && align >= TYPE_ALIGN (packable_type)) + type = packable_type; + } + + /* Now create the field with the original size. */ + field = create_field_decl (get_identifier ("F"), type, record, 0, + orig_size, bitsize_zero_node, 1); + DECL_INTERNAL_P (field) = 1; + + /* Do not finalize it until after the auxiliary record is built. */ + finish_record_type (record, field, 1, true); + + /* Set the same size for its RM_size if requested; otherwise reuse + the RM_size of the original type. */ + SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size); + + /* Unless debugging information isn't being written for the input type, + write a record that shows what we are a subtype of and also make a + variable that indicates our size, if still variable. */ + if (TYPE_NAME (record) + && AGGREGATE_TYPE_P (type) + && TREE_CODE (orig_size) != INTEGER_CST + && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL + && DECL_IGNORED_P (TYPE_NAME (type)))) + { + tree marker = make_node (RECORD_TYPE); + tree name = TYPE_NAME (record); + tree orig_name = TYPE_NAME (type); + + if (TREE_CODE (name) == TYPE_DECL) + name = DECL_NAME (name); + + if (TREE_CODE (orig_name) == TYPE_DECL) + orig_name = DECL_NAME (orig_name); + + TYPE_NAME (marker) = concat_id_with_name (name, "XVS"); + finish_record_type (marker, + create_field_decl (orig_name, integer_type_node, + marker, 0, NULL_TREE, NULL_TREE, + 0), + 0, false); + + add_parallel_type (TYPE_STUB_DECL (record), marker); + + if (size && TREE_CODE (size) != INTEGER_CST && definition) + create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE, + sizetype, TYPE_SIZE_UNIT (record), false, false, + false, false, NULL, gnat_entity); + } + + rest_of_record_type_compilation (record); + + /* If the size was widened explicitly, maybe give a warning. Take the + original size as the maximum size of the input if there was an + unconstrained record involved and round it up to the specified alignment, + if one was specified. */ + if (CONTAINS_PLACEHOLDER_P (orig_size)) + orig_size = max_size (orig_size, true); + + if (align) + orig_size = round_up (orig_size, align); + + if (size && Present (gnat_entity) + && !operand_equal_p (size, orig_size, 0) + && !(TREE_CODE (size) == INTEGER_CST + && TREE_CODE (orig_size) == INTEGER_CST + && tree_int_cst_lt (size, orig_size))) + { + Node_Id gnat_error_node = Empty; + + if (Is_Packed_Array_Type (gnat_entity)) + gnat_entity = Original_Array_Type (gnat_entity); + + if ((Ekind (gnat_entity) == E_Component + || Ekind (gnat_entity) == E_Discriminant) + && Present (Component_Clause (gnat_entity))) + gnat_error_node = Last_Bit (Component_Clause (gnat_entity)); + else if (Present (Size_Clause (gnat_entity))) + gnat_error_node = Expression (Size_Clause (gnat_entity)); + + /* Generate message only for entities that come from source, since + if we have an entity created by expansion, the message will be + generated for some other corresponding source entity. */ + if (Comes_From_Source (gnat_entity) && Present (gnat_error_node)) + post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node, + gnat_entity, + size_diffop (size, orig_size)); + + else if (*name_trailer == 'C' && !Is_Internal (gnat_entity)) + post_error_ne_tree ("component of& padded{ by ^ bits}?", + gnat_entity, gnat_entity, + size_diffop (size, orig_size)); + } + + return record; + } + + /* Given a GNU tree and a GNAT list of choices, generate an expression to test + the value passed against the list of choices. */ + + tree + choices_to_gnu (tree operand, Node_Id choices) + { + Node_Id choice; + Node_Id gnat_temp; + tree result = integer_zero_node; + tree this_test, low = 0, high = 0, single = 0; + + for (choice = First (choices); Present (choice); choice = Next (choice)) + { + switch (Nkind (choice)) + { + case N_Range: + low = gnat_to_gnu (Low_Bound (choice)); + high = gnat_to_gnu (High_Bound (choice)); + + /* There's no good type to use here, so we might as well use + integer_type_node. */ + this_test + = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, + build_binary_op (GE_EXPR, integer_type_node, + operand, low), + build_binary_op (LE_EXPR, integer_type_node, + operand, high)); + + break; + + case N_Subtype_Indication: + gnat_temp = Range_Expression (Constraint (choice)); + low = gnat_to_gnu (Low_Bound (gnat_temp)); + high = gnat_to_gnu (High_Bound (gnat_temp)); + + this_test + = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, + build_binary_op (GE_EXPR, integer_type_node, + operand, low), + build_binary_op (LE_EXPR, integer_type_node, + operand, high)); + break; + + case N_Identifier: + case N_Expanded_Name: + /* This represents either a subtype range, an enumeration + literal, or a constant Ekind says which. If an enumeration + literal or constant, fall through to the next case. */ + if (Ekind (Entity (choice)) != E_Enumeration_Literal + && Ekind (Entity (choice)) != E_Constant) + { + tree type = gnat_to_gnu_type (Entity (choice)); + + low = TYPE_MIN_VALUE (type); + high = TYPE_MAX_VALUE (type); + + this_test + = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, + build_binary_op (GE_EXPR, integer_type_node, + operand, low), + build_binary_op (LE_EXPR, integer_type_node, + operand, high)); + break; + } + + /* ... fall through ... */ + + case N_Character_Literal: + case N_Integer_Literal: + single = gnat_to_gnu (choice); + this_test = build_binary_op (EQ_EXPR, integer_type_node, operand, + single); + break; + + case N_Others_Choice: + this_test = integer_one_node; + break; + + default: + gcc_unreachable (); + } + + result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, + result, this_test); + } + + return result; + } + + /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of + type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */ + + static int + adjust_packed (tree field_type, tree record_type, int packed) + { + /* If the field contains an item of variable size, we cannot pack it + because we cannot create temporaries of non-fixed size in case + we need to take the address of the field. See addressable_p and + the notes on the addressability issues for further details. */ + if (is_variable_size (field_type)) + return 0; + + /* If the alignment of the record is specified and the field type + is over-aligned, request Storage_Unit alignment for the field. */ + if (packed == -2) + { + if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type)) + return -1; + else + return 0; + } + + return packed; + } + + /* Return a GCC tree for a field corresponding to GNAT_FIELD to be + placed in GNU_RECORD_TYPE. + + PACKED is 1 if the enclosing record is packed, -1 if the enclosing + record has Component_Alignment of Storage_Unit, -2 if the enclosing + record has a specified alignment. + + DEFINITION is true if this field is for a record being defined. */ + + static tree + gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, + bool definition) + { + tree gnu_field_id = get_entity_name (gnat_field); + tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); + tree gnu_field, gnu_size, gnu_pos; + bool needs_strict_alignment + = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field)) + || Treat_As_Volatile (gnat_field)); + + /* If this field requires strict alignment, we cannot pack it because + it would very likely be under-aligned in the record. */ + if (needs_strict_alignment) + packed = 0; + else + packed = adjust_packed (gnu_field_type, gnu_record_type, packed); + + /* If a size is specified, use it. Otherwise, if the record type is packed, + use the official RM size. See "Handling of Type'Size Values" in Einfo + for further details. */ + if (Known_Static_Esize (gnat_field)) + gnu_size = validate_size (Esize (gnat_field), gnu_field_type, + gnat_field, FIELD_DECL, false, true); + else if (packed == 1) + gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type, + gnat_field, FIELD_DECL, false, true); + else + gnu_size = NULL_TREE; + + /* If we have a specified size that's smaller than that of the field type, + or a position is specified, and the field type is a record, see if we can + get either an integral mode form of the type or a smaller form. If we + can, show a size was specified for the field if there wasn't one already, + so we know to make this a bitfield and avoid making things wider. + + Doing this is first useful if the record is packed because we may then + place the field at a non-byte-aligned position and so achieve tighter + packing. + + This is in addition *required* if the field shares a byte with another + field and the front-end lets the back-end handle the references, because + GCC does not handle BLKmode bitfields properly. + + We avoid the transformation if it is not required or potentially useful, + as it might entail an increase of the field's alignment and have ripple + effects on the outer record type. A typical case is a field known to be + byte aligned and not to share a byte with another field. + + Besides, we don't even look the possibility of a transformation in cases + known to be in error already, for instance when an invalid size results + from a component clause. */ + + if (TREE_CODE (gnu_field_type) == RECORD_TYPE + && !TYPE_IS_FAT_POINTER_P (gnu_field_type) + && host_integerp (TYPE_SIZE (gnu_field_type), 1) + && (packed == 1 + || (gnu_size + && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type)) + || Present (Component_Clause (gnat_field)))))) + { + /* See what the alternate type and size would be. */ + tree gnu_packable_type = make_packable_type (gnu_field_type, true); + + bool has_byte_aligned_clause + = Present (Component_Clause (gnat_field)) + && (UI_To_Int (Component_Bit_Offset (gnat_field)) + % BITS_PER_UNIT == 0); + + /* Compute whether we should avoid the substitution. */ + bool reject + /* There is no point substituting if there is no change... */ + = (gnu_packable_type == gnu_field_type) + /* ... nor when the field is known to be byte aligned and not to + share a byte with another field. */ + || (has_byte_aligned_clause + && value_factor_p (gnu_size, BITS_PER_UNIT)) + /* The size of an aliased field must be an exact multiple of the + type's alignment, which the substitution might increase. Reject + substitutions that would so invalidate a component clause when the + specified position is byte aligned, as the change would have no + real benefit from the packing standpoint anyway. */ + || (Is_Aliased (gnat_field) + && has_byte_aligned_clause + && !value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type))); + + /* Substitute unless told otherwise. */ + if (!reject) + { + gnu_field_type = gnu_packable_type; + + if (!gnu_size) + gnu_size = rm_size (gnu_field_type); + } + } + + /* If we are packing the record and the field is BLKmode, round the + size up to a byte boundary. */ + if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size) + gnu_size = round_up (gnu_size, BITS_PER_UNIT); + + if (Present (Component_Clause (gnat_field))) + { + gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype); + gnu_size = validate_size (Esize (gnat_field), gnu_field_type, + gnat_field, FIELD_DECL, false, true); + + /* Ensure the position does not overlap with the parent subtype, + if there is one. */ + if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field))))) + { + tree gnu_parent + = gnat_to_gnu_type (Parent_Subtype + (Underlying_Type (Scope (gnat_field)))); + + if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST + && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent))) + { + post_error_ne_tree + ("offset of& must be beyond parent{, minimum allowed is ^}", + First_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_SIZE_UNIT (gnu_parent)); + } + } + + /* If this field needs strict alignment, ensure the record is + sufficiently aligned and that that position and size are + consistent with the alignment. */ + if (needs_strict_alignment) + { + TYPE_ALIGN (gnu_record_type) + = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type)); + + if (gnu_size + && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0)) + { + if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field))) + post_error_ne_tree + ("atomic field& must be natural size of type{ (^)}", + Last_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_SIZE (gnu_field_type)); + + else if (Is_Aliased (gnat_field)) + post_error_ne_tree + ("size of aliased field& must be ^ bits", + Last_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_SIZE (gnu_field_type)); + + else if (Strict_Alignment (Etype (gnat_field))) + post_error_ne_tree + ("size of & with aliased or tagged components not ^ bits", + Last_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_SIZE (gnu_field_type)); + + gnu_size = NULL_TREE; + } + + if (!integer_zerop (size_binop + (TRUNC_MOD_EXPR, gnu_pos, + bitsize_int (TYPE_ALIGN (gnu_field_type))))) + { + if (Is_Aliased (gnat_field)) + post_error_ne_num + ("position of aliased field& must be multiple of ^ bits", + First_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_ALIGN (gnu_field_type)); + + else if (Treat_As_Volatile (gnat_field)) + post_error_ne_num + ("position of volatile field& must be multiple of ^ bits", + First_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_ALIGN (gnu_field_type)); + + else if (Strict_Alignment (Etype (gnat_field))) + post_error_ne_num + ("position of & with aliased or tagged components not multiple of ^ bits", + First_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_ALIGN (gnu_field_type)); + + else + gcc_unreachable (); + + gnu_pos = NULL_TREE; + } + } + + if (Is_Atomic (gnat_field)) + check_ok_for_atomic (gnu_field_type, gnat_field, false); + } + + /* If the record has rep clauses and this is the tag field, make a rep + clause for it as well. */ + else if (Has_Specified_Layout (Scope (gnat_field)) + && Chars (gnat_field) == Name_uTag) + { + gnu_pos = bitsize_zero_node; + gnu_size = TYPE_SIZE (gnu_field_type); + } + + else + gnu_pos = NULL_TREE; + + /* We need to make the size the maximum for the type if it is + self-referential and an unconstrained type. In that case, we can't + pack the field since we can't make a copy to align it. */ + if (TREE_CODE (gnu_field_type) == RECORD_TYPE + && !gnu_size + && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type)) + && !Is_Constrained (Underlying_Type (Etype (gnat_field)))) + { + gnu_size = max_size (TYPE_SIZE (gnu_field_type), true); + packed = 0; + } + + /* If a size is specified, adjust the field's type to it. */ + if (gnu_size) + { + /* If the field's type is justified modular, we would need to remove + the wrapper to (better) meet the layout requirements. However we + can do so only if the field is not aliased to preserve the unique + layout and if the prescribed size is not greater than that of the + packed array to preserve the justification. */ + if (!needs_strict_alignment + && TREE_CODE (gnu_field_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type) + && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type)) + <= 0) + gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type)); + + gnu_field_type + = make_type_from_size (gnu_field_type, gnu_size, + Has_Biased_Representation (gnat_field)); + gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field, + "PAD", false, definition, true); + } + + /* Otherwise (or if there was an error), don't specify a position. */ + else + gnu_pos = NULL_TREE; + + gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE + || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type)); + + /* Now create the decl for the field. */ + gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type, + packed, gnu_size, gnu_pos, + Is_Aliased (gnat_field)); + Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field)); + TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field); + + if (Ekind (gnat_field) == E_Discriminant) + DECL_DISCRIMINANT_NUMBER (gnu_field) + = UI_To_gnu (Discriminant_Number (gnat_field), sizetype); + + return gnu_field; + } + + /* Return true if TYPE is a type with variable size, a padding type with a + field of variable size or is a record that has a field such a field. */ + + static bool + is_variable_size (tree type) + { + tree field; + + if (!TREE_CONSTANT (TYPE_SIZE (type))) + return true; + + if (TREE_CODE (type) == RECORD_TYPE + && TYPE_IS_PADDING_P (type) + && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type)))) + return true; + + if (TREE_CODE (type) != RECORD_TYPE + && TREE_CODE (type) != UNION_TYPE + && TREE_CODE (type) != QUAL_UNION_TYPE) + return false; + + for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) + if (is_variable_size (TREE_TYPE (field))) + return true; + + return false; + } + + /* qsort comparer for the bit positions of two record components. */ + + static int + compare_field_bitpos (const PTR rt1, const PTR rt2) + { + const_tree const field1 = * (const_tree const *) rt1; + const_tree const field2 = * (const_tree const *) rt2; + const int ret + = tree_int_cst_compare (bit_position (field1), bit_position (field2)); + + return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2)); + } + + /* Return a GCC tree for a record type given a GNAT Component_List and a chain + of GCC trees for fields that are in the record and have already been + processed. When called from gnat_to_gnu_entity during the processing of a + record type definition, the GCC nodes for the discriminants will be on + the chain. The other calls to this function are recursive calls from + itself for the Component_List of a variant and the chain is empty. + + PACKED is 1 if this is for a packed record, -1 if this is for a record + with Component_Alignment of Storage_Unit, -2 if this is for a record + with a specified alignment. + + DEFINITION is true if we are defining this record. + + P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field + with a rep clause is to be added. If it is nonzero, that is all that + should be done with such fields. + + CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before + laying out the record. This means the alignment only serves to force fields + to be bitfields, but not require the record to be that aligned. This is + used for variants. + + ALL_REP, if true, means a rep clause was found for all the fields. This + simplifies the logic since we know we're not in the mixed case. + + DO_NOT_FINALIZE, if true, means that the record type is expected to be + modified afterwards so it will not be sent to the back-end for finalization. + + UNCHECKED_UNION, if true, means that we are building a type for a record + with a Pragma Unchecked_Union. + + The processing of the component list fills in the chain with all of the + fields of the record and then the record type is finished. */ + + static void + components_to_record (tree gnu_record_type, Node_Id component_list, + tree gnu_field_list, int packed, bool definition, + tree *p_gnu_rep_list, bool cancel_alignment, + bool all_rep, bool do_not_finalize, bool unchecked_union) + { + Node_Id component_decl; + Entity_Id gnat_field; + Node_Id variant_part; + tree gnu_our_rep_list = NULL_TREE; + tree gnu_field, gnu_last; + bool layout_with_rep = false; + bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type); + + /* For each variable within each component declaration create a GCC field + and add it to the list, skipping any pragmas in the list. */ + if (Present (Component_Items (component_list))) + for (component_decl = First_Non_Pragma (Component_Items (component_list)); + Present (component_decl); + component_decl = Next_Non_Pragma (component_decl)) + { + gnat_field = Defining_Entity (component_decl); + + if (Chars (gnat_field) == Name_uParent) + gnu_field = tree_last (TYPE_FIELDS (gnu_record_type)); + else + { + gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, + packed, definition); + + /* If this is the _Tag field, put it before any discriminants, + instead of after them as is the case for all other fields. */ + if (Chars (gnat_field) == Name_uTag) + gnu_field_list = chainon (gnu_field_list, gnu_field); + else + { + TREE_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + } + } + + save_gnu_tree (gnat_field, gnu_field, false); + } + + /* At the end of the component list there may be a variant part. */ + variant_part = Variant_Part (component_list); + + /* We create a QUAL_UNION_TYPE for the variant part since the variants are + mutually exclusive and should go in the same memory. To do this we need + to treat each variant as a record whose elements are created from the + component list for the variant. So here we create the records from the + lists for the variants and put them all into the QUAL_UNION_TYPE. + If this is an Unchecked_Union, we make a UNION_TYPE instead or + use GNU_RECORD_TYPE if there are no fields so far. */ + if (Present (variant_part)) + { + tree gnu_discriminant = gnat_to_gnu (Name (variant_part)); + Node_Id variant; + tree gnu_name = TYPE_NAME (gnu_record_type); + tree gnu_var_name + = concat_id_with_name (get_identifier (Get_Name_String + (Chars (Name (variant_part)))), + "XVN"); + tree gnu_union_type; + tree gnu_union_name; + tree gnu_union_field; + tree gnu_variant_list = NULL_TREE; + + if (TREE_CODE (gnu_name) == TYPE_DECL) + gnu_name = DECL_NAME (gnu_name); + + gnu_union_name = concat_id_with_name (gnu_name, + IDENTIFIER_POINTER (gnu_var_name)); + + /* Reuse an enclosing union if all fields are in the variant part + and there is no representation clause on the record, to match + the layout of C unions. There is an associated check below. */ + if (!gnu_field_list + && TREE_CODE (gnu_record_type) == UNION_TYPE + && !TYPE_PACKED (gnu_record_type)) + gnu_union_type = gnu_record_type; + else + { + gnu_union_type + = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE); + + TYPE_NAME (gnu_union_type) = gnu_union_name; + TYPE_ALIGN (gnu_union_type) = 0; + TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type); + } + + for (variant = First_Non_Pragma (Variants (variant_part)); + Present (variant); + variant = Next_Non_Pragma (variant)) + { + tree gnu_variant_type = make_node (RECORD_TYPE); + tree gnu_inner_name; + tree gnu_qual; + + Get_Variant_Encoding (variant); + gnu_inner_name = get_identifier (Name_Buffer); + TYPE_NAME (gnu_variant_type) + = concat_id_with_name (gnu_union_name, + IDENTIFIER_POINTER (gnu_inner_name)); + + /* Set the alignment of the inner type in case we need to make + inner objects into bitfields, but then clear it out + so the record actually gets only the alignment required. */ + TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type); + TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type); + + /* Similarly, if the outer record has a size specified and all fields + have record rep clauses, we can propagate the size into the + variant part. */ + if (all_rep_and_size) + { + TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type); + TYPE_SIZE_UNIT (gnu_variant_type) + = TYPE_SIZE_UNIT (gnu_record_type); + } + + /* Create the record type for the variant. Note that we defer + finalizing it until after we are sure to actually use it. */ + components_to_record (gnu_variant_type, Component_List (variant), + NULL_TREE, packed, definition, + &gnu_our_rep_list, !all_rep_and_size, all_rep, + true, unchecked_union); + + gnu_qual = choices_to_gnu (gnu_discriminant, + Discrete_Choices (variant)); + + Set_Present_Expr (variant, annotate_value (gnu_qual)); + + /* If this is an Unchecked_Union and we have exactly one field, + use this field directly to match the layout of C unions. */ + if (unchecked_union + && TYPE_FIELDS (gnu_variant_type) + && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type))) + gnu_field = TYPE_FIELDS (gnu_variant_type); + else + { + /* Deal with packedness like in gnat_to_gnu_field. */ + int field_packed + = adjust_packed (gnu_variant_type, gnu_record_type, packed); + + /* Finalize the record type now. We used to throw away + empty records but we no longer do that because we need + them to generate complete debug info for the variant; + otherwise, the union type definition will be lacking + the fields associated with these empty variants. */ + rest_of_record_type_compilation (gnu_variant_type); + + gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type, + gnu_union_type, field_packed, + (all_rep_and_size + ? TYPE_SIZE (gnu_variant_type) + : 0), + (all_rep_and_size + ? bitsize_zero_node : 0), + 0); + + DECL_INTERNAL_P (gnu_field) = 1; + + if (!unchecked_union) + DECL_QUALIFIER (gnu_field) = gnu_qual; + } + + TREE_CHAIN (gnu_field) = gnu_variant_list; + gnu_variant_list = gnu_field; + } + + /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */ + if (gnu_variant_list) + { + int union_field_packed; + + if (all_rep_and_size) + { + TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type); + TYPE_SIZE_UNIT (gnu_union_type) + = TYPE_SIZE_UNIT (gnu_record_type); + } + + finish_record_type (gnu_union_type, nreverse (gnu_variant_list), + all_rep_and_size ? 1 : 0, false); + + /* If GNU_UNION_TYPE is our record type, it means we must have an + Unchecked_Union with no fields. Verify that and, if so, just + return. */ + if (gnu_union_type == gnu_record_type) + { + gcc_assert (unchecked_union + && !gnu_field_list + && !gnu_our_rep_list); + return; + } + + /* Deal with packedness like in gnat_to_gnu_field. */ + union_field_packed + = adjust_packed (gnu_union_type, gnu_record_type, packed); + + gnu_union_field + = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type, + union_field_packed, + all_rep ? TYPE_SIZE (gnu_union_type) : 0, + all_rep ? bitsize_zero_node : 0, 0); + + DECL_INTERNAL_P (gnu_union_field) = 1; + TREE_CHAIN (gnu_union_field) = gnu_field_list; + gnu_field_list = gnu_union_field; + } + } + + /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they + do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this + in a separate pass since we want to handle the discriminants but can't + play with them until we've used them in debugging data above. + + ??? Note: if we then reorder them, debugging information will be wrong, + but there's nothing that can be done about this at the moment. */ + for (gnu_field = gnu_field_list, gnu_last = NULL_TREE; gnu_field; ) + { + if (DECL_FIELD_OFFSET (gnu_field)) + { + tree gnu_next = TREE_CHAIN (gnu_field); + + if (!gnu_last) + gnu_field_list = gnu_next; + else + TREE_CHAIN (gnu_last) = gnu_next; + + TREE_CHAIN (gnu_field) = gnu_our_rep_list; + gnu_our_rep_list = gnu_field; + gnu_field = gnu_next; + } + else + { + gnu_last = gnu_field; + gnu_field = TREE_CHAIN (gnu_field); + } + } + + /* If we have any items in our rep'ed field list, it is not the case that all + the fields in the record have rep clauses, and P_REP_LIST is nonzero, + set it and ignore the items. */ + if (gnu_our_rep_list && p_gnu_rep_list && !all_rep) + *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list); + else if (gnu_our_rep_list) + { + /* Otherwise, sort the fields by bit position and put them into their + own record if we have any fields without rep clauses. */ + tree gnu_rep_type + = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type); + int len = list_length (gnu_our_rep_list); + tree *gnu_arr = (tree *) alloca (sizeof (tree) * len); + int i; + + for (i = 0, gnu_field = gnu_our_rep_list; gnu_field; + gnu_field = TREE_CHAIN (gnu_field), i++) + gnu_arr[i] = gnu_field; + + qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos); + + /* Put the fields in the list in order of increasing position, which + means we start from the end. */ + gnu_our_rep_list = NULL_TREE; + for (i = len - 1; i >= 0; i--) + { + TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list; + gnu_our_rep_list = gnu_arr[i]; + DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type; + } + + if (gnu_field_list) + { + finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, false); + gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type, + gnu_record_type, 0, 0, 0, 1); + DECL_INTERNAL_P (gnu_field) = 1; + gnu_field_list = chainon (gnu_field_list, gnu_field); + } + else + { + layout_with_rep = true; + gnu_field_list = nreverse (gnu_our_rep_list); + } + } + + if (cancel_alignment) + TYPE_ALIGN (gnu_record_type) = 0; + + finish_record_type (gnu_record_type, nreverse (gnu_field_list), + layout_with_rep ? 1 : 0, do_not_finalize); + } + + /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be + placed into an Esize, Component_Bit_Offset, or Component_Size value + in the GNAT tree. */ + + static Uint + annotate_value (tree gnu_size) + { + int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size)); + TCode tcode; + Node_Ref_Or_Val ops[3], ret; + int i; + int size; + struct tree_int_map **h = NULL; + + /* See if we've already saved the value for this node. */ + if (EXPR_P (gnu_size)) + { + struct tree_int_map in; + if (!annotate_value_cache) + annotate_value_cache = htab_create_ggc (512, tree_int_map_hash, + tree_int_map_eq, 0); + in.base.from = gnu_size; + h = (struct tree_int_map **) + htab_find_slot (annotate_value_cache, &in, INSERT); + + if (*h) + return (Node_Ref_Or_Val) (*h)->to; + } + + /* If we do not return inside this switch, TCODE will be set to the + code to use for a Create_Node operand and LEN (set above) will be + the number of recursive calls for us to make. */ + + switch (TREE_CODE (gnu_size)) + { + case INTEGER_CST: + if (TREE_OVERFLOW (gnu_size)) + return No_Uint; + + /* This may have come from a conversion from some smaller type, + so ensure this is in bitsizetype. */ + gnu_size = convert (bitsizetype, gnu_size); + + /* For negative values, use NEGATE_EXPR of the supplied value. */ + if (tree_int_cst_sgn (gnu_size) < 0) + { + /* The ridiculous code below is to handle the case of the largest + negative integer. */ + tree negative_size = size_diffop (bitsize_zero_node, gnu_size); + bool adjust = false; + tree temp; + + if (TREE_OVERFLOW (negative_size)) + { + negative_size + = size_binop (MINUS_EXPR, bitsize_zero_node, + size_binop (PLUS_EXPR, gnu_size, + bitsize_one_node)); + adjust = true; + } + + temp = build1 (NEGATE_EXPR, bitsizetype, negative_size); + if (adjust) + temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node); + + return annotate_value (temp); + } + + if (!host_integerp (gnu_size, 1)) + return No_Uint; + + size = tree_low_cst (gnu_size, 1); + + /* This peculiar test is to make sure that the size fits in an int + on machines where HOST_WIDE_INT is not "int". */ + if (tree_low_cst (gnu_size, 1) == size) + return UI_From_Int (size); + else + return No_Uint; + + case COMPONENT_REF: + /* The only case we handle here is a simple discriminant reference. */ + if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR + && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL + && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1))) + return Create_Node (Discrim_Val, + annotate_value (DECL_DISCRIMINANT_NUMBER + (TREE_OPERAND (gnu_size, 1))), + No_Uint, No_Uint); + else + return No_Uint; + + CASE_CONVERT: case NON_LVALUE_EXPR: + return annotate_value (TREE_OPERAND (gnu_size, 0)); + + /* Now just list the operations we handle. */ + case COND_EXPR: tcode = Cond_Expr; break; + case PLUS_EXPR: tcode = Plus_Expr; break; + case MINUS_EXPR: tcode = Minus_Expr; break; + case MULT_EXPR: tcode = Mult_Expr; break; + case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break; + case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break; + case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break; + case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break; + case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break; + case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break; + case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break; + case NEGATE_EXPR: tcode = Negate_Expr; break; + case MIN_EXPR: tcode = Min_Expr; break; + case MAX_EXPR: tcode = Max_Expr; break; + case ABS_EXPR: tcode = Abs_Expr; break; + case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break; + case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break; + case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break; + case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break; + case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break; + case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break; + case BIT_AND_EXPR: tcode = Bit_And_Expr; break; + case LT_EXPR: tcode = Lt_Expr; break; + case LE_EXPR: tcode = Le_Expr; break; + case GT_EXPR: tcode = Gt_Expr; break; + case GE_EXPR: tcode = Ge_Expr; break; + case EQ_EXPR: tcode = Eq_Expr; break; + case NE_EXPR: tcode = Ne_Expr; break; + + default: + return No_Uint; + } + + /* Now get each of the operands that's relevant for this code. If any + cannot be expressed as a repinfo node, say we can't. */ + for (i = 0; i < 3; i++) + ops[i] = No_Uint; + + for (i = 0; i < len; i++) + { + ops[i] = annotate_value (TREE_OPERAND (gnu_size, i)); + if (ops[i] == No_Uint) + return No_Uint; + } + + ret = Create_Node (tcode, ops[0], ops[1], ops[2]); + + /* Save the result in the cache. */ + if (h) + { + *h = GGC_NEW (struct tree_int_map); + (*h)->base.from = gnu_size; + (*h)->to = ret; + } + + return ret; + } + + /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding + GCC type, set Component_Bit_Offset and Esize to the position and size + used by Gigi. */ + + static void + annotate_rep (Entity_Id gnat_entity, tree gnu_type) + { + tree gnu_list; + tree gnu_entry; + Entity_Id gnat_field; + + /* We operate by first making a list of all fields and their positions + (we can get the sizes easily at any time) by a recursive call + and then update all the sizes into the tree. */ + gnu_list = compute_field_positions (gnu_type, NULL_TREE, + size_zero_node, bitsize_zero_node, + BIGGEST_ALIGNMENT); + + for (gnat_field = First_Entity (gnat_entity); Present (gnat_field); + gnat_field = Next_Entity (gnat_field)) + if ((Ekind (gnat_field) == E_Component + || (Ekind (gnat_field) == E_Discriminant + && !Is_Unchecked_Union (Scope (gnat_field))))) + { + tree parent_offset = bitsize_zero_node; + + gnu_entry = purpose_member (gnat_to_gnu_field_decl (gnat_field), + gnu_list); + + if (gnu_entry) + { + if (type_annotate_only && Is_Tagged_Type (gnat_entity)) + { + /* In this mode the tag and parent components have not been + generated, so we add the appropriate offset to each + component. For a component appearing in the current + extension, the offset is the size of the parent. */ + if (Is_Derived_Type (gnat_entity) + && Original_Record_Component (gnat_field) == gnat_field) + parent_offset + = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))), + bitsizetype); + else + parent_offset = bitsize_int (POINTER_SIZE); + } + + Set_Component_Bit_Offset + (gnat_field, + annotate_value + (size_binop (PLUS_EXPR, + bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)), + TREE_VALUE (TREE_VALUE + (TREE_VALUE (gnu_entry)))), + parent_offset))); + + Set_Esize (gnat_field, + annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry)))); + } + else if (Is_Tagged_Type (gnat_entity) + && Is_Derived_Type (gnat_entity)) + { + /* If there is no gnu_entry, this is an inherited component whose + position is the same as in the parent type. */ + Set_Component_Bit_Offset + (gnat_field, + Component_Bit_Offset (Original_Record_Component (gnat_field))); + Set_Esize (gnat_field, + Esize (Original_Record_Component (gnat_field))); + } + } + } + + /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the + FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte + position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be + placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is + to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is + the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries + so far. */ + + static tree + compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos, + tree gnu_bitpos, unsigned int offset_align) + { + tree gnu_field; + tree gnu_result = gnu_list; + + for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field; + gnu_field = TREE_CHAIN (gnu_field)) + { + tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos, + DECL_FIELD_BIT_OFFSET (gnu_field)); + tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos, + DECL_FIELD_OFFSET (gnu_field)); + unsigned int our_offset_align + = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field)); + + gnu_result + = tree_cons (gnu_field, + tree_cons (gnu_our_offset, + tree_cons (size_int (our_offset_align), + gnu_our_bitpos, NULL_TREE), + NULL_TREE), + gnu_result); + + if (DECL_INTERNAL_P (gnu_field)) + gnu_result + = compute_field_positions (TREE_TYPE (gnu_field), gnu_result, + gnu_our_offset, gnu_our_bitpos, + our_offset_align); + } + + return gnu_result; + } + + /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE + corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding + to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying + the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL + for the size of a field. COMPONENT_P is true if we are being called + to process the Component_Size of GNAT_OBJECT. This is used for error + message handling and to indicate to use the object size of GNU_TYPE. + ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false, + it means that a size of zero should be treated as an unspecified size. */ + + static tree + validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object, + enum tree_code kind, bool component_p, bool zero_ok) + { + Node_Id gnat_error_node; + tree type_size, size; + + if (kind == VAR_DECL + /* If a type needs strict alignment, a component of this type in + a packed record cannot be packed and thus uses the type size. */ + || (kind == TYPE_DECL && Strict_Alignment (gnat_object))) + type_size = TYPE_SIZE (gnu_type); + else + type_size = rm_size (gnu_type); + + /* Find the node to use for errors. */ + if ((Ekind (gnat_object) == E_Component + || Ekind (gnat_object) == E_Discriminant) + && Present (Component_Clause (gnat_object))) + gnat_error_node = Last_Bit (Component_Clause (gnat_object)); + else if (Present (Size_Clause (gnat_object))) + gnat_error_node = Expression (Size_Clause (gnat_object)); + else + gnat_error_node = gnat_object; + + /* Return 0 if no size was specified, either because Esize was not Present or + the specified size was zero. */ + if (No (uint_size) || uint_size == No_Uint) + return NULL_TREE; + + /* Get the size as a tree. Give an error if a size was specified, but cannot + be represented as in sizetype. */ + size = UI_To_gnu (uint_size, bitsizetype); + if (TREE_OVERFLOW (size)) + { + post_error_ne (component_p ? "component size of & is too large" + : "size of & is too large", + gnat_error_node, gnat_object); + return NULL_TREE; + } + + /* Ignore a negative size since that corresponds to our back-annotation. + Also ignore a zero size unless a size clause exists. */ + else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok)) + return NULL_TREE; + + /* The size of objects is always a multiple of a byte. */ + if (kind == VAR_DECL + && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node))) + { + if (component_p) + post_error_ne ("component size for& is not a multiple of Storage_Unit", + gnat_error_node, gnat_object); + else + post_error_ne ("size for& is not a multiple of Storage_Unit", + gnat_error_node, gnat_object); + return NULL_TREE; + } + + /* If this is an integral type or a packed array type, the front-end has + verified the size, so we need not do it here (which would entail + checking against the bounds). However, if this is an aliased object, it + may not be smaller than the type of the object. */ + if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type)) + && !(kind == VAR_DECL && Is_Aliased (gnat_object))) + return size; + + /* If the object is a record that contains a template, add the size of + the template to the specified size. */ + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) + size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size); + + /* Modify the size of the type to be that of the maximum size if it has a + discriminant. */ + if (type_size && CONTAINS_PLACEHOLDER_P (type_size)) + type_size = max_size (type_size, true); + + /* If this is an access type or a fat pointer, the minimum size is that given + by the smallest integral mode that's valid for pointers. */ + if ((TREE_CODE (gnu_type) == POINTER_TYPE) || TYPE_FAT_POINTER_P (gnu_type)) + { + enum machine_mode p_mode; + + for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT); + !targetm.valid_pointer_mode (p_mode); + p_mode = GET_MODE_WIDER_MODE (p_mode)) + ; + + type_size = bitsize_int (GET_MODE_BITSIZE (p_mode)); + } + + /* If the size of the object is a constant, the new size must not be + smaller. */ + if (TREE_CODE (type_size) != INTEGER_CST + || TREE_OVERFLOW (type_size) + || tree_int_cst_lt (size, type_size)) + { + if (component_p) + post_error_ne_tree + ("component size for& too small{, minimum allowed is ^}", + gnat_error_node, gnat_object, type_size); + else + post_error_ne_tree ("size for& too small{, minimum allowed is ^}", + gnat_error_node, gnat_object, type_size); + + if (kind == VAR_DECL && !component_p + && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST + && !tree_int_cst_lt (size, rm_size (gnu_type))) + post_error_ne_tree_2 + ("\\size of ^ is not a multiple of alignment (^ bits)", + gnat_error_node, gnat_object, rm_size (gnu_type), + TYPE_ALIGN (gnu_type)); + + else if (INTEGRAL_TYPE_P (gnu_type)) + post_error_ne ("\\size would be legal if & were not aliased!", + gnat_error_node, gnat_object); + + return NULL_TREE; + } + + return size; + } + + /* Similarly, but both validate and process a value of RM_Size. This + routine is only called for types. */ + + static void + set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity) + { + /* Only give an error if a Value_Size clause was explicitly given. + Otherwise, we'd be duplicating an error on the Size clause. */ + Node_Id gnat_attr_node + = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size); + tree old_size = rm_size (gnu_type); + tree size; + + /* Get the size as a tree. Do nothing if none was specified, either + because RM_Size was not Present or if the specified size was zero. + Give an error if a size was specified, but cannot be represented as + in sizetype. */ + if (No (uint_size) || uint_size == No_Uint) + return; + + size = UI_To_gnu (uint_size, bitsizetype); + if (TREE_OVERFLOW (size)) + { + if (Present (gnat_attr_node)) + post_error_ne ("Value_Size of & is too large", gnat_attr_node, + gnat_entity); + + return; + } + + /* Ignore a negative size since that corresponds to our back-annotation. + Also ignore a zero size unless a size clause exists, a Value_Size + clause exists, or this is an integer type, in which case the + front end will have always set it. */ + else if (tree_int_cst_sgn (size) < 0 + || (integer_zerop (size) && No (gnat_attr_node) + && !Has_Size_Clause (gnat_entity) + && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity))) + return; + + /* If the old size is self-referential, get the maximum size. */ + if (CONTAINS_PLACEHOLDER_P (old_size)) + old_size = max_size (old_size, true); + + /* If the size of the object is a constant, the new size must not be + smaller (the front end checks this for scalar types). */ + if (TREE_CODE (old_size) != INTEGER_CST + || TREE_OVERFLOW (old_size) + || (AGGREGATE_TYPE_P (gnu_type) + && tree_int_cst_lt (size, old_size))) + { + if (Present (gnat_attr_node)) + post_error_ne_tree + ("Value_Size for& too small{, minimum allowed is ^}", + gnat_attr_node, gnat_entity, old_size); + + return; + } + + /* Otherwise, set the RM_Size. */ + if (TREE_CODE (gnu_type) == INTEGER_TYPE + && Is_Discrete_Or_Fixed_Point_Type (gnat_entity)) + TYPE_RM_SIZE_NUM (gnu_type) = size; + else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE + || TREE_CODE (gnu_type) == BOOLEAN_TYPE) + TYPE_RM_SIZE_NUM (gnu_type) = size; + else if ((TREE_CODE (gnu_type) == RECORD_TYPE + || TREE_CODE (gnu_type) == UNION_TYPE + || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) + && !TYPE_IS_FAT_POINTER_P (gnu_type)) + SET_TYPE_ADA_SIZE (gnu_type, size); + } + + /* Given a type TYPE, return a new type whose size is appropriate for SIZE. + If TYPE is the best type, return it. Otherwise, make a new type. We + only support new integral and pointer types. FOR_BIASED is nonzero if + we are making a biased type. */ + + static tree + make_type_from_size (tree type, tree size_tree, bool for_biased) + { + unsigned HOST_WIDE_INT size; + bool biased_p; + tree new_type; + + /* If size indicates an error, just return TYPE to avoid propagating + the error. Likewise if it's too large to represent. */ + if (!size_tree || !host_integerp (size_tree, 1)) + return type; + + size = tree_low_cst (size_tree, 1); + + switch (TREE_CODE (type)) + { + case INTEGER_TYPE: + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + biased_p = (TREE_CODE (type) == INTEGER_TYPE + && TYPE_BIASED_REPRESENTATION_P (type)); + + /* Only do something if the type is not a packed array type and + doesn't already have the proper size. */ + if (TYPE_PACKED_ARRAY_TYPE_P (type) + || (TYPE_PRECISION (type) == size && biased_p == for_biased)) + break; + + biased_p |= for_biased; + size = MIN (size, LONG_LONG_TYPE_SIZE); + + if (TYPE_UNSIGNED (type) || biased_p) + new_type = make_unsigned_type (size); + else + new_type = make_signed_type (size); + TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type; + TYPE_MIN_VALUE (new_type) + = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type)); + TYPE_MAX_VALUE (new_type) + = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type)); + /* Propagate the name to avoid creating a fake subrange type. */ + if (TYPE_NAME (type)) + { + if (TREE_CODE (TYPE_NAME (type)) == TYPE_DECL) + TYPE_NAME (new_type) = DECL_NAME (TYPE_NAME (type)); + else + TYPE_NAME (new_type) = TYPE_NAME (type); + } + TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p; + TYPE_RM_SIZE_NUM (new_type) = bitsize_int (size); + return new_type; + + case RECORD_TYPE: + /* Do something if this is a fat pointer, in which case we + may need to return the thin pointer. */ + if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2) + { + enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0); + if (!targetm.valid_pointer_mode (p_mode)) + p_mode = ptr_mode; + return + build_pointer_type_for_mode + (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)), + p_mode, 0); + } + break; + + case POINTER_TYPE: + /* Only do something if this is a thin pointer, in which case we + may need to return the fat pointer. */ + if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2) + return + build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))); + break; + + default: + break; + } + + return type; + } + + /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY, + a type or object whose present alignment is ALIGN. If this alignment is + valid, return it. Otherwise, give an error and return ALIGN. */ + + static unsigned int + validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align) + { + unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment (); + unsigned int new_align; + Node_Id gnat_error_node; + + /* Don't worry about checking alignment if alignment was not specified + by the source program and we already posted an error for this entity. */ + if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity)) + return align; + + /* Post the error on the alignment clause if any. */ + if (Present (Alignment_Clause (gnat_entity))) + gnat_error_node = Expression (Alignment_Clause (gnat_entity)); + else + gnat_error_node = gnat_entity; + + /* Within GCC, an alignment is an integer, so we must make sure a value is + specified that fits in that range. Also, there is an upper bound to + alignments we can support/allow. */ + if (!UI_Is_In_Int_Range (alignment) + || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment)) + post_error_ne_num ("largest supported alignment for& is ^", + gnat_error_node, gnat_entity, max_allowed_alignment); + else if (!(Present (Alignment_Clause (gnat_entity)) + && From_At_Mod (Alignment_Clause (gnat_entity))) + && new_align * BITS_PER_UNIT < align) + post_error_ne_num ("alignment for& must be at least ^", + gnat_error_node, gnat_entity, + align / BITS_PER_UNIT); + else + { + new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1); + if (new_align > align) + align = new_align; + } + + return align; + } + + /* Return the smallest alignment not less than SIZE. */ + + static unsigned int + ceil_alignment (unsigned HOST_WIDE_INT size) + { + return (unsigned int) 1 << (floor_log2 (size - 1) + 1); + } + + /* Verify that OBJECT, a type or decl, is something we can implement + atomically. If not, give an error for GNAT_ENTITY. COMP_P is true + if we require atomic components. */ + + static void + check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p) + { + Node_Id gnat_error_point = gnat_entity; + Node_Id gnat_node; + enum machine_mode mode; + unsigned int align; + tree size; + + /* There are three case of what OBJECT can be. It can be a type, in which + case we take the size, alignment and mode from the type. It can be a + declaration that was indirect, in which case the relevant values are + that of the type being pointed to, or it can be a normal declaration, + in which case the values are of the decl. The code below assumes that + OBJECT is either a type or a decl. */ + if (TYPE_P (object)) + { + mode = TYPE_MODE (object); + align = TYPE_ALIGN (object); + size = TYPE_SIZE (object); + } + else if (DECL_BY_REF_P (object)) + { + mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object))); + align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object))); + size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object))); + } + else + { + mode = DECL_MODE (object); + align = DECL_ALIGN (object); + size = DECL_SIZE (object); + } + + /* Consider all floating-point types atomic and any types that that are + represented by integers no wider than a machine word. */ + if (GET_MODE_CLASS (mode) == MODE_FLOAT + || ((GET_MODE_CLASS (mode) == MODE_INT + || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT) + && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD)) + return; + + /* For the moment, also allow anything that has an alignment equal + to its size and which is smaller than a word. */ + if (size && TREE_CODE (size) == INTEGER_CST + && compare_tree_int (size, align) == 0 + && align <= BITS_PER_WORD) + return; + + for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node); + gnat_node = Next_Rep_Item (gnat_node)) + { + if (!comp_p && Nkind (gnat_node) == N_Pragma + && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))) + == Pragma_Atomic)) + gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); + else if (comp_p && Nkind (gnat_node) == N_Pragma + && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))) + == Pragma_Atomic_Components)) + gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); + } + + if (comp_p) + post_error_ne ("atomic access to component of & cannot be guaranteed", + gnat_error_point, gnat_entity); + else + post_error_ne ("atomic access to & cannot be guaranteed", + gnat_error_point, gnat_entity); + } + + /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes, + have compatible signatures so that a call using one type may be safely + issued if the actual target function type is the other. Return 1 if it is + the case, 0 otherwise, and post errors on the incompatibilities. + + This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure + that calls to the subprogram will have arguments suitable for the later + underlying builtin expansion. */ + + static int + compatible_signatures_p (tree ftype1, tree ftype2) + { + /* As of now, we only perform very trivial tests and consider it's the + programmer's responsibility to ensure the type correctness in the Ada + declaration, as in the regular Import cases. + + Mismatches typically result in either error messages from the builtin + expander, internal compiler errors, or in a real call sequence. This + should be refined to issue diagnostics helping error detection and + correction. */ + + /* Almost fake test, ensuring a use of each argument. */ + if (ftype1 == ftype2) + return 1; + + return 1; + } + + /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new + type with all size expressions that contain F updated by replacing F + with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if + nothing has changed. */ + + tree + substitute_in_type (tree t, tree f, tree r) + { + tree new = t; + tree tem; + + switch (TREE_CODE (t)) + { + case INTEGER_TYPE: + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t)) + || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t))) + { + tree low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r); + tree high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r); + + if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t)) + return t; + + new = build_range_type (TREE_TYPE (t), low, high); + if (TYPE_INDEX_TYPE (t)) + SET_TYPE_INDEX_TYPE + (new, substitute_in_type (TYPE_INDEX_TYPE (t), f, r)); + return new; + } + + return t; + + case REAL_TYPE: + if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t)) + || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t))) + { + tree low = NULL_TREE, high = NULL_TREE; + + if (TYPE_MIN_VALUE (t)) + low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r); + if (TYPE_MAX_VALUE (t)) + high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r); + + if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t)) + return t; + + t = copy_type (t); + TYPE_MIN_VALUE (t) = low; + TYPE_MAX_VALUE (t) = high; + } + return t; + + case COMPLEX_TYPE: + tem = substitute_in_type (TREE_TYPE (t), f, r); + if (tem == TREE_TYPE (t)) + return t; + + return build_complex_type (tem); + + case OFFSET_TYPE: + case METHOD_TYPE: + case FUNCTION_TYPE: + case LANG_TYPE: + /* Don't know how to do these yet. */ + gcc_unreachable (); + + case ARRAY_TYPE: + { + tree component = substitute_in_type (TREE_TYPE (t), f, r); + tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r); + + if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t)) + return t; + + new = build_array_type (component, domain); + TYPE_SIZE (new) = 0; + TYPE_NONALIASED_COMPONENT (new) = TYPE_NONALIASED_COMPONENT (t); + TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t); + TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t); + layout_type (new); + TYPE_ALIGN (new) = TYPE_ALIGN (t); + TYPE_USER_ALIGN (new) = TYPE_USER_ALIGN (t); + + /* If we had bounded the sizes of T by a constant, bound the sizes of + NEW by the same constant. */ + if (TREE_CODE (TYPE_SIZE (t)) == MIN_EXPR) + TYPE_SIZE (new) + = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE (t), 1), + TYPE_SIZE (new)); + if (TREE_CODE (TYPE_SIZE_UNIT (t)) == MIN_EXPR) + TYPE_SIZE_UNIT (new) + = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE_UNIT (t), 1), + TYPE_SIZE_UNIT (new)); + return new; + } + + case RECORD_TYPE: + case UNION_TYPE: + case QUAL_UNION_TYPE: + { + tree field; + bool changed_field + = (f == NULL_TREE && !TREE_CONSTANT (TYPE_SIZE (t))); + bool field_has_rep = false; + tree last_field = NULL_TREE; + + tree new = copy_type (t); + + /* Start out with no fields, make new fields, and chain them + in. If we haven't actually changed the type of any field, + discard everything we've done and return the old type. */ + + TYPE_FIELDS (new) = NULL_TREE; + TYPE_SIZE (new) = NULL_TREE; + + for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field)) + { + tree new_field = copy_node (field); + + TREE_TYPE (new_field) + = substitute_in_type (TREE_TYPE (new_field), f, r); + + if (DECL_HAS_REP_P (field) && !DECL_INTERNAL_P (field)) + field_has_rep = true; + else if (TREE_TYPE (new_field) != TREE_TYPE (field)) + changed_field = true; + + /* If this is an internal field and the type of this field is + a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If + the type just has one element, treat that as the field. + But don't do this if we are processing a QUAL_UNION_TYPE. */ + if (TREE_CODE (t) != QUAL_UNION_TYPE + && DECL_INTERNAL_P (new_field) + && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE + || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE)) + { + if (!TYPE_FIELDS (TREE_TYPE (new_field))) + continue; + + if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field)))) + { + tree next_new_field + = copy_node (TYPE_FIELDS (TREE_TYPE (new_field))); + + /* Make sure omitting the union doesn't change + the layout. */ + DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field); + new_field = next_new_field; + } + } + + DECL_CONTEXT (new_field) = new; + SET_DECL_ORIGINAL_FIELD (new_field, + (DECL_ORIGINAL_FIELD (field) + ? DECL_ORIGINAL_FIELD (field) : field)); + + /* If the size of the old field was set at a constant, + propagate the size in case the type's size was variable. + (This occurs in the case of a variant or discriminated + record with a default size used as a field of another + record.) */ + DECL_SIZE (new_field) + = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST + ? DECL_SIZE (field) : NULL_TREE; + DECL_SIZE_UNIT (new_field) + = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST + ? DECL_SIZE_UNIT (field) : NULL_TREE; + + if (TREE_CODE (t) == QUAL_UNION_TYPE) + { + tree new_q = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r); + + if (new_q != DECL_QUALIFIER (new_field)) + changed_field = true; + + /* Do the substitution inside the qualifier and if we find + that this field will not be present, omit it. */ + DECL_QUALIFIER (new_field) = new_q; + + if (integer_zerop (DECL_QUALIFIER (new_field))) + continue; + } + + if (!last_field) + TYPE_FIELDS (new) = new_field; + else + TREE_CHAIN (last_field) = new_field; + + last_field = new_field; + + /* If this is a qualified type and this field will always be + present, we are done. */ + if (TREE_CODE (t) == QUAL_UNION_TYPE + && integer_onep (DECL_QUALIFIER (new_field))) + break; + } + + /* If this used to be a qualified union type, but we now know what + field will be present, make this a normal union. */ + if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE + && (!TYPE_FIELDS (new) + || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new))))) + TREE_SET_CODE (new, UNION_TYPE); + else if (!changed_field) + return t; + + gcc_assert (!field_has_rep); + layout_type (new); + + /* If the size was originally a constant use it. */ + if (TYPE_SIZE (t) && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST + && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST) + { + TYPE_SIZE (new) = TYPE_SIZE (t); + TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t); + SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t)); + } + + return new; + } + + default: + return t; + } + } + + /* Return the "RM size" of GNU_TYPE. This is the actual number of bits + needed to represent the object. */ + + tree + rm_size (tree gnu_type) + { + /* For integer types, this is the precision. For record types, we store + the size explicitly. For other types, this is just the size. */ + + if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type)) + return TYPE_RM_SIZE (gnu_type); + else if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) + /* Return the rm_size of the actual data plus the size of the template. */ + return + size_binop (PLUS_EXPR, + rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))), + DECL_SIZE (TYPE_FIELDS (gnu_type))); + else if ((TREE_CODE (gnu_type) == RECORD_TYPE + || TREE_CODE (gnu_type) == UNION_TYPE + || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) + && !TYPE_IS_FAT_POINTER_P (gnu_type) + && TYPE_ADA_SIZE (gnu_type)) + return TYPE_ADA_SIZE (gnu_type); + else + return TYPE_SIZE (gnu_type); + } + + /* Return an identifier representing the external name to be used for + GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___" + and the specified suffix. */ + + tree + create_concat_name (Entity_Id gnat_entity, const char *suffix) + { + Entity_Kind kind = Ekind (gnat_entity); + + const char *str = (!suffix ? "" : suffix); + String_Template temp = {1, strlen (str)}; + Fat_Pointer fp = {str, &temp}; + + Get_External_Name_With_Suffix (gnat_entity, fp); + + /* A variable using the Stdcall convention (meaning we are running + on a Windows box) live in a DLL. Here we adjust its name to use + the jump-table, the _imp__NAME contains the address for the NAME + variable. */ + if ((kind == E_Variable || kind == E_Constant) + && Has_Stdcall_Convention (gnat_entity)) + { + const char *prefix = "_imp__"; + int k, plen = strlen (prefix); + + for (k = 0; k <= Name_Len; k++) + Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k]; + strncpy (Name_Buffer, prefix, plen); + } + + return get_identifier (Name_Buffer); + } + + /* Return the name to be used for GNAT_ENTITY. If a type, create a + fully-qualified name, possibly with type information encoding. + Otherwise, return the name. */ + + tree + get_entity_name (Entity_Id gnat_entity) + { + Get_Encoded_Name (gnat_entity); + return get_identifier (Name_Buffer); + } + + /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a + string, return a new IDENTIFIER_NODE that is the concatenation of + the name in GNU_ID and SUFFIX. */ + + tree + concat_id_with_name (tree gnu_id, const char *suffix) + { + int len = IDENTIFIER_LENGTH (gnu_id); + + strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id), len); + strncpy (Name_Buffer + len, "___", 3); + len += 3; + strcpy (Name_Buffer + len, suffix); + return get_identifier (Name_Buffer); + } + + #include "gt-ada-decl.h" diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/gigi.h gcc-4.4.0/gcc/ada/gcc-interface/gigi.h *** gcc-4.3.3/gcc/ada/gcc-interface/gigi.h Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/gigi.h Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,922 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * G I G I * + * * + * C Header File * + * * + * Copyright (C) 1992-2009, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + /* Declare all functions and types used by gigi. */ + + /* The largest alignment, in bits, that is needed for using the widest + move instruction. */ + extern unsigned int largest_move_alignment; + + /* Compute the alignment of the largest mode that can be used for copying + objects. */ + extern void gnat_compute_largest_alignment (void); + + /* GNU_TYPE is a type. Determine if it should be passed by reference by + default. */ + extern bool default_pass_by_ref (tree gnu_type); + + /* GNU_TYPE is the type of a subprogram parameter. Determine from the type + if it should be passed by reference. */ + extern bool must_pass_by_ref (tree gnu_type); + + /* Initialize DUMMY_NODE_TABLE. */ + extern void init_dummy_type (void); + + /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a + GCC type corresponding to that entity. GNAT_ENTITY is assumed to + refer to an Ada type. */ + extern tree gnat_to_gnu_type (Entity_Id gnat_entity); + + /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada + entity, this routine returns the equivalent GCC tree for that entity + (an ..._DECL node) and associates the ..._DECL node with the input GNAT + defining identifier. + + If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its + initial value (in GCC tree form). This is optional for variables. + For renamed entities, GNU_EXPR gives the object being renamed. + + DEFINITION is nonzero if this call is intended for a definition. This is + used for separate compilation where it necessary to know whether an + external declaration or a definition should be created if the GCC equivalent + was not created previously. The value of 1 is normally used for a nonzero + DEFINITION, but a value of 2 is used in special circumstances, defined in + the code. */ + extern tree gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, + int definition); + + /* Similar, but if the returned value is a COMPONENT_REF, return the + FIELD_DECL. */ + extern tree gnat_to_gnu_field_decl (Entity_Id gnat_entity); + + /* Wrap up compilation of T, a TYPE_DECL, possibly deferring it. */ + extern void rest_of_type_decl_compilation (tree t); + + /* Start a new statement group chained to the previous group. */ + extern void start_stmt_group (void); + + /* Add GNU_STMT to the current BLOCK_STMT node. */ + extern void add_stmt (tree gnu_stmt); + + /* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */ + extern void add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node); + + /* Return code corresponding to the current code group. It is normally + a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if + BLOCK or cleanups were set. */ + extern tree end_stmt_group (void); + + /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */ + extern void set_block_for_group (tree); + + /* Add a declaration statement for GNU_DECL to the current BLOCK_STMT node. + Get SLOC from GNAT_ENTITY. */ + extern void add_decl_expr (tree gnu_decl, Entity_Id gnat_entity); + + /* Mark nodes rooted at *TP with TREE_VISITED and types as having their + sized gimplified. We use this to indicate all variable sizes and + positions in global types may not be shared by any subprogram. */ + extern void mark_visited (tree *); + + /* Finalize any From_With_Type incomplete types. We do this after processing + our compilation unit and after processing its spec, if this is a body. */ + extern void finalize_from_with_types (void); + + /* Return the equivalent type to be used for GNAT_ENTITY, if it's a + kind of type (such E_Task_Type) that has a different type which Gigi + uses for its representation. If the type does not have a special type + for its representation, return GNAT_ENTITY. If a type is supposed to + exist, but does not, abort unless annotating types, in which case + return Empty. If GNAT_ENTITY is Empty, return Empty. */ + extern Entity_Id Gigi_Equivalent_Type (Entity_Id); + + /* Given GNAT_ENTITY, elaborate all expressions that are required to + be elaborated at the point of its definition, but do nothing else. */ + extern void elaborate_entity (Entity_Id gnat_entity); + + /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark + any entities on its entity chain similarly. */ + extern void mark_out_of_scope (Entity_Id gnat_entity); + + /* Make a dummy type corresponding to GNAT_TYPE. */ + extern tree make_dummy_type (Entity_Id gnat_type); + + /* Get the unpadded version of a GNAT type. */ + extern tree get_unpadded_type (Entity_Id gnat_entity); + + /* Called when we need to protect a variable object using a save_expr. */ + extern tree maybe_variable (tree gnu_operand); + + /* Create a record type that contains a SIZE bytes long field of TYPE with a + starting bit position so that it is aligned to ALIGN bits, and leaving at + least ROOM bytes free before the field. BASE_ALIGN is the alignment the + record is guaranteed to get. */ + extern tree make_aligning_type (tree type, unsigned int align, tree size, + unsigned int base_align, int room); + + /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type + if needed. We have already verified that SIZE and TYPE are large enough. + + GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and + to issue a warning. + + IS_USER_TYPE is true if we must be sure we complete the original type. + + DEFINITION is true if this type is being defined. + + SAME_RM_SIZE is true if the RM_Size of the resulting type is to be + set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original + type. */ + extern tree maybe_pad_type (tree type, tree size, unsigned int align, + Entity_Id gnat_entity, const char *name_trailer, + bool is_user_type, bool definition, + bool same_rm_size); + + /* Given a GNU tree and a GNAT list of choices, generate an expression to test + the value passed against the list of choices. */ + extern tree choices_to_gnu (tree operand, Node_Id choices); + + /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new + type with all size expressions that contain F updated by replacing F + with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if + nothing has changed. */ + extern tree substitute_in_type (tree t, tree f, tree r); + + /* Return the "RM size" of GNU_TYPE. This is the actual number of bits + needed to represent the object. */ + extern tree rm_size (tree gnu_type); + + /* Given GNU_ID, an IDENTIFIER_NODE containing a name, and SUFFIX, a + string, return a new IDENTIFIER_NODE that is the concatenation of + the name in GNU_ID and SUFFIX. */ + extern tree concat_id_with_name (tree gnu_id, const char *suffix); + + /* Return the name to be used for GNAT_ENTITY. If a type, create a + fully-qualified name, possibly with type information encoding. + Otherwise, return the name. */ + extern tree get_entity_name (Entity_Id gnat_entity); + + /* Return a name for GNAT_ENTITY concatenated with two underscores and + SUFFIX. */ + extern tree create_concat_name (Entity_Id gnat_entity, const char *suffix); + + /* If true, then gigi is being called on an analyzed but unexpanded tree, and + the only purpose of the call is to properly annotate types with + representation information. */ + extern bool type_annotate_only; + + /* Current file name without path */ + extern const char *ref_filename; + + /* This structure must be kept synchronized with Call_Back_End. */ + struct File_Info_Type + { + File_Name_Type File_Name; + Nat Num_Source_Lines; + }; + + /* This is the main program of the back-end. It sets up all the table + structures and then generates code. + + ??? Needs parameter descriptions */ + + extern void gigi (Node_Id gnat_root, int max_gnat_node, int number_name, + struct Node *nodes_ptr, Node_Id *next_node_ptr, + Node_Id *prev_node_ptr, struct Elist_Header *elists_ptr, + struct Elmt_Item *elmts_ptr, + struct String_Entry *strings_ptr, + Char_Code *strings_chars_ptr, + struct List_Header *list_headers_ptr, + Nat number_file, + struct File_Info_Type *file_info_ptr, + Entity_Id standard_boolean, + Entity_Id standard_integer, + Entity_Id standard_long_long_float, + Entity_Id standard_exception_type, + Int gigi_operating_mode); + + /* GNAT_NODE is the root of some GNAT tree. Return the root of the + GCC tree corresponding to that GNAT tree. Normally, no code is generated; + we just return an equivalent tree which is used elsewhere to generate + code. */ + extern tree gnat_to_gnu (Node_Id gnat_node); + + /* GNU_STMT is a statement. We generate code for that statement. */ + extern void gnat_expand_stmt (tree gnu_stmt); + + /* ??? missing documentation */ + extern int gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, + gimple_seq *post_p ATTRIBUTE_UNUSED); + + /* Do the processing for the declaration of a GNAT_ENTITY, a type. If + a separate Freeze node exists, delay the bulk of the processing. Otherwise + make a GCC type for GNAT_ENTITY and set up the correspondence. */ + extern void process_type (Entity_Id gnat_entity); + + /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code + location and false if it doesn't. In the former case, set the Gigi global + variable REF_FILENAME to the simple debug file name as given by sinput. */ + extern bool Sloc_to_locus (Source_Ptr Sloc, location_t *locus); + + /* Post an error message. MSG is the error message, properly annotated. + NODE is the node at which to post the error and the node to use for the + "&" substitution. */ + extern void post_error (const char *, Node_Id); + + /* Similar, but NODE is the node at which to post the error and ENT + is the node to use for the "&" substitution. */ + extern void post_error_ne (const char *msg, Node_Id node, Entity_Id ent); + + /* Similar, but NODE is the node at which to post the error, ENT is the node + to use for the "&" substitution, and N is the number to use for the ^. */ + extern void post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, + int n); + + /* Similar to post_error_ne_num, but T is a GCC tree representing the number + to write. If the tree represents a constant that fits within a + host integer, the text inside curly brackets in MSG will be output + (presumably including a '^'). Otherwise that text will not be output + and the text inside square brackets will be output instead. */ + extern void post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, + tree t); + + /* Similar to post_error_ne_tree, except that NUM is a second + integer to write in the message. */ + extern void post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, + tree t, int num); + + /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */ + extern tree protect_multiple_eval (tree exp); + + /* Return a label to branch to for the exception type in KIND or NULL_TREE + if none. */ + extern tree get_exception_label (char); + + /* Current node being treated, in case gigi_abort or Check_Elaboration_Code + called. */ + extern Node_Id error_gnat_node; + + /* This is equivalent to stabilize_reference in tree.c, but we know how to + handle our own nodes and we take extra arguments. FORCE says whether to + force evaluation of everything. We set SUCCESS to true unless we walk + through something we don't know how to stabilize. */ + extern tree maybe_stabilize_reference (tree ref, bool force, bool *success); + + /* Highest number in the front-end node table. */ + extern int max_gnat_nodes; + + /* If nonzero, pretend we are allocating at global level. */ + extern int force_global; + + /* Standard data type sizes. Most of these are not used. */ + + #ifndef CHAR_TYPE_SIZE + #define CHAR_TYPE_SIZE BITS_PER_UNIT + #endif + + #ifndef SHORT_TYPE_SIZE + #define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2)) + #endif + + #ifndef INT_TYPE_SIZE + #define INT_TYPE_SIZE BITS_PER_WORD + #endif + + #ifndef LONG_TYPE_SIZE + #define LONG_TYPE_SIZE BITS_PER_WORD + #endif + + #ifndef LONG_LONG_TYPE_SIZE + #define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2) + #endif + + #ifndef FLOAT_TYPE_SIZE + #define FLOAT_TYPE_SIZE BITS_PER_WORD + #endif + + #ifndef DOUBLE_TYPE_SIZE + #define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) + #endif + + #ifndef LONG_DOUBLE_TYPE_SIZE + #define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) + #endif + + /* The choice of SIZE_TYPE here is very problematic. We need a signed + type whose bit width is Pmode. Assume "long" is such a type here. */ + #undef SIZE_TYPE + #define SIZE_TYPE "long int" + + /* Data structures used to represent attributes. */ + + enum attr_type + { + ATTR_MACHINE_ATTRIBUTE, + ATTR_LINK_ALIAS, + ATTR_LINK_SECTION, + ATTR_LINK_CONSTRUCTOR, + ATTR_LINK_DESTRUCTOR, + ATTR_WEAK_EXTERNAL + }; + + struct attrib + { + struct attrib *next; + enum attr_type type; + tree name; + tree args; + Node_Id error_point; + }; + + /* Table of machine-independent internal attributes. */ + extern const struct attribute_spec gnat_internal_attribute_table[]; + + /* Define the entries in the standard data array. */ + enum standard_datatypes + { + /* Various standard data types and nodes. */ + ADT_longest_float_type, + ADT_void_type_decl, + + /* The type of an exception. */ + ADT_except_type, + + /* Type declaration node <==> typedef void *T */ + ADT_ptr_void_type, + + /* Function type declaration -- void T() */ + ADT_void_ftype, + + /* Type declaration node <==> typedef void *T() */ + ADT_ptr_void_ftype, + + /* Type declaration node <==> typedef virtual void *T() */ + ADT_fdesc_type, + + /* Null pointer for above type */ + ADT_null_fdesc, + + /* Function declaration nodes for run-time functions for allocating memory. + Ada allocators cause calls to these functions to be generated. Malloc32 + is used only on 64bit systems needing to allocate 32bit memory. */ + ADT_malloc_decl, + ADT_malloc32_decl, + + /* Likewise for freeing memory. */ + ADT_free_decl, + + /* Function decl node for 64-bit multiplication with overflow checking */ + ADT_mulv64_decl, + + /* Types and decls used by our temporary exception mechanism. See + init_gigi_decls for details. */ + ADT_jmpbuf_type, + ADT_jmpbuf_ptr_type, + ADT_get_jmpbuf_decl, + ADT_set_jmpbuf_decl, + ADT_get_excptr_decl, + ADT_setjmp_decl, + ADT_longjmp_decl, + ADT_update_setjmp_buf_decl, + ADT_raise_nodefer_decl, + ADT_begin_handler_decl, + ADT_end_handler_decl, + ADT_others_decl, + ADT_all_others_decl, + ADT_LAST}; + + extern GTY(()) tree gnat_std_decls[(int) ADT_LAST]; + extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1]; + + #define longest_float_type_node gnat_std_decls[(int) ADT_longest_float_type] + #define void_type_decl_node gnat_std_decls[(int) ADT_void_type_decl] + #define except_type_node gnat_std_decls[(int) ADT_except_type] + #define ptr_void_type_node gnat_std_decls[(int) ADT_ptr_void_type] + #define void_ftype gnat_std_decls[(int) ADT_void_ftype] + #define ptr_void_ftype gnat_std_decls[(int) ADT_ptr_void_ftype] + #define fdesc_type_node gnat_std_decls[(int) ADT_fdesc_type] + #define null_fdesc_node gnat_std_decls[(int) ADT_null_fdesc] + #define malloc_decl gnat_std_decls[(int) ADT_malloc_decl] + #define malloc32_decl gnat_std_decls[(int) ADT_malloc32_decl] + #define free_decl gnat_std_decls[(int) ADT_free_decl] + #define mulv64_decl gnat_std_decls[(int) ADT_mulv64_decl] + #define jmpbuf_type gnat_std_decls[(int) ADT_jmpbuf_type] + #define jmpbuf_ptr_type gnat_std_decls[(int) ADT_jmpbuf_ptr_type] + #define get_jmpbuf_decl gnat_std_decls[(int) ADT_get_jmpbuf_decl] + #define set_jmpbuf_decl gnat_std_decls[(int) ADT_set_jmpbuf_decl] + #define get_excptr_decl gnat_std_decls[(int) ADT_get_excptr_decl] + #define setjmp_decl gnat_std_decls[(int) ADT_setjmp_decl] + #define longjmp_decl gnat_std_decls[(int) ADT_longjmp_decl] + #define update_setjmp_buf_decl gnat_std_decls[(int) ADT_update_setjmp_buf_decl] + #define raise_nodefer_decl gnat_std_decls[(int) ADT_raise_nodefer_decl] + #define begin_handler_decl gnat_std_decls[(int) ADT_begin_handler_decl] + #define others_decl gnat_std_decls[(int) ADT_others_decl] + #define all_others_decl gnat_std_decls[(int) ADT_all_others_decl] + #define end_handler_decl gnat_std_decls[(int) ADT_end_handler_decl] + + /* Routines expected by the gcc back-end. They must have exactly the same + prototype and names as below. */ + + /* Returns nonzero if we are currently in the global binding level. */ + extern int global_bindings_p (void); + + /* Enter and exit a new binding level. */ + extern void gnat_pushlevel (void); + extern void gnat_poplevel (void); + + /* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL + and point FNDECL to this BLOCK. */ + extern void set_current_block_context (tree fndecl); + + /* Set the jmpbuf_decl for the current binding level to DECL. */ + extern void set_block_jmpbuf_decl (tree decl); + + /* Get the setjmp_decl, if any, for the current binding level. */ + extern tree get_block_jmpbuf_decl (void); + + /* Records a ..._DECL node DECL as belonging to the current lexical scope + and uses GNAT_NODE for location information. */ + extern void gnat_pushdecl (tree decl, Node_Id gnat_node); + + extern void gnat_init_decl_processing (void); + extern void init_gigi_decls (tree long_long_float_type, tree exception_type); + extern void gnat_init_gcc_eh (void); + + /* Return an integer type with the number of bits of precision given by + PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise + it is a signed type. */ + extern tree gnat_type_for_size (unsigned precision, int unsignedp); + + /* Return a data type that has machine mode MODE. UNSIGNEDP selects + an unsigned type; otherwise a signed type is returned. */ + extern tree gnat_type_for_mode (enum machine_mode mode, int unsignedp); + + /* Emit debug info for all global variable declarations. */ + extern void gnat_write_global_declarations (void); + + /* Return the unsigned version of a TYPE_NODE, a scalar type. */ + extern tree gnat_unsigned_type (tree type_node); + + /* Return the signed version of a TYPE_NODE, a scalar type. */ + extern tree gnat_signed_type (tree type_node); + + /* Return 1 if the types T1 and T2 are compatible, i.e. if they can be + transparently converted to each other. */ + extern int gnat_types_compatible_p (tree t1, tree t2); + + /* Create an expression whose value is that of EXPR, + converted to type TYPE. The TREE_TYPE of the value + is always TYPE. This function implements all reasonable + conversions; callers should filter out those that are + not permitted by the language being compiled. */ + extern tree convert (tree type, tree expr); + + /* Routines created solely for the tree translator's sake. Their prototypes + can be changed as desired. */ + + /* GNAT_ENTITY is a GNAT tree node for a defining identifier. + GNU_DECL is the GCC tree which is to be associated with + GNAT_ENTITY. Such gnu tree node is always an ..._DECL node. + If NO_CHECK is nonzero, the latter check is suppressed. + If GNU_DECL is zero, a previous association is to be reset. */ + extern void save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, + bool no_check); + + /* GNAT_ENTITY is a GNAT tree node for a defining identifier. + Return the ..._DECL node that was associated with it. If there is no tree + node associated with GNAT_ENTITY, abort. */ + extern tree get_gnu_tree (Entity_Id gnat_entity); + + /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */ + extern bool present_gnu_tree (Entity_Id gnat_entity); + + /* Initialize tables for above routines. */ + extern void init_gnat_to_gnu (void); + + /* Given a record type RECORD_TYPE and a chain of FIELD_DECL nodes FIELDLIST, + finish constructing the record or union type. If REP_LEVEL is zero, this + record has no representation clause and so will be entirely laid out here. + If REP_LEVEL is one, this record has a representation clause and has been + laid out already; only set the sizes and alignment. If REP_LEVEL is two, + this record is derived from a parent record and thus inherits its layout; + only make a pass on the fields to finalize them. If DO_NOT_FINALIZE is + true, the record type is expected to be modified afterwards so it will + not be sent to the back-end for finalization. */ + extern void finish_record_type (tree record_type, tree fieldlist, + int rep_level, bool do_not_finalize); + + /* Wrap up compilation of RECORD_TYPE, i.e. most notably output all + the debug information associated with it. It need not be invoked + directly in most cases since finish_record_type takes care of doing + so, unless explicitly requested not to through DO_NOT_FINALIZE. */ + extern void rest_of_record_type_compilation (tree record_type); + + /* Append PARALLEL_TYPE on the chain of parallel types for decl. */ + extern void add_parallel_type (tree decl, tree parallel_type); + + /* Return the parallel type associated to a type, if any. */ + extern tree get_parallel_type (tree type); + + /* Returns a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the + subprogram. If it is void_type_node, then we are dealing with a procedure, + otherwise we are dealing with a function. PARAM_DECL_LIST is a list of + PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the + copy-in/copy-out list to be stored into TYPE_CI_CO_LIST. + RETURNS_UNCONSTRAINED is true if the function returns an unconstrained + object. RETURNS_BY_REF is true if the function returns by reference. + RETURNS_BY_TARGET_PTR is true if the function is to be passed (as its + first parameter) the address of the place to copy its result. */ + extern tree create_subprog_type (tree return_type, tree param_decl_list, + tree cico_list, bool returns_unconstrained, + bool returns_by_ref, + bool returns_by_target_ptr); + + /* Return a copy of TYPE, but safe to modify in any way. */ + extern tree copy_type (tree type); + + /* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose + TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position of + the decl. */ + extern tree create_index_type (tree min, tree max, tree index, + Node_Id gnat_node); + + /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character + string) and TYPE is a ..._TYPE node giving its data type. + ARTIFICIAL_P is true if this is a declaration that was generated + by the compiler. DEBUG_INFO_P is true if we need to write debugging + information about this type. GNAT_NODE is used for the position of + the decl. */ + extern tree create_type_decl (tree type_name, tree type, + struct attrib *attr_list, + bool artificial_p, bool debug_info_p, + Node_Id gnat_node); + + /* Return a VAR_DECL or CONST_DECL node. + + VAR_NAME gives the name of the variable. ASM_NAME is its assembler name + (if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is + the GCC tree for an optional initial expression; NULL_TREE if none. + + CONST_FLAG is true if this variable is constant, in which case we might + return a CONST_DECL node unless CONST_DECL_ALLOWED_P is false. + + PUBLIC_FLAG is true if this definition is to be made visible outside of + the current compilation unit. This flag should be set when processing the + variable definitions in a package specification. + + EXTERN_FLAG is nonzero when processing an external variable declaration (as + opposed to a definition: no storage is to be allocated for the variable). + + STATIC_FLAG is only relevant when not at top level. In that case + it indicates whether to always allocate storage to the variable. + + GNAT_NODE is used for the position of the decl. */ + tree + create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init, + bool const_flag, bool public_flag, bool extern_flag, + bool static_flag, bool const_decl_allowed_p, + struct attrib *attr_list, Node_Id gnat_node); + + /* Wrapper around create_var_decl_1 for cases where we don't care whether + a VAR or a CONST decl node is created. */ + #define create_var_decl(var_name, asm_name, type, var_init, \ + const_flag, public_flag, extern_flag, \ + static_flag, attr_list, gnat_node) \ + create_var_decl_1 (var_name, asm_name, type, var_init, \ + const_flag, public_flag, extern_flag, \ + static_flag, true, attr_list, gnat_node) + + /* Wrapper around create_var_decl_1 for cases where a VAR_DECL node is + required. The primary intent is for DECL_CONST_CORRESPONDING_VARs, which + must be VAR_DECLs and on which we want TREE_READONLY set to have them + possibly assigned to a readonly data section. */ + #define create_true_var_decl(var_name, asm_name, type, var_init, \ + const_flag, public_flag, extern_flag, \ + static_flag, attr_list, gnat_node) \ + create_var_decl_1 (var_name, asm_name, type, var_init, \ + const_flag, public_flag, extern_flag, \ + static_flag, false, attr_list, gnat_node) + + /* Given a DECL and ATTR_LIST, apply the listed attributes. */ + extern void process_attributes (tree decl, struct attrib *attr_list); + + /* Record a global renaming pointer. */ + void record_global_renaming_pointer (tree); + + /* Invalidate the global renaming pointers. */ + void invalidate_global_renaming_pointers (void); + + /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its + type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if + this field is in a record type with a "pragma pack". If SIZE is nonzero + it is the specified size for this field. If POS is nonzero, it is the bit + position. If ADDRESSABLE is nonzero, it means we are allowed to take + the address of this field for aliasing purposes. */ + extern tree create_field_decl (tree field_name, tree field_type, + tree record_type, int packed, tree size, + tree pos, int addressable); + + /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter, + PARAM_TYPE is its type. READONLY is true if the parameter is + readonly (either an In parameter or an address of a pass-by-ref + parameter). */ + extern tree create_param_decl (tree param_name, tree param_type, + bool readonly); + + /* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram, + ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE + node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of + PARM_DECL nodes chained through the TREE_CHAIN field). + + INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the + appropriate fields in the FUNCTION_DECL. GNAT_NODE gives the location. */ + extern tree create_subprog_decl (tree subprog_name, tree asm_name, + tree subprog_type, tree param_decl_list, + bool inlinee_flag, bool public_flag, + bool extern_flag, + struct attrib *attr_list, Node_Id gnat_node); + + /* Returns a LABEL_DECL node for LABEL_NAME. */ + extern tree create_label_decl (tree label_name); + + /* Set up the framework for generating code for SUBPROG_DECL, a subprogram + body. This routine needs to be invoked before processing the declarations + appearing in the subprogram. */ + extern void begin_subprog_body (tree subprog_decl); + + /* Finish the definition of the current subprogram BODY and compile it all the + way to assembler language output. ELAB_P tells if this is called for an + elaboration routine, to be entirely discarded if empty. */ + extern void end_subprog_body (tree body, bool elab_p); + + /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE. + EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs. + Return a constructor for the template. */ + extern tree build_template (tree template_type, tree array_type, tree expr); + + /* Build a 64bit VMS descriptor from a Mechanism_Type, which must specify + a descriptor type, and the GCC type of an object. Each FIELD_DECL + in the type contains in its DECL_INITIAL the expression to use when + a constructor is made for the type. GNAT_ENTITY is a gnat node used + to print out an error message if the mechanism cannot be applied to + an object of that type and also for the name. */ + extern tree build_vms_descriptor (tree type, Mechanism_Type mech, + Entity_Id gnat_entity); + + /* Build a 32bit VMS descriptor from a Mechanism_Type. See above. */ + extern tree build_vms_descriptor32 (tree type, Mechanism_Type mech, + Entity_Id gnat_entity); + + /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG + and the GNAT node GNAT_SUBPROG. */ + extern void build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog); + + /* Build a type to be used to represent an aliased object whose nominal + type is an unconstrained array. This consists of a RECORD_TYPE containing + a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an + ARRAY_TYPE. If ARRAY_TYPE is that of the unconstrained array, this + is used to represent an arbitrary unconstrained object. Use NAME + as the name of the record. */ + extern tree build_unc_object_type (tree template_type, tree object_type, + tree name); + + /* Same as build_unc_object_type, but taking a thin or fat pointer type + instead of the template type. */ + extern tree build_unc_object_type_from_ptr (tree thin_fat_ptr_type, + tree object_type, tree name); + + /* Shift the component offsets within an unconstrained object TYPE to make it + suitable for use as a designated type for thin pointers. */ + extern void shift_unc_components_for_thin_pointers (tree type); + + /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In + the normal case this is just two adjustments, but we have more to do + if NEW is an UNCONSTRAINED_ARRAY_TYPE. */ + extern void update_pointer_to (tree old_type, tree new_type); + + /* EXP is an expression for the size of an object. If this size contains + discriminant references, replace them with the maximum (if MAX_P) or + minimum (if !MAX_P) possible value of the discriminant. */ + extern tree max_size (tree exp, bool max_p); + + /* Remove all conversions that are done in EXP. This includes converting + from a padded type or to a left-justified modular type. If TRUE_ADDRESS + is true, always return the address of the containing object even if + the address is not bit-aligned. */ + extern tree remove_conversions (tree exp, bool true_address); + + /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that + refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P, + likewise return an expression pointing to the underlying array. */ + extern tree maybe_unconstrained_array (tree exp); + + /* Return an expression that does an unchecked conversion of EXPR to TYPE. + If NOTRUNC_P is true, truncation operations should be suppressed. */ + extern tree unchecked_convert (tree type, tree expr, bool notrunc_p); + + /* Return the appropriate GCC tree code for the specified GNAT type, + the latter being a record type as predicated by Is_Record_Type. */ + extern enum tree_code tree_code_for_record_type (Entity_Id); + + /* Return true if GNU_TYPE is suitable as the type of a non-aliased + component of an aggregate type. */ + extern bool type_for_nonaliased_component_p (tree); + + /* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical + operation. + + This preparation consists of taking the ordinary + representation of an expression EXPR and producing a valid tree + boolean expression describing whether EXPR is nonzero. We could + simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1), + but we optimize comparisons, &&, ||, and !. + + The resulting type should always be the same as the input type. + This function is simpler than the corresponding C version since + the only possible operands will be things of Boolean type. */ + extern tree gnat_truthvalue_conversion (tree expr); + + /* Return the base type of TYPE. */ + extern tree get_base_type (tree type); + + /* EXP is a GCC tree representing an address. See if we can find how + strictly the object at that address is aligned. Return that alignment + strictly the object at that address is aligned. Return that alignment + in bits. If we don't know anything about the alignment, return 0. */ + extern unsigned int known_alignment (tree exp); + + /* Return true if VALUE is a multiple of FACTOR. FACTOR must be a power + of 2. */ + extern bool value_factor_p (tree value, HOST_WIDE_INT factor); + + /* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type + desired for the result. Usually the operation is to be performed + in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0 + in which case the type to be used will be derived from the operands. */ + extern tree build_binary_op (enum tree_code op_code, tree result_type, + tree left_operand, tree right_operand); + + /* Similar, but make unary operation. */ + extern tree build_unary_op (enum tree_code op_code, tree result_type, + tree operand); + + /* Similar, but for COND_EXPR. */ + extern tree build_cond_expr (tree result_type, tree condition_operand, + tree true_operand, tree false_operand); + + /* Similar, but for RETURN_EXPR. */ + extern tree build_return_expr (tree result_decl, tree ret_val); + + /* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return + the CALL_EXPR. */ + extern tree build_call_1_expr (tree fundecl, tree arg); + + /* Build a CALL_EXPR to call FUNDECL with two argument, ARG1 & ARG2. Return + the CALL_EXPR. */ + extern tree build_call_2_expr (tree fundecl, tree arg1, tree arg2); + + /* Likewise to call FUNDECL with no arguments. */ + extern tree build_call_0_expr (tree fundecl); + + /* Call a function that raises an exception and pass the line number and file + name, if requested. MSG says which exception function to call. + + GNAT_NODE is the gnat node conveying the source location for which the + error should be signaled, or Empty in which case the error is signaled on + the current ref_file_name/input_line. + + KIND says which kind of exception this is for + (N_Raise_{Constraint,Storage,Program}_Error). */ + extern tree build_call_raise (int msg, Node_Id gnat_node, char kind); + + /* Return a CONSTRUCTOR of TYPE whose list is LIST. This is not the + same as build_constructor in the language-independent tree.c. */ + extern tree gnat_build_constructor (tree type, tree list); + + /* Return a COMPONENT_REF to access a field that is given by COMPONENT, + an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL, + for the field, or both. Don't fold the result if NO_FOLD_P. */ + extern tree build_component_ref (tree record_variable, tree component, + tree field, bool no_fold_p); + + /* Build a GCC tree to call an allocation or deallocation function. + If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise, + generate an allocator. + + GNU_SIZE is the size of the object and ALIGN is the alignment. + GNAT_PROC, if present is a procedure to call and GNAT_POOL is the + storage pool to use. If not preset, malloc and free will be used. */ + extern tree build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, + unsigned align, Entity_Id gnat_proc, + Entity_Id gnat_pool, Node_Id gnat_node); + + /* Build a GCC tree to correspond to allocating an object of TYPE whose + initial value if INIT, if INIT is nonzero. Convert the expression to + RESULT_TYPE, which must be some type of pointer. Return the tree. + GNAT_PROC and GNAT_POOL optionally give the procedure to call and + the storage pool to use. GNAT_NODE is used to provide an error + location for restriction violations messages. If IGNORE_INIT_TYPE is + true, ignore the type of INIT for the purpose of determining the size; + this will cause the maximum size to be allocated if TYPE is of + self-referential size. */ + extern tree build_allocator (tree type, tree init, tree result_type, + Entity_Id gnat_proc, Entity_Id gnat_pool, + Node_Id gnat_node, bool); + + /* Fill in a VMS descriptor for EXPR and return a constructor for it. + GNAT_FORMAL is how we find the descriptor record. GNAT_ACTUAL is how + we derive the source location on a C_E */ + extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal, + Node_Id gnat_actual); + + /* Indicate that we need to make the address of EXPR_NODE and it therefore + should not be allocated in a register. Return true if successful. */ + extern bool gnat_mark_addressable (tree expr_node); + + /* Implementation of the builtin_function langhook. */ + extern tree gnat_builtin_function (tree decl); + + /* Search the chain of currently reachable declarations for a builtin + FUNCTION_DECL node corresponding to function NAME (an IDENTIFIER_NODE). + Return the first node found, if any, or NULL_TREE otherwise. */ + extern tree builtin_decl_for (tree name); + + /* This function is called by the front end to enumerate all the supported + modes for the machine. We pass a function which is called back with + the following integer parameters: + + FLOAT_P nonzero if this represents a floating-point mode + COMPLEX_P nonzero is this represents a complex mode + COUNT count of number of items, nonzero for vector mode + PRECISION number of bits in data representation + MANTISSA number of bits in mantissa, if FP and known, else zero. + SIZE number of bits used to store data + ALIGN number of bits to which mode is aligned. */ + extern void enumerate_modes (void (*f) (int, int, int, int, int, int, + unsigned int)); + + /* These are temporary function to deal with recent GCC changes related to + FP type sizes and precisions. */ + extern int fp_prec_to_size (int prec); + extern int fp_size_to_prec (int size); + + /* These functions return the basic data type sizes and related parameters + about the target machine. */ + + extern Pos get_target_bits_per_unit (void); + extern Pos get_target_bits_per_word (void); + extern Pos get_target_char_size (void); + extern Pos get_target_wchar_t_size (void); + extern Pos get_target_short_size (void); + extern Pos get_target_int_size (void); + extern Pos get_target_long_size (void); + extern Pos get_target_long_long_size (void); + extern Pos get_target_float_size (void); + extern Pos get_target_double_size (void); + extern Pos get_target_long_double_size (void); + extern Pos get_target_pointer_size (void); + extern Pos get_target_maximum_alignment (void); + extern Pos get_target_default_allocator_alignment (void); + extern Pos get_target_maximum_default_alignment (void); + extern Pos get_target_maximum_allowed_alignment (void); + extern Nat get_float_words_be (void); + extern Nat get_words_be (void); + extern Nat get_bytes_be (void); + extern Nat get_bits_be (void); + extern Nat get_strict_alignment (void); + + /* Let code know whether we are targetting VMS without need of + intrusive preprocessor directives. */ + #ifndef TARGET_ABI_OPEN_VMS + #define TARGET_ABI_OPEN_VMS 0 + #endif + + /* VMS macro set by default, when clear forces 32bit mallocs and 32bit + Descriptors. Always used in combination with TARGET_ABI_OPEN_VMS + so no effect on non-VMS systems. */ + #ifndef TARGET_MALLOC64 + #define TARGET_MALLOC64 0 + #endif + diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/lang-specs.h gcc-4.4.0/gcc/ada/gcc-interface/lang-specs.h *** gcc-4.3.3/gcc/ada/gcc-interface/lang-specs.h Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/lang-specs.h Sat Nov 15 12:43:16 2008 *************** *** 0 **** --- 1,50 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * L A N G - S P E C S * + * * + * C Header File * + * * + * Copyright (C) 1992-2008, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + /* This is the contribution to the `default_compilers' array in gcc.c for + GNAT. */ + + {".ads", "@ada", 0, 0, 0}, + {".adb", "@ada", 0, 0, 0}, + {"@ada", + "\ + %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ + %{!S:%{!c:%e-c or -S required for Ada}}\ + gnat1 %{I*} %{k8:-gnatk8} %{Wall:-gnatwa} %{w:-gnatws} %{!Q:-quiet}\ + %{nostdinc*} %{nostdlib*}\ + -dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\ + %{O*} %{W*} %{w} %{p} %{pg:-p} %{a} %{d*} %{f*}\ + %{coverage:-fprofile-arcs -ftest-coverage} " + #if CONFIG_DUAL_EXCEPTIONS + "%{fRTS=sjlj:-fsjlj} " + #endif + "%{gnatea:-gnatez} %{g*&m*} " + #if defined(TARGET_VXWORKS_RTP) + "%{fRTS=rtp:-mrtp} " + #endif + "%1 %{!S:%{o*:%w%*-gnatO}} \ + %i %{S:%W{o*}%{!o*:-o %b.s}} \ + %{gnatc*|gnats*: -o %j} %{-param*} \ + %{!gnatc*:%{!gnats*:%(invoke_as)}}", 0, 0, 0}, diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/lang.opt gcc-4.4.0/gcc/ada/gcc-interface/lang.opt *** gcc-4.3.3/gcc/ada/gcc-interface/lang.opt Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/lang.opt Fri Feb 20 15:20:38 2009 *************** *** 0 **** --- 1,102 ---- + ; Options for the Ada front end. + ; Copyright (C) 2003, 2007, 2008 Free Software Foundation, Inc. + ; + ; This file is part of GCC. + ; + ; GCC is free software; you can redistribute it and/or modify it under + ; the terms of the GNU General Public License as published by the Free + ; Software Foundation; either version 3, or (at your option) any later + ; version. + ; + ; GCC is distributed in the hope that it will be useful, but WITHOUT ANY + ; WARRANTY; without even the implied warranty of MERCHANTABILITY or + ; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + ; for more details. + ; + ; You should have received a copy of the GNU General Public License + ; along with GCC; see the file COPYING3. If not see + ; . + + + ; See the GCC internals manual for a description of this file's format. + + ; Please try to keep this file in ASCII collating order. + + Language + Ada + + I + Ada Joined Separate + ; Documented for C + + Wall + Ada + ; Documented for C + + Wmissing-prototypes + Ada + ; Documented for C + + Wstrict-prototypes + Ada + ; Documented for C + + Wwrite-strings + Ada + ; Documented for C + + Wlong-long + Ada + ; Documented for C + + Wvariadic-macros + Ada + ; Documented for C + + Wold-style-definition + Ada + ; Documented for C + + Wmissing-format-attribute + Ada + ; Documented for C + + Woverlength-strings + Ada + ; Documented for C + + nostdinc + Ada RejectNegative + ; Don't look for source files + + nostdlib + Ada + ; Don't look for object files + + feliminate-unused-debug-types + Ada + ; Effect documented for C - intercepted for Ada to force the associated flag + ; not to be set by default, as it currently eliminates unreferenced parallel + ; types we need for encoding descriptions to the debugger. + + fRTS= + Ada Joined RejectNegative + ; Selects the runtime + + gdwarf+ + Ada + ; Explicit request for dwarf debug info with GNAT specific extensions. + + gant + Ada Joined Undocumented + ; Catches typos + + gnatO + Ada Separate + ; Sets name of output ALI file (internal switch) + + gnat + Ada Joined + -gnat Specify options to GNAT + + ; This comment is to ensure we retain the blank line above. diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/misc.c gcc-4.4.0/gcc/ada/gcc-interface/misc.c *** gcc-4.3.3/gcc/ada/gcc-interface/misc.c Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/misc.c Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,873 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * M I S C * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2009, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + /* This file contains parts of the compiler that are required for interfacing + with GCC but otherwise do nothing and parts of Gigi that need to know + about RTL. */ + + #include "config.h" + #include "system.h" + #include "coretypes.h" + #include "tm.h" + #include "tree.h" + #include "real.h" + #include "rtl.h" + #include "diagnostic.h" + #include "expr.h" + #include "libfuncs.h" + #include "ggc.h" + #include "flags.h" + #include "debug.h" + #include "cgraph.h" + #include "tree-inline.h" + #include "insn-codes.h" + #include "insn-flags.h" + #include "insn-config.h" + #include "optabs.h" + #include "recog.h" + #include "toplev.h" + #include "output.h" + #include "except.h" + #include "tm_p.h" + #include "langhooks.h" + #include "langhooks-def.h" + #include "target.h" + + #include "ada.h" + #include "types.h" + #include "atree.h" + #include "elists.h" + #include "namet.h" + #include "nlists.h" + #include "stringt.h" + #include "uintp.h" + #include "fe.h" + #include "sinfo.h" + #include "einfo.h" + #include "ada-tree.h" + #include "gigi.h" + #include "adadecode.h" + #include "opts.h" + #include "options.h" + + extern FILE *asm_out_file; + + /* The largest alignment, in bits, that is needed for using the widest + move instruction. */ + unsigned int largest_move_alignment; + + static bool gnat_init (void); + static void gnat_finish_incomplete_decl (tree); + static unsigned int gnat_init_options (unsigned int, const char **); + static int gnat_handle_option (size_t, const char *, int); + static bool gnat_post_options (const char **); + static alias_set_type gnat_get_alias_set (tree); + static void gnat_print_decl (FILE *, tree, int); + static void gnat_print_type (FILE *, tree, int); + static const char *gnat_printable_name (tree, int); + static const char *gnat_dwarf_name (tree, int); + static tree gnat_return_tree (tree); + static int gnat_eh_type_covers (tree, tree); + static void gnat_parse_file (int); + static rtx gnat_expand_expr (tree, rtx, enum machine_mode, int, + rtx *); + static void internal_error_function (const char *, va_list *); + static tree gnat_type_max_size (const_tree); + + /* Definitions for our language-specific hooks. */ + + #undef LANG_HOOKS_NAME + #define LANG_HOOKS_NAME "GNU Ada" + #undef LANG_HOOKS_IDENTIFIER_SIZE + #define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier) + #undef LANG_HOOKS_INIT + #define LANG_HOOKS_INIT gnat_init + #undef LANG_HOOKS_INIT_OPTIONS + #define LANG_HOOKS_INIT_OPTIONS gnat_init_options + #undef LANG_HOOKS_HANDLE_OPTION + #define LANG_HOOKS_HANDLE_OPTION gnat_handle_option + #undef LANG_HOOKS_POST_OPTIONS + #define LANG_HOOKS_POST_OPTIONS gnat_post_options + #undef LANG_HOOKS_PARSE_FILE + #define LANG_HOOKS_PARSE_FILE gnat_parse_file + #undef LANG_HOOKS_HASH_TYPES + #define LANG_HOOKS_HASH_TYPES false + #undef LANG_HOOKS_GETDECLS + #define LANG_HOOKS_GETDECLS lhd_return_null_tree_v + #undef LANG_HOOKS_PUSHDECL + #define LANG_HOOKS_PUSHDECL gnat_return_tree + #undef LANG_HOOKS_WRITE_GLOBALS + #define LANG_HOOKS_WRITE_GLOBALS gnat_write_global_declarations + #undef LANG_HOOKS_FINISH_INCOMPLETE_DECL + #define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl + #undef LANG_HOOKS_GET_ALIAS_SET + #define LANG_HOOKS_GET_ALIAS_SET gnat_get_alias_set + #undef LANG_HOOKS_EXPAND_EXPR + #define LANG_HOOKS_EXPAND_EXPR gnat_expand_expr + #undef LANG_HOOKS_MARK_ADDRESSABLE + #define LANG_HOOKS_MARK_ADDRESSABLE gnat_mark_addressable + #undef LANG_HOOKS_PRINT_DECL + #define LANG_HOOKS_PRINT_DECL gnat_print_decl + #undef LANG_HOOKS_PRINT_TYPE + #define LANG_HOOKS_PRINT_TYPE gnat_print_type + #undef LANG_HOOKS_TYPE_MAX_SIZE + #define LANG_HOOKS_TYPE_MAX_SIZE gnat_type_max_size + #undef LANG_HOOKS_DECL_PRINTABLE_NAME + #define LANG_HOOKS_DECL_PRINTABLE_NAME gnat_printable_name + #undef LANG_HOOKS_DWARF_NAME + #define LANG_HOOKS_DWARF_NAME gnat_dwarf_name + #undef LANG_HOOKS_GIMPLIFY_EXPR + #define LANG_HOOKS_GIMPLIFY_EXPR gnat_gimplify_expr + #undef LANG_HOOKS_TYPE_FOR_MODE + #define LANG_HOOKS_TYPE_FOR_MODE gnat_type_for_mode + #undef LANG_HOOKS_TYPE_FOR_SIZE + #define LANG_HOOKS_TYPE_FOR_SIZE gnat_type_for_size + #undef LANG_HOOKS_TYPES_COMPATIBLE_P + #define LANG_HOOKS_TYPES_COMPATIBLE_P gnat_types_compatible_p + #undef LANG_HOOKS_ATTRIBUTE_TABLE + #define LANG_HOOKS_ATTRIBUTE_TABLE gnat_internal_attribute_table + #undef LANG_HOOKS_BUILTIN_FUNCTION + #define LANG_HOOKS_BUILTIN_FUNCTION gnat_builtin_function + + const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; + + /* How much we want of our DWARF extensions. Some of our dwarf+ extensions + are incompatible with regular GDB versions, so we must make sure to only + produce them on explicit request. This is eventually reflected into the + use_gnu_debug_info_extensions common flag for later processing. */ + + static int gnat_dwarf_extensions = 0; + + /* Command-line argc and argv. + These variables are global, since they are imported and used in + back_end.adb */ + + unsigned int save_argc; + const char **save_argv; + + /* gnat standard argc argv */ + + extern int gnat_argc; + extern char **gnat_argv; + + + /* Declare functions we use as part of startup. */ + extern void __gnat_initialize (void *); + extern void __gnat_install_SEH_handler (void *); + extern void adainit (void); + extern void _ada_gnat1drv (void); + + /* The parser for the language. For us, we process the GNAT tree. */ + + static void + gnat_parse_file (int set_yydebug ATTRIBUTE_UNUSED) + { + int seh[2]; + + /* Call the target specific initializations. */ + __gnat_initialize (NULL); + + /* ??? Call the SEH initialization routine. This is to workaround + a bootstrap path problem. The call below should be removed at some + point and the SEH pointer passed to __gnat_initialize() above. */ + __gnat_install_SEH_handler((void *)seh); + + /* Call the front-end elaboration procedures. */ + adainit (); + + /* Call the front end. */ + _ada_gnat1drv (); + + /* We always have a single compilation unit in Ada. */ + cgraph_finalize_compilation_unit (); + } + + /* Decode all the language specific options that cannot be decoded by GCC. + The option decoding phase of GCC calls this routine on the flags that + it cannot decode. This routine returns the number of consecutive arguments + from ARGV that it successfully decoded; 0 indicates failure. */ + + static int + gnat_handle_option (size_t scode, const char *arg, int value) + { + const struct cl_option *option = &cl_options[scode]; + enum opt_code code = (enum opt_code) scode; + char *q; + + if (arg == NULL && (option->flags & (CL_JOINED | CL_SEPARATE))) + { + error ("missing argument to \"-%s\"", option->opt_text); + return 1; + } + + switch (code) + { + case OPT_I: + q = XNEWVEC (char, sizeof("-I") + strlen (arg)); + strcpy (q, "-I"); + strcat (q, arg); + gnat_argv[gnat_argc] = q; + gnat_argc++; + break; + + case OPT_Wall: + warn_unused = value; + + /* We save the value of warn_uninitialized, since if they put + -Wuninitialized on the command line, we need to generate a + warning about not using it without also specifying -O. */ + if (warn_uninitialized != 1) + warn_uninitialized = (value ? 2 : 0); + break; + + /* These are used in the GCC Makefile. */ + case OPT_Wmissing_prototypes: + case OPT_Wstrict_prototypes: + case OPT_Wwrite_strings: + case OPT_Wlong_long: + case OPT_Wvariadic_macros: + case OPT_Wold_style_definition: + case OPT_Wmissing_format_attribute: + case OPT_Woverlength_strings: + break; + + /* This is handled by the front-end. */ + case OPT_nostdinc: + break; + + case OPT_nostdlib: + gnat_argv[gnat_argc] = xstrdup ("-nostdlib"); + gnat_argc++; + break; + + case OPT_feliminate_unused_debug_types: + /* We arrange for post_option to be able to only set the corresponding + flag to 1 when explicitly requested by the user. We expect the + default flag value to be either 0 or positive, and expose a positive + -f as a negative value to post_option. */ + flag_eliminate_unused_debug_types = -value; + break; + + case OPT_fRTS_: + gnat_argv[gnat_argc] = xstrdup ("-fRTS"); + gnat_argc++; + break; + + case OPT_gant: + warning (0, "%<-gnat%> misspelled as %<-gant%>"); + + /* ... fall through ... */ + + case OPT_gnat: + /* Recopy the switches without the 'gnat' prefix. */ + gnat_argv[gnat_argc] = XNEWVEC (char, strlen (arg) + 2); + gnat_argv[gnat_argc][0] = '-'; + strcpy (gnat_argv[gnat_argc] + 1, arg); + gnat_argc++; + break; + + case OPT_gnatO: + gnat_argv[gnat_argc] = xstrdup ("-O"); + gnat_argc++; + gnat_argv[gnat_argc] = xstrdup (arg); + gnat_argc++; + break; + + case OPT_gdwarf_: + gnat_dwarf_extensions ++; + break; + + default: + gcc_unreachable (); + } + + return 1; + } + + /* Initialize for option processing. */ + + static unsigned int + gnat_init_options (unsigned int argc, const char **argv) + { + /* Initialize gnat_argv with save_argv size. */ + gnat_argv = (char **) xmalloc ((argc + 1) * sizeof (argv[0])); + gnat_argv[0] = xstrdup (argv[0]); /* name of the command */ + gnat_argc = 1; + + save_argc = argc; + save_argv = argv; + + /* Uninitialized really means uninitialized in Ada. */ + flag_zero_initialized_in_bss = 0; + + return CL_Ada; + } + + /* Post-switch processing. */ + + bool + gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED) + { + /* ??? The warning machinery is outsmarted by Ada. */ + warn_unused_parameter = 0; + + /* No psABI change warnings for Ada. */ + warn_psabi = 0; + + /* Force eliminate_unused_debug_types to 0 unless an explicit positive + -f has been passed. This forces the default to 0 for Ada, which might + differ from the common default. */ + if (flag_eliminate_unused_debug_types < 0) + flag_eliminate_unused_debug_types = 1; + else + flag_eliminate_unused_debug_types = 0; + + /* Reflect the explicit request of DWARF extensions into the common + flag for use by later passes. */ + if (write_symbols == DWARF2_DEBUG) + use_gnu_debug_info_extensions = gnat_dwarf_extensions > 0; + + return false; + } + + /* Here is the function to handle the compiler error processing in GCC. */ + + static void + internal_error_function (const char *msgid, va_list *ap) + { + text_info tinfo; + char *buffer, *p, *loc; + String_Template temp, temp_loc; + Fat_Pointer fp, fp_loc; + expanded_location s; + + /* Reset the pretty-printer. */ + pp_clear_output_area (global_dc->printer); + + /* Format the message into the pretty-printer. */ + tinfo.format_spec = msgid; + tinfo.args_ptr = ap; + tinfo.err_no = errno; + pp_format_verbatim (global_dc->printer, &tinfo); + + /* Extract a (writable) pointer to the formatted text. */ + buffer = (char*) pp_formatted_text (global_dc->printer); + + /* Go up to the first newline. */ + for (p = buffer; *p; p++) + if (*p == '\n') + { + *p = '\0'; + break; + } + + temp.Low_Bound = 1; + temp.High_Bound = p - buffer; + fp.Bounds = &temp; + fp.Array = buffer; + + s = expand_location (input_location); + if (flag_show_column && s.column != 0) + asprintf (&loc, "%s:%d:%d", s.file, s.line, s.column); + else + asprintf (&loc, "%s:%d", s.file, s.line); + temp_loc.Low_Bound = 1; + temp_loc.High_Bound = strlen (loc); + fp_loc.Bounds = &temp_loc; + fp_loc.Array = loc; + + Current_Error_Node = error_gnat_node; + Compiler_Abort (fp, -1, fp_loc); + } + + /* Perform all the initialization steps that are language-specific. */ + + static bool + gnat_init (void) + { + /* Performs whatever initialization steps needed by the language-dependent + lexical analyzer. */ + gnat_init_decl_processing (); + + /* Add the input filename as the last argument. */ + gnat_argv[gnat_argc] = (char *) main_input_filename; + gnat_argc++; + gnat_argv[gnat_argc] = 0; + + global_dc->internal_error = &internal_error_function; + + /* Show that REFERENCE_TYPEs are internal and should be Pmode. */ + internal_reference_types (); + + return true; + } + + /* This function is called indirectly from toplev.c to handle incomplete + declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise, + compile_file in toplev.c makes an indirect call through the function pointer + incomplete_decl_finalize_hook which is initialized to this routine in + init_decl_processing. */ + + static void + gnat_finish_incomplete_decl (tree dont_care ATTRIBUTE_UNUSED) + { + gcc_unreachable (); + } + + /* Compute the alignment of the largest mode that can be used for copying + objects. */ + + void + gnat_compute_largest_alignment (void) + { + enum machine_mode mode; + + for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); mode != VOIDmode; + mode = GET_MODE_WIDER_MODE (mode)) + if (optab_handler (mov_optab, mode)->insn_code != CODE_FOR_nothing) + largest_move_alignment = MIN (BIGGEST_ALIGNMENT, + MAX (largest_move_alignment, + GET_MODE_ALIGNMENT (mode))); + } + + /* If we are using the GCC mechanism to process exception handling, we + have to register the personality routine for Ada and to initialize + various language dependent hooks. */ + + void + gnat_init_gcc_eh (void) + { + #ifdef DWARF2_UNWIND_INFO + /* lang_dependent_init already called dwarf2out_frame_init if true. */ + int dwarf2out_frame_initialized = dwarf2out_do_frame (); + #endif + + /* We shouldn't do anything if the No_Exceptions_Handler pragma is set, + though. This could for instance lead to the emission of tables with + references to symbols (such as the Ada eh personality routine) within + libraries we won't link against. */ + if (No_Exception_Handlers_Set ()) + return; + + /* Tell GCC we are handling cleanup actions through exception propagation. + This opens possibilities that we don't take advantage of yet, but is + nonetheless necessary to ensure that fixup code gets assigned to the + right exception regions. */ + using_eh_for_cleanups (); + + eh_personality_libfunc = init_one_libfunc (USING_SJLJ_EXCEPTIONS + ? "__gnat_eh_personality_sj" + : "__gnat_eh_personality"); + lang_eh_type_covers = gnat_eh_type_covers; + lang_eh_runtime_type = gnat_return_tree; + default_init_unwind_resume_libfunc (); + + /* Turn on -fexceptions and -fnon-call-exceptions. The first one triggers + the generation of the necessary exception runtime tables. The second one + is useful for two reasons: 1/ we map some asynchronous signals like SEGV + to exceptions, so we need to ensure that the insns which can lead to such + signals are correctly attached to the exception region they pertain to, + 2/ Some calls to pure subprograms are handled as libcall blocks and then + marked as "cannot trap" if the flag is not set (see emit_libcall_block). + We should not let this be since it is possible for such calls to actually + raise in Ada. */ + flag_exceptions = 1; + flag_non_call_exceptions = 1; + + init_eh (); + #ifdef DWARF2_UNWIND_INFO + if (!dwarf2out_frame_initialized && dwarf2out_do_frame ()) + dwarf2out_frame_init (); + #endif + } + + /* Language hooks, first one to print language-specific items in a DECL. */ + + static void + gnat_print_decl (FILE *file, tree node, int indent) + { + switch (TREE_CODE (node)) + { + case CONST_DECL: + print_node (file, "const_corresponding_var", + DECL_CONST_CORRESPONDING_VAR (node), indent + 4); + break; + + case FIELD_DECL: + print_node (file, "original_field", DECL_ORIGINAL_FIELD (node), + indent + 4); + break; + + case VAR_DECL: + print_node (file, "renamed_object", DECL_RENAMED_OBJECT (node), + indent + 4); + break; + + default: + break; + } + } + + static void + gnat_print_type (FILE *file, tree node, int indent) + { + switch (TREE_CODE (node)) + { + case FUNCTION_TYPE: + print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4); + break; + + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4); + break; + + case INTEGER_TYPE: + if (TYPE_MODULAR_P (node)) + print_node (file, "modulus", TYPE_MODULUS (node), indent + 4); + else if (TYPE_HAS_ACTUAL_BOUNDS_P (node)) + print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node), + indent + 4); + else if (TYPE_VAX_FLOATING_POINT_P (node)) + ; + else + print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4); + + print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4); + break; + + case ARRAY_TYPE: + print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4); + break; + + case RECORD_TYPE: + if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node)) + print_node (file, "unconstrained array", + TYPE_UNCONSTRAINED_ARRAY (node), indent + 4); + else + print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4); + break; + + case UNION_TYPE: + case QUAL_UNION_TYPE: + print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4); + break; + + default: + break; + } + } + + static const char * + gnat_dwarf_name (tree t, int verbosity ATTRIBUTE_UNUSED) + { + gcc_assert (DECL_P (t)); + + return (const char *) IDENTIFIER_POINTER (DECL_NAME (t)); + } + + static const char * + gnat_printable_name (tree decl, int verbosity) + { + const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl)); + char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60); + + __gnat_decode (coded_name, ada_name, 0); + + if (verbosity == 2) + { + Set_Identifier_Casing (ada_name, (char *) DECL_SOURCE_FILE (decl)); + return ggc_strdup (Name_Buffer); + } + else + return ada_name; + } + + /* Expands GNAT-specific GCC tree nodes. The only ones we support + here are and NULL_EXPR. */ + + static rtx + gnat_expand_expr (tree exp, rtx target, enum machine_mode tmode, + int modifier, rtx *alt_rtl) + { + tree type = TREE_TYPE (exp); + tree new; + + /* Update EXP to be the new expression to expand. */ + switch (TREE_CODE (exp)) + { + #if 0 + case ALLOCATE_EXPR: + return + allocate_dynamic_stack_space + (expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, TYPE_MODE (sizetype), + EXPAND_NORMAL), + NULL_RTX, tree_low_cst (TREE_OPERAND (exp, 1), 1)); + #endif + + case UNCONSTRAINED_ARRAY_REF: + /* If we are evaluating just for side-effects, just evaluate our + operand. Otherwise, abort since this code should never appear + in a tree to be evaluated (objects aren't unconstrained). */ + if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE) + return expand_expr (TREE_OPERAND (exp, 0), const0_rtx, + VOIDmode, modifier); + + /* ... fall through ... */ + + default: + gcc_unreachable (); + } + + return expand_expr_real (new, target, tmode, modifier, alt_rtl); + } + + /* Do nothing (return the tree node passed). */ + + static tree + gnat_return_tree (tree t) + { + return t; + } + + /* Return true if type A catches type B. Callback for flow analysis from + the exception handling part of the back-end. */ + + static int + gnat_eh_type_covers (tree a, tree b) + { + /* a catches b if they represent the same exception id or if a + is an "others". + + ??? integer_zero_node for "others" is hardwired in too many places + currently. */ + return (a == b || a == integer_zero_node); + } + + /* Get the alias set corresponding to a type or expression. */ + + static alias_set_type + gnat_get_alias_set (tree type) + { + /* If this is a padding type, use the type of the first field. */ + if (TREE_CODE (type) == RECORD_TYPE + && TYPE_IS_PADDING_P (type)) + return get_alias_set (TREE_TYPE (TYPE_FIELDS (type))); + + /* If the type is an unconstrained array, use the type of the + self-referential array we make. */ + else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) + return + get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))))); + + /* If the type can alias any other types, return the alias set 0. */ + else if (TYPE_P (type) + && TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (type))) + return 0; + + return -1; + } + + /* GNU_TYPE is a type. Return its maximum size in bytes, if known, + as a constant when possible. */ + + static tree + gnat_type_max_size (const_tree gnu_type) + { + /* First see what we can get from TYPE_SIZE_UNIT, which might not + be constant even for simple expressions if it has already been + elaborated and possibly replaced by a VAR_DECL. */ + tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true); + + /* If we don't have a constant, see what we can get from TYPE_ADA_SIZE, + which should stay untouched. */ + if (!host_integerp (max_unitsize, 1) + && (TREE_CODE (gnu_type) == RECORD_TYPE + || TREE_CODE (gnu_type) == UNION_TYPE + || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) + && TYPE_ADA_SIZE (gnu_type)) + { + tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true); + + /* If we have succeeded in finding a constant, round it up to the + type's alignment and return the result in units. */ + if (host_integerp (max_adasize, 1)) + max_unitsize + = size_binop (CEIL_DIV_EXPR, + round_up (max_adasize, TYPE_ALIGN (gnu_type)), + bitsize_unit_node); + } + + return max_unitsize; + } + + /* GNU_TYPE is a type. Determine if it should be passed by reference by + default. */ + + bool + default_pass_by_ref (tree gnu_type) + { + /* We pass aggregates by reference if they are sufficiently large. The + choice of constant here is somewhat arbitrary. We also pass by + reference if the target machine would either pass or return by + reference. Strictly speaking, we need only check the return if this + is an In Out parameter, but it's probably best to err on the side of + passing more things by reference. */ + + if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, 1)) + return true; + + if (targetm.calls.return_in_memory (gnu_type, NULL_TREE)) + return true; + + if (AGGREGATE_TYPE_P (gnu_type) + && (!host_integerp (TYPE_SIZE (gnu_type), 1) + || 0 < compare_tree_int (TYPE_SIZE (gnu_type), + 8 * TYPE_ALIGN (gnu_type)))) + return true; + + return false; + } + + /* GNU_TYPE is the type of a subprogram parameter. Determine from the type if + it should be passed by reference. */ + + bool + must_pass_by_ref (tree gnu_type) + { + /* We pass only unconstrained objects, those required by the language + to be passed by reference, and objects of variable size. The latter + is more efficient, avoids problems with variable size temporaries, + and does not produce compatibility problems with C, since C does + not have such objects. */ + return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE + || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type)) + || (TYPE_SIZE (gnu_type) + && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST)); + } + + /* This function is called by the front end to enumerate all the supported + modes for the machine. We pass a function which is called back with + the following integer parameters: + + FLOAT_P nonzero if this represents a floating-point mode + COMPLEX_P nonzero is this represents a complex mode + COUNT count of number of items, nonzero for vector mode + PRECISION number of bits in data representation + MANTISSA number of bits in mantissa, if FP and known, else zero. + SIZE number of bits used to store data + ALIGN number of bits to which mode is aligned. */ + + void + enumerate_modes (void (*f) (int, int, int, int, int, int, unsigned int)) + { + enum machine_mode i; + + for (i = 0; i < NUM_MACHINE_MODES; i++) + { + enum machine_mode j; + bool float_p = 0; + bool complex_p = 0; + bool vector_p = 0; + bool skip_p = 0; + int mantissa = 0; + enum machine_mode inner_mode = i; + + switch (GET_MODE_CLASS (i)) + { + case MODE_INT: + break; + case MODE_FLOAT: + float_p = 1; + break; + case MODE_COMPLEX_INT: + complex_p = 1; + inner_mode = GET_MODE_INNER (i); + break; + case MODE_COMPLEX_FLOAT: + float_p = 1; + complex_p = 1; + inner_mode = GET_MODE_INNER (i); + break; + case MODE_VECTOR_INT: + vector_p = 1; + inner_mode = GET_MODE_INNER (i); + break; + case MODE_VECTOR_FLOAT: + float_p = 1; + vector_p = 1; + inner_mode = GET_MODE_INNER (i); + break; + default: + skip_p = 1; + } + + /* Skip this mode if it's one the front end doesn't need to know about + (e.g., the CC modes) or if there is no add insn for that mode (or + any wider mode), meaning it is not supported by the hardware. If + this a complex or vector mode, we care about the inner mode. */ + for (j = inner_mode; j != VOIDmode; j = GET_MODE_WIDER_MODE (j)) + if (optab_handler (add_optab, j)->insn_code != CODE_FOR_nothing) + break; + + if (float_p) + { + const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode); + + mantissa = fmt->p; + } + + if (!skip_p && j != VOIDmode) + (*f) (float_p, complex_p, vector_p ? GET_MODE_NUNITS (i) : 0, + GET_MODE_BITSIZE (i), mantissa, + GET_MODE_SIZE (i) * BITS_PER_UNIT, GET_MODE_ALIGNMENT (i)); + } + } + + int + fp_prec_to_size (int prec) + { + enum machine_mode mode; + + for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode; + mode = GET_MODE_WIDER_MODE (mode)) + if (GET_MODE_PRECISION (mode) == prec) + return GET_MODE_BITSIZE (mode); + + gcc_unreachable (); + } + + int + fp_size_to_prec (int size) + { + enum machine_mode mode; + + for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode; + mode = GET_MODE_WIDER_MODE (mode)) + if (GET_MODE_BITSIZE (mode) == size) + return GET_MODE_PRECISION (mode); + + gcc_unreachable (); + } diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/targtyps.c gcc-4.4.0/gcc/ada/gcc-interface/targtyps.c *** gcc-4.3.3/gcc/ada/gcc-interface/targtyps.c Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/targtyps.c Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,224 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * T A R G T Y P S * + * * + * Body * + * * + * Copyright (C) 1992-2009, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + /* Functions for retrieving target types. See Ada package Get_Targ */ + + #include "config.h" + #include "system.h" + #include "coretypes.h" + #include "tm.h" + #include "tree.h" + #include "real.h" + #include "rtl.h" + #include "ada.h" + #include "types.h" + #include "atree.h" + #include "elists.h" + #include "namet.h" + #include "nlists.h" + #include "snames.h" + #include "stringt.h" + #include "uintp.h" + #include "urealp.h" + #include "fe.h" + #include "sinfo.h" + #include "einfo.h" + #include "ada-tree.h" + #include "gigi.h" + + /* If we don't have a specific size for Ada's equivalent of `long', use that + of C. */ + #ifndef ADA_LONG_TYPE_SIZE + #define ADA_LONG_TYPE_SIZE LONG_TYPE_SIZE + #endif + + #ifndef WIDEST_HARDWARE_FP_SIZE + #define WIDEST_HARDWARE_FP_SIZE LONG_DOUBLE_TYPE_SIZE + #endif + + /* The following provide a functional interface for the front end Ada code + to determine the sizes that are used for various C types. */ + + Pos + get_target_bits_per_unit (void) + { + return BITS_PER_UNIT; + } + + Pos + get_target_bits_per_word (void) + { + return BITS_PER_WORD; + } + + Pos + get_target_char_size (void) + { + return CHAR_TYPE_SIZE; + } + + Pos + get_target_wchar_t_size (void) + { + /* We never want wide characters less than "short" in Ada. */ + return MAX (SHORT_TYPE_SIZE, WCHAR_TYPE_SIZE); + } + + Pos + get_target_short_size (void) + { + return SHORT_TYPE_SIZE; + } + + Pos + get_target_int_size (void) + { + return INT_TYPE_SIZE; + } + + Pos + get_target_long_size (void) + { + return ADA_LONG_TYPE_SIZE; + } + + Pos + get_target_long_long_size (void) + { + return LONG_LONG_TYPE_SIZE; + } + + Pos + get_target_float_size (void) + { + return fp_prec_to_size (FLOAT_TYPE_SIZE); + } + + Pos + get_target_double_size (void) + { + return fp_prec_to_size (DOUBLE_TYPE_SIZE); + } + + Pos + get_target_long_double_size (void) + { + return fp_prec_to_size (WIDEST_HARDWARE_FP_SIZE); + } + + + Pos + get_target_pointer_size (void) + { + return POINTER_SIZE; + } + + /* Alignment related values, mapped to attributes for functional and + documentation purposes. */ + + /* Standard'Maximum_Default_Alignment. Maximum alignment that the compiler + might choose by default for a type or object. + + Stricter alignment requests trigger gigi's aligning_type circuitry for + stack objects or objects allocated by the default allocator. */ + + Pos + get_target_maximum_default_alignment (void) + { + return BIGGEST_ALIGNMENT / BITS_PER_UNIT; + } + + /* Standard'Default_Allocator_Alignment. Alignment guaranteed to be honored + by the default allocator (System.Memory.Alloc or malloc if we have no + run-time library at hand). + + Stricter alignment requests trigger gigi's aligning_type circuitry for + objects allocated by the default allocator. */ + + /* ??? Need a way to get info about __gnat_malloc from here (whether it is + handy and what alignment it honors). In the meantime, resort to malloc + considerations only. */ + + Pos + get_target_default_allocator_alignment (void) + { + return MALLOC_ABI_ALIGNMENT / BITS_PER_UNIT; + } + + /* Standard'Maximum_Allowed_Alignment. Maximum alignment that we may + accept for any type or object. */ + + #ifndef MAX_OFILE_ALIGNMENT + #define MAX_OFILE_ALIGNMENT BIGGEST_ALIGNMENT + #endif + + Pos + get_target_maximum_allowed_alignment (void) + { + return MAX_OFILE_ALIGNMENT / BITS_PER_UNIT; + } + + /* Standard'Maximum_Alignment. The single attribute initially made + available, now a synonym of Standard'Maximum_Default_Alignment. */ + + Pos + get_target_maximum_alignment (void) + { + return get_target_maximum_default_alignment (); + } + + #ifndef FLOAT_WORDS_BIG_ENDIAN + #define FLOAT_WORDS_BIG_ENDIAN WORDS_BIG_ENDIAN + #endif + + Nat + get_float_words_be (void) + { + return FLOAT_WORDS_BIG_ENDIAN; + } + + Nat + get_words_be (void) + { + return WORDS_BIG_ENDIAN; + } + + Nat + get_bytes_be (void) + { + return BYTES_BIG_ENDIAN; + } + + Nat + get_bits_be (void) + { + return BITS_BIG_ENDIAN; + } + + Nat + get_strict_alignment (void) + { + return STRICT_ALIGNMENT; + } diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/trans.c gcc-4.4.0/gcc/ada/gcc-interface/trans.c *** gcc-4.3.3/gcc/ada/gcc-interface/trans.c Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/trans.c Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,7403 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * T R A N S * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2009, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + #include "config.h" + #include "system.h" + #include "coretypes.h" + #include "tm.h" + #include "tree.h" + #include "real.h" + #include "flags.h" + #include "toplev.h" + #include "rtl.h" + #include "expr.h" + #include "ggc.h" + #include "cgraph.h" + #include "function.h" + #include "except.h" + #include "debug.h" + #include "output.h" + #include "tree-iterator.h" + #include "gimple.h" + #include "ada.h" + #include "types.h" + #include "atree.h" + #include "elists.h" + #include "namet.h" + #include "nlists.h" + #include "snames.h" + #include "stringt.h" + #include "uintp.h" + #include "urealp.h" + #include "fe.h" + #include "sinfo.h" + #include "einfo.h" + #include "ada-tree.h" + #include "gigi.h" + #include "adadecode.h" + + #include "dwarf2.h" + #include "dwarf2out.h" + + /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca, + for fear of running out of stack space. If we need more, we use xmalloc + instead. */ + #define ALLOCA_THRESHOLD 1000 + + /* Let code below know whether we are targetting VMS without need of + intrusive preprocessor directives. */ + #ifndef TARGET_ABI_OPEN_VMS + #define TARGET_ABI_OPEN_VMS 0 + #endif + + /* For efficient float-to-int rounding, it is necessary to know whether + floating-point arithmetic may use wider intermediate results. + When FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume + floating-point arithmetic does not widen if double precision is emulated. */ + + #ifndef FP_ARITH_MAY_WIDEN + #if defined(HAVE_extendsfdf2) + #define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2 + #else + #define FP_ARITH_MAY_WIDEN 0 + #endif + #endif + + extern char *__gnat_to_canonical_file_spec (char *); + + int max_gnat_nodes; + int number_names; + int number_files; + struct Node *Nodes_Ptr; + Node_Id *Next_Node_Ptr; + Node_Id *Prev_Node_Ptr; + struct Elist_Header *Elists_Ptr; + struct Elmt_Item *Elmts_Ptr; + struct String_Entry *Strings_Ptr; + Char_Code *String_Chars_Ptr; + struct List_Header *List_Headers_Ptr; + + /* Current filename without path. */ + const char *ref_filename; + + /* If true, then gigi is being called on an analyzed but unexpanded + tree, and the only purpose of the call is to properly annotate + types with representation information. */ + bool type_annotate_only; + + /* When not optimizing, we cache the 'First, 'Last and 'Length attributes + of unconstrained array IN parameters to avoid emitting a great deal of + redundant instructions to recompute them each time. */ + struct parm_attr GTY (()) + { + int id; /* GTY doesn't like Entity_Id. */ + int dim; + tree first; + tree last; + tree length; + }; + + typedef struct parm_attr *parm_attr; + + DEF_VEC_P(parm_attr); + DEF_VEC_ALLOC_P(parm_attr,gc); + + struct language_function GTY(()) + { + VEC(parm_attr,gc) *parm_attr_cache; + }; + + #define f_parm_attr_cache \ + DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache + + /* A structure used to gather together information about a statement group. + We use this to gather related statements, for example the "then" part + of a IF. In the case where it represents a lexical scope, we may also + have a BLOCK node corresponding to it and/or cleanups. */ + + struct stmt_group GTY((chain_next ("%h.previous"))) { + struct stmt_group *previous; /* Previous code group. */ + tree stmt_list; /* List of statements for this code group. */ + tree block; /* BLOCK for this code group, if any. */ + tree cleanups; /* Cleanups for this code group, if any. */ + }; + + static GTY(()) struct stmt_group *current_stmt_group; + + /* List of unused struct stmt_group nodes. */ + static GTY((deletable)) struct stmt_group *stmt_group_free_list; + + /* A structure used to record information on elaboration procedures + we've made and need to process. + + ??? gnat_node should be Node_Id, but gengtype gets confused. */ + + struct elab_info GTY((chain_next ("%h.next"))) { + struct elab_info *next; /* Pointer to next in chain. */ + tree elab_proc; /* Elaboration procedure. */ + int gnat_node; /* The N_Compilation_Unit. */ + }; + + static GTY(()) struct elab_info *elab_info_list; + + /* Free list of TREE_LIST nodes used for stacks. */ + static GTY((deletable)) tree gnu_stack_free_list; + + /* List of TREE_LIST nodes representing a stack of exception pointer + variables. TREE_VALUE is the VAR_DECL that stores the address of + the raised exception. Nonzero means we are in an exception + handler. Not used in the zero-cost case. */ + static GTY(()) tree gnu_except_ptr_stack; + + /* List of TREE_LIST nodes used to store the current elaboration procedure + decl. TREE_VALUE is the decl. */ + static GTY(()) tree gnu_elab_proc_stack; + + /* Variable that stores a list of labels to be used as a goto target instead of + a return in some functions. See processing for N_Subprogram_Body. */ + static GTY(()) tree gnu_return_label_stack; + + /* List of TREE_LIST nodes representing a stack of LOOP_STMT nodes. + TREE_VALUE of each entry is the label of the corresponding LOOP_STMT. */ + static GTY(()) tree gnu_loop_label_stack; + + /* List of TREE_LIST nodes representing labels for switch statements. + TREE_VALUE of each entry is the label at the end of the switch. */ + static GTY(()) tree gnu_switch_label_stack; + + /* List of TREE_LIST nodes containing the stacks for N_{Push,Pop}_*_Label. */ + static GTY(()) tree gnu_constraint_error_label_stack; + static GTY(()) tree gnu_storage_error_label_stack; + static GTY(()) tree gnu_program_error_label_stack; + + /* Map GNAT tree codes to GCC tree codes for simple expressions. */ + static enum tree_code gnu_codes[Number_Node_Kinds]; + + /* Current node being treated, in case abort called. */ + Node_Id error_gnat_node; + + static void init_code_table (void); + static void Compilation_Unit_to_gnu (Node_Id); + static void record_code_position (Node_Id); + static void insert_code_for (Node_Id); + static void add_cleanup (tree, Node_Id); + static tree unshare_save_expr (tree *, int *, void *); + static void add_stmt_list (List_Id); + static void push_exception_label_stack (tree *, Entity_Id); + static tree build_stmt_group (List_Id, bool); + static void push_stack (tree *, tree, tree); + static void pop_stack (tree *); + static enum gimplify_status gnat_gimplify_stmt (tree *); + static void elaborate_all_entities (Node_Id); + static void process_freeze_entity (Node_Id); + static void process_inlined_subprograms (Node_Id); + static void process_decls (List_Id, List_Id, Node_Id, bool, bool); + static tree emit_range_check (tree, Node_Id); + static tree emit_index_check (tree, tree, tree, tree); + static tree emit_check (tree, tree, int); + static tree build_unary_op_trapv (enum tree_code, tree, tree); + static tree build_binary_op_trapv (enum tree_code, tree, tree, tree); + static tree convert_with_check (Entity_Id, tree, bool, bool, bool); + static bool smaller_packable_type_p (tree, tree); + static bool addressable_p (tree, tree); + static tree assoc_to_constructor (Entity_Id, Node_Id, tree); + static tree extract_values (tree, tree); + static tree pos_to_constructor (Node_Id, tree, Entity_Id); + static tree maybe_implicit_deref (tree); + static tree gnat_stabilize_reference (tree, bool); + static tree gnat_stabilize_reference_1 (tree, bool); + static void set_expr_location_from_node (tree, Node_Id); + static int lvalue_required_p (Node_Id, tree, int); + + /* Hooks for debug info back-ends, only supported and used in a restricted set + of configurations. */ + static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED; + static const char *decode_name (const char *) ATTRIBUTE_UNUSED; + + /* This is the main program of the back-end. It sets up all the table + structures and then generates code. */ + + void + gigi (Node_Id gnat_root, int max_gnat_node, int number_name, + struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr, + struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr, + struct String_Entry *strings_ptr, Char_Code *string_chars_ptr, + struct List_Header *list_headers_ptr, Nat number_file, + struct File_Info_Type *file_info_ptr, Entity_Id standard_boolean, + Entity_Id standard_integer, Entity_Id standard_long_long_float, + Entity_Id standard_exception_type, Int gigi_operating_mode) + { + Entity_Id gnat_literal; + tree gnu_standard_long_long_float, gnu_standard_exception_type, t; + struct elab_info *info; + int i; + + max_gnat_nodes = max_gnat_node; + number_names = number_name; + number_files = number_file; + Nodes_Ptr = nodes_ptr; + Next_Node_Ptr = next_node_ptr; + Prev_Node_Ptr = prev_node_ptr; + Elists_Ptr = elists_ptr; + Elmts_Ptr = elmts_ptr; + Strings_Ptr = strings_ptr; + String_Chars_Ptr = string_chars_ptr; + List_Headers_Ptr = list_headers_ptr; + + type_annotate_only = (gigi_operating_mode == 1); + + for (i = 0; i < number_files; i++) + { + /* Use the identifier table to make a permanent copy of the filename as + the name table gets reallocated after Gigi returns but before all the + debugging information is output. The __gnat_to_canonical_file_spec + call translates filenames from pragmas Source_Reference that contain + host style syntax not understood by gdb. */ + const char *filename + = IDENTIFIER_POINTER + (get_identifier + (__gnat_to_canonical_file_spec + (Get_Name_String (file_info_ptr[i].File_Name)))); + + /* We rely on the order isomorphism between files and line maps. */ + gcc_assert ((int) line_table->used == i); + + /* We create the line map for a source file at once, with a fixed number + of columns chosen to avoid jumping over the next power of 2. */ + linemap_add (line_table, LC_ENTER, 0, filename, 1); + linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252); + linemap_position_for_column (line_table, 252 - 1); + linemap_add (line_table, LC_LEAVE, 0, NULL, 0); + } + + /* Initialize ourselves. */ + init_code_table (); + init_gnat_to_gnu (); + gnat_compute_largest_alignment (); + init_dummy_type (); + + /* If we are just annotating types, give VOID_TYPE zero sizes to avoid + errors. */ + if (type_annotate_only) + { + TYPE_SIZE (void_type_node) = bitsize_zero_node; + TYPE_SIZE_UNIT (void_type_node) = size_zero_node; + } + + /* If the GNU type extensions to DWARF are available, setup the hooks. */ + #if defined (DWARF2_DEBUGGING_INFO) && defined (DWARF2_GNU_TYPE_EXTENSIONS) + /* We condition the name demangling and the generation of type encoding + strings on -gdwarf+ and always set descriptive types on. */ + if (use_gnu_debug_info_extensions) + { + dwarf2out_set_type_encoding_func (extract_encoding); + dwarf2out_set_demangle_name_func (decode_name); + } + dwarf2out_set_descriptive_type_func (get_parallel_type); + #endif + + /* Enable GNAT stack checking method if needed */ + if (!Stack_Check_Probes_On_Target) + set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode, "_gnat_stack_check")); + + /* Give names and make TYPE_DECLs for common types. */ + create_type_decl (get_identifier (SIZE_TYPE), sizetype, + NULL, false, true, Empty); + create_type_decl (get_identifier ("boolean"), boolean_type_node, + NULL, false, true, Empty); + create_type_decl (get_identifier ("integer"), integer_type_node, + NULL, false, true, Empty); + create_type_decl (get_identifier ("unsigned char"), char_type_node, + NULL, false, true, Empty); + create_type_decl (get_identifier ("long integer"), long_integer_type_node, + NULL, false, true, Empty); + + /* Save the type we made for boolean as the type for Standard.Boolean. */ + save_gnu_tree (Base_Type (standard_boolean), TYPE_NAME (boolean_type_node), + false); + gnat_literal = First_Literal (Base_Type (standard_boolean)); + t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node); + gcc_assert (t == boolean_false_node); + t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE, + boolean_type_node, t, true, false, false, false, + NULL, gnat_literal); + DECL_IGNORED_P (t) = 1; + save_gnu_tree (gnat_literal, t, false); + gnat_literal = Next_Literal (gnat_literal); + t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node); + gcc_assert (t == boolean_true_node); + t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE, + boolean_type_node, t, true, false, false, false, + NULL, gnat_literal); + DECL_IGNORED_P (t) = 1; + save_gnu_tree (gnat_literal, t, false); + + /* Save the type we made for integer as the type for Standard.Integer. + Then make the rest of the standard types. Note that some of these + may be subtypes. */ + save_gnu_tree (Base_Type (standard_integer), TYPE_NAME (integer_type_node), + false); + + gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); + gnu_constraint_error_label_stack + = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); + gnu_storage_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); + gnu_program_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); + + gnu_standard_long_long_float + = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0); + gnu_standard_exception_type + = gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0); + + init_gigi_decls (gnu_standard_long_long_float, gnu_standard_exception_type); + + /* Process any Pragma Ident for the main unit. */ + #ifdef ASM_OUTPUT_IDENT + if (Present (Ident_String (Main_Unit))) + ASM_OUTPUT_IDENT + (asm_out_file, + TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit)))); + #endif + + /* If we are using the GCC exception mechanism, let GCC know. */ + if (Exception_Mechanism == Back_End_Exceptions) + gnat_init_gcc_eh (); + + gcc_assert (Nkind (gnat_root) == N_Compilation_Unit); + + /* Declare the name of the compilation unit as the first global + name in order to make the middle-end fully deterministic. */ + t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL); + first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t)); + + /* Now translate the compilation unit proper. */ + start_stmt_group (); + Compilation_Unit_to_gnu (gnat_root); + + /* Finally see if we have any elaboration procedures to deal with. */ + for (info = elab_info_list; info; info = info->next) + { + tree gnu_body = DECL_SAVED_TREE (info->elab_proc); + + /* Unshare SAVE_EXPRs between subprograms. These are not unshared by + the gimplifier for obvious reasons, but it turns out that we need to + unshare them for the global level because of SAVE_EXPRs made around + checks for global objects and around allocators for global objects + of variable size, in order to prevent node sharing in the underlying + expression. Note that this implicitly assumes that the SAVE_EXPR + nodes themselves are not shared between subprograms, which would be + an upstream bug for which we would not change the outcome. */ + walk_tree_without_duplicates (&gnu_body, unshare_save_expr, NULL); + + /* Process the function as others, but for indicating this is an + elab proc, to be discarded if empty, then propagate the status + up to the GNAT tree node. */ + begin_subprog_body (info->elab_proc); + end_subprog_body (gnu_body, true); + + if (empty_body_p (gimple_body (info->elab_proc))) + Set_Has_No_Elaboration_Code (info->gnat_node, 1); + } + + /* We cannot track the location of errors past this point. */ + error_gnat_node = Empty; + } + + /* Return a positive value if an lvalue is required for GNAT_NODE. + GNU_TYPE is the type that will be used for GNAT_NODE in the + translated GNU tree. ALIASED indicates whether the underlying + object represented by GNAT_NODE is aliased in the Ada sense. + + The function climbs up the GNAT tree starting from the node and + returns 1 upon encountering a node that effectively requires an + lvalue downstream. It returns int instead of bool to facilitate + usage in non purely binary logic contexts. */ + + static int + lvalue_required_p (Node_Id gnat_node, tree gnu_type, int aliased) + { + Node_Id gnat_parent = Parent (gnat_node), gnat_temp; + + switch (Nkind (gnat_parent)) + { + case N_Reference: + return 1; + + case N_Attribute_Reference: + { + unsigned char id = Get_Attribute_Id (Attribute_Name (gnat_parent)); + return id == Attr_Address + || id == Attr_Access + || id == Attr_Unchecked_Access + || id == Attr_Unrestricted_Access; + } + + case N_Parameter_Association: + case N_Function_Call: + case N_Procedure_Call_Statement: + return (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type)); + + case N_Indexed_Component: + /* Only the array expression can require an lvalue. */ + if (Prefix (gnat_parent) != gnat_node) + return 0; + + /* ??? Consider that referencing an indexed component with a + non-constant index forces the whole aggregate to memory. + Note that N_Integer_Literal is conservative, any static + expression in the RM sense could probably be accepted. */ + for (gnat_temp = First (Expressions (gnat_parent)); + Present (gnat_temp); + gnat_temp = Next (gnat_temp)) + if (Nkind (gnat_temp) != N_Integer_Literal) + return 1; + + /* ... fall through ... */ + + case N_Slice: + /* Only the array expression can require an lvalue. */ + if (Prefix (gnat_parent) != gnat_node) + return 0; + + aliased |= Has_Aliased_Components (Etype (gnat_node)); + return lvalue_required_p (gnat_parent, gnu_type, aliased); + + case N_Selected_Component: + aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent))); + return lvalue_required_p (gnat_parent, gnu_type, aliased); + + case N_Object_Renaming_Declaration: + /* We need to make a real renaming only if the constant object is + aliased or if we may use a renaming pointer; otherwise we can + optimize and return the rvalue. We make an exception if the object + is an identifier since in this case the rvalue can be propagated + attached to the CONST_DECL. */ + return (aliased != 0 + /* This should match the constant case of the renaming code. */ + || Is_Composite_Type (Etype (Name (gnat_parent))) + || Nkind (Name (gnat_parent)) == N_Identifier); + + default: + return 0; + } + + gcc_unreachable (); + } + + /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier, + to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer + to where we should place the result type. */ + + static tree + Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) + { + Node_Id gnat_temp, gnat_temp_type; + tree gnu_result, gnu_result_type; + + /* Whether we should require an lvalue for GNAT_NODE. Needed in + specific circumstances only, so evaluated lazily. < 0 means + unknown, > 0 means known true, 0 means known false. */ + int require_lvalue = -1; + + /* If GNAT_NODE is a constant, whether we should use the initialization + value instead of the constant entity, typically for scalars with an + address clause when the parent doesn't require an lvalue. */ + bool use_constant_initializer = false; + + /* If the Etype of this node does not equal the Etype of the Entity, + something is wrong with the entity map, probably in generic + instantiation. However, this does not apply to types. Since we sometime + have strange Ekind's, just do this test for objects. Also, if the Etype of + the Entity is private, the Etype of the N_Identifier is allowed to be the + full type and also we consider a packed array type to be the same as the + original type. Similarly, a class-wide type is equivalent to a subtype of + itself. Finally, if the types are Itypes, one may be a copy of the other, + which is also legal. */ + gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier + ? gnat_node : Entity (gnat_node)); + gnat_temp_type = Etype (gnat_temp); + + gcc_assert (Etype (gnat_node) == gnat_temp_type + || (Is_Packed (gnat_temp_type) + && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type)) + || (Is_Class_Wide_Type (Etype (gnat_node))) + || (IN (Ekind (gnat_temp_type), Private_Kind) + && Present (Full_View (gnat_temp_type)) + && ((Etype (gnat_node) == Full_View (gnat_temp_type)) + || (Is_Packed (Full_View (gnat_temp_type)) + && (Etype (gnat_node) + == Packed_Array_Type (Full_View + (gnat_temp_type)))))) + || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type)) + || !(Ekind (gnat_temp) == E_Variable + || Ekind (gnat_temp) == E_Component + || Ekind (gnat_temp) == E_Constant + || Ekind (gnat_temp) == E_Loop_Parameter + || IN (Ekind (gnat_temp), Formal_Kind))); + + /* If this is a reference to a deferred constant whose partial view is an + unconstrained private type, the proper type is on the full view of the + constant, not on the full view of the type, which may be unconstrained. + + This may be a reference to a type, for example in the prefix of the + attribute Position, generated for dispatching code (see Make_DT in + exp_disp,adb). In that case we need the type itself, not is parent, + in particular if it is a derived type */ + if (Is_Private_Type (gnat_temp_type) + && Has_Unknown_Discriminants (gnat_temp_type) + && Ekind (gnat_temp) == E_Constant + && Present (Full_View (gnat_temp))) + { + gnat_temp = Full_View (gnat_temp); + gnat_temp_type = Etype (gnat_temp); + } + else + { + /* We want to use the Actual_Subtype if it has already been elaborated, + otherwise the Etype. Avoid using Actual_Subtype for packed arrays to + simplify things. */ + if ((Ekind (gnat_temp) == E_Constant + || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp)) + && !(Is_Array_Type (Etype (gnat_temp)) + && Present (Packed_Array_Type (Etype (gnat_temp)))) + && Present (Actual_Subtype (gnat_temp)) + && present_gnu_tree (Actual_Subtype (gnat_temp))) + gnat_temp_type = Actual_Subtype (gnat_temp); + else + gnat_temp_type = Etype (gnat_node); + } + + /* Expand the type of this identifier first, in case it is an enumeral + literal, which only get made when the type is expanded. There is no + order-of-elaboration issue here. */ + gnu_result_type = get_unpadded_type (gnat_temp_type); + + /* If this is a non-imported scalar constant with an address clause, + retrieve the value instead of a pointer to be dereferenced unless + an lvalue is required. This is generally more efficient and actually + required if this is a static expression because it might be used + in a context where a dereference is inappropriate, such as a case + statement alternative or a record discriminant. There is no possible + volatile-ness short-circuit here since Volatile constants must be imported + per C.6. */ + if (Ekind (gnat_temp) == E_Constant && Is_Scalar_Type (gnat_temp_type) + && !Is_Imported (gnat_temp) + && Present (Address_Clause (gnat_temp))) + { + require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, + Is_Aliased (gnat_temp)); + use_constant_initializer = !require_lvalue; + } + + if (use_constant_initializer) + { + /* If this is a deferred constant, the initializer is attached to + the full view. */ + if (Present (Full_View (gnat_temp))) + gnat_temp = Full_View (gnat_temp); + + gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp))); + } + else + gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0); + + /* If we are in an exception handler, force this variable into memory to + ensure optimization does not remove stores that appear redundant but are + actually needed in case an exception occurs. + + ??? Note that we need not do this if the variable is declared within the + handler, only if it is referenced in the handler and declared in an + enclosing block, but we have no way of testing that right now. + + ??? We used to essentially set the TREE_ADDRESSABLE flag on the variable + here, but it can now be removed by the Tree aliasing machinery if the + address of the variable is never taken. All we can do is to make the + variable volatile, which might incur the generation of temporaries just + to access the memory in some circumstances. This can be avoided for + variables of non-constant size because they are automatically allocated + to memory. There might be no way of allocating a proper temporary for + them in any case. We only do this for SJLJ though. */ + if (TREE_VALUE (gnu_except_ptr_stack) + && TREE_CODE (gnu_result) == VAR_DECL + && TREE_CODE (DECL_SIZE_UNIT (gnu_result)) == INTEGER_CST) + TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1; + + /* Some objects (such as parameters passed by reference, globals of + variable size, and renamed objects) actually represent the address + of the object. In that case, we must do the dereference. Likewise, + deal with parameters to foreign convention subprograms. */ + if (DECL_P (gnu_result) + && (DECL_BY_REF_P (gnu_result) + || (TREE_CODE (gnu_result) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (gnu_result)))) + { + bool ro = DECL_POINTS_TO_READONLY_P (gnu_result); + tree renamed_obj; + + if (TREE_CODE (gnu_result) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (gnu_result)) + gnu_result + = build_unary_op (INDIRECT_REF, NULL_TREE, + convert (build_pointer_type (gnu_result_type), + gnu_result)); + + /* If it's a renaming pointer and we are at the right binding level, + we can reference the renamed object directly, since the renamed + expression has been protected against multiple evaluations. */ + else if (TREE_CODE (gnu_result) == VAR_DECL + && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) != 0 + && (! DECL_RENAMING_GLOBAL_P (gnu_result) + || global_bindings_p ())) + gnu_result = renamed_obj; + + /* Return the underlying CST for a CONST_DECL like a few lines below, + after dereferencing in this case. */ + else if (TREE_CODE (gnu_result) == CONST_DECL) + gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, + DECL_INITIAL (gnu_result)); + + else + gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); + + TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro; + } + + /* The GNAT tree has the type of a function as the type of its result. Also + use the type of the result if the Etype is a subtype which is nominally + unconstrained. But remove any padding from the resulting type. */ + if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE + || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)) + { + gnu_result_type = TREE_TYPE (gnu_result); + if (TREE_CODE (gnu_result_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_result_type)) + gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type)); + } + + /* If we have a constant declaration and its initializer at hand, + try to return the latter to avoid the need to call fold in lots + of places and the need of elaboration code if this Id is used as + an initializer itself. */ + if (TREE_CONSTANT (gnu_result) + && DECL_P (gnu_result) + && DECL_INITIAL (gnu_result)) + { + tree object + = (TREE_CODE (gnu_result) == CONST_DECL + ? DECL_CONST_CORRESPONDING_VAR (gnu_result) : gnu_result); + + /* If there is a corresponding variable, we only want to return + the CST value if an lvalue is not required. Evaluate this + now if we have not already done so. */ + if (object && require_lvalue < 0) + require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, + Is_Aliased (gnat_temp)); + + if (!object || !require_lvalue) + gnu_result = unshare_expr (DECL_INITIAL (gnu_result)); + } + + *gnu_result_type_p = gnu_result_type; + return gnu_result; + } + + /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return + any statements we generate. */ + + static tree + Pragma_to_gnu (Node_Id gnat_node) + { + Node_Id gnat_temp; + tree gnu_result = alloc_stmt_list (); + + /* Check for (and ignore) unrecognized pragma and do nothing if we are just + annotating types. */ + if (type_annotate_only + || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node)))) + return gnu_result; + + switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))) + { + case Pragma_Inspection_Point: + /* Do nothing at top level: all such variables are already viewable. */ + if (global_bindings_p ()) + break; + + for (gnat_temp = First (Pragma_Argument_Associations (gnat_node)); + Present (gnat_temp); + gnat_temp = Next (gnat_temp)) + { + Node_Id gnat_expr = Expression (gnat_temp); + tree gnu_expr = gnat_to_gnu (gnat_expr); + int use_address; + enum machine_mode mode; + tree asm_constraint = NULL_TREE; + #ifdef ASM_COMMENT_START + char *comment; + #endif + + if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF) + gnu_expr = TREE_OPERAND (gnu_expr, 0); + + /* Use the value only if it fits into a normal register, + otherwise use the address. */ + mode = TYPE_MODE (TREE_TYPE (gnu_expr)); + use_address = ((GET_MODE_CLASS (mode) != MODE_INT + && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT) + || GET_MODE_SIZE (mode) > UNITS_PER_WORD); + + if (use_address) + gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); + + #ifdef ASM_COMMENT_START + comment = concat (ASM_COMMENT_START, + " inspection point: ", + Get_Name_String (Chars (gnat_expr)), + use_address ? " address" : "", + " is in %0", + NULL); + asm_constraint = build_string (strlen (comment), comment); + free (comment); + #endif + gnu_expr = build4 (ASM_EXPR, void_type_node, + asm_constraint, + NULL_TREE, + tree_cons + (build_tree_list (NULL_TREE, + build_string (1, "g")), + gnu_expr, NULL_TREE), + NULL_TREE); + ASM_VOLATILE_P (gnu_expr) = 1; + set_expr_location_from_node (gnu_expr, gnat_node); + append_to_statement_list (gnu_expr, &gnu_result); + } + break; + + case Pragma_Optimize: + switch (Chars (Expression + (First (Pragma_Argument_Associations (gnat_node))))) + { + case Name_Time: case Name_Space: + if (!optimize) + post_error ("insufficient -O value?", gnat_node); + break; + + case Name_Off: + if (optimize) + post_error ("must specify -O0?", gnat_node); + break; + + default: + gcc_unreachable (); + } + break; + + case Pragma_Reviewable: + if (write_symbols == NO_DEBUG) + post_error ("must specify -g?", gnat_node); + break; + } + + return gnu_result; + } + /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Attribute, + to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to + where we should place the result type. ATTRIBUTE is the attribute ID. */ + + static tree + Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) + { + tree gnu_result = error_mark_node; + tree gnu_result_type; + tree gnu_expr; + bool prefix_unused = false; + tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); + tree gnu_type = TREE_TYPE (gnu_prefix); + + /* If the input is a NULL_EXPR, make a new one. */ + if (TREE_CODE (gnu_prefix) == NULL_EXPR) + { + *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); + return build1 (NULL_EXPR, *gnu_result_type_p, + TREE_OPERAND (gnu_prefix, 0)); + } + + switch (attribute) + { + case Attr_Pos: + case Attr_Val: + /* These are just conversions until since representation clauses for + enumerations are handled in the front end. */ + { + bool checkp = Do_Range_Check (First (Expressions (gnat_node))); + + gnu_result = gnat_to_gnu (First (Expressions (gnat_node))); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = convert_with_check (Etype (gnat_node), gnu_result, + checkp, checkp, true); + } + break; + + case Attr_Pred: + case Attr_Succ: + /* These just add or subject the constant 1. Representation clauses for + enumerations are handled in the front-end. */ + gnu_expr = gnat_to_gnu (First (Expressions (gnat_node))); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (Do_Range_Check (First (Expressions (gnat_node)))) + { + gnu_expr = protect_multiple_eval (gnu_expr); + gnu_expr + = emit_check + (build_binary_op (EQ_EXPR, integer_type_node, + gnu_expr, + attribute == Attr_Pred + ? TYPE_MIN_VALUE (gnu_result_type) + : TYPE_MAX_VALUE (gnu_result_type)), + gnu_expr, CE_Range_Check_Failed); + } + + gnu_result + = build_binary_op (attribute == Attr_Pred + ? MINUS_EXPR : PLUS_EXPR, + gnu_result_type, gnu_expr, + convert (gnu_result_type, integer_one_node)); + break; + + case Attr_Address: + case Attr_Unrestricted_Access: + /* Conversions don't change something's address but can cause us to miss + the COMPONENT_REF case below, so strip them off. */ + gnu_prefix = remove_conversions (gnu_prefix, + !Must_Be_Byte_Aligned (gnat_node)); + + /* If we are taking 'Address of an unconstrained object, this is the + pointer to the underlying array. */ + if (attribute == Attr_Address) + gnu_prefix = maybe_unconstrained_array (gnu_prefix); + + /* If we are building a static dispatch table, we have to honor + TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible + with the C++ ABI. We do it in the non-static case as well, + see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */ + else if (TARGET_VTABLE_USES_DESCRIPTORS + && Is_Dispatch_Table_Entity (Etype (gnat_node))) + { + tree gnu_field, gnu_list = NULL_TREE, t; + /* Descriptors can only be built here for top-level functions. */ + bool build_descriptor = (global_bindings_p () != 0); + int i; + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* If we're not going to build the descriptor, we have to retrieve + the one which will be built by the linker (or by the compiler + later if a static chain is requested). */ + if (!build_descriptor) + { + gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix); + gnu_result = fold_convert (build_pointer_type (gnu_result_type), + gnu_result); + gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result); + } + + for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0; + i < TARGET_VTABLE_USES_DESCRIPTORS; + gnu_field = TREE_CHAIN (gnu_field), i++) + { + if (build_descriptor) + { + t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix, + build_int_cst (NULL_TREE, i)); + TREE_CONSTANT (t) = 1; + } + else + t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result, + gnu_field, NULL_TREE); + + gnu_list = tree_cons (gnu_field, t, gnu_list); + } + + gnu_result = gnat_build_constructor (gnu_result_type, gnu_list); + break; + } + + /* ... fall through ... */ + + case Attr_Access: + case Attr_Unchecked_Access: + case Attr_Code_Address: + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result + = build_unary_op (((attribute == Attr_Address + || attribute == Attr_Unrestricted_Access) + && !Must_Be_Byte_Aligned (gnat_node)) + ? ATTR_ADDR_EXPR : ADDR_EXPR, + gnu_result_type, gnu_prefix); + + /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we + don't try to build a trampoline. */ + if (attribute == Attr_Code_Address) + { + for (gnu_expr = gnu_result; + CONVERT_EXPR_P (gnu_expr); + gnu_expr = TREE_OPERAND (gnu_expr, 0)) + TREE_CONSTANT (gnu_expr) = 1; + + if (TREE_CODE (gnu_expr) == ADDR_EXPR) + TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1; + } + + /* For other address attributes applied to a nested function, + find an inner ADDR_EXPR and annotate it so that we can issue + a useful warning with -Wtrampolines. */ + else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE) + { + for (gnu_expr = gnu_result; + CONVERT_EXPR_P (gnu_expr); + gnu_expr = TREE_OPERAND (gnu_expr, 0)) + ; + + if (TREE_CODE (gnu_expr) == ADDR_EXPR + && decl_function_context (TREE_OPERAND (gnu_expr, 0))) + { + set_expr_location_from_node (gnu_expr, gnat_node); + + /* Check that we're not violating the No_Implicit_Dynamic_Code + restriction. Be conservative if we don't know anything + about the trampoline strategy for the target. */ + Check_Implicit_Dynamic_Code_Allowed (gnat_node); + } + } + break; + + case Attr_Pool_Address: + { + tree gnu_obj_type; + tree gnu_ptr = gnu_prefix; + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* If this is an unconstrained array, we know the object must have been + allocated with the template in front of the object. So compute the + template address.*/ + if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) + gnu_ptr + = convert (build_pointer_type + (TYPE_OBJECT_RECORD_TYPE + (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))), + gnu_ptr); + + gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr)); + if (TREE_CODE (gnu_obj_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type)) + { + tree gnu_char_ptr_type = build_pointer_type (char_type_node); + tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type)); + tree gnu_byte_offset + = convert (sizetype, + size_diffop (size_zero_node, gnu_pos)); + gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset); + + gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr); + gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type, + gnu_ptr, gnu_byte_offset); + } + + gnu_result = convert (gnu_result_type, gnu_ptr); + } + break; + + case Attr_Size: + case Attr_Object_Size: + case Attr_Value_Size: + case Attr_Max_Size_In_Storage_Elements: + gnu_expr = gnu_prefix; + + /* Remove NOPS from gnu_expr and conversions from gnu_prefix. + We only use GNU_EXPR to see if a COMPONENT_REF was involved. */ + while (TREE_CODE (gnu_expr) == NOP_EXPR) + gnu_expr = TREE_OPERAND (gnu_expr, 0); + + gnu_prefix = remove_conversions (gnu_prefix, true); + prefix_unused = true; + gnu_type = TREE_TYPE (gnu_prefix); + + /* Replace an unconstrained array type with the type of the underlying + array. We can't do this with a call to maybe_unconstrained_array + since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements, + use the record type that will be used to allocate the object and its + template. */ + if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + { + gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type); + if (attribute != Attr_Max_Size_In_Storage_Elements) + gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); + } + + /* If we're looking for the size of a field, return the field size. + Otherwise, if the prefix is an object, or if 'Object_Size or + 'Max_Size_In_Storage_Elements has been specified, the result is the + GCC size of the type. Otherwise, the result is the RM_Size of the + type. */ + if (TREE_CODE (gnu_prefix) == COMPONENT_REF) + gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1)); + else if (TREE_CODE (gnu_prefix) != TYPE_DECL + || attribute == Attr_Object_Size + || attribute == Attr_Max_Size_In_Storage_Elements) + { + /* If this is a padded type, the GCC size isn't relevant to the + programmer. Normally, what we want is the RM_Size, which was set + from the specified size, but if it was not set, we want the size + of the relevant field. Using the MAX of those two produces the + right result in all case. Don't use the size of the field if it's + a self-referential type, since that's never what's wanted. */ + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_type) + && TREE_CODE (gnu_expr) == COMPONENT_REF) + { + gnu_result = rm_size (gnu_type); + if (!(CONTAINS_PLACEHOLDER_P + (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))) + gnu_result + = size_binop (MAX_EXPR, gnu_result, + DECL_SIZE (TREE_OPERAND (gnu_expr, 1))); + } + else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference) + { + Node_Id gnat_deref = Prefix (gnat_node); + Node_Id gnat_actual_subtype = Actual_Designated_Subtype (gnat_deref); + tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref))); + if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type) + && Present (gnat_actual_subtype)) + { + tree gnu_actual_obj_type = gnat_to_gnu_type (gnat_actual_subtype); + gnu_type = build_unc_object_type_from_ptr (gnu_ptr_type, + gnu_actual_obj_type, get_identifier ("SIZE")); + } + + gnu_result = TYPE_SIZE (gnu_type); + } + else + gnu_result = TYPE_SIZE (gnu_type); + } + else + gnu_result = rm_size (gnu_type); + + gcc_assert (gnu_result); + + /* Deal with a self-referential size by returning the maximum size for a + type and by qualifying the size with the object for 'Size of an + object. */ + if (CONTAINS_PLACEHOLDER_P (gnu_result)) + { + if (TREE_CODE (gnu_prefix) != TYPE_DECL) + gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr); + else + gnu_result = max_size (gnu_result, true); + } + + /* If the type contains a template, subtract its size. */ + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) + gnu_result = size_binop (MINUS_EXPR, gnu_result, + DECL_SIZE (TYPE_FIELDS (gnu_type))); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* Always perform division using unsigned arithmetic as the size cannot + be negative, but may be an overflowed positive value. This provides + correct results for sizes up to 512 MB. + + ??? Size should be calculated in storage elements directly. */ + + if (attribute == Attr_Max_Size_In_Storage_Elements) + gnu_result = convert (sizetype, + fold_build2 (CEIL_DIV_EXPR, bitsizetype, + gnu_result, bitsize_unit_node)); + break; + + case Attr_Alignment: + if (TREE_CODE (gnu_prefix) == COMPONENT_REF + && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) + == RECORD_TYPE) + && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) + gnu_prefix = TREE_OPERAND (gnu_prefix, 0); + + gnu_type = TREE_TYPE (gnu_prefix); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + prefix_unused = true; + + gnu_result = size_int ((TREE_CODE (gnu_prefix) == COMPONENT_REF + ? DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) + : TYPE_ALIGN (gnu_type)) / BITS_PER_UNIT); + break; + + case Attr_First: + case Attr_Last: + case Attr_Range_Length: + prefix_unused = true; + + if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE) + { + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (attribute == Attr_First) + gnu_result = TYPE_MIN_VALUE (gnu_type); + else if (attribute == Attr_Last) + gnu_result = TYPE_MAX_VALUE (gnu_type); + else + gnu_result + = build_binary_op + (MAX_EXPR, get_base_type (gnu_result_type), + build_binary_op + (PLUS_EXPR, get_base_type (gnu_result_type), + build_binary_op (MINUS_EXPR, + get_base_type (gnu_result_type), + convert (gnu_result_type, + TYPE_MAX_VALUE (gnu_type)), + convert (gnu_result_type, + TYPE_MIN_VALUE (gnu_type))), + convert (gnu_result_type, integer_one_node)), + convert (gnu_result_type, integer_zero_node)); + + break; + } + + /* ... fall through ... */ + + case Attr_Length: + { + int Dimension = (Present (Expressions (gnat_node)) + ? UI_To_Int (Intval (First (Expressions (gnat_node)))) + : 1), i; + struct parm_attr *pa = NULL; + Entity_Id gnat_param = Empty; + + /* Make sure any implicit dereference gets done. */ + gnu_prefix = maybe_implicit_deref (gnu_prefix); + gnu_prefix = maybe_unconstrained_array (gnu_prefix); + /* We treat unconstrained array In parameters specially. */ + if (Nkind (Prefix (gnat_node)) == N_Identifier + && !Is_Constrained (Etype (Prefix (gnat_node))) + && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter) + gnat_param = Entity (Prefix (gnat_node)); + gnu_type = TREE_TYPE (gnu_prefix); + prefix_unused = true; + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (TYPE_CONVENTION_FORTRAN_P (gnu_type)) + { + int ndim; + tree gnu_type_temp; + + for (ndim = 1, gnu_type_temp = gnu_type; + TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp)); + ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp)) + ; + + Dimension = ndim + 1 - Dimension; + } + + for (i = 1; i < Dimension; i++) + gnu_type = TREE_TYPE (gnu_type); + + gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); + + /* When not optimizing, look up the slot associated with the parameter + and the dimension in the cache and create a new one on failure. */ + if (!optimize && Present (gnat_param)) + { + for (i = 0; VEC_iterate (parm_attr, f_parm_attr_cache, i, pa); i++) + if (pa->id == gnat_param && pa->dim == Dimension) + break; + + if (!pa) + { + pa = GGC_CNEW (struct parm_attr); + pa->id = gnat_param; + pa->dim = Dimension; + VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa); + } + } + + /* Return the cached expression or build a new one. */ + if (attribute == Attr_First) + { + if (pa && pa->first) + { + gnu_result = pa->first; + break; + } + + gnu_result + = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); + } + + else if (attribute == Attr_Last) + { + if (pa && pa->last) + { + gnu_result = pa->last; + break; + } + + gnu_result + = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); + } + + else /* attribute == Attr_Range_Length || attribute == Attr_Length */ + { + if (pa && pa->length) + { + gnu_result = pa->length; + break; + } + else + { + /* We used to compute the length as max (hb - lb + 1, 0), + which could overflow for some cases of empty arrays, e.g. + when lb == index_type'first. We now compute the length as + (hb < lb) ? 0 : hb - lb + 1, which would only overflow in + much rarer cases, for extremely large arrays we expect + never to encounter in practice. In addition, the former + computation required the use of potentially constraining + signed arithmetic while the latter doesn't. Note that the + comparison must be done in the original index base type, + otherwise the conversion of either bound to gnu_compute_type + may overflow. */ + + tree gnu_compute_type = get_base_type (gnu_result_type); + + tree index_type + = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)); + tree lb + = convert (gnu_compute_type, TYPE_MIN_VALUE (index_type)); + tree hb + = convert (gnu_compute_type, TYPE_MAX_VALUE (index_type)); + + gnu_result + = build3 + (COND_EXPR, gnu_compute_type, + build_binary_op (LT_EXPR, get_base_type (index_type), + TYPE_MAX_VALUE (index_type), + TYPE_MIN_VALUE (index_type)), + convert (gnu_compute_type, integer_zero_node), + build_binary_op + (PLUS_EXPR, gnu_compute_type, + build_binary_op (MINUS_EXPR, gnu_compute_type, hb, lb), + convert (gnu_compute_type, integer_one_node))); + } + } + + /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are + handling. Note that these attributes could not have been used on + an unconstrained array type. */ + gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, + gnu_prefix); + + /* Cache the expression we have just computed. Since we want to do it + at runtime, we force the use of a SAVE_EXPR and let the gimplifier + create the temporary. */ + if (pa) + { + gnu_result + = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result); + TREE_SIDE_EFFECTS (gnu_result) = 1; + if (attribute == Attr_First) + pa->first = gnu_result; + else if (attribute == Attr_Last) + pa->last = gnu_result; + else + pa->length = gnu_result; + } + break; + } + + case Attr_Bit_Position: + case Attr_Position: + case Attr_First_Bit: + case Attr_Last_Bit: + case Attr_Bit: + { + HOST_WIDE_INT bitsize; + HOST_WIDE_INT bitpos; + tree gnu_offset; + tree gnu_field_bitpos; + tree gnu_field_offset; + tree gnu_inner; + enum machine_mode mode; + int unsignedp, volatilep; + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_prefix = remove_conversions (gnu_prefix, true); + prefix_unused = true; + + /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF, + the result is 0. Don't allow 'Bit on a bare component, though. */ + if (attribute == Attr_Bit + && TREE_CODE (gnu_prefix) != COMPONENT_REF + && TREE_CODE (gnu_prefix) != FIELD_DECL) + { + gnu_result = integer_zero_node; + break; + } + + else + gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF + || (attribute == Attr_Bit_Position + && TREE_CODE (gnu_prefix) == FIELD_DECL)); + + get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset, + &mode, &unsignedp, &volatilep, false); + + if (TREE_CODE (gnu_prefix) == COMPONENT_REF) + { + gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1)); + gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1)); + + for (gnu_inner = TREE_OPERAND (gnu_prefix, 0); + TREE_CODE (gnu_inner) == COMPONENT_REF + && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1)); + gnu_inner = TREE_OPERAND (gnu_inner, 0)) + { + gnu_field_bitpos + = size_binop (PLUS_EXPR, gnu_field_bitpos, + bit_position (TREE_OPERAND (gnu_inner, 1))); + gnu_field_offset + = size_binop (PLUS_EXPR, gnu_field_offset, + byte_position (TREE_OPERAND (gnu_inner, 1))); + } + } + else if (TREE_CODE (gnu_prefix) == FIELD_DECL) + { + gnu_field_bitpos = bit_position (gnu_prefix); + gnu_field_offset = byte_position (gnu_prefix); + } + else + { + gnu_field_bitpos = bitsize_zero_node; + gnu_field_offset = size_zero_node; + } + + switch (attribute) + { + case Attr_Position: + gnu_result = gnu_field_offset; + break; + + case Attr_First_Bit: + case Attr_Bit: + gnu_result = size_int (bitpos % BITS_PER_UNIT); + break; + + case Attr_Last_Bit: + gnu_result = bitsize_int (bitpos % BITS_PER_UNIT); + gnu_result = size_binop (PLUS_EXPR, gnu_result, + TYPE_SIZE (TREE_TYPE (gnu_prefix))); + gnu_result = size_binop (MINUS_EXPR, gnu_result, + bitsize_one_node); + break; + + case Attr_Bit_Position: + gnu_result = gnu_field_bitpos; + break; + } + + /* If this has a PLACEHOLDER_EXPR, qualify it by the object + we are handling. */ + gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); + break; + } + + case Attr_Min: + case Attr_Max: + { + tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node))); + tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node)))); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = build_binary_op (attribute == Attr_Min + ? MIN_EXPR : MAX_EXPR, + gnu_result_type, gnu_lhs, gnu_rhs); + } + break; + + case Attr_Passed_By_Reference: + gnu_result = size_int (default_pass_by_ref (gnu_type) + || must_pass_by_ref (gnu_type)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; + + case Attr_Component_Size: + if (TREE_CODE (gnu_prefix) == COMPONENT_REF + && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) + == RECORD_TYPE) + && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) + gnu_prefix = TREE_OPERAND (gnu_prefix, 0); + + gnu_prefix = maybe_implicit_deref (gnu_prefix); + gnu_type = TREE_TYPE (gnu_prefix); + + if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type)))); + + while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) + gnu_type = TREE_TYPE (gnu_type); + + gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); + + /* Note this size cannot be self-referential. */ + gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + prefix_unused = true; + break; + + case Attr_Null_Parameter: + /* This is just a zero cast to the pointer type for + our prefix and dereferenced. */ + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result + = build_unary_op (INDIRECT_REF, NULL_TREE, + convert (build_pointer_type (gnu_result_type), + integer_zero_node)); + TREE_PRIVATE (gnu_result) = 1; + break; + + case Attr_Mechanism_Code: + { + int code; + Entity_Id gnat_obj = Entity (Prefix (gnat_node)); + + prefix_unused = true; + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + if (Present (Expressions (gnat_node))) + { + int i = UI_To_Int (Intval (First (Expressions (gnat_node)))); + + for (gnat_obj = First_Formal (gnat_obj); i > 1; + i--, gnat_obj = Next_Formal (gnat_obj)) + ; + } + + code = Mechanism (gnat_obj); + if (code == Default) + code = ((present_gnu_tree (gnat_obj) + && (DECL_BY_REF_P (get_gnu_tree (gnat_obj)) + || ((TREE_CODE (get_gnu_tree (gnat_obj)) + == PARM_DECL) + && (DECL_BY_COMPONENT_PTR_P + (get_gnu_tree (gnat_obj)))))) + ? By_Reference : By_Copy); + gnu_result = convert (gnu_result_type, size_int (- code)); + } + break; + + default: + /* Say we have an unimplemented attribute. Then set the value to be + returned to be a zero and hope that's something we can convert to the + type of this attribute. */ + post_error ("unimplemented attribute", gnat_node); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = integer_zero_node; + break; + } + + /* If this is an attribute where the prefix was unused, force a use of it if + it has a side-effect. But don't do it if the prefix is just an entity + name. However, if an access check is needed, we must do it. See second + example in AARM 11.6(5.e). */ + if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix) + && !Is_Entity_Name (Prefix (gnat_node))) + gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result), + gnu_prefix, gnu_result); + + *gnu_result_type_p = gnu_result_type; + return gnu_result; + } + + /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement, + to a GCC tree, which is returned. */ + + static tree + Case_Statement_to_gnu (Node_Id gnat_node) + { + tree gnu_result; + tree gnu_expr; + Node_Id gnat_when; + + gnu_expr = gnat_to_gnu (Expression (gnat_node)); + gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); + + /* The range of values in a case statement is determined by the rules in + RM 5.4(7-9). In almost all cases, this range is represented by the Etype + of the expression. One exception arises in the case of a simple name that + is parenthesized. This still has the Etype of the name, but since it is + not a name, para 7 does not apply, and we need to go to the base type. + This is the only case where parenthesization affects the dynamic + semantics (i.e. the range of possible values at runtime that is covered + by the others alternative. + + Another exception is if the subtype of the expression is non-static. In + that case, we also have to use the base type. */ + if (Paren_Count (Expression (gnat_node)) != 0 + || !Is_OK_Static_Subtype (Underlying_Type + (Etype (Expression (gnat_node))))) + gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); + + /* We build a SWITCH_EXPR that contains the code with interspersed + CASE_LABEL_EXPRs for each label. */ + + push_stack (&gnu_switch_label_stack, NULL_TREE, create_artificial_label ()); + start_stmt_group (); + for (gnat_when = First_Non_Pragma (Alternatives (gnat_node)); + Present (gnat_when); + gnat_when = Next_Non_Pragma (gnat_when)) + { + Node_Id gnat_choice; + int choices_added = 0; + + /* First compile all the different case choices for the current WHEN + alternative. */ + for (gnat_choice = First (Discrete_Choices (gnat_when)); + Present (gnat_choice); gnat_choice = Next (gnat_choice)) + { + tree gnu_low = NULL_TREE, gnu_high = NULL_TREE; + + switch (Nkind (gnat_choice)) + { + case N_Range: + gnu_low = gnat_to_gnu (Low_Bound (gnat_choice)); + gnu_high = gnat_to_gnu (High_Bound (gnat_choice)); + break; + + case N_Subtype_Indication: + gnu_low = gnat_to_gnu (Low_Bound (Range_Expression + (Constraint (gnat_choice)))); + gnu_high = gnat_to_gnu (High_Bound (Range_Expression + (Constraint (gnat_choice)))); + break; + + case N_Identifier: + case N_Expanded_Name: + /* This represents either a subtype range or a static value of + some kind; Ekind says which. */ + if (IN (Ekind (Entity (gnat_choice)), Type_Kind)) + { + tree gnu_type = get_unpadded_type (Entity (gnat_choice)); + + gnu_low = fold (TYPE_MIN_VALUE (gnu_type)); + gnu_high = fold (TYPE_MAX_VALUE (gnu_type)); + break; + } + + /* ... fall through ... */ + + case N_Character_Literal: + case N_Integer_Literal: + gnu_low = gnat_to_gnu (gnat_choice); + break; + + case N_Others_Choice: + break; + + default: + gcc_unreachable (); + } + + /* If the case value is a subtype that raises Constraint_Error at + run-time because of a wrong bound, then gnu_low or gnu_high is + not translated into an INTEGER_CST. In such a case, we need + to ensure that the when statement is not added in the tree, + otherwise it will crash the gimplifier. */ + if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST) + && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST)) + { + add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node, + gnu_low, gnu_high, + create_artificial_label ()), + gnat_choice); + choices_added++; + } + } + + /* Push a binding level here in case variables are declared as we want + them to be local to this set of statements instead of to the block + containing the Case statement. */ + if (choices_added > 0) + { + add_stmt (build_stmt_group (Statements (gnat_when), true)); + add_stmt (build1 (GOTO_EXPR, void_type_node, + TREE_VALUE (gnu_switch_label_stack))); + } + } + + /* Now emit a definition of the label all the cases branched to. */ + add_stmt (build1 (LABEL_EXPR, void_type_node, + TREE_VALUE (gnu_switch_label_stack))); + gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr, + end_stmt_group (), NULL_TREE); + pop_stack (&gnu_switch_label_stack); + + return gnu_result; + } + + /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement, + to a GCC tree, which is returned. */ + + static tree + Loop_Statement_to_gnu (Node_Id gnat_node) + { + /* ??? It would be nice to use "build" here, but there's no build5. */ + tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, NULL_TREE); + tree gnu_loop_var = NULL_TREE; + Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node); + tree gnu_cond_expr = NULL_TREE; + tree gnu_result; + + TREE_TYPE (gnu_loop_stmt) = void_type_node; + TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1; + LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label (); + set_expr_location_from_node (gnu_loop_stmt, gnat_node); + Sloc_to_locus (Sloc (End_Label (gnat_node)), + &DECL_SOURCE_LOCATION (LOOP_STMT_LABEL (gnu_loop_stmt))); + + /* Save the end label of this LOOP_STMT in a stack so that the corresponding + N_Exit_Statement can find it. */ + push_stack (&gnu_loop_label_stack, NULL_TREE, + LOOP_STMT_LABEL (gnu_loop_stmt)); + + /* Set the condition under which the loop must keep going. + For the case "LOOP .... END LOOP;" the condition is always true. */ + if (No (gnat_iter_scheme)) + ; + + /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */ + else if (Present (Condition (gnat_iter_scheme))) + LOOP_STMT_TOP_COND (gnu_loop_stmt) + = gnat_to_gnu (Condition (gnat_iter_scheme)); + + /* Otherwise we have an iteration scheme and the condition is given by + the bounds of the subtype of the iteration variable. */ + else + { + Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme); + Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec); + Entity_Id gnat_type = Etype (gnat_loop_var); + tree gnu_type = get_unpadded_type (gnat_type); + tree gnu_low = TYPE_MIN_VALUE (gnu_type); + tree gnu_high = TYPE_MAX_VALUE (gnu_type); + tree gnu_first, gnu_last, gnu_limit; + enum tree_code update_code, end_code; + tree gnu_base_type = get_base_type (gnu_type); + + /* We must disable modulo reduction for the loop variable, if any, + in order for the loop comparison to be effective. */ + if (Reverse_Present (gnat_loop_spec)) + { + gnu_first = gnu_high; + gnu_last = gnu_low; + update_code = MINUS_NOMOD_EXPR; + end_code = GE_EXPR; + gnu_limit = TYPE_MIN_VALUE (gnu_base_type); + } + else + { + gnu_first = gnu_low; + gnu_last = gnu_high; + update_code = PLUS_NOMOD_EXPR; + end_code = LE_EXPR; + gnu_limit = TYPE_MAX_VALUE (gnu_base_type); + } + + /* We know the loop variable will not overflow if GNU_LAST is a constant + and is not equal to GNU_LIMIT. If it might overflow, we have to move + the limit test to the end of the loop. In that case, we have to test + for an empty loop outside the loop. */ + if (TREE_CODE (gnu_last) != INTEGER_CST + || TREE_CODE (gnu_limit) != INTEGER_CST + || tree_int_cst_equal (gnu_last, gnu_limit)) + { + gnu_cond_expr + = build3 (COND_EXPR, void_type_node, + build_binary_op (LE_EXPR, integer_type_node, + gnu_low, gnu_high), + NULL_TREE, alloc_stmt_list ()); + set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec); + } + + /* Open a new nesting level that will surround the loop to declare the + loop index variable. */ + start_stmt_group (); + gnat_pushlevel (); + + /* Declare the loop index and set it to its initial value. */ + gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1); + if (DECL_BY_REF_P (gnu_loop_var)) + gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var); + + /* The loop variable might be a padded type, so use `convert' to get a + reference to the inner variable if so. */ + gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var); + + /* Set either the top or bottom exit condition as appropriate depending + on whether or not we know an overflow cannot occur. */ + if (gnu_cond_expr) + LOOP_STMT_BOT_COND (gnu_loop_stmt) + = build_binary_op (NE_EXPR, integer_type_node, + gnu_loop_var, gnu_last); + else + LOOP_STMT_TOP_COND (gnu_loop_stmt) + = build_binary_op (end_code, integer_type_node, + gnu_loop_var, gnu_last); + + LOOP_STMT_UPDATE (gnu_loop_stmt) + = build_binary_op (MODIFY_EXPR, NULL_TREE, + gnu_loop_var, + build_binary_op (update_code, + TREE_TYPE (gnu_loop_var), + gnu_loop_var, + convert (TREE_TYPE (gnu_loop_var), + integer_one_node))); + set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt), + gnat_iter_scheme); + } + + /* If the loop was named, have the name point to this loop. In this case, + the association is not a ..._DECL node, but the end label from this + LOOP_STMT. */ + if (Present (Identifier (gnat_node))) + save_gnu_tree (Entity (Identifier (gnat_node)), + LOOP_STMT_LABEL (gnu_loop_stmt), true); + + /* Make the loop body into its own block, so any allocated storage will be + released every iteration. This is needed for stack allocation. */ + LOOP_STMT_BODY (gnu_loop_stmt) + = build_stmt_group (Statements (gnat_node), true); + + /* If we declared a variable, then we are in a statement group for that + declaration. Add the LOOP_STMT to it and make that the "loop". */ + if (gnu_loop_var) + { + add_stmt (gnu_loop_stmt); + gnat_poplevel (); + gnu_loop_stmt = end_stmt_group (); + } + + /* If we have an outer COND_EXPR, that's our result and this loop is its + "true" statement. Otherwise, the result is the LOOP_STMT. */ + if (gnu_cond_expr) + { + COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt; + gnu_result = gnu_cond_expr; + recalculate_side_effects (gnu_cond_expr); + } + else + gnu_result = gnu_loop_stmt; + + pop_stack (&gnu_loop_label_stack); + + return gnu_result; + } + + /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition + handler for the current function. */ + + /* This is implemented by issuing a call to the appropriate VMS specific + builtin. To avoid having VMS specific sections in the global gigi decls + array, we maintain the decls of interest here. We can't declare them + inside the function because we must mark them never to be GC'd, which we + can only do at the global level. */ + + static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE; + static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE; + + static void + establish_gnat_vms_condition_handler (void) + { + tree establish_stmt; + + /* Elaborate the required decls on the first call. Check on the decl for + the gnat condition handler to decide, as this is one we create so we are + sure that it will be non null on subsequent calls. The builtin decl is + looked up so remains null on targets where it is not implemented yet. */ + if (gnat_vms_condition_handler_decl == NULL_TREE) + { + vms_builtin_establish_handler_decl + = builtin_decl_for + (get_identifier ("__builtin_establish_vms_condition_handler")); + + gnat_vms_condition_handler_decl + = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"), + NULL_TREE, + build_function_type_list (integer_type_node, + ptr_void_type_node, + ptr_void_type_node, + NULL_TREE), + NULL_TREE, 0, 1, 1, 0, Empty); + } + + /* Do nothing if the establish builtin is not available, which might happen + on targets where the facility is not implemented. */ + if (vms_builtin_establish_handler_decl == NULL_TREE) + return; + + establish_stmt + = build_call_1_expr (vms_builtin_establish_handler_decl, + build_unary_op + (ADDR_EXPR, NULL_TREE, + gnat_vms_condition_handler_decl)); + + add_stmt (establish_stmt); + } + + /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We + don't return anything. */ + + static void + Subprogram_Body_to_gnu (Node_Id gnat_node) + { + /* Defining identifier of a parameter to the subprogram. */ + Entity_Id gnat_param; + /* The defining identifier for the subprogram body. Note that if a + specification has appeared before for this body, then the identifier + occurring in that specification will also be a defining identifier and all + the calls to this subprogram will point to that specification. */ + Entity_Id gnat_subprog_id + = (Present (Corresponding_Spec (gnat_node)) + ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node)); + /* The FUNCTION_DECL node corresponding to the subprogram spec. */ + tree gnu_subprog_decl; + /* The FUNCTION_TYPE node corresponding to the subprogram spec. */ + tree gnu_subprog_type; + tree gnu_cico_list; + tree gnu_result; + VEC(parm_attr,gc) *cache; + + /* If this is a generic object or if it has been eliminated, + ignore it. */ + if (Ekind (gnat_subprog_id) == E_Generic_Procedure + || Ekind (gnat_subprog_id) == E_Generic_Function + || Is_Eliminated (gnat_subprog_id)) + return; + + /* If this subprogram acts as its own spec, define it. Otherwise, just get + the already-elaborated tree node. However, if this subprogram had its + elaboration deferred, we will already have made a tree node for it. So + treat it as not being defined in that case. Such a subprogram cannot + have an address clause or a freeze node, so this test is safe, though it + does disable some otherwise-useful error checking. */ + gnu_subprog_decl + = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, + Acts_As_Spec (gnat_node) + && !present_gnu_tree (gnat_subprog_id)); + + gnu_subprog_type = TREE_TYPE (gnu_subprog_decl); + + /* Propagate the debug mode. */ + if (!Needs_Debug_Info (gnat_subprog_id)) + DECL_IGNORED_P (gnu_subprog_decl) = 1; + + /* Set the line number in the decl to correspond to that of the body so that + the line number notes are written correctly. */ + Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl)); + + /* Initialize the information structure for the function. */ + allocate_struct_function (gnu_subprog_decl, false); + DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language + = GGC_CNEW (struct language_function); + + begin_subprog_body (gnu_subprog_decl); + gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); + + /* If there are Out parameters, we need to ensure that the return statement + properly copies them out. We do this by making a new block and converting + any inner return into a goto to a label at the end of the block. */ + push_stack (&gnu_return_label_stack, NULL_TREE, + gnu_cico_list ? create_artificial_label () : NULL_TREE); + + /* Get a tree corresponding to the code for the subprogram. */ + start_stmt_group (); + gnat_pushlevel (); + + /* See if there are any parameters for which we don't yet have GCC entities. + These must be for Out parameters for which we will be making VAR_DECL + nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty + entry as well. We can match up the entries because TYPE_CI_CO_LIST is in + the order of the parameters. */ + for (gnat_param = First_Formal_With_Extras (gnat_subprog_id); + Present (gnat_param); + gnat_param = Next_Formal_With_Extras (gnat_param)) + if (!present_gnu_tree (gnat_param)) + { + /* Skip any entries that have been already filled in; they must + correspond to In Out parameters. */ + for (; gnu_cico_list && TREE_VALUE (gnu_cico_list); + gnu_cico_list = TREE_CHAIN (gnu_cico_list)) + ; + + /* Do any needed references for padded types. */ + TREE_VALUE (gnu_cico_list) + = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)), + gnat_to_gnu_entity (gnat_param, NULL_TREE, 1)); + } + + /* On VMS, establish our condition handler to possibly turn a condition into + the corresponding exception if the subprogram has a foreign convention or + is exported. + + To ensure proper execution of local finalizations on condition instances, + we must turn a condition into the corresponding exception even if there + is no applicable Ada handler, and need at least one condition handler per + possible call chain involving GNAT code. OTOH, establishing the handler + has a cost so we want to minimize the number of subprograms into which + this happens. The foreign or exported condition is expected to satisfy + all the constraints. */ + if (TARGET_ABI_OPEN_VMS + && (Has_Foreign_Convention (gnat_node) || Is_Exported (gnat_node))) + establish_gnat_vms_condition_handler (); + + process_decls (Declarations (gnat_node), Empty, Empty, true, true); + + /* Generate the code of the subprogram itself. A return statement will be + present and any Out parameters will be handled there. */ + add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); + gnat_poplevel (); + gnu_result = end_stmt_group (); + + /* If we populated the parameter attributes cache, we need to make sure + that the cached expressions are evaluated on all possible paths. */ + cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache; + if (cache) + { + struct parm_attr *pa; + int i; + + start_stmt_group (); + + for (i = 0; VEC_iterate (parm_attr, cache, i, pa); i++) + { + if (pa->first) + add_stmt_with_node (pa->first, gnat_node); + if (pa->last) + add_stmt_with_node (pa->last, gnat_node); + if (pa->length) + add_stmt_with_node (pa->length, gnat_node); + } + + add_stmt (gnu_result); + gnu_result = end_stmt_group (); + } + + /* If we made a special return label, we need to make a block that contains + the definition of that label and the copying to the return value. That + block first contains the function, then the label and copy statement. */ + if (TREE_VALUE (gnu_return_label_stack)) + { + tree gnu_retval; + + start_stmt_group (); + gnat_pushlevel (); + add_stmt (gnu_result); + add_stmt (build1 (LABEL_EXPR, void_type_node, + TREE_VALUE (gnu_return_label_stack))); + + gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); + if (list_length (gnu_cico_list) == 1) + gnu_retval = TREE_VALUE (gnu_cico_list); + else + gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type), + gnu_cico_list); + + if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval)) + gnu_retval = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval); + + add_stmt_with_node + (build_return_expr (DECL_RESULT (gnu_subprog_decl), gnu_retval), + End_Label (Handled_Statement_Sequence (gnat_node))); + gnat_poplevel (); + gnu_result = end_stmt_group (); + } + + pop_stack (&gnu_return_label_stack); + + /* Set the end location. */ + Sloc_to_locus + ((Present (End_Label (Handled_Statement_Sequence (gnat_node))) + ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node))) + : Sloc (gnat_node)), + &DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus); + + end_subprog_body (gnu_result, false); + + /* Disconnect the trees for parameters that we made variables for from the + GNAT entities since these are unusable after we end the function. */ + for (gnat_param = First_Formal_With_Extras (gnat_subprog_id); + Present (gnat_param); + gnat_param = Next_Formal_With_Extras (gnat_param)) + if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL) + save_gnu_tree (gnat_param, NULL_TREE, false); + + if (DECL_FUNCTION_STUB (gnu_subprog_decl)) + build_function_stub (gnu_subprog_decl, gnat_subprog_id); + + mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node))); + } + + /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call + or an N_Procedure_Call_Statement, to a GCC tree, which is returned. + GNU_RESULT_TYPE_P is a pointer to where we should place the result type. + If GNU_TARGET is non-null, this must be a function call and the result + of the call is to be placed into that object. */ + + static tree + call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) + { + tree gnu_result; + /* The GCC node corresponding to the GNAT subprogram name. This can either + be a FUNCTION_DECL node if we are dealing with a standard subprogram call, + or an indirect reference expression (an INDIRECT_REF node) pointing to a + subprogram. */ + tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node)); + /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */ + tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node); + tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_subprog_node); + Entity_Id gnat_formal; + Node_Id gnat_actual; + tree gnu_actual_list = NULL_TREE; + tree gnu_name_list = NULL_TREE; + tree gnu_before_list = NULL_TREE; + tree gnu_after_list = NULL_TREE; + tree gnu_subprog_call; + + switch (Nkind (Name (gnat_node))) + { + case N_Identifier: + case N_Operator_Symbol: + case N_Expanded_Name: + case N_Attribute_Reference: + if (Is_Eliminated (Entity (Name (gnat_node)))) + Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node))); + } + + gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE); + + /* If we are calling a stubbed function, make this into a raise of + Program_Error. Elaborate all our args first. */ + if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL + && DECL_STUBBED_P (gnu_subprog_node)) + { + for (gnat_actual = First_Actual (gnat_node); + Present (gnat_actual); + gnat_actual = Next_Actual (gnat_actual)) + add_stmt (gnat_to_gnu (gnat_actual)); + + { + tree call_expr + = build_call_raise (PE_Stubbed_Subprogram_Called, gnat_node, + N_Raise_Program_Error); + + if (Nkind (gnat_node) == N_Function_Call && !gnu_target) + { + *gnu_result_type_p = TREE_TYPE (gnu_subprog_type); + return build1 (NULL_EXPR, *gnu_result_type_p, call_expr); + } + else + return call_expr; + } + } + + /* If we are calling by supplying a pointer to a target, set up that + pointer as the first argument. Use GNU_TARGET if one was passed; + otherwise, make a target by building a variable of the maximum size + of the type. */ + if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)) + { + tree gnu_real_ret_type + = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type))); + + if (!gnu_target) + { + tree gnu_obj_type + = maybe_pad_type (gnu_real_ret_type, + max_size (TYPE_SIZE (gnu_real_ret_type), true), + 0, Etype (Name (gnat_node)), "PAD", false, + false, false); + + /* ??? We may be about to create a static temporary if we happen to + be at the global binding level. That's a regression from what + the 3.x back-end would generate in the same situation, but we + don't have a mechanism in Gigi for creating automatic variables + in the elaboration routines. */ + gnu_target + = create_var_decl (create_tmp_var_name ("LR"), NULL, gnu_obj_type, + NULL, false, false, false, false, NULL, + gnat_node); + } + + gnu_actual_list + = tree_cons (NULL_TREE, + build_unary_op (ADDR_EXPR, NULL_TREE, + unchecked_convert (gnu_real_ret_type, + gnu_target, + false)), + NULL_TREE); + + } + + /* The only way we can be making a call via an access type is if Name is an + explicit dereference. In that case, get the list of formal args from the + type the access type is pointing to. Otherwise, get the formals from + entity being called. */ + if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) + gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node))); + else if (Nkind (Name (gnat_node)) == N_Attribute_Reference) + /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */ + gnat_formal = 0; + else + gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node))); + + /* Create the list of the actual parameters as GCC expects it, namely a chain + of TREE_LIST nodes in which the TREE_VALUE field of each node is a + parameter-expression and the TREE_PURPOSE field is null. Skip Out + parameters not passed by reference and don't need to be copied in. */ + for (gnat_actual = First_Actual (gnat_node); + Present (gnat_actual); + gnat_formal = Next_Formal_With_Extras (gnat_formal), + gnat_actual = Next_Actual (gnat_actual)) + { + tree gnu_formal + = (present_gnu_tree (gnat_formal) + ? get_gnu_tree (gnat_formal) : NULL_TREE); + tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal)); + /* We must suppress conversions that can cause the creation of a + temporary in the Out or In Out case because we need the real + object in this case, either to pass its address if it's passed + by reference or as target of the back copy done after the call + if it uses the copy-in copy-out mechanism. We do it in the In + case too, except for an unchecked conversion because it alone + can cause the actual to be misaligned and the addressability + test is applied to the real object. */ + bool suppress_type_conversion + = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion + && Ekind (gnat_formal) != E_In_Parameter) + || (Nkind (gnat_actual) == N_Type_Conversion + && Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))); + Node_Id gnat_name = (suppress_type_conversion + ? Expression (gnat_actual) : gnat_actual); + tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type; + tree gnu_actual; + + /* If it's possible we may need to use this expression twice, make sure + that any side-effects are handled via SAVE_EXPRs. Likewise if we need + to force side-effects before the call. + ??? This is more conservative than we need since we don't need to do + this for pass-by-ref with no conversion. */ + if (Ekind (gnat_formal) != E_In_Parameter) + gnu_name = gnat_stabilize_reference (gnu_name, true); + + /* If we are passing a non-addressable parameter by reference, pass the + address of a copy. In the Out or In Out case, set up to copy back + out after the call. */ + if (gnu_formal + && (DECL_BY_REF_P (gnu_formal) + || (TREE_CODE (gnu_formal) == PARM_DECL + && (DECL_BY_COMPONENT_PTR_P (gnu_formal) + || (DECL_BY_DESCRIPTOR_P (gnu_formal))))) + && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name))) + && !addressable_p (gnu_name, gnu_name_type)) + { + tree gnu_copy = gnu_name, gnu_temp; + + /* If the type is by_reference, a copy is not allowed. */ + if (Is_By_Reference_Type (Etype (gnat_formal))) + post_error + ("misaligned actual cannot be passed by reference", gnat_actual); + + /* For users of Starlet we issue a warning because the + interface apparently assumes that by-ref parameters + outlive the procedure invocation. The code still + will not work as intended, but we cannot do much + better since other low-level parts of the back-end + would allocate temporaries at will because of the + misalignment if we did not do so here. */ + else if (Is_Valued_Procedure (Entity (Name (gnat_node)))) + { + post_error + ("?possible violation of implicit assumption", gnat_actual); + post_error_ne + ("?made by pragma Import_Valued_Procedure on &", gnat_actual, + Entity (Name (gnat_node))); + post_error_ne ("?because of misalignment of &", gnat_actual, + gnat_formal); + } + + /* Remove any unpadding from the object and reset the copy. */ + if (TREE_CODE (gnu_name) == COMPONENT_REF + && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0))) + == RECORD_TYPE) + && (TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))))) + gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0); + + /* Otherwise convert to the nominal type of the object if it's + a record type. There are several cases in which we need to + make the temporary using this type instead of the actual type + of the object if they are distinct, because the expectations + of the callee would otherwise not be met: + - if it's a justified modular type, + - if the actual type is a smaller packable version of it. */ + else if (TREE_CODE (gnu_name_type) == RECORD_TYPE + && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type) + || smaller_packable_type_p (TREE_TYPE (gnu_name), + gnu_name_type))) + gnu_name = convert (gnu_name_type, gnu_name); + + /* Make a SAVE_EXPR to both properly account for potential side + effects and handle the creation of a temporary copy. Special + code in gnat_gimplify_expr ensures that the same temporary is + used as the object and copied back after the call if needed. */ + gnu_name = build1 (SAVE_EXPR, TREE_TYPE (gnu_name), gnu_name); + TREE_SIDE_EFFECTS (gnu_name) = 1; + + /* Set up to move the copy back to the original. */ + if (Ekind (gnat_formal) != E_In_Parameter) + { + gnu_temp = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_copy, + gnu_name); + set_expr_location_from_node (gnu_temp, gnat_node); + append_to_statement_list (gnu_temp, &gnu_after_list); + } + } + + /* Start from the real object and build the actual. */ + gnu_actual = gnu_name; + + /* If this was a procedure call, we may not have removed any padding. + So do it here for the part we will use as an input, if any. */ + if (Ekind (gnat_formal) != E_Out_Parameter + && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))) + gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), + gnu_actual); + + /* Do any needed conversions for the actual and make sure that it is + in range of the formal's type. */ + if (suppress_type_conversion) + { + /* Put back the conversion we suppressed above in the computation + of the real object. Note that we treat a conversion between + aggregate types as if it is an unchecked conversion here. */ + gnu_actual + = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)), + gnu_actual, + (Nkind (gnat_actual) + == N_Unchecked_Type_Conversion) + && No_Truncation (gnat_actual)); + + if (Ekind (gnat_formal) != E_Out_Parameter + && Do_Range_Check (gnat_actual)) + gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal)); + } + else + { + if (Ekind (gnat_formal) != E_Out_Parameter + && Do_Range_Check (gnat_actual)) + gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal)); + + /* We may have suppressed a conversion to the Etype of the actual + since the parent is a procedure call. So put it back here. + ??? We use the reverse order compared to the case above because + of an awkward interaction with the check and actually don't put + back the conversion at all if a check is emitted. This is also + done for the conversion to the formal's type just below. */ + if (TREE_CODE (gnu_actual) != SAVE_EXPR) + gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)), + gnu_actual); + } + + if (TREE_CODE (gnu_actual) != SAVE_EXPR) + gnu_actual = convert (gnu_formal_type, gnu_actual); + + /* Unless this is an In parameter, we must remove any justified modular + building from GNU_NAME to get an lvalue. */ + if (Ekind (gnat_formal) != E_In_Parameter + && TREE_CODE (gnu_name) == CONSTRUCTOR + && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name))) + gnu_name = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), + gnu_name); + + /* If we have not saved a GCC object for the formal, it means it is an + Out parameter not passed by reference and that does not need to be + copied in. Otherwise, look at the PARM_DECL to see if it is passed by + reference. */ + if (gnu_formal + && TREE_CODE (gnu_formal) == PARM_DECL + && DECL_BY_REF_P (gnu_formal)) + { + if (Ekind (gnat_formal) != E_In_Parameter) + { + /* In Out or Out parameters passed by reference don't use the + copy-in copy-out mechanism so the address of the real object + must be passed to the function. */ + gnu_actual = gnu_name; + + /* If we have a padded type, be sure we've removed padding. */ + if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)) + && TREE_CODE (gnu_actual) != SAVE_EXPR) + gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), + gnu_actual); + + /* If we have the constructed subtype of an aliased object + with an unconstrained nominal subtype, the type of the + actual includes the template, although it is formally + constrained. So we need to convert it back to the real + constructed subtype to retrieve the constrained part + and takes its address. */ + if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual)) + && TREE_CODE (gnu_actual) != SAVE_EXPR + && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual)) + && Is_Array_Type (Etype (gnat_actual))) + gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)), + gnu_actual); + } + + /* The symmetry of the paths to the type of an entity is broken here + since arguments don't know that they will be passed by ref. */ + gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); + gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); + } + else if (gnu_formal + && TREE_CODE (gnu_formal) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (gnu_formal)) + { + gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); + gnu_actual = maybe_implicit_deref (gnu_actual); + gnu_actual = maybe_unconstrained_array (gnu_actual); + + if (TREE_CODE (gnu_formal_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_formal_type)) + { + gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type)); + gnu_actual = convert (gnu_formal_type, gnu_actual); + } + + /* Take the address of the object and convert to the proper pointer + type. We'd like to actually compute the address of the beginning + of the array using an ADDR_EXPR of an ARRAY_REF, but there's a + possibility that the ARRAY_REF might return a constant and we'd be + getting the wrong address. Neither approach is exactly correct, + but this is the most likely to work in all cases. */ + gnu_actual = convert (gnu_formal_type, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_actual)); + } + else if (gnu_formal + && TREE_CODE (gnu_formal) == PARM_DECL + && DECL_BY_DESCRIPTOR_P (gnu_formal)) + { + /* If arg is 'Null_Parameter, pass zero descriptor. */ + if ((TREE_CODE (gnu_actual) == INDIRECT_REF + || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF) + && TREE_PRIVATE (gnu_actual)) + gnu_actual = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)), + integer_zero_node); + else + gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE, + fill_vms_descriptor (gnu_actual, + gnat_formal, + gnat_actual)); + } + else + { + tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual)); + + if (Ekind (gnat_formal) != E_In_Parameter) + gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list); + + if (!gnu_formal || TREE_CODE (gnu_formal) != PARM_DECL) + continue; + + /* If this is 'Null_Parameter, pass a zero even though we are + dereferencing it. */ + else if (TREE_CODE (gnu_actual) == INDIRECT_REF + && TREE_PRIVATE (gnu_actual) + && host_integerp (gnu_actual_size, 1) + && 0 >= compare_tree_int (gnu_actual_size, + BITS_PER_WORD)) + gnu_actual + = unchecked_convert (DECL_ARG_TYPE (gnu_formal), + convert (gnat_type_for_size + (tree_low_cst (gnu_actual_size, 1), + 1), + integer_zero_node), + false); + else + gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual); + } + + gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list); + } + + gnu_subprog_call = build_call_list (TREE_TYPE (gnu_subprog_type), + gnu_subprog_addr, + nreverse (gnu_actual_list)); + set_expr_location_from_node (gnu_subprog_call, gnat_node); + + /* If we return by passing a target, the result is the target after the + call. We must not emit the call directly here because this might be + evaluated as part of an expression with conditions to control whether + the call should be emitted or not. */ + if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)) + { + /* Conceptually, what we need is a COMPOUND_EXPR with the call followed + by the target object converted to the proper type. Doing so would + potentially be very inefficient, however, as this expression might + end up wrapped into an outer SAVE_EXPR later on, which would incur a + pointless temporary copy of the whole object. + + What we do instead is build a COMPOUND_EXPR returning the address of + the target, and then dereference. Wrapping the COMPOUND_EXPR into a + SAVE_EXPR later on then only incurs a pointer copy. */ + + tree gnu_result_type + = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type))); + + /* Build and return + (result_type) *[gnu_subprog_call (&gnu_target, ...), &gnu_target] */ + + tree gnu_target_address + = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_target); + set_expr_location_from_node (gnu_target_address, gnat_node); + + gnu_result + = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_target_address), + gnu_subprog_call, gnu_target_address); + + gnu_result + = unchecked_convert (gnu_result_type, + build_unary_op (INDIRECT_REF, NULL_TREE, + gnu_result), + false); + + *gnu_result_type_p = gnu_result_type; + return gnu_result; + } + + /* If it is a function call, the result is the call expression unless + a target is specified, in which case we copy the result into the target + and return the assignment statement. */ + else if (Nkind (gnat_node) == N_Function_Call) + { + gnu_result = gnu_subprog_call; + + /* If the function returns an unconstrained array or by reference, + we have to de-dereference the pointer. */ + if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type) + || TYPE_RETURNS_BY_REF_P (gnu_subprog_type)) + gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); + + if (gnu_target) + gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, + gnu_target, gnu_result); + else + *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); + + return gnu_result; + } + + /* If this is the case where the GNAT tree contains a procedure call + but the Ada procedure has copy in copy out parameters, the special + parameter passing mechanism must be used. */ + else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE) + { + /* List of FIELD_DECLs associated with the PARM_DECLs of the copy + in copy out parameters. */ + tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type); + int length = list_length (scalar_return_list); + + if (length > 1) + { + tree gnu_name; + + gnu_subprog_call = save_expr (gnu_subprog_call); + gnu_name_list = nreverse (gnu_name_list); + + /* If any of the names had side-effects, ensure they are all + evaluated before the call. */ + for (gnu_name = gnu_name_list; gnu_name; + gnu_name = TREE_CHAIN (gnu_name)) + if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name))) + append_to_statement_list (TREE_VALUE (gnu_name), + &gnu_before_list); + } + + if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) + gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node))); + else + gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node))); + + for (gnat_actual = First_Actual (gnat_node); + Present (gnat_actual); + gnat_formal = Next_Formal_With_Extras (gnat_formal), + gnat_actual = Next_Actual (gnat_actual)) + /* If we are dealing with a copy in copy out parameter, we must + retrieve its value from the record returned in the call. */ + if (!(present_gnu_tree (gnat_formal) + && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && (DECL_BY_REF_P (get_gnu_tree (gnat_formal)) + || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)) + || (DECL_BY_DESCRIPTOR_P + (get_gnu_tree (gnat_formal)))))))) + && Ekind (gnat_formal) != E_In_Parameter) + { + /* Get the value to assign to this Out or In Out parameter. It is + either the result of the function if there is only a single such + parameter or the appropriate field from the record returned. */ + tree gnu_result + = length == 1 ? gnu_subprog_call + : build_component_ref (gnu_subprog_call, NULL_TREE, + TREE_PURPOSE (scalar_return_list), + false); + + /* If the actual is a conversion, get the inner expression, which + will be the real destination, and convert the result to the + type of the actual parameter. */ + tree gnu_actual + = maybe_unconstrained_array (TREE_VALUE (gnu_name_list)); + + /* If the result is a padded type, remove the padding. */ + if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) + gnu_result = convert (TREE_TYPE (TYPE_FIELDS + (TREE_TYPE (gnu_result))), + gnu_result); + + /* If the actual is a type conversion, the real target object is + denoted by the inner Expression and we need to convert the + result to the associated type. + We also need to convert our gnu assignment target to this type + if the corresponding GNU_NAME was constructed from the GNAT + conversion node and not from the inner Expression. */ + if (Nkind (gnat_actual) == N_Type_Conversion) + { + gnu_result + = convert_with_check + (Etype (Expression (gnat_actual)), gnu_result, + Do_Overflow_Check (gnat_actual), + Do_Range_Check (Expression (gnat_actual)), + Float_Truncate (gnat_actual)); + + if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))) + gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual); + } + + /* Unchecked conversions as actuals for Out parameters are not + allowed in user code because they are not variables, but do + occur in front-end expansions. The associated GNU_NAME is + always obtained from the inner expression in such cases. */ + else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion) + gnu_result = unchecked_convert (TREE_TYPE (gnu_actual), + gnu_result, + No_Truncation (gnat_actual)); + else + { + if (Do_Range_Check (gnat_actual)) + gnu_result = emit_range_check (gnu_result, + Etype (gnat_actual)); + + if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual))) + && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result))))) + gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result); + } + + gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, + gnu_actual, gnu_result); + set_expr_location_from_node (gnu_result, gnat_node); + append_to_statement_list (gnu_result, &gnu_before_list); + scalar_return_list = TREE_CHAIN (scalar_return_list); + gnu_name_list = TREE_CHAIN (gnu_name_list); + } + } + else + append_to_statement_list (gnu_subprog_call, &gnu_before_list); + + append_to_statement_list (gnu_after_list, &gnu_before_list); + return gnu_before_list; + } + + /* Subroutine of gnat_to_gnu to translate gnat_node, an + N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */ + + static tree + Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) + { + tree gnu_jmpsave_decl = NULL_TREE; + tree gnu_jmpbuf_decl = NULL_TREE; + /* If just annotating, ignore all EH and cleanups. */ + bool gcc_zcx = (!type_annotate_only + && Present (Exception_Handlers (gnat_node)) + && Exception_Mechanism == Back_End_Exceptions); + bool setjmp_longjmp + = (!type_annotate_only && Present (Exception_Handlers (gnat_node)) + && Exception_Mechanism == Setjmp_Longjmp); + bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node)); + bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp); + tree gnu_inner_block; /* The statement(s) for the block itself. */ + tree gnu_result; + tree gnu_expr; + Node_Id gnat_temp; + + /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes + and we have our own SJLJ mechanism. To call the GCC mechanism, we call + add_cleanup, and when we leave the binding, end_stmt_group will create + the TRY_FINALLY_EXPR. + + ??? The region level calls down there have been specifically put in place + for a ZCX context and currently the order in which things are emitted + (region/handlers) is different from the SJLJ case. Instead of putting + other calls with different conditions at other places for the SJLJ case, + it seems cleaner to reorder things for the SJLJ case and generalize the + condition to make it not ZCX specific. + + If there are any exceptions or cleanup processing involved, we need an + outer statement group (for Setjmp_Longjmp) and binding level. */ + if (binding_for_block) + { + start_stmt_group (); + gnat_pushlevel (); + } + + /* If using setjmp_longjmp, make the variables for the setjmp buffer and save + area for address of previous buffer. Do this first since we need to have + the setjmp buf known for any decls in this block. */ + if (setjmp_longjmp) + { + gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"), + NULL_TREE, jmpbuf_ptr_type, + build_call_0_expr (get_jmpbuf_decl), + false, false, false, false, NULL, + gnat_node); + DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1; + + /* The __builtin_setjmp receivers will immediately reinstall it. Now + because of the unstructured form of EH used by setjmp_longjmp, there + might be forward edges going to __builtin_setjmp receivers on which + it is uninitialized, although they will never be actually taken. */ + TREE_NO_WARNING (gnu_jmpsave_decl) = 1; + gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"), + NULL_TREE, jmpbuf_type, + NULL_TREE, false, false, false, false, + NULL, gnat_node); + DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1; + + set_block_jmpbuf_decl (gnu_jmpbuf_decl); + + /* When we exit this block, restore the saved value. */ + add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl), + End_Label (gnat_node)); + } + + /* If we are to call a function when exiting this block, add a cleanup + to the binding level we made above. Note that add_cleanup is FIFO + so we must register this cleanup after the EH cleanup just above. */ + if (at_end) + add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))), + End_Label (gnat_node)); + + /* Now build the tree for the declarations and statements inside this block. + If this is SJLJ, set our jmp_buf as the current buffer. */ + start_stmt_group (); + + if (setjmp_longjmp) + add_stmt (build_call_1_expr (set_jmpbuf_decl, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_jmpbuf_decl))); + + if (Present (First_Real_Statement (gnat_node))) + process_decls (Statements (gnat_node), Empty, + First_Real_Statement (gnat_node), true, true); + + /* Generate code for each statement in the block. */ + for (gnat_temp = (Present (First_Real_Statement (gnat_node)) + ? First_Real_Statement (gnat_node) + : First (Statements (gnat_node))); + Present (gnat_temp); gnat_temp = Next (gnat_temp)) + add_stmt (gnat_to_gnu (gnat_temp)); + gnu_inner_block = end_stmt_group (); + + /* Now generate code for the two exception models, if either is relevant for + this block. */ + if (setjmp_longjmp) + { + tree *gnu_else_ptr = 0; + tree gnu_handler; + + /* Make a binding level for the exception handling declarations and code + and set up gnu_except_ptr_stack for the handlers to use. */ + start_stmt_group (); + gnat_pushlevel (); + + push_stack (&gnu_except_ptr_stack, NULL_TREE, + create_var_decl (get_identifier ("EXCEPT_PTR"), + NULL_TREE, + build_pointer_type (except_type_node), + build_call_0_expr (get_excptr_decl), false, + false, false, false, NULL, gnat_node)); + + /* Generate code for each handler. The N_Exception_Handler case does the + real work and returns a COND_EXPR for each handler, which we chain + together here. */ + for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); + Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp)) + { + gnu_expr = gnat_to_gnu (gnat_temp); + + /* If this is the first one, set it as the outer one. Otherwise, + point the "else" part of the previous handler to us. Then point + to our "else" part. */ + if (!gnu_else_ptr) + add_stmt (gnu_expr); + else + *gnu_else_ptr = gnu_expr; + + gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr); + } + + /* If none of the exception handlers did anything, re-raise but do not + defer abortion. */ + gnu_expr = build_call_1_expr (raise_nodefer_decl, + TREE_VALUE (gnu_except_ptr_stack)); + set_expr_location_from_node (gnu_expr, gnat_node); + + if (gnu_else_ptr) + *gnu_else_ptr = gnu_expr; + else + add_stmt (gnu_expr); + + /* End the binding level dedicated to the exception handlers and get the + whole statement group. */ + pop_stack (&gnu_except_ptr_stack); + gnat_poplevel (); + gnu_handler = end_stmt_group (); + + /* If the setjmp returns 1, we restore our incoming longjmp value and + then check the handlers. */ + start_stmt_group (); + add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl, + gnu_jmpsave_decl), + gnat_node); + add_stmt (gnu_handler); + gnu_handler = end_stmt_group (); + + /* This block is now "if (setjmp) ... else ". */ + gnu_result = build3 (COND_EXPR, void_type_node, + (build_call_1_expr + (setjmp_decl, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_jmpbuf_decl))), + gnu_handler, gnu_inner_block); + } + else if (gcc_zcx) + { + tree gnu_handlers; + + /* First make a block containing the handlers. */ + start_stmt_group (); + for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); + Present (gnat_temp); + gnat_temp = Next_Non_Pragma (gnat_temp)) + add_stmt (gnat_to_gnu (gnat_temp)); + gnu_handlers = end_stmt_group (); + + /* Now make the TRY_CATCH_EXPR for the block. */ + gnu_result = build2 (TRY_CATCH_EXPR, void_type_node, + gnu_inner_block, gnu_handlers); + } + else + gnu_result = gnu_inner_block; + + /* Now close our outer block, if we had to make one. */ + if (binding_for_block) + { + add_stmt (gnu_result); + gnat_poplevel (); + gnu_result = end_stmt_group (); + } + + return gnu_result; + } + + /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler, + to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp + exception handling. */ + + static tree + Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) + { + /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make + an "if" statement to select the proper exceptions. For "Others", exclude + exceptions where Handled_By_Others is nonzero unless the All_Others flag + is set. For "Non-ada", accept an exception if "Lang" is 'V'. */ + tree gnu_choice = integer_zero_node; + tree gnu_body = build_stmt_group (Statements (gnat_node), false); + Node_Id gnat_temp; + + for (gnat_temp = First (Exception_Choices (gnat_node)); + gnat_temp; gnat_temp = Next (gnat_temp)) + { + tree this_choice; + + if (Nkind (gnat_temp) == N_Others_Choice) + { + if (All_Others (gnat_temp)) + this_choice = integer_one_node; + else + this_choice + = build_binary_op + (EQ_EXPR, integer_type_node, + convert + (integer_type_node, + build_component_ref + (build_unary_op + (INDIRECT_REF, NULL_TREE, + TREE_VALUE (gnu_except_ptr_stack)), + get_identifier ("not_handled_by_others"), NULL_TREE, + false)), + integer_zero_node); + } + + else if (Nkind (gnat_temp) == N_Identifier + || Nkind (gnat_temp) == N_Expanded_Name) + { + Entity_Id gnat_ex_id = Entity (gnat_temp); + tree gnu_expr; + + /* Exception may be a renaming. Recover original exception which is + the one elaborated and registered. */ + if (Present (Renamed_Object (gnat_ex_id))) + gnat_ex_id = Renamed_Object (gnat_ex_id); + + gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0); + + this_choice + = build_binary_op + (EQ_EXPR, integer_type_node, TREE_VALUE (gnu_except_ptr_stack), + convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)), + build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr))); + + /* If this is the distinguished exception "Non_Ada_Error" (and we are + in VMS mode), also allow a non-Ada exception (a VMS condition) t + match. */ + if (Is_Non_Ada_Error (Entity (gnat_temp))) + { + tree gnu_comp + = build_component_ref + (build_unary_op (INDIRECT_REF, NULL_TREE, + TREE_VALUE (gnu_except_ptr_stack)), + get_identifier ("lang"), NULL_TREE, false); + + this_choice + = build_binary_op + (TRUTH_ORIF_EXPR, integer_type_node, + build_binary_op (EQ_EXPR, integer_type_node, gnu_comp, + build_int_cst (TREE_TYPE (gnu_comp), 'V')), + this_choice); + } + } + else + gcc_unreachable (); + + gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, + gnu_choice, this_choice); + } + + return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE); + } + + /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler, + to a GCC tree, which is returned. This is the variant for ZCX. */ + + static tree + Exception_Handler_to_gnu_zcx (Node_Id gnat_node) + { + tree gnu_etypes_list = NULL_TREE; + tree gnu_expr; + tree gnu_etype; + tree gnu_current_exc_ptr; + tree gnu_incoming_exc_ptr; + Node_Id gnat_temp; + + /* We build a TREE_LIST of nodes representing what exception types this + handler can catch, with special cases for others and all others cases. + + Each exception type is actually identified by a pointer to the exception + id, or to a dummy object for "others" and "all others". + + Care should be taken to ensure that the control flow impact of "others" + and "all others" is known to GCC. lang_eh_type_covers is doing the trick + currently. */ + for (gnat_temp = First (Exception_Choices (gnat_node)); + gnat_temp; gnat_temp = Next (gnat_temp)) + { + if (Nkind (gnat_temp) == N_Others_Choice) + { + tree gnu_expr + = All_Others (gnat_temp) ? all_others_decl : others_decl; + + gnu_etype + = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); + } + else if (Nkind (gnat_temp) == N_Identifier + || Nkind (gnat_temp) == N_Expanded_Name) + { + Entity_Id gnat_ex_id = Entity (gnat_temp); + + /* Exception may be a renaming. Recover original exception which is + the one elaborated and registered. */ + if (Present (Renamed_Object (gnat_ex_id))) + gnat_ex_id = Renamed_Object (gnat_ex_id); + + gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0); + gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); + + /* The Non_Ada_Error case for VMS exceptions is handled + by the personality routine. */ + } + else + gcc_unreachable (); + + /* The GCC interface expects NULL to be passed for catch all handlers, so + it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype + is integer_zero_node. It would not work, however, because GCC's + notion of "catch all" is stronger than our notion of "others". Until + we correctly use the cleanup interface as well, doing that would + prevent the "all others" handlers from being seen, because nothing + can be caught beyond a catch all from GCC's point of view. */ + gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list); + } + + start_stmt_group (); + gnat_pushlevel (); + + /* Expand a call to the begin_handler hook at the beginning of the handler, + and arrange for a call to the end_handler hook to occur on every possible + exit path. + + The hooks expect a pointer to the low level occurrence. This is required + for our stack management scheme because a raise inside the handler pushes + a new occurrence on top of the stack, which means that this top does not + necessarily match the occurrence this handler was dealing with. + + The EXC_PTR_EXPR object references the exception occurrence being + propagated. Upon handler entry, this is the exception for which the + handler is triggered. This might not be the case upon handler exit, + however, as we might have a new occurrence propagated by the handler's + body, and the end_handler hook called as a cleanup in this context. + + We use a local variable to retrieve the incoming value at handler entry + time, and reuse it to feed the end_handler hook's argument at exit. */ + gnu_current_exc_ptr = build0 (EXC_PTR_EXPR, ptr_type_node); + gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE, + ptr_type_node, gnu_current_exc_ptr, + false, false, false, false, NULL, + gnat_node); + + add_stmt_with_node (build_call_1_expr (begin_handler_decl, + gnu_incoming_exc_ptr), + gnat_node); + /* ??? We don't seem to have an End_Label at hand to set the location. */ + add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr), + Empty); + add_stmt_list (Statements (gnat_node)); + gnat_poplevel (); + + return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list, + end_stmt_group ()); + } + + /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */ + + static void + Compilation_Unit_to_gnu (Node_Id gnat_node) + { + /* Make the decl for the elaboration procedure. */ + bool body_p = (Defining_Entity (Unit (gnat_node)), + Nkind (Unit (gnat_node)) == N_Package_Body + || Nkind (Unit (gnat_node)) == N_Subprogram_Body); + Entity_Id gnat_unit_entity = Defining_Entity (Unit (gnat_node)); + tree gnu_elab_proc_decl + = create_subprog_decl + (create_concat_name (gnat_unit_entity, + body_p ? "elabb" : "elabs"), + NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL, + gnat_unit_entity); + struct elab_info *info; + + push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl); + + DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1; + allocate_struct_function (gnu_elab_proc_decl, false); + Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus); + set_cfun (NULL); + + /* For a body, first process the spec if there is one. */ + if (Nkind (Unit (gnat_node)) == N_Package_Body + || (Nkind (Unit (gnat_node)) == N_Subprogram_Body + && !Acts_As_Spec (gnat_node))) + { + add_stmt (gnat_to_gnu (Library_Unit (gnat_node))); + finalize_from_with_types (); + } + + process_inlined_subprograms (gnat_node); + + if (type_annotate_only && gnat_node == Cunit (Main_Unit)) + { + elaborate_all_entities (gnat_node); + + if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration + || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration + || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration) + return; + } + + process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty, + true, true); + add_stmt (gnat_to_gnu (Unit (gnat_node))); + + /* Process any pragmas and actions following the unit. */ + add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node))); + add_stmt_list (Actions (Aux_Decls_Node (gnat_node))); + finalize_from_with_types (); + + /* Save away what we've made so far and record this potential elaboration + procedure. */ + info = (struct elab_info *) ggc_alloc (sizeof (struct elab_info)); + set_current_block_context (gnu_elab_proc_decl); + gnat_poplevel (); + DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group (); + info->next = elab_info_list; + info->elab_proc = gnu_elab_proc_decl; + info->gnat_node = gnat_node; + elab_info_list = info; + + /* Generate elaboration code for this unit, if necessary, and say whether + we did or not. */ + pop_stack (&gnu_elab_proc_stack); + + /* Invalidate the global renaming pointers. This is necessary because + stabilization of the renamed entities may create SAVE_EXPRs which + have been tied to a specific elaboration routine just above. */ + invalidate_global_renaming_pointers (); + } + + /* This function is the driver of the GNAT to GCC tree transformation + process. It is the entry point of the tree transformer. GNAT_NODE is the + root of some GNAT tree. Return the root of the corresponding GCC tree. + If this is an expression, return the GCC equivalent of the expression. If + it is a statement, return the statement. In the case when called for a + statement, it may also add statements to the current statement group, in + which case anything it returns is to be interpreted as occurring after + anything `it already added. */ + + tree + gnat_to_gnu (Node_Id gnat_node) + { + bool went_into_elab_proc = false; + tree gnu_result = error_mark_node; /* Default to no value. */ + tree gnu_result_type = void_type_node; + tree gnu_expr; + tree gnu_lhs, gnu_rhs; + Node_Id gnat_temp; + + /* Save node number for error message and set location information. */ + error_gnat_node = gnat_node; + Sloc_to_locus (Sloc (gnat_node), &input_location); + + if (type_annotate_only + && IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)) + return alloc_stmt_list (); + + /* If this node is a non-static subexpression and we are only + annotating types, make this into a NULL_EXPR. */ + if (type_annotate_only + && IN (Nkind (gnat_node), N_Subexpr) + && Nkind (gnat_node) != N_Identifier + && !Compile_Time_Known_Value (gnat_node)) + return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)), + build_call_raise (CE_Range_Check_Failed, gnat_node, + N_Raise_Constraint_Error)); + + /* If this is a Statement and we are at top level, it must be part of the + elaboration procedure, so mark us as being in that procedure and push our + context. + + If we are in the elaboration procedure, check if we are violating a + No_Elaboration_Code restriction by having a statement there. */ + if ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call) + && Nkind (gnat_node) != N_Null_Statement) + || Nkind (gnat_node) == N_Procedure_Call_Statement + || Nkind (gnat_node) == N_Label + || Nkind (gnat_node) == N_Implicit_Label_Declaration + || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements + || ((Nkind (gnat_node) == N_Raise_Constraint_Error + || Nkind (gnat_node) == N_Raise_Storage_Error + || Nkind (gnat_node) == N_Raise_Program_Error) + && (Ekind (Etype (gnat_node)) == E_Void))) + { + if (!current_function_decl) + { + current_function_decl = TREE_VALUE (gnu_elab_proc_stack); + start_stmt_group (); + gnat_pushlevel (); + went_into_elab_proc = true; + } + + /* Don't check for a possible No_Elaboration_Code restriction violation + on N_Handled_Sequence_Of_Statements, as we want to signal an error on + every nested real statement instead. This also avoids triggering + spurious errors on dummy (empty) sequences created by the front-end + for package bodies in some cases. */ + + if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack) + && Nkind (gnat_node) != N_Handled_Sequence_Of_Statements) + Check_Elaboration_Code_Allowed (gnat_node); + } + + switch (Nkind (gnat_node)) + { + /********************************/ + /* Chapter 2: Lexical Elements: */ + /********************************/ + + case N_Identifier: + case N_Expanded_Name: + case N_Operator_Symbol: + case N_Defining_Identifier: + gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type); + break; + + case N_Integer_Literal: + { + tree gnu_type; + + /* Get the type of the result, looking inside any padding and + justified modular types. Then get the value in that type. */ + gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (gnu_type)) + gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); + + gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type); + + /* If the result overflows (meaning it doesn't fit in its base type), + abort. We would like to check that the value is within the range + of the subtype, but that causes problems with subtypes whose usage + will raise Constraint_Error and with biased representation, so + we don't. */ + gcc_assert (!TREE_OVERFLOW (gnu_result)); + } + break; + + case N_Character_Literal: + /* If a Entity is present, it means that this was one of the + literals in a user-defined character type. In that case, + just return the value in the CONST_DECL. Otherwise, use the + character code. In that case, the base type should be an + INTEGER_TYPE, but we won't bother checking for that. */ + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + if (Present (Entity (gnat_node))) + gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node))); + else + gnu_result + = build_int_cst_type + (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node))); + break; + + case N_Real_Literal: + /* If this is of a fixed-point type, the value we want is the + value of the corresponding integer. */ + if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind)) + { + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node), + gnu_result_type); + gcc_assert (!TREE_OVERFLOW (gnu_result)); + } + + /* We should never see a Vax_Float type literal, since the front end + is supposed to transform these using appropriate conversions */ + else if (Vax_Float (Underlying_Type (Etype (gnat_node)))) + gcc_unreachable (); + + else + { + Ureal ur_realval = Realval (gnat_node); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* If the real value is zero, so is the result. Otherwise, + convert it to a machine number if it isn't already. That + forces BASE to 0 or 2 and simplifies the rest of our logic. */ + if (UR_Is_Zero (ur_realval)) + gnu_result = convert (gnu_result_type, integer_zero_node); + else + { + if (!Is_Machine_Number (gnat_node)) + ur_realval + = Machine (Base_Type (Underlying_Type (Etype (gnat_node))), + ur_realval, Round_Even, gnat_node); + + gnu_result + = UI_To_gnu (Numerator (ur_realval), gnu_result_type); + + /* If we have a base of zero, divide by the denominator. + Otherwise, the base must be 2 and we scale the value, which + we know can fit in the mantissa of the type (hence the use + of that type above). */ + if (No (Rbase (ur_realval))) + gnu_result + = build_binary_op (RDIV_EXPR, + get_base_type (gnu_result_type), + gnu_result, + UI_To_gnu (Denominator (ur_realval), + gnu_result_type)); + else + { + REAL_VALUE_TYPE tmp; + + gcc_assert (Rbase (ur_realval) == 2); + real_ldexp (&tmp, &TREE_REAL_CST (gnu_result), + - UI_To_Int (Denominator (ur_realval))); + gnu_result = build_real (gnu_result_type, tmp); + } + } + + /* Now see if we need to negate the result. Do it this way to + properly handle -0. */ + if (UR_Is_Negative (Realval (gnat_node))) + gnu_result + = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type), + gnu_result); + } + + break; + + case N_String_Literal: + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR) + { + String_Id gnat_string = Strval (gnat_node); + int length = String_Length (gnat_string); + int i; + char *string; + if (length >= ALLOCA_THRESHOLD) + string = XNEWVEC (char, length + 1); /* in case of large strings */ + else + string = (char *) alloca (length + 1); + + /* Build the string with the characters in the literal. Note + that Ada strings are 1-origin. */ + for (i = 0; i < length; i++) + string[i] = Get_String_Char (gnat_string, i + 1); + + /* Put a null at the end of the string in case it's in a context + where GCC will want to treat it as a C string. */ + string[i] = 0; + + gnu_result = build_string (length, string); + + /* Strings in GCC don't normally have types, but we want + this to not be converted to the array type. */ + TREE_TYPE (gnu_result) = gnu_result_type; + + if (length >= ALLOCA_THRESHOLD) /* free if heap-allocated */ + free (string); + } + else + { + /* Build a list consisting of each character, then make + the aggregate. */ + String_Id gnat_string = Strval (gnat_node); + int length = String_Length (gnat_string); + int i; + tree gnu_list = NULL_TREE; + tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type)); + + for (i = 0; i < length; i++) + { + gnu_list + = tree_cons (gnu_idx, + build_int_cst (TREE_TYPE (gnu_result_type), + Get_String_Char (gnat_string, + i + 1)), + gnu_list); + + gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node, + 0); + } + + gnu_result + = gnat_build_constructor (gnu_result_type, nreverse (gnu_list)); + } + break; + + case N_Pragma: + gnu_result = Pragma_to_gnu (gnat_node); + break; + + /**************************************/ + /* Chapter 3: Declarations and Types: */ + /**************************************/ + + case N_Subtype_Declaration: + case N_Full_Type_Declaration: + case N_Incomplete_Type_Declaration: + case N_Private_Type_Declaration: + case N_Private_Extension_Declaration: + case N_Task_Type_Declaration: + process_type (Defining_Entity (gnat_node)); + gnu_result = alloc_stmt_list (); + break; + + case N_Object_Declaration: + case N_Exception_Declaration: + gnat_temp = Defining_Entity (gnat_node); + gnu_result = alloc_stmt_list (); + + /* If we are just annotating types and this object has an unconstrained + or task type, don't elaborate it. */ + if (type_annotate_only + && (((Is_Array_Type (Etype (gnat_temp)) + || Is_Record_Type (Etype (gnat_temp))) + && !Is_Constrained (Etype (gnat_temp))) + || Is_Concurrent_Type (Etype (gnat_temp)))) + break; + + if (Present (Expression (gnat_node)) + && !(Nkind (gnat_node) == N_Object_Declaration + && No_Initialization (gnat_node)) + && (!type_annotate_only + || Compile_Time_Known_Value (Expression (gnat_node)))) + { + gnu_expr = gnat_to_gnu (Expression (gnat_node)); + if (Do_Range_Check (Expression (gnat_node))) + gnu_expr = emit_range_check (gnu_expr, Etype (gnat_temp)); + + /* If this object has its elaboration delayed, we must force + evaluation of GNU_EXPR right now and save it for when the object + is frozen. */ + if (Present (Freeze_Node (gnat_temp))) + { + if ((Is_Public (gnat_temp) || global_bindings_p ()) + && !TREE_CONSTANT (gnu_expr)) + gnu_expr + = create_var_decl (create_concat_name (gnat_temp, "init"), + NULL_TREE, TREE_TYPE (gnu_expr), + gnu_expr, false, Is_Public (gnat_temp), + false, false, NULL, gnat_temp); + else + gnu_expr = maybe_variable (gnu_expr); + + save_gnu_tree (gnat_node, gnu_expr, true); + } + } + else + gnu_expr = NULL_TREE; + + if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK) + gnu_expr = NULL_TREE; + + /* If this is a deferred constant with an address clause, we ignore the + full view since the clause is on the partial view and we cannot have + 2 different GCC trees for the object. The only bits of the full view + we will use is the initializer, but it will be directly fetched. */ + if (Ekind(gnat_temp) == E_Constant + && Present (Address_Clause (gnat_temp)) + && Present (Full_View (gnat_temp))) + save_gnu_tree (Full_View (gnat_temp), error_mark_node, true); + + if (No (Freeze_Node (gnat_temp))) + gnat_to_gnu_entity (gnat_temp, gnu_expr, 1); + break; + + case N_Object_Renaming_Declaration: + gnat_temp = Defining_Entity (gnat_node); + + /* Don't do anything if this renaming is handled by the front end or if + we are just annotating types and this object has a composite or task + type, don't elaborate it. We return the result in case it has any + SAVE_EXPRs in it that need to be evaluated here. */ + if (!Is_Renaming_Of_Object (gnat_temp) + && ! (type_annotate_only + && (Is_Array_Type (Etype (gnat_temp)) + || Is_Record_Type (Etype (gnat_temp)) + || Is_Concurrent_Type (Etype (gnat_temp))))) + gnu_result + = gnat_to_gnu_entity (gnat_temp, + gnat_to_gnu (Renamed_Object (gnat_temp)), 1); + else + gnu_result = alloc_stmt_list (); + break; + + case N_Implicit_Label_Declaration: + gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1); + gnu_result = alloc_stmt_list (); + break; + + case N_Exception_Renaming_Declaration: + case N_Number_Declaration: + case N_Package_Renaming_Declaration: + case N_Subprogram_Renaming_Declaration: + /* These are fully handled in the front end. */ + gnu_result = alloc_stmt_list (); + break; + + /*************************************/ + /* Chapter 4: Names and Expressions: */ + /*************************************/ + + case N_Explicit_Dereference: + gnu_result = gnat_to_gnu (Prefix (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); + break; + + case N_Indexed_Component: + { + tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node)); + tree gnu_type; + int ndim; + int i; + Node_Id *gnat_expr_array; + + gnu_array_object = maybe_implicit_deref (gnu_array_object); + gnu_array_object = maybe_unconstrained_array (gnu_array_object); + + /* If we got a padded type, remove it too. */ + if (TREE_CODE (TREE_TYPE (gnu_array_object)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object))) + gnu_array_object + = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))), + gnu_array_object); + + gnu_result = gnu_array_object; + + /* First compute the number of dimensions of the array, then + fill the expression array, the order depending on whether + this is a Convention_Fortran array or not. */ + for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object); + TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)); + ndim++, gnu_type = TREE_TYPE (gnu_type)) + ; + + gnat_expr_array = (Node_Id *) alloca (ndim * sizeof (Node_Id)); + + if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object))) + for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node)); + i >= 0; + i--, gnat_temp = Next (gnat_temp)) + gnat_expr_array[i] = gnat_temp; + else + for (i = 0, gnat_temp = First (Expressions (gnat_node)); + i < ndim; + i++, gnat_temp = Next (gnat_temp)) + gnat_expr_array[i] = gnat_temp; + + for (i = 0, gnu_type = TREE_TYPE (gnu_array_object); + i < ndim; i++, gnu_type = TREE_TYPE (gnu_type)) + { + gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); + gnat_temp = gnat_expr_array[i]; + gnu_expr = gnat_to_gnu (gnat_temp); + + if (Do_Range_Check (gnat_temp)) + gnu_expr + = emit_index_check + (gnu_array_object, gnu_expr, + TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))), + TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))); + + gnu_result = build_binary_op (ARRAY_REF, NULL_TREE, + gnu_result, gnu_expr); + } + } + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; + + case N_Slice: + { + tree gnu_type; + Node_Id gnat_range_node = Discrete_Range (gnat_node); + + gnu_result = gnat_to_gnu (Prefix (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* Do any implicit dereferences of the prefix and do any needed + range check. */ + gnu_result = maybe_implicit_deref (gnu_result); + gnu_result = maybe_unconstrained_array (gnu_result); + gnu_type = TREE_TYPE (gnu_result); + if (Do_Range_Check (gnat_range_node)) + { + /* Get the bounds of the slice. */ + tree gnu_index_type + = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type)); + tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type); + tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type); + /* Get the permitted bounds. */ + tree gnu_base_index_type + = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)); + tree gnu_base_min_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR + (TYPE_MIN_VALUE (gnu_base_index_type), gnu_result); + tree gnu_base_max_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR + (TYPE_MAX_VALUE (gnu_base_index_type), gnu_result); + tree gnu_expr_l, gnu_expr_h, gnu_expr_type; + + gnu_min_expr = protect_multiple_eval (gnu_min_expr); + gnu_max_expr = protect_multiple_eval (gnu_max_expr); + + /* Derive a good type to convert everything to. */ + gnu_expr_type = get_base_type (gnu_index_type); + + /* Test whether the minimum slice value is too small. */ + gnu_expr_l = build_binary_op (LT_EXPR, integer_type_node, + convert (gnu_expr_type, + gnu_min_expr), + convert (gnu_expr_type, + gnu_base_min_expr)); + + /* Test whether the maximum slice value is too large. */ + gnu_expr_h = build_binary_op (GT_EXPR, integer_type_node, + convert (gnu_expr_type, + gnu_max_expr), + convert (gnu_expr_type, + gnu_base_max_expr)); + + /* Build a slice index check that returns the low bound, + assuming the slice is not empty. */ + gnu_expr = emit_check + (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, + gnu_expr_l, gnu_expr_h), + gnu_min_expr, CE_Index_Check_Failed); + + /* Build a conditional expression that does the index checks and + returns the low bound if the slice is not empty (max >= min), + and returns the naked low bound otherwise (max < min), unless + it is non-constant and the high bound is; this prevents VRP + from inferring bogus ranges on the unlikely path. */ + gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type, + build_binary_op (GE_EXPR, gnu_expr_type, + convert (gnu_expr_type, + gnu_max_expr), + convert (gnu_expr_type, + gnu_min_expr)), + gnu_expr, + TREE_CODE (gnu_min_expr) != INTEGER_CST + && TREE_CODE (gnu_max_expr) == INTEGER_CST + ? gnu_max_expr : gnu_min_expr); + } + else + /* Simply return the naked low bound. */ + gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type)); + + gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type, + gnu_result, gnu_expr); + } + break; + + case N_Selected_Component: + { + tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); + Entity_Id gnat_field = Entity (Selector_Name (gnat_node)); + Entity_Id gnat_pref_type = Etype (Prefix (gnat_node)); + tree gnu_field; + + while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind) + || IN (Ekind (gnat_pref_type), Access_Kind)) + { + if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)) + gnat_pref_type = Underlying_Type (gnat_pref_type); + else if (IN (Ekind (gnat_pref_type), Access_Kind)) + gnat_pref_type = Designated_Type (gnat_pref_type); + } + + gnu_prefix = maybe_implicit_deref (gnu_prefix); + + /* For discriminant references in tagged types always substitute the + corresponding discriminant as the actual selected component. */ + + if (Is_Tagged_Type (gnat_pref_type)) + while (Present (Corresponding_Discriminant (gnat_field))) + gnat_field = Corresponding_Discriminant (gnat_field); + + /* For discriminant references of untagged types always substitute the + corresponding stored discriminant. */ + + else if (Present (Corresponding_Discriminant (gnat_field))) + gnat_field = Original_Record_Component (gnat_field); + + /* Handle extracting the real or imaginary part of a complex. + The real part is the first field and the imaginary the last. */ + + if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE) + gnu_result = build_unary_op (Present (Next_Entity (gnat_field)) + ? REALPART_EXPR : IMAGPART_EXPR, + NULL_TREE, gnu_prefix); + else + { + gnu_field = gnat_to_gnu_field_decl (gnat_field); + + /* If there are discriminants, the prefix might be + evaluated more than once, which is a problem if it has + side-effects. */ + if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node))) + ? Designated_Type (Etype + (Prefix (gnat_node))) + : Etype (Prefix (gnat_node)))) + gnu_prefix = gnat_stabilize_reference (gnu_prefix, false); + + gnu_result + = build_component_ref (gnu_prefix, NULL_TREE, gnu_field, + (Nkind (Parent (gnat_node)) + == N_Attribute_Reference)); + } + + gcc_assert (gnu_result); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + } + break; + + case N_Attribute_Reference: + { + /* The attribute designator (like an enumeration value). */ + int attribute = Get_Attribute_Id (Attribute_Name (gnat_node)); + + /* The Elab_Spec and Elab_Body attributes are special in that + Prefix is a unit, not an object with a GCC equivalent. Similarly + for Elaborated, since that variable isn't otherwise known. */ + if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec) + return (create_subprog_decl + (create_concat_name (Entity (Prefix (gnat_node)), + attribute == Attr_Elab_Body + ? "elabb" : "elabs"), + NULL_TREE, void_ftype, NULL_TREE, false, true, true, NULL, + gnat_node)); + + gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attribute); + } + break; + + case N_Reference: + /* Like 'Access as far as we are concerned. */ + gnu_result = gnat_to_gnu (Prefix (gnat_node)); + gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; + + case N_Aggregate: + case N_Extension_Aggregate: + { + tree gnu_aggr_type; + + /* ??? It is wrong to evaluate the type now, but there doesn't + seem to be any other practical way of doing it. */ + + gcc_assert (!Expansion_Delayed (gnat_node)); + + gnu_aggr_type = gnu_result_type + = get_unpadded_type (Etype (gnat_node)); + + if (TREE_CODE (gnu_result_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type)) + gnu_aggr_type + = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type))); + + if (Null_Record_Present (gnat_node)) + gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE); + + else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE + || TREE_CODE (gnu_aggr_type) == UNION_TYPE) + gnu_result + = assoc_to_constructor (Etype (gnat_node), + First (Component_Associations (gnat_node)), + gnu_aggr_type); + else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE) + gnu_result = pos_to_constructor (First (Expressions (gnat_node)), + gnu_aggr_type, + Component_Type (Etype (gnat_node))); + else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE) + gnu_result + = build_binary_op + (COMPLEX_EXPR, gnu_aggr_type, + gnat_to_gnu (Expression (First + (Component_Associations (gnat_node)))), + gnat_to_gnu (Expression + (Next + (First (Component_Associations (gnat_node)))))); + else + gcc_unreachable (); + + gnu_result = convert (gnu_result_type, gnu_result); + } + break; + + case N_Null: + if (TARGET_VTABLE_USES_DESCRIPTORS + && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type + && Is_Dispatch_Table_Entity (Etype (gnat_node))) + gnu_result = null_fdesc_node; + else + gnu_result = null_pointer_node; + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; + + case N_Type_Conversion: + case N_Qualified_Expression: + /* Get the operand expression. */ + gnu_result = gnat_to_gnu (Expression (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + gnu_result + = convert_with_check (Etype (gnat_node), gnu_result, + Do_Overflow_Check (gnat_node), + Do_Range_Check (Expression (gnat_node)), + Nkind (gnat_node) == N_Type_Conversion + && Float_Truncate (gnat_node)); + break; + + case N_Unchecked_Type_Conversion: + gnu_result = gnat_to_gnu (Expression (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* If the result is a pointer type, see if we are improperly + converting to a stricter alignment. */ + if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type) + && IN (Ekind (Etype (gnat_node)), Access_Kind)) + { + unsigned int align = known_alignment (gnu_result); + tree gnu_obj_type = TREE_TYPE (gnu_result_type); + unsigned int oalign = TYPE_ALIGN (gnu_obj_type); + + if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type)) + post_error_ne_tree_2 + ("?source alignment (^) '< alignment of & (^)", + gnat_node, Designated_Type (Etype (gnat_node)), + size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT); + } + + /* If we are converting a descriptor to a function pointer, first + build the pointer. */ + if (TARGET_VTABLE_USES_DESCRIPTORS + && TREE_TYPE (gnu_result) == fdesc_type_node + && POINTER_TYPE_P (gnu_result_type)) + gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result); + + gnu_result = unchecked_convert (gnu_result_type, gnu_result, + No_Truncation (gnat_node)); + break; + + case N_In: + case N_Not_In: + { + tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node)); + Node_Id gnat_range = Right_Opnd (gnat_node); + tree gnu_low; + tree gnu_high; + + /* GNAT_RANGE is either an N_Range node or an identifier + denoting a subtype. */ + if (Nkind (gnat_range) == N_Range) + { + gnu_low = gnat_to_gnu (Low_Bound (gnat_range)); + gnu_high = gnat_to_gnu (High_Bound (gnat_range)); + } + else if (Nkind (gnat_range) == N_Identifier + || Nkind (gnat_range) == N_Expanded_Name) + { + tree gnu_range_type = get_unpadded_type (Entity (gnat_range)); + + gnu_low = TYPE_MIN_VALUE (gnu_range_type); + gnu_high = TYPE_MAX_VALUE (gnu_range_type); + } + else + gcc_unreachable (); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* If LOW and HIGH are identical, perform an equality test. + Otherwise, ensure that GNU_OBJECT is only evaluated once + and perform a full range test. */ + if (operand_equal_p (gnu_low, gnu_high, 0)) + gnu_result = build_binary_op (EQ_EXPR, gnu_result_type, + gnu_object, gnu_low); + else + { + gnu_object = protect_multiple_eval (gnu_object); + gnu_result + = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, + build_binary_op (GE_EXPR, gnu_result_type, + gnu_object, gnu_low), + build_binary_op (LE_EXPR, gnu_result_type, + gnu_object, gnu_high)); + } + + if (Nkind (gnat_node) == N_Not_In) + gnu_result = invert_truthvalue (gnu_result); + } + break; + + case N_Op_Divide: + gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node)); + gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type) + ? RDIV_EXPR + : (Rounded_Result (gnat_node) + ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR), + gnu_result_type, gnu_lhs, gnu_rhs); + break; + + case N_Op_Or: case N_Op_And: case N_Op_Xor: + /* These can either be operations on booleans or on modular types. + Fall through for boolean types since that's the way GNU_CODES is + set up. */ + if (IN (Ekind (Underlying_Type (Etype (gnat_node))), + Modular_Integer_Kind)) + { + enum tree_code code + = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR + : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR + : BIT_XOR_EXPR); + + gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node)); + gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = build_binary_op (code, gnu_result_type, + gnu_lhs, gnu_rhs); + break; + } + + /* ... fall through ... */ + + case N_Op_Eq: case N_Op_Ne: case N_Op_Lt: + case N_Op_Le: case N_Op_Gt: case N_Op_Ge: + case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply: + case N_Op_Mod: case N_Op_Rem: + case N_Op_Rotate_Left: + case N_Op_Rotate_Right: + case N_Op_Shift_Left: + case N_Op_Shift_Right: + case N_Op_Shift_Right_Arithmetic: + case N_And_Then: case N_Or_Else: + { + enum tree_code code = gnu_codes[Nkind (gnat_node)]; + bool ignore_lhs_overflow = false; + tree gnu_type; + + gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node)); + gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); + gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* If this is a comparison operator, convert any references to + an unconstrained array value into a reference to the + actual array. */ + if (TREE_CODE_CLASS (code) == tcc_comparison) + { + gnu_lhs = maybe_unconstrained_array (gnu_lhs); + gnu_rhs = maybe_unconstrained_array (gnu_rhs); + } + + /* If the result type is a private type, its full view may be a + numeric subtype. The representation we need is that of its base + type, given that it is the result of an arithmetic operation. */ + else if (Is_Private_Type (Etype (gnat_node))) + gnu_type = gnu_result_type + = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node)))); + + /* If this is a shift whose count is not guaranteed to be correct, + we need to adjust the shift count. */ + if (IN (Nkind (gnat_node), N_Op_Shift) + && !Shift_Count_OK (gnat_node)) + { + tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs)); + tree gnu_max_shift + = convert (gnu_count_type, TYPE_SIZE (gnu_type)); + + if (Nkind (gnat_node) == N_Op_Rotate_Left + || Nkind (gnat_node) == N_Op_Rotate_Right) + gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type, + gnu_rhs, gnu_max_shift); + else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic) + gnu_rhs + = build_binary_op + (MIN_EXPR, gnu_count_type, + build_binary_op (MINUS_EXPR, + gnu_count_type, + gnu_max_shift, + convert (gnu_count_type, + integer_one_node)), + gnu_rhs); + } + + /* For right shifts, the type says what kind of shift to do, + so we may need to choose a different type. In this case, + we have to ignore integer overflow lest it propagates all + the way down and causes a CE to be explicitly raised. */ + if (Nkind (gnat_node) == N_Op_Shift_Right + && !TYPE_UNSIGNED (gnu_type)) + { + gnu_type = gnat_unsigned_type (gnu_type); + ignore_lhs_overflow = true; + } + else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic + && TYPE_UNSIGNED (gnu_type)) + { + gnu_type = gnat_signed_type (gnu_type); + ignore_lhs_overflow = true; + } + + if (gnu_type != gnu_result_type) + { + tree gnu_old_lhs = gnu_lhs; + gnu_lhs = convert (gnu_type, gnu_lhs); + if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow) + TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs); + gnu_rhs = convert (gnu_type, gnu_rhs); + } + + /* Instead of expanding overflow checks for addition, subtraction + and multiplication itself, the front end will leave this to + the back end when Backend_Overflow_Checks_On_Target is set. + As the GCC back end itself does not know yet how to properly + do overflow checking, do it here. The goal is to push + the expansions further into the back end over time. */ + if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target + && (Nkind (gnat_node) == N_Op_Add + || Nkind (gnat_node) == N_Op_Subtract + || Nkind (gnat_node) == N_Op_Multiply) + && !TYPE_UNSIGNED (gnu_type) + && !FLOAT_TYPE_P (gnu_type)) + gnu_result + = build_binary_op_trapv (code, gnu_type, gnu_lhs, gnu_rhs); + else + gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs); + + /* If this is a logical shift with the shift count not verified, + we must return zero if it is too large. We cannot compensate + above in this case. */ + if ((Nkind (gnat_node) == N_Op_Shift_Left + || Nkind (gnat_node) == N_Op_Shift_Right) + && !Shift_Count_OK (gnat_node)) + gnu_result + = build_cond_expr + (gnu_type, + build_binary_op (GE_EXPR, integer_type_node, + gnu_rhs, + convert (TREE_TYPE (gnu_rhs), + TYPE_SIZE (gnu_type))), + convert (gnu_type, integer_zero_node), + gnu_result); + } + break; + + case N_Conditional_Expression: + { + tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node))); + tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node)))); + tree gnu_false + = gnat_to_gnu (Next (Next (First (Expressions (gnat_node))))); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = build_cond_expr (gnu_result_type, + gnat_truthvalue_conversion (gnu_cond), + gnu_true, gnu_false); + } + break; + + case N_Op_Plus: + gnu_result = gnat_to_gnu (Right_Opnd (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; + + case N_Op_Not: + /* This case can apply to a boolean or a modular type. + Fall through for a boolean operand since GNU_CODES is set + up to handle this. */ + if (Is_Modular_Integer_Type (Etype (gnat_node)) + || (Ekind (Etype (gnat_node)) == E_Private_Type + && Is_Modular_Integer_Type (Full_View (Etype (gnat_node))))) + { + gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type, + gnu_expr); + break; + } + + /* ... fall through ... */ + + case N_Op_Minus: case N_Op_Abs: + gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node)); + + if (Ekind (Etype (gnat_node)) != E_Private_Type) + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + else + gnu_result_type = get_unpadded_type (Base_Type + (Full_View (Etype (gnat_node)))); + + if (Do_Overflow_Check (gnat_node) + && !TYPE_UNSIGNED (gnu_result_type) + && !FLOAT_TYPE_P (gnu_result_type)) + gnu_result = build_unary_op_trapv (gnu_codes[Nkind (gnat_node)], + gnu_result_type, gnu_expr); + else + gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)], + gnu_result_type, gnu_expr); + break; + + case N_Allocator: + { + tree gnu_init = 0; + tree gnu_type; + bool ignore_init_type = false; + + gnat_temp = Expression (gnat_node); + + /* The Expression operand can either be an N_Identifier or + Expanded_Name, which must represent a type, or a + N_Qualified_Expression, which contains both the object type and an + initial value for the object. */ + if (Nkind (gnat_temp) == N_Identifier + || Nkind (gnat_temp) == N_Expanded_Name) + gnu_type = gnat_to_gnu_type (Entity (gnat_temp)); + else if (Nkind (gnat_temp) == N_Qualified_Expression) + { + Entity_Id gnat_desig_type + = Designated_Type (Underlying_Type (Etype (gnat_node))); + + ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type); + gnu_init = gnat_to_gnu (Expression (gnat_temp)); + + gnu_init = maybe_unconstrained_array (gnu_init); + if (Do_Range_Check (Expression (gnat_temp))) + gnu_init = emit_range_check (gnu_init, gnat_desig_type); + + if (Is_Elementary_Type (gnat_desig_type) + || Is_Constrained (gnat_desig_type)) + { + gnu_type = gnat_to_gnu_type (gnat_desig_type); + gnu_init = convert (gnu_type, gnu_init); + } + else + { + gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp))); + if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_type = TREE_TYPE (gnu_init); + + gnu_init = convert (gnu_type, gnu_init); + } + } + else + gcc_unreachable (); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + return build_allocator (gnu_type, gnu_init, gnu_result_type, + Procedure_To_Call (gnat_node), + Storage_Pool (gnat_node), gnat_node, + ignore_init_type); + } + break; + + /***************************/ + /* Chapter 5: Statements: */ + /***************************/ + + case N_Label: + gnu_result = build1 (LABEL_EXPR, void_type_node, + gnat_to_gnu (Identifier (gnat_node))); + break; + + case N_Null_Statement: + gnu_result = alloc_stmt_list (); + break; + + case N_Assignment_Statement: + /* Get the LHS and RHS of the statement and convert any reference to an + unconstrained array into a reference to the underlying array. + If we are not to do range checking and the RHS is an N_Function_Call, + pass the LHS to the call function. */ + gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node))); + + /* If the type has a size that overflows, convert this into raise of + Storage_Error: execution shouldn't have gotten here anyway. */ + if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST + && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs)))) + gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node, + N_Raise_Storage_Error); + else if (Nkind (Expression (gnat_node)) == N_Function_Call + && !Do_Range_Check (Expression (gnat_node))) + gnu_result = call_to_gnu (Expression (gnat_node), + &gnu_result_type, gnu_lhs); + else + { + gnu_rhs + = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node))); + + /* If range check is needed, emit code to generate it. */ + if (Do_Range_Check (Expression (gnat_node))) + gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node))); + + gnu_result + = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs); + + /* If the type being assigned is an array type and the two sides + are not completely disjoint, play safe and use memmove. */ + if (TREE_CODE (gnu_result) == MODIFY_EXPR + && Is_Array_Type (Etype (Name (gnat_node))) + && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node))) + { + tree to, from, size, to_ptr, from_ptr, t; + + to = TREE_OPERAND (gnu_result, 0); + from = TREE_OPERAND (gnu_result, 1); + + size = TYPE_SIZE_UNIT (TREE_TYPE (from)); + size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, from); + + to_ptr = build_fold_addr_expr (to); + from_ptr = build_fold_addr_expr (from); + + t = implicit_built_in_decls[BUILT_IN_MEMMOVE]; + gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size); + } + } + break; + + case N_If_Statement: + { + tree *gnu_else_ptr; /* Point to put next "else if" or "else". */ + + /* Make the outer COND_EXPR. Avoid non-determinism. */ + gnu_result = build3 (COND_EXPR, void_type_node, + gnat_to_gnu (Condition (gnat_node)), + NULL_TREE, NULL_TREE); + COND_EXPR_THEN (gnu_result) + = build_stmt_group (Then_Statements (gnat_node), false); + TREE_SIDE_EFFECTS (gnu_result) = 1; + gnu_else_ptr = &COND_EXPR_ELSE (gnu_result); + + /* Now make a COND_EXPR for each of the "else if" parts. Put each + into the previous "else" part and point to where to put any + outer "else". Also avoid non-determinism. */ + if (Present (Elsif_Parts (gnat_node))) + for (gnat_temp = First (Elsif_Parts (gnat_node)); + Present (gnat_temp); gnat_temp = Next (gnat_temp)) + { + gnu_expr = build3 (COND_EXPR, void_type_node, + gnat_to_gnu (Condition (gnat_temp)), + NULL_TREE, NULL_TREE); + COND_EXPR_THEN (gnu_expr) + = build_stmt_group (Then_Statements (gnat_temp), false); + TREE_SIDE_EFFECTS (gnu_expr) = 1; + set_expr_location_from_node (gnu_expr, gnat_temp); + *gnu_else_ptr = gnu_expr; + gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr); + } + + *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false); + } + break; + + case N_Case_Statement: + gnu_result = Case_Statement_to_gnu (gnat_node); + break; + + case N_Loop_Statement: + gnu_result = Loop_Statement_to_gnu (gnat_node); + break; + + case N_Block_Statement: + start_stmt_group (); + gnat_pushlevel (); + process_decls (Declarations (gnat_node), Empty, Empty, true, true); + add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); + gnat_poplevel (); + gnu_result = end_stmt_group (); + + if (Present (Identifier (gnat_node))) + mark_out_of_scope (Entity (Identifier (gnat_node))); + break; + + case N_Exit_Statement: + gnu_result + = build2 (EXIT_STMT, void_type_node, + (Present (Condition (gnat_node)) + ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE), + (Present (Name (gnat_node)) + ? get_gnu_tree (Entity (Name (gnat_node))) + : TREE_VALUE (gnu_loop_label_stack))); + break; + + case N_Return_Statement: + { + /* The gnu function type of the subprogram currently processed. */ + tree gnu_subprog_type = TREE_TYPE (current_function_decl); + /* The return value from the subprogram. */ + tree gnu_ret_val = NULL_TREE; + /* The place to put the return value. */ + tree gnu_lhs; + + /* If we are dealing with a "return;" from an Ada procedure with + parameters passed by copy in copy out, we need to return a record + containing the final values of these parameters. If the list + contains only one entry, return just that entry. + + For a full description of the copy in copy out parameter mechanism, + see the part of the gnat_to_gnu_entity routine dealing with the + translation of subprograms. + + But if we have a return label defined, convert this into + a branch to that label. */ + + if (TREE_VALUE (gnu_return_label_stack)) + { + gnu_result = build1 (GOTO_EXPR, void_type_node, + TREE_VALUE (gnu_return_label_stack)); + break; + } + + else if (TYPE_CI_CO_LIST (gnu_subprog_type)) + { + gnu_lhs = DECL_RESULT (current_function_decl); + if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1) + gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type)); + else + gnu_ret_val + = gnat_build_constructor (TREE_TYPE (gnu_subprog_type), + TYPE_CI_CO_LIST (gnu_subprog_type)); + } + + /* If the Ada subprogram is a function, we just need to return the + expression. If the subprogram returns an unconstrained + array, we have to allocate a new version of the result and + return it. If we return by reference, return a pointer. */ + + else if (Present (Expression (gnat_node))) + { + /* If the current function returns by target pointer and we + are doing a call, pass that target to the call. */ + if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type) + && Nkind (Expression (gnat_node)) == N_Function_Call) + { + gnu_lhs + = build_unary_op (INDIRECT_REF, NULL_TREE, + DECL_ARGUMENTS (current_function_decl)); + gnu_result = call_to_gnu (Expression (gnat_node), + &gnu_result_type, gnu_lhs); + } + else + { + gnu_ret_val = gnat_to_gnu (Expression (gnat_node)); + + if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)) + /* The original return type was unconstrained so dereference + the TARGET pointer in the actual return value's type. */ + gnu_lhs + = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val), + DECL_ARGUMENTS (current_function_decl)); + else + gnu_lhs = DECL_RESULT (current_function_decl); + + /* Do not remove the padding from GNU_RET_VAL if the inner + type is self-referential since we want to allocate the fixed + size in that case. */ + if (TREE_CODE (gnu_ret_val) == COMPONENT_REF + && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))) + == RECORD_TYPE) + && (TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))) + && (CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))) + gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0); + + if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type) + || By_Ref (gnat_node)) + gnu_ret_val + = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val); + + else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)) + { + gnu_ret_val = maybe_unconstrained_array (gnu_ret_val); + gnu_ret_val + = build_allocator (TREE_TYPE (gnu_ret_val), + gnu_ret_val, + TREE_TYPE (gnu_subprog_type), + Procedure_To_Call (gnat_node), + Storage_Pool (gnat_node), + gnat_node, false); + } + } + } + else + /* If the Ada subprogram is a regular procedure, just return. */ + gnu_lhs = NULL_TREE; + + if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)) + { + if (gnu_ret_val) + gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, + gnu_lhs, gnu_ret_val); + add_stmt_with_node (gnu_result, gnat_node); + gnu_lhs = NULL_TREE; + } + + gnu_result = build_return_expr (gnu_lhs, gnu_ret_val); + } + break; + + case N_Goto_Statement: + gnu_result = build1 (GOTO_EXPR, void_type_node, + gnat_to_gnu (Name (gnat_node))); + break; + + /****************************/ + /* Chapter 6: Subprograms: */ + /****************************/ + + case N_Subprogram_Declaration: + /* Unless there is a freeze node, declare the subprogram. We consider + this a "definition" even though we're not generating code for + the subprogram because we will be making the corresponding GCC + node here. */ + + if (No (Freeze_Node (Defining_Entity (Specification (gnat_node))))) + gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)), + NULL_TREE, 1); + gnu_result = alloc_stmt_list (); + break; + + case N_Abstract_Subprogram_Declaration: + /* This subprogram doesn't exist for code generation purposes, but we + have to elaborate the types of any parameters and result, unless + they are imported types (nothing to generate in this case). */ + + /* Process the parameter types first. */ + + for (gnat_temp + = First_Formal_With_Extras + (Defining_Entity (Specification (gnat_node))); + Present (gnat_temp); + gnat_temp = Next_Formal_With_Extras (gnat_temp)) + if (Is_Itype (Etype (gnat_temp)) + && !From_With_Type (Etype (gnat_temp))) + gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); + + + /* Then the result type, set to Standard_Void_Type for procedures. */ + + { + Entity_Id gnat_temp_type + = Etype (Defining_Entity (Specification (gnat_node))); + + if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type)) + gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0); + } + + gnu_result = alloc_stmt_list (); + break; + + case N_Defining_Program_Unit_Name: + /* For a child unit identifier go up a level to get the + specification. We get this when we try to find the spec of + a child unit package that is the compilation unit being compiled. */ + gnu_result = gnat_to_gnu (Parent (gnat_node)); + break; + + case N_Subprogram_Body: + Subprogram_Body_to_gnu (gnat_node); + gnu_result = alloc_stmt_list (); + break; + + case N_Function_Call: + case N_Procedure_Call_Statement: + gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE); + break; + + /*************************/ + /* Chapter 7: Packages: */ + /*************************/ + + case N_Package_Declaration: + gnu_result = gnat_to_gnu (Specification (gnat_node)); + break; + + case N_Package_Specification: + + start_stmt_group (); + process_decls (Visible_Declarations (gnat_node), + Private_Declarations (gnat_node), Empty, true, true); + gnu_result = end_stmt_group (); + break; + + case N_Package_Body: + + /* If this is the body of a generic package - do nothing */ + if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package) + { + gnu_result = alloc_stmt_list (); + break; + } + + start_stmt_group (); + process_decls (Declarations (gnat_node), Empty, Empty, true, true); + + if (Present (Handled_Statement_Sequence (gnat_node))) + add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); + + gnu_result = end_stmt_group (); + break; + + /*********************************/ + /* Chapter 8: Visibility Rules: */ + /*********************************/ + + case N_Use_Package_Clause: + case N_Use_Type_Clause: + /* Nothing to do here - but these may appear in list of declarations */ + gnu_result = alloc_stmt_list (); + break; + + /***********************/ + /* Chapter 9: Tasks: */ + /***********************/ + + case N_Protected_Type_Declaration: + gnu_result = alloc_stmt_list (); + break; + + case N_Single_Task_Declaration: + gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1); + gnu_result = alloc_stmt_list (); + break; + + /***********************************************************/ + /* Chapter 10: Program Structure and Compilation Issues: */ + /***********************************************************/ + + case N_Compilation_Unit: + + /* This is not called for the main unit, which is handled in function + gigi above. */ + start_stmt_group (); + gnat_pushlevel (); + + Compilation_Unit_to_gnu (gnat_node); + gnu_result = alloc_stmt_list (); + break; + + case N_Subprogram_Body_Stub: + case N_Package_Body_Stub: + case N_Protected_Body_Stub: + case N_Task_Body_Stub: + /* Simply process whatever unit is being inserted. */ + gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node))); + break; + + case N_Subunit: + gnu_result = gnat_to_gnu (Proper_Body (gnat_node)); + break; + + /***************************/ + /* Chapter 11: Exceptions: */ + /***************************/ + + case N_Handled_Sequence_Of_Statements: + /* If there is an At_End procedure attached to this node, and the EH + mechanism is SJLJ, we must have at least a corresponding At_End + handler, unless the No_Exception_Handlers restriction is set. */ + gcc_assert (type_annotate_only + || Exception_Mechanism != Setjmp_Longjmp + || No (At_End_Proc (gnat_node)) + || Present (Exception_Handlers (gnat_node)) + || No_Exception_Handlers_Set ()); + + gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node); + break; + + case N_Exception_Handler: + if (Exception_Mechanism == Setjmp_Longjmp) + gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node); + else if (Exception_Mechanism == Back_End_Exceptions) + gnu_result = Exception_Handler_to_gnu_zcx (gnat_node); + else + gcc_unreachable (); + + break; + + case N_Push_Constraint_Error_Label: + push_exception_label_stack (&gnu_constraint_error_label_stack, + Exception_Label (gnat_node)); + break; + + case N_Push_Storage_Error_Label: + push_exception_label_stack (&gnu_storage_error_label_stack, + Exception_Label (gnat_node)); + break; + + case N_Push_Program_Error_Label: + push_exception_label_stack (&gnu_program_error_label_stack, + Exception_Label (gnat_node)); + break; + + case N_Pop_Constraint_Error_Label: + gnu_constraint_error_label_stack + = TREE_CHAIN (gnu_constraint_error_label_stack); + break; + + case N_Pop_Storage_Error_Label: + gnu_storage_error_label_stack + = TREE_CHAIN (gnu_storage_error_label_stack); + break; + + case N_Pop_Program_Error_Label: + gnu_program_error_label_stack + = TREE_CHAIN (gnu_program_error_label_stack); + break; + + /*******************************/ + /* Chapter 12: Generic Units: */ + /*******************************/ + + case N_Generic_Function_Renaming_Declaration: + case N_Generic_Package_Renaming_Declaration: + case N_Generic_Procedure_Renaming_Declaration: + case N_Generic_Package_Declaration: + case N_Generic_Subprogram_Declaration: + case N_Package_Instantiation: + case N_Procedure_Instantiation: + case N_Function_Instantiation: + /* These nodes can appear on a declaration list but there is nothing to + to be done with them. */ + gnu_result = alloc_stmt_list (); + break; + + /***************************************************/ + /* Chapter 13: Representation Clauses and */ + /* Implementation-Dependent Features: */ + /***************************************************/ + + case N_Attribute_Definition_Clause: + gnu_result = alloc_stmt_list (); + + /* The only one we need to deal with is 'Address since, for the others, + the front-end puts the information elsewhere. */ + if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address) + break; + + /* And we only deal with 'Address if the object has a Freeze node. */ + gnat_temp = Entity (Name (gnat_node)); + if (No (Freeze_Node (gnat_temp))) + break; + + /* Get the value to use as the address and save it as the equivalent + for the object. When it is frozen, gnat_to_gnu_entity will do the + right thing. */ + save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true); + break; + + case N_Enumeration_Representation_Clause: + case N_Record_Representation_Clause: + case N_At_Clause: + /* We do nothing with these. SEM puts the information elsewhere. */ + gnu_result = alloc_stmt_list (); + break; + + case N_Code_Statement: + if (!type_annotate_only) + { + tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node)); + tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE; + tree gnu_clobbers = NULL_TREE, tail; + bool allows_mem, allows_reg, fake; + int ninputs, noutputs, i; + const char **oconstraints; + const char *constraint; + char *clobber; + + /* First retrieve the 3 operand lists built by the front-end. */ + Setup_Asm_Outputs (gnat_node); + while (Present (gnat_temp = Asm_Output_Variable ())) + { + tree gnu_value = gnat_to_gnu (gnat_temp); + tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu + (Asm_Output_Constraint ())); + + gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs); + Next_Asm_Output (); + } + + Setup_Asm_Inputs (gnat_node); + while (Present (gnat_temp = Asm_Input_Value ())) + { + tree gnu_value = gnat_to_gnu (gnat_temp); + tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu + (Asm_Input_Constraint ())); + + gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs); + Next_Asm_Input (); + } + + Clobber_Setup (gnat_node); + while ((clobber = Clobber_Get_Next ())) + gnu_clobbers + = tree_cons (NULL_TREE, + build_string (strlen (clobber) + 1, clobber), + gnu_clobbers); + + /* Then perform some standard checking and processing on the + operands. In particular, mark them addressable if needed. */ + gnu_outputs = nreverse (gnu_outputs); + noutputs = list_length (gnu_outputs); + gnu_inputs = nreverse (gnu_inputs); + ninputs = list_length (gnu_inputs); + oconstraints + = (const char **) alloca (noutputs * sizeof (const char *)); + + for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail)) + { + tree output = TREE_VALUE (tail); + constraint + = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail))); + oconstraints[i] = constraint; + + if (parse_output_constraint (&constraint, i, ninputs, noutputs, + &allows_mem, &allows_reg, &fake)) + { + /* If the operand is going to end up in memory, + mark it addressable. Note that we don't test + allows_mem like in the input case below; this + is modelled on the C front-end. */ + if (!allows_reg + && !gnat_mark_addressable (output)) + output = error_mark_node; + } + else + output = error_mark_node; + + TREE_VALUE (tail) = output; + } + + for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail)) + { + tree input = TREE_VALUE (tail); + constraint + = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail))); + + if (parse_input_constraint (&constraint, i, ninputs, noutputs, + 0, oconstraints, + &allows_mem, &allows_reg)) + { + /* If the operand is going to end up in memory, + mark it addressable. */ + if (!allows_reg && allows_mem + && !gnat_mark_addressable (input)) + input = error_mark_node; + } + else + input = error_mark_node; + + TREE_VALUE (tail) = input; + } + + gnu_result = build4 (ASM_EXPR, void_type_node, + gnu_template, gnu_outputs, + gnu_inputs, gnu_clobbers); + ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node); + } + else + gnu_result = alloc_stmt_list (); + + break; + + /***************************************************/ + /* Added Nodes */ + /***************************************************/ + + case N_Freeze_Entity: + start_stmt_group (); + process_freeze_entity (gnat_node); + process_decls (Actions (gnat_node), Empty, Empty, true, true); + gnu_result = end_stmt_group (); + break; + + case N_Itype_Reference: + if (!present_gnu_tree (Itype (gnat_node))) + process_type (Itype (gnat_node)); + + gnu_result = alloc_stmt_list (); + break; + + case N_Free_Statement: + if (!type_annotate_only) + { + tree gnu_ptr = gnat_to_gnu (Expression (gnat_node)); + tree gnu_ptr_type = TREE_TYPE (gnu_ptr); + tree gnu_obj_type; + tree gnu_actual_obj_type = 0; + tree gnu_obj_size; + unsigned int align; + unsigned int default_allocator_alignment + = get_target_default_allocator_alignment () * BITS_PER_UNIT; + + /* If this is a thin pointer, we must dereference it to create + a fat pointer, then go back below to a thin pointer. The + reason for this is that we need a fat pointer someplace in + order to properly compute the size. */ + if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr))) + gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE, + build_unary_op (INDIRECT_REF, NULL_TREE, + gnu_ptr)); + + /* If this is an unconstrained array, we know the object must + have been allocated with the template in front of the object. + So pass the template address, but get the total size. Do this + by converting to a thin pointer. */ + if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) + gnu_ptr + = convert (build_pointer_type + (TYPE_OBJECT_RECORD_TYPE + (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))), + gnu_ptr); + + gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr)); + + if (Present (Actual_Designated_Subtype (gnat_node))) + { + gnu_actual_obj_type + = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node)); + + if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)) + gnu_actual_obj_type + = build_unc_object_type_from_ptr (gnu_ptr_type, + gnu_actual_obj_type, + get_identifier ("DEALLOC")); + } + else + gnu_actual_obj_type = gnu_obj_type; + + gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type); + align = TYPE_ALIGN (gnu_obj_type); + + if (TREE_CODE (gnu_obj_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type)) + { + tree gnu_char_ptr_type = build_pointer_type (char_type_node); + tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type)); + tree gnu_byte_offset + = convert (sizetype, + size_diffop (size_zero_node, gnu_pos)); + gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset); + + gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr); + gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type, + gnu_ptr, gnu_byte_offset); + } + + /* If the object was allocated from the default storage pool, the + alignment was greater than what the allocator provides, and this + is not a fat or thin pointer, what we have in gnu_ptr here is an + address dynamically adjusted to match the alignment requirement + (see build_allocator). What we need to pass to free is the + initial allocator's return value, which has been stored just in + front of the block we have. */ + + if (No (Procedure_To_Call (gnat_node)) + && align > default_allocator_alignment + && ! TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)) + { + /* We set GNU_PTR + as * (void **)((void *)GNU_PTR - (void *)sizeof(void *)) + in two steps: */ + + /* GNU_PTR (void *) + = (void *)GNU_PTR - (void *)sizeof (void *)) */ + gnu_ptr + = build_binary_op + (POINTER_PLUS_EXPR, ptr_void_type_node, + convert (ptr_void_type_node, gnu_ptr), + size_int (-POINTER_SIZE/BITS_PER_UNIT)); + + /* GNU_PTR (void *) = *(void **)GNU_PTR */ + gnu_ptr + = build_unary_op + (INDIRECT_REF, NULL_TREE, + convert (build_pointer_type (ptr_void_type_node), + gnu_ptr)); + } + + gnu_result = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align, + Procedure_To_Call (gnat_node), + Storage_Pool (gnat_node), + gnat_node); + } + break; + + case N_Raise_Constraint_Error: + case N_Raise_Program_Error: + case N_Raise_Storage_Error: + if (type_annotate_only) + { + gnu_result = alloc_stmt_list (); + break; + } + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result + = build_call_raise (UI_To_Int (Reason (gnat_node)), gnat_node, + Nkind (gnat_node)); + + /* If the type is VOID, this is a statement, so we need to + generate the code for the call. Handle a Condition, if there + is one. */ + if (TREE_CODE (gnu_result_type) == VOID_TYPE) + { + set_expr_location_from_node (gnu_result, gnat_node); + + if (Present (Condition (gnat_node))) + gnu_result = build3 (COND_EXPR, void_type_node, + gnat_to_gnu (Condition (gnat_node)), + gnu_result, alloc_stmt_list ()); + } + else + gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result); + break; + + case N_Validate_Unchecked_Conversion: + { + Entity_Id gnat_target_type = Target_Type (gnat_node); + tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node)); + tree gnu_target_type = gnat_to_gnu_type (gnat_target_type); + + /* No need for any warning in this case. */ + if (!flag_strict_aliasing) + ; + + /* If the result is a pointer type, see if we are either converting + from a non-pointer or from a pointer to a type with a different + alias set and warn if so. If the result is defined in the same + unit as this unchecked conversion, we can allow this because we + can know to make the pointer type behave properly. */ + else if (POINTER_TYPE_P (gnu_target_type) + && !In_Same_Source_Unit (gnat_target_type, gnat_node) + && !No_Strict_Aliasing (Underlying_Type (gnat_target_type))) + { + tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type) + ? TREE_TYPE (gnu_source_type) + : NULL_TREE; + tree gnu_target_desig_type = TREE_TYPE (gnu_target_type); + + if ((TYPE_DUMMY_P (gnu_target_desig_type) + || get_alias_set (gnu_target_desig_type) != 0) + && (!POINTER_TYPE_P (gnu_source_type) + || (TYPE_DUMMY_P (gnu_source_desig_type) + != TYPE_DUMMY_P (gnu_target_desig_type)) + || (TYPE_DUMMY_P (gnu_source_desig_type) + && gnu_source_desig_type != gnu_target_desig_type) + || !alias_sets_conflict_p + (get_alias_set (gnu_source_desig_type), + get_alias_set (gnu_target_desig_type)))) + { + post_error_ne + ("?possible aliasing problem for type&", + gnat_node, Target_Type (gnat_node)); + post_error + ("\\?use -fno-strict-aliasing switch for references", + gnat_node); + post_error_ne + ("\\?or use `pragma No_Strict_Aliasing (&);`", + gnat_node, Target_Type (gnat_node)); + } + } + + /* But if the result is a fat pointer type, we have no mechanism to + do that, so we unconditionally warn in problematic cases. */ + else if (TYPE_FAT_POINTER_P (gnu_target_type)) + { + tree gnu_source_array_type + = TYPE_FAT_POINTER_P (gnu_source_type) + ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type))) + : NULL_TREE; + tree gnu_target_array_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type))); + + if ((TYPE_DUMMY_P (gnu_target_array_type) + || get_alias_set (gnu_target_array_type) != 0) + && (!TYPE_FAT_POINTER_P (gnu_source_type) + || (TYPE_DUMMY_P (gnu_source_array_type) + != TYPE_DUMMY_P (gnu_target_array_type)) + || (TYPE_DUMMY_P (gnu_source_array_type) + && gnu_source_array_type != gnu_target_array_type) + || !alias_sets_conflict_p + (get_alias_set (gnu_source_array_type), + get_alias_set (gnu_target_array_type)))) + { + post_error_ne + ("?possible aliasing problem for type&", + gnat_node, Target_Type (gnat_node)); + post_error + ("\\?use -fno-strict-aliasing switch for references", + gnat_node); + } + } + } + gnu_result = alloc_stmt_list (); + break; + + case N_Raise_Statement: + case N_Function_Specification: + case N_Procedure_Specification: + case N_Op_Concat: + case N_Component_Association: + case N_Task_Body: + default: + gcc_assert (type_annotate_only); + gnu_result = alloc_stmt_list (); + } + + /* If we pushed our level as part of processing the elaboration routine, + pop it back now. */ + if (went_into_elab_proc) + { + add_stmt (gnu_result); + gnat_poplevel (); + gnu_result = end_stmt_group (); + current_function_decl = NULL_TREE; + } + + /* Set the location information on the result if it is a real expression. + References can be reused for multiple GNAT nodes and they would get + the location information of their last use. Note that we may have + no result if we tried to build a CALL_EXPR node to a procedure with + no side-effects and optimization is enabled. */ + if (gnu_result + && EXPR_P (gnu_result) + && TREE_CODE (gnu_result) != NOP_EXPR + && !REFERENCE_CLASS_P (gnu_result)) + set_expr_location_from_node (gnu_result, gnat_node); + + /* If we're supposed to return something of void_type, it means we have + something we're elaborating for effect, so just return. */ + if (TREE_CODE (gnu_result_type) == VOID_TYPE) + return gnu_result; + + /* If the result is a constant that overflows, raise constraint error. */ + else if (TREE_CODE (gnu_result) == INTEGER_CST + && TREE_OVERFLOW (gnu_result)) + { + post_error ("Constraint_Error will be raised at run-time?", gnat_node); + + gnu_result + = build1 (NULL_EXPR, gnu_result_type, + build_call_raise (CE_Overflow_Check_Failed, gnat_node, + N_Raise_Constraint_Error)); + } + + /* If our result has side-effects and is of an unconstrained type, + make a SAVE_EXPR so that we can be sure it will only be referenced + once. Note we must do this before any conversions. */ + if (TREE_SIDE_EFFECTS (gnu_result) + && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE + || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))) + gnu_result = gnat_stabilize_reference (gnu_result, false); + + /* Now convert the result to the result type, unless we are in one of the + following cases: + + 1. If this is the Name of an assignment statement or a parameter of + a procedure call, return the result almost unmodified since the + RHS will have to be converted to our type in that case, unless + the result type has a simpler size. Similarly, don't convert + integral types that are the operands of an unchecked conversion + since we need to ignore those conversions (for 'Valid). + + 2. If we have a label (which doesn't have any well-defined type), a + field or an error, return the result almost unmodified. Also don't + do the conversion if the result type involves a PLACEHOLDER_EXPR in + its size since those are the cases where the front end may have the + type wrong due to "instantiating" the unconstrained record with + discriminant values. Similarly, if the two types are record types + with the same name don't convert. This will be the case when we are + converting from a packable version of a type to its original type and + we need those conversions to be NOPs in order for assignments into + these types to work properly. + + 3. If the type is void or if we have no result, return error_mark_node + to show we have no result. + + 4. Finally, if the type of the result is already correct. */ + + if (Present (Parent (gnat_node)) + && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement + && Name (Parent (gnat_node)) == gnat_node) + || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement + && Name (Parent (gnat_node)) != gnat_node) + || Nkind (Parent (gnat_node)) == N_Parameter_Association + || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion + && !AGGREGATE_TYPE_P (gnu_result_type) + && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))) + && !(TYPE_SIZE (gnu_result_type) + && TYPE_SIZE (TREE_TYPE (gnu_result)) + && (AGGREGATE_TYPE_P (gnu_result_type) + == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))) + && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST + && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result))) + != INTEGER_CST)) + || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST + && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)) + && (CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (gnu_result)))))) + && !(TREE_CODE (gnu_result_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type)))) + { + /* Remove padding only if the inner object is of self-referential + size: in that case it must be an object of unconstrained type + with a default discriminant and we want to avoid copying too + much data. */ + if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)) + && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS + (TREE_TYPE (gnu_result)))))) + gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), + gnu_result); + } + + else if (TREE_CODE (gnu_result) == LABEL_DECL + || TREE_CODE (gnu_result) == FIELD_DECL + || TREE_CODE (gnu_result) == ERROR_MARK + || (TYPE_SIZE (gnu_result_type) + && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST + && TREE_CODE (gnu_result) != INDIRECT_REF + && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))) + || ((TYPE_NAME (gnu_result_type) + == TYPE_NAME (TREE_TYPE (gnu_result))) + && TREE_CODE (gnu_result_type) == RECORD_TYPE + && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE)) + { + /* Remove any padding. */ + if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) + gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), + gnu_result); + } + + else if (gnu_result == error_mark_node || gnu_result_type == void_type_node) + gnu_result = error_mark_node; + + else if (gnu_result_type != TREE_TYPE (gnu_result)) + gnu_result = convert (gnu_result_type, gnu_result); + + /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */ + while ((TREE_CODE (gnu_result) == NOP_EXPR + || TREE_CODE (gnu_result) == NON_LVALUE_EXPR) + && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result)) + gnu_result = TREE_OPERAND (gnu_result, 0); + + return gnu_result; + } + + /* Subroutine of above to push the exception label stack. GNU_STACK is + a pointer to the stack to update and GNAT_LABEL, if present, is the + label to push onto the stack. */ + + static void + push_exception_label_stack (tree *gnu_stack, Entity_Id gnat_label) + { + tree gnu_label = (Present (gnat_label) + ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0) + : NULL_TREE); + + *gnu_stack = tree_cons (NULL_TREE, gnu_label, *gnu_stack); + } + + /* Record the current code position in GNAT_NODE. */ + + static void + record_code_position (Node_Id gnat_node) + { + tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE); + + add_stmt_with_node (stmt_stmt, gnat_node); + save_gnu_tree (gnat_node, stmt_stmt, true); + } + + /* Insert the code for GNAT_NODE at the position saved for that node. */ + + static void + insert_code_for (Node_Id gnat_node) + { + STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node); + save_gnu_tree (gnat_node, NULL_TREE, true); + } + + /* Start a new statement group chained to the previous group. */ + + void + start_stmt_group (void) + { + struct stmt_group *group = stmt_group_free_list; + + /* First see if we can get one from the free list. */ + if (group) + stmt_group_free_list = group->previous; + else + group = (struct stmt_group *) ggc_alloc (sizeof (struct stmt_group)); + + group->previous = current_stmt_group; + group->stmt_list = group->block = group->cleanups = NULL_TREE; + current_stmt_group = group; + } + + /* Add GNU_STMT to the current statement group. */ + + void + add_stmt (tree gnu_stmt) + { + append_to_statement_list (gnu_stmt, ¤t_stmt_group->stmt_list); + } + + /* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */ + + void + add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node) + { + if (Present (gnat_node)) + set_expr_location_from_node (gnu_stmt, gnat_node); + add_stmt (gnu_stmt); + } + + /* Add a declaration statement for GNU_DECL to the current statement group. + Get SLOC from Entity_Id. */ + + void + add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) + { + tree type = TREE_TYPE (gnu_decl); + tree gnu_stmt, gnu_init, t; + + /* If this is a variable that Gigi is to ignore, we may have been given + an ERROR_MARK. So test for it. We also might have been given a + reference for a renaming. So only do something for a decl. Also + ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */ + if (!DECL_P (gnu_decl) + || (TREE_CODE (gnu_decl) == TYPE_DECL + && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)) + return; + + gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl); + + /* If we are global, we don't want to actually output the DECL_EXPR for + this decl since we already have evaluated the expressions in the + sizes and positions as globals and doing it again would be wrong. */ + if (global_bindings_p ()) + { + /* Mark everything as used to prevent node sharing with subprograms. + Note that walk_tree knows how to deal with TYPE_DECL, but neither + VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */ + mark_visited (&gnu_stmt); + if (TREE_CODE (gnu_decl) == VAR_DECL + || TREE_CODE (gnu_decl) == CONST_DECL) + { + mark_visited (&DECL_SIZE (gnu_decl)); + mark_visited (&DECL_SIZE_UNIT (gnu_decl)); + mark_visited (&DECL_INITIAL (gnu_decl)); + } + /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */ + if (TREE_CODE (gnu_decl) == TYPE_DECL + && (TREE_CODE (type) == RECORD_TYPE + || TREE_CODE (type) == UNION_TYPE + || TREE_CODE (type) == QUAL_UNION_TYPE) + && (t = TYPE_ADA_SIZE (type))) + mark_visited (&t); + } + else + add_stmt_with_node (gnu_stmt, gnat_entity); + + /* If this is a variable and an initializer is attached to it, it must be + valid for the context. Similar to init_const in create_var_decl_1. */ + if (TREE_CODE (gnu_decl) == VAR_DECL + && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE + && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init)) + || (TREE_STATIC (gnu_decl) + && !initializer_constant_valid_p (gnu_init, + TREE_TYPE (gnu_init))))) + { + /* If GNU_DECL has a padded type, convert it to the unpadded + type so the assignment is done properly. */ + if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl); + else + t = gnu_decl; + + gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, t, gnu_init); + + DECL_INITIAL (gnu_decl) = NULL_TREE; + if (TREE_READONLY (gnu_decl)) + { + TREE_READONLY (gnu_decl) = 0; + DECL_READONLY_ONCE_ELAB (gnu_decl) = 1; + } + + add_stmt_with_node (gnu_stmt, gnat_entity); + } + } + + /* Callback for walk_tree to mark the visited trees rooted at *TP. */ + + static tree + mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) + { + if (TREE_VISITED (*tp)) + *walk_subtrees = 0; + + /* Don't mark a dummy type as visited because we want to mark its sizes + and fields once it's filled in. */ + else if (!TYPE_IS_DUMMY_P (*tp)) + TREE_VISITED (*tp) = 1; + + if (TYPE_P (*tp)) + TYPE_SIZES_GIMPLIFIED (*tp) = 1; + + return NULL_TREE; + } + + /* Utility function to unshare expressions wrapped up in a SAVE_EXPR. */ + + static tree + unshare_save_expr (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) + { + tree t = *tp; + + if (TREE_CODE (t) == SAVE_EXPR) + TREE_OPERAND (t, 0) = unshare_expr (TREE_OPERAND (t, 0)); + + return NULL_TREE; + } + + /* Mark nodes rooted at *TP with TREE_VISITED and types as having their + sized gimplified. We use this to indicate all variable sizes and + positions in global types may not be shared by any subprogram. */ + + void + mark_visited (tree *tp) + { + walk_tree (tp, mark_visited_r, NULL, NULL); + } + + /* Add GNU_CLEANUP, a cleanup action, to the current code group and + set its location to that of GNAT_NODE if present. */ + + static void + add_cleanup (tree gnu_cleanup, Node_Id gnat_node) + { + if (Present (gnat_node)) + set_expr_location_from_node (gnu_cleanup, gnat_node); + append_to_statement_list (gnu_cleanup, ¤t_stmt_group->cleanups); + } + + /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */ + + void + set_block_for_group (tree gnu_block) + { + gcc_assert (!current_stmt_group->block); + current_stmt_group->block = gnu_block; + } + + /* Return code corresponding to the current code group. It is normally + a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if + BLOCK or cleanups were set. */ + + tree + end_stmt_group (void) + { + struct stmt_group *group = current_stmt_group; + tree gnu_retval = group->stmt_list; + + /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there + are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK, + make a BIND_EXPR. Note that we nest in that because the cleanup may + reference variables in the block. */ + if (gnu_retval == NULL_TREE) + gnu_retval = alloc_stmt_list (); + + if (group->cleanups) + gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval, + group->cleanups); + + if (current_stmt_group->block) + gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block), + gnu_retval, group->block); + + /* Remove this group from the stack and add it to the free list. */ + current_stmt_group = group->previous; + group->previous = stmt_group_free_list; + stmt_group_free_list = group; + + return gnu_retval; + } + + /* Add a list of statements from GNAT_LIST, a possibly-empty list of + statements.*/ + + static void + add_stmt_list (List_Id gnat_list) + { + Node_Id gnat_node; + + if (Present (gnat_list)) + for (gnat_node = First (gnat_list); Present (gnat_node); + gnat_node = Next (gnat_node)) + add_stmt (gnat_to_gnu (gnat_node)); + } + + /* Build a tree from GNAT_LIST, a possibly-empty list of statements. + If BINDING_P is true, push and pop a binding level around the list. */ + + static tree + build_stmt_group (List_Id gnat_list, bool binding_p) + { + start_stmt_group (); + if (binding_p) + gnat_pushlevel (); + + add_stmt_list (gnat_list); + if (binding_p) + gnat_poplevel (); + + return end_stmt_group (); + } + + /* Push and pop routines for stacks. We keep a free list around so we + don't waste tree nodes. */ + + static void + push_stack (tree *gnu_stack_ptr, tree gnu_purpose, tree gnu_value) + { + tree gnu_node = gnu_stack_free_list; + + if (gnu_node) + { + gnu_stack_free_list = TREE_CHAIN (gnu_node); + TREE_CHAIN (gnu_node) = *gnu_stack_ptr; + TREE_PURPOSE (gnu_node) = gnu_purpose; + TREE_VALUE (gnu_node) = gnu_value; + } + else + gnu_node = tree_cons (gnu_purpose, gnu_value, *gnu_stack_ptr); + + *gnu_stack_ptr = gnu_node; + } + + static void + pop_stack (tree *gnu_stack_ptr) + { + tree gnu_node = *gnu_stack_ptr; + + *gnu_stack_ptr = TREE_CHAIN (gnu_node); + TREE_CHAIN (gnu_node) = gnu_stack_free_list; + gnu_stack_free_list = gnu_node; + } + + /* Generate GIMPLE in place for the expression at *EXPR_P. */ + + int + gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, + gimple_seq *post_p ATTRIBUTE_UNUSED) + { + tree expr = *expr_p; + tree op; + + if (IS_ADA_STMT (expr)) + return gnat_gimplify_stmt (expr_p); + + switch (TREE_CODE (expr)) + { + case NULL_EXPR: + /* If this is for a scalar, just make a VAR_DECL for it. If for + an aggregate, get a null pointer of the appropriate type and + dereference it. */ + if (AGGREGATE_TYPE_P (TREE_TYPE (expr))) + *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr), + convert (build_pointer_type (TREE_TYPE (expr)), + integer_zero_node)); + else + { + *expr_p = create_tmp_var (TREE_TYPE (expr), NULL); + TREE_NO_WARNING (*expr_p) = 1; + } + + gimplify_and_add (TREE_OPERAND (expr, 0), pre_p); + return GS_OK; + + case UNCONSTRAINED_ARRAY_REF: + /* We should only do this if we are just elaborating for side-effects, + but we can't know that yet. */ + *expr_p = TREE_OPERAND (*expr_p, 0); + return GS_OK; + + case ADDR_EXPR: + op = TREE_OPERAND (expr, 0); + + /* If we're taking the address of a constant CONSTRUCTOR, force it to + be put into static memory. We know it's going to be readonly given + the semantics we have and it's required to be static memory in + the case when the reference is in an elaboration procedure. */ + if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op)) + { + tree new_var = create_tmp_var (TREE_TYPE (op), "C"); + + TREE_READONLY (new_var) = 1; + TREE_STATIC (new_var) = 1; + TREE_ADDRESSABLE (new_var) = 1; + DECL_INITIAL (new_var) = op; + + TREE_OPERAND (expr, 0) = new_var; + recompute_tree_invariant_for_addr_expr (expr); + return GS_ALL_DONE; + } + + /* If we are taking the address of a SAVE_EXPR, we are typically + processing a misaligned argument to be passed by reference in a + procedure call. We just mark the operand as addressable + not + readonly here and let the common gimplifier code perform the + temporary creation, initialization, and "instantiation" in place of + the SAVE_EXPR in further operands, in particular in the copy back + code inserted after the call. */ + else if (TREE_CODE (op) == SAVE_EXPR) + { + TREE_ADDRESSABLE (op) = 1; + TREE_READONLY (op) = 0; + } + + /* We let the gimplifier process &COND_EXPR and expect it to yield the + address of the selected operand when it is addressable. Besides, we + also expect addressable_p to only let COND_EXPRs where both arms are + addressable reach here. */ + else if (TREE_CODE (op) == COND_EXPR) + ; + + /* Otherwise, if we are taking the address of something that is neither + reference, declaration, or constant, make a variable for the operand + here and then take its address. If we don't do it this way, we may + confuse the gimplifier because it needs to know the variable is + addressable at this point. This duplicates code in + internal_get_tmp_var, which is unfortunate. */ + else if (TREE_CODE_CLASS (TREE_CODE (op)) != tcc_reference + && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_declaration + && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_constant) + { + tree new_var = create_tmp_var (TREE_TYPE (op), "A"); + gimple stmt; + + TREE_ADDRESSABLE (new_var) = 1; + + stmt = gimplify_assign (new_var, op, pre_p); + if (EXPR_HAS_LOCATION (op)) + gimple_set_location (stmt, *EXPR_LOCUS (op)); + + TREE_OPERAND (expr, 0) = new_var; + recompute_tree_invariant_for_addr_expr (expr); + return GS_ALL_DONE; + } + + /* ... fall through ... */ + + default: + return GS_UNHANDLED; + } + } + + /* Generate GIMPLE in place for the statement at *STMT_P. */ + + static enum gimplify_status + gnat_gimplify_stmt (tree *stmt_p) + { + tree stmt = *stmt_p; + + switch (TREE_CODE (stmt)) + { + case STMT_STMT: + *stmt_p = STMT_STMT_STMT (stmt); + return GS_OK; + + case LOOP_STMT: + { + tree gnu_start_label = create_artificial_label (); + tree gnu_end_label = LOOP_STMT_LABEL (stmt); + tree t; + + /* Set to emit the statements of the loop. */ + *stmt_p = NULL_TREE; + + /* We first emit the start label and then a conditional jump to + the end label if there's a top condition, then the body of the + loop, then a conditional branch to the end label, then the update, + if any, and finally a jump to the start label and the definition + of the end label. */ + append_to_statement_list (build1 (LABEL_EXPR, void_type_node, + gnu_start_label), + stmt_p); + + if (LOOP_STMT_TOP_COND (stmt)) + append_to_statement_list (build3 (COND_EXPR, void_type_node, + LOOP_STMT_TOP_COND (stmt), + alloc_stmt_list (), + build1 (GOTO_EXPR, + void_type_node, + gnu_end_label)), + stmt_p); + + append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p); + + if (LOOP_STMT_BOT_COND (stmt)) + append_to_statement_list (build3 (COND_EXPR, void_type_node, + LOOP_STMT_BOT_COND (stmt), + alloc_stmt_list (), + build1 (GOTO_EXPR, + void_type_node, + gnu_end_label)), + stmt_p); + + if (LOOP_STMT_UPDATE (stmt)) + append_to_statement_list (LOOP_STMT_UPDATE (stmt), stmt_p); + + t = build1 (GOTO_EXPR, void_type_node, gnu_start_label); + SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label)); + append_to_statement_list (t, stmt_p); + + append_to_statement_list (build1 (LABEL_EXPR, void_type_node, + gnu_end_label), + stmt_p); + return GS_OK; + } + + case EXIT_STMT: + /* Build a statement to jump to the corresponding end label, then + see if it needs to be conditional. */ + *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt)); + if (EXIT_STMT_COND (stmt)) + *stmt_p = build3 (COND_EXPR, void_type_node, + EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ()); + return GS_OK; + + default: + gcc_unreachable (); + } + } + + /* Force references to each of the entities in packages withed by GNAT_NODE. + Operate recursively but check that we aren't elaborating something more + than once. + + This routine is exclusively called in type_annotate mode, to compute DDA + information for types in withed units, for ASIS use. */ + + static void + elaborate_all_entities (Node_Id gnat_node) + { + Entity_Id gnat_with_clause, gnat_entity; + + /* Process each unit only once. As we trace the context of all relevant + units transitively, including generic bodies, we may encounter the + same generic unit repeatedly. */ + if (!present_gnu_tree (gnat_node)) + save_gnu_tree (gnat_node, integer_zero_node, true); + + /* Save entities in all context units. A body may have an implicit_with + on its own spec, if the context includes a child unit, so don't save + the spec twice. */ + for (gnat_with_clause = First (Context_Items (gnat_node)); + Present (gnat_with_clause); + gnat_with_clause = Next (gnat_with_clause)) + if (Nkind (gnat_with_clause) == N_With_Clause + && !present_gnu_tree (Library_Unit (gnat_with_clause)) + && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit))) + { + elaborate_all_entities (Library_Unit (gnat_with_clause)); + + if (Ekind (Entity (Name (gnat_with_clause))) == E_Package) + { + for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause))); + Present (gnat_entity); + gnat_entity = Next_Entity (gnat_entity)) + if (Is_Public (gnat_entity) + && Convention (gnat_entity) != Convention_Intrinsic + && Ekind (gnat_entity) != E_Package + && Ekind (gnat_entity) != E_Package_Body + && Ekind (gnat_entity) != E_Operator + && !(IN (Ekind (gnat_entity), Type_Kind) + && !Is_Frozen (gnat_entity)) + && !((Ekind (gnat_entity) == E_Procedure + || Ekind (gnat_entity) == E_Function) + && Is_Intrinsic_Subprogram (gnat_entity)) + && !IN (Ekind (gnat_entity), Named_Kind) + && !IN (Ekind (gnat_entity), Generic_Unit_Kind)) + gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); + } + else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package) + { + Node_Id gnat_body + = Corresponding_Body (Unit (Library_Unit (gnat_with_clause))); + + /* Retrieve compilation unit node of generic body. */ + while (Present (gnat_body) + && Nkind (gnat_body) != N_Compilation_Unit) + gnat_body = Parent (gnat_body); + + /* If body is available, elaborate its context. */ + if (Present (gnat_body)) + elaborate_all_entities (gnat_body); + } + } + + if (Nkind (Unit (gnat_node)) == N_Package_Body) + elaborate_all_entities (Library_Unit (gnat_node)); + } + + /* Do the processing of N_Freeze_Entity, GNAT_NODE. */ + + static void + process_freeze_entity (Node_Id gnat_node) + { + Entity_Id gnat_entity = Entity (gnat_node); + tree gnu_old; + tree gnu_new; + tree gnu_init + = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration + && present_gnu_tree (Declaration_Node (gnat_entity))) + ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE; + + /* If this is a package, need to generate code for the package. */ + if (Ekind (gnat_entity) == E_Package) + { + insert_code_for + (Parent (Corresponding_Body + (Parent (Declaration_Node (gnat_entity))))); + return; + } + + /* Check for old definition after the above call. This Freeze_Node + might be for one its Itypes. */ + gnu_old + = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0; + + /* If this entity has an Address representation clause, GNU_OLD is the + address, so discard it here. */ + if (Present (Address_Clause (gnat_entity))) + gnu_old = 0; + + /* Don't do anything for class-wide types they are always + transformed into their root type. */ + if (Ekind (gnat_entity) == E_Class_Wide_Type + || (Ekind (gnat_entity) == E_Class_Wide_Subtype + && Present (Equivalent_Type (gnat_entity)))) + return; + + /* Don't do anything for subprograms that may have been elaborated before + their freeze nodes. This can happen, for example because of an inner call + in an instance body, or a previous compilation of a spec for inlining + purposes. */ + if (gnu_old + && ((TREE_CODE (gnu_old) == FUNCTION_DECL + && (Ekind (gnat_entity) == E_Function + || Ekind (gnat_entity) == E_Procedure)) + || (gnu_old + && TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE + && Ekind (gnat_entity) == E_Subprogram_Type))) + return; + + /* If we have a non-dummy type old tree, we have nothing to do, except + aborting if this is the public view of a private type whose full view was + not delayed, as this node was never delayed as it should have been. We + let this happen for concurrent types and their Corresponding_Record_Type, + however, because each might legitimately be elaborated before it's own + freeze node, e.g. while processing the other. */ + if (gnu_old + && !(TREE_CODE (gnu_old) == TYPE_DECL + && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))) + { + gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity)) + && No (Freeze_Node (Full_View (gnat_entity)))) + || Is_Concurrent_Type (gnat_entity) + || (IN (Ekind (gnat_entity), Record_Kind) + && Is_Concurrent_Record_Type (gnat_entity))); + return; + } + + /* Reset the saved tree, if any, and elaborate the object or type for real. + If there is a full declaration, elaborate it and copy the type to + GNAT_ENTITY. Likewise if this is the record subtype corresponding to + a class wide type or subtype. */ + if (gnu_old) + { + save_gnu_tree (gnat_entity, NULL_TREE, false); + if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity)) + && present_gnu_tree (Full_View (gnat_entity))) + save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false); + if (Present (Class_Wide_Type (gnat_entity)) + && Class_Wide_Type (gnat_entity) != gnat_entity) + save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false); + } + + if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity))) + { + gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1); + + /* Propagate back-annotations from full view to partial view. */ + if (Unknown_Alignment (gnat_entity)) + Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity))); + + if (Unknown_Esize (gnat_entity)) + Set_Esize (gnat_entity, Esize (Full_View (gnat_entity))); + + if (Unknown_RM_Size (gnat_entity)) + Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity))); + + /* The above call may have defined this entity (the simplest example + of this is when we have a private enumeral type since the bounds + will have the public view. */ + if (!present_gnu_tree (gnat_entity)) + save_gnu_tree (gnat_entity, gnu_new, false); + if (Present (Class_Wide_Type (gnat_entity)) + && Class_Wide_Type (gnat_entity) != gnat_entity) + save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false); + } + else + gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1); + + /* If we've made any pointers to the old version of this type, we + have to update them. */ + if (gnu_old) + update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)), + TREE_TYPE (gnu_new)); + } + + /* Process the list of inlined subprograms of GNAT_NODE, which is an + N_Compilation_Unit. */ + + static void + process_inlined_subprograms (Node_Id gnat_node) + { + Entity_Id gnat_entity; + Node_Id gnat_body; + + /* If we can inline, generate Gimple for all the inlined subprograms. + Define the entity first so we set DECL_EXTERNAL. */ + if (optimize > 0) + for (gnat_entity = First_Inlined_Subprogram (gnat_node); + Present (gnat_entity); + gnat_entity = Next_Inlined_Subprogram (gnat_entity)) + { + gnat_body = Parent (Declaration_Node (gnat_entity)); + + if (Nkind (gnat_body) != N_Subprogram_Body) + { + /* ??? This really should always be Present. */ + if (No (Corresponding_Body (gnat_body))) + continue; + + gnat_body + = Parent (Declaration_Node (Corresponding_Body (gnat_body))); + } + + if (Present (gnat_body)) + { + gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); + add_stmt (gnat_to_gnu (gnat_body)); + } + } + } + + /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present. + We make two passes, one to elaborate anything other than bodies (but + we declare a function if there was no spec). The second pass + elaborates the bodies. + + GNAT_END_LIST gives the element in the list past the end. Normally, + this is Empty, but can be First_Real_Statement for a + Handled_Sequence_Of_Statements. + + We make a complete pass through both lists if PASS1P is true, then make + the second pass over both lists if PASS2P is true. The lists usually + correspond to the public and private parts of a package. */ + + static void + process_decls (List_Id gnat_decls, List_Id gnat_decls2, + Node_Id gnat_end_list, bool pass1p, bool pass2p) + { + List_Id gnat_decl_array[2]; + Node_Id gnat_decl; + int i; + + gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2; + + if (pass1p) + for (i = 0; i <= 1; i++) + if (Present (gnat_decl_array[i])) + for (gnat_decl = First (gnat_decl_array[i]); + gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl)) + { + /* For package specs, we recurse inside the declarations, + thus taking the two pass approach inside the boundary. */ + if (Nkind (gnat_decl) == N_Package_Declaration + && (Nkind (Specification (gnat_decl) + == N_Package_Specification))) + process_decls (Visible_Declarations (Specification (gnat_decl)), + Private_Declarations (Specification (gnat_decl)), + Empty, true, false); + + /* Similarly for any declarations in the actions of a + freeze node. */ + else if (Nkind (gnat_decl) == N_Freeze_Entity) + { + process_freeze_entity (gnat_decl); + process_decls (Actions (gnat_decl), Empty, Empty, true, false); + } + + /* Package bodies with freeze nodes get their elaboration deferred + until the freeze node, but the code must be placed in the right + place, so record the code position now. */ + else if (Nkind (gnat_decl) == N_Package_Body + && Present (Freeze_Node (Corresponding_Spec (gnat_decl)))) + record_code_position (gnat_decl); + + else if (Nkind (gnat_decl) == N_Package_Body_Stub + && Present (Library_Unit (gnat_decl)) + && Present (Freeze_Node + (Corresponding_Spec + (Proper_Body (Unit + (Library_Unit (gnat_decl))))))) + record_code_position + (Proper_Body (Unit (Library_Unit (gnat_decl)))); + + /* We defer most subprogram bodies to the second pass. */ + else if (Nkind (gnat_decl) == N_Subprogram_Body) + { + if (Acts_As_Spec (gnat_decl)) + { + Node_Id gnat_subprog_id = Defining_Entity (gnat_decl); + + if (Ekind (gnat_subprog_id) != E_Generic_Procedure + && Ekind (gnat_subprog_id) != E_Generic_Function) + gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1); + } + } + /* For bodies and stubs that act as their own specs, the entity + itself must be elaborated in the first pass, because it may + be used in other declarations. */ + else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub) + { + Node_Id gnat_subprog_id = + Defining_Entity (Specification (gnat_decl)); + + if (Ekind (gnat_subprog_id) != E_Subprogram_Body + && Ekind (gnat_subprog_id) != E_Generic_Procedure + && Ekind (gnat_subprog_id) != E_Generic_Function) + gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1); + } + + /* Concurrent stubs stand for the corresponding subprogram bodies, + which are deferred like other bodies. */ + else if (Nkind (gnat_decl) == N_Task_Body_Stub + || Nkind (gnat_decl) == N_Protected_Body_Stub) + ; + else + add_stmt (gnat_to_gnu (gnat_decl)); + } + + /* Here we elaborate everything we deferred above except for package bodies, + which are elaborated at their freeze nodes. Note that we must also + go inside things (package specs and freeze nodes) the first pass did. */ + if (pass2p) + for (i = 0; i <= 1; i++) + if (Present (gnat_decl_array[i])) + for (gnat_decl = First (gnat_decl_array[i]); + gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl)) + { + if (Nkind (gnat_decl) == N_Subprogram_Body + || Nkind (gnat_decl) == N_Subprogram_Body_Stub + || Nkind (gnat_decl) == N_Task_Body_Stub + || Nkind (gnat_decl) == N_Protected_Body_Stub) + add_stmt (gnat_to_gnu (gnat_decl)); + + else if (Nkind (gnat_decl) == N_Package_Declaration + && (Nkind (Specification (gnat_decl) + == N_Package_Specification))) + process_decls (Visible_Declarations (Specification (gnat_decl)), + Private_Declarations (Specification (gnat_decl)), + Empty, false, true); + + else if (Nkind (gnat_decl) == N_Freeze_Entity) + process_decls (Actions (gnat_decl), Empty, Empty, false, true); + } + } + + /* Make a unary operation of kind CODE using build_unary_op, but guard + the operation by an overflow check. CODE can be one of NEGATE_EXPR + or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually + the operation is to be performed in that type. */ + + static tree + build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand) + { + gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR); + + operand = protect_multiple_eval (operand); + + return emit_check (build_binary_op (EQ_EXPR, integer_type_node, + operand, TYPE_MIN_VALUE (gnu_type)), + build_unary_op (code, gnu_type, operand), + CE_Overflow_Check_Failed); + } + + /* Make a binary operation of kind CODE using build_binary_op, but guard + the operation by an overflow check. CODE can be one of PLUS_EXPR, + MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result. + Usually the operation is to be performed in that type. */ + + static tree + build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left, + tree right) + { + tree lhs = protect_multiple_eval (left); + tree rhs = protect_multiple_eval (right); + tree type_max = TYPE_MAX_VALUE (gnu_type); + tree type_min = TYPE_MIN_VALUE (gnu_type); + tree gnu_expr; + tree tmp1, tmp2; + tree zero = convert (gnu_type, integer_zero_node); + tree rhs_lt_zero; + tree check_pos; + tree check_neg; + tree check; + int precision = TYPE_PRECISION (gnu_type); + + gcc_assert (!(precision & (precision - 1))); /* ensure power of 2 */ + + /* Prefer a constant or known-positive rhs to simplify checks. */ + if (!TREE_CONSTANT (rhs) + && commutative_tree_code (code) + && (TREE_CONSTANT (lhs) || (!tree_expr_nonnegative_p (rhs) + && tree_expr_nonnegative_p (lhs)))) + { + tree tmp = lhs; + lhs = rhs; + rhs = tmp; + } + + rhs_lt_zero = tree_expr_nonnegative_p (rhs) + ? integer_zero_node + : build_binary_op (LT_EXPR, integer_type_node, rhs, zero); + + /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */ + + /* Try a few strategies that may be cheaper than the general + code at the end of the function, if the rhs is not known. + The strategies are: + - Call library function for 64-bit multiplication (complex) + - Widen, if input arguments are sufficiently small + - Determine overflow using wrapped result for addition/subtraction. */ + + if (!TREE_CONSTANT (rhs)) + { + /* Even for add/subtract double size to get another base type. */ + int needed_precision = precision * 2; + + if (code == MULT_EXPR && precision == 64) + { + tree int_64 = gnat_type_for_size (64, 0); + + return convert (gnu_type, build_call_2_expr (mulv64_decl, + convert (int_64, lhs), + convert (int_64, rhs))); + } + + else if (needed_precision <= BITS_PER_WORD + || (code == MULT_EXPR + && needed_precision <= LONG_LONG_TYPE_SIZE)) + { + tree wide_type = gnat_type_for_size (needed_precision, 0); + + tree wide_result = build_binary_op (code, wide_type, + convert (wide_type, lhs), + convert (wide_type, rhs)); + + tree check = build_binary_op + (TRUTH_ORIF_EXPR, integer_type_node, + build_binary_op (LT_EXPR, integer_type_node, wide_result, + convert (wide_type, type_min)), + build_binary_op (GT_EXPR, integer_type_node, wide_result, + convert (wide_type, type_max))); + + tree result = convert (gnu_type, wide_result); + + return emit_check (check, result, CE_Overflow_Check_Failed); + } + + else if (code == PLUS_EXPR || code == MINUS_EXPR) + { + tree unsigned_type = gnat_type_for_size (precision, 1); + tree wrapped_expr = convert + (gnu_type, build_binary_op (code, unsigned_type, + convert (unsigned_type, lhs), + convert (unsigned_type, rhs))); + + tree result = convert + (gnu_type, build_binary_op (code, gnu_type, lhs, rhs)); + + /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition + or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction. */ + tree check = build_binary_op + (TRUTH_XOR_EXPR, integer_type_node, rhs_lt_zero, + build_binary_op (code == PLUS_EXPR ? LT_EXPR : GT_EXPR, + integer_type_node, wrapped_expr, lhs)); + + return emit_check (check, result, CE_Overflow_Check_Failed); + } + } + + switch (code) + { + case PLUS_EXPR: + /* When rhs >= 0, overflow when lhs > type_max - rhs. */ + check_pos = build_binary_op (GT_EXPR, integer_type_node, lhs, + build_binary_op (MINUS_EXPR, gnu_type, + type_max, rhs)), + + /* When rhs < 0, overflow when lhs < type_min - rhs. */ + check_neg = build_binary_op (LT_EXPR, integer_type_node, lhs, + build_binary_op (MINUS_EXPR, gnu_type, + type_min, rhs)); + break; + + case MINUS_EXPR: + /* When rhs >= 0, overflow when lhs < type_min + rhs. */ + check_pos = build_binary_op (LT_EXPR, integer_type_node, lhs, + build_binary_op (PLUS_EXPR, gnu_type, + type_min, rhs)), + + /* When rhs < 0, overflow when lhs > type_max + rhs. */ + check_neg = build_binary_op (GT_EXPR, integer_type_node, lhs, + build_binary_op (PLUS_EXPR, gnu_type, + type_max, rhs)); + break; + + case MULT_EXPR: + /* The check here is designed to be efficient if the rhs is constant, + but it will work for any rhs by using integer division. + Four different check expressions determine wether X * C overflows, + depending on C. + C == 0 => false + C > 0 => X > type_max / C || X < type_min / C + C == -1 => X == type_min + C < -1 => X > type_min / C || X < type_max / C */ + + tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs); + tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs); + + check_pos = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, + build_binary_op (NE_EXPR, integer_type_node, zero, rhs), + build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, + build_binary_op (GT_EXPR, integer_type_node, lhs, tmp1), + build_binary_op (LT_EXPR, integer_type_node, lhs, tmp2))); + + check_neg = fold_build3 (COND_EXPR, integer_type_node, + build_binary_op (EQ_EXPR, integer_type_node, rhs, + build_int_cst (gnu_type, -1)), + build_binary_op (EQ_EXPR, integer_type_node, lhs, type_min), + build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, + build_binary_op (GT_EXPR, integer_type_node, lhs, tmp2), + build_binary_op (LT_EXPR, integer_type_node, lhs, tmp1))); + break; + + default: + gcc_unreachable(); + } + + gnu_expr = build_binary_op (code, gnu_type, lhs, rhs); + + /* If we can fold the expression to a constant, just return it. + The caller will deal with overflow, no need to generate a check. */ + if (TREE_CONSTANT (gnu_expr)) + return gnu_expr; + + check = fold_build3 (COND_EXPR, integer_type_node, + rhs_lt_zero, check_neg, check_pos); + + return emit_check (check, gnu_expr, CE_Overflow_Check_Failed); + } + + /* Emit code for a range check. GNU_EXPR is the expression to be checked, + GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against + which we have to check. */ + + static tree + emit_range_check (tree gnu_expr, Entity_Id gnat_range_type) + { + tree gnu_range_type = get_unpadded_type (gnat_range_type); + tree gnu_low = TYPE_MIN_VALUE (gnu_range_type); + tree gnu_high = TYPE_MAX_VALUE (gnu_range_type); + tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr)); + + /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed. + This can for example happen when translating 'Val or 'Value. */ + if (gnu_compare_type == gnu_range_type) + return gnu_expr; + + /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE, + we can't do anything since we might be truncating the bounds. No + check is needed in this case. */ + if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr)) + && (TYPE_PRECISION (gnu_compare_type) + < TYPE_PRECISION (get_base_type (gnu_range_type)))) + return gnu_expr; + + /* Checked expressions must be evaluated only once. */ + gnu_expr = protect_multiple_eval (gnu_expr); + + /* There's no good type to use here, so we might as well use + integer_type_node. Note that the form of the check is + (not (expr >= lo)) or (not (expr <= hi)) + the reason for this slightly convoluted form is that NaNs + are not considered to be in range in the float case. */ + return emit_check + (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, + invert_truthvalue + (build_binary_op (GE_EXPR, integer_type_node, + convert (gnu_compare_type, gnu_expr), + convert (gnu_compare_type, gnu_low))), + invert_truthvalue + (build_binary_op (LE_EXPR, integer_type_node, + convert (gnu_compare_type, gnu_expr), + convert (gnu_compare_type, + gnu_high)))), + gnu_expr, CE_Range_Check_Failed); + } + + /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object + which we are about to index, GNU_EXPR is the index expression to be + checked, GNU_LOW and GNU_HIGH are the lower and upper bounds + against which GNU_EXPR has to be checked. Note that for index + checking we cannot use the emit_range_check function (although very + similar code needs to be generated in both cases) since for index + checking the array type against which we are checking the indices + may be unconstrained and consequently we need to retrieve the + actual index bounds from the array object itself + (GNU_ARRAY_OBJECT). The place where we need to do that is in + subprograms having unconstrained array formal parameters */ + + static tree + emit_index_check (tree gnu_array_object, + tree gnu_expr, + tree gnu_low, + tree gnu_high) + { + tree gnu_expr_check; + + /* Checked expressions must be evaluated only once. */ + gnu_expr = protect_multiple_eval (gnu_expr); + + /* Must do this computation in the base type in case the expression's + type is an unsigned subtypes. */ + gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); + + /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by + the object we are handling. */ + gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object); + gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object); + + /* There's no good type to use here, so we might as well use + integer_type_node. */ + return emit_check + (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, + build_binary_op (LT_EXPR, integer_type_node, + gnu_expr_check, + convert (TREE_TYPE (gnu_expr_check), + gnu_low)), + build_binary_op (GT_EXPR, integer_type_node, + gnu_expr_check, + convert (TREE_TYPE (gnu_expr_check), + gnu_high))), + gnu_expr, CE_Index_Check_Failed); + } + + /* GNU_COND contains the condition corresponding to an access, discriminant or + range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if + GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true. + REASON is the code that says why the exception was raised. */ + + static tree + emit_check (tree gnu_cond, tree gnu_expr, int reason) + { + tree gnu_call = build_call_raise (reason, Empty, N_Raise_Constraint_Error); + tree gnu_result + = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond, + build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call, + convert (TREE_TYPE (gnu_expr), integer_zero_node)), + gnu_expr); + + /* GNU_RESULT has side effects if and only if GNU_EXPR has: + we don't need to evaluate it just for the check. */ + TREE_SIDE_EFFECTS (gnu_result) = TREE_SIDE_EFFECTS (gnu_expr); + + /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing, + we will repeatedly do the test and, at compile time, we will repeatedly + visit it during unsharing, which leads to an exponential explosion. */ + return save_expr (gnu_result); + } + + /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing + overflow checks if OVERFLOW_P is nonzero and range checks if + RANGE_P is nonzero. GNAT_TYPE is known to be an integral type. + If TRUNCATE_P is nonzero, do a float to integer conversion with + truncation; otherwise round. */ + + static tree + convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, + bool rangep, bool truncatep) + { + tree gnu_type = get_unpadded_type (gnat_type); + tree gnu_in_type = TREE_TYPE (gnu_expr); + tree gnu_in_basetype = get_base_type (gnu_in_type); + tree gnu_base_type = get_base_type (gnu_type); + tree gnu_result = gnu_expr; + + /* If we are not doing any checks, the output is an integral type, and + the input is not a floating type, just do the conversion. This + shortcut is required to avoid problems with packed array types + and simplifies code in all cases anyway. */ + if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type) + && !FLOAT_TYPE_P (gnu_in_type)) + return convert (gnu_type, gnu_expr); + + /* First convert the expression to its base type. This + will never generate code, but makes the tests below much simpler. + But don't do this if converting from an integer type to an unconstrained + array type since then we need to get the bounds from the original + (unpacked) type. */ + if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE) + gnu_result = convert (gnu_in_basetype, gnu_result); + + /* If overflow checks are requested, we need to be sure the result will + fit in the output base type. But don't do this if the input + is integer and the output floating-point. */ + if (overflowp + && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype))) + { + /* Ensure GNU_EXPR only gets evaluated once. */ + tree gnu_input = protect_multiple_eval (gnu_result); + tree gnu_cond = integer_zero_node; + tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype); + tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype); + tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type); + tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type); + + /* Convert the lower bounds to signed types, so we're sure we're + comparing them properly. Likewise, convert the upper bounds + to unsigned types. */ + if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype)) + gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb); + + if (INTEGRAL_TYPE_P (gnu_in_basetype) + && !TYPE_UNSIGNED (gnu_in_basetype)) + gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub); + + if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type)) + gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb); + + if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type)) + gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub); + + /* Check each bound separately and only if the result bound + is tighter than the bound on the input type. Note that all the + types are base types, so the bounds must be constant. Also, + the comparison is done in the base type of the input, which + always has the proper signedness. First check for input + integer (which means output integer), output float (which means + both float), or mixed, in which case we always compare. + Note that we have to do the comparison which would *fail* in the + case of an error since if it's an FP comparison and one of the + values is a NaN or Inf, the comparison will fail. */ + if (INTEGRAL_TYPE_P (gnu_in_basetype) + ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb) + : (FLOAT_TYPE_P (gnu_base_type) + ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb), + TREE_REAL_CST (gnu_out_lb)) + : 1)) + gnu_cond + = invert_truthvalue + (build_binary_op (GE_EXPR, integer_type_node, + gnu_input, convert (gnu_in_basetype, + gnu_out_lb))); + + if (INTEGRAL_TYPE_P (gnu_in_basetype) + ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub) + : (FLOAT_TYPE_P (gnu_base_type) + ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub), + TREE_REAL_CST (gnu_in_lb)) + : 1)) + gnu_cond + = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond, + invert_truthvalue + (build_binary_op (LE_EXPR, integer_type_node, + gnu_input, + convert (gnu_in_basetype, + gnu_out_ub)))); + + if (!integer_zerop (gnu_cond)) + gnu_result = emit_check (gnu_cond, gnu_input, + CE_Overflow_Check_Failed); + } + + /* Now convert to the result base type. If this is a non-truncating + float-to-integer conversion, round. */ + if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype) + && !truncatep) + { + REAL_VALUE_TYPE half_minus_pred_half, pred_half; + tree gnu_conv, gnu_zero, gnu_comp, gnu_saved_result, calc_type; + tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half; + const struct real_format *fmt; + + /* The following calculations depend on proper rounding to even + of each arithmetic operation. In order to prevent excess + precision from spoiling this property, use the widest hardware + floating-point type if FP_ARITH_MAY_WIDEN is true. */ + + calc_type = (FP_ARITH_MAY_WIDEN ? longest_float_type_node + : gnu_in_basetype); + + /* FIXME: Should not have padding in the first place */ + if (TREE_CODE (calc_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (calc_type)) + calc_type = TREE_TYPE (TYPE_FIELDS (calc_type)); + + /* Compute the exact value calc_type'Pred (0.5) at compile time. */ + fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type)); + real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type)); + REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf, + half_minus_pred_half); + gnu_pred_half = build_real (calc_type, pred_half); + + /* If the input is strictly negative, subtract this value + and otherwise add it from the input. For 0.5, the result + is exactly between 1.0 and the machine number preceding 1.0 + (for calc_type). Since the last bit of 1.0 is even, this 0.5 + will round to 1.0, while all other number with an absolute + value less than 0.5 round to 0.0. For larger numbers exactly + halfway between integers, rounding will always be correct as + the true mathematical result will be closer to the higher + integer compared to the lower one. So, this constant works + for all floating-point numbers. + + The reason to use the same constant with subtract/add instead + of a positive and negative constant is to allow the comparison + to be scheduled in parallel with retrieval of the constant and + conversion of the input to the calc_type (if necessary). + */ + + gnu_zero = convert (gnu_in_basetype, integer_zero_node); + gnu_saved_result = save_expr (gnu_result); + gnu_conv = convert (calc_type, gnu_saved_result); + gnu_comp = build2 (GE_EXPR, integer_type_node, + gnu_saved_result, gnu_zero); + gnu_add_pred_half + = build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half); + gnu_subtract_pred_half + = build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half); + gnu_result = build3 (COND_EXPR, calc_type, gnu_comp, + gnu_add_pred_half, gnu_subtract_pred_half); + } + + if (TREE_CODE (gnu_base_type) == INTEGER_TYPE + && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type) + && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF) + gnu_result = unchecked_convert (gnu_base_type, gnu_result, false); + else + gnu_result = convert (gnu_base_type, gnu_result); + + /* Finally, do the range check if requested. Note that if the + result type is a modular type, the range check is actually + an overflow check. */ + + if (rangep + || (TREE_CODE (gnu_base_type) == INTEGER_TYPE + && TYPE_MODULAR_P (gnu_base_type) && overflowp)) + gnu_result = emit_range_check (gnu_result, gnat_type); + + return convert (gnu_type, gnu_result); + } + + /* Return true if TYPE is a smaller packable version of RECORD_TYPE. */ + + static bool + smaller_packable_type_p (tree type, tree record_type) + { + tree size, rsize; + + /* We're not interested in variants here. */ + if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (record_type)) + return false; + + /* Like a variant, a packable version keeps the original TYPE_NAME. */ + if (TYPE_NAME (type) != TYPE_NAME (record_type)) + return false; + + size = TYPE_SIZE (type); + rsize = TYPE_SIZE (record_type); + + if (!(TREE_CODE (size) == INTEGER_CST && TREE_CODE (rsize) == INTEGER_CST)) + return false; + + return tree_int_cst_lt (size, rsize) != 0; + } + + /* Return true if GNU_EXPR can be directly addressed. This is the case + unless it is an expression involving computation or if it involves a + reference to a bitfield or to an object not sufficiently aligned for + its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can + be directly addressed as an object of this type. + + *** Notes on addressability issues in the Ada compiler *** + + This predicate is necessary in order to bridge the gap between Gigi + and the middle-end about addressability of GENERIC trees. A tree + is said to be addressable if it can be directly addressed, i.e. if + its address can be taken, is a multiple of the type's alignment on + strict-alignment architectures and returns the first storage unit + assigned to the object represented by the tree. + + In the C family of languages, everything is in practice addressable + at the language level, except for bit-fields. This means that these + compilers will take the address of any tree that doesn't represent + a bit-field reference and expect the result to be the first storage + unit assigned to the object. Even in cases where this will result + in unaligned accesses at run time, nothing is supposed to be done + and the program is considered as erroneous instead (see PR c/18287). + + The implicit assumptions made in the middle-end are in keeping with + the C viewpoint described above: + - the address of a bit-field reference is supposed to be never + taken; the compiler (generally) will stop on such a construct, + - any other tree is addressable if it is formally addressable, + i.e. if it is formally allowed to be the operand of ADDR_EXPR. + + In Ada, the viewpoint is the opposite one: nothing is addressable + at the language level unless explicitly declared so. This means + that the compiler will both make sure that the trees representing + references to addressable ("aliased" in Ada parlance) objects are + addressable and make no real attempts at ensuring that the trees + representing references to non-addressable objects are addressable. + + In the first case, Ada is effectively equivalent to C and handing + down the direct result of applying ADDR_EXPR to these trees to the + middle-end works flawlessly. In the second case, Ada cannot afford + to consider the program as erroneous if the address of trees that + are not addressable is requested for technical reasons, unlike C; + as a consequence, the Ada compiler must arrange for either making + sure that this address is not requested in the middle-end or for + compensating by inserting temporaries if it is requested in Gigi. + + The first goal can be achieved because the middle-end should not + request the address of non-addressable trees on its own; the only + exception is for the invocation of low-level block operations like + memcpy, for which the addressability requirements are lower since + the type's alignment can be disregarded. In practice, this means + that Gigi must make sure that such operations cannot be applied to + non-BLKmode bit-fields. + + The second goal is achieved by means of the addressable_p predicate + and by inserting SAVE_EXPRs around trees deemed non-addressable. + They will be turned during gimplification into proper temporaries + whose address will be used in lieu of that of the original tree. */ + + static bool + addressable_p (tree gnu_expr, tree gnu_type) + { + /* The size of the real type of the object must not be smaller than + that of the expected type, otherwise an indirect access in the + latter type would be larger than the object. Only records need + to be considered in practice. */ + if (gnu_type + && TREE_CODE (gnu_type) == RECORD_TYPE + && smaller_packable_type_p (TREE_TYPE (gnu_expr), gnu_type)) + return false; + + switch (TREE_CODE (gnu_expr)) + { + case VAR_DECL: + case PARM_DECL: + case FUNCTION_DECL: + case RESULT_DECL: + /* All DECLs are addressable: if they are in a register, we can force + them to memory. */ + return true; + + case UNCONSTRAINED_ARRAY_REF: + case INDIRECT_REF: + case CONSTRUCTOR: + case STRING_CST: + case INTEGER_CST: + case NULL_EXPR: + case SAVE_EXPR: + case CALL_EXPR: + return true; + + case COND_EXPR: + /* We accept &COND_EXPR as soon as both operands are addressable and + expect the outcome to be the address of the selected operand. */ + return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE) + && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE)); + + case COMPONENT_REF: + return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1)) + /* Even with DECL_BIT_FIELD cleared, we have to ensure that + the field is sufficiently aligned, in case it is subject + to a pragma Component_Alignment. But we don't need to + check the alignment of the containing record, as it is + guaranteed to be not smaller than that of its most + aligned field that is not a bit-field. */ + && (!STRICT_ALIGNMENT + || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1)) + >= TYPE_ALIGN (TREE_TYPE (gnu_expr)))) + /* The field of a padding record is always addressable. */ + || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) + && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); + + case ARRAY_REF: case ARRAY_RANGE_REF: + case REALPART_EXPR: case IMAGPART_EXPR: + case NOP_EXPR: + return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE); + + case CONVERT_EXPR: + return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr)) + && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); + + case VIEW_CONVERT_EXPR: + { + /* This is addressable if we can avoid a copy. */ + tree type = TREE_TYPE (gnu_expr); + tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0)); + return (((TYPE_MODE (type) == TYPE_MODE (inner_type) + && (!STRICT_ALIGNMENT + || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type) + || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT)) + || ((TYPE_MODE (type) == BLKmode + || TYPE_MODE (inner_type) == BLKmode) + && (!STRICT_ALIGNMENT + || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type) + || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT + || TYPE_ALIGN_OK (type) + || TYPE_ALIGN_OK (inner_type)))) + && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); + } + + default: + return false; + } + } + + /* Do the processing for the declaration of a GNAT_ENTITY, a type. If + a separate Freeze node exists, delay the bulk of the processing. Otherwise + make a GCC type for GNAT_ENTITY and set up the correspondence. */ + + void + process_type (Entity_Id gnat_entity) + { + tree gnu_old + = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0; + tree gnu_new; + + /* If we are to delay elaboration of this type, just do any + elaborations needed for expressions within the declaration and + make a dummy type entry for this node and its Full_View (if + any) in case something points to it. Don't do this if it + has already been done (the only way that can happen is if + the private completion is also delayed). */ + if (Present (Freeze_Node (gnat_entity)) + || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity)) + && Freeze_Node (Full_View (gnat_entity)) + && !present_gnu_tree (Full_View (gnat_entity)))) + { + elaborate_entity (gnat_entity); + + if (!gnu_old) + { + tree gnu_decl = create_type_decl (get_entity_name (gnat_entity), + make_dummy_type (gnat_entity), + NULL, false, false, gnat_entity); + + save_gnu_tree (gnat_entity, gnu_decl, false); + if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity))) + save_gnu_tree (Full_View (gnat_entity), gnu_decl, false); + } + + return; + } + + /* If we saved away a dummy type for this node it means that this + made the type that corresponds to the full type of an incomplete + type. Clear that type for now and then update the type in the + pointers. */ + if (gnu_old) + { + gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL + && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))); + + save_gnu_tree (gnat_entity, NULL_TREE, false); + } + + /* Now fully elaborate the type. */ + gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1); + gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL); + + /* If we have an old type and we've made pointers to this type, + update those pointers. */ + if (gnu_old) + update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)), + TREE_TYPE (gnu_new)); + + /* If this is a record type corresponding to a task or protected type + that is a completion of an incomplete type, perform a similar update + on the type. */ + /* ??? Including protected types here is a guess. */ + + if (IN (Ekind (gnat_entity), Record_Kind) + && Is_Concurrent_Record_Type (gnat_entity) + && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity))) + { + tree gnu_task_old + = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)); + + save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity), + NULL_TREE, false); + save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity), + gnu_new, false); + + update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)), + TREE_TYPE (gnu_new)); + } + } + + /* GNAT_ENTITY is the type of the resulting constructors, + GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate, + and GNU_TYPE is the GCC type of the corresponding record. + + Return a CONSTRUCTOR to build the record. */ + + static tree + assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type) + { + tree gnu_list, gnu_result; + + /* We test for GNU_FIELD being empty in the case where a variant + was the last thing since we don't take things off GNAT_ASSOC in + that case. We check GNAT_ASSOC in case we have a variant, but it + has no fields. */ + + for (gnu_list = NULL_TREE; Present (gnat_assoc); + gnat_assoc = Next (gnat_assoc)) + { + Node_Id gnat_field = First (Choices (gnat_assoc)); + tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field)); + tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc)); + + /* The expander is supposed to put a single component selector name + in every record component association */ + gcc_assert (No (Next (gnat_field))); + + /* Ignore fields that have Corresponding_Discriminants since we'll + be setting that field in the parent. */ + if (Present (Corresponding_Discriminant (Entity (gnat_field))) + && Is_Tagged_Type (Scope (Entity (gnat_field)))) + continue; + + /* Also ignore discriminants of Unchecked_Unions. */ + else if (Is_Unchecked_Union (gnat_entity) + && Ekind (Entity (gnat_field)) == E_Discriminant) + continue; + + /* Before assigning a value in an aggregate make sure range checks + are done if required. Then convert to the type of the field. */ + if (Do_Range_Check (Expression (gnat_assoc))) + gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field)); + + gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr); + + /* Add the field and expression to the list. */ + gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list); + } + + gnu_result = extract_values (gnu_list, gnu_type); + + #ifdef ENABLE_CHECKING + { + tree gnu_field; + + /* Verify every entry in GNU_LIST was used. */ + for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field)) + gcc_assert (TREE_ADDRESSABLE (gnu_field)); + } + #endif + + return gnu_result; + } + + /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR + is the first element of an array aggregate. It may itself be an + aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type + corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type + of the array component. It is needed for range checking. */ + + static tree + pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type, + Entity_Id gnat_component_type) + { + tree gnu_expr_list = NULL_TREE; + tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type)); + tree gnu_expr; + + for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr)) + { + /* If the expression is itself an array aggregate then first build the + innermost constructor if it is part of our array (multi-dimensional + case). */ + + if (Nkind (gnat_expr) == N_Aggregate + && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type))) + gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)), + TREE_TYPE (gnu_array_type), + gnat_component_type); + else + { + gnu_expr = gnat_to_gnu (gnat_expr); + + /* before assigning the element to the array make sure it is + in range */ + if (Do_Range_Check (gnat_expr)) + gnu_expr = emit_range_check (gnu_expr, gnat_component_type); + } + + gnu_expr_list + = tree_cons (gnu_index, convert (TREE_TYPE (gnu_array_type), gnu_expr), + gnu_expr_list); + + gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0); + } + + return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list)); + } + + /* Subroutine of assoc_to_constructor: VALUES is a list of field associations, + some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting + of the associations that are from RECORD_TYPE. If we see an internal + record, make a recursive call to fill it in as well. */ + + static tree + extract_values (tree values, tree record_type) + { + tree result = NULL_TREE; + tree field, tem; + + for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field)) + { + tree value = 0; + + /* _Parent is an internal field, but may have values in the aggregate, + so check for values first. */ + if ((tem = purpose_member (field, values))) + { + value = TREE_VALUE (tem); + TREE_ADDRESSABLE (tem) = 1; + } + + else if (DECL_INTERNAL_P (field)) + { + value = extract_values (values, TREE_TYPE (field)); + if (TREE_CODE (value) == CONSTRUCTOR + && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value))) + value = 0; + } + else + /* If we have a record subtype, the names will match, but not the + actual FIELD_DECLs. */ + for (tem = values; tem; tem = TREE_CHAIN (tem)) + if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field)) + { + value = convert (TREE_TYPE (field), TREE_VALUE (tem)); + TREE_ADDRESSABLE (tem) = 1; + } + + if (!value) + continue; + + result = tree_cons (field, value, result); + } + + return gnat_build_constructor (record_type, nreverse (result)); + } + + /* EXP is to be treated as an array or record. Handle the cases when it is + an access object and perform the required dereferences. */ + + static tree + maybe_implicit_deref (tree exp) + { + /* If the type is a pointer, dereference it. */ + + if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp))) + exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp); + + /* If we got a padded type, remove it too. */ + if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (exp))) + exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp); + + return exp; + } + + /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */ + + tree + protect_multiple_eval (tree exp) + { + tree type = TREE_TYPE (exp); + + /* If this has no side effects, we don't need to do anything. */ + if (!TREE_SIDE_EFFECTS (exp)) + return exp; + + /* If it is a conversion, protect what's inside the conversion. + Similarly, if we're indirectly referencing something, we only + actually need to protect the address since the data itself can't + change in these situations. */ + else if (TREE_CODE (exp) == NON_LVALUE_EXPR + || CONVERT_EXPR_P (exp) + || TREE_CODE (exp) == VIEW_CONVERT_EXPR + || TREE_CODE (exp) == INDIRECT_REF + || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF) + return build1 (TREE_CODE (exp), type, + protect_multiple_eval (TREE_OPERAND (exp, 0))); + + /* If EXP is a fat pointer or something that can be placed into a register, + just make a SAVE_EXPR. */ + if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode) + return save_expr (exp); + + /* Otherwise, dereference, protect the address, and re-reference. */ + else + return + build_unary_op (INDIRECT_REF, type, + save_expr (build_unary_op (ADDR_EXPR, + build_reference_type (type), + exp))); + } + + /* This is equivalent to stabilize_reference in tree.c, but we know how to + handle our own nodes and we take extra arguments. FORCE says whether to + force evaluation of everything. We set SUCCESS to true unless we walk + through something we don't know how to stabilize. */ + + tree + maybe_stabilize_reference (tree ref, bool force, bool *success) + { + tree type = TREE_TYPE (ref); + enum tree_code code = TREE_CODE (ref); + tree result; + + /* Assume we'll success unless proven otherwise. */ + *success = true; + + switch (code) + { + case CONST_DECL: + case VAR_DECL: + case PARM_DECL: + case RESULT_DECL: + /* No action is needed in this case. */ + return ref; + + case ADDR_EXPR: + CASE_CONVERT: + case FLOAT_EXPR: + case FIX_TRUNC_EXPR: + case VIEW_CONVERT_EXPR: + result + = build1 (code, type, + maybe_stabilize_reference (TREE_OPERAND (ref, 0), force, + success)); + break; + + case INDIRECT_REF: + case UNCONSTRAINED_ARRAY_REF: + result = build1 (code, type, + gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0), + force)); + break; + + case COMPONENT_REF: + result = build3 (COMPONENT_REF, type, + maybe_stabilize_reference (TREE_OPERAND (ref, 0), force, + success), + TREE_OPERAND (ref, 1), NULL_TREE); + break; + + case BIT_FIELD_REF: + result = build3 (BIT_FIELD_REF, type, + maybe_stabilize_reference (TREE_OPERAND (ref, 0), force, + success), + gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), + force), + gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2), + force)); + break; + + case ARRAY_REF: + case ARRAY_RANGE_REF: + result = build4 (code, type, + maybe_stabilize_reference (TREE_OPERAND (ref, 0), force, + success), + gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), + force), + NULL_TREE, NULL_TREE); + break; + + case COMPOUND_EXPR: + result = gnat_stabilize_reference_1 (ref, force); + break; + + case CALL_EXPR: + /* This generates better code than the scheme in protect_multiple_eval + because large objects will be returned via invisible reference in + most ABIs so the temporary will directly be filled by the callee. */ + result = gnat_stabilize_reference_1 (ref, force); + break; + + case CONSTRUCTOR: + /* Constructors with 1 element are used extensively to formally + convert objects to special wrapping types. */ + if (TREE_CODE (type) == RECORD_TYPE + && VEC_length (constructor_elt, CONSTRUCTOR_ELTS (ref)) == 1) + { + tree index + = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->index; + tree value + = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->value; + result + = build_constructor_single (type, index, + gnat_stabilize_reference_1 (value, + force)); + } + else + { + *success = false; + return ref; + } + break; + + case ERROR_MARK: + ref = error_mark_node; + + /* ... Fallthru to failure ... */ + + /* If arg isn't a kind of lvalue we recognize, make no change. + Caller should recognize the error for an invalid lvalue. */ + default: + *success = false; + return ref; + } + + TREE_READONLY (result) = TREE_READONLY (ref); + + /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS attached to the initial + expression may not be sustained across some paths, such as the way via + build1 for INDIRECT_REF. We re-populate those flags here for the general + case, which is consistent with the GCC version of this routine. + + Special care should be taken regarding TREE_SIDE_EFFECTS, because some + paths introduce side effects where there was none initially (e.g. calls + to save_expr), and we also want to keep track of that. */ + + TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref); + TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref); + + return result; + } + + /* Wrapper around maybe_stabilize_reference, for common uses without + lvalue restrictions and without need to examine the success + indication. */ + + static tree + gnat_stabilize_reference (tree ref, bool force) + { + bool dummy; + return maybe_stabilize_reference (ref, force, &dummy); + } + + /* Similar to stabilize_reference_1 in tree.c, but supports an extra + arg to force a SAVE_EXPR for everything. */ + + static tree + gnat_stabilize_reference_1 (tree e, bool force) + { + enum tree_code code = TREE_CODE (e); + tree type = TREE_TYPE (e); + tree result; + + /* We cannot ignore const expressions because it might be a reference + to a const array but whose index contains side-effects. But we can + ignore things that are actual constant or that already have been + handled by this function. */ + + if (TREE_CONSTANT (e) || code == SAVE_EXPR) + return e; + + switch (TREE_CODE_CLASS (code)) + { + case tcc_exceptional: + case tcc_type: + case tcc_declaration: + case tcc_comparison: + case tcc_statement: + case tcc_expression: + case tcc_reference: + case tcc_vl_exp: + /* If this is a COMPONENT_REF of a fat pointer, save the entire + fat pointer. This may be more efficient, but will also allow + us to more easily find the match for the PLACEHOLDER_EXPR. */ + if (code == COMPONENT_REF + && TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0)))) + result = build3 (COMPONENT_REF, type, + gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), + force), + TREE_OPERAND (e, 1), TREE_OPERAND (e, 2)); + else if (TREE_SIDE_EFFECTS (e) || force) + return save_expr (e); + else + return e; + break; + + case tcc_constant: + /* Constants need no processing. In fact, we should never reach + here. */ + return e; + + case tcc_binary: + /* Recursively stabilize each operand. */ + result = build2 (code, type, + gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force), + gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), + force)); + break; + + case tcc_unary: + /* Recursively stabilize each operand. */ + result = build1 (code, type, + gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), + force)); + break; + + default: + gcc_unreachable (); + } + + TREE_READONLY (result) = TREE_READONLY (e); + + TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e); + TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e); + return result; + } + + /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code + location and false if it doesn't. In the former case, set the Gigi global + variable REF_FILENAME to the simple debug file name as given by sinput. */ + + bool + Sloc_to_locus (Source_Ptr Sloc, location_t *locus) + { + if (Sloc == No_Location) + return false; + + if (Sloc <= Standard_Location) + { + if (*locus == UNKNOWN_LOCATION) + *locus = BUILTINS_LOCATION; + return false; + } + else + { + Source_File_Index file = Get_Source_File_Index (Sloc); + Logical_Line_Number line = Get_Logical_Line_Number (Sloc); + Column_Number column = Get_Column_Number (Sloc); + struct line_map *map = &line_table->maps[file - 1]; + + /* Translate the location according to the line-map.h formula. */ + *locus = map->start_location + + ((line - map->to_line) << map->column_bits) + + (column & ((1 << map->column_bits) - 1)); + } + + ref_filename + = IDENTIFIER_POINTER + (get_identifier + (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));; + + return true; + } + + /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and + don't do anything if it doesn't correspond to a source location. */ + + static void + set_expr_location_from_node (tree node, Node_Id gnat_node) + { + location_t locus; + + if (!Sloc_to_locus (Sloc (gnat_node), &locus)) + return; + + SET_EXPR_LOCATION (node, locus); + } + + /* Return a colon-separated list of encodings contained in encoded Ada + name. */ + + static const char * + extract_encoding (const char *name) + { + char *encoding = GGC_NEWVEC (char, strlen (name)); + + get_encoding (name, encoding); + + return encoding; + } + + /* Extract the Ada name from an encoded name. */ + + static const char * + decode_name (const char *name) + { + char *decoded = GGC_NEWVEC (char, strlen (name) * 2 + 60); + + __gnat_decode (name, decoded, 0); + + return decoded; + } + + /* Post an error message. MSG is the error message, properly annotated. + NODE is the node at which to post the error and the node to use for the + "&" substitution. */ + + void + post_error (const char *msg, Node_Id node) + { + String_Template temp; + Fat_Pointer fp; + + temp.Low_Bound = 1, temp.High_Bound = strlen (msg); + fp.Array = msg, fp.Bounds = &temp; + if (Present (node)) + Error_Msg_N (fp, node); + } + + /* Similar, but NODE is the node at which to post the error and ENT + is the node to use for the "&" substitution. */ + + void + post_error_ne (const char *msg, Node_Id node, Entity_Id ent) + { + String_Template temp; + Fat_Pointer fp; + + temp.Low_Bound = 1, temp.High_Bound = strlen (msg); + fp.Array = msg, fp.Bounds = &temp; + if (Present (node)) + Error_Msg_NE (fp, node, ent); + } + + /* Similar, but NODE is the node at which to post the error, ENT is the node + to use for the "&" substitution, and N is the number to use for the ^. */ + + void + post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n) + { + String_Template temp; + Fat_Pointer fp; + + temp.Low_Bound = 1, temp.High_Bound = strlen (msg); + fp.Array = msg, fp.Bounds = &temp; + Error_Msg_Uint_1 = UI_From_Int (n); + + if (Present (node)) + Error_Msg_NE (fp, node, ent); + } + + /* Similar to post_error_ne_num, but T is a GCC tree representing the + number to write. If the tree represents a constant that fits within + a host integer, the text inside curly brackets in MSG will be output + (presumably including a '^'). Otherwise that text will not be output + and the text inside square brackets will be output instead. */ + + void + post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t) + { + char *newmsg = XALLOCAVEC (char, strlen (msg) + 1); + String_Template temp = {1, 0}; + Fat_Pointer fp; + char start_yes, end_yes, start_no, end_no; + const char *p; + char *q; + + fp.Array = newmsg, fp.Bounds = &temp; + + if (host_integerp (t, 1) + #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT + && + compare_tree_int + (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0 + #endif + ) + { + Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1)); + start_yes = '{', end_yes = '}', start_no = '[', end_no = ']'; + } + else + start_yes = '[', end_yes = ']', start_no = '{', end_no = '}'; + + for (p = msg, q = newmsg; *p; p++) + { + if (*p == start_yes) + for (p++; *p != end_yes; p++) + *q++ = *p; + else if (*p == start_no) + for (p++; *p != end_no; p++) + ; + else + *q++ = *p; + } + + *q = 0; + + temp.High_Bound = strlen (newmsg); + if (Present (node)) + Error_Msg_NE (fp, node, ent); + } + + /* Similar to post_error_ne_tree, except that NUM is a second + integer to write in the message. */ + + void + post_error_ne_tree_2 (const char *msg, + Node_Id node, + Entity_Id ent, + tree t, + int num) + { + Error_Msg_Uint_2 = UI_From_Int (num); + post_error_ne_tree (msg, node, ent, t); + } + + /* Initialize the table that maps GNAT codes to GCC codes for simple + binary and unary operations. */ + + static void + init_code_table (void) + { + gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR; + gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR; + + gnu_codes[N_Op_And] = TRUTH_AND_EXPR; + gnu_codes[N_Op_Or] = TRUTH_OR_EXPR; + gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR; + gnu_codes[N_Op_Eq] = EQ_EXPR; + gnu_codes[N_Op_Ne] = NE_EXPR; + gnu_codes[N_Op_Lt] = LT_EXPR; + gnu_codes[N_Op_Le] = LE_EXPR; + gnu_codes[N_Op_Gt] = GT_EXPR; + gnu_codes[N_Op_Ge] = GE_EXPR; + gnu_codes[N_Op_Add] = PLUS_EXPR; + gnu_codes[N_Op_Subtract] = MINUS_EXPR; + gnu_codes[N_Op_Multiply] = MULT_EXPR; + gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR; + gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR; + gnu_codes[N_Op_Minus] = NEGATE_EXPR; + gnu_codes[N_Op_Abs] = ABS_EXPR; + gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR; + gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR; + gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR; + gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR; + gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR; + gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR; + } + + /* Return a label to branch to for the exception type in KIND or NULL_TREE + if none. */ + + tree + get_exception_label (char kind) + { + if (kind == N_Raise_Constraint_Error) + return TREE_VALUE (gnu_constraint_error_label_stack); + else if (kind == N_Raise_Storage_Error) + return TREE_VALUE (gnu_storage_error_label_stack); + else if (kind == N_Raise_Program_Error) + return TREE_VALUE (gnu_program_error_label_stack); + else + return NULL_TREE; + } + + #include "gt-ada-trans.h" diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/utils.c gcc-4.4.0/gcc/ada/gcc-interface/utils.c *** gcc-4.3.3/gcc/ada/gcc-interface/utils.c Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/utils.c Tue Dec 9 10:35:15 2008 *************** *** 0 **** --- 1,5509 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * U T I L S * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2008, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + /* We have attribute handlers using C specific format specifiers in warning + messages. Make sure they are properly recognized. */ + #define GCC_DIAG_STYLE __gcc_cdiag__ + + #include "config.h" + #include "system.h" + #include "coretypes.h" + #include "tm.h" + #include "tree.h" + #include "flags.h" + #include "defaults.h" + #include "toplev.h" + #include "output.h" + #include "ggc.h" + #include "debug.h" + #include "convert.h" + #include "target.h" + #include "function.h" + #include "cgraph.h" + #include "tree-inline.h" + #include "tree-iterator.h" + #include "gimple.h" + #include "tree-dump.h" + #include "pointer-set.h" + #include "langhooks.h" + + #include "ada.h" + #include "types.h" + #include "atree.h" + #include "elists.h" + #include "namet.h" + #include "nlists.h" + #include "stringt.h" + #include "uintp.h" + #include "fe.h" + #include "sinfo.h" + #include "einfo.h" + #include "ada-tree.h" + #include "gigi.h" + + #ifndef MAX_FIXED_MODE_SIZE + #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode) + #endif + + #ifndef MAX_BITS_PER_WORD + #define MAX_BITS_PER_WORD BITS_PER_WORD + #endif + + /* If nonzero, pretend we are allocating at global level. */ + int force_global; + + /* Tree nodes for the various types and decls we create. */ + tree gnat_std_decls[(int) ADT_LAST]; + + /* Functions to call for each of the possible raise reasons. */ + tree gnat_raise_decls[(int) LAST_REASON_CODE + 1]; + + /* Forward declarations for handlers of attributes. */ + static tree handle_const_attribute (tree *, tree, tree, int, bool *); + static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *); + static tree handle_pure_attribute (tree *, tree, tree, int, bool *); + static tree handle_novops_attribute (tree *, tree, tree, int, bool *); + static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *); + static tree handle_sentinel_attribute (tree *, tree, tree, int, bool *); + static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *); + static tree handle_malloc_attribute (tree *, tree, tree, int, bool *); + static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *); + + /* Fake handler for attributes we don't properly support, typically because + they'd require dragging a lot of the common-c front-end circuitry. */ + static tree fake_attribute_handler (tree *, tree, tree, int, bool *); + + /* Table of machine-independent internal attributes for Ada. We support + this minimal set of attributes to accommodate the needs of builtins. */ + const struct attribute_spec gnat_internal_attribute_table[] = + { + /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler } */ + { "const", 0, 0, true, false, false, handle_const_attribute }, + { "nothrow", 0, 0, true, false, false, handle_nothrow_attribute }, + { "pure", 0, 0, true, false, false, handle_pure_attribute }, + { "no vops", 0, 0, true, false, false, handle_novops_attribute }, + { "nonnull", 0, -1, false, true, true, handle_nonnull_attribute }, + { "sentinel", 0, 1, false, true, true, handle_sentinel_attribute }, + { "noreturn", 0, 0, true, false, false, handle_noreturn_attribute }, + { "malloc", 0, 0, true, false, false, handle_malloc_attribute }, + { "type generic", 0, 0, false, true, true, handle_type_generic_attribute }, + + /* ??? format and format_arg are heavy and not supported, which actually + prevents support for stdio builtins, which we however declare as part + of the common builtins.def contents. */ + { "format", 3, 3, false, true, true, fake_attribute_handler }, + { "format_arg", 1, 1, false, true, true, fake_attribute_handler }, + + { NULL, 0, 0, false, false, false, NULL } + }; + + /* Associates a GNAT tree node to a GCC tree node. It is used in + `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation + of `save_gnu_tree' for more info. */ + static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu; + + #define GET_GNU_TREE(GNAT_ENTITY) \ + associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] + + #define SET_GNU_TREE(GNAT_ENTITY,VAL) \ + associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] = (VAL) + + #define PRESENT_GNU_TREE(GNAT_ENTITY) \ + (associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE) + + /* Associates a GNAT entity to a GCC tree node used as a dummy, if any. */ + static GTY((length ("max_gnat_nodes"))) tree *dummy_node_table; + + #define GET_DUMMY_NODE(GNAT_ENTITY) \ + dummy_node_table[(GNAT_ENTITY) - First_Node_Id] + + #define SET_DUMMY_NODE(GNAT_ENTITY,VAL) \ + dummy_node_table[(GNAT_ENTITY) - First_Node_Id] = (VAL) + + #define PRESENT_DUMMY_NODE(GNAT_ENTITY) \ + (dummy_node_table[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE) + + /* This variable keeps a table for types for each precision so that we only + allocate each of them once. Signed and unsigned types are kept separate. + + Note that these types are only used when fold-const requests something + special. Perhaps we should NOT share these types; we'll see how it + goes later. */ + static GTY(()) tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2]; + + /* Likewise for float types, but record these by mode. */ + static GTY(()) tree float_types[NUM_MACHINE_MODES]; + + /* For each binding contour we allocate a binding_level structure to indicate + the binding depth. */ + + struct gnat_binding_level GTY((chain_next ("%h.chain"))) + { + /* The binding level containing this one (the enclosing binding level). */ + struct gnat_binding_level *chain; + /* The BLOCK node for this level. */ + tree block; + /* If nonzero, the setjmp buffer that needs to be updated for any + variable-sized definition within this context. */ + tree jmpbuf_decl; + }; + + /* The binding level currently in effect. */ + static GTY(()) struct gnat_binding_level *current_binding_level; + + /* A chain of gnat_binding_level structures awaiting reuse. */ + static GTY((deletable)) struct gnat_binding_level *free_binding_level; + + /* An array of global declarations. */ + static GTY(()) VEC(tree,gc) *global_decls; + + /* An array of builtin function declarations. */ + static GTY(()) VEC(tree,gc) *builtin_decls; + + /* An array of global renaming pointers. */ + static GTY(()) VEC(tree,gc) *global_renaming_pointers; + + /* A chain of unused BLOCK nodes. */ + static GTY((deletable)) tree free_block_chain; + + static void gnat_install_builtins (void); + static tree merge_sizes (tree, tree, tree, bool, bool); + static tree compute_related_constant (tree, tree); + static tree split_plus (tree, tree *); + static void gnat_gimplify_function (tree); + static tree float_type_for_precision (int, enum machine_mode); + static tree convert_to_fat_pointer (tree, tree); + static tree convert_to_thin_pointer (tree, tree); + static tree make_descriptor_field (const char *,tree, tree, tree); + static bool potential_alignment_gap (tree, tree, tree); + + /* Initialize the association of GNAT nodes to GCC trees. */ + + void + init_gnat_to_gnu (void) + { + associate_gnat_to_gnu + = (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree)); + } + + /* GNAT_ENTITY is a GNAT tree node for an entity. GNU_DECL is the GCC tree + which is to be associated with GNAT_ENTITY. Such GCC tree node is always + a ..._DECL node. If NO_CHECK is nonzero, the latter check is suppressed. + + If GNU_DECL is zero, a previous association is to be reset. */ + + void + save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, bool no_check) + { + /* Check that GNAT_ENTITY is not already defined and that it is being set + to something which is a decl. Raise gigi 401 if not. Usually, this + means GNAT_ENTITY is defined twice, but occasionally is due to some + Gigi problem. */ + gcc_assert (!(gnu_decl + && (PRESENT_GNU_TREE (gnat_entity) + || (!no_check && !DECL_P (gnu_decl))))); + + SET_GNU_TREE (gnat_entity, gnu_decl); + } + + /* GNAT_ENTITY is a GNAT tree node for a defining identifier. + Return the ..._DECL node that was associated with it. If there is no tree + node associated with GNAT_ENTITY, abort. + + In some cases, such as delayed elaboration or expressions that need to + be elaborated only once, GNAT_ENTITY is really not an entity. */ + + tree + get_gnu_tree (Entity_Id gnat_entity) + { + gcc_assert (PRESENT_GNU_TREE (gnat_entity)); + return GET_GNU_TREE (gnat_entity); + } + + /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */ + + bool + present_gnu_tree (Entity_Id gnat_entity) + { + return PRESENT_GNU_TREE (gnat_entity); + } + + /* Initialize the association of GNAT nodes to GCC trees as dummies. */ + + void + init_dummy_type (void) + { + dummy_node_table + = (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree)); + } + + /* Make a dummy type corresponding to GNAT_TYPE. */ + + tree + make_dummy_type (Entity_Id gnat_type) + { + Entity_Id gnat_underlying = Gigi_Equivalent_Type (gnat_type); + tree gnu_type; + + /* If there is an equivalent type, get its underlying type. */ + if (Present (gnat_underlying)) + gnat_underlying = Underlying_Type (gnat_underlying); + + /* If there was no equivalent type (can only happen when just annotating + types) or underlying type, go back to the original type. */ + if (No (gnat_underlying)) + gnat_underlying = gnat_type; + + /* If it there already a dummy type, use that one. Else make one. */ + if (PRESENT_DUMMY_NODE (gnat_underlying)) + return GET_DUMMY_NODE (gnat_underlying); + + /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make + an ENUMERAL_TYPE. */ + gnu_type = make_node (Is_Record_Type (gnat_underlying) + ? tree_code_for_record_type (gnat_underlying) + : ENUMERAL_TYPE); + TYPE_NAME (gnu_type) = get_entity_name (gnat_type); + TYPE_DUMMY_P (gnu_type) = 1; + if (AGGREGATE_TYPE_P (gnu_type)) + { + TYPE_STUB_DECL (gnu_type) = build_decl (TYPE_DECL, NULL_TREE, gnu_type); + TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_type); + } + + SET_DUMMY_NODE (gnat_underlying, gnu_type); + + return gnu_type; + } + + /* Return nonzero if we are currently in the global binding level. */ + + int + global_bindings_p (void) + { + return ((force_global || !current_function_decl) ? -1 : 0); + } + + /* Enter a new binding level. */ + + void + gnat_pushlevel () + { + struct gnat_binding_level *newlevel = NULL; + + /* Reuse a struct for this binding level, if there is one. */ + if (free_binding_level) + { + newlevel = free_binding_level; + free_binding_level = free_binding_level->chain; + } + else + newlevel + = (struct gnat_binding_level *) + ggc_alloc (sizeof (struct gnat_binding_level)); + + /* Use a free BLOCK, if any; otherwise, allocate one. */ + if (free_block_chain) + { + newlevel->block = free_block_chain; + free_block_chain = BLOCK_CHAIN (free_block_chain); + BLOCK_CHAIN (newlevel->block) = NULL_TREE; + } + else + newlevel->block = make_node (BLOCK); + + /* Point the BLOCK we just made to its parent. */ + if (current_binding_level) + BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block; + + BLOCK_VARS (newlevel->block) = BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE; + TREE_USED (newlevel->block) = 1; + + /* Add this level to the front of the chain (stack) of levels that are + active. */ + newlevel->chain = current_binding_level; + newlevel->jmpbuf_decl = NULL_TREE; + current_binding_level = newlevel; + } + + /* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL + and point FNDECL to this BLOCK. */ + + void + set_current_block_context (tree fndecl) + { + BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl; + DECL_INITIAL (fndecl) = current_binding_level->block; + } + + /* Set the jmpbuf_decl for the current binding level to DECL. */ + + void + set_block_jmpbuf_decl (tree decl) + { + current_binding_level->jmpbuf_decl = decl; + } + + /* Get the jmpbuf_decl, if any, for the current binding level. */ + + tree + get_block_jmpbuf_decl () + { + return current_binding_level->jmpbuf_decl; + } + + /* Exit a binding level. Set any BLOCK into the current code group. */ + + void + gnat_poplevel () + { + struct gnat_binding_level *level = current_binding_level; + tree block = level->block; + + BLOCK_VARS (block) = nreverse (BLOCK_VARS (block)); + BLOCK_SUBBLOCKS (block) = nreverse (BLOCK_SUBBLOCKS (block)); + + /* If this is a function-level BLOCK don't do anything. Otherwise, if there + are no variables free the block and merge its subblocks into those of its + parent block. Otherwise, add it to the list of its parent. */ + if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL) + ; + else if (BLOCK_VARS (block) == NULL_TREE) + { + BLOCK_SUBBLOCKS (level->chain->block) + = chainon (BLOCK_SUBBLOCKS (block), + BLOCK_SUBBLOCKS (level->chain->block)); + BLOCK_CHAIN (block) = free_block_chain; + free_block_chain = block; + } + else + { + BLOCK_CHAIN (block) = BLOCK_SUBBLOCKS (level->chain->block); + BLOCK_SUBBLOCKS (level->chain->block) = block; + TREE_USED (block) = 1; + set_block_for_group (block); + } + + /* Free this binding structure. */ + current_binding_level = level->chain; + level->chain = free_binding_level; + free_binding_level = level; + } + + + /* Records a ..._DECL node DECL as belonging to the current lexical scope + and uses GNAT_NODE for location information and propagating flags. */ + + void + gnat_pushdecl (tree decl, Node_Id gnat_node) + { + /* If this decl is public external or at toplevel, there is no context. + But PARM_DECLs always go in the level of its function. */ + if (TREE_CODE (decl) != PARM_DECL + && ((DECL_EXTERNAL (decl) && TREE_PUBLIC (decl)) + || global_bindings_p ())) + DECL_CONTEXT (decl) = 0; + else + { + DECL_CONTEXT (decl) = current_function_decl; + + /* Functions imported in another function are not really nested. */ + if (TREE_CODE (decl) == FUNCTION_DECL && TREE_PUBLIC (decl)) + DECL_NO_STATIC_CHAIN (decl) = 1; + } + + TREE_NO_WARNING (decl) = (gnat_node == Empty || Warnings_Off (gnat_node)); + + /* Set the location of DECL and emit a declaration for it. */ + if (Present (gnat_node)) + Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (decl)); + add_decl_expr (decl, gnat_node); + + /* Put the declaration on the list. The list of declarations is in reverse + order. The list will be reversed later. Put global variables in the + globals list and builtin functions in a dedicated list to speed up + further lookups. Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into + the list, as they will cause trouble with the debugger and aren't needed + anyway. */ + if (TREE_CODE (decl) != TYPE_DECL + || TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE) + { + if (global_bindings_p ()) + { + VEC_safe_push (tree, gc, global_decls, decl); + + if (TREE_CODE (decl) == FUNCTION_DECL && DECL_BUILT_IN (decl)) + VEC_safe_push (tree, gc, builtin_decls, decl); + } + else + { + TREE_CHAIN (decl) = BLOCK_VARS (current_binding_level->block); + BLOCK_VARS (current_binding_level->block) = decl; + } + } + + /* For the declaration of a type, set its name if it either is not already + set, was set to an IDENTIFIER_NODE, indicating an internal name, + or if the previous type name was not derived from a source name. + We'd rather have the type named with a real name and all the pointer + types to the same object have the same POINTER_TYPE node. Code in the + equivalent function of c-decl.c makes a copy of the type node here, but + that may cause us trouble with incomplete types. We make an exception + for fat pointer types because the compiler automatically builds them + for unconstrained array types and the debugger uses them to represent + both these and pointers to these. */ + if (TREE_CODE (decl) == TYPE_DECL && DECL_NAME (decl)) + { + tree t = TREE_TYPE (decl); + + if (!TYPE_NAME (t) || TREE_CODE (TYPE_NAME (t)) == IDENTIFIER_NODE) + ; + else if (TYPE_FAT_POINTER_P (t)) + { + tree tt = build_variant_type_copy (t); + TYPE_NAME (tt) = decl; + TREE_USED (tt) = TREE_USED (t); + TREE_TYPE (decl) = tt; + DECL_ORIGINAL_TYPE (decl) = t; + t = NULL_TREE; + } + else if (DECL_ARTIFICIAL (TYPE_NAME (t)) && !DECL_ARTIFICIAL (decl)) + ; + else + t = NULL_TREE; + + /* Propagate the name to all the variants. This is needed for + the type qualifiers machinery to work properly. */ + if (t) + for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t)) + TYPE_NAME (t) = decl; + } + } + + /* Do little here. Set up the standard declarations later after the + front end has been run. */ + + void + gnat_init_decl_processing (void) + { + /* Make the binding_level structure for global names. */ + current_function_decl = 0; + current_binding_level = 0; + free_binding_level = 0; + gnat_pushlevel (); + + build_common_tree_nodes (true, true); + + /* In Ada, we use a signed type for SIZETYPE. Use the signed type + corresponding to the size of Pmode. In most cases when ptr_mode and + Pmode differ, C will use the width of ptr_mode as sizetype. But we get + far better code using the width of Pmode. Make this here since we need + this before we can expand the GNAT types. */ + size_type_node = gnat_type_for_size (GET_MODE_BITSIZE (Pmode), 0); + set_sizetype (size_type_node); + + /* In Ada, we use an unsigned 8-bit type for the default boolean type. */ + boolean_type_node = make_node (BOOLEAN_TYPE); + TYPE_PRECISION (boolean_type_node) = 1; + fixup_unsigned_type (boolean_type_node); + TYPE_RM_SIZE_NUM (boolean_type_node) = bitsize_int (1); + + build_common_tree_nodes_2 (0); + + ptr_void_type_node = build_pointer_type (void_type_node); + } + + /* Create the predefined scalar types such as `integer_type_node' needed + in the gcc back-end and initialize the global binding level. */ + + void + init_gigi_decls (tree long_long_float_type, tree exception_type) + { + tree endlink, decl; + tree int64_type = gnat_type_for_size (64, 0); + unsigned int i; + + /* Set the types that GCC and Gigi use from the front end. We would like + to do this for char_type_node, but it needs to correspond to the C + char type. */ + if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE) + { + /* In this case, the builtin floating point types are VAX float, + so make up a type for use. */ + longest_float_type_node = make_node (REAL_TYPE); + TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE; + layout_type (longest_float_type_node); + create_type_decl (get_identifier ("longest float type"), + longest_float_type_node, NULL, false, true, Empty); + } + else + longest_float_type_node = TREE_TYPE (long_long_float_type); + + except_type_node = TREE_TYPE (exception_type); + + unsigned_type_node = gnat_type_for_size (INT_TYPE_SIZE, 1); + create_type_decl (get_identifier ("unsigned int"), unsigned_type_node, + NULL, false, true, Empty); + + void_type_decl_node = create_type_decl (get_identifier ("void"), + void_type_node, NULL, false, true, + Empty); + + void_ftype = build_function_type (void_type_node, NULL_TREE); + ptr_void_ftype = build_pointer_type (void_ftype); + + /* Build the special descriptor type and its null node if needed. */ + if (TARGET_VTABLE_USES_DESCRIPTORS) + { + tree null_node = fold_convert (ptr_void_ftype, null_pointer_node); + tree field_list = NULL_TREE, null_list = NULL_TREE; + int j; + + fdesc_type_node = make_node (RECORD_TYPE); + + for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++) + { + tree field = create_field_decl (NULL_TREE, ptr_void_ftype, + fdesc_type_node, 0, 0, 0, 1); + TREE_CHAIN (field) = field_list; + field_list = field; + null_list = tree_cons (field, null_node, null_list); + } + + finish_record_type (fdesc_type_node, nreverse (field_list), 0, false); + null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list); + } + + /* Now declare runtime functions. */ + endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE); + + /* malloc is a function declaration tree for a function to allocate + memory. */ + malloc_decl = create_subprog_decl (get_identifier ("__gnat_malloc"), + NULL_TREE, + build_function_type (ptr_void_type_node, + tree_cons (NULL_TREE, + sizetype, + endlink)), + NULL_TREE, false, true, true, NULL, + Empty); + DECL_IS_MALLOC (malloc_decl) = 1; + + /* malloc32 is a function declaration tree for a function to allocate + 32bit memory on a 64bit system. Needed only on 64bit VMS. */ + malloc32_decl = create_subprog_decl (get_identifier ("__gnat_malloc32"), + NULL_TREE, + build_function_type (ptr_void_type_node, + tree_cons (NULL_TREE, + sizetype, + endlink)), + NULL_TREE, false, true, true, NULL, + Empty); + DECL_IS_MALLOC (malloc32_decl) = 1; + + /* free is a function declaration tree for a function to free memory. */ + free_decl + = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, + ptr_void_type_node, + endlink)), + NULL_TREE, false, true, true, NULL, Empty); + + /* This is used for 64-bit multiplication with overflow checking. */ + mulv64_decl + = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE, + build_function_type_list (int64_type, int64_type, + int64_type, NULL_TREE), + NULL_TREE, false, true, true, NULL, Empty); + + /* Make the types and functions used for exception processing. */ + jmpbuf_type + = build_array_type (gnat_type_for_mode (Pmode, 0), + build_index_type (build_int_cst (NULL_TREE, 5))); + create_type_decl (get_identifier ("JMPBUF_T"), jmpbuf_type, NULL, + true, true, Empty); + jmpbuf_ptr_type = build_pointer_type (jmpbuf_type); + + /* Functions to get and set the jumpbuf pointer for the current thread. */ + get_jmpbuf_decl + = create_subprog_decl + (get_identifier ("system__soft_links__get_jmpbuf_address_soft"), + NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE), + NULL_TREE, false, true, true, NULL, Empty); + /* Avoid creating superfluous edges to __builtin_setjmp receivers. */ + DECL_PURE_P (get_jmpbuf_decl) = 1; + + set_jmpbuf_decl + = create_subprog_decl + (get_identifier ("system__soft_links__set_jmpbuf_address_soft"), + NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)), + NULL_TREE, false, true, true, NULL, Empty); + + /* Function to get the current exception. */ + get_excptr_decl + = create_subprog_decl + (get_identifier ("system__soft_links__get_gnat_exception"), + NULL_TREE, + build_function_type (build_pointer_type (except_type_node), NULL_TREE), + NULL_TREE, false, true, true, NULL, Empty); + /* Avoid creating superfluous edges to __builtin_setjmp receivers. */ + DECL_PURE_P (get_excptr_decl) = 1; + + /* Functions that raise exceptions. */ + raise_nodefer_decl + = create_subprog_decl + (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, + build_pointer_type (except_type_node), + endlink)), + NULL_TREE, false, true, true, NULL, Empty); + + /* Dummy objects to materialize "others" and "all others" in the exception + tables. These are exported by a-exexpr.adb, so see this unit for the + types to use. */ + + others_decl + = create_var_decl (get_identifier ("OTHERS"), + get_identifier ("__gnat_others_value"), + integer_type_node, 0, 1, 0, 1, 1, 0, Empty); + + all_others_decl + = create_var_decl (get_identifier ("ALL_OTHERS"), + get_identifier ("__gnat_all_others_value"), + integer_type_node, 0, 1, 0, 1, 1, 0, Empty); + + /* Hooks to call when entering/leaving an exception handler. */ + begin_handler_decl + = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, + ptr_void_type_node, + endlink)), + NULL_TREE, false, true, true, NULL, Empty); + + end_handler_decl + = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, + ptr_void_type_node, + endlink)), + NULL_TREE, false, true, true, NULL, Empty); + + /* If in no exception handlers mode, all raise statements are redirected to + __gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since + this procedure will never be called in this mode. */ + if (No_Exception_Handlers_Set ()) + { + decl + = create_subprog_decl + (get_identifier ("__gnat_last_chance_handler"), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, + build_pointer_type (char_type_node), + tree_cons (NULL_TREE, + integer_type_node, + endlink))), + NULL_TREE, false, true, true, NULL, Empty); + + for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++) + gnat_raise_decls[i] = decl; + } + else + /* Otherwise, make one decl for each exception reason. */ + for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++) + { + char name[17]; + + sprintf (name, "__gnat_rcheck_%.2d", i); + gnat_raise_decls[i] + = create_subprog_decl + (get_identifier (name), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, + build_pointer_type + (char_type_node), + tree_cons (NULL_TREE, + integer_type_node, + endlink))), + NULL_TREE, false, true, true, NULL, Empty); + } + + /* Indicate that these never return. */ + TREE_THIS_VOLATILE (raise_nodefer_decl) = 1; + TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1; + TREE_TYPE (raise_nodefer_decl) + = build_qualified_type (TREE_TYPE (raise_nodefer_decl), + TYPE_QUAL_VOLATILE); + + for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++) + { + TREE_THIS_VOLATILE (gnat_raise_decls[i]) = 1; + TREE_SIDE_EFFECTS (gnat_raise_decls[i]) = 1; + TREE_TYPE (gnat_raise_decls[i]) + = build_qualified_type (TREE_TYPE (gnat_raise_decls[i]), + TYPE_QUAL_VOLATILE); + } + + /* setjmp returns an integer and has one operand, which is a pointer to + a jmpbuf. */ + setjmp_decl + = create_subprog_decl + (get_identifier ("__builtin_setjmp"), NULL_TREE, + build_function_type (integer_type_node, + tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)), + NULL_TREE, false, true, true, NULL, Empty); + + DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL; + DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP; + + /* update_setjmp_buf updates a setjmp buffer from the current stack pointer + address. */ + update_setjmp_buf_decl + = create_subprog_decl + (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)), + NULL_TREE, false, true, true, NULL, Empty); + + DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL; + DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF; + + main_identifier_node = get_identifier ("main"); + + /* Install the builtins we might need, either internally or as + user available facilities for Intrinsic imports. */ + gnat_install_builtins (); + } + + /* Given a record type RECORD_TYPE and a chain of FIELD_DECL nodes FIELDLIST, + finish constructing the record or union type. If REP_LEVEL is zero, this + record has no representation clause and so will be entirely laid out here. + If REP_LEVEL is one, this record has a representation clause and has been + laid out already; only set the sizes and alignment. If REP_LEVEL is two, + this record is derived from a parent record and thus inherits its layout; + only make a pass on the fields to finalize them. If DO_NOT_FINALIZE is + true, the record type is expected to be modified afterwards so it will + not be sent to the back-end for finalization. */ + + void + finish_record_type (tree record_type, tree fieldlist, int rep_level, + bool do_not_finalize) + { + enum tree_code code = TREE_CODE (record_type); + tree name = TYPE_NAME (record_type); + tree ada_size = bitsize_zero_node; + tree size = bitsize_zero_node; + bool had_size = TYPE_SIZE (record_type) != 0; + bool had_size_unit = TYPE_SIZE_UNIT (record_type) != 0; + bool had_align = TYPE_ALIGN (record_type) != 0; + tree field; + + if (name && TREE_CODE (name) == TYPE_DECL) + name = DECL_NAME (name); + + TYPE_FIELDS (record_type) = fieldlist; + TYPE_STUB_DECL (record_type) = build_decl (TYPE_DECL, name, record_type); + + /* We don't need both the typedef name and the record name output in + the debugging information, since they are the same. */ + DECL_ARTIFICIAL (TYPE_STUB_DECL (record_type)) = 1; + + /* Globally initialize the record first. If this is a rep'ed record, + that just means some initializations; otherwise, layout the record. */ + if (rep_level > 0) + { + TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type)); + SET_TYPE_MODE (record_type, BLKmode); + + if (!had_size_unit) + TYPE_SIZE_UNIT (record_type) = size_zero_node; + if (!had_size) + TYPE_SIZE (record_type) = bitsize_zero_node; + + /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE + out just like a UNION_TYPE, since the size will be fixed. */ + else if (code == QUAL_UNION_TYPE) + code = UNION_TYPE; + } + else + { + /* Ensure there isn't a size already set. There can be in an error + case where there is a rep clause but all fields have errors and + no longer have a position. */ + TYPE_SIZE (record_type) = 0; + layout_type (record_type); + } + + /* At this point, the position and size of each field is known. It was + either set before entry by a rep clause, or by laying out the type above. + + We now run a pass over the fields (in reverse order for QUAL_UNION_TYPEs) + to compute the Ada size; the GCC size and alignment (for rep'ed records + that are not padding types); and the mode (for rep'ed records). We also + clear the DECL_BIT_FIELD indication for the cases we know have not been + handled yet, and adjust DECL_NONADDRESSABLE_P accordingly. */ + + if (code == QUAL_UNION_TYPE) + fieldlist = nreverse (fieldlist); + + for (field = fieldlist; field; field = TREE_CHAIN (field)) + { + tree type = TREE_TYPE (field); + tree pos = bit_position (field); + tree this_size = DECL_SIZE (field); + tree this_ada_size; + + if ((TREE_CODE (type) == RECORD_TYPE + || TREE_CODE (type) == UNION_TYPE + || TREE_CODE (type) == QUAL_UNION_TYPE) + && !TYPE_IS_FAT_POINTER_P (type) + && !TYPE_CONTAINS_TEMPLATE_P (type) + && TYPE_ADA_SIZE (type)) + this_ada_size = TYPE_ADA_SIZE (type); + else + this_ada_size = this_size; + + /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle. */ + if (DECL_BIT_FIELD (field) + && operand_equal_p (this_size, TYPE_SIZE (type), 0)) + { + unsigned int align = TYPE_ALIGN (type); + + /* In the general case, type alignment is required. */ + if (value_factor_p (pos, align)) + { + /* The enclosing record type must be sufficiently aligned. + Otherwise, if no alignment was specified for it and it + has been laid out already, bump its alignment to the + desired one if this is compatible with its size. */ + if (TYPE_ALIGN (record_type) >= align) + { + DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align); + DECL_BIT_FIELD (field) = 0; + } + else if (!had_align + && rep_level == 0 + && value_factor_p (TYPE_SIZE (record_type), align)) + { + TYPE_ALIGN (record_type) = align; + DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align); + DECL_BIT_FIELD (field) = 0; + } + } + + /* In the non-strict alignment case, only byte alignment is. */ + if (!STRICT_ALIGNMENT + && DECL_BIT_FIELD (field) + && value_factor_p (pos, BITS_PER_UNIT)) + DECL_BIT_FIELD (field) = 0; + } + + /* If we still have DECL_BIT_FIELD set at this point, we know the field + is technically not addressable. Except that it can actually be + addressed if the field is BLKmode and happens to be properly + aligned. */ + DECL_NONADDRESSABLE_P (field) + |= DECL_BIT_FIELD (field) && DECL_MODE (field) != BLKmode; + + /* A type must be as aligned as its most aligned field that is not + a bit-field. But this is already enforced by layout_type. */ + if (rep_level > 0 && !DECL_BIT_FIELD (field)) + TYPE_ALIGN (record_type) + = MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field)); + + switch (code) + { + case UNION_TYPE: + ada_size = size_binop (MAX_EXPR, ada_size, this_ada_size); + size = size_binop (MAX_EXPR, size, this_size); + break; + + case QUAL_UNION_TYPE: + ada_size + = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field), + this_ada_size, ada_size); + size = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field), + this_size, size); + break; + + case RECORD_TYPE: + /* Since we know here that all fields are sorted in order of + increasing bit position, the size of the record is one + higher than the ending bit of the last field processed + unless we have a rep clause, since in that case we might + have a field outside a QUAL_UNION_TYPE that has a higher ending + position. So use a MAX in that case. Also, if this field is a + QUAL_UNION_TYPE, we need to take into account the previous size in + the case of empty variants. */ + ada_size + = merge_sizes (ada_size, pos, this_ada_size, + TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0); + size + = merge_sizes (size, pos, this_size, + TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0); + break; + + default: + gcc_unreachable (); + } + } + + if (code == QUAL_UNION_TYPE) + nreverse (fieldlist); + + if (rep_level < 2) + { + /* If this is a padding record, we never want to make the size smaller + than what was specified in it, if any. */ + if (TREE_CODE (record_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type)) + size = TYPE_SIZE (record_type); + + /* Now set any of the values we've just computed that apply. */ + if (!TYPE_IS_FAT_POINTER_P (record_type) + && !TYPE_CONTAINS_TEMPLATE_P (record_type)) + SET_TYPE_ADA_SIZE (record_type, ada_size); + + if (rep_level > 0) + { + tree size_unit = had_size_unit + ? TYPE_SIZE_UNIT (record_type) + : convert (sizetype, + size_binop (CEIL_DIV_EXPR, size, + bitsize_unit_node)); + unsigned int align = TYPE_ALIGN (record_type); + + TYPE_SIZE (record_type) = variable_size (round_up (size, align)); + TYPE_SIZE_UNIT (record_type) + = variable_size (round_up (size_unit, align / BITS_PER_UNIT)); + + compute_record_mode (record_type); + } + } + + if (!do_not_finalize) + rest_of_record_type_compilation (record_type); + } + + /* Wrap up compilation of RECORD_TYPE, i.e. most notably output all + the debug information associated with it. It need not be invoked + directly in most cases since finish_record_type takes care of doing + so, unless explicitly requested not to through DO_NOT_FINALIZE. */ + + void + rest_of_record_type_compilation (tree record_type) + { + tree fieldlist = TYPE_FIELDS (record_type); + tree field; + enum tree_code code = TREE_CODE (record_type); + bool var_size = false; + + for (field = fieldlist; field; field = TREE_CHAIN (field)) + { + /* We need to make an XVE/XVU record if any field has variable size, + whether or not the record does. For example, if we have a union, + it may be that all fields, rounded up to the alignment, have the + same size, in which case we'll use that size. But the debug + output routines (except Dwarf2) won't be able to output the fields, + so we need to make the special record. */ + if (TREE_CODE (DECL_SIZE (field)) != INTEGER_CST + /* If a field has a non-constant qualifier, the record will have + variable size too. */ + || (code == QUAL_UNION_TYPE + && TREE_CODE (DECL_QUALIFIER (field)) != INTEGER_CST)) + { + var_size = true; + break; + } + } + + /* If this record is of variable size, rename it so that the + debugger knows it is and make a new, parallel, record + that tells the debugger how the record is laid out. See + exp_dbug.ads. But don't do this for records that are padding + since they confuse GDB. */ + if (var_size + && !(TREE_CODE (record_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (record_type))) + { + tree new_record_type + = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE + ? UNION_TYPE : TREE_CODE (record_type)); + tree orig_name = TYPE_NAME (record_type); + tree orig_id + = (TREE_CODE (orig_name) == TYPE_DECL ? DECL_NAME (orig_name) + : orig_name); + tree new_id + = concat_id_with_name (orig_id, + TREE_CODE (record_type) == QUAL_UNION_TYPE + ? "XVU" : "XVE"); + tree last_pos = bitsize_zero_node; + tree old_field; + tree prev_old_field = 0; + + TYPE_NAME (new_record_type) = new_id; + TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT; + TYPE_STUB_DECL (new_record_type) + = build_decl (TYPE_DECL, new_id, new_record_type); + DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type)) = 1; + DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type)) + = DECL_IGNORED_P (TYPE_STUB_DECL (record_type)); + TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type)); + TYPE_SIZE_UNIT (new_record_type) + = size_int (TYPE_ALIGN (record_type) / BITS_PER_UNIT); + + add_parallel_type (TYPE_STUB_DECL (record_type), new_record_type); + + /* Now scan all the fields, replacing each field with a new + field corresponding to the new encoding. */ + for (old_field = TYPE_FIELDS (record_type); old_field; + old_field = TREE_CHAIN (old_field)) + { + tree field_type = TREE_TYPE (old_field); + tree field_name = DECL_NAME (old_field); + tree new_field; + tree curpos = bit_position (old_field); + bool var = false; + unsigned int align = 0; + tree pos; + + /* See how the position was modified from the last position. + + There are two basic cases we support: a value was added + to the last position or the last position was rounded to + a boundary and they something was added. Check for the + first case first. If not, see if there is any evidence + of rounding. If so, round the last position and try + again. + + If this is a union, the position can be taken as zero. */ + + /* Some computations depend on the shape of the position expression, + so strip conversions to make sure it's exposed. */ + curpos = remove_conversions (curpos, true); + + if (TREE_CODE (new_record_type) == UNION_TYPE) + pos = bitsize_zero_node, align = 0; + else + pos = compute_related_constant (curpos, last_pos); + + if (!pos && TREE_CODE (curpos) == MULT_EXPR + && host_integerp (TREE_OPERAND (curpos, 1), 1)) + { + tree offset = TREE_OPERAND (curpos, 0); + align = tree_low_cst (TREE_OPERAND (curpos, 1), 1); + + /* An offset which is a bitwise AND with a negative power of 2 + means an alignment corresponding to this power of 2. */ + offset = remove_conversions (offset, true); + if (TREE_CODE (offset) == BIT_AND_EXPR + && host_integerp (TREE_OPERAND (offset, 1), 0) + && tree_int_cst_sgn (TREE_OPERAND (offset, 1)) < 0) + { + unsigned int pow + = - tree_low_cst (TREE_OPERAND (offset, 1), 0); + if (exact_log2 (pow) > 0) + align *= pow; + } + + pos = compute_related_constant (curpos, + round_up (last_pos, align)); + } + else if (!pos && TREE_CODE (curpos) == PLUS_EXPR + && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST + && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR + && host_integerp (TREE_OPERAND + (TREE_OPERAND (curpos, 0), 1), + 1)) + { + align + = tree_low_cst + (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1), 1); + pos = compute_related_constant (curpos, + round_up (last_pos, align)); + } + else if (potential_alignment_gap (prev_old_field, old_field, + pos)) + { + align = TYPE_ALIGN (field_type); + pos = compute_related_constant (curpos, + round_up (last_pos, align)); + } + + /* If we can't compute a position, set it to zero. + + ??? We really should abort here, but it's too much work + to get this correct for all cases. */ + + if (!pos) + pos = bitsize_zero_node; + + /* See if this type is variable-sized and make a pointer type + and indicate the indirection if so. Beware that the debug + back-end may adjust the position computed above according + to the alignment of the field type, i.e. the pointer type + in this case, if we don't preventively counter that. */ + if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST) + { + field_type = build_pointer_type (field_type); + if (align != 0 && TYPE_ALIGN (field_type) > align) + { + field_type = copy_node (field_type); + TYPE_ALIGN (field_type) = align; + } + var = true; + } + + /* Make a new field name, if necessary. */ + if (var || align != 0) + { + char suffix[16]; + + if (align != 0) + sprintf (suffix, "XV%c%u", var ? 'L' : 'A', + align / BITS_PER_UNIT); + else + strcpy (suffix, "XVL"); + + field_name = concat_id_with_name (field_name, suffix); + } + + new_field = create_field_decl (field_name, field_type, + new_record_type, 0, + DECL_SIZE (old_field), pos, 0); + TREE_CHAIN (new_field) = TYPE_FIELDS (new_record_type); + TYPE_FIELDS (new_record_type) = new_field; + + /* If old_field is a QUAL_UNION_TYPE, take its size as being + zero. The only time it's not the last field of the record + is when there are other components at fixed positions after + it (meaning there was a rep clause for every field) and we + want to be able to encode them. */ + last_pos = size_binop (PLUS_EXPR, bit_position (old_field), + (TREE_CODE (TREE_TYPE (old_field)) + == QUAL_UNION_TYPE) + ? bitsize_zero_node + : DECL_SIZE (old_field)); + prev_old_field = old_field; + } + + TYPE_FIELDS (new_record_type) + = nreverse (TYPE_FIELDS (new_record_type)); + + rest_of_type_decl_compilation (TYPE_STUB_DECL (new_record_type)); + } + + rest_of_type_decl_compilation (TYPE_STUB_DECL (record_type)); + } + + /* Append PARALLEL_TYPE on the chain of parallel types for decl. */ + + void + add_parallel_type (tree decl, tree parallel_type) + { + tree d = decl; + + while (DECL_PARALLEL_TYPE (d)) + d = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (d)); + + SET_DECL_PARALLEL_TYPE (d, parallel_type); + } + + /* Return the parallel type associated to a type, if any. */ + + tree + get_parallel_type (tree type) + { + if (TYPE_STUB_DECL (type)) + return DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type)); + else + return NULL_TREE; + } + + /* Utility function of above to merge LAST_SIZE, the previous size of a record + with FIRST_BIT and SIZE that describe a field. SPECIAL is nonzero + if this represents a QUAL_UNION_TYPE in which case we must look for + COND_EXPRs and replace a value of zero with the old size. If HAS_REP + is nonzero, we must take the MAX of the end position of this field + with LAST_SIZE. In all other cases, we use FIRST_BIT plus SIZE. + + We return an expression for the size. */ + + static tree + merge_sizes (tree last_size, tree first_bit, tree size, bool special, + bool has_rep) + { + tree type = TREE_TYPE (last_size); + tree new; + + if (!special || TREE_CODE (size) != COND_EXPR) + { + new = size_binop (PLUS_EXPR, first_bit, size); + if (has_rep) + new = size_binop (MAX_EXPR, last_size, new); + } + + else + new = fold_build3 (COND_EXPR, type, TREE_OPERAND (size, 0), + integer_zerop (TREE_OPERAND (size, 1)) + ? last_size : merge_sizes (last_size, first_bit, + TREE_OPERAND (size, 1), + 1, has_rep), + integer_zerop (TREE_OPERAND (size, 2)) + ? last_size : merge_sizes (last_size, first_bit, + TREE_OPERAND (size, 2), + 1, has_rep)); + + /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially + when fed through substitute_in_expr) into thinking that a constant + size is not constant. */ + while (TREE_CODE (new) == NON_LVALUE_EXPR) + new = TREE_OPERAND (new, 0); + + return new; + } + + /* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are + related by the addition of a constant. Return that constant if so. */ + + static tree + compute_related_constant (tree op0, tree op1) + { + tree op0_var, op1_var; + tree op0_con = split_plus (op0, &op0_var); + tree op1_con = split_plus (op1, &op1_var); + tree result = size_binop (MINUS_EXPR, op0_con, op1_con); + + if (operand_equal_p (op0_var, op1_var, 0)) + return result; + else if (operand_equal_p (op0, size_binop (PLUS_EXPR, op1_var, result), 0)) + return result; + else + return 0; + } + + /* Utility function of above to split a tree OP which may be a sum, into a + constant part, which is returned, and a variable part, which is stored + in *PVAR. *PVAR may be bitsize_zero_node. All operations must be of + bitsizetype. */ + + static tree + split_plus (tree in, tree *pvar) + { + /* Strip NOPS in order to ease the tree traversal and maximize the + potential for constant or plus/minus discovery. We need to be careful + to always return and set *pvar to bitsizetype trees, but it's worth + the effort. */ + STRIP_NOPS (in); + + *pvar = convert (bitsizetype, in); + + if (TREE_CODE (in) == INTEGER_CST) + { + *pvar = bitsize_zero_node; + return convert (bitsizetype, in); + } + else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR) + { + tree lhs_var, rhs_var; + tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var); + tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var); + + if (lhs_var == TREE_OPERAND (in, 0) + && rhs_var == TREE_OPERAND (in, 1)) + return bitsize_zero_node; + + *pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var); + return size_binop (TREE_CODE (in), lhs_con, rhs_con); + } + else + return bitsize_zero_node; + } + + /* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the + subprogram. If it is void_type_node, then we are dealing with a procedure, + otherwise we are dealing with a function. PARAM_DECL_LIST is a list of + PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the + copy-in/copy-out list to be stored into TYPE_CICO_LIST. + RETURNS_UNCONSTRAINED is true if the function returns an unconstrained + object. RETURNS_BY_REF is true if the function returns by reference. + RETURNS_BY_TARGET_PTR is true if the function is to be passed (as its + first parameter) the address of the place to copy its result. */ + + tree + create_subprog_type (tree return_type, tree param_decl_list, tree cico_list, + bool returns_unconstrained, bool returns_by_ref, + bool returns_by_target_ptr) + { + /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of + the subprogram formal parameters. This list is generated by traversing the + input list of PARM_DECL nodes. */ + tree param_type_list = NULL; + tree param_decl; + tree type; + + for (param_decl = param_decl_list; param_decl; + param_decl = TREE_CHAIN (param_decl)) + param_type_list = tree_cons (NULL_TREE, TREE_TYPE (param_decl), + param_type_list); + + /* The list of the function parameter types has to be terminated by the void + type to signal to the back-end that we are not dealing with a variable + parameter subprogram, but that the subprogram has a fixed number of + parameters. */ + param_type_list = tree_cons (NULL_TREE, void_type_node, param_type_list); + + /* The list of argument types has been created in reverse + so nreverse it. */ + param_type_list = nreverse (param_type_list); + + type = build_function_type (return_type, param_type_list); + + /* TYPE may have been shared since GCC hashes types. If it has a CICO_LIST + or the new type should, make a copy of TYPE. Likewise for + RETURNS_UNCONSTRAINED and RETURNS_BY_REF. */ + if (TYPE_CI_CO_LIST (type) || cico_list + || TYPE_RETURNS_UNCONSTRAINED_P (type) != returns_unconstrained + || TYPE_RETURNS_BY_REF_P (type) != returns_by_ref + || TYPE_RETURNS_BY_TARGET_PTR_P (type) != returns_by_target_ptr) + type = copy_type (type); + + TYPE_CI_CO_LIST (type) = cico_list; + TYPE_RETURNS_UNCONSTRAINED_P (type) = returns_unconstrained; + TYPE_RETURNS_BY_REF_P (type) = returns_by_ref; + TYPE_RETURNS_BY_TARGET_PTR_P (type) = returns_by_target_ptr; + return type; + } + + /* Return a copy of TYPE but safe to modify in any way. */ + + tree + copy_type (tree type) + { + tree new = copy_node (type); + + /* copy_node clears this field instead of copying it, because it is + aliased with TREE_CHAIN. */ + TYPE_STUB_DECL (new) = TYPE_STUB_DECL (type); + + TYPE_POINTER_TO (new) = 0; + TYPE_REFERENCE_TO (new) = 0; + TYPE_MAIN_VARIANT (new) = new; + TYPE_NEXT_VARIANT (new) = 0; + + return new; + } + + /* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose + TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position of + the decl. */ + + tree + create_index_type (tree min, tree max, tree index, Node_Id gnat_node) + { + /* First build a type for the desired range. */ + tree type = build_index_2_type (min, max); + + /* If this type has the TYPE_INDEX_TYPE we want, return it. Otherwise, if it + doesn't have TYPE_INDEX_TYPE set, set it to INDEX. If TYPE_INDEX_TYPE + is set, but not to INDEX, make a copy of this type with the requested + index type. Note that we have no way of sharing these types, but that's + only a small hole. */ + if (TYPE_INDEX_TYPE (type) == index) + return type; + else if (TYPE_INDEX_TYPE (type)) + type = copy_type (type); + + SET_TYPE_INDEX_TYPE (type, index); + create_type_decl (NULL_TREE, type, NULL, true, false, gnat_node); + return type; + } + + /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character + string) and TYPE is a ..._TYPE node giving its data type. + ARTIFICIAL_P is true if this is a declaration that was generated + by the compiler. DEBUG_INFO_P is true if we need to write debugging + information about this type. GNAT_NODE is used for the position of + the decl. */ + + tree + create_type_decl (tree type_name, tree type, struct attrib *attr_list, + bool artificial_p, bool debug_info_p, Node_Id gnat_node) + { + tree type_decl = build_decl (TYPE_DECL, type_name, type); + enum tree_code code = TREE_CODE (type); + + DECL_ARTIFICIAL (type_decl) = artificial_p; + + if (!TYPE_IS_DUMMY_P (type)) + gnat_pushdecl (type_decl, gnat_node); + + process_attributes (type_decl, attr_list); + + /* Pass type declaration information to the debugger unless this is an + UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support, + and ENUMERAL_TYPE or RECORD_TYPE which is handled separately, or + type for which debugging information was not requested. */ + if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p) + DECL_IGNORED_P (type_decl) = 1; + else if (code != ENUMERAL_TYPE + && (code != RECORD_TYPE || TYPE_IS_FAT_POINTER_P (type)) + && !((code == POINTER_TYPE || code == REFERENCE_TYPE) + && TYPE_IS_DUMMY_P (TREE_TYPE (type)))) + rest_of_type_decl_compilation (type_decl); + + return type_decl; + } + + /* Return a VAR_DECL or CONST_DECL node. + + VAR_NAME gives the name of the variable. ASM_NAME is its assembler name + (if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is + the GCC tree for an optional initial expression; NULL_TREE if none. + + CONST_FLAG is true if this variable is constant, in which case we might + return a CONST_DECL node unless CONST_DECL_ALLOWED_P is false. + + PUBLIC_FLAG is true if this is for a reference to a public entity or for a + definition to be made visible outside of the current compilation unit, for + instance variable definitions in a package specification. + + EXTERN_FLAG is nonzero when processing an external variable declaration (as + opposed to a definition: no storage is to be allocated for the variable). + + STATIC_FLAG is only relevant when not at top level. In that case + it indicates whether to always allocate storage to the variable. + + GNAT_NODE is used for the position of the decl. */ + + tree + create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init, + bool const_flag, bool public_flag, bool extern_flag, + bool static_flag, bool const_decl_allowed_p, + struct attrib *attr_list, Node_Id gnat_node) + { + bool init_const + = (var_init != 0 + && gnat_types_compatible_p (type, TREE_TYPE (var_init)) + && (global_bindings_p () || static_flag + ? initializer_constant_valid_p (var_init, TREE_TYPE (var_init)) != 0 + : TREE_CONSTANT (var_init))); + + /* Whether we will make TREE_CONSTANT the DECL we produce here, in which + case the initializer may be used in-lieu of the DECL node (as done in + Identifier_to_gnu). This is useful to prevent the need of elaboration + code when an identifier for which such a decl is made is in turn used as + an initializer. We used to rely on CONST vs VAR_DECL for this purpose, + but extra constraints apply to this choice (see below) and are not + relevant to the distinction we wish to make. */ + bool constant_p = const_flag && init_const; + + /* The actual DECL node. CONST_DECL was initially intended for enumerals + and may be used for scalars in general but not for aggregates. */ + tree var_decl + = build_decl ((constant_p && const_decl_allowed_p + && !AGGREGATE_TYPE_P (type)) ? CONST_DECL : VAR_DECL, + var_name, type); + + /* If this is external, throw away any initializations (they will be done + elsewhere) unless this is a constant for which we would like to remain + able to get the initializer. If we are defining a global here, leave a + constant initialization and save any variable elaborations for the + elaboration routine. If we are just annotating types, throw away the + initialization if it isn't a constant. */ + if ((extern_flag && !constant_p) + || (type_annotate_only && var_init && !TREE_CONSTANT (var_init))) + var_init = NULL_TREE; + + /* At the global level, an initializer requiring code to be generated + produces elaboration statements. Check that such statements are allowed, + that is, not violating a No_Elaboration_Code restriction. */ + if (global_bindings_p () && var_init != 0 && ! init_const) + Check_Elaboration_Code_Allowed (gnat_node); + + /* Ada doesn't feature Fortran-like COMMON variables so we shouldn't + try to fiddle with DECL_COMMON. However, on platforms that don't + support global BSS sections, uninitialized global variables would + go in DATA instead, thus increasing the size of the executable. */ + if (!flag_no_common + && TREE_CODE (var_decl) == VAR_DECL + && !have_global_bss_p ()) + DECL_COMMON (var_decl) = 1; + DECL_INITIAL (var_decl) = var_init; + TREE_READONLY (var_decl) = const_flag; + DECL_EXTERNAL (var_decl) = extern_flag; + TREE_PUBLIC (var_decl) = public_flag || extern_flag; + TREE_CONSTANT (var_decl) = constant_p; + TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl) + = TYPE_VOLATILE (type); + + /* If it's public and not external, always allocate storage for it. + At the global binding level we need to allocate static storage for the + variable if and only if it's not external. If we are not at the top level + we allocate automatic storage unless requested not to. */ + TREE_STATIC (var_decl) + = !extern_flag && (public_flag || static_flag || global_bindings_p ()); + + if (asm_name && VAR_OR_FUNCTION_DECL_P (var_decl)) + SET_DECL_ASSEMBLER_NAME (var_decl, asm_name); + + process_attributes (var_decl, attr_list); + + /* Add this decl to the current binding level. */ + gnat_pushdecl (var_decl, gnat_node); + + if (TREE_SIDE_EFFECTS (var_decl)) + TREE_ADDRESSABLE (var_decl) = 1; + + if (TREE_CODE (var_decl) != CONST_DECL) + { + if (global_bindings_p ()) + rest_of_decl_compilation (var_decl, true, 0); + } + else + expand_decl (var_decl); + + return var_decl; + } + + /* Return true if TYPE, an aggregate type, contains (or is) an array. */ + + static bool + aggregate_type_contains_array_p (tree type) + { + switch (TREE_CODE (type)) + { + case RECORD_TYPE: + case UNION_TYPE: + case QUAL_UNION_TYPE: + { + tree field; + for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) + if (AGGREGATE_TYPE_P (TREE_TYPE (field)) + && aggregate_type_contains_array_p (TREE_TYPE (field))) + return true; + return false; + } + + case ARRAY_TYPE: + return true; + + default: + gcc_unreachable (); + } + } + + /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its + type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if + this field is in a record type with a "pragma pack". If SIZE is nonzero + it is the specified size for this field. If POS is nonzero, it is the bit + position. If ADDRESSABLE is nonzero, it means we are allowed to take + the address of this field for aliasing purposes. If it is negative, we + should not make a bitfield, which is used by make_aligning_type. */ + + tree + create_field_decl (tree field_name, tree field_type, tree record_type, + int packed, tree size, tree pos, int addressable) + { + tree field_decl = build_decl (FIELD_DECL, field_name, field_type); + + DECL_CONTEXT (field_decl) = record_type; + TREE_READONLY (field_decl) = TYPE_READONLY (field_type); + + /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a + byte boundary since GCC cannot handle less-aligned BLKmode bitfields. + Likewise for an aggregate without specified position that contains an + array, because in this case slices of variable length of this array + must be handled by GCC and variable-sized objects need to be aligned + to at least a byte boundary. */ + if (packed && (TYPE_MODE (field_type) == BLKmode + || (!pos + && AGGREGATE_TYPE_P (field_type) + && aggregate_type_contains_array_p (field_type)))) + DECL_ALIGN (field_decl) = BITS_PER_UNIT; + + /* If a size is specified, use it. Otherwise, if the record type is packed + compute a size to use, which may differ from the object's natural size. + We always set a size in this case to trigger the checks for bitfield + creation below, which is typically required when no position has been + specified. */ + if (size) + size = convert (bitsizetype, size); + else if (packed == 1) + { + size = rm_size (field_type); + + /* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to + byte. */ + if (TREE_CODE (size) == INTEGER_CST + && compare_tree_int (size, MAX_FIXED_MODE_SIZE) > 0) + size = round_up (size, BITS_PER_UNIT); + } + + /* If we may, according to ADDRESSABLE, make a bitfield if a size is + specified for two reasons: first if the size differs from the natural + size. Second, if the alignment is insufficient. There are a number of + ways the latter can be true. + + We never make a bitfield if the type of the field has a nonconstant size, + because no such entity requiring bitfield operations should reach here. + + We do *preventively* make a bitfield when there might be the need for it + but we don't have all the necessary information to decide, as is the case + of a field with no specified position in a packed record. + + We also don't look at STRICT_ALIGNMENT here, and rely on later processing + in layout_decl or finish_record_type to clear the bit_field indication if + it is in fact not needed. */ + if (addressable >= 0 + && size + && TREE_CODE (size) == INTEGER_CST + && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST + && (!tree_int_cst_equal (size, TYPE_SIZE (field_type)) + || (pos && !value_factor_p (pos, TYPE_ALIGN (field_type))) + || packed + || (TYPE_ALIGN (record_type) != 0 + && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type)))) + { + DECL_BIT_FIELD (field_decl) = 1; + DECL_SIZE (field_decl) = size; + if (!packed && !pos) + DECL_ALIGN (field_decl) + = (TYPE_ALIGN (record_type) != 0 + ? MIN (TYPE_ALIGN (record_type), TYPE_ALIGN (field_type)) + : TYPE_ALIGN (field_type)); + } + + DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed; + + /* Bump the alignment if need be, either for bitfield/packing purposes or + to satisfy the type requirements if no such consideration applies. When + we get the alignment from the type, indicate if this is from an explicit + user request, which prevents stor-layout from lowering it later on. */ + { + int bit_align + = (DECL_BIT_FIELD (field_decl) ? 1 + : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT : 0); + + if (bit_align > DECL_ALIGN (field_decl)) + DECL_ALIGN (field_decl) = bit_align; + else if (!bit_align && TYPE_ALIGN (field_type) > DECL_ALIGN (field_decl)) + { + DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type); + DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (field_type); + } + } + + if (pos) + { + /* We need to pass in the alignment the DECL is known to have. + This is the lowest-order bit set in POS, but no more than + the alignment of the record, if one is specified. Note + that an alignment of 0 is taken as infinite. */ + unsigned int known_align; + + if (host_integerp (pos, 1)) + known_align = tree_low_cst (pos, 1) & - tree_low_cst (pos, 1); + else + known_align = BITS_PER_UNIT; + + if (TYPE_ALIGN (record_type) + && (known_align == 0 || known_align > TYPE_ALIGN (record_type))) + known_align = TYPE_ALIGN (record_type); + + layout_decl (field_decl, known_align); + SET_DECL_OFFSET_ALIGN (field_decl, + host_integerp (pos, 1) ? BIGGEST_ALIGNMENT + : BITS_PER_UNIT); + pos_from_bit (&DECL_FIELD_OFFSET (field_decl), + &DECL_FIELD_BIT_OFFSET (field_decl), + DECL_OFFSET_ALIGN (field_decl), pos); + + DECL_HAS_REP_P (field_decl) = 1; + } + + /* In addition to what our caller says, claim the field is addressable if we + know that its type is not suitable. + + The field may also be "technically" nonaddressable, meaning that even if + we attempt to take the field's address we will actually get the address + of a copy. This is the case for true bitfields, but the DECL_BIT_FIELD + value we have at this point is not accurate enough, so we don't account + for this here and let finish_record_type decide. */ + if (!addressable && !type_for_nonaliased_component_p (field_type)) + addressable = 1; + + DECL_NONADDRESSABLE_P (field_decl) = !addressable; + + return field_decl; + } + + /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter, + PARAM_TYPE is its type. READONLY is true if the parameter is + readonly (either an In parameter or an address of a pass-by-ref + parameter). */ + + tree + create_param_decl (tree param_name, tree param_type, bool readonly) + { + tree param_decl = build_decl (PARM_DECL, param_name, param_type); + + /* Honor targetm.calls.promote_prototypes(), as not doing so can + lead to various ABI violations. */ + if (targetm.calls.promote_prototypes (param_type) + && (TREE_CODE (param_type) == INTEGER_TYPE + || TREE_CODE (param_type) == ENUMERAL_TYPE + || TREE_CODE (param_type) == BOOLEAN_TYPE) + && TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node)) + { + /* We have to be careful about biased types here. Make a subtype + of integer_type_node with the proper biasing. */ + if (TREE_CODE (param_type) == INTEGER_TYPE + && TYPE_BIASED_REPRESENTATION_P (param_type)) + { + param_type + = copy_type (build_range_type (integer_type_node, + TYPE_MIN_VALUE (param_type), + TYPE_MAX_VALUE (param_type))); + + TYPE_BIASED_REPRESENTATION_P (param_type) = 1; + } + else + param_type = integer_type_node; + } + + DECL_ARG_TYPE (param_decl) = param_type; + TREE_READONLY (param_decl) = readonly; + return param_decl; + } + + /* Given a DECL and ATTR_LIST, process the listed attributes. */ + + void + process_attributes (tree decl, struct attrib *attr_list) + { + for (; attr_list; attr_list = attr_list->next) + switch (attr_list->type) + { + case ATTR_MACHINE_ATTRIBUTE: + decl_attributes (&decl, tree_cons (attr_list->name, attr_list->args, + NULL_TREE), + ATTR_FLAG_TYPE_IN_PLACE); + break; + + case ATTR_LINK_ALIAS: + if (! DECL_EXTERNAL (decl)) + { + TREE_STATIC (decl) = 1; + assemble_alias (decl, attr_list->name); + } + break; + + case ATTR_WEAK_EXTERNAL: + if (SUPPORTS_WEAK) + declare_weak (decl); + else + post_error ("?weak declarations not supported on this target", + attr_list->error_point); + break; + + case ATTR_LINK_SECTION: + if (targetm.have_named_sections) + { + DECL_SECTION_NAME (decl) + = build_string (IDENTIFIER_LENGTH (attr_list->name), + IDENTIFIER_POINTER (attr_list->name)); + DECL_COMMON (decl) = 0; + } + else + post_error ("?section attributes are not supported for this target", + attr_list->error_point); + break; + + case ATTR_LINK_CONSTRUCTOR: + DECL_STATIC_CONSTRUCTOR (decl) = 1; + TREE_USED (decl) = 1; + break; + + case ATTR_LINK_DESTRUCTOR: + DECL_STATIC_DESTRUCTOR (decl) = 1; + TREE_USED (decl) = 1; + break; + } + } + + /* Record a global renaming pointer. */ + + void + record_global_renaming_pointer (tree decl) + { + gcc_assert (DECL_RENAMED_OBJECT (decl)); + VEC_safe_push (tree, gc, global_renaming_pointers, decl); + } + + /* Invalidate the global renaming pointers. */ + + void + invalidate_global_renaming_pointers (void) + { + unsigned int i; + tree iter; + + for (i = 0; VEC_iterate(tree, global_renaming_pointers, i, iter); i++) + SET_DECL_RENAMED_OBJECT (iter, NULL_TREE); + + VEC_free (tree, gc, global_renaming_pointers); + } + + /* Return true if VALUE is a known to be a multiple of FACTOR, which must be + a power of 2. */ + + bool + value_factor_p (tree value, HOST_WIDE_INT factor) + { + if (host_integerp (value, 1)) + return tree_low_cst (value, 1) % factor == 0; + + if (TREE_CODE (value) == MULT_EXPR) + return (value_factor_p (TREE_OPERAND (value, 0), factor) + || value_factor_p (TREE_OPERAND (value, 1), factor)); + + return false; + } + + /* Given 2 consecutive field decls PREV_FIELD and CURR_FIELD, return true + unless we can prove these 2 fields are laid out in such a way that no gap + exist between the end of PREV_FIELD and the beginning of CURR_FIELD. OFFSET + is the distance in bits between the end of PREV_FIELD and the starting + position of CURR_FIELD. It is ignored if null. */ + + static bool + potential_alignment_gap (tree prev_field, tree curr_field, tree offset) + { + /* If this is the first field of the record, there cannot be any gap */ + if (!prev_field) + return false; + + /* If the previous field is a union type, then return False: The only + time when such a field is not the last field of the record is when + there are other components at fixed positions after it (meaning there + was a rep clause for every field), in which case we don't want the + alignment constraint to override them. */ + if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE) + return false; + + /* If the distance between the end of prev_field and the beginning of + curr_field is constant, then there is a gap if the value of this + constant is not null. */ + if (offset && host_integerp (offset, 1)) + return !integer_zerop (offset); + + /* If the size and position of the previous field are constant, + then check the sum of this size and position. There will be a gap + iff it is not multiple of the current field alignment. */ + if (host_integerp (DECL_SIZE (prev_field), 1) + && host_integerp (bit_position (prev_field), 1)) + return ((tree_low_cst (bit_position (prev_field), 1) + + tree_low_cst (DECL_SIZE (prev_field), 1)) + % DECL_ALIGN (curr_field) != 0); + + /* If both the position and size of the previous field are multiples + of the current field alignment, there cannot be any gap. */ + if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field)) + && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field))) + return false; + + /* Fallback, return that there may be a potential gap */ + return true; + } + + /* Returns a LABEL_DECL node for LABEL_NAME. */ + + tree + create_label_decl (tree label_name) + { + tree label_decl = build_decl (LABEL_DECL, label_name, void_type_node); + + DECL_CONTEXT (label_decl) = current_function_decl; + DECL_MODE (label_decl) = VOIDmode; + DECL_SOURCE_LOCATION (label_decl) = input_location; + + return label_decl; + } + + /* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram, + ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE + node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of + PARM_DECL nodes chained through the TREE_CHAIN field). + + INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the + appropriate fields in the FUNCTION_DECL. GNAT_NODE gives the location. */ + + tree + create_subprog_decl (tree subprog_name, tree asm_name, + tree subprog_type, tree param_decl_list, bool inline_flag, + bool public_flag, bool extern_flag, + struct attrib *attr_list, Node_Id gnat_node) + { + tree return_type = TREE_TYPE (subprog_type); + tree subprog_decl = build_decl (FUNCTION_DECL, subprog_name, subprog_type); + + /* If this is a non-inline function nested inside an inlined external + function, we cannot honor both requests without cloning the nested + function in the current unit since it is private to the other unit. + We could inline the nested function as well but it's probably better + to err on the side of too little inlining. */ + if (!inline_flag + && current_function_decl + && DECL_DECLARED_INLINE_P (current_function_decl) + && DECL_EXTERNAL (current_function_decl)) + DECL_DECLARED_INLINE_P (current_function_decl) = 0; + + DECL_EXTERNAL (subprog_decl) = extern_flag; + TREE_PUBLIC (subprog_decl) = public_flag; + TREE_STATIC (subprog_decl) = 1; + TREE_READONLY (subprog_decl) = TYPE_READONLY (subprog_type); + TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type); + TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type); + DECL_DECLARED_INLINE_P (subprog_decl) = inline_flag; + DECL_ARGUMENTS (subprog_decl) = param_decl_list; + DECL_RESULT (subprog_decl) = build_decl (RESULT_DECL, 0, return_type); + DECL_ARTIFICIAL (DECL_RESULT (subprog_decl)) = 1; + DECL_IGNORED_P (DECL_RESULT (subprog_decl)) = 1; + + /* TREE_ADDRESSABLE is set on the result type to request the use of the + target by-reference return mechanism. This is not supported all the + way down to RTL expansion with GCC 4, which ICEs on temporary creation + attempts with such a type and expects DECL_BY_REFERENCE to be set on + the RESULT_DECL instead - see gnat_genericize for more details. */ + if (TREE_ADDRESSABLE (TREE_TYPE (DECL_RESULT (subprog_decl)))) + { + tree result_decl = DECL_RESULT (subprog_decl); + + TREE_ADDRESSABLE (TREE_TYPE (result_decl)) = 0; + DECL_BY_REFERENCE (result_decl) = 1; + } + + if (asm_name) + { + SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name); + + /* The expand_main_function circuitry expects "main_identifier_node" to + designate the DECL_NAME of the 'main' entry point, in turn expected + to be declared as the "main" function literally by default. Ada + program entry points are typically declared with a different name + within the binder generated file, exported as 'main' to satisfy the + system expectations. Redirect main_identifier_node in this case. */ + if (asm_name == main_identifier_node) + main_identifier_node = DECL_NAME (subprog_decl); + } + + process_attributes (subprog_decl, attr_list); + + /* Add this decl to the current binding level. */ + gnat_pushdecl (subprog_decl, gnat_node); + + /* Output the assembler code and/or RTL for the declaration. */ + rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0); + + return subprog_decl; + } + + /* Set up the framework for generating code for SUBPROG_DECL, a subprogram + body. This routine needs to be invoked before processing the declarations + appearing in the subprogram. */ + + void + begin_subprog_body (tree subprog_decl) + { + tree param_decl; + + current_function_decl = subprog_decl; + announce_function (subprog_decl); + + /* Enter a new binding level and show that all the parameters belong to + this function. */ + gnat_pushlevel (); + for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl; + param_decl = TREE_CHAIN (param_decl)) + DECL_CONTEXT (param_decl) = subprog_decl; + + make_decl_rtl (subprog_decl); + + /* We handle pending sizes via the elaboration of types, so we don't need to + save them. This causes them to be marked as part of the outer function + and then discarded. */ + get_pending_sizes (); + } + + + /* Helper for the genericization callback. Return a dereference of VAL + if it is of a reference type. */ + + static tree + convert_from_reference (tree val) + { + tree value_type, ref; + + if (TREE_CODE (TREE_TYPE (val)) != REFERENCE_TYPE) + return val; + + value_type = TREE_TYPE (TREE_TYPE (val)); + ref = build1 (INDIRECT_REF, value_type, val); + + /* See if what we reference is CONST or VOLATILE, which requires + looking into array types to get to the component type. */ + + while (TREE_CODE (value_type) == ARRAY_TYPE) + value_type = TREE_TYPE (value_type); + + TREE_READONLY (ref) + = (TYPE_QUALS (value_type) & TYPE_QUAL_CONST); + TREE_THIS_VOLATILE (ref) + = (TYPE_QUALS (value_type) & TYPE_QUAL_VOLATILE); + + TREE_SIDE_EFFECTS (ref) + = (TREE_THIS_VOLATILE (ref) || TREE_SIDE_EFFECTS (val)); + + return ref; + } + + /* Helper for the genericization callback. Returns true if T denotes + a RESULT_DECL with DECL_BY_REFERENCE set. */ + + static inline bool + is_byref_result (tree t) + { + return (TREE_CODE (t) == RESULT_DECL && DECL_BY_REFERENCE (t)); + } + + + /* Tree walking callback for gnat_genericize. Currently ... + + o Adjust references to the function's DECL_RESULT if it is marked + DECL_BY_REFERENCE and so has had its type turned into a reference + type at the end of the function compilation. */ + + static tree + gnat_genericize_r (tree *stmt_p, int *walk_subtrees, void *data) + { + /* This implementation is modeled after what the C++ front-end is + doing, basis of the downstream passes behavior. */ + + tree stmt = *stmt_p; + struct pointer_set_t *p_set = (struct pointer_set_t*) data; + + /* If we have a direct mention of the result decl, dereference. */ + if (is_byref_result (stmt)) + { + *stmt_p = convert_from_reference (stmt); + *walk_subtrees = 0; + return NULL; + } + + /* Otherwise, no need to walk the same tree twice. */ + if (pointer_set_contains (p_set, stmt)) + { + *walk_subtrees = 0; + return NULL_TREE; + } + + /* If we are taking the address of what now is a reference, just get the + reference value. */ + if (TREE_CODE (stmt) == ADDR_EXPR + && is_byref_result (TREE_OPERAND (stmt, 0))) + { + *stmt_p = convert (TREE_TYPE (stmt), TREE_OPERAND (stmt, 0)); + *walk_subtrees = 0; + } + + /* Don't dereference an by-reference RESULT_DECL inside a RETURN_EXPR. */ + else if (TREE_CODE (stmt) == RETURN_EXPR + && TREE_OPERAND (stmt, 0) + && is_byref_result (TREE_OPERAND (stmt, 0))) + *walk_subtrees = 0; + + /* Don't look inside trees that cannot embed references of interest. */ + else if (IS_TYPE_OR_DECL_P (stmt)) + *walk_subtrees = 0; + + pointer_set_insert (p_set, *stmt_p); + + return NULL; + } + + /* Perform lowering of Ada trees to GENERIC. In particular: + + o Turn a DECL_BY_REFERENCE RESULT_DECL into a real by-reference decl + and adjust all the references to this decl accordingly. */ + + static void + gnat_genericize (tree fndecl) + { + /* Prior to GCC 4, an explicit By_Reference result mechanism for a function + was handled by simply setting TREE_ADDRESSABLE on the result type. + Everything required to actually pass by invisible ref using the target + mechanism (e.g. extra parameter) was handled at RTL expansion time. + + This doesn't work with GCC 4 any more for several reasons. First, the + gimplification process might need the creation of temporaries of this + type, and the gimplifier ICEs on such attempts. Second, the middle-end + now relies on a different attribute for such cases (DECL_BY_REFERENCE on + RESULT/PARM_DECLs), and expects the user invisible by-reference-ness to + be explicitly accounted for by the front-end in the function body. + + We achieve the complete transformation in two steps: + + 1/ create_subprog_decl performs early attribute tweaks: it clears + TREE_ADDRESSABLE from the result type and sets DECL_BY_REFERENCE on + the result decl. The former ensures that the bit isn't set in the GCC + tree saved for the function, so prevents ICEs on temporary creation. + The latter we use here to trigger the rest of the processing. + + 2/ This function performs the type transformation on the result decl + and adjusts all the references to this decl from the function body + accordingly. + + Clearing TREE_ADDRESSABLE from the type differs from the C++ front-end + strategy, which escapes the gimplifier temporary creation issues by + creating it's own temporaries using TARGET_EXPR nodes. Our way relies + on simple specific support code in aggregate_value_p to look at the + target function result decl explicitly. */ + + struct pointer_set_t *p_set; + tree decl_result = DECL_RESULT (fndecl); + + if (!DECL_BY_REFERENCE (decl_result)) + return; + + /* Make the DECL_RESULT explicitly by-reference and adjust all the + occurrences in the function body using the common tree-walking facility. + We want to see every occurrence of the result decl to adjust the + referencing tree, so need to use our own pointer set to control which + trees should be visited again or not. */ + + p_set = pointer_set_create (); + + TREE_TYPE (decl_result) = build_reference_type (TREE_TYPE (decl_result)); + TREE_ADDRESSABLE (decl_result) = 0; + relayout_decl (decl_result); + + walk_tree (&DECL_SAVED_TREE (fndecl), gnat_genericize_r, p_set, NULL); + + pointer_set_destroy (p_set); + } + + /* Finish the definition of the current subprogram BODY and compile it all the + way to assembler language output. ELAB_P tells if this is called for an + elaboration routine, to be entirely discarded if empty. */ + + void + end_subprog_body (tree body, bool elab_p) + { + tree fndecl = current_function_decl; + + /* Mark the BLOCK for this level as being for this function and pop the + level. Since the vars in it are the parameters, clear them. */ + BLOCK_VARS (current_binding_level->block) = 0; + BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl; + DECL_INITIAL (fndecl) = current_binding_level->block; + gnat_poplevel (); + + /* We handle pending sizes via the elaboration of types, so we don't + need to save them. */ + get_pending_sizes (); + + /* Mark the RESULT_DECL as being in this subprogram. */ + DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; + + DECL_SAVED_TREE (fndecl) = body; + + current_function_decl = DECL_CONTEXT (fndecl); + set_cfun (NULL); + + /* We cannot track the location of errors past this point. */ + error_gnat_node = Empty; + + /* If we're only annotating types, don't actually compile this function. */ + if (type_annotate_only) + return; + + /* Perform the required pre-gimplification transformations on the tree. */ + gnat_genericize (fndecl); + + /* We do different things for nested and non-nested functions. + ??? This should be in cgraph. */ + if (!DECL_CONTEXT (fndecl)) + { + gnat_gimplify_function (fndecl); + + /* If this is an empty elaboration proc, just discard the node. + Otherwise, compile further. */ + if (elab_p && empty_body_p (gimple_body (fndecl))) + cgraph_remove_node (cgraph_node (fndecl)); + else + cgraph_finalize_function (fndecl, false); + } + else + /* Register this function with cgraph just far enough to get it + added to our parent's nested function list. */ + (void) cgraph_node (fndecl); + } + + /* Convert FNDECL's code to GIMPLE and handle any nested functions. */ + + static void + gnat_gimplify_function (tree fndecl) + { + struct cgraph_node *cgn; + + dump_function (TDI_original, fndecl); + gimplify_function_tree (fndecl); + dump_function (TDI_generic, fndecl); + + /* Convert all nested functions to GIMPLE now. We do things in this order + so that items like VLA sizes are expanded properly in the context of the + correct function. */ + cgn = cgraph_node (fndecl); + for (cgn = cgn->nested; cgn; cgn = cgn->next_nested) + gnat_gimplify_function (cgn->decl); + } + + + tree + gnat_builtin_function (tree decl) + { + gnat_pushdecl (decl, Empty); + return decl; + } + + /* Return an integer type with the number of bits of precision given by + PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise + it is a signed type. */ + + tree + gnat_type_for_size (unsigned precision, int unsignedp) + { + tree t; + char type_name[20]; + + if (precision <= 2 * MAX_BITS_PER_WORD + && signed_and_unsigned_types[precision][unsignedp]) + return signed_and_unsigned_types[precision][unsignedp]; + + if (unsignedp) + t = make_unsigned_type (precision); + else + t = make_signed_type (precision); + + if (precision <= 2 * MAX_BITS_PER_WORD) + signed_and_unsigned_types[precision][unsignedp] = t; + + if (!TYPE_NAME (t)) + { + sprintf (type_name, "%sSIGNED_%d", unsignedp ? "UN" : "", precision); + TYPE_NAME (t) = get_identifier (type_name); + } + + return t; + } + + /* Likewise for floating-point types. */ + + static tree + float_type_for_precision (int precision, enum machine_mode mode) + { + tree t; + char type_name[20]; + + if (float_types[(int) mode]) + return float_types[(int) mode]; + + float_types[(int) mode] = t = make_node (REAL_TYPE); + TYPE_PRECISION (t) = precision; + layout_type (t); + + gcc_assert (TYPE_MODE (t) == mode); + if (!TYPE_NAME (t)) + { + sprintf (type_name, "FLOAT_%d", precision); + TYPE_NAME (t) = get_identifier (type_name); + } + + return t; + } + + /* Return a data type that has machine mode MODE. UNSIGNEDP selects + an unsigned type; otherwise a signed type is returned. */ + + tree + gnat_type_for_mode (enum machine_mode mode, int unsignedp) + { + if (mode == BLKmode) + return NULL_TREE; + else if (mode == VOIDmode) + return void_type_node; + else if (COMPLEX_MODE_P (mode)) + return NULL_TREE; + else if (SCALAR_FLOAT_MODE_P (mode)) + return float_type_for_precision (GET_MODE_PRECISION (mode), mode); + else if (SCALAR_INT_MODE_P (mode)) + return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp); + else + return NULL_TREE; + } + + /* Return the unsigned version of a TYPE_NODE, a scalar type. */ + + tree + gnat_unsigned_type (tree type_node) + { + tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 1); + + if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node)) + { + type = copy_node (type); + TREE_TYPE (type) = type_node; + } + else if (TREE_TYPE (type_node) + && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE + && TYPE_MODULAR_P (TREE_TYPE (type_node))) + { + type = copy_node (type); + TREE_TYPE (type) = TREE_TYPE (type_node); + } + + return type; + } + + /* Return the signed version of a TYPE_NODE, a scalar type. */ + + tree + gnat_signed_type (tree type_node) + { + tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 0); + + if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node)) + { + type = copy_node (type); + TREE_TYPE (type) = type_node; + } + else if (TREE_TYPE (type_node) + && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE + && TYPE_MODULAR_P (TREE_TYPE (type_node))) + { + type = copy_node (type); + TREE_TYPE (type) = TREE_TYPE (type_node); + } + + return type; + } + + /* Return 1 if the types T1 and T2 are compatible, i.e. if they can be + transparently converted to each other. */ + + int + gnat_types_compatible_p (tree t1, tree t2) + { + enum tree_code code; + + /* This is the default criterion. */ + if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2)) + return 1; + + /* We only check structural equivalence here. */ + if ((code = TREE_CODE (t1)) != TREE_CODE (t2)) + return 0; + + /* Array types are also compatible if they are constrained and have + the same component type and the same domain. */ + if (code == ARRAY_TYPE + && TREE_TYPE (t1) == TREE_TYPE (t2) + && (TYPE_DOMAIN (t1) == TYPE_DOMAIN (t2) + || (TYPE_DOMAIN (t1) + && TYPE_DOMAIN (t2) + && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (t1)), + TYPE_MIN_VALUE (TYPE_DOMAIN (t2))) + && tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (t1)), + TYPE_MAX_VALUE (TYPE_DOMAIN (t2)))))) + return 1; + + /* Padding record types are also compatible if they pad the same + type and have the same constant size. */ + if (code == RECORD_TYPE + && TYPE_IS_PADDING_P (t1) && TYPE_IS_PADDING_P (t2) + && TREE_TYPE (TYPE_FIELDS (t1)) == TREE_TYPE (TYPE_FIELDS (t2)) + && tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2))) + return 1; + + return 0; + } + + /* EXP is an expression for the size of an object. If this size contains + discriminant references, replace them with the maximum (if MAX_P) or + minimum (if !MAX_P) possible value of the discriminant. */ + + tree + max_size (tree exp, bool max_p) + { + enum tree_code code = TREE_CODE (exp); + tree type = TREE_TYPE (exp); + + switch (TREE_CODE_CLASS (code)) + { + case tcc_declaration: + case tcc_constant: + return exp; + + case tcc_vl_exp: + if (code == CALL_EXPR) + { + tree *argarray; + int i, n = call_expr_nargs (exp); + gcc_assert (n > 0); + + argarray = (tree *) alloca (n * sizeof (tree)); + for (i = 0; i < n; i++) + argarray[i] = max_size (CALL_EXPR_ARG (exp, i), max_p); + return build_call_array (type, CALL_EXPR_FN (exp), n, argarray); + } + break; + + case tcc_reference: + /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to + modify. Otherwise, we treat it like a variable. */ + if (!CONTAINS_PLACEHOLDER_P (exp)) + return exp; + + type = TREE_TYPE (TREE_OPERAND (exp, 1)); + return + max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), true); + + case tcc_comparison: + return max_p ? size_one_node : size_zero_node; + + case tcc_unary: + case tcc_binary: + case tcc_expression: + switch (TREE_CODE_LENGTH (code)) + { + case 1: + if (code == NON_LVALUE_EXPR) + return max_size (TREE_OPERAND (exp, 0), max_p); + else + return + fold_build1 (code, type, + max_size (TREE_OPERAND (exp, 0), + code == NEGATE_EXPR ? !max_p : max_p)); + + case 2: + if (code == COMPOUND_EXPR) + return max_size (TREE_OPERAND (exp, 1), max_p); + + /* Calculate "(A ? B : C) - D" as "A ? B - D : C - D" which + may provide a tighter bound on max_size. */ + if (code == MINUS_EXPR + && TREE_CODE (TREE_OPERAND (exp, 0)) == COND_EXPR) + { + tree lhs = fold_build2 (MINUS_EXPR, type, + TREE_OPERAND (TREE_OPERAND (exp, 0), 1), + TREE_OPERAND (exp, 1)); + tree rhs = fold_build2 (MINUS_EXPR, type, + TREE_OPERAND (TREE_OPERAND (exp, 0), 2), + TREE_OPERAND (exp, 1)); + return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type, + max_size (lhs, max_p), + max_size (rhs, max_p)); + } + + { + tree lhs = max_size (TREE_OPERAND (exp, 0), max_p); + tree rhs = max_size (TREE_OPERAND (exp, 1), + code == MINUS_EXPR ? !max_p : max_p); + + /* Special-case wanting the maximum value of a MIN_EXPR. + In that case, if one side overflows, return the other. + sizetype is signed, but we know sizes are non-negative. + Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS + overflowing or the maximum possible value and the RHS + a variable. */ + if (max_p + && code == MIN_EXPR + && TREE_CODE (rhs) == INTEGER_CST + && TREE_OVERFLOW (rhs)) + return lhs; + else if (max_p + && code == MIN_EXPR + && TREE_CODE (lhs) == INTEGER_CST + && TREE_OVERFLOW (lhs)) + return rhs; + else if ((code == MINUS_EXPR || code == PLUS_EXPR) + && ((TREE_CODE (lhs) == INTEGER_CST + && TREE_OVERFLOW (lhs)) + || operand_equal_p (lhs, TYPE_MAX_VALUE (type), 0)) + && !TREE_CONSTANT (rhs)) + return lhs; + else + return fold_build2 (code, type, lhs, rhs); + } + + case 3: + if (code == SAVE_EXPR) + return exp; + else if (code == COND_EXPR) + return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type, + max_size (TREE_OPERAND (exp, 1), max_p), + max_size (TREE_OPERAND (exp, 2), max_p)); + } + + /* Other tree classes cannot happen. */ + default: + break; + } + + gcc_unreachable (); + } + + /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE. + EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs. + Return a constructor for the template. */ + + tree + build_template (tree template_type, tree array_type, tree expr) + { + tree template_elts = NULL_TREE; + tree bound_list = NULL_TREE; + tree field; + + while (TREE_CODE (array_type) == RECORD_TYPE + && (TYPE_IS_PADDING_P (array_type) + || TYPE_JUSTIFIED_MODULAR_P (array_type))) + array_type = TREE_TYPE (TYPE_FIELDS (array_type)); + + if (TREE_CODE (array_type) == ARRAY_TYPE + || (TREE_CODE (array_type) == INTEGER_TYPE + && TYPE_HAS_ACTUAL_BOUNDS_P (array_type))) + bound_list = TYPE_ACTUAL_BOUNDS (array_type); + + /* First make the list for a CONSTRUCTOR for the template. Go down the + field list of the template instead of the type chain because this + array might be an Ada array of arrays and we can't tell where the + nested arrays stop being the underlying object. */ + + for (field = TYPE_FIELDS (template_type); field; + (bound_list + ? (bound_list = TREE_CHAIN (bound_list)) + : (array_type = TREE_TYPE (array_type))), + field = TREE_CHAIN (TREE_CHAIN (field))) + { + tree bounds, min, max; + + /* If we have a bound list, get the bounds from there. Likewise + for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with + DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template. + This will give us a maximum range. */ + if (bound_list) + bounds = TREE_VALUE (bound_list); + else if (TREE_CODE (array_type) == ARRAY_TYPE) + bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type)); + else if (expr && TREE_CODE (expr) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (expr)) + bounds = TREE_TYPE (field); + else + gcc_unreachable (); + + min = convert (TREE_TYPE (field), TYPE_MIN_VALUE (bounds)); + max = convert (TREE_TYPE (TREE_CHAIN (field)), TYPE_MAX_VALUE (bounds)); + + /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must + substitute it from OBJECT. */ + min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr); + max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr); + + template_elts = tree_cons (TREE_CHAIN (field), max, + tree_cons (field, min, template_elts)); + } + + return gnat_build_constructor (template_type, nreverse (template_elts)); + } + + /* Build a 32bit VMS descriptor from a Mechanism_Type, which must specify + a descriptor type, and the GCC type of an object. Each FIELD_DECL + in the type contains in its DECL_INITIAL the expression to use when + a constructor is made for the type. GNAT_ENTITY is an entity used + to print out an error message if the mechanism cannot be applied to + an object of that type and also for the name. */ + + tree + build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity) + { + tree record_type = make_node (RECORD_TYPE); + tree pointer32_type; + tree field_list = 0; + int class; + int dtype = 0; + tree inner_type; + int ndim; + int i; + tree *idx_arr; + tree tem; + + /* If TYPE is an unconstrained array, use the underlying array type. */ + if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) + type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))); + + /* If this is an array, compute the number of dimensions in the array, + get the index types, and point to the inner type. */ + if (TREE_CODE (type) != ARRAY_TYPE) + ndim = 0; + else + for (ndim = 1, inner_type = type; + TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type)); + ndim++, inner_type = TREE_TYPE (inner_type)) + ; + + idx_arr = (tree *) alloca (ndim * sizeof (tree)); + + if (mech != By_Descriptor_NCA && mech != By_Short_Descriptor_NCA + && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type)) + for (i = ndim - 1, inner_type = type; + i >= 0; + i--, inner_type = TREE_TYPE (inner_type)) + idx_arr[i] = TYPE_DOMAIN (inner_type); + else + for (i = 0, inner_type = type; + i < ndim; + i++, inner_type = TREE_TYPE (inner_type)) + idx_arr[i] = TYPE_DOMAIN (inner_type); + + /* Now get the DTYPE value. */ + switch (TREE_CODE (type)) + { + case INTEGER_TYPE: + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + if (TYPE_VAX_FLOATING_POINT_P (type)) + switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1)) + { + case 6: + dtype = 10; + break; + case 9: + dtype = 11; + break; + case 15: + dtype = 27; + break; + } + else + switch (GET_MODE_BITSIZE (TYPE_MODE (type))) + { + case 8: + dtype = TYPE_UNSIGNED (type) ? 2 : 6; + break; + case 16: + dtype = TYPE_UNSIGNED (type) ? 3 : 7; + break; + case 32: + dtype = TYPE_UNSIGNED (type) ? 4 : 8; + break; + case 64: + dtype = TYPE_UNSIGNED (type) ? 5 : 9; + break; + case 128: + dtype = TYPE_UNSIGNED (type) ? 25 : 26; + break; + } + break; + + case REAL_TYPE: + dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53; + break; + + case COMPLEX_TYPE: + if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE + && TYPE_VAX_FLOATING_POINT_P (type)) + switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1)) + { + case 6: + dtype = 12; + break; + case 9: + dtype = 13; + break; + case 15: + dtype = 29; + } + else + dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55; + break; + + case ARRAY_TYPE: + dtype = 14; + break; + + default: + break; + } + + /* Get the CLASS value. */ + switch (mech) + { + case By_Descriptor_A: + case By_Short_Descriptor_A: + class = 4; + break; + case By_Descriptor_NCA: + case By_Short_Descriptor_NCA: + class = 10; + break; + case By_Descriptor_SB: + case By_Short_Descriptor_SB: + class = 15; + break; + case By_Descriptor: + case By_Short_Descriptor: + case By_Descriptor_S: + case By_Short_Descriptor_S: + default: + class = 1; + break; + } + + /* Make the type for a descriptor for VMS. The first four fields + are the same for all types. */ + + field_list + = chainon (field_list, + make_descriptor_field + ("LENGTH", gnat_type_for_size (16, 1), record_type, + size_in_bytes ((mech == By_Descriptor_A || + mech == By_Short_Descriptor_A) + ? inner_type : type))); + + field_list = chainon (field_list, + make_descriptor_field ("DTYPE", + gnat_type_for_size (8, 1), + record_type, size_int (dtype))); + field_list = chainon (field_list, + make_descriptor_field ("CLASS", + gnat_type_for_size (8, 1), + record_type, size_int (class))); + + /* Of course this will crash at run-time if the address space is not + within the low 32 bits, but there is nothing else we can do. */ + pointer32_type = build_pointer_type_for_mode (type, SImode, false); + + field_list + = chainon (field_list, + make_descriptor_field + ("POINTER", pointer32_type, record_type, + build_unary_op (ADDR_EXPR, + pointer32_type, + build0 (PLACEHOLDER_EXPR, type)))); + + switch (mech) + { + case By_Descriptor: + case By_Short_Descriptor: + case By_Descriptor_S: + case By_Short_Descriptor_S: + break; + + case By_Descriptor_SB: + case By_Short_Descriptor_SB: + field_list + = chainon (field_list, + make_descriptor_field + ("SB_L1", gnat_type_for_size (32, 1), record_type, + TREE_CODE (type) == ARRAY_TYPE + ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node)); + field_list + = chainon (field_list, + make_descriptor_field + ("SB_U1", gnat_type_for_size (32, 1), record_type, + TREE_CODE (type) == ARRAY_TYPE + ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node)); + break; + + case By_Descriptor_A: + case By_Short_Descriptor_A: + case By_Descriptor_NCA: + case By_Short_Descriptor_NCA: + field_list = chainon (field_list, + make_descriptor_field ("SCALE", + gnat_type_for_size (8, 1), + record_type, + size_zero_node)); + + field_list = chainon (field_list, + make_descriptor_field ("DIGITS", + gnat_type_for_size (8, 1), + record_type, + size_zero_node)); + + field_list + = chainon (field_list, + make_descriptor_field + ("AFLAGS", gnat_type_for_size (8, 1), record_type, + size_int ((mech == By_Descriptor_NCA || + mech == By_Short_Descriptor_NCA) + ? 0 + /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS. */ + : (TREE_CODE (type) == ARRAY_TYPE + && TYPE_CONVENTION_FORTRAN_P (type) + ? 224 : 192)))); + + field_list = chainon (field_list, + make_descriptor_field ("DIMCT", + gnat_type_for_size (8, 1), + record_type, + size_int (ndim))); + + field_list = chainon (field_list, + make_descriptor_field ("ARSIZE", + gnat_type_for_size (32, 1), + record_type, + size_in_bytes (type))); + + /* Now build a pointer to the 0,0,0... element. */ + tem = build0 (PLACEHOLDER_EXPR, type); + for (i = 0, inner_type = type; i < ndim; + i++, inner_type = TREE_TYPE (inner_type)) + tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem, + convert (TYPE_DOMAIN (inner_type), size_zero_node), + NULL_TREE, NULL_TREE); + + field_list + = chainon (field_list, + make_descriptor_field + ("A0", + build_pointer_type_for_mode (inner_type, SImode, false), + record_type, + build1 (ADDR_EXPR, + build_pointer_type_for_mode (inner_type, SImode, + false), + tem))); + + /* Next come the addressing coefficients. */ + tem = size_one_node; + for (i = 0; i < ndim; i++) + { + char fname[3]; + tree idx_length + = size_binop (MULT_EXPR, tem, + size_binop (PLUS_EXPR, + size_binop (MINUS_EXPR, + TYPE_MAX_VALUE (idx_arr[i]), + TYPE_MIN_VALUE (idx_arr[i])), + size_int (1))); + + fname[0] = ((mech == By_Descriptor_NCA || + mech == By_Short_Descriptor_NCA) ? 'S' : 'M'); + fname[1] = '0' + i, fname[2] = 0; + field_list + = chainon (field_list, + make_descriptor_field (fname, + gnat_type_for_size (32, 1), + record_type, idx_length)); + + if (mech == By_Descriptor_NCA || mech == By_Short_Descriptor_NCA) + tem = idx_length; + } + + /* Finally here are the bounds. */ + for (i = 0; i < ndim; i++) + { + char fname[3]; + + fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0; + field_list + = chainon (field_list, + make_descriptor_field + (fname, gnat_type_for_size (32, 1), record_type, + TYPE_MIN_VALUE (idx_arr[i]))); + + fname[0] = 'U'; + field_list + = chainon (field_list, + make_descriptor_field + (fname, gnat_type_for_size (32, 1), record_type, + TYPE_MAX_VALUE (idx_arr[i]))); + } + break; + + default: + post_error ("unsupported descriptor type for &", gnat_entity); + } + + finish_record_type (record_type, field_list, 0, true); + create_type_decl (create_concat_name (gnat_entity, "DESC"), record_type, + NULL, true, false, gnat_entity); + + return record_type; + } + + /* Build a 64bit VMS descriptor from a Mechanism_Type, which must specify + a descriptor type, and the GCC type of an object. Each FIELD_DECL + in the type contains in its DECL_INITIAL the expression to use when + a constructor is made for the type. GNAT_ENTITY is an entity used + to print out an error message if the mechanism cannot be applied to + an object of that type and also for the name. */ + + tree + build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) + { + tree record64_type = make_node (RECORD_TYPE); + tree pointer64_type; + tree field_list64 = 0; + int class; + int dtype = 0; + tree inner_type; + int ndim; + int i; + tree *idx_arr; + tree tem; + + /* If TYPE is an unconstrained array, use the underlying array type. */ + if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) + type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))); + + /* If this is an array, compute the number of dimensions in the array, + get the index types, and point to the inner type. */ + if (TREE_CODE (type) != ARRAY_TYPE) + ndim = 0; + else + for (ndim = 1, inner_type = type; + TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type)); + ndim++, inner_type = TREE_TYPE (inner_type)) + ; + + idx_arr = (tree *) alloca (ndim * sizeof (tree)); + + if (mech != By_Descriptor_NCA + && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type)) + for (i = ndim - 1, inner_type = type; + i >= 0; + i--, inner_type = TREE_TYPE (inner_type)) + idx_arr[i] = TYPE_DOMAIN (inner_type); + else + for (i = 0, inner_type = type; + i < ndim; + i++, inner_type = TREE_TYPE (inner_type)) + idx_arr[i] = TYPE_DOMAIN (inner_type); + + /* Now get the DTYPE value. */ + switch (TREE_CODE (type)) + { + case INTEGER_TYPE: + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + if (TYPE_VAX_FLOATING_POINT_P (type)) + switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1)) + { + case 6: + dtype = 10; + break; + case 9: + dtype = 11; + break; + case 15: + dtype = 27; + break; + } + else + switch (GET_MODE_BITSIZE (TYPE_MODE (type))) + { + case 8: + dtype = TYPE_UNSIGNED (type) ? 2 : 6; + break; + case 16: + dtype = TYPE_UNSIGNED (type) ? 3 : 7; + break; + case 32: + dtype = TYPE_UNSIGNED (type) ? 4 : 8; + break; + case 64: + dtype = TYPE_UNSIGNED (type) ? 5 : 9; + break; + case 128: + dtype = TYPE_UNSIGNED (type) ? 25 : 26; + break; + } + break; + + case REAL_TYPE: + dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53; + break; + + case COMPLEX_TYPE: + if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE + && TYPE_VAX_FLOATING_POINT_P (type)) + switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1)) + { + case 6: + dtype = 12; + break; + case 9: + dtype = 13; + break; + case 15: + dtype = 29; + } + else + dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55; + break; + + case ARRAY_TYPE: + dtype = 14; + break; + + default: + break; + } + + /* Get the CLASS value. */ + switch (mech) + { + case By_Descriptor_A: + class = 4; + break; + case By_Descriptor_NCA: + class = 10; + break; + case By_Descriptor_SB: + class = 15; + break; + case By_Descriptor: + case By_Descriptor_S: + default: + class = 1; + break; + } + + /* Make the type for a 64bit descriptor for VMS. The first six fields + are the same for all types. */ + + field_list64 = chainon (field_list64, + make_descriptor_field ("MBO", + gnat_type_for_size (16, 1), + record64_type, size_int (1))); + + field_list64 = chainon (field_list64, + make_descriptor_field ("DTYPE", + gnat_type_for_size (8, 1), + record64_type, size_int (dtype))); + field_list64 = chainon (field_list64, + make_descriptor_field ("CLASS", + gnat_type_for_size (8, 1), + record64_type, size_int (class))); + + field_list64 = chainon (field_list64, + make_descriptor_field ("MBMO", + gnat_type_for_size (32, 1), + record64_type, ssize_int (-1))); + + field_list64 + = chainon (field_list64, + make_descriptor_field + ("LENGTH", gnat_type_for_size (64, 1), record64_type, + size_in_bytes (mech == By_Descriptor_A ? inner_type : type))); + + pointer64_type = build_pointer_type_for_mode (type, DImode, false); + + field_list64 + = chainon (field_list64, + make_descriptor_field + ("POINTER", pointer64_type, record64_type, + build_unary_op (ADDR_EXPR, + pointer64_type, + build0 (PLACEHOLDER_EXPR, type)))); + + switch (mech) + { + case By_Descriptor: + case By_Descriptor_S: + break; + + case By_Descriptor_SB: + field_list64 + = chainon (field_list64, + make_descriptor_field + ("SB_L1", gnat_type_for_size (64, 1), record64_type, + TREE_CODE (type) == ARRAY_TYPE + ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node)); + field_list64 + = chainon (field_list64, + make_descriptor_field + ("SB_U1", gnat_type_for_size (64, 1), record64_type, + TREE_CODE (type) == ARRAY_TYPE + ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node)); + break; + + case By_Descriptor_A: + case By_Descriptor_NCA: + field_list64 = chainon (field_list64, + make_descriptor_field ("SCALE", + gnat_type_for_size (8, 1), + record64_type, + size_zero_node)); + + field_list64 = chainon (field_list64, + make_descriptor_field ("DIGITS", + gnat_type_for_size (8, 1), + record64_type, + size_zero_node)); + + field_list64 + = chainon (field_list64, + make_descriptor_field + ("AFLAGS", gnat_type_for_size (8, 1), record64_type, + size_int (mech == By_Descriptor_NCA + ? 0 + /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS. */ + : (TREE_CODE (type) == ARRAY_TYPE + && TYPE_CONVENTION_FORTRAN_P (type) + ? 224 : 192)))); + + field_list64 = chainon (field_list64, + make_descriptor_field ("DIMCT", + gnat_type_for_size (8, 1), + record64_type, + size_int (ndim))); + + field_list64 = chainon (field_list64, + make_descriptor_field ("MBZ", + gnat_type_for_size (32, 1), + record64_type, + size_int (0))); + field_list64 = chainon (field_list64, + make_descriptor_field ("ARSIZE", + gnat_type_for_size (64, 1), + record64_type, + size_in_bytes (type))); + + /* Now build a pointer to the 0,0,0... element. */ + tem = build0 (PLACEHOLDER_EXPR, type); + for (i = 0, inner_type = type; i < ndim; + i++, inner_type = TREE_TYPE (inner_type)) + tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem, + convert (TYPE_DOMAIN (inner_type), size_zero_node), + NULL_TREE, NULL_TREE); + + field_list64 + = chainon (field_list64, + make_descriptor_field + ("A0", + build_pointer_type_for_mode (inner_type, DImode, false), + record64_type, + build1 (ADDR_EXPR, + build_pointer_type_for_mode (inner_type, DImode, + false), + tem))); + + /* Next come the addressing coefficients. */ + tem = size_one_node; + for (i = 0; i < ndim; i++) + { + char fname[3]; + tree idx_length + = size_binop (MULT_EXPR, tem, + size_binop (PLUS_EXPR, + size_binop (MINUS_EXPR, + TYPE_MAX_VALUE (idx_arr[i]), + TYPE_MIN_VALUE (idx_arr[i])), + size_int (1))); + + fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M'); + fname[1] = '0' + i, fname[2] = 0; + field_list64 + = chainon (field_list64, + make_descriptor_field (fname, + gnat_type_for_size (64, 1), + record64_type, idx_length)); + + if (mech == By_Descriptor_NCA) + tem = idx_length; + } + + /* Finally here are the bounds. */ + for (i = 0; i < ndim; i++) + { + char fname[3]; + + fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0; + field_list64 + = chainon (field_list64, + make_descriptor_field + (fname, gnat_type_for_size (64, 1), record64_type, + TYPE_MIN_VALUE (idx_arr[i]))); + + fname[0] = 'U'; + field_list64 + = chainon (field_list64, + make_descriptor_field + (fname, gnat_type_for_size (64, 1), record64_type, + TYPE_MAX_VALUE (idx_arr[i]))); + } + break; + + default: + post_error ("unsupported descriptor type for &", gnat_entity); + } + + finish_record_type (record64_type, field_list64, 0, true); + create_type_decl (create_concat_name (gnat_entity, "DESC64"), record64_type, + NULL, true, false, gnat_entity); + + return record64_type; + } + + /* Utility routine for above code to make a field. */ + + static tree + make_descriptor_field (const char *name, tree type, + tree rec_type, tree initial) + { + tree field + = create_field_decl (get_identifier (name), type, rec_type, 0, 0, 0, 0); + + DECL_INITIAL (field) = initial; + return field; + } + + /* Convert GNU_EXPR, a pointer to a 64bit VMS descriptor, to GNU_TYPE, a + regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to + which the VMS descriptor is passed. */ + + static tree + convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) + { + tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); + tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); + /* The CLASS field is the 3rd field in the descriptor. */ + tree class = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (desc_type))); + /* The POINTER field is the 6th field in the descriptor. */ + tree pointer64 = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (class))); + + /* Retrieve the value of the POINTER field. */ + tree gnu_expr64 + = build3 (COMPONENT_REF, TREE_TYPE (pointer64), desc, pointer64, NULL_TREE); + + if (POINTER_TYPE_P (gnu_type)) + return convert (gnu_type, gnu_expr64); + + else if (TYPE_FAT_POINTER_P (gnu_type)) + { + tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); + tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); + tree template_type = TREE_TYPE (p_bounds_type); + tree min_field = TYPE_FIELDS (template_type); + tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type)); + tree template, template_addr, aflags, dimct, t, u; + /* See the head comment of build_vms_descriptor. */ + int iclass = TREE_INT_CST_LOW (DECL_INITIAL (class)); + tree lfield, ufield; + + /* Convert POINTER to the type of the P_ARRAY field. */ + gnu_expr64 = convert (p_array_type, gnu_expr64); + + switch (iclass) + { + case 1: /* Class S */ + case 15: /* Class SB */ + /* Build {1, LENGTH} template; LENGTH64 is the 5th field. */ + t = TREE_CHAIN (TREE_CHAIN (class)); + t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + t = tree_cons (min_field, + convert (TREE_TYPE (min_field), integer_one_node), + tree_cons (max_field, + convert (TREE_TYPE (max_field), t), + NULL_TREE)); + template = gnat_build_constructor (template_type, t); + template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template); + + /* For class S, we are done. */ + if (iclass == 1) + break; + + /* Test that we really have a SB descriptor, like DEC Ada. */ + t = build3 (COMPONENT_REF, TREE_TYPE (class), desc, class, NULL); + u = convert (TREE_TYPE (class), DECL_INITIAL (class)); + u = build_binary_op (EQ_EXPR, integer_type_node, t, u); + /* If so, there is already a template in the descriptor and + it is located right after the POINTER field. The fields are + 64bits so they must be repacked. */ + t = TREE_CHAIN (pointer64); + lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield); + + t = TREE_CHAIN (t); + ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + ufield = convert + (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (template_type))), ufield); + + /* Build the template in the form of a constructor. */ + t = tree_cons (TYPE_FIELDS (template_type), lfield, + tree_cons (TREE_CHAIN (TYPE_FIELDS (template_type)), + ufield, NULL_TREE)); + template = gnat_build_constructor (template_type, t); + + /* Otherwise use the {1, LENGTH} template we build above. */ + template_addr = build3 (COND_EXPR, p_bounds_type, u, + build_unary_op (ADDR_EXPR, p_bounds_type, + template), + template_addr); + break; + + case 4: /* Class A */ + /* The AFLAGS field is the 3rd field after the pointer in the + descriptor. */ + t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (pointer64))); + aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + /* The DIMCT field is the next field in the descriptor after + aflags. */ + t = TREE_CHAIN (t); + dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + /* Raise CONSTRAINT_ERROR if either more than 1 dimension + or FL_COEFF or FL_BOUNDS not set. */ + u = build_int_cst (TREE_TYPE (aflags), 192); + u = build_binary_op (TRUTH_OR_EXPR, integer_type_node, + build_binary_op (NE_EXPR, integer_type_node, + dimct, + convert (TREE_TYPE (dimct), + size_one_node)), + build_binary_op (NE_EXPR, integer_type_node, + build2 (BIT_AND_EXPR, + TREE_TYPE (aflags), + aflags, u), + u)); + /* There is already a template in the descriptor and it is located + in block 3. The fields are 64bits so they must be repacked. */ + t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN + (t))))); + lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield); + + t = TREE_CHAIN (t); + ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + ufield = convert + (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (template_type))), ufield); + + /* Build the template in the form of a constructor. */ + t = tree_cons (TYPE_FIELDS (template_type), lfield, + tree_cons (TREE_CHAIN (TYPE_FIELDS (template_type)), + ufield, NULL_TREE)); + template = gnat_build_constructor (template_type, t); + template = build3 (COND_EXPR, p_bounds_type, u, + build_call_raise (CE_Length_Check_Failed, Empty, + N_Raise_Constraint_Error), + template); + template_addr = build_unary_op (ADDR_EXPR, p_bounds_type, template); + break; + + case 10: /* Class NCA */ + default: + post_error ("unsupported descriptor type for &", gnat_subprog); + template_addr = integer_zero_node; + break; + } + + /* Build the fat pointer in the form of a constructor. */ + t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr64, + tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)), + template_addr, NULL_TREE)); + return gnat_build_constructor (gnu_type, t); + } + + else + gcc_unreachable (); + } + + /* Convert GNU_EXPR, a pointer to a 32bit VMS descriptor, to GNU_TYPE, a + regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to + which the VMS descriptor is passed. */ + + static tree + convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) + { + tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); + tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); + /* The CLASS field is the 3rd field in the descriptor. */ + tree class = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (desc_type))); + /* The POINTER field is the 4th field in the descriptor. */ + tree pointer = TREE_CHAIN (class); + + /* Retrieve the value of the POINTER field. */ + tree gnu_expr32 + = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE); + + if (POINTER_TYPE_P (gnu_type)) + return convert (gnu_type, gnu_expr32); + + else if (TYPE_FAT_POINTER_P (gnu_type)) + { + tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); + tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); + tree template_type = TREE_TYPE (p_bounds_type); + tree min_field = TYPE_FIELDS (template_type); + tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type)); + tree template, template_addr, aflags, dimct, t, u; + /* See the head comment of build_vms_descriptor. */ + int iclass = TREE_INT_CST_LOW (DECL_INITIAL (class)); + + /* Convert POINTER to the type of the P_ARRAY field. */ + gnu_expr32 = convert (p_array_type, gnu_expr32); + + switch (iclass) + { + case 1: /* Class S */ + case 15: /* Class SB */ + /* Build {1, LENGTH} template; LENGTH is the 1st field. */ + t = TYPE_FIELDS (desc_type); + t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + t = tree_cons (min_field, + convert (TREE_TYPE (min_field), integer_one_node), + tree_cons (max_field, + convert (TREE_TYPE (max_field), t), + NULL_TREE)); + template = gnat_build_constructor (template_type, t); + template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template); + + /* For class S, we are done. */ + if (iclass == 1) + break; + + /* Test that we really have a SB descriptor, like DEC Ada. */ + t = build3 (COMPONENT_REF, TREE_TYPE (class), desc, class, NULL); + u = convert (TREE_TYPE (class), DECL_INITIAL (class)); + u = build_binary_op (EQ_EXPR, integer_type_node, t, u); + /* If so, there is already a template in the descriptor and + it is located right after the POINTER field. */ + t = TREE_CHAIN (pointer); + template = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + /* Otherwise use the {1, LENGTH} template we build above. */ + template_addr = build3 (COND_EXPR, p_bounds_type, u, + build_unary_op (ADDR_EXPR, p_bounds_type, + template), + template_addr); + break; + + case 4: /* Class A */ + /* The AFLAGS field is the 7th field in the descriptor. */ + t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (pointer))); + aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + /* The DIMCT field is the 8th field in the descriptor. */ + t = TREE_CHAIN (t); + dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + /* Raise CONSTRAINT_ERROR if either more than 1 dimension + or FL_COEFF or FL_BOUNDS not set. */ + u = build_int_cst (TREE_TYPE (aflags), 192); + u = build_binary_op (TRUTH_OR_EXPR, integer_type_node, + build_binary_op (NE_EXPR, integer_type_node, + dimct, + convert (TREE_TYPE (dimct), + size_one_node)), + build_binary_op (NE_EXPR, integer_type_node, + build2 (BIT_AND_EXPR, + TREE_TYPE (aflags), + aflags, u), + u)); + /* There is already a template in the descriptor and it is + located at the start of block 3 (12th field). */ + t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (t)))); + template = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + template = build3 (COND_EXPR, p_bounds_type, u, + build_call_raise (CE_Length_Check_Failed, Empty, + N_Raise_Constraint_Error), + template); + template_addr = build_unary_op (ADDR_EXPR, p_bounds_type, template); + break; + + case 10: /* Class NCA */ + default: + post_error ("unsupported descriptor type for &", gnat_subprog); + template_addr = integer_zero_node; + break; + } + + /* Build the fat pointer in the form of a constructor. */ + t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr32, + tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)), + template_addr, NULL_TREE)); + + return gnat_build_constructor (gnu_type, t); + } + + else + gcc_unreachable (); + } + + /* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular + pointer or fat pointer type. GNU_EXPR_ALT_TYPE is the alternate (32-bit) + pointer type of GNU_EXPR. GNAT_SUBPROG is the subprogram to which the + VMS descriptor is passed. */ + + static tree + convert_vms_descriptor (tree gnu_type, tree gnu_expr, tree gnu_expr_alt_type, + Entity_Id gnat_subprog) + { + tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); + tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); + tree mbo = TYPE_FIELDS (desc_type); + const char *mbostr = IDENTIFIER_POINTER (DECL_NAME (mbo)); + tree mbmo = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (mbo))); + tree is64bit, gnu_expr32, gnu_expr64; + + /* If the field name is not MBO, it must be 32-bit and no alternate. + Otherwise primary must be 64-bit and alternate 32-bit. */ + if (strcmp (mbostr, "MBO") != 0) + return convert_vms_descriptor32 (gnu_type, gnu_expr, gnat_subprog); + + /* Build the test for 64-bit descriptor. */ + mbo = build3 (COMPONENT_REF, TREE_TYPE (mbo), desc, mbo, NULL_TREE); + mbmo = build3 (COMPONENT_REF, TREE_TYPE (mbmo), desc, mbmo, NULL_TREE); + is64bit + = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, + build_binary_op (EQ_EXPR, integer_type_node, + convert (integer_type_node, mbo), + integer_one_node), + build_binary_op (EQ_EXPR, integer_type_node, + convert (integer_type_node, mbmo), + integer_minus_one_node)); + + /* Build the 2 possible end results. */ + gnu_expr64 = convert_vms_descriptor64 (gnu_type, gnu_expr, gnat_subprog); + gnu_expr = fold_convert (gnu_expr_alt_type, gnu_expr); + gnu_expr32 = convert_vms_descriptor32 (gnu_type, gnu_expr, gnat_subprog); + + return build3 (COND_EXPR, gnu_type, is64bit, gnu_expr64, gnu_expr32); + } + + /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG + and the GNAT node GNAT_SUBPROG. */ + + void + build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog) + { + tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call; + tree gnu_stub_param, gnu_param_list, gnu_arg_types, gnu_param; + tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog); + tree gnu_body; + + gnu_subprog_type = TREE_TYPE (gnu_subprog); + gnu_param_list = NULL_TREE; + + begin_subprog_body (gnu_stub_decl); + gnat_pushlevel (); + + start_stmt_group (); + + /* Loop over the parameters of the stub and translate any of them + passed by descriptor into a by reference one. */ + for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl), + gnu_arg_types = TYPE_ARG_TYPES (gnu_subprog_type); + gnu_stub_param; + gnu_stub_param = TREE_CHAIN (gnu_stub_param), + gnu_arg_types = TREE_CHAIN (gnu_arg_types)) + { + if (DECL_BY_DESCRIPTOR_P (gnu_stub_param)) + gnu_param + = convert_vms_descriptor (TREE_VALUE (gnu_arg_types), + gnu_stub_param, + DECL_PARM_ALT_TYPE (gnu_stub_param), + gnat_subprog); + else + gnu_param = gnu_stub_param; + + gnu_param_list = tree_cons (NULL_TREE, gnu_param, gnu_param_list); + } + + gnu_body = end_stmt_group (); + + /* Invoke the internal subprogram. */ + gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type), + gnu_subprog); + gnu_subprog_call = build_call_list (TREE_TYPE (gnu_subprog_type), + gnu_subprog_addr, + nreverse (gnu_param_list)); + + /* Propagate the return value, if any. */ + if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type))) + append_to_statement_list (gnu_subprog_call, &gnu_body); + else + append_to_statement_list (build_return_expr (DECL_RESULT (gnu_stub_decl), + gnu_subprog_call), + &gnu_body); + + gnat_poplevel (); + + allocate_struct_function (gnu_stub_decl, false); + end_subprog_body (gnu_body, false); + } + + /* Build a type to be used to represent an aliased object whose nominal + type is an unconstrained array. This consists of a RECORD_TYPE containing + a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an + ARRAY_TYPE. If ARRAY_TYPE is that of the unconstrained array, this + is used to represent an arbitrary unconstrained object. Use NAME + as the name of the record. */ + + tree + build_unc_object_type (tree template_type, tree object_type, tree name) + { + tree type = make_node (RECORD_TYPE); + tree template_field = create_field_decl (get_identifier ("BOUNDS"), + template_type, type, 0, 0, 0, 1); + tree array_field = create_field_decl (get_identifier ("ARRAY"), object_type, + type, 0, 0, 0, 1); + + TYPE_NAME (type) = name; + TYPE_CONTAINS_TEMPLATE_P (type) = 1; + finish_record_type (type, + chainon (chainon (NULL_TREE, template_field), + array_field), + 0, false); + + return type; + } + + /* Same, taking a thin or fat pointer type instead of a template type. */ + + tree + build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type, + tree name) + { + tree template_type; + + gcc_assert (TYPE_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type)); + + template_type + = (TYPE_FAT_POINTER_P (thin_fat_ptr_type) + ? TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (thin_fat_ptr_type)))) + : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type)))); + return build_unc_object_type (template_type, object_type, name); + } + + /* Shift the component offsets within an unconstrained object TYPE to make it + suitable for use as a designated type for thin pointers. */ + + void + shift_unc_components_for_thin_pointers (tree type) + { + /* Thin pointer values designate the ARRAY data of an unconstrained object, + allocated past the BOUNDS template. The designated type is adjusted to + have ARRAY at position zero and the template at a negative offset, so + that COMPONENT_REFs on (*thin_ptr) designate the proper location. */ + + tree bounds_field = TYPE_FIELDS (type); + tree array_field = TREE_CHAIN (TYPE_FIELDS (type)); + + DECL_FIELD_OFFSET (bounds_field) + = size_binop (MINUS_EXPR, size_zero_node, byte_position (array_field)); + + DECL_FIELD_OFFSET (array_field) = size_zero_node; + DECL_FIELD_BIT_OFFSET (array_field) = bitsize_zero_node; + } + + /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In + the normal case this is just two adjustments, but we have more to do + if NEW is an UNCONSTRAINED_ARRAY_TYPE. */ + + void + update_pointer_to (tree old_type, tree new_type) + { + tree ptr = TYPE_POINTER_TO (old_type); + tree ref = TYPE_REFERENCE_TO (old_type); + tree ptr1, ref1; + tree type; + + /* If this is the main variant, process all the other variants first. */ + if (TYPE_MAIN_VARIANT (old_type) == old_type) + for (type = TYPE_NEXT_VARIANT (old_type); type; + type = TYPE_NEXT_VARIANT (type)) + update_pointer_to (type, new_type); + + /* If no pointer or reference, we are done. */ + if (!ptr && !ref) + return; + + /* Merge the old type qualifiers in the new type. + + Each old variant has qualifiers for specific reasons, and the new + designated type as well. Each set of qualifiers represents useful + information grabbed at some point, and merging the two simply unifies + these inputs into the final type description. + + Consider for instance a volatile type frozen after an access to constant + type designating it. After the designated type freeze, we get here with a + volatile new_type and a dummy old_type with a readonly variant, created + when the access type was processed. We shall make a volatile and readonly + designated type, because that's what it really is. + + We might also get here for a non-dummy old_type variant with different + qualifiers than the new_type ones, for instance in some cases of pointers + to private record type elaboration (see the comments around the call to + this routine from gnat_to_gnu_entity/E_Access_Type). We have to merge the + qualifiers in those cases too, to avoid accidentally discarding the + initial set, and will often end up with old_type == new_type then. */ + new_type = build_qualified_type (new_type, + TYPE_QUALS (old_type) + | TYPE_QUALS (new_type)); + + /* If the new type and the old one are identical, there is nothing to + update. */ + if (old_type == new_type) + return; + + /* Otherwise, first handle the simple case. */ + if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE) + { + TYPE_POINTER_TO (new_type) = ptr; + TYPE_REFERENCE_TO (new_type) = ref; + + for (; ptr; ptr = TYPE_NEXT_PTR_TO (ptr)) + for (ptr1 = TYPE_MAIN_VARIANT (ptr); ptr1; + ptr1 = TYPE_NEXT_VARIANT (ptr1)) + TREE_TYPE (ptr1) = new_type; + + for (; ref; ref = TYPE_NEXT_REF_TO (ref)) + for (ref1 = TYPE_MAIN_VARIANT (ref); ref1; + ref1 = TYPE_NEXT_VARIANT (ref1)) + TREE_TYPE (ref1) = new_type; + } + + /* Now deal with the unconstrained array case. In this case the "pointer" + is actually a RECORD_TYPE where both fields are pointers to dummy nodes. + Turn them into pointers to the correct types using update_pointer_to. */ + else if (TREE_CODE (ptr) != RECORD_TYPE || !TYPE_IS_FAT_POINTER_P (ptr)) + gcc_unreachable (); + + else + { + tree new_obj_rec = TYPE_OBJECT_RECORD_TYPE (new_type); + tree array_field = TYPE_FIELDS (ptr); + tree bounds_field = TREE_CHAIN (TYPE_FIELDS (ptr)); + tree new_ptr = TYPE_POINTER_TO (new_type); + tree new_ref; + tree var; + + /* Make pointers to the dummy template point to the real template. */ + update_pointer_to + (TREE_TYPE (TREE_TYPE (bounds_field)), + TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_ptr))))); + + /* The references to the template bounds present in the array type + are made through a PLACEHOLDER_EXPR of type new_ptr. Since we + are updating ptr to make it a full replacement for new_ptr as + pointer to new_type, we must rework the PLACEHOLDER_EXPR so as + to make it of type ptr. */ + new_ref = build3 (COMPONENT_REF, TREE_TYPE (bounds_field), + build0 (PLACEHOLDER_EXPR, ptr), + bounds_field, NULL_TREE); + + /* Create the new array for the new PLACEHOLDER_EXPR and make + pointers to the dummy array point to it. + + ??? This is now the only use of substitute_in_type, + which is a very "heavy" routine to do this, so it + should be replaced at some point. */ + update_pointer_to + (TREE_TYPE (TREE_TYPE (array_field)), + substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (new_ptr))), + TREE_CHAIN (TYPE_FIELDS (new_ptr)), new_ref)); + + /* Make ptr the pointer to new_type. */ + TYPE_POINTER_TO (new_type) = TYPE_REFERENCE_TO (new_type) + = TREE_TYPE (new_type) = ptr; + + for (var = TYPE_MAIN_VARIANT (ptr); var; var = TYPE_NEXT_VARIANT (var)) + SET_TYPE_UNCONSTRAINED_ARRAY (var, new_type); + + /* Now handle updating the allocation record, what the thin pointer + points to. Update all pointers from the old record into the new + one, update the type of the array field, and recompute the size. */ + update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type), new_obj_rec); + + TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))) + = TREE_TYPE (TREE_TYPE (array_field)); + + /* The size recomputation needs to account for alignment constraints, so + we let layout_type work it out. This will reset the field offsets to + what they would be in a regular record, so we shift them back to what + we want them to be for a thin pointer designated type afterwards. */ + DECL_SIZE (TYPE_FIELDS (new_obj_rec)) = 0; + DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))) = 0; + TYPE_SIZE (new_obj_rec) = 0; + layout_type (new_obj_rec); + + shift_unc_components_for_thin_pointers (new_obj_rec); + + /* We are done, at last. */ + rest_of_record_type_compilation (ptr); + } + } + + /* Convert EXPR, a pointer to a constrained array, into a pointer to an + unconstrained one. This involves making or finding a template. */ + + static tree + convert_to_fat_pointer (tree type, tree expr) + { + tree template_type = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)))); + tree p_array_type = TREE_TYPE (TYPE_FIELDS (type)); + tree etype = TREE_TYPE (expr); + tree template; + + /* If EXPR is null, make a fat pointer that contains null pointers to the + template and array. */ + if (integer_zerop (expr)) + return + gnat_build_constructor + (type, + tree_cons (TYPE_FIELDS (type), + convert (p_array_type, expr), + tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), + convert (build_pointer_type (template_type), + expr), + NULL_TREE))); + + /* If EXPR is a thin pointer, make template and data from the record.. */ + else if (TYPE_THIN_POINTER_P (etype)) + { + tree fields = TYPE_FIELDS (TREE_TYPE (etype)); + + expr = save_expr (expr); + if (TREE_CODE (expr) == ADDR_EXPR) + expr = TREE_OPERAND (expr, 0); + else + expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr); + + template = build_component_ref (expr, NULL_TREE, fields, false); + expr = build_unary_op (ADDR_EXPR, NULL_TREE, + build_component_ref (expr, NULL_TREE, + TREE_CHAIN (fields), false)); + } + + /* Otherwise, build the constructor for the template. */ + else + template = build_template (template_type, TREE_TYPE (etype), expr); + + /* The final result is a constructor for the fat pointer. + + If EXPR is an argument of a foreign convention subprogram, the type it + points to is directly the component type. In this case, the expression + type may not match the corresponding FIELD_DECL type at this point, so we + call "convert" here to fix that up if necessary. This type consistency is + required, for instance because it ensures that possible later folding of + COMPONENT_REFs against this constructor always yields something of the + same type as the initial reference. + + Note that the call to "build_template" above is still fine because it + will only refer to the provided TEMPLATE_TYPE in this case. */ + return + gnat_build_constructor + (type, + tree_cons (TYPE_FIELDS (type), + convert (p_array_type, expr), + tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), + build_unary_op (ADDR_EXPR, NULL_TREE, template), + NULL_TREE))); + } + + /* Convert to a thin pointer type, TYPE. The only thing we know how to convert + is something that is a fat pointer, so convert to it first if it EXPR + is not already a fat pointer. */ + + static tree + convert_to_thin_pointer (tree type, tree expr) + { + if (!TYPE_FAT_POINTER_P (TREE_TYPE (expr))) + expr + = convert_to_fat_pointer + (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), expr); + + /* We get the pointer to the data and use a NOP_EXPR to make it the + proper GCC type. */ + expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)), + false); + expr = build1 (NOP_EXPR, type, expr); + + return expr; + } + + /* Create an expression whose value is that of EXPR, + converted to type TYPE. The TREE_TYPE of the value + is always TYPE. This function implements all reasonable + conversions; callers should filter out those that are + not permitted by the language being compiled. */ + + tree + convert (tree type, tree expr) + { + enum tree_code code = TREE_CODE (type); + tree etype = TREE_TYPE (expr); + enum tree_code ecode = TREE_CODE (etype); + + /* If EXPR is already the right type, we are done. */ + if (type == etype) + return expr; + + /* If both input and output have padding and are of variable size, do this + as an unchecked conversion. Likewise if one is a mere variant of the + other, so we avoid a pointless unpad/repad sequence. */ + else if (code == RECORD_TYPE && ecode == RECORD_TYPE + && TYPE_IS_PADDING_P (type) && TYPE_IS_PADDING_P (etype) + && (!TREE_CONSTANT (TYPE_SIZE (type)) + || !TREE_CONSTANT (TYPE_SIZE (etype)) + || gnat_types_compatible_p (type, etype) + || TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type))) + == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (etype))))) + ; + + /* If the output type has padding, convert to the inner type and + make a constructor to build the record. */ + else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + { + /* If we previously converted from another type and our type is + of variable size, remove the conversion to avoid the need for + variable-size temporaries. Likewise for a conversion between + original and packable version. */ + if (TREE_CODE (expr) == VIEW_CONVERT_EXPR + && (!TREE_CONSTANT (TYPE_SIZE (type)) + || (ecode == RECORD_TYPE + && TYPE_NAME (etype) + == TYPE_NAME (TREE_TYPE (TREE_OPERAND (expr, 0)))))) + expr = TREE_OPERAND (expr, 0); + + /* If we are just removing the padding from expr, convert the original + object if we have variable size in order to avoid the need for some + variable-size temporaries. Likewise if the padding is a mere variant + of the other, so we avoid a pointless unpad/repad sequence. */ + if (TREE_CODE (expr) == COMPONENT_REF + && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0))) + && (!TREE_CONSTANT (TYPE_SIZE (type)) + || gnat_types_compatible_p (type, + TREE_TYPE (TREE_OPERAND (expr, 0))) + || (ecode == RECORD_TYPE + && TYPE_NAME (etype) + == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type)))))) + return convert (type, TREE_OPERAND (expr, 0)); + + /* If the result type is a padded type with a self-referentially-sized + field and the expression type is a record, do this as an + unchecked conversion. */ + else if (TREE_CODE (etype) == RECORD_TYPE + && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type)))) + return unchecked_convert (type, expr, false); + + else + return + gnat_build_constructor (type, + tree_cons (TYPE_FIELDS (type), + convert (TREE_TYPE + (TYPE_FIELDS (type)), + expr), + NULL_TREE)); + } + + /* If the input type has padding, remove it and convert to the output type. + The conditions ordering is arranged to ensure that the output type is not + a padding type here, as it is not clear whether the conversion would + always be correct if this was to happen. */ + else if (ecode == RECORD_TYPE && TYPE_IS_PADDING_P (etype)) + { + tree unpadded; + + /* If we have just converted to this padded type, just get the + inner expression. */ + if (TREE_CODE (expr) == CONSTRUCTOR + && !VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (expr)) + && VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->index + == TYPE_FIELDS (etype)) + unpadded + = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->value; + + /* Otherwise, build an explicit component reference. */ + else + unpadded + = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false); + + return convert (type, unpadded); + } + + /* If the input is a biased type, adjust first. */ + if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype)) + return convert (type, fold_build2 (PLUS_EXPR, TREE_TYPE (etype), + fold_convert (TREE_TYPE (etype), + expr), + TYPE_MIN_VALUE (etype))); + + /* If the input is a justified modular type, we need to extract the actual + object before converting it to any other type with the exceptions of an + unconstrained array or of a mere type variant. It is useful to avoid the + extraction and conversion in the type variant case because it could end + up replacing a VAR_DECL expr by a constructor and we might be about the + take the address of the result. */ + if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype) + && code != UNCONSTRAINED_ARRAY_TYPE + && TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (etype)) + return convert (type, build_component_ref (expr, NULL_TREE, + TYPE_FIELDS (etype), false)); + + /* If converting to a type that contains a template, convert to the data + type and then build the template. */ + if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type)) + { + tree obj_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))); + + /* If the source already has a template, get a reference to the + associated array only, as we are going to rebuild a template + for the target type anyway. */ + expr = maybe_unconstrained_array (expr); + + return + gnat_build_constructor + (type, + tree_cons (TYPE_FIELDS (type), + build_template (TREE_TYPE (TYPE_FIELDS (type)), + obj_type, NULL_TREE), + tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), + convert (obj_type, expr), NULL_TREE))); + } + + /* There are some special cases of expressions that we process + specially. */ + switch (TREE_CODE (expr)) + { + case ERROR_MARK: + return expr; + + case NULL_EXPR: + /* Just set its type here. For TRANSFORM_EXPR, we will do the actual + conversion in gnat_expand_expr. NULL_EXPR does not represent + and actual value, so no conversion is needed. */ + expr = copy_node (expr); + TREE_TYPE (expr) = type; + return expr; + + case STRING_CST: + /* If we are converting a STRING_CST to another constrained array type, + just make a new one in the proper type. */ + if (code == ecode && AGGREGATE_TYPE_P (etype) + && !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST + && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)) + { + expr = copy_node (expr); + TREE_TYPE (expr) = type; + return expr; + } + break; + + case CONSTRUCTOR: + /* If we are converting a CONSTRUCTOR to a mere variant type, just make + a new one in the proper type. */ + if (code == ecode && gnat_types_compatible_p (type, etype)) + { + expr = copy_node (expr); + TREE_TYPE (expr) = type; + return expr; + } + + /* Likewise for a conversion between original and packable version, but + we have to work harder in order to preserve type consistency. */ + if (code == ecode + && code == RECORD_TYPE + && TYPE_NAME (type) == TYPE_NAME (etype)) + { + VEC(constructor_elt,gc) *e = CONSTRUCTOR_ELTS (expr); + unsigned HOST_WIDE_INT len = VEC_length (constructor_elt, e); + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, len); + tree efield = TYPE_FIELDS (etype), field = TYPE_FIELDS (type); + unsigned HOST_WIDE_INT idx; + tree index, value; + + FOR_EACH_CONSTRUCTOR_ELT(e, idx, index, value) + { + constructor_elt *elt = VEC_quick_push (constructor_elt, v, NULL); + /* We expect only simple constructors. Otherwise, punt. */ + if (!(index == efield || index == DECL_ORIGINAL_FIELD (efield))) + break; + elt->index = field; + elt->value = convert (TREE_TYPE (field), value); + efield = TREE_CHAIN (efield); + field = TREE_CHAIN (field); + } + + if (idx == len) + { + expr = copy_node (expr); + TREE_TYPE (expr) = type; + CONSTRUCTOR_ELTS (expr) = v; + return expr; + } + } + break; + + case UNCONSTRAINED_ARRAY_REF: + /* Convert this to the type of the inner array by getting the address of + the array from the template. */ + expr = build_unary_op (INDIRECT_REF, NULL_TREE, + build_component_ref (TREE_OPERAND (expr, 0), + get_identifier ("P_ARRAY"), + NULL_TREE, false)); + etype = TREE_TYPE (expr); + ecode = TREE_CODE (etype); + break; + + case VIEW_CONVERT_EXPR: + { + /* GCC 4.x is very sensitive to type consistency overall, and view + conversions thus are very frequent. Even though just "convert"ing + the inner operand to the output type is fine in most cases, it + might expose unexpected input/output type mismatches in special + circumstances so we avoid such recursive calls when we can. */ + tree op0 = TREE_OPERAND (expr, 0); + + /* If we are converting back to the original type, we can just + lift the input conversion. This is a common occurrence with + switches back-and-forth amongst type variants. */ + if (type == TREE_TYPE (op0)) + return op0; + + /* Otherwise, if we're converting between two aggregate types, we + might be allowed to substitute the VIEW_CONVERT_EXPR target type + in place or to just convert the inner expression. */ + if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)) + { + /* If we are converting between mere variants, we can just + substitute the VIEW_CONVERT_EXPR in place. */ + if (gnat_types_compatible_p (type, etype)) + return build1 (VIEW_CONVERT_EXPR, type, op0); + + /* Otherwise, we may just bypass the input view conversion unless + one of the types is a fat pointer, which is handled by + specialized code below which relies on exact type matching. */ + else if (!TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)) + return convert (type, op0); + } + } + break; + + case INDIRECT_REF: + /* If both types are record types, just convert the pointer and + make a new INDIRECT_REF. + + ??? Disable this for now since it causes problems with the + code in build_binary_op for MODIFY_EXPR which wants to + strip off conversions. But that code really is a mess and + we need to do this a much better way some time. */ + if (0 + && (TREE_CODE (type) == RECORD_TYPE + || TREE_CODE (type) == UNION_TYPE) + && (TREE_CODE (etype) == RECORD_TYPE + || TREE_CODE (etype) == UNION_TYPE) + && !TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)) + return build_unary_op (INDIRECT_REF, NULL_TREE, + convert (build_pointer_type (type), + TREE_OPERAND (expr, 0))); + break; + + default: + break; + } + + /* Check for converting to a pointer to an unconstrained array. */ + if (TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)) + return convert_to_fat_pointer (type, expr); + + /* If we are converting between two aggregate types that are mere + variants, just make a VIEW_CONVERT_EXPR. */ + else if (code == ecode + && AGGREGATE_TYPE_P (type) + && gnat_types_compatible_p (type, etype)) + return build1 (VIEW_CONVERT_EXPR, type, expr); + + /* In all other cases of related types, make a NOP_EXPR. */ + else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype) + || (code == INTEGER_CST && ecode == INTEGER_CST + && (type == TREE_TYPE (etype) || etype == TREE_TYPE (type)))) + return fold_convert (type, expr); + + switch (code) + { + case VOID_TYPE: + return fold_build1 (CONVERT_EXPR, type, expr); + + case INTEGER_TYPE: + if (TYPE_HAS_ACTUAL_BOUNDS_P (type) + && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE + || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype)))) + return unchecked_convert (type, expr, false); + else if (TYPE_BIASED_REPRESENTATION_P (type)) + return fold_convert (type, + fold_build2 (MINUS_EXPR, TREE_TYPE (type), + convert (TREE_TYPE (type), expr), + TYPE_MIN_VALUE (type))); + + /* ... fall through ... */ + + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + /* If we are converting an additive expression to an integer type + with lower precision, be wary of the optimization that can be + applied by convert_to_integer. There are 2 problematic cases: + - if the first operand was originally of a biased type, + because we could be recursively called to convert it + to an intermediate type and thus rematerialize the + additive operator endlessly, + - if the expression contains a placeholder, because an + intermediate conversion that changes the sign could + be inserted and thus introduce an artificial overflow + at compile time when the placeholder is substituted. */ + if (code == INTEGER_TYPE + && ecode == INTEGER_TYPE + && TYPE_PRECISION (type) < TYPE_PRECISION (etype) + && (TREE_CODE (expr) == PLUS_EXPR || TREE_CODE (expr) == MINUS_EXPR)) + { + tree op0 = get_unwidened (TREE_OPERAND (expr, 0), type); + + if ((TREE_CODE (TREE_TYPE (op0)) == INTEGER_TYPE + && TYPE_BIASED_REPRESENTATION_P (TREE_TYPE (op0))) + || CONTAINS_PLACEHOLDER_P (expr)) + return build1 (NOP_EXPR, type, expr); + } + + return fold (convert_to_integer (type, expr)); + + case POINTER_TYPE: + case REFERENCE_TYPE: + /* If converting between two pointers to records denoting + both a template and type, adjust if needed to account + for any differing offsets, since one might be negative. */ + if (TYPE_THIN_POINTER_P (etype) && TYPE_THIN_POINTER_P (type)) + { + tree bit_diff + = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype))), + bit_position (TYPE_FIELDS (TREE_TYPE (type)))); + tree byte_diff = size_binop (CEIL_DIV_EXPR, bit_diff, + sbitsize_int (BITS_PER_UNIT)); + + expr = build1 (NOP_EXPR, type, expr); + TREE_CONSTANT (expr) = TREE_CONSTANT (TREE_OPERAND (expr, 0)); + if (integer_zerop (byte_diff)) + return expr; + + return build_binary_op (POINTER_PLUS_EXPR, type, expr, + fold (convert (sizetype, byte_diff))); + } + + /* If converting to a thin pointer, handle specially. */ + if (TYPE_THIN_POINTER_P (type) + && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))) + return convert_to_thin_pointer (type, expr); + + /* If converting fat pointer to normal pointer, get the pointer to the + array and then convert it. */ + else if (TYPE_FAT_POINTER_P (etype)) + expr = build_component_ref (expr, get_identifier ("P_ARRAY"), + NULL_TREE, false); + + return fold (convert_to_pointer (type, expr)); + + case REAL_TYPE: + return fold (convert_to_real (type, expr)); + + case RECORD_TYPE: + if (TYPE_JUSTIFIED_MODULAR_P (type) && !AGGREGATE_TYPE_P (etype)) + return + gnat_build_constructor + (type, tree_cons (TYPE_FIELDS (type), + convert (TREE_TYPE (TYPE_FIELDS (type)), expr), + NULL_TREE)); + + /* ... fall through ... */ + + case ARRAY_TYPE: + /* In these cases, assume the front-end has validated the conversion. + If the conversion is valid, it will be a bit-wise conversion, so + it can be viewed as an unchecked conversion. */ + return unchecked_convert (type, expr, false); + + case UNION_TYPE: + /* This is a either a conversion between a tagged type and some + subtype, which we have to mark as a UNION_TYPE because of + overlapping fields or a conversion of an Unchecked_Union. */ + return unchecked_convert (type, expr, false); + + case UNCONSTRAINED_ARRAY_TYPE: + /* If EXPR is a constrained array, take its address, convert it to a + fat pointer, and then dereference it. Likewise if EXPR is a + record containing both a template and a constrained array. + Note that a record representing a justified modular type + always represents a packed constrained array. */ + if (ecode == ARRAY_TYPE + || (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype)) + || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype)) + || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype))) + return + build_unary_op + (INDIRECT_REF, NULL_TREE, + convert_to_fat_pointer (TREE_TYPE (type), + build_unary_op (ADDR_EXPR, + NULL_TREE, expr))); + + /* Do something very similar for converting one unconstrained + array to another. */ + else if (ecode == UNCONSTRAINED_ARRAY_TYPE) + return + build_unary_op (INDIRECT_REF, NULL_TREE, + convert (TREE_TYPE (type), + build_unary_op (ADDR_EXPR, + NULL_TREE, expr))); + else + gcc_unreachable (); + + case COMPLEX_TYPE: + return fold (convert_to_complex (type, expr)); + + default: + gcc_unreachable (); + } + } + + /* Remove all conversions that are done in EXP. This includes converting + from a padded type or to a justified modular type. If TRUE_ADDRESS + is true, always return the address of the containing object even if + the address is not bit-aligned. */ + + tree + remove_conversions (tree exp, bool true_address) + { + switch (TREE_CODE (exp)) + { + case CONSTRUCTOR: + if (true_address + && TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (exp))) + return + remove_conversions (VEC_index (constructor_elt, + CONSTRUCTOR_ELTS (exp), 0)->value, + true); + break; + + case COMPONENT_REF: + if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp, 0))) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0)))) + return remove_conversions (TREE_OPERAND (exp, 0), true_address); + break; + + case VIEW_CONVERT_EXPR: case NON_LVALUE_EXPR: + CASE_CONVERT: + return remove_conversions (TREE_OPERAND (exp, 0), true_address); + + default: + break; + } + + return exp; + } + + /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that + refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P, + likewise return an expression pointing to the underlying array. */ + + tree + maybe_unconstrained_array (tree exp) + { + enum tree_code code = TREE_CODE (exp); + tree new; + + switch (TREE_CODE (TREE_TYPE (exp))) + { + case UNCONSTRAINED_ARRAY_TYPE: + if (code == UNCONSTRAINED_ARRAY_REF) + { + new + = build_unary_op (INDIRECT_REF, NULL_TREE, + build_component_ref (TREE_OPERAND (exp, 0), + get_identifier ("P_ARRAY"), + NULL_TREE, false)); + TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp); + return new; + } + + else if (code == NULL_EXPR) + return build1 (NULL_EXPR, + TREE_TYPE (TREE_TYPE (TYPE_FIELDS + (TREE_TYPE (TREE_TYPE (exp))))), + TREE_OPERAND (exp, 0)); + + case RECORD_TYPE: + /* If this is a padded type, convert to the unpadded type and see if + it contains a template. */ + if (TYPE_IS_PADDING_P (TREE_TYPE (exp))) + { + new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp); + if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new))) + return + build_component_ref (new, NULL_TREE, + TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))), + 0); + } + else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp))) + return + build_component_ref (exp, NULL_TREE, + TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))), 0); + break; + + default: + break; + } + + return exp; + } + + /* Return true if EXPR is an expression that can be folded as an operand + of a VIEW_CONVERT_EXPR. See the head comment of unchecked_convert for + the rationale. */ + + static bool + can_fold_for_view_convert_p (tree expr) + { + tree t1, t2; + + /* The folder will fold NOP_EXPRs between integral types with the same + precision (in the middle-end's sense). We cannot allow it if the + types don't have the same precision in the Ada sense as well. */ + if (TREE_CODE (expr) != NOP_EXPR) + return true; + + t1 = TREE_TYPE (expr); + t2 = TREE_TYPE (TREE_OPERAND (expr, 0)); + + /* Defer to the folder for non-integral conversions. */ + if (!(INTEGRAL_TYPE_P (t1) && INTEGRAL_TYPE_P (t2))) + return true; + + /* Only fold conversions that preserve both precisions. */ + if (TYPE_PRECISION (t1) == TYPE_PRECISION (t2) + && operand_equal_p (rm_size (t1), rm_size (t2), 0)) + return true; + + return false; + } + + /* Return an expression that does an unchecked conversion of EXPR to TYPE. + If NOTRUNC_P is true, truncation operations should be suppressed. + + Special care is required with (source or target) integral types whose + precision is not equal to their size, to make sure we fetch or assign + the value bits whose location might depend on the endianness, e.g. + + Rmsize : constant := 8; + subtype Int is Integer range 0 .. 2 ** Rmsize - 1; + + type Bit_Array is array (1 .. Rmsize) of Boolean; + pragma Pack (Bit_Array); + + function To_Bit_Array is new Unchecked_Conversion (Int, Bit_Array); + + Value : Int := 2#1000_0001#; + Vbits : Bit_Array := To_Bit_Array (Value); + + we expect the 8 bits at Vbits'Address to always contain Value, while + their original location depends on the endianness, at Value'Address + on a little-endian architecture but not on a big-endian one. + + ??? There is a problematic discrepancy between what is called precision + here (and more generally throughout gigi) for integral types and what is + called precision in the middle-end. In the former case it's the RM size + as given by TYPE_RM_SIZE (or rm_size) whereas it's TYPE_PRECISION in the + latter case, the hitch being that they are not equal when they matter, + that is when the number of value bits is not equal to the type's size: + TYPE_RM_SIZE does give the number of value bits but TYPE_PRECISION is set + to the size. The sole exception are BOOLEAN_TYPEs for which both are 1. + + The consequence is that gigi must duplicate code bridging the gap between + the type's size and its precision that exists for TYPE_PRECISION in the + middle-end, because the latter knows nothing about TYPE_RM_SIZE, and be + wary of transformations applied in the middle-end based on TYPE_PRECISION + because this value doesn't reflect the actual precision for Ada. */ + + tree + unchecked_convert (tree type, tree expr, bool notrunc_p) + { + tree etype = TREE_TYPE (expr); + + /* If the expression is already the right type, we are done. */ + if (etype == type) + return expr; + + /* If both types types are integral just do a normal conversion. + Likewise for a conversion to an unconstrained array. */ + if ((((INTEGRAL_TYPE_P (type) + && !(TREE_CODE (type) == INTEGER_TYPE + && TYPE_VAX_FLOATING_POINT_P (type))) + || (POINTER_TYPE_P (type) && ! TYPE_THIN_POINTER_P (type)) + || (TREE_CODE (type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (type))) + && ((INTEGRAL_TYPE_P (etype) + && !(TREE_CODE (etype) == INTEGER_TYPE + && TYPE_VAX_FLOATING_POINT_P (etype))) + || (POINTER_TYPE_P (etype) && !TYPE_THIN_POINTER_P (etype)) + || (TREE_CODE (etype) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (etype)))) + || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) + { + if (TREE_CODE (etype) == INTEGER_TYPE + && TYPE_BIASED_REPRESENTATION_P (etype)) + { + tree ntype = copy_type (etype); + TYPE_BIASED_REPRESENTATION_P (ntype) = 0; + TYPE_MAIN_VARIANT (ntype) = ntype; + expr = build1 (NOP_EXPR, ntype, expr); + } + + if (TREE_CODE (type) == INTEGER_TYPE + && TYPE_BIASED_REPRESENTATION_P (type)) + { + tree rtype = copy_type (type); + TYPE_BIASED_REPRESENTATION_P (rtype) = 0; + TYPE_MAIN_VARIANT (rtype) = rtype; + expr = convert (rtype, expr); + expr = build1 (NOP_EXPR, type, expr); + } + + /* We have another special case: if we are unchecked converting either + a subtype or a type with limited range into a base type, we need to + ensure that VRP doesn't propagate range information because this + conversion may be done precisely to validate that the object is + within the range it is supposed to have. */ + else if (TREE_CODE (expr) != INTEGER_CST + && TREE_CODE (type) == INTEGER_TYPE && !TREE_TYPE (type) + && ((TREE_CODE (etype) == INTEGER_TYPE && TREE_TYPE (etype)) + || TREE_CODE (etype) == ENUMERAL_TYPE + || TREE_CODE (etype) == BOOLEAN_TYPE)) + { + /* The optimization barrier is a VIEW_CONVERT_EXPR node; moreover, + in order not to be deemed an useless type conversion, it must + be from subtype to base type. + + Therefore we first do the bulk of the conversion to a subtype of + the final type. And this conversion must itself not be deemed + useless if the source type is not a subtype because, otherwise, + the final VIEW_CONVERT_EXPR will be deemed so as well. That's + why we toggle the unsigned flag in this conversion, which is + harmless since the final conversion is only a reinterpretation + of the bit pattern. + + ??? This may raise addressability and/or aliasing issues because + VIEW_CONVERT_EXPR gets gimplified as an lvalue, thus causing the + address of its operand to be taken if it is deemed addressable + and not already in GIMPLE form. */ + tree rtype + = gnat_type_for_mode (TYPE_MODE (type), !TYPE_UNSIGNED (etype)); + rtype = copy_type (rtype); + TYPE_MAIN_VARIANT (rtype) = rtype; + TREE_TYPE (rtype) = type; + expr = convert (rtype, expr); + expr = build1 (VIEW_CONVERT_EXPR, type, expr); + } + + else + expr = convert (type, expr); + } + + /* If we are converting to an integral type whose precision is not equal + to its size, first unchecked convert to a record that contains an + object of the output type. Then extract the field. */ + else if (INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) + && 0 != compare_tree_int (TYPE_RM_SIZE (type), + GET_MODE_BITSIZE (TYPE_MODE (type)))) + { + tree rec_type = make_node (RECORD_TYPE); + tree field = create_field_decl (get_identifier ("OBJ"), type, + rec_type, 1, 0, 0, 0); + + TYPE_FIELDS (rec_type) = field; + layout_type (rec_type); + + expr = unchecked_convert (rec_type, expr, notrunc_p); + expr = build_component_ref (expr, NULL_TREE, field, 0); + } + + /* Similarly if we are converting from an integral type whose precision + is not equal to its size. */ + else if (INTEGRAL_TYPE_P (etype) && TYPE_RM_SIZE (etype) + && 0 != compare_tree_int (TYPE_RM_SIZE (etype), + GET_MODE_BITSIZE (TYPE_MODE (etype)))) + { + tree rec_type = make_node (RECORD_TYPE); + tree field + = create_field_decl (get_identifier ("OBJ"), etype, rec_type, + 1, 0, 0, 0); + + TYPE_FIELDS (rec_type) = field; + layout_type (rec_type); + + expr = gnat_build_constructor (rec_type, build_tree_list (field, expr)); + expr = unchecked_convert (type, expr, notrunc_p); + } + + /* We have a special case when we are converting between two + unconstrained array types. In that case, take the address, + convert the fat pointer types, and dereference. */ + else if (TREE_CODE (etype) == UNCONSTRAINED_ARRAY_TYPE + && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) + expr = build_unary_op (INDIRECT_REF, NULL_TREE, + build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type), + build_unary_op (ADDR_EXPR, NULL_TREE, + expr))); + else + { + expr = maybe_unconstrained_array (expr); + etype = TREE_TYPE (expr); + if (can_fold_for_view_convert_p (expr)) + expr = fold_build1 (VIEW_CONVERT_EXPR, type, expr); + else + expr = build1 (VIEW_CONVERT_EXPR, type, expr); + } + + /* If the result is an integral type whose precision is not equal to its + size, sign- or zero-extend the result. We need not do this if the input + is an integral type of the same precision and signedness or if the output + is a biased type or if both the input and output are unsigned. */ + if (!notrunc_p + && INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) + && !(TREE_CODE (type) == INTEGER_TYPE + && TYPE_BIASED_REPRESENTATION_P (type)) + && 0 != compare_tree_int (TYPE_RM_SIZE (type), + GET_MODE_BITSIZE (TYPE_MODE (type))) + && !(INTEGRAL_TYPE_P (etype) + && TYPE_UNSIGNED (type) == TYPE_UNSIGNED (etype) + && operand_equal_p (TYPE_RM_SIZE (type), + (TYPE_RM_SIZE (etype) != 0 + ? TYPE_RM_SIZE (etype) : TYPE_SIZE (etype)), + 0)) + && !(TYPE_UNSIGNED (type) && TYPE_UNSIGNED (etype))) + { + tree base_type = gnat_type_for_mode (TYPE_MODE (type), + TYPE_UNSIGNED (type)); + tree shift_expr + = convert (base_type, + size_binop (MINUS_EXPR, + bitsize_int + (GET_MODE_BITSIZE (TYPE_MODE (type))), + TYPE_RM_SIZE (type))); + expr + = convert (type, + build_binary_op (RSHIFT_EXPR, base_type, + build_binary_op (LSHIFT_EXPR, base_type, + convert (base_type, expr), + shift_expr), + shift_expr)); + } + + /* An unchecked conversion should never raise Constraint_Error. The code + below assumes that GCC's conversion routines overflow the same way that + the underlying hardware does. This is probably true. In the rare case + when it is false, we can rely on the fact that such conversions are + erroneous anyway. */ + if (TREE_CODE (expr) == INTEGER_CST) + TREE_OVERFLOW (expr) = 0; + + /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR, + show no longer constant. */ + if (TREE_CODE (expr) == VIEW_CONVERT_EXPR + && !operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype), + OEP_ONLY_CONST)) + TREE_CONSTANT (expr) = 0; + + return expr; + } + + /* Return the appropriate GCC tree code for the specified GNAT type, + the latter being a record type as predicated by Is_Record_Type. */ + + enum tree_code + tree_code_for_record_type (Entity_Id gnat_type) + { + Node_Id component_list + = Component_List (Type_Definition + (Declaration_Node + (Implementation_Base_Type (gnat_type)))); + Node_Id component; + + /* Make this a UNION_TYPE unless it's either not an Unchecked_Union or + we have a non-discriminant field outside a variant. In either case, + it's a RECORD_TYPE. */ + + if (!Is_Unchecked_Union (gnat_type)) + return RECORD_TYPE; + + for (component = First_Non_Pragma (Component_Items (component_list)); + Present (component); + component = Next_Non_Pragma (component)) + if (Ekind (Defining_Entity (component)) == E_Component) + return RECORD_TYPE; + + return UNION_TYPE; + } + + /* Return true if GNU_TYPE is suitable as the type of a non-aliased + component of an aggregate type. */ + + bool + type_for_nonaliased_component_p (tree gnu_type) + { + /* If the type is passed by reference, we may have pointers to the + component so it cannot be made non-aliased. */ + if (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type)) + return false; + + /* We used to say that any component of aggregate type is aliased + because the front-end may take 'Reference of it. The front-end + has been enhanced in the meantime so as to use a renaming instead + in most cases, but the back-end can probably take the address of + such a component too so we go for the conservative stance. + + For instance, we might need the address of any array type, even + if normally passed by copy, to construct a fat pointer if the + component is used as an actual for an unconstrained formal. + + Likewise for record types: even if a specific record subtype is + passed by copy, the parent type might be passed by ref (e.g. if + it's of variable size) and we might take the address of a child + component to pass to a parent formal. We have no way to check + for such conditions here. */ + if (AGGREGATE_TYPE_P (gnu_type)) + return false; + + return true; + } + + /* Perform final processing on global variables. */ + + void + gnat_write_global_declarations (void) + { + /* Proceed to optimize and emit assembly. + FIXME: shouldn't be the front end's responsibility to call this. */ + cgraph_optimize (); + + /* Emit debug info for all global declarations. */ + emit_debug_global_declarations (VEC_address (tree, global_decls), + VEC_length (tree, global_decls)); + } + + /* ************************************************************************ + * * GCC builtins support * + * ************************************************************************ */ + + /* The general scheme is fairly simple: + + For each builtin function/type to be declared, gnat_install_builtins calls + internal facilities which eventually get to gnat_push_decl, which in turn + tracks the so declared builtin function decls in the 'builtin_decls' global + datastructure. When an Intrinsic subprogram declaration is processed, we + search this global datastructure to retrieve the associated BUILT_IN DECL + node. */ + + /* Search the chain of currently available builtin declarations for a node + corresponding to function NAME (an IDENTIFIER_NODE). Return the first node + found, if any, or NULL_TREE otherwise. */ + tree + builtin_decl_for (tree name) + { + unsigned i; + tree decl; + + for (i = 0; VEC_iterate(tree, builtin_decls, i, decl); i++) + if (DECL_NAME (decl) == name) + return decl; + + return NULL_TREE; + } + + /* The code below eventually exposes gnat_install_builtins, which declares + the builtin types and functions we might need, either internally or as + user accessible facilities. + + ??? This is a first implementation shot, still in rough shape. It is + heavily inspired from the "C" family implementation, with chunks copied + verbatim from there. + + Two obvious TODO candidates are + o Use a more efficient name/decl mapping scheme + o Devise a middle-end infrastructure to avoid having to copy + pieces between front-ends. */ + + /* ----------------------------------------------------------------------- * + * BUILTIN ELEMENTARY TYPES * + * ----------------------------------------------------------------------- */ + + /* Standard data types to be used in builtin argument declarations. */ + + enum c_tree_index + { + CTI_SIGNED_SIZE_TYPE, /* For format checking only. */ + CTI_STRING_TYPE, + CTI_CONST_STRING_TYPE, + + CTI_MAX + }; + + static tree c_global_trees[CTI_MAX]; + + #define signed_size_type_node c_global_trees[CTI_SIGNED_SIZE_TYPE] + #define string_type_node c_global_trees[CTI_STRING_TYPE] + #define const_string_type_node c_global_trees[CTI_CONST_STRING_TYPE] + + /* ??? In addition some attribute handlers, we currently don't support a + (small) number of builtin-types, which in turns inhibits support for a + number of builtin functions. */ + #define wint_type_node void_type_node + #define intmax_type_node void_type_node + #define uintmax_type_node void_type_node + + /* Build the void_list_node (void_type_node having been created). */ + + static tree + build_void_list_node (void) + { + tree t = build_tree_list (NULL_TREE, void_type_node); + return t; + } + + /* Used to help initialize the builtin-types.def table. When a type of + the correct size doesn't exist, use error_mark_node instead of NULL. + The later results in segfaults even when a decl using the type doesn't + get invoked. */ + + static tree + builtin_type_for_size (int size, bool unsignedp) + { + tree type = lang_hooks.types.type_for_size (size, unsignedp); + return type ? type : error_mark_node; + } + + /* Build/push the elementary type decls that builtin functions/types + will need. */ + + static void + install_builtin_elementary_types (void) + { + signed_size_type_node = size_type_node; + pid_type_node = integer_type_node; + void_list_node = build_void_list_node (); + + string_type_node = build_pointer_type (char_type_node); + const_string_type_node + = build_pointer_type (build_qualified_type + (char_type_node, TYPE_QUAL_CONST)); + } + + /* ----------------------------------------------------------------------- * + * BUILTIN FUNCTION TYPES * + * ----------------------------------------------------------------------- */ + + /* Now, builtin function types per se. */ + + enum c_builtin_type + { + #define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME, + #define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME, + #define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME, + #define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME, + #define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, + #define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, + #define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME, + #define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME, + #define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME, + #define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME, + #define DEF_FUNCTION_TYPE_VAR_1(NAME, RETURN, ARG1) NAME, + #define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME, + #define DEF_FUNCTION_TYPE_VAR_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, + #define DEF_FUNCTION_TYPE_VAR_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, + #define DEF_FUNCTION_TYPE_VAR_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG6) \ + NAME, + #define DEF_POINTER_TYPE(NAME, TYPE) NAME, + #include "builtin-types.def" + #undef DEF_PRIMITIVE_TYPE + #undef DEF_FUNCTION_TYPE_0 + #undef DEF_FUNCTION_TYPE_1 + #undef DEF_FUNCTION_TYPE_2 + #undef DEF_FUNCTION_TYPE_3 + #undef DEF_FUNCTION_TYPE_4 + #undef DEF_FUNCTION_TYPE_5 + #undef DEF_FUNCTION_TYPE_6 + #undef DEF_FUNCTION_TYPE_7 + #undef DEF_FUNCTION_TYPE_VAR_0 + #undef DEF_FUNCTION_TYPE_VAR_1 + #undef DEF_FUNCTION_TYPE_VAR_2 + #undef DEF_FUNCTION_TYPE_VAR_3 + #undef DEF_FUNCTION_TYPE_VAR_4 + #undef DEF_FUNCTION_TYPE_VAR_5 + #undef DEF_POINTER_TYPE + BT_LAST + }; + + typedef enum c_builtin_type builtin_type; + + /* A temporary array used in communication with def_fn_type. */ + static GTY(()) tree builtin_types[(int) BT_LAST + 1]; + + /* A helper function for install_builtin_types. Build function type + for DEF with return type RET and N arguments. If VAR is true, then the + function should be variadic after those N arguments. + + Takes special care not to ICE if any of the types involved are + error_mark_node, which indicates that said type is not in fact available + (see builtin_type_for_size). In which case the function type as a whole + should be error_mark_node. */ + + static void + def_fn_type (builtin_type def, builtin_type ret, bool var, int n, ...) + { + tree args = NULL, t; + va_list list; + int i; + + va_start (list, n); + for (i = 0; i < n; ++i) + { + builtin_type a = va_arg (list, builtin_type); + t = builtin_types[a]; + if (t == error_mark_node) + goto egress; + args = tree_cons (NULL_TREE, t, args); + } + va_end (list); + + args = nreverse (args); + if (!var) + args = chainon (args, void_list_node); + + t = builtin_types[ret]; + if (t == error_mark_node) + goto egress; + t = build_function_type (t, args); + + egress: + builtin_types[def] = t; + } + + /* Build the builtin function types and install them in the builtin_types + array for later use in builtin function decls. */ + + static void + install_builtin_function_types (void) + { + tree va_list_ref_type_node; + tree va_list_arg_type_node; + + if (TREE_CODE (va_list_type_node) == ARRAY_TYPE) + { + va_list_arg_type_node = va_list_ref_type_node = + build_pointer_type (TREE_TYPE (va_list_type_node)); + } + else + { + va_list_arg_type_node = va_list_type_node; + va_list_ref_type_node = build_reference_type (va_list_type_node); + } + + #define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \ + builtin_types[ENUM] = VALUE; + #define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \ + def_fn_type (ENUM, RETURN, 0, 0); + #define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \ + def_fn_type (ENUM, RETURN, 0, 1, ARG1); + #define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \ + def_fn_type (ENUM, RETURN, 0, 2, ARG1, ARG2); + #define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ + def_fn_type (ENUM, RETURN, 0, 3, ARG1, ARG2, ARG3); + #define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ + def_fn_type (ENUM, RETURN, 0, 4, ARG1, ARG2, ARG3, ARG4); + #define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ + def_fn_type (ENUM, RETURN, 0, 5, ARG1, ARG2, ARG3, ARG4, ARG5); + #define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6) \ + def_fn_type (ENUM, RETURN, 0, 6, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6); + #define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7) \ + def_fn_type (ENUM, RETURN, 0, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7); + #define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \ + def_fn_type (ENUM, RETURN, 1, 0); + #define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \ + def_fn_type (ENUM, RETURN, 1, 1, ARG1); + #define DEF_FUNCTION_TYPE_VAR_2(ENUM, RETURN, ARG1, ARG2) \ + def_fn_type (ENUM, RETURN, 1, 2, ARG1, ARG2); + #define DEF_FUNCTION_TYPE_VAR_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ + def_fn_type (ENUM, RETURN, 1, 3, ARG1, ARG2, ARG3); + #define DEF_FUNCTION_TYPE_VAR_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ + def_fn_type (ENUM, RETURN, 1, 4, ARG1, ARG2, ARG3, ARG4); + #define DEF_FUNCTION_TYPE_VAR_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ + def_fn_type (ENUM, RETURN, 1, 5, ARG1, ARG2, ARG3, ARG4, ARG5); + #define DEF_POINTER_TYPE(ENUM, TYPE) \ + builtin_types[(int) ENUM] = build_pointer_type (builtin_types[(int) TYPE]); + + #include "builtin-types.def" + + #undef DEF_PRIMITIVE_TYPE + #undef DEF_FUNCTION_TYPE_1 + #undef DEF_FUNCTION_TYPE_2 + #undef DEF_FUNCTION_TYPE_3 + #undef DEF_FUNCTION_TYPE_4 + #undef DEF_FUNCTION_TYPE_5 + #undef DEF_FUNCTION_TYPE_6 + #undef DEF_FUNCTION_TYPE_VAR_0 + #undef DEF_FUNCTION_TYPE_VAR_1 + #undef DEF_FUNCTION_TYPE_VAR_2 + #undef DEF_FUNCTION_TYPE_VAR_3 + #undef DEF_FUNCTION_TYPE_VAR_4 + #undef DEF_FUNCTION_TYPE_VAR_5 + #undef DEF_POINTER_TYPE + builtin_types[(int) BT_LAST] = NULL_TREE; + } + + /* ----------------------------------------------------------------------- * + * BUILTIN ATTRIBUTES * + * ----------------------------------------------------------------------- */ + + enum built_in_attribute + { + #define DEF_ATTR_NULL_TREE(ENUM) ENUM, + #define DEF_ATTR_INT(ENUM, VALUE) ENUM, + #define DEF_ATTR_IDENT(ENUM, STRING) ENUM, + #define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) ENUM, + #include "builtin-attrs.def" + #undef DEF_ATTR_NULL_TREE + #undef DEF_ATTR_INT + #undef DEF_ATTR_IDENT + #undef DEF_ATTR_TREE_LIST + ATTR_LAST + }; + + static GTY(()) tree built_in_attributes[(int) ATTR_LAST]; + + static void + install_builtin_attributes (void) + { + /* Fill in the built_in_attributes array. */ + #define DEF_ATTR_NULL_TREE(ENUM) \ + built_in_attributes[(int) ENUM] = NULL_TREE; + #define DEF_ATTR_INT(ENUM, VALUE) \ + built_in_attributes[(int) ENUM] = build_int_cst (NULL_TREE, VALUE); + #define DEF_ATTR_IDENT(ENUM, STRING) \ + built_in_attributes[(int) ENUM] = get_identifier (STRING); + #define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) \ + built_in_attributes[(int) ENUM] \ + = tree_cons (built_in_attributes[(int) PURPOSE], \ + built_in_attributes[(int) VALUE], \ + built_in_attributes[(int) CHAIN]); + #include "builtin-attrs.def" + #undef DEF_ATTR_NULL_TREE + #undef DEF_ATTR_INT + #undef DEF_ATTR_IDENT + #undef DEF_ATTR_TREE_LIST + } + + /* Handle a "const" attribute; arguments as in + struct attribute_spec.handler. */ + + static tree + handle_const_attribute (tree *node, tree ARG_UNUSED (name), + tree ARG_UNUSED (args), int ARG_UNUSED (flags), + bool *no_add_attrs) + { + if (TREE_CODE (*node) == FUNCTION_DECL) + TREE_READONLY (*node) = 1; + else + *no_add_attrs = true; + + return NULL_TREE; + } + + /* Handle a "nothrow" attribute; arguments as in + struct attribute_spec.handler. */ + + static tree + handle_nothrow_attribute (tree *node, tree ARG_UNUSED (name), + tree ARG_UNUSED (args), int ARG_UNUSED (flags), + bool *no_add_attrs) + { + if (TREE_CODE (*node) == FUNCTION_DECL) + TREE_NOTHROW (*node) = 1; + else + *no_add_attrs = true; + + return NULL_TREE; + } + + /* Handle a "pure" attribute; arguments as in + struct attribute_spec.handler. */ + + static tree + handle_pure_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) + { + if (TREE_CODE (*node) == FUNCTION_DECL) + DECL_PURE_P (*node) = 1; + /* ??? TODO: Support types. */ + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; + } + + /* Handle a "no vops" attribute; arguments as in + struct attribute_spec.handler. */ + + static tree + handle_novops_attribute (tree *node, tree ARG_UNUSED (name), + tree ARG_UNUSED (args), int ARG_UNUSED (flags), + bool *ARG_UNUSED (no_add_attrs)) + { + gcc_assert (TREE_CODE (*node) == FUNCTION_DECL); + DECL_IS_NOVOPS (*node) = 1; + return NULL_TREE; + } + + /* Helper for nonnull attribute handling; fetch the operand number + from the attribute argument list. */ + + static bool + get_nonnull_operand (tree arg_num_expr, unsigned HOST_WIDE_INT *valp) + { + /* Verify the arg number is a constant. */ + if (TREE_CODE (arg_num_expr) != INTEGER_CST + || TREE_INT_CST_HIGH (arg_num_expr) != 0) + return false; + + *valp = TREE_INT_CST_LOW (arg_num_expr); + return true; + } + + /* Handle the "nonnull" attribute. */ + static tree + handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name), + tree args, int ARG_UNUSED (flags), + bool *no_add_attrs) + { + tree type = *node; + unsigned HOST_WIDE_INT attr_arg_num; + + /* If no arguments are specified, all pointer arguments should be + non-null. Verify a full prototype is given so that the arguments + will have the correct types when we actually check them later. */ + if (!args) + { + if (!TYPE_ARG_TYPES (type)) + { + error ("nonnull attribute without arguments on a non-prototype"); + *no_add_attrs = true; + } + return NULL_TREE; + } + + /* Argument list specified. Verify that each argument number references + a pointer argument. */ + for (attr_arg_num = 1; args; args = TREE_CHAIN (args)) + { + tree argument; + unsigned HOST_WIDE_INT arg_num = 0, ck_num; + + if (!get_nonnull_operand (TREE_VALUE (args), &arg_num)) + { + error ("nonnull argument has invalid operand number (argument %lu)", + (unsigned long) attr_arg_num); + *no_add_attrs = true; + return NULL_TREE; + } + + argument = TYPE_ARG_TYPES (type); + if (argument) + { + for (ck_num = 1; ; ck_num++) + { + if (!argument || ck_num == arg_num) + break; + argument = TREE_CHAIN (argument); + } + + if (!argument + || TREE_CODE (TREE_VALUE (argument)) == VOID_TYPE) + { + error ("nonnull argument with out-of-range operand number (argument %lu, operand %lu)", + (unsigned long) attr_arg_num, (unsigned long) arg_num); + *no_add_attrs = true; + return NULL_TREE; + } + + if (TREE_CODE (TREE_VALUE (argument)) != POINTER_TYPE) + { + error ("nonnull argument references non-pointer operand (argument %lu, operand %lu)", + (unsigned long) attr_arg_num, (unsigned long) arg_num); + *no_add_attrs = true; + return NULL_TREE; + } + } + } + + return NULL_TREE; + } + + /* Handle a "sentinel" attribute. */ + + static tree + handle_sentinel_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), bool *no_add_attrs) + { + tree params = TYPE_ARG_TYPES (*node); + + if (!params) + { + warning (OPT_Wattributes, + "%qE attribute requires prototypes with named arguments", name); + *no_add_attrs = true; + } + else + { + while (TREE_CHAIN (params)) + params = TREE_CHAIN (params); + + if (VOID_TYPE_P (TREE_VALUE (params))) + { + warning (OPT_Wattributes, + "%qE attribute only applies to variadic functions", name); + *no_add_attrs = true; + } + } + + if (args) + { + tree position = TREE_VALUE (args); + + if (TREE_CODE (position) != INTEGER_CST) + { + warning (0, "requested position is not an integer constant"); + *no_add_attrs = true; + } + else + { + if (tree_int_cst_lt (position, integer_zero_node)) + { + warning (0, "requested position is less than zero"); + *no_add_attrs = true; + } + } + } + + return NULL_TREE; + } + + /* Handle a "noreturn" attribute; arguments as in + struct attribute_spec.handler. */ + + static tree + handle_noreturn_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) + { + tree type = TREE_TYPE (*node); + + /* See FIXME comment in c_common_attribute_table. */ + if (TREE_CODE (*node) == FUNCTION_DECL) + TREE_THIS_VOLATILE (*node) = 1; + else if (TREE_CODE (type) == POINTER_TYPE + && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) + TREE_TYPE (*node) + = build_pointer_type + (build_type_variant (TREE_TYPE (type), + TYPE_READONLY (TREE_TYPE (type)), 1)); + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; + } + + /* Handle a "malloc" attribute; arguments as in + struct attribute_spec.handler. */ + + static tree + handle_malloc_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) + { + if (TREE_CODE (*node) == FUNCTION_DECL + && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (*node)))) + DECL_IS_MALLOC (*node) = 1; + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; + } + + /* Fake handler for attributes we don't properly support. */ + + tree + fake_attribute_handler (tree * ARG_UNUSED (node), + tree ARG_UNUSED (name), + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), + bool * ARG_UNUSED (no_add_attrs)) + { + return NULL_TREE; + } + + /* Handle a "type_generic" attribute. */ + + static tree + handle_type_generic_attribute (tree *node, tree ARG_UNUSED (name), + tree ARG_UNUSED (args), int ARG_UNUSED (flags), + bool * ARG_UNUSED (no_add_attrs)) + { + tree params; + + /* Ensure we have a function type. */ + gcc_assert (TREE_CODE (*node) == FUNCTION_TYPE); + + params = TYPE_ARG_TYPES (*node); + while (params && ! VOID_TYPE_P (TREE_VALUE (params))) + params = TREE_CHAIN (params); + + /* Ensure we have a variadic function. */ + gcc_assert (!params); + + return NULL_TREE; + } + + /* ----------------------------------------------------------------------- * + * BUILTIN FUNCTIONS * + * ----------------------------------------------------------------------- */ + + /* Worker for DEF_BUILTIN. Possibly define a builtin function with one or two + names. Does not declare a non-__builtin_ function if flag_no_builtin, or + if nonansi_p and flag_no_nonansi_builtin. */ + + static void + def_builtin_1 (enum built_in_function fncode, + const char *name, + enum built_in_class fnclass, + tree fntype, tree libtype, + bool both_p, bool fallback_p, + bool nonansi_p ATTRIBUTE_UNUSED, + tree fnattrs, bool implicit_p) + { + tree decl; + const char *libname; + + /* Preserve an already installed decl. It most likely was setup in advance + (e.g. as part of the internal builtins) for specific reasons. */ + if (built_in_decls[(int) fncode] != NULL_TREE) + return; + + gcc_assert ((!both_p && !fallback_p) + || !strncmp (name, "__builtin_", + strlen ("__builtin_"))); + + libname = name + strlen ("__builtin_"); + decl = add_builtin_function (name, fntype, fncode, fnclass, + (fallback_p ? libname : NULL), + fnattrs); + if (both_p) + /* ??? This is normally further controlled by command-line options + like -fno-builtin, but we don't have them for Ada. */ + add_builtin_function (libname, libtype, fncode, fnclass, + NULL, fnattrs); + + built_in_decls[(int) fncode] = decl; + if (implicit_p) + implicit_built_in_decls[(int) fncode] = decl; + } + + static int flag_isoc94 = 0; + static int flag_isoc99 = 0; + + /* Install what the common builtins.def offers. */ + + static void + install_builtin_functions (void) + { + #define DEF_BUILTIN(ENUM, NAME, CLASS, TYPE, LIBTYPE, BOTH_P, FALLBACK_P, \ + NONANSI_P, ATTRS, IMPLICIT, COND) \ + if (NAME && COND) \ + def_builtin_1 (ENUM, NAME, CLASS, \ + builtin_types[(int) TYPE], \ + builtin_types[(int) LIBTYPE], \ + BOTH_P, FALLBACK_P, NONANSI_P, \ + built_in_attributes[(int) ATTRS], IMPLICIT); + #include "builtins.def" + #undef DEF_BUILTIN + } + + /* ----------------------------------------------------------------------- * + * BUILTIN FUNCTIONS * + * ----------------------------------------------------------------------- */ + + /* Install the builtin functions we might need. */ + + void + gnat_install_builtins (void) + { + install_builtin_elementary_types (); + install_builtin_function_types (); + install_builtin_attributes (); + + /* Install builtins used by generic middle-end pieces first. Some of these + know about internal specificities and control attributes accordingly, for + instance __builtin_alloca vs no-throw and -fstack-check. We will ignore + the generic definition from builtins.def. */ + build_common_builtin_nodes (); + + /* Now, install the target specific builtins, such as the AltiVec family on + ppc, and the common set as exposed by builtins.def. */ + targetm.init_builtins (); + install_builtin_functions (); + } + + #include "gt-ada-utils.h" + #include "gtype-ada.h" diff -Nrcpad gcc-4.3.3/gcc/ada/gcc-interface/utils2.c gcc-4.4.0/gcc/ada/gcc-interface/utils2.c *** gcc-4.3.3/gcc/ada/gcc-interface/utils2.c Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gcc-interface/utils2.c Sun Nov 9 09:50:02 2008 *************** *** 0 **** --- 1,2256 ---- + /**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * U T I L S 2 * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2008, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + #include "config.h" + #include "system.h" + #include "coretypes.h" + #include "tm.h" + #include "tree.h" + #include "rtl.h" + #include "ggc.h" + #include "flags.h" + #include "output.h" + #include "ada.h" + #include "types.h" + #include "atree.h" + #include "stringt.h" + #include "namet.h" + #include "uintp.h" + #include "fe.h" + #include "elists.h" + #include "nlists.h" + #include "sinfo.h" + #include "einfo.h" + #include "ada-tree.h" + #include "gigi.h" + #include "snames.h" + + static tree find_common_type (tree, tree); + static bool contains_save_expr_p (tree); + static tree contains_null_expr (tree); + static tree compare_arrays (tree, tree, tree); + static tree nonbinary_modular_operation (enum tree_code, tree, tree, tree); + static tree build_simple_component_ref (tree, tree, tree, bool); + + /* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical + operation. + + This preparation consists of taking the ordinary representation of + an expression expr and producing a valid tree boolean expression + describing whether expr is nonzero. We could simply always do + + build_binary_op (NE_EXPR, expr, integer_zero_node, 1), + + but we optimize comparisons, &&, ||, and !. + + The resulting type should always be the same as the input type. + This function is simpler than the corresponding C version since + the only possible operands will be things of Boolean type. */ + + tree + gnat_truthvalue_conversion (tree expr) + { + tree type = TREE_TYPE (expr); + + switch (TREE_CODE (expr)) + { + case EQ_EXPR: case NE_EXPR: case LE_EXPR: case GE_EXPR: + case LT_EXPR: case GT_EXPR: + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: + case ERROR_MARK: + return expr; + + case INTEGER_CST: + return (integer_zerop (expr) + ? build_int_cst (type, 0) + : build_int_cst (type, 1)); + + case REAL_CST: + return (real_zerop (expr) + ? fold_convert (type, integer_zero_node) + : fold_convert (type, integer_one_node)); + + case COND_EXPR: + /* Distribute the conversion into the arms of a COND_EXPR. */ + { + tree arg1 = gnat_truthvalue_conversion (TREE_OPERAND (expr, 1)); + tree arg2 = gnat_truthvalue_conversion (TREE_OPERAND (expr, 2)); + return fold_build3 (COND_EXPR, type, TREE_OPERAND (expr, 0), + arg1, arg2); + } + + default: + return build_binary_op (NE_EXPR, type, expr, + fold_convert (type, integer_zero_node)); + } + } + + /* Return the base type of TYPE. */ + + tree + get_base_type (tree type) + { + if (TREE_CODE (type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (type)) + type = TREE_TYPE (TYPE_FIELDS (type)); + + while (TREE_TYPE (type) + && (TREE_CODE (type) == INTEGER_TYPE + || TREE_CODE (type) == REAL_TYPE)) + type = TREE_TYPE (type); + + return type; + } + + /* EXP is a GCC tree representing an address. See if we can find how + strictly the object at that address is aligned. Return that alignment + in bits. If we don't know anything about the alignment, return 0. */ + + unsigned int + known_alignment (tree exp) + { + unsigned int this_alignment; + unsigned int lhs, rhs; + + switch (TREE_CODE (exp)) + { + CASE_CONVERT: + case VIEW_CONVERT_EXPR: + case NON_LVALUE_EXPR: + /* Conversions between pointers and integers don't change the alignment + of the underlying object. */ + this_alignment = known_alignment (TREE_OPERAND (exp, 0)); + break; + + case COMPOUND_EXPR: + /* The value of a COMPOUND_EXPR is that of it's second operand. */ + this_alignment = known_alignment (TREE_OPERAND (exp, 1)); + break; + + case PLUS_EXPR: + case MINUS_EXPR: + /* If two address are added, the alignment of the result is the + minimum of the two alignments. */ + lhs = known_alignment (TREE_OPERAND (exp, 0)); + rhs = known_alignment (TREE_OPERAND (exp, 1)); + this_alignment = MIN (lhs, rhs); + break; + + case POINTER_PLUS_EXPR: + lhs = known_alignment (TREE_OPERAND (exp, 0)); + rhs = known_alignment (TREE_OPERAND (exp, 1)); + /* If we don't know the alignment of the offset, we assume that + of the base. */ + if (rhs == 0) + this_alignment = lhs; + else + this_alignment = MIN (lhs, rhs); + break; + + case COND_EXPR: + /* If there is a choice between two values, use the smallest one. */ + lhs = known_alignment (TREE_OPERAND (exp, 1)); + rhs = known_alignment (TREE_OPERAND (exp, 2)); + this_alignment = MIN (lhs, rhs); + break; + + case INTEGER_CST: + { + unsigned HOST_WIDE_INT c = TREE_INT_CST_LOW (exp); + /* The first part of this represents the lowest bit in the constant, + but it is originally in bytes, not bits. */ + this_alignment = MIN (BITS_PER_UNIT * (c & -c), BIGGEST_ALIGNMENT); + } + break; + + case MULT_EXPR: + /* If we know the alignment of just one side, use it. Otherwise, + use the product of the alignments. */ + lhs = known_alignment (TREE_OPERAND (exp, 0)); + rhs = known_alignment (TREE_OPERAND (exp, 1)); + + if (lhs == 0) + this_alignment = rhs; + else if (rhs == 0) + this_alignment = lhs; + else + this_alignment = MIN (lhs * rhs, BIGGEST_ALIGNMENT); + break; + + case BIT_AND_EXPR: + /* A bit-and expression is as aligned as the maximum alignment of the + operands. We typically get here for a complex lhs and a constant + negative power of two on the rhs to force an explicit alignment, so + don't bother looking at the lhs. */ + this_alignment = known_alignment (TREE_OPERAND (exp, 1)); + break; + + case ADDR_EXPR: + this_alignment = expr_align (TREE_OPERAND (exp, 0)); + break; + + default: + /* For other pointer expressions, we assume that the pointed-to object + is at least as aligned as the pointed-to type. Beware that we can + have a dummy type here (e.g. a Taft Amendment type), for which the + alignment is meaningless and should be ignored. */ + if (POINTER_TYPE_P (TREE_TYPE (exp)) + && !TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp)))) + this_alignment = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (exp))); + else + this_alignment = 0; + break; + } + + return this_alignment; + } + + /* We have a comparison or assignment operation on two types, T1 and T2, which + are either both array types or both record types. T1 is assumed to be for + the left hand side operand, and T2 for the right hand side. Return the + type that both operands should be converted to for the operation, if any. + Otherwise return zero. */ + + static tree + find_common_type (tree t1, tree t2) + { + /* ??? As of today, various constructs lead here with types of different + sizes even when both constants (e.g. tagged types, packable vs regular + component types, padded vs unpadded types, ...). While some of these + would better be handled upstream (types should be made consistent before + calling into build_binary_op), some others are really expected and we + have to be careful. */ + + /* We must prevent writing more than what the target may hold if this is for + an assignment and the case of tagged types is handled in build_binary_op + so use the lhs type if it is known to be smaller, or of constant size and + the rhs type is not, whatever the modes. We also force t1 in case of + constant size equality to minimize occurrences of view conversions on the + lhs of assignments. */ + if (TREE_CONSTANT (TYPE_SIZE (t1)) + && (!TREE_CONSTANT (TYPE_SIZE (t2)) + || !tree_int_cst_lt (TYPE_SIZE (t2), TYPE_SIZE (t1)))) + return t1; + + /* Otherwise, if the lhs type is non-BLKmode, use it. Note that we know + that we will not have any alignment problems since, if we did, the + non-BLKmode type could not have been used. */ + if (TYPE_MODE (t1) != BLKmode) + return t1; + + /* If the rhs type is of constant size, use it whatever the modes. At + this point it is known to be smaller, or of constant size and the + lhs type is not. */ + if (TREE_CONSTANT (TYPE_SIZE (t2))) + return t2; + + /* Otherwise, if the rhs type is non-BLKmode, use it. */ + if (TYPE_MODE (t2) != BLKmode) + return t2; + + /* In this case, both types have variable size and BLKmode. It's + probably best to leave the "type mismatch" because changing it + could cause a bad self-referential reference. */ + return NULL_TREE; + } + + /* See if EXP contains a SAVE_EXPR in a position where we would + normally put it. + + ??? This is a real kludge, but is probably the best approach short + of some very general solution. */ + + static bool + contains_save_expr_p (tree exp) + { + switch (TREE_CODE (exp)) + { + case SAVE_EXPR: + return true; + + case ADDR_EXPR: case INDIRECT_REF: + case COMPONENT_REF: + CASE_CONVERT: case VIEW_CONVERT_EXPR: + return contains_save_expr_p (TREE_OPERAND (exp, 0)); + + case CONSTRUCTOR: + { + tree value; + unsigned HOST_WIDE_INT ix; + + FOR_EACH_CONSTRUCTOR_VALUE (CONSTRUCTOR_ELTS (exp), ix, value) + if (contains_save_expr_p (value)) + return true; + return false; + } + + default: + return false; + } + } + + /* See if EXP contains a NULL_EXPR in an expression we use for sizes. Return + it if so. This is used to detect types whose sizes involve computations + that are known to raise Constraint_Error. */ + + static tree + contains_null_expr (tree exp) + { + tree tem; + + if (TREE_CODE (exp) == NULL_EXPR) + return exp; + + switch (TREE_CODE_CLASS (TREE_CODE (exp))) + { + case tcc_unary: + return contains_null_expr (TREE_OPERAND (exp, 0)); + + case tcc_comparison: + case tcc_binary: + tem = contains_null_expr (TREE_OPERAND (exp, 0)); + if (tem) + return tem; + + return contains_null_expr (TREE_OPERAND (exp, 1)); + + case tcc_expression: + switch (TREE_CODE (exp)) + { + case SAVE_EXPR: + return contains_null_expr (TREE_OPERAND (exp, 0)); + + case COND_EXPR: + tem = contains_null_expr (TREE_OPERAND (exp, 0)); + if (tem) + return tem; + + tem = contains_null_expr (TREE_OPERAND (exp, 1)); + if (tem) + return tem; + + return contains_null_expr (TREE_OPERAND (exp, 2)); + + default: + return 0; + } + + default: + return 0; + } + } + + /* Return an expression tree representing an equality comparison of + A1 and A2, two objects of ARRAY_TYPE. The returned expression should + be of type RESULT_TYPE + + Two arrays are equal in one of two ways: (1) if both have zero length + in some dimension (not necessarily the same dimension) or (2) if the + lengths in each dimension are equal and the data is equal. We perform the + length tests in as efficient a manner as possible. */ + + static tree + compare_arrays (tree result_type, tree a1, tree a2) + { + tree t1 = TREE_TYPE (a1); + tree t2 = TREE_TYPE (a2); + tree result = convert (result_type, integer_one_node); + tree a1_is_null = convert (result_type, integer_zero_node); + tree a2_is_null = convert (result_type, integer_zero_node); + bool length_zero_p = false; + + /* Process each dimension separately and compare the lengths. If any + dimension has a size known to be zero, set SIZE_ZERO_P to 1 to + suppress the comparison of the data. */ + while (TREE_CODE (t1) == ARRAY_TYPE && TREE_CODE (t2) == ARRAY_TYPE) + { + tree lb1 = TYPE_MIN_VALUE (TYPE_DOMAIN (t1)); + tree ub1 = TYPE_MAX_VALUE (TYPE_DOMAIN (t1)); + tree lb2 = TYPE_MIN_VALUE (TYPE_DOMAIN (t2)); + tree ub2 = TYPE_MAX_VALUE (TYPE_DOMAIN (t2)); + tree bt = get_base_type (TREE_TYPE (lb1)); + tree length1 = fold_build2 (MINUS_EXPR, bt, ub1, lb1); + tree length2 = fold_build2 (MINUS_EXPR, bt, ub2, lb2); + tree nbt; + tree tem; + tree comparison, this_a1_is_null, this_a2_is_null; + + /* If the length of the first array is a constant, swap our operands + unless the length of the second array is the constant zero. + Note that we have set the `length' values to the length - 1. */ + if (TREE_CODE (length1) == INTEGER_CST + && !integer_zerop (fold_build2 (PLUS_EXPR, bt, length2, + convert (bt, integer_one_node)))) + { + tem = a1, a1 = a2, a2 = tem; + tem = t1, t1 = t2, t2 = tem; + tem = lb1, lb1 = lb2, lb2 = tem; + tem = ub1, ub1 = ub2, ub2 = tem; + tem = length1, length1 = length2, length2 = tem; + tem = a1_is_null, a1_is_null = a2_is_null, a2_is_null = tem; + } + + /* If the length of this dimension in the second array is the constant + zero, we can just go inside the original bounds for the first + array and see if last < first. */ + if (integer_zerop (fold_build2 (PLUS_EXPR, bt, length2, + convert (bt, integer_one_node)))) + { + tree ub = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); + tree lb = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); + + comparison = build_binary_op (LT_EXPR, result_type, ub, lb); + comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1); + length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1); + + length_zero_p = true; + this_a1_is_null = comparison; + this_a2_is_null = convert (result_type, integer_one_node); + } + + /* If the length is some other constant value, we know that the + this dimension in the first array cannot be superflat, so we + can just use its length from the actual stored bounds. */ + else if (TREE_CODE (length2) == INTEGER_CST) + { + ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); + lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); + ub2 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2))); + lb2 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2))); + nbt = get_base_type (TREE_TYPE (ub1)); + + comparison + = build_binary_op (EQ_EXPR, result_type, + build_binary_op (MINUS_EXPR, nbt, ub1, lb1), + build_binary_op (MINUS_EXPR, nbt, ub2, lb2)); + + /* Note that we know that UB2 and LB2 are constant and hence + cannot contain a PLACEHOLDER_EXPR. */ + + comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1); + length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1); + + this_a1_is_null = build_binary_op (LT_EXPR, result_type, ub1, lb1); + this_a2_is_null = convert (result_type, integer_zero_node); + } + + /* Otherwise compare the computed lengths. */ + else + { + length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1); + length2 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length2, a2); + + comparison + = build_binary_op (EQ_EXPR, result_type, length1, length2); + + this_a1_is_null + = build_binary_op (LT_EXPR, result_type, length1, + convert (bt, integer_zero_node)); + this_a2_is_null + = build_binary_op (LT_EXPR, result_type, length2, + convert (bt, integer_zero_node)); + } + + result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, + result, comparison); + + a1_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type, + this_a1_is_null, a1_is_null); + a2_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type, + this_a2_is_null, a2_is_null); + + t1 = TREE_TYPE (t1); + t2 = TREE_TYPE (t2); + } + + /* Unless the size of some bound is known to be zero, compare the + data in the array. */ + if (!length_zero_p) + { + tree type = find_common_type (TREE_TYPE (a1), TREE_TYPE (a2)); + + if (type) + a1 = convert (type, a1), a2 = convert (type, a2); + + result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result, + fold_build2 (EQ_EXPR, result_type, a1, a2)); + + } + + /* The result is also true if both sizes are zero. */ + result = build_binary_op (TRUTH_ORIF_EXPR, result_type, + build_binary_op (TRUTH_ANDIF_EXPR, result_type, + a1_is_null, a2_is_null), + result); + + /* If either operand contains SAVE_EXPRs, they have to be evaluated before + starting the comparison above since the place it would be otherwise + evaluated would be wrong. */ + + if (contains_save_expr_p (a1)) + result = build2 (COMPOUND_EXPR, result_type, a1, result); + + if (contains_save_expr_p (a2)) + result = build2 (COMPOUND_EXPR, result_type, a2, result); + + return result; + } + + /* Compute the result of applying OP_CODE to LHS and RHS, where both are of + type TYPE. We know that TYPE is a modular type with a nonbinary + modulus. */ + + static tree + nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs, + tree rhs) + { + tree modulus = TYPE_MODULUS (type); + unsigned int needed_precision = tree_floor_log2 (modulus) + 1; + unsigned int precision; + bool unsignedp = true; + tree op_type = type; + tree result; + + /* If this is an addition of a constant, convert it to a subtraction + of a constant since we can do that faster. */ + if (op_code == PLUS_EXPR && TREE_CODE (rhs) == INTEGER_CST) + { + rhs = fold_build2 (MINUS_EXPR, type, modulus, rhs); + op_code = MINUS_EXPR; + } + + /* For the logical operations, we only need PRECISION bits. For + addition and subtraction, we need one more and for multiplication we + need twice as many. But we never want to make a size smaller than + our size. */ + if (op_code == PLUS_EXPR || op_code == MINUS_EXPR) + needed_precision += 1; + else if (op_code == MULT_EXPR) + needed_precision *= 2; + + precision = MAX (needed_precision, TYPE_PRECISION (op_type)); + + /* Unsigned will do for everything but subtraction. */ + if (op_code == MINUS_EXPR) + unsignedp = false; + + /* If our type is the wrong signedness or isn't wide enough, make a new + type and convert both our operands to it. */ + if (TYPE_PRECISION (op_type) < precision + || TYPE_UNSIGNED (op_type) != unsignedp) + { + /* Copy the node so we ensure it can be modified to make it modular. */ + op_type = copy_node (gnat_type_for_size (precision, unsignedp)); + modulus = convert (op_type, modulus); + SET_TYPE_MODULUS (op_type, modulus); + TYPE_MODULAR_P (op_type) = 1; + lhs = convert (op_type, lhs); + rhs = convert (op_type, rhs); + } + + /* Do the operation, then we'll fix it up. */ + result = fold_build2 (op_code, op_type, lhs, rhs); + + /* For multiplication, we have no choice but to do a full modulus + operation. However, we want to do this in the narrowest + possible size. */ + if (op_code == MULT_EXPR) + { + tree div_type = copy_node (gnat_type_for_size (needed_precision, 1)); + modulus = convert (div_type, modulus); + SET_TYPE_MODULUS (div_type, modulus); + TYPE_MODULAR_P (div_type) = 1; + result = convert (op_type, + fold_build2 (TRUNC_MOD_EXPR, div_type, + convert (div_type, result), modulus)); + } + + /* For subtraction, add the modulus back if we are negative. */ + else if (op_code == MINUS_EXPR) + { + result = save_expr (result); + result = fold_build3 (COND_EXPR, op_type, + fold_build2 (LT_EXPR, integer_type_node, result, + convert (op_type, integer_zero_node)), + fold_build2 (PLUS_EXPR, op_type, result, modulus), + result); + } + + /* For the other operations, subtract the modulus if we are >= it. */ + else + { + result = save_expr (result); + result = fold_build3 (COND_EXPR, op_type, + fold_build2 (GE_EXPR, integer_type_node, + result, modulus), + fold_build2 (MINUS_EXPR, op_type, + result, modulus), + result); + } + + return convert (type, result); + } + + /* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type + desired for the result. Usually the operation is to be performed + in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0 + in which case the type to be used will be derived from the operands. + + This function is very much unlike the ones for C and C++ since we + have already done any type conversion and matching required. All we + have to do here is validate the work done by SEM and handle subtypes. */ + + tree + build_binary_op (enum tree_code op_code, tree result_type, + tree left_operand, tree right_operand) + { + tree left_type = TREE_TYPE (left_operand); + tree right_type = TREE_TYPE (right_operand); + tree left_base_type = get_base_type (left_type); + tree right_base_type = get_base_type (right_type); + tree operation_type = result_type; + tree best_type = NULL_TREE; + tree modulus, result; + bool has_side_effects = false; + + if (operation_type + && TREE_CODE (operation_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (operation_type)) + operation_type = TREE_TYPE (TYPE_FIELDS (operation_type)); + + if (operation_type + && !AGGREGATE_TYPE_P (operation_type) + && TYPE_EXTRA_SUBTYPE_P (operation_type)) + operation_type = get_base_type (operation_type); + + modulus = (operation_type + && TREE_CODE (operation_type) == INTEGER_TYPE + && TYPE_MODULAR_P (operation_type) + ? TYPE_MODULUS (operation_type) : NULL_TREE); + + switch (op_code) + { + case MODIFY_EXPR: + /* If there were integral or pointer conversions on the LHS, remove + them; we'll be putting them back below if needed. Likewise for + conversions between array and record types, except for justified + modular types. But don't do this if the right operand is not + BLKmode (for packed arrays) unless we are not changing the mode. */ + while ((CONVERT_EXPR_P (left_operand) + || TREE_CODE (left_operand) == VIEW_CONVERT_EXPR) + && (((INTEGRAL_TYPE_P (left_type) + || POINTER_TYPE_P (left_type)) + && (INTEGRAL_TYPE_P (TREE_TYPE + (TREE_OPERAND (left_operand, 0))) + || POINTER_TYPE_P (TREE_TYPE + (TREE_OPERAND (left_operand, 0))))) + || (((TREE_CODE (left_type) == RECORD_TYPE + && !TYPE_JUSTIFIED_MODULAR_P (left_type)) + || TREE_CODE (left_type) == ARRAY_TYPE) + && ((TREE_CODE (TREE_TYPE + (TREE_OPERAND (left_operand, 0))) + == RECORD_TYPE) + || (TREE_CODE (TREE_TYPE + (TREE_OPERAND (left_operand, 0))) + == ARRAY_TYPE)) + && (TYPE_MODE (right_type) == BLKmode + || (TYPE_MODE (left_type) + == TYPE_MODE (TREE_TYPE + (TREE_OPERAND + (left_operand, 0)))))))) + { + left_operand = TREE_OPERAND (left_operand, 0); + left_type = TREE_TYPE (left_operand); + } + + /* If a class-wide type may be involved, force use of the RHS type. */ + if ((TREE_CODE (right_type) == RECORD_TYPE + || TREE_CODE (right_type) == UNION_TYPE) + && TYPE_ALIGN_OK (right_type)) + operation_type = right_type; + + /* If we are copying between padded objects with compatible types, use + the padded view of the objects, this is very likely more efficient. + Likewise for a padded that is assigned a constructor, in order to + avoid putting a VIEW_CONVERT_EXPR on the LHS. But don't do this if + we wouldn't have actually copied anything. */ + else if (TREE_CODE (left_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (left_type) + && TREE_CONSTANT (TYPE_SIZE (left_type)) + && ((TREE_CODE (right_operand) == COMPONENT_REF + && TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0))) + == RECORD_TYPE + && TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (right_operand, 0))) + && gnat_types_compatible_p + (left_type, + TREE_TYPE (TREE_OPERAND (right_operand, 0)))) + || TREE_CODE (right_operand) == CONSTRUCTOR) + && !integer_zerop (TYPE_SIZE (right_type))) + operation_type = left_type; + + /* Find the best type to use for copying between aggregate types. */ + else if (((TREE_CODE (left_type) == ARRAY_TYPE + && TREE_CODE (right_type) == ARRAY_TYPE) + || (TREE_CODE (left_type) == RECORD_TYPE + && TREE_CODE (right_type) == RECORD_TYPE)) + && (best_type = find_common_type (left_type, right_type))) + operation_type = best_type; + + /* Otherwise use the LHS type. */ + else if (!operation_type) + operation_type = left_type; + + /* Ensure everything on the LHS is valid. If we have a field reference, + strip anything that get_inner_reference can handle. Then remove any + conversions between types having the same code and mode. And mark + VIEW_CONVERT_EXPRs with TREE_ADDRESSABLE. When done, we must have + either an INDIRECT_REF, a NULL_EXPR or a DECL node. */ + result = left_operand; + while (true) + { + tree restype = TREE_TYPE (result); + + if (TREE_CODE (result) == COMPONENT_REF + || TREE_CODE (result) == ARRAY_REF + || TREE_CODE (result) == ARRAY_RANGE_REF) + while (handled_component_p (result)) + result = TREE_OPERAND (result, 0); + else if (TREE_CODE (result) == REALPART_EXPR + || TREE_CODE (result) == IMAGPART_EXPR + || (CONVERT_EXPR_P (result) + && (((TREE_CODE (restype) + == TREE_CODE (TREE_TYPE + (TREE_OPERAND (result, 0)))) + && (TYPE_MODE (TREE_TYPE + (TREE_OPERAND (result, 0))) + == TYPE_MODE (restype))) + || TYPE_ALIGN_OK (restype)))) + result = TREE_OPERAND (result, 0); + else if (TREE_CODE (result) == VIEW_CONVERT_EXPR) + { + TREE_ADDRESSABLE (result) = 1; + result = TREE_OPERAND (result, 0); + } + else + break; + } + + gcc_assert (TREE_CODE (result) == INDIRECT_REF + || TREE_CODE (result) == NULL_EXPR + || DECL_P (result)); + + /* Convert the right operand to the operation type unless it is + either already of the correct type or if the type involves a + placeholder, since the RHS may not have the same record type. */ + if (operation_type != right_type + && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (operation_type))) + { + right_operand = convert (operation_type, right_operand); + right_type = operation_type; + } + + /* If the left operand is not of the same type as the operation + type, wrap it up in a VIEW_CONVERT_EXPR. */ + if (left_type != operation_type) + left_operand = unchecked_convert (operation_type, left_operand, false); + + has_side_effects = true; + modulus = NULL_TREE; + break; + + case ARRAY_REF: + if (!operation_type) + operation_type = TREE_TYPE (left_type); + + /* ... fall through ... */ + + case ARRAY_RANGE_REF: + /* First look through conversion between type variants. Note that + this changes neither the operation type nor the type domain. */ + if (TREE_CODE (left_operand) == VIEW_CONVERT_EXPR + && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (left_operand, 0))) + == TYPE_MAIN_VARIANT (left_type)) + { + left_operand = TREE_OPERAND (left_operand, 0); + left_type = TREE_TYPE (left_operand); + } + + /* Then convert the right operand to its base type. This will + prevent unneeded signedness conversions when sizetype is wider than + integer. */ + right_operand = convert (right_base_type, right_operand); + right_operand = convert (TYPE_DOMAIN (left_type), right_operand); + + if (!TREE_CONSTANT (right_operand) + || !TREE_CONSTANT (TYPE_MIN_VALUE (right_type))) + gnat_mark_addressable (left_operand); + + modulus = NULL_TREE; + break; + + case GE_EXPR: + case LE_EXPR: + case GT_EXPR: + case LT_EXPR: + gcc_assert (!POINTER_TYPE_P (left_type)); + + /* ... fall through ... */ + + case EQ_EXPR: + case NE_EXPR: + /* If either operand is a NULL_EXPR, just return a new one. */ + if (TREE_CODE (left_operand) == NULL_EXPR) + return build2 (op_code, result_type, + build1 (NULL_EXPR, integer_type_node, + TREE_OPERAND (left_operand, 0)), + integer_zero_node); + + else if (TREE_CODE (right_operand) == NULL_EXPR) + return build2 (op_code, result_type, + build1 (NULL_EXPR, integer_type_node, + TREE_OPERAND (right_operand, 0)), + integer_zero_node); + + /* If either object is a justified modular types, get the + fields from within. */ + if (TREE_CODE (left_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (left_type)) + { + left_operand = convert (TREE_TYPE (TYPE_FIELDS (left_type)), + left_operand); + left_type = TREE_TYPE (left_operand); + left_base_type = get_base_type (left_type); + } + + if (TREE_CODE (right_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (right_type)) + { + right_operand = convert (TREE_TYPE (TYPE_FIELDS (right_type)), + right_operand); + right_type = TREE_TYPE (right_operand); + right_base_type = get_base_type (right_type); + } + + /* If both objects are arrays, compare them specially. */ + if ((TREE_CODE (left_type) == ARRAY_TYPE + || (TREE_CODE (left_type) == INTEGER_TYPE + && TYPE_HAS_ACTUAL_BOUNDS_P (left_type))) + && (TREE_CODE (right_type) == ARRAY_TYPE + || (TREE_CODE (right_type) == INTEGER_TYPE + && TYPE_HAS_ACTUAL_BOUNDS_P (right_type)))) + { + result = compare_arrays (result_type, left_operand, right_operand); + + if (op_code == NE_EXPR) + result = invert_truthvalue (result); + else + gcc_assert (op_code == EQ_EXPR); + + return result; + } + + /* Otherwise, the base types must be the same unless the objects are + fat pointers or records. If we have records, use the best type and + convert both operands to that type. */ + if (left_base_type != right_base_type) + { + if (TYPE_FAT_POINTER_P (left_base_type) + && TYPE_FAT_POINTER_P (right_base_type) + && TYPE_MAIN_VARIANT (left_base_type) + == TYPE_MAIN_VARIANT (right_base_type)) + best_type = left_base_type; + else if (TREE_CODE (left_base_type) == RECORD_TYPE + && TREE_CODE (right_base_type) == RECORD_TYPE) + { + /* The only way these are permitted to be the same is if both + types have the same name. In that case, one of them must + not be self-referential. Use that one as the best type. + Even better is if one is of fixed size. */ + gcc_assert (TYPE_NAME (left_base_type) + && (TYPE_NAME (left_base_type) + == TYPE_NAME (right_base_type))); + + if (TREE_CONSTANT (TYPE_SIZE (left_base_type))) + best_type = left_base_type; + else if (TREE_CONSTANT (TYPE_SIZE (right_base_type))) + best_type = right_base_type; + else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (left_base_type))) + best_type = left_base_type; + else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (right_base_type))) + best_type = right_base_type; + else + gcc_unreachable (); + } + else + gcc_unreachable (); + + left_operand = convert (best_type, left_operand); + right_operand = convert (best_type, right_operand); + } + + /* If we are comparing a fat pointer against zero, we need to + just compare the data pointer. */ + else if (TYPE_FAT_POINTER_P (left_base_type) + && TREE_CODE (right_operand) == CONSTRUCTOR + && integer_zerop (VEC_index (constructor_elt, + CONSTRUCTOR_ELTS (right_operand), + 0) + ->value)) + { + right_operand = build_component_ref (left_operand, NULL_TREE, + TYPE_FIELDS (left_base_type), + false); + left_operand = convert (TREE_TYPE (right_operand), + integer_zero_node); + } + else + { + left_operand = convert (left_base_type, left_operand); + right_operand = convert (right_base_type, right_operand); + } + + modulus = NULL_TREE; + break; + + case PREINCREMENT_EXPR: + case PREDECREMENT_EXPR: + case POSTINCREMENT_EXPR: + case POSTDECREMENT_EXPR: + /* These operations are not used anymore. */ + gcc_unreachable (); + + case LSHIFT_EXPR: + case RSHIFT_EXPR: + case LROTATE_EXPR: + case RROTATE_EXPR: + /* The RHS of a shift can be any type. Also, ignore any modulus + (we used to abort, but this is needed for unchecked conversion + to modular types). Otherwise, processing is the same as normal. */ + gcc_assert (operation_type == left_base_type); + modulus = NULL_TREE; + left_operand = convert (operation_type, left_operand); + break; + + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: + left_operand = gnat_truthvalue_conversion (left_operand); + right_operand = gnat_truthvalue_conversion (right_operand); + goto common; + + case BIT_AND_EXPR: + case BIT_IOR_EXPR: + case BIT_XOR_EXPR: + /* For binary modulus, if the inputs are in range, so are the + outputs. */ + if (modulus && integer_pow2p (modulus)) + modulus = NULL_TREE; + goto common; + + case COMPLEX_EXPR: + gcc_assert (TREE_TYPE (result_type) == left_base_type + && TREE_TYPE (result_type) == right_base_type); + left_operand = convert (left_base_type, left_operand); + right_operand = convert (right_base_type, right_operand); + break; + + case TRUNC_DIV_EXPR: case TRUNC_MOD_EXPR: + case CEIL_DIV_EXPR: case CEIL_MOD_EXPR: + case FLOOR_DIV_EXPR: case FLOOR_MOD_EXPR: + case ROUND_DIV_EXPR: case ROUND_MOD_EXPR: + /* These always produce results lower than either operand. */ + modulus = NULL_TREE; + goto common; + + case POINTER_PLUS_EXPR: + gcc_assert (operation_type == left_base_type + && sizetype == right_base_type); + left_operand = convert (operation_type, left_operand); + right_operand = convert (sizetype, right_operand); + break; + + case PLUS_NOMOD_EXPR: + case MINUS_NOMOD_EXPR: + if (op_code == PLUS_NOMOD_EXPR) + op_code = PLUS_EXPR; + else + op_code = MINUS_EXPR; + modulus = NULL_TREE; + + /* ... fall through ... */ + + case PLUS_EXPR: + case MINUS_EXPR: + /* Avoid doing arithmetics in BOOLEAN_TYPE like the other compilers. + Contrary to C, Ada doesn't allow arithmetics in Standard.Boolean + but we can generate addition or subtraction for 'Succ and 'Pred. */ + if (operation_type && TREE_CODE (operation_type) == BOOLEAN_TYPE) + operation_type = left_base_type = right_base_type = integer_type_node; + + /* ... fall through ... */ + + default: + common: + /* The result type should be the same as the base types of the + both operands (and they should be the same). Convert + everything to the result type. */ + + gcc_assert (operation_type == left_base_type + && left_base_type == right_base_type); + left_operand = convert (operation_type, left_operand); + right_operand = convert (operation_type, right_operand); + } + + if (modulus && !integer_pow2p (modulus)) + { + result = nonbinary_modular_operation (op_code, operation_type, + left_operand, right_operand); + modulus = NULL_TREE; + } + /* If either operand is a NULL_EXPR, just return a new one. */ + else if (TREE_CODE (left_operand) == NULL_EXPR) + return build1 (NULL_EXPR, operation_type, TREE_OPERAND (left_operand, 0)); + else if (TREE_CODE (right_operand) == NULL_EXPR) + return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0)); + else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF) + result = fold (build4 (op_code, operation_type, left_operand, + right_operand, NULL_TREE, NULL_TREE)); + else + result + = fold_build2 (op_code, operation_type, left_operand, right_operand); + + TREE_SIDE_EFFECTS (result) |= has_side_effects; + TREE_CONSTANT (result) + |= (TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand) + && op_code != ARRAY_REF && op_code != ARRAY_RANGE_REF); + + if ((op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF) + && TYPE_VOLATILE (operation_type)) + TREE_THIS_VOLATILE (result) = 1; + + /* If we are working with modular types, perform the MOD operation + if something above hasn't eliminated the need for it. */ + if (modulus) + result = fold_build2 (FLOOR_MOD_EXPR, operation_type, result, + convert (operation_type, modulus)); + + if (result_type && result_type != operation_type) + result = convert (result_type, result); + + return result; + } + + /* Similar, but for unary operations. */ + + tree + build_unary_op (enum tree_code op_code, tree result_type, tree operand) + { + tree type = TREE_TYPE (operand); + tree base_type = get_base_type (type); + tree operation_type = result_type; + tree result; + bool side_effects = false; + + if (operation_type + && TREE_CODE (operation_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (operation_type)) + operation_type = TREE_TYPE (TYPE_FIELDS (operation_type)); + + if (operation_type + && !AGGREGATE_TYPE_P (operation_type) + && TYPE_EXTRA_SUBTYPE_P (operation_type)) + operation_type = get_base_type (operation_type); + + switch (op_code) + { + case REALPART_EXPR: + case IMAGPART_EXPR: + if (!operation_type) + result_type = operation_type = TREE_TYPE (type); + else + gcc_assert (result_type == TREE_TYPE (type)); + + result = fold_build1 (op_code, operation_type, operand); + break; + + case TRUTH_NOT_EXPR: + gcc_assert (result_type == base_type); + result = invert_truthvalue (gnat_truthvalue_conversion (operand)); + break; + + case ATTR_ADDR_EXPR: + case ADDR_EXPR: + switch (TREE_CODE (operand)) + { + case INDIRECT_REF: + case UNCONSTRAINED_ARRAY_REF: + result = TREE_OPERAND (operand, 0); + + /* Make sure the type here is a pointer, not a reference. + GCC wants pointer types for function addresses. */ + if (!result_type) + result_type = build_pointer_type (type); + + /* If the underlying object can alias everything, propagate the + property since we are effectively retrieving the object. */ + if (POINTER_TYPE_P (TREE_TYPE (result)) + && TYPE_REF_CAN_ALIAS_ALL (TREE_TYPE (result))) + { + if (TREE_CODE (result_type) == POINTER_TYPE + && !TYPE_REF_CAN_ALIAS_ALL (result_type)) + result_type + = build_pointer_type_for_mode (TREE_TYPE (result_type), + TYPE_MODE (result_type), + true); + else if (TREE_CODE (result_type) == REFERENCE_TYPE + && !TYPE_REF_CAN_ALIAS_ALL (result_type)) + result_type + = build_reference_type_for_mode (TREE_TYPE (result_type), + TYPE_MODE (result_type), + true); + } + break; + + case NULL_EXPR: + result = operand; + TREE_TYPE (result) = type = build_pointer_type (type); + break; + + case ARRAY_REF: + case ARRAY_RANGE_REF: + case COMPONENT_REF: + case BIT_FIELD_REF: + /* If this is for 'Address, find the address of the prefix and + add the offset to the field. Otherwise, do this the normal + way. */ + if (op_code == ATTR_ADDR_EXPR) + { + HOST_WIDE_INT bitsize; + HOST_WIDE_INT bitpos; + tree offset, inner; + enum machine_mode mode; + int unsignedp, volatilep; + + inner = get_inner_reference (operand, &bitsize, &bitpos, &offset, + &mode, &unsignedp, &volatilep, + false); + + /* If INNER is a padding type whose field has a self-referential + size, convert to that inner type. We know the offset is zero + and we need to have that type visible. */ + if (TREE_CODE (TREE_TYPE (inner)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (inner)) + && (CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS + (TREE_TYPE (inner))))))) + inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))), + inner); + + /* Compute the offset as a byte offset from INNER. */ + if (!offset) + offset = size_zero_node; + + if (bitpos % BITS_PER_UNIT != 0) + post_error + ("taking address of object not aligned on storage unit?", + error_gnat_node); + + offset = size_binop (PLUS_EXPR, offset, + size_int (bitpos / BITS_PER_UNIT)); + + /* Take the address of INNER, convert the offset to void *, and + add then. It will later be converted to the desired result + type, if any. */ + inner = build_unary_op (ADDR_EXPR, NULL_TREE, inner); + inner = convert (ptr_void_type_node, inner); + result = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node, + inner, offset); + result = convert (build_pointer_type (TREE_TYPE (operand)), + result); + break; + } + goto common; + + case CONSTRUCTOR: + /* If this is just a constructor for a padded record, we can + just take the address of the single field and convert it to + a pointer to our type. */ + if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + { + result = (VEC_index (constructor_elt, + CONSTRUCTOR_ELTS (operand), + 0) + ->value); + + result = convert (build_pointer_type (TREE_TYPE (operand)), + build_unary_op (ADDR_EXPR, NULL_TREE, result)); + break; + } + + goto common; + + case NOP_EXPR: + if (AGGREGATE_TYPE_P (type) + && AGGREGATE_TYPE_P (TREE_TYPE (TREE_OPERAND (operand, 0)))) + return build_unary_op (ADDR_EXPR, result_type, + TREE_OPERAND (operand, 0)); + + /* ... fallthru ... */ + + case VIEW_CONVERT_EXPR: + /* If this just a variant conversion or if the conversion doesn't + change the mode, get the result type from this type and go down. + This is needed for conversions of CONST_DECLs, to eventually get + to the address of their CORRESPONDING_VARs. */ + if ((TYPE_MAIN_VARIANT (type) + == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand, 0)))) + || (TYPE_MODE (type) != BLKmode + && (TYPE_MODE (type) + == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0)))))) + return build_unary_op (ADDR_EXPR, + (result_type ? result_type + : build_pointer_type (type)), + TREE_OPERAND (operand, 0)); + goto common; + + case CONST_DECL: + operand = DECL_CONST_CORRESPONDING_VAR (operand); + + /* ... fall through ... */ + + default: + common: + + /* If we are taking the address of a padded record whose field is + contains a template, take the address of the template. */ + if (TREE_CODE (type) == RECORD_TYPE + && TYPE_IS_PADDING_P (type) + && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type)))) + { + type = TREE_TYPE (TYPE_FIELDS (type)); + operand = convert (type, operand); + } + + if (type != error_mark_node) + operation_type = build_pointer_type (type); + + gnat_mark_addressable (operand); + result = fold_build1 (ADDR_EXPR, operation_type, operand); + } + + TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand); + break; + + case INDIRECT_REF: + /* If we want to refer to an entire unconstrained array, + make up an expression to do so. This will never survive to + the backend. If TYPE is a thin pointer, first convert the + operand to a fat pointer. */ + if (TYPE_THIN_POINTER_P (type) + && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))) + { + operand + = convert (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), + operand); + type = TREE_TYPE (operand); + } + + if (TYPE_FAT_POINTER_P (type)) + { + result = build1 (UNCONSTRAINED_ARRAY_REF, + TYPE_UNCONSTRAINED_ARRAY (type), operand); + TREE_READONLY (result) = TREE_STATIC (result) + = TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type)); + } + else if (TREE_CODE (operand) == ADDR_EXPR) + result = TREE_OPERAND (operand, 0); + + else + { + result = fold_build1 (op_code, TREE_TYPE (type), operand); + TREE_READONLY (result) = TYPE_READONLY (TREE_TYPE (type)); + } + + side_effects + = (!TYPE_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type))); + break; + + case NEGATE_EXPR: + case BIT_NOT_EXPR: + { + tree modulus = ((operation_type + && TREE_CODE (operation_type) == INTEGER_TYPE + && TYPE_MODULAR_P (operation_type)) + ? TYPE_MODULUS (operation_type) : NULL_TREE); + int mod_pow2 = modulus && integer_pow2p (modulus); + + /* If this is a modular type, there are various possibilities + depending on the operation and whether the modulus is a + power of two or not. */ + + if (modulus) + { + gcc_assert (operation_type == base_type); + operand = convert (operation_type, operand); + + /* The fastest in the negate case for binary modulus is + the straightforward code; the TRUNC_MOD_EXPR below + is an AND operation. */ + if (op_code == NEGATE_EXPR && mod_pow2) + result = fold_build2 (TRUNC_MOD_EXPR, operation_type, + fold_build1 (NEGATE_EXPR, operation_type, + operand), + modulus); + + /* For nonbinary negate case, return zero for zero operand, + else return the modulus minus the operand. If the modulus + is a power of two minus one, we can do the subtraction + as an XOR since it is equivalent and faster on most machines. */ + else if (op_code == NEGATE_EXPR && !mod_pow2) + { + if (integer_pow2p (fold_build2 (PLUS_EXPR, operation_type, + modulus, + convert (operation_type, + integer_one_node)))) + result = fold_build2 (BIT_XOR_EXPR, operation_type, + operand, modulus); + else + result = fold_build2 (MINUS_EXPR, operation_type, + modulus, operand); + + result = fold_build3 (COND_EXPR, operation_type, + fold_build2 (NE_EXPR, + integer_type_node, + operand, + convert + (operation_type, + integer_zero_node)), + result, operand); + } + else + { + /* For the NOT cases, we need a constant equal to + the modulus minus one. For a binary modulus, we + XOR against the constant and subtract the operand from + that constant for nonbinary modulus. */ + + tree cnst = fold_build2 (MINUS_EXPR, operation_type, modulus, + convert (operation_type, + integer_one_node)); + + if (mod_pow2) + result = fold_build2 (BIT_XOR_EXPR, operation_type, + operand, cnst); + else + result = fold_build2 (MINUS_EXPR, operation_type, + cnst, operand); + } + + break; + } + } + + /* ... fall through ... */ + + default: + gcc_assert (operation_type == base_type); + result = fold_build1 (op_code, operation_type, + convert (operation_type, operand)); + } + + if (side_effects) + { + TREE_SIDE_EFFECTS (result) = 1; + if (TREE_CODE (result) == INDIRECT_REF) + TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result)); + } + + if (result_type && TREE_TYPE (result) != result_type) + result = convert (result_type, result); + + return result; + } + + /* Similar, but for COND_EXPR. */ + + tree + build_cond_expr (tree result_type, tree condition_operand, + tree true_operand, tree false_operand) + { + tree result; + bool addr_p = false; + + /* The front-end verifies that result, true and false operands have same base + type. Convert everything to the result type. */ + + true_operand = convert (result_type, true_operand); + false_operand = convert (result_type, false_operand); + + /* If the result type is unconstrained, take the address of + the operands and then dereference our result. */ + if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE + || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type))) + { + addr_p = true; + result_type = build_pointer_type (result_type); + true_operand = build_unary_op (ADDR_EXPR, result_type, true_operand); + false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand); + } + + result = fold_build3 (COND_EXPR, result_type, condition_operand, + true_operand, false_operand); + + /* If either operand is a SAVE_EXPR (possibly surrounded by + arithmetic, make sure it gets done. */ + true_operand = skip_simple_arithmetic (true_operand); + false_operand = skip_simple_arithmetic (false_operand); + + if (TREE_CODE (true_operand) == SAVE_EXPR) + result = build2 (COMPOUND_EXPR, result_type, true_operand, result); + + if (TREE_CODE (false_operand) == SAVE_EXPR) + result = build2 (COMPOUND_EXPR, result_type, false_operand, result); + + /* ??? Seems the code above is wrong, as it may move ahead of the COND + SAVE_EXPRs with side effects and not shared by both arms. */ + + if (addr_p) + result = build_unary_op (INDIRECT_REF, NULL_TREE, result); + + return result; + } + + /* Similar, but for RETURN_EXPR. If RESULT_DECL is non-zero, build + a RETURN_EXPR around the assignment of RET_VAL to RESULT_DECL. + If RESULT_DECL is zero, build a bare RETURN_EXPR. */ + + tree + build_return_expr (tree result_decl, tree ret_val) + { + tree result_expr; + + if (result_decl) + { + /* The gimplifier explicitly enforces the following invariant: + + RETURN_EXPR + | + MODIFY_EXPR + / \ + / \ + RESULT_DECL ... + + As a consequence, type-homogeneity dictates that we use the type + of the RESULT_DECL as the operation type. */ + + tree operation_type = TREE_TYPE (result_decl); + + /* Convert the right operand to the operation type. Note that + it's the same transformation as in the MODIFY_EXPR case of + build_binary_op with the additional guarantee that the type + cannot involve a placeholder, since otherwise the function + would use the "target pointer" return mechanism. */ + + if (operation_type != TREE_TYPE (ret_val)) + ret_val = convert (operation_type, ret_val); + + result_expr + = build2 (MODIFY_EXPR, operation_type, result_decl, ret_val); + } + else + result_expr = NULL_TREE; + + return build1 (RETURN_EXPR, void_type_node, result_expr); + } + + /* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return + the CALL_EXPR. */ + + tree + build_call_1_expr (tree fundecl, tree arg) + { + tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)), + build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), + 1, arg); + TREE_SIDE_EFFECTS (call) = 1; + return call; + } + + /* Build a CALL_EXPR to call FUNDECL with two arguments, ARG1 & ARG2. Return + the CALL_EXPR. */ + + tree + build_call_2_expr (tree fundecl, tree arg1, tree arg2) + { + tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)), + build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), + 2, arg1, arg2); + TREE_SIDE_EFFECTS (call) = 1; + return call; + } + + /* Likewise to call FUNDECL with no arguments. */ + + tree + build_call_0_expr (tree fundecl) + { + /* We rely on build_call_nary to compute TREE_SIDE_EFFECTS. This makes + it possible to propagate DECL_IS_PURE on parameterless functions. */ + tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)), + build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), + 0); + return call; + } + + /* Call a function that raises an exception and pass the line number and file + name, if requested. MSG says which exception function to call. + + GNAT_NODE is the gnat node conveying the source location for which the + error should be signaled, or Empty in which case the error is signaled on + the current ref_file_name/input_line. + + KIND says which kind of exception this is for + (N_Raise_{Constraint,Storage,Program}_Error). */ + + tree + build_call_raise (int msg, Node_Id gnat_node, char kind) + { + tree fndecl = gnat_raise_decls[msg]; + tree label = get_exception_label (kind); + tree filename; + int line_number; + const char *str; + int len; + + /* If this is to be done as a goto, handle that case. */ + if (label) + { + Entity_Id local_raise = Get_Local_Raise_Call_Entity (); + tree gnu_result = build1 (GOTO_EXPR, void_type_node, label); + + /* If Local_Raise is present, generate + Local_Raise (exception'Identity); */ + if (Present (local_raise)) + { + tree gnu_local_raise + = gnat_to_gnu_entity (local_raise, NULL_TREE, 0); + tree gnu_exception_entity + = gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0); + tree gnu_call + = build_call_1_expr (gnu_local_raise, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_exception_entity)); + + gnu_result = build2 (COMPOUND_EXPR, void_type_node, + gnu_call, gnu_result);} + + return gnu_result; + } + + str + = (Debug_Flag_NN || Exception_Locations_Suppressed) + ? "" + : (gnat_node != Empty && Sloc (gnat_node) != No_Location) + ? IDENTIFIER_POINTER + (get_identifier (Get_Name_String + (Debug_Source_Name + (Get_Source_File_Index (Sloc (gnat_node)))))) + : ref_filename; + + len = strlen (str) + 1; + filename = build_string (len, str); + line_number + = (gnat_node != Empty && Sloc (gnat_node) != No_Location) + ? Get_Logical_Line_Number (Sloc(gnat_node)) : input_line; + + TREE_TYPE (filename) + = build_array_type (char_type_node, + build_index_type (build_int_cst (NULL_TREE, len))); + + return + build_call_2_expr (fndecl, + build1 (ADDR_EXPR, build_pointer_type (char_type_node), + filename), + build_int_cst (NULL_TREE, line_number)); + } + + /* qsort comparer for the bit positions of two constructor elements + for record components. */ + + static int + compare_elmt_bitpos (const PTR rt1, const PTR rt2) + { + const_tree const elmt1 = * (const_tree const *) rt1; + const_tree const elmt2 = * (const_tree const *) rt2; + const_tree const field1 = TREE_PURPOSE (elmt1); + const_tree const field2 = TREE_PURPOSE (elmt2); + const int ret + = tree_int_cst_compare (bit_position (field1), bit_position (field2)); + + return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2)); + } + + /* Return a CONSTRUCTOR of TYPE whose list is LIST. */ + + tree + gnat_build_constructor (tree type, tree list) + { + tree elmt; + int n_elmts; + bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST); + bool side_effects = false; + tree result; + + /* Scan the elements to see if they are all constant or if any has side + effects, to let us set global flags on the resulting constructor. Count + the elements along the way for possible sorting purposes below. */ + for (n_elmts = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), n_elmts ++) + { + if (!TREE_CONSTANT (TREE_VALUE (elmt)) + || (TREE_CODE (type) == RECORD_TYPE + && DECL_BIT_FIELD (TREE_PURPOSE (elmt)) + && TREE_CODE (TREE_VALUE (elmt)) != INTEGER_CST) + || !initializer_constant_valid_p (TREE_VALUE (elmt), + TREE_TYPE (TREE_VALUE (elmt)))) + allconstant = false; + + if (TREE_SIDE_EFFECTS (TREE_VALUE (elmt))) + side_effects = true; + + /* Propagate an NULL_EXPR from the size of the type. We won't ever + be executing the code we generate here in that case, but handle it + specially to avoid the compiler blowing up. */ + if (TREE_CODE (type) == RECORD_TYPE + && (0 != (result + = contains_null_expr (DECL_SIZE (TREE_PURPOSE (elmt)))))) + return build1 (NULL_EXPR, type, TREE_OPERAND (result, 0)); + } + + /* For record types with constant components only, sort field list + by increasing bit position. This is necessary to ensure the + constructor can be output as static data. */ + if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1) + { + /* Fill an array with an element tree per index, and ask qsort to order + them according to what a bitpos comparison function says. */ + tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts); + int i; + + for (i = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), i++) + gnu_arr[i] = elmt; + + qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos); + + /* Then reconstruct the list from the sorted array contents. */ + list = NULL_TREE; + for (i = n_elmts - 1; i >= 0; i--) + { + TREE_CHAIN (gnu_arr[i]) = list; + list = gnu_arr[i]; + } + } + + result = build_constructor_from_list (type, list); + TREE_CONSTANT (result) = TREE_STATIC (result) = allconstant; + TREE_SIDE_EFFECTS (result) = side_effects; + TREE_READONLY (result) = TYPE_READONLY (type) || allconstant; + return result; + } + + /* Return a COMPONENT_REF to access a field that is given by COMPONENT, + an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL, + for the field. Don't fold the result if NO_FOLD_P is true. + + We also handle the fact that we might have been passed a pointer to the + actual record and know how to look for fields in variant parts. */ + + static tree + build_simple_component_ref (tree record_variable, tree component, + tree field, bool no_fold_p) + { + tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable)); + tree ref, inner_variable; + + gcc_assert ((TREE_CODE (record_type) == RECORD_TYPE + || TREE_CODE (record_type) == UNION_TYPE + || TREE_CODE (record_type) == QUAL_UNION_TYPE) + && TYPE_SIZE (record_type) + && (component != 0) != (field != 0)); + + /* If no field was specified, look for a field with the specified name + in the current record only. */ + if (!field) + for (field = TYPE_FIELDS (record_type); field; + field = TREE_CHAIN (field)) + if (DECL_NAME (field) == component) + break; + + if (!field) + return NULL_TREE; + + /* If this field is not in the specified record, see if we can find + something in the record whose original field is the same as this one. */ + if (DECL_CONTEXT (field) != record_type) + /* Check if there is a field with name COMPONENT in the record. */ + { + tree new_field; + + /* First loop thru normal components. */ + + for (new_field = TYPE_FIELDS (record_type); new_field; + new_field = TREE_CHAIN (new_field)) + if (field == new_field + || DECL_ORIGINAL_FIELD (new_field) == field + || new_field == DECL_ORIGINAL_FIELD (field) + || (DECL_ORIGINAL_FIELD (field) + && (DECL_ORIGINAL_FIELD (field) + == DECL_ORIGINAL_FIELD (new_field)))) + break; + + /* Next, loop thru DECL_INTERNAL_P components if we haven't found + the component in the first search. Doing this search in 2 steps + is required to avoiding hidden homonymous fields in the + _Parent field. */ + + if (!new_field) + for (new_field = TYPE_FIELDS (record_type); new_field; + new_field = TREE_CHAIN (new_field)) + if (DECL_INTERNAL_P (new_field)) + { + tree field_ref + = build_simple_component_ref (record_variable, + NULL_TREE, new_field, no_fold_p); + ref = build_simple_component_ref (field_ref, NULL_TREE, field, + no_fold_p); + + if (ref) + return ref; + } + + field = new_field; + } + + if (!field) + return NULL_TREE; + + /* If the field's offset has overflowed, do not attempt to access it + as doing so may trigger sanity checks deeper in the back-end. + Note that we don't need to warn since this will be done on trying + to declare the object. */ + if (TREE_CODE (DECL_FIELD_OFFSET (field)) == INTEGER_CST + && TREE_OVERFLOW (DECL_FIELD_OFFSET (field))) + return NULL_TREE; + + /* Look through conversion between type variants. Note that this + is transparent as far as the field is concerned. */ + if (TREE_CODE (record_variable) == VIEW_CONVERT_EXPR + && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (record_variable, 0))) + == record_type) + inner_variable = TREE_OPERAND (record_variable, 0); + else + inner_variable = record_variable; + + ref = build3 (COMPONENT_REF, TREE_TYPE (field), inner_variable, field, + NULL_TREE); + + if (TREE_READONLY (record_variable) || TREE_READONLY (field)) + TREE_READONLY (ref) = 1; + if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field) + || TYPE_VOLATILE (record_type)) + TREE_THIS_VOLATILE (ref) = 1; + + if (no_fold_p) + return ref; + + /* The generic folder may punt in this case because the inner array type + can be self-referential, but folding is in fact not problematic. */ + else if (TREE_CODE (record_variable) == CONSTRUCTOR + && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (record_variable))) + { + VEC(constructor_elt,gc) *elts = CONSTRUCTOR_ELTS (record_variable); + unsigned HOST_WIDE_INT idx; + tree index, value; + FOR_EACH_CONSTRUCTOR_ELT (elts, idx, index, value) + if (index == field) + return value; + return ref; + } + + else + return fold (ref); + } + + /* Like build_simple_component_ref, except that we give an error if the + reference could not be found. */ + + tree + build_component_ref (tree record_variable, tree component, + tree field, bool no_fold_p) + { + tree ref = build_simple_component_ref (record_variable, component, field, + no_fold_p); + + if (ref) + return ref; + + /* If FIELD was specified, assume this is an invalid user field so + raise constraint error. Otherwise, we can't find the type to return, so + abort. */ + gcc_assert (field); + return build1 (NULL_EXPR, TREE_TYPE (field), + build_call_raise (CE_Discriminant_Check_Failed, Empty, + N_Raise_Constraint_Error)); + } + + /* Build a GCC tree to call an allocation or deallocation function. + If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise, + generate an allocator. + + GNU_SIZE is the size of the object in bytes and ALIGN is the alignment in + bits. GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the + storage pool to use. If not preset, malloc and free will be used except + if GNAT_PROC is the "fake" value of -1, in which case we allocate the + object dynamically on the stack frame. */ + + tree + build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align, + Entity_Id gnat_proc, Entity_Id gnat_pool, + Node_Id gnat_node) + { + tree gnu_align = size_int (align / BITS_PER_UNIT); + + gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj); + + if (Present (gnat_proc)) + { + /* The storage pools are obviously always tagged types, but the + secondary stack uses the same mechanism and is not tagged */ + if (Is_Tagged_Type (Etype (gnat_pool))) + { + /* The size is the third parameter; the alignment is the + same type. */ + Entity_Id gnat_size_type + = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc)))); + tree gnu_size_type = gnat_to_gnu_type (gnat_size_type); + tree gnu_proc = gnat_to_gnu (gnat_proc); + tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc); + tree gnu_pool = gnat_to_gnu (gnat_pool); + tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool); + tree gnu_call; + + gnu_size = convert (gnu_size_type, gnu_size); + gnu_align = convert (gnu_size_type, gnu_align); + + /* The first arg is always the address of the storage pool; next + comes the address of the object, for a deallocator, then the + size and alignment. */ + if (gnu_obj) + gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)), + gnu_proc_addr, 4, gnu_pool_addr, + gnu_obj, gnu_size, gnu_align); + else + gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)), + gnu_proc_addr, 3, gnu_pool_addr, + gnu_size, gnu_align); + TREE_SIDE_EFFECTS (gnu_call) = 1; + return gnu_call; + } + + /* Secondary stack case. */ + else + { + /* The size is the second parameter */ + Entity_Id gnat_size_type + = Etype (Next_Formal (First_Formal (gnat_proc))); + tree gnu_size_type = gnat_to_gnu_type (gnat_size_type); + tree gnu_proc = gnat_to_gnu (gnat_proc); + tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc); + tree gnu_call; + + gnu_size = convert (gnu_size_type, gnu_size); + + /* The first arg is the address of the object, for a + deallocator, then the size */ + if (gnu_obj) + gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)), + gnu_proc_addr, 2, gnu_obj, gnu_size); + else + gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)), + gnu_proc_addr, 1, gnu_size); + TREE_SIDE_EFFECTS (gnu_call) = 1; + return gnu_call; + } + } + + else if (gnu_obj) + return build_call_1_expr (free_decl, gnu_obj); + + /* ??? For now, disable variable-sized allocators in the stack since + we can't yet gimplify an ALLOCATE_EXPR. */ + else if (gnat_pool == -1 + && TREE_CODE (gnu_size) == INTEGER_CST + && flag_stack_check != GENERIC_STACK_CHECK) + { + /* If the size is a constant, we can put it in the fixed portion of + the stack frame to avoid the need to adjust the stack pointer. */ + { + tree gnu_range + = build_range_type (NULL_TREE, size_one_node, gnu_size); + tree gnu_array_type = build_array_type (char_type_node, gnu_range); + tree gnu_decl + = create_var_decl (get_identifier ("RETVAL"), NULL_TREE, + gnu_array_type, NULL_TREE, false, false, false, + false, NULL, gnat_node); + + return convert (ptr_void_type_node, + build_unary_op (ADDR_EXPR, NULL_TREE, gnu_decl)); + } + #if 0 + else + return build2 (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align); + #endif + } + else + { + if (Nkind (gnat_node) != N_Allocator || !Comes_From_Source (gnat_node)) + Check_No_Implicit_Heap_Alloc (gnat_node); + + /* If the allocator size is 32bits but the pointer size is 64bits then + allocate 32bit memory (sometimes necessary on 64bit VMS). Otherwise + default to standard malloc. */ + if (TARGET_ABI_OPEN_VMS && + (!TARGET_MALLOC64 || + (POINTER_SIZE == 64 + && (UI_To_Int (Esize (Etype (gnat_node))) == 32 + || Convention (Etype (gnat_node)) == Convention_C)))) + return build_call_1_expr (malloc32_decl, gnu_size); + else + return build_call_1_expr (malloc_decl, gnu_size); + } + } + + /* Build a GCC tree to correspond to allocating an object of TYPE whose + initial value is INIT, if INIT is nonzero. Convert the expression to + RESULT_TYPE, which must be some type of pointer. Return the tree. + GNAT_PROC and GNAT_POOL optionally give the procedure to call and + the storage pool to use. GNAT_NODE is used to provide an error + location for restriction violations messages. If IGNORE_INIT_TYPE is + true, ignore the type of INIT for the purpose of determining the size; + this will cause the maximum size to be allocated if TYPE is of + self-referential size. */ + + tree + build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, + Entity_Id gnat_pool, Node_Id gnat_node, bool ignore_init_type) + { + tree size = TYPE_SIZE_UNIT (type); + tree result; + unsigned int default_allocator_alignment + = get_target_default_allocator_alignment () * BITS_PER_UNIT; + + /* If the initializer, if present, is a NULL_EXPR, just return a new one. */ + if (init && TREE_CODE (init) == NULL_EXPR) + return build1 (NULL_EXPR, result_type, TREE_OPERAND (init, 0)); + + /* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the + sizes of the object and its template. Allocate the whole thing and + fill in the parts that are known. */ + else if (TYPE_FAT_OR_THIN_POINTER_P (result_type)) + { + tree storage_type + = build_unc_object_type_from_ptr (result_type, type, + get_identifier ("ALLOC")); + tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type)); + tree storage_ptr_type = build_pointer_type (storage_type); + tree storage; + tree template_cons = NULL_TREE; + + size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type), + init); + + /* If the size overflows, pass -1 so the allocator will raise + storage error. */ + if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size)) + size = ssize_int (-1); + + storage = build_call_alloc_dealloc (NULL_TREE, size, + TYPE_ALIGN (storage_type), + gnat_proc, gnat_pool, gnat_node); + storage = convert (storage_ptr_type, protect_multiple_eval (storage)); + + if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + { + type = TREE_TYPE (TYPE_FIELDS (type)); + + if (init) + init = convert (type, init); + } + + /* If there is an initializing expression, make a constructor for + the entire object including the bounds and copy it into the + object. If there is no initializing expression, just set the + bounds. */ + if (init) + { + template_cons = tree_cons (TREE_CHAIN (TYPE_FIELDS (storage_type)), + init, NULL_TREE); + template_cons = tree_cons (TYPE_FIELDS (storage_type), + build_template (template_type, type, + init), + template_cons); + + return convert + (result_type, + build2 (COMPOUND_EXPR, storage_ptr_type, + build_binary_op + (MODIFY_EXPR, storage_type, + build_unary_op (INDIRECT_REF, NULL_TREE, + convert (storage_ptr_type, storage)), + gnat_build_constructor (storage_type, template_cons)), + convert (storage_ptr_type, storage))); + } + else + return build2 + (COMPOUND_EXPR, result_type, + build_binary_op + (MODIFY_EXPR, template_type, + build_component_ref + (build_unary_op (INDIRECT_REF, NULL_TREE, + convert (storage_ptr_type, storage)), + NULL_TREE, TYPE_FIELDS (storage_type), 0), + build_template (template_type, type, NULL_TREE)), + convert (result_type, convert (storage_ptr_type, storage))); + } + + /* If we have an initializing expression, see if its size is simpler + than the size from the type. */ + if (!ignore_init_type && init && TYPE_SIZE_UNIT (TREE_TYPE (init)) + && (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST + || CONTAINS_PLACEHOLDER_P (size))) + size = TYPE_SIZE_UNIT (TREE_TYPE (init)); + + /* If the size is still self-referential, reference the initializing + expression, if it is present. If not, this must have been a + call to allocate a library-level object, in which case we use + the maximum size. */ + if (CONTAINS_PLACEHOLDER_P (size)) + { + if (!ignore_init_type && init) + size = substitute_placeholder_in_expr (size, init); + else + size = max_size (size, true); + } + + /* If the size overflows, pass -1 so the allocator will raise + storage error. */ + if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size)) + size = ssize_int (-1); + + /* If this is in the default storage pool and the type alignment is larger + than what the default allocator supports, make an "aligning" record type + with room to store a pointer before the field, allocate an object of that + type, store the system's allocator return value just in front of the + field and return the field's address. */ + + if (No (gnat_proc) && TYPE_ALIGN (type) > default_allocator_alignment) + { + /* Construct the aligning type with enough room for a pointer ahead + of the field, then allocate. */ + tree record_type + = make_aligning_type (type, TYPE_ALIGN (type), size, + default_allocator_alignment, + POINTER_SIZE / BITS_PER_UNIT); + + tree record, record_addr; + + record_addr + = build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE_UNIT (record_type), + default_allocator_alignment, Empty, Empty, + gnat_node); + + record_addr + = convert (build_pointer_type (record_type), + save_expr (record_addr)); + + record = build_unary_op (INDIRECT_REF, NULL_TREE, record_addr); + + /* Our RESULT (the Ada allocator's value) is the super-aligned address + of the internal record field ... */ + result + = build_unary_op (ADDR_EXPR, NULL_TREE, + build_component_ref + (record, NULL_TREE, TYPE_FIELDS (record_type), 0)); + result = convert (result_type, result); + + /* ... with the system allocator's return value stored just in + front. */ + { + tree ptr_addr + = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node, + convert (ptr_void_type_node, result), + size_int (-POINTER_SIZE/BITS_PER_UNIT)); + + tree ptr_ref + = convert (build_pointer_type (ptr_void_type_node), ptr_addr); + + result + = build2 (COMPOUND_EXPR, TREE_TYPE (result), + build_binary_op (MODIFY_EXPR, NULL_TREE, + build_unary_op (INDIRECT_REF, NULL_TREE, + ptr_ref), + convert (ptr_void_type_node, + record_addr)), + result); + } + } + else + result = convert (result_type, + build_call_alloc_dealloc (NULL_TREE, size, + TYPE_ALIGN (type), + gnat_proc, + gnat_pool, + gnat_node)); + + /* If we have an initial value, put the new address into a SAVE_EXPR, assign + the value, and return the address. Do this with a COMPOUND_EXPR. */ + + if (init) + { + result = save_expr (result); + result + = build2 (COMPOUND_EXPR, TREE_TYPE (result), + build_binary_op + (MODIFY_EXPR, NULL_TREE, + build_unary_op (INDIRECT_REF, + TREE_TYPE (TREE_TYPE (result)), result), + init), + result); + } + + return convert (result_type, result); + } + + /* Fill in a VMS descriptor for EXPR and return a constructor for it. + GNAT_FORMAL is how we find the descriptor record. GNAT_ACTUAL is + how we derive the source location to raise C_E on an out of range + pointer. */ + + tree + fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual) + { + tree field; + tree parm_decl = get_gnu_tree (gnat_formal); + tree const_list = NULL_TREE; + tree record_type = TREE_TYPE (TREE_TYPE (parm_decl)); + int do_range_check = + strcmp ("MBO", + IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (record_type)))); + + expr = maybe_unconstrained_array (expr); + gnat_mark_addressable (expr); + + for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field)) + { + tree conexpr = convert (TREE_TYPE (field), + SUBSTITUTE_PLACEHOLDER_IN_EXPR + (DECL_INITIAL (field), expr)); + + /* Check to ensure that only 32bit pointers are passed in + 32bit descriptors */ + if (do_range_check && + strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), "POINTER") == 0) + { + tree pointer64type = + build_pointer_type_for_mode (void_type_node, DImode, false); + tree addr64expr = build_unary_op (ADDR_EXPR, pointer64type, expr); + tree malloc64low = + build_int_cstu (long_integer_type_node, 0x80000000); + + add_stmt (build3 (COND_EXPR, void_type_node, + build_binary_op (GE_EXPR, long_integer_type_node, + convert (long_integer_type_node, + addr64expr), + malloc64low), + build_call_raise (CE_Range_Check_Failed, gnat_actual, + N_Raise_Constraint_Error), + NULL_TREE)); + } + const_list = tree_cons (field, conexpr, const_list); + } + + return gnat_build_constructor (record_type, nreverse (const_list)); + } + + /* Indicate that we need to make the address of EXPR_NODE and it therefore + should not be allocated in a register. Returns true if successful. */ + + bool + gnat_mark_addressable (tree expr_node) + { + while (1) + switch (TREE_CODE (expr_node)) + { + case ADDR_EXPR: + case COMPONENT_REF: + case ARRAY_REF: + case ARRAY_RANGE_REF: + case REALPART_EXPR: + case IMAGPART_EXPR: + case VIEW_CONVERT_EXPR: + case NON_LVALUE_EXPR: + CASE_CONVERT: + expr_node = TREE_OPERAND (expr_node, 0); + break; + + case CONSTRUCTOR: + TREE_ADDRESSABLE (expr_node) = 1; + return true; + + case VAR_DECL: + case PARM_DECL: + case RESULT_DECL: + TREE_ADDRESSABLE (expr_node) = 1; + return true; + + case FUNCTION_DECL: + TREE_ADDRESSABLE (expr_node) = 1; + return true; + + case CONST_DECL: + return (DECL_CONST_CORRESPONDING_VAR (expr_node) + && (gnat_mark_addressable + (DECL_CONST_CORRESPONDING_VAR (expr_node)))); + default: + return true; + } + } diff -Nrcpad gcc-4.3.3/gcc/ada/gen-soccon.c gcc-4.4.0/gcc/ada/gen-soccon.c *** gcc-4.3.3/gcc/ada/gen-soccon.c Wed Dec 19 16:25:58 2007 --- gcc-4.4.0/gcc/ada/gen-soccon.c Thu Jan 1 00:00:00 1970 *************** *** 1,716 **** - /**************************************************************************** - * * - * GNAT SYSTEM UTILITIES * - * * - * G E N - S O C C O N * - * * - * Copyright (C) 2004-2007, 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- * - * ware Foundation; either version 2, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License distributed with GNAT; see file COPYING. If not, write * - * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * - * Boston, MA 02110-1301, USA. * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - /* This program generates g-soccon.ads */ - - /* - * To build using DEC C: - * - * CC/DEFINE="TARGET=""OpenVMS""" gen-soccon - * LINK gen-soccon - * RUN gen-soccon - * - * Note: OpenVMS versions older than 8.3 provide an incorrect value in - * the DEC C header files for MSG_WAITALL. To generate the VMS version - * of g-soccon.ads, gen-soccon should be run on an 8.3 or later machine. - */ - - #ifndef TARGET - # error Please define TARGET - #endif - - #include - #include - #include - #include - - #ifdef __MINGW32__ - #include - #endif - - #include "gsocket.h" - - struct line { - char *text; - char *value; - char *comment; - struct line *next; - }; - - struct line *first = NULL, *last = NULL; - - #define TXT(_text) add_line(_text, NULL, NULL); - /* Plain text */ - - #define _NL TXT("") - /* Empty line */ - - #define itoad(n) f_itoa ("%d", (n)) - #define itoax(n) f_itoa ("16#%08x#", (n)) - - #define CND(name,comment) add_line(#name, itoad (name), comment); - /* Constant (decimal) */ - - #define CNX(name,comment) add_line(#name, itoax (name), comment); - /* Constant (hexadecimal) */ - - #define CN_(name,comment) add_line(#name, name, comment); - /* Constant (generic) */ - - #define STR(p) STR1(p) - #define STR1(p) #p - - void output (void); - /* Generate output spec */ - - char *f_itoa (char *, int); - /* int to string */ - - void add_line (char *, char*, char*); - - #ifdef __MINGW32__ - unsigned int _CRT_fmode = _O_BINARY; - #endif - - int - main (void) { - - TXT("------------------------------------------------------------------------------") - TXT("-- --") - TXT("-- GNAT COMPILER COMPONENTS --") - TXT("-- --") - TXT("-- G N A T . S O C K E T S . C O N S T A N T S --") - TXT("-- --") - TXT("-- S p e c --") - TXT("-- --") - TXT("-- Copyright (C) 2000-2007, Free Software Foundation, Inc. --") - TXT("-- --") - TXT("-- GNAT is free software; you can redistribute it and/or modify it under --") - TXT("-- terms of the GNU General Public License as published by the Free Soft- --") - TXT("-- ware Foundation; either version 2, or (at your option) any later ver- --") - TXT("-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --") - TXT("-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --") - TXT("-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --") - TXT("-- for more details. You should have received a copy of the GNU General --") - TXT("-- Public License distributed with GNAT; see file COPYING. If not, write --") - TXT("-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --") - TXT("-- Boston, MA 02110-1301, USA. --") - TXT("-- --") - TXT("-- As a special exception, if other files instantiate generics from this --") - TXT("-- unit, or you link this unit with other files to produce an executable, --") - TXT("-- this unit does not by itself cause the resulting executable to be --") - TXT("-- covered by the GNU General Public License. This exception does not --") - TXT("-- however invalidate any other reasons why the executable file might be --") - TXT("-- covered by the GNU Public License. --") - TXT("-- --") - TXT("-- GNAT was originally developed by the GNAT team at New York University. --") - TXT("-- Extensive contributions were provided by Ada Core Technologies Inc. --") - TXT("-- --") - TXT("------------------------------------------------------------------------------") - _NL - TXT("-- This package provides target dependent definitions of constant for use") - TXT("-- by the GNAT.Sockets package (g-socket.ads). This package should not be") - TXT("-- directly with'ed by an applications program.") - _NL - TXT("-- This is the version for " TARGET) - TXT("-- This file is generated automatically, do not modify it by hand! Instead,") - TXT("-- make changes to gen-soccon.c and re-run it on each target.") - _NL - TXT("package GNAT.Sockets.Constants is") - _NL - TXT(" --------------") - TXT(" -- Families --") - TXT(" --------------") - _NL - - #ifndef AF_INET - #define AF_INET -1 - #endif - CND(AF_INET, "IPv4 address family") - - #ifndef AF_INET6 - #define AF_INET6 -1 - #endif - CND(AF_INET6, "IPv6 address family") - _NL - TXT(" -----------") - TXT(" -- Modes --") - TXT(" -----------") - _NL - - #ifndef SOCK_STREAM - #define SOCK_STREAM -1 - #endif - CND(SOCK_STREAM, "Stream socket") - - #ifndef SOCK_DGRAM - #define SOCK_DGRAM -1 - #endif - CND(SOCK_DGRAM, "Datagram socket") - _NL - TXT(" -------------------") - TXT(" -- Socket errors --") - TXT(" -------------------") - _NL - - #ifndef EACCES - #define EACCES -1 - #endif - CND(EACCES, "Permission denied") - - #ifndef EADDRINUSE - #define EADDRINUSE -1 - #endif - CND(EADDRINUSE, "Address already in use") - - #ifndef EADDRNOTAVAIL - #define EADDRNOTAVAIL -1 - #endif - CND(EADDRNOTAVAIL, "Cannot assign address") - - #ifndef EAFNOSUPPORT - #define EAFNOSUPPORT -1 - #endif - CND(EAFNOSUPPORT, "Addr family not supported") - - #ifndef EALREADY - #define EALREADY -1 - #endif - CND(EALREADY, "Operation in progress") - - #ifndef EBADF - #define EBADF -1 - #endif - CND(EBADF, "Bad file descriptor") - - #ifndef ECONNABORTED - #define ECONNABORTED -1 - #endif - CND(ECONNABORTED, "Connection aborted") - - #ifndef ECONNREFUSED - #define ECONNREFUSED -1 - #endif - CND(ECONNREFUSED, "Connection refused") - - #ifndef ECONNRESET - #define ECONNRESET -1 - #endif - CND(ECONNRESET, "Connection reset by peer") - - #ifndef EDESTADDRREQ - #define EDESTADDRREQ -1 - #endif - CND(EDESTADDRREQ, "Destination addr required") - - #ifndef EFAULT - #define EFAULT -1 - #endif - CND(EFAULT, "Bad address") - - #ifndef EHOSTDOWN - #define EHOSTDOWN -1 - #endif - CND(EHOSTDOWN, "Host is down") - - #ifndef EHOSTUNREACH - #define EHOSTUNREACH -1 - #endif - CND(EHOSTUNREACH, "No route to host") - - #ifndef EINPROGRESS - #define EINPROGRESS -1 - #endif - CND(EINPROGRESS, "Operation now in progress") - - #ifndef EINTR - #define EINTR -1 - #endif - CND(EINTR, "Interrupted system call") - - #ifndef EINVAL - #define EINVAL -1 - #endif - CND(EINVAL, "Invalid argument") - - #ifndef EIO - #define EIO -1 - #endif - CND(EIO, "Input output error") - - #ifndef EISCONN - #define EISCONN -1 - #endif - CND(EISCONN, "Socket already connected") - - #ifndef ELOOP - #define ELOOP -1 - #endif - CND(ELOOP, "Too many symbolic lynks") - - #ifndef EMFILE - #define EMFILE -1 - #endif - CND(EMFILE, "Too many open files") - - #ifndef EMSGSIZE - #define EMSGSIZE -1 - #endif - CND(EMSGSIZE, "Message too long") - - #ifndef ENAMETOOLONG - #define ENAMETOOLONG -1 - #endif - CND(ENAMETOOLONG, "Name too long") - - #ifndef ENETDOWN - #define ENETDOWN -1 - #endif - CND(ENETDOWN, "Network is down") - - #ifndef ENETRESET - #define ENETRESET -1 - #endif - CND(ENETRESET, "Disconn. on network reset") - - #ifndef ENETUNREACH - #define ENETUNREACH -1 - #endif - CND(ENETUNREACH, "Network is unreachable") - - #ifndef ENOBUFS - #define ENOBUFS -1 - #endif - CND(ENOBUFS, "No buffer space available") - - #ifndef ENOPROTOOPT - #define ENOPROTOOPT -1 - #endif - CND(ENOPROTOOPT, "Protocol not available") - - #ifndef ENOTCONN - #define ENOTCONN -1 - #endif - CND(ENOTCONN, "Socket not connected") - - #ifndef ENOTSOCK - #define ENOTSOCK -1 - #endif - CND(ENOTSOCK, "Operation on non socket") - - #ifndef EOPNOTSUPP - #define EOPNOTSUPP -1 - #endif - CND(EOPNOTSUPP, "Operation not supported") - - #ifndef EPFNOSUPPORT - #define EPFNOSUPPORT -1 - #endif - CND(EPFNOSUPPORT, "Unknown protocol family") - - #ifndef EPROTONOSUPPORT - #define EPROTONOSUPPORT -1 - #endif - CND(EPROTONOSUPPORT, "Unknown protocol") - - #ifndef EPROTOTYPE - #define EPROTOTYPE -1 - #endif - CND(EPROTOTYPE, "Unknown protocol type") - - #ifndef ESHUTDOWN - #define ESHUTDOWN -1 - #endif - CND(ESHUTDOWN, "Cannot send once shutdown") - - #ifndef ESOCKTNOSUPPORT - #define ESOCKTNOSUPPORT -1 - #endif - CND(ESOCKTNOSUPPORT, "Socket type not supported") - - #ifndef ETIMEDOUT - #define ETIMEDOUT -1 - #endif - CND(ETIMEDOUT, "Connection timed out") - - #ifndef ETOOMANYREFS - #define ETOOMANYREFS -1 - #endif - CND(ETOOMANYREFS, "Too many references") - - #ifndef EWOULDBLOCK - #define EWOULDBLOCK -1 - #endif - CND(EWOULDBLOCK, "Operation would block") - _NL - TXT(" -----------------") - TXT(" -- Host errors --") - TXT(" -----------------") - _NL - - #ifndef HOST_NOT_FOUND - #define HOST_NOT_FOUND -1 - #endif - CND(HOST_NOT_FOUND, "Unknown host") - - #ifndef TRY_AGAIN - #define TRY_AGAIN -1 - #endif - CND(TRY_AGAIN, "Host name lookup failure") - - #ifndef NO_DATA - #define NO_DATA -1 - #endif - CND(NO_DATA, "No data record for name") - - #ifndef NO_RECOVERY - #define NO_RECOVERY -1 - #endif - CND(NO_RECOVERY, "Non recoverable errors") - _NL - TXT(" -------------------") - TXT(" -- Control flags --") - TXT(" -------------------") - _NL - - #ifndef FIONBIO - #define FIONBIO -1 - #endif - CND(FIONBIO, "Set/clear non-blocking io") - - #ifndef FIONREAD - #define FIONREAD -1 - #endif - CND(FIONREAD, "How many bytes to read") - _NL - TXT(" --------------------") - TXT(" -- Shutdown modes --") - TXT(" --------------------") - _NL - - #ifndef SHUT_RD - #define SHUT_RD -1 - #endif - CND(SHUT_RD, "No more recv") - - #ifndef SHUT_WR - #define SHUT_WR -1 - #endif - CND(SHUT_WR, "No more send") - - #ifndef SHUT_RDWR - #define SHUT_RDWR -1 - #endif - CND(SHUT_RDWR, "No more recv/send") - _NL - TXT(" ---------------------") - TXT(" -- Protocol levels --") - TXT(" ---------------------") - _NL - - #ifndef SOL_SOCKET - #define SOL_SOCKET -1 - #endif - CND(SOL_SOCKET, "Options for socket level") - - #ifndef IPPROTO_IP - #define IPPROTO_IP -1 - #endif - CND(IPPROTO_IP, "Dummy protocol for IP") - - #ifndef IPPROTO_UDP - #define IPPROTO_UDP -1 - #endif - CND(IPPROTO_UDP, "UDP") - - #ifndef IPPROTO_TCP - #define IPPROTO_TCP -1 - #endif - CND(IPPROTO_TCP, "TCP") - _NL - TXT(" -------------------") - TXT(" -- Request flags --") - TXT(" -------------------") - _NL - - #ifndef MSG_OOB - #define MSG_OOB -1 - #endif - CND(MSG_OOB, "Process out-of-band data") - - #ifndef MSG_PEEK - #define MSG_PEEK -1 - #endif - CND(MSG_PEEK, "Peek at incoming data") - - #ifndef MSG_EOR - #define MSG_EOR -1 - #endif - CND(MSG_EOR, "Send end of record") - - #ifndef MSG_WAITALL - #define MSG_WAITALL -1 - #endif - CND(MSG_WAITALL, "Wait for full reception") - - #ifndef MSG_NOSIGNAL - #define MSG_NOSIGNAL -1 - #endif - CND(MSG_NOSIGNAL, "No SIGPIPE on send") - - #ifdef __linux__ - # define MSG_Forced_Flags "MSG_NOSIGNAL" - #else - # define MSG_Forced_Flags "0" - #endif - CN_(MSG_Forced_Flags, "") - TXT(" -- Flags set on all send(2) calls") - - _NL - TXT(" --------------------") - TXT(" -- Socket options --") - TXT(" --------------------") - _NL - - #ifndef TCP_NODELAY - #define TCP_NODELAY -1 - #endif - CND(TCP_NODELAY, "Do not coalesce packets") - - #ifndef SO_REUSEADDR - #define SO_REUSEADDR -1 - #endif - CND(SO_REUSEADDR, "Bind reuse local address") - - #ifndef SO_REUSEPORT - #define SO_REUSEPORT -1 - #endif - CND(SO_REUSEPORT, "Bind reuse port number") - - #ifndef SO_KEEPALIVE - #define SO_KEEPALIVE -1 - #endif - CND(SO_KEEPALIVE, "Enable keep-alive msgs") - - #ifndef SO_LINGER - #define SO_LINGER -1 - #endif - CND(SO_LINGER, "Defer close to flush data") - - #ifndef SO_BROADCAST - #define SO_BROADCAST -1 - #endif - CND(SO_BROADCAST, "Can send broadcast msgs") - - #ifndef SO_SNDBUF - #define SO_SNDBUF -1 - #endif - CND(SO_SNDBUF, "Set/get send buffer size") - - #ifndef SO_RCVBUF - #define SO_RCVBUF -1 - #endif - CND(SO_RCVBUF, "Set/get recv buffer size") - - #ifndef SO_SNDTIMEO - #define SO_SNDTIMEO -1 - #endif - CND(SO_SNDTIMEO, "Emission timeout") - - #ifndef SO_RCVTIMEO - #define SO_RCVTIMEO -1 - #endif - CND(SO_RCVTIMEO, "Reception timeout") - - #ifndef SO_ERROR - #define SO_ERROR -1 - #endif - CND(SO_ERROR, "Get/clear error status") - - #ifndef IP_MULTICAST_IF - #define IP_MULTICAST_IF -1 - #endif - CND(IP_MULTICAST_IF, "Set/get mcast interface") - - #ifndef IP_MULTICAST_TTL - #define IP_MULTICAST_TTL -1 - #endif - CND(IP_MULTICAST_TTL, "Set/get multicast TTL") - - #ifndef IP_MULTICAST_LOOP - #define IP_MULTICAST_LOOP -1 - #endif - CND(IP_MULTICAST_LOOP, "Set/get mcast loopback") - - #ifndef IP_ADD_MEMBERSHIP - #define IP_ADD_MEMBERSHIP -1 - #endif - CND(IP_ADD_MEMBERSHIP, "Join a multicast group") - - #ifndef IP_DROP_MEMBERSHIP - #define IP_DROP_MEMBERSHIP -1 - #endif - CND(IP_DROP_MEMBERSHIP, "Leave a multicast group") - - #ifndef IP_PKTINFO - #define IP_PKTINFO -1 - #endif - CND(IP_PKTINFO, "Get datagram info") - - _NL - TXT(" -------------------") - TXT(" -- System limits --") - TXT(" -------------------") - _NL - - #ifndef IOV_MAX - #define IOV_MAX INT_MAX - #endif - CND(IOV_MAX, "Maximum writev iovcnt") - - _NL - TXT(" ----------------------") - TXT(" -- Type definitions --") - TXT(" ----------------------") - _NL - - { - struct timeval tv; - TXT(" -- Sizes (in bytes) of the components of struct timeval") - _NL - #define SIZEOF_tv_sec (sizeof tv.tv_sec) - CND(SIZEOF_tv_sec, "tv_sec") - #define SIZEOF_tv_usec (sizeof tv.tv_usec) - CND(SIZEOF_tv_usec, "tv_usec") - } - - _NL - TXT(" ----------------------------------------") - TXT(" -- Properties of supported interfaces --") - TXT(" ----------------------------------------") - _NL - - CND(Need_Netdb_Buffer, "Need buffer for Netdb ops") - - #ifdef __vxworks - _NL - TXT(" --------------------------------") - TXT(" -- VxWorks-specific constants --") - TXT(" --------------------------------") - _NL - TXT(" -- These constants may be used only within the VxWorks version of") - TXT(" -- GNAT.Sockets.Thin.") - _NL - - CND(OK, "VxWorks generic success") - CND(ERROR, "VxWorks generic error") - #endif - - #ifdef __MINGW32__ - _NL - TXT(" ------------------------------") - TXT(" -- MinGW-specific constants --") - TXT(" ------------------------------") - _NL - TXT(" -- These constants may be used only within the MinGW version of") - TXT(" -- GNAT.Sockets.Thin.") - _NL - - CND(WSASYSNOTREADY, "System not ready") - CND(WSAVERNOTSUPPORTED, "Version not supported") - CND(WSANOTINITIALISED, "Winsock not intialized") - CND(WSAEDISCON, "Disconnected") - - #endif - - _NL - TXT(" ----------------------") - TXT(" -- Additional flags --") - TXT(" ----------------------") - _NL - TXT(" Thread_Blocking_IO : constant Boolean := True;") - TXT(" -- Set False for contexts where socket i/o are process blocking") - - _NL - TXT("end GNAT.Sockets.Constants;") - - output (); - return 0; - } - - void - output (void) { - int text_max = 0, value_max = 0, l; - struct line *p; - char fmt[64]; - #define UPD_MAX(x) do { \ - l = strlen (p->x); \ - if (l > x ## _max) x ## _max = l; \ - } while (0) - - for (p = first; p != NULL; p = p->next) { - if (p->value != NULL) { - UPD_MAX(text); - UPD_MAX(value); - } - } - sprintf (fmt, " %%-%ds : constant := %%%ds;%%s%%s\n", - text_max, value_max); - - for (p = first; p != NULL; p = p->next) { - if (p->value == NULL) { - printf ("%s\n", p->text); - } else { - char *comment_sep = (strlen (p->comment) > 0) - ? " -- " : ""; - printf (fmt, p->text, p->value, comment_sep, p->comment); - } - } - } - - char * - f_itoa (char *fmt, int n) { - char buf[32], *ret; - sprintf (buf, fmt, n); - ret = malloc (strlen (buf) + 1); - if (ret != NULL) - strcpy (ret, buf); - return ret; - } - - void - add_line (char *_text, char *_value, char *_comment) { - struct line *l = (struct line *) malloc (sizeof (struct line)); - - l->text = _text; - l->value = _value; - l->comment = _comment; - l->next = NULL; - if (last == NULL) - first = last = l; - else { - last->next = l; - last = l; - } - } --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/gigi.h gcc-4.4.0/gcc/ada/gigi.h *** gcc-4.3.3/gcc/ada/gigi.h Sun Jan 13 21:00:39 2008 --- gcc-4.4.0/gcc/ada/gigi.h Thu Jan 1 00:00:00 1970 *************** *** 1,871 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * G I G I * - * * - * C Header File * - * * - * Copyright (C) 1992-2008, 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- * - * ware Foundation; either version 2, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License distributed with GNAT; see file COPYING. If not, write * - * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * - * Boston, MA 02110-1301, USA. * - * * - * As a special exception, if you link this file with other files to * - * produce an executable, this file does not by itself cause the resulting * - * executable to be covered by the GNU General Public License. This except- * - * ion does not however invalidate any other reasons why the executable * - * file might be covered by the GNU Public License. * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - /* Declare all functions and types used by gigi. */ - - /* The largest alignment, in bits, that is needed for using the widest - move instruction. */ - extern unsigned int largest_move_alignment; - - /* Compute the alignment of the largest mode that can be used for copying - objects. */ - extern void gnat_compute_largest_alignment (void); - - /* GNU_TYPE is a type. Determine if it should be passed by reference by - default. */ - extern bool default_pass_by_ref (tree gnu_type); - - /* GNU_TYPE is the type of a subprogram parameter. Determine from the type - if it should be passed by reference. */ - extern bool must_pass_by_ref (tree gnu_type); - - /* Initialize DUMMY_NODE_TABLE. */ - extern void init_dummy_type (void); - - /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a - GCC type corresponding to that entity. GNAT_ENTITY is assumed to - refer to an Ada type. */ - extern tree gnat_to_gnu_type (Entity_Id gnat_entity); - - /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada - entity, this routine returns the equivalent GCC tree for that entity - (an ..._DECL node) and associates the ..._DECL node with the input GNAT - defining identifier. - - If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its - initial value (in GCC tree form). This is optional for variables. - For renamed entities, GNU_EXPR gives the object being renamed. - - DEFINITION is nonzero if this call is intended for a definition. This is - used for separate compilation where it necessary to know whether an - external declaration or a definition should be created if the GCC equivalent - was not created previously. The value of 1 is normally used for a nonzero - DEFINITION, but a value of 2 is used in special circumstances, defined in - the code. */ - extern tree gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, - int definition); - - /* Similar, but if the returned value is a COMPONENT_REF, return the - FIELD_DECL. */ - extern tree gnat_to_gnu_field_decl (Entity_Id gnat_entity); - - /* Wrap up compilation of T, a TYPE_DECL, possibly deferring it. */ - extern void rest_of_type_decl_compilation (tree t); - - /* Start a new statement group chained to the previous group. */ - extern void start_stmt_group (void); - - /* Add GNU_STMT to the current BLOCK_STMT node. */ - extern void add_stmt (tree gnu_stmt); - - /* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */ - extern void add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node); - - /* Return code corresponding to the current code group. It is normally - a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if - BLOCK or cleanups were set. */ - extern tree end_stmt_group (void); - - /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */ - extern void set_block_for_group (tree); - - /* Add a declaration statement for GNU_DECL to the current BLOCK_STMT node. - Get SLOC from GNAT_ENTITY. */ - extern void add_decl_expr (tree gnu_decl, Entity_Id gnat_entity); - - /* Finalize any From_With_Type incomplete types. We do this after processing - our compilation unit and after processing its spec, if this is a body. */ - extern void finalize_from_with_types (void); - - /* Return the equivalent type to be used for GNAT_ENTITY, if it's a - kind of type (such E_Task_Type) that has a different type which Gigi - uses for its representation. If the type does not have a special type - for its representation, return GNAT_ENTITY. If a type is supposed to - exist, but does not, abort unless annotating types, in which case - return Empty. If GNAT_ENTITY is Empty, return Empty. */ - extern Entity_Id Gigi_Equivalent_Type (Entity_Id); - - /* Given GNAT_ENTITY, elaborate all expressions that are required to - be elaborated at the point of its definition, but do nothing else. */ - extern void elaborate_entity (Entity_Id gnat_entity); - - /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark - any entities on its entity chain similarly. */ - extern void mark_out_of_scope (Entity_Id gnat_entity); - - /* Make a dummy type corresponding to GNAT_TYPE. */ - extern tree make_dummy_type (Entity_Id gnat_type); - - /* Get the unpadded version of a GNAT type. */ - extern tree get_unpadded_type (Entity_Id gnat_entity); - - /* Called when we need to protect a variable object using a save_expr. */ - extern tree maybe_variable (tree gnu_operand); - - /* Create a record type that contains a SIZE bytes long field of TYPE with a - starting bit position so that it is aligned to ALIGN bits, and leaving at - least ROOM bytes free before the field. BASE_ALIGN is the alignment the - record is guaranteed to get. */ - extern tree make_aligning_type (tree type, unsigned int align, tree size, - unsigned int base_align, int room); - - /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type - if needed. We have already verified that SIZE and TYPE are large enough. - - GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and - to issue a warning. - - IS_USER_TYPE is true if we must be sure we complete the original type. - - DEFINITION is true if this type is being defined. - - SAME_RM_SIZE is true if the RM_Size of the resulting type is to be - set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original - type. */ - extern tree maybe_pad_type (tree type, tree size, unsigned int align, - Entity_Id gnat_entity, const char *name_trailer, - bool is_user_type, bool definition, - bool same_rm_size); - - /* Given a GNU tree and a GNAT list of choices, generate an expression to test - the value passed against the list of choices. */ - extern tree choices_to_gnu (tree operand, Node_Id choices); - - /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new - type with all size expressions that contain F updated by replacing F - with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if - nothing has changed. */ - extern tree substitute_in_type (tree t, tree f, tree r); - - /* Return the "RM size" of GNU_TYPE. This is the actual number of bits - needed to represent the object. */ - extern tree rm_size (tree gnu_type); - - /* Given GNU_ID, an IDENTIFIER_NODE containing a name, and SUFFIX, a - string, return a new IDENTIFIER_NODE that is the concatenation of - the name in GNU_ID and SUFFIX. */ - extern tree concat_id_with_name (tree gnu_id, const char *suffix); - - /* Return the name to be used for GNAT_ENTITY. If a type, create a - fully-qualified name, possibly with type information encoding. - Otherwise, return the name. */ - extern tree get_entity_name (Entity_Id gnat_entity); - - /* Return a name for GNAT_ENTITY concatenated with two underscores and - SUFFIX. */ - extern tree create_concat_name (Entity_Id gnat_entity, const char *suffix); - - /* If true, then gigi is being called on an analyzed but unexpanded tree, and - the only purpose of the call is to properly annotate types with - representation information. */ - extern bool type_annotate_only; - - /* Current file name without path */ - extern const char *ref_filename; - - /* This structure must be kept synchronized with Call_Back_End. */ - struct File_Info_Type - { - File_Name_Type File_Name; - Nat Num_Source_Lines; - }; - - /* This is the main program of the back-end. It sets up all the table - structures and then generates code. - - ??? Needs parameter descriptions */ - - extern void gigi (Node_Id gnat_root, int max_gnat_node, int number_name, - struct Node *nodes_ptr, Node_Id *next_node_ptr, - Node_Id *prev_node_ptr, struct Elist_Header *elists_ptr, - struct Elmt_Item *elmts_ptr, - struct String_Entry *strings_ptr, - Char_Code *strings_chars_ptr, - struct List_Header *list_headers_ptr, - Nat number_file, - struct File_Info_Type *file_info_ptr ATTRIBUTE_UNUSED, - Entity_Id standard_integer, - Entity_Id standard_long_long_float, - Entity_Id standard_exception_type, - Int gigi_operating_mode); - - /* GNAT_NODE is the root of some GNAT tree. Return the root of the - GCC tree corresponding to that GNAT tree. Normally, no code is generated; - we just return an equivalent tree which is used elsewhere to generate - code. */ - extern tree gnat_to_gnu (Node_Id gnat_node); - - /* GNU_STMT is a statement. We generate code for that statement. */ - extern void gnat_expand_stmt (tree gnu_stmt); - - /* ??? missing documentation */ - extern int gnat_gimplify_expr (tree *expr_p, tree *pre_p, - tree *post_p ATTRIBUTE_UNUSED); - - /* Do the processing for the declaration of a GNAT_ENTITY, a type. If - a separate Freeze node exists, delay the bulk of the processing. Otherwise - make a GCC type for GNAT_ENTITY and set up the correspondence. */ - extern void process_type (Entity_Id gnat_entity); - - /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code - location and false if it doesn't. In the former case, set the Gigi global - variable REF_FILENAME to the simple debug file name as given by sinput. */ - extern bool Sloc_to_locus (Source_Ptr Sloc, location_t *locus); - - /* Post an error message. MSG is the error message, properly annotated. - NODE is the node at which to post the error and the node to use for the - "&" substitution. */ - extern void post_error (const char *, Node_Id); - - /* Similar, but NODE is the node at which to post the error and ENT - is the node to use for the "&" substitution. */ - extern void post_error_ne (const char *msg, Node_Id node, Entity_Id ent); - - /* Similar, but NODE is the node at which to post the error, ENT is the node - to use for the "&" substitution, and N is the number to use for the ^. */ - extern void post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, - int n); - - /* Similar to post_error_ne_num, but T is a GCC tree representing the number - to write. If the tree represents a constant that fits within a - host integer, the text inside curly brackets in MSG will be output - (presumably including a '^'). Otherwise that text will not be output - and the text inside square brackets will be output instead. */ - extern void post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, - tree t); - - /* Similar to post_error_ne_tree, except that NUM is a second - integer to write in the message. */ - extern void post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, - tree t, int num); - - /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */ - extern tree protect_multiple_eval (tree exp); - - /* Return a label to branch to for the exception type in KIND or NULL_TREE - if none. */ - extern tree get_exception_label (char); - - /* Current node being treated, in case gigi_abort or Check_Elaboration_Code - called. */ - extern Node_Id error_gnat_node; - - /* This is equivalent to stabilize_reference in tree.c, but we know how to - handle our own nodes and we take extra arguments. FORCE says whether to - force evaluation of everything. We set SUCCESS to true unless we walk - through something we don't know how to stabilize. */ - extern tree maybe_stabilize_reference (tree ref, bool force, bool *success); - - /* Highest number in the front-end node table. */ - extern int max_gnat_nodes; - - /* If nonzero, pretend we are allocating at global level. */ - extern int force_global; - - /* Standard data type sizes. Most of these are not used. */ - - #ifndef CHAR_TYPE_SIZE - #define CHAR_TYPE_SIZE BITS_PER_UNIT - #endif - - #ifndef SHORT_TYPE_SIZE - #define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2)) - #endif - - #ifndef INT_TYPE_SIZE - #define INT_TYPE_SIZE BITS_PER_WORD - #endif - - #ifndef LONG_TYPE_SIZE - #define LONG_TYPE_SIZE BITS_PER_WORD - #endif - - #ifndef LONG_LONG_TYPE_SIZE - #define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2) - #endif - - #ifndef FLOAT_TYPE_SIZE - #define FLOAT_TYPE_SIZE BITS_PER_WORD - #endif - - #ifndef DOUBLE_TYPE_SIZE - #define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) - #endif - - #ifndef LONG_DOUBLE_TYPE_SIZE - #define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) - #endif - - /* The choice of SIZE_TYPE here is very problematic. We need a signed - type whose bit width is Pmode. Assume "long" is such a type here. */ - #undef SIZE_TYPE - #define SIZE_TYPE "long int" - - /* Data structures used to represent attributes. */ - - enum attr_type - { - ATTR_MACHINE_ATTRIBUTE, - ATTR_LINK_ALIAS, - ATTR_LINK_SECTION, - ATTR_LINK_CONSTRUCTOR, - ATTR_LINK_DESTRUCTOR, - ATTR_WEAK_EXTERNAL - }; - - struct attrib - { - struct attrib *next; - enum attr_type type; - tree name; - tree args; - Node_Id error_point; - }; - - /* Table of machine-independent internal attributes. */ - extern const struct attribute_spec gnat_internal_attribute_table[]; - - /* Define the entries in the standard data array. */ - enum standard_datatypes - { - /* Various standard data types and nodes. */ - ADT_longest_float_type, - ADT_void_type_decl, - - /* The type of an exception. */ - ADT_except_type, - - /* Type declaration node <==> typedef void *T */ - ADT_ptr_void_type, - - /* Function type declaration -- void T() */ - ADT_void_ftype, - - /* Type declaration node <==> typedef void *T() */ - ADT_ptr_void_ftype, - - /* A function declaration node for a run-time function for allocating memory. - Ada allocators cause calls to this function to be generated. */ - ADT_malloc_decl, - - /* Likewise for freeing memory. */ - ADT_free_decl, - - /* Types and decls used by our temporary exception mechanism. See - init_gigi_decls for details. */ - ADT_jmpbuf_type, - ADT_jmpbuf_ptr_type, - ADT_get_jmpbuf_decl, - ADT_set_jmpbuf_decl, - ADT_get_excptr_decl, - ADT_setjmp_decl, - ADT_longjmp_decl, - ADT_update_setjmp_buf_decl, - ADT_raise_nodefer_decl, - ADT_begin_handler_decl, - ADT_end_handler_decl, - ADT_others_decl, - ADT_all_others_decl, - ADT_LAST}; - - extern GTY(()) tree gnat_std_decls[(int) ADT_LAST]; - extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1]; - - #define longest_float_type_node gnat_std_decls[(int) ADT_longest_float_type] - #define void_type_decl_node gnat_std_decls[(int) ADT_void_type_decl] - #define except_type_node gnat_std_decls[(int) ADT_except_type] - #define ptr_void_type_node gnat_std_decls[(int) ADT_ptr_void_type] - #define void_ftype gnat_std_decls[(int) ADT_void_ftype] - #define ptr_void_ftype gnat_std_decls[(int) ADT_ptr_void_ftype] - #define malloc_decl gnat_std_decls[(int) ADT_malloc_decl] - #define free_decl gnat_std_decls[(int) ADT_free_decl] - #define jmpbuf_type gnat_std_decls[(int) ADT_jmpbuf_type] - #define jmpbuf_ptr_type gnat_std_decls[(int) ADT_jmpbuf_ptr_type] - #define get_jmpbuf_decl gnat_std_decls[(int) ADT_get_jmpbuf_decl] - #define set_jmpbuf_decl gnat_std_decls[(int) ADT_set_jmpbuf_decl] - #define get_excptr_decl gnat_std_decls[(int) ADT_get_excptr_decl] - #define setjmp_decl gnat_std_decls[(int) ADT_setjmp_decl] - #define longjmp_decl gnat_std_decls[(int) ADT_longjmp_decl] - #define update_setjmp_buf_decl gnat_std_decls[(int) ADT_update_setjmp_buf_decl] - #define raise_nodefer_decl gnat_std_decls[(int) ADT_raise_nodefer_decl] - #define begin_handler_decl gnat_std_decls[(int) ADT_begin_handler_decl] - #define others_decl gnat_std_decls[(int) ADT_others_decl] - #define all_others_decl gnat_std_decls[(int) ADT_all_others_decl] - #define end_handler_decl gnat_std_decls[(int) ADT_end_handler_decl] - - /* Routines expected by the gcc back-end. They must have exactly the same - prototype and names as below. */ - - /* Returns nonzero if we are currently in the global binding level. */ - extern int global_bindings_p (void); - - /* Enter and exit a new binding level. */ - extern void gnat_pushlevel (void); - extern void gnat_poplevel (void); - - /* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL - and point FNDECL to this BLOCK. */ - extern void set_current_block_context (tree fndecl); - - /* Set the jmpbuf_decl for the current binding level to DECL. */ - extern void set_block_jmpbuf_decl (tree decl); - - /* Get the setjmp_decl, if any, for the current binding level. */ - extern tree get_block_jmpbuf_decl (void); - - /* Insert BLOCK at the end of the list of subblocks of the - current binding level. This is used when a BIND_EXPR is expanded, - to handle the BLOCK node inside the BIND_EXPR. */ - extern void insert_block (tree block); - - /* Records a ..._DECL node DECL as belonging to the current lexical scope - and uses GNAT_NODE for location information. */ - extern void gnat_pushdecl (tree decl, Node_Id gnat_node); - - extern void gnat_init_decl_processing (void); - extern void init_gigi_decls (tree long_long_float_type, tree exception_type); - extern void gnat_init_gcc_eh (void); - - /* Return an integer type with the number of bits of precision given by - PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise - it is a signed type. */ - extern tree gnat_type_for_size (unsigned precision, int unsignedp); - - /* Return a data type that has machine mode MODE. UNSIGNEDP selects - an unsigned type; otherwise a signed type is returned. */ - extern tree gnat_type_for_mode (enum machine_mode mode, int unsignedp); - - /* Emit debug info for all global variable declarations. */ - extern void gnat_write_global_declarations (void); - - /* Return the unsigned version of a TYPE_NODE, a scalar type. */ - extern tree gnat_unsigned_type (tree type_node); - - /* Return the signed version of a TYPE_NODE, a scalar type. */ - extern tree gnat_signed_type (tree type_node); - - /* Create an expression whose value is that of EXPR, - converted to type TYPE. The TREE_TYPE of the value - is always TYPE. This function implements all reasonable - conversions; callers should filter out those that are - not permitted by the language being compiled. */ - extern tree convert (tree type, tree expr); - - /* Routines created solely for the tree translator's sake. Their prototypes - can be changed as desired. */ - - /* GNAT_ENTITY is a GNAT tree node for a defining identifier. - GNU_DECL is the GCC tree which is to be associated with - GNAT_ENTITY. Such gnu tree node is always an ..._DECL node. - If NO_CHECK is nonzero, the latter check is suppressed. - If GNU_DECL is zero, a previous association is to be reset. */ - extern void save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, - bool no_check); - - /* GNAT_ENTITY is a GNAT tree node for a defining identifier. - Return the ..._DECL node that was associated with it. If there is no tree - node associated with GNAT_ENTITY, abort. */ - extern tree get_gnu_tree (Entity_Id gnat_entity); - - /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */ - extern bool present_gnu_tree (Entity_Id gnat_entity); - - /* Initialize tables for above routines. */ - extern void init_gnat_to_gnu (void); - - /* Given a record type RECORD_TYPE and a chain of FIELD_DECL nodes FIELDLIST, - finish constructing the record or union type. If REP_LEVEL is zero, this - record has no representation clause and so will be entirely laid out here. - If REP_LEVEL is one, this record has a representation clause and has been - laid out already; only set the sizes and alignment. If REP_LEVEL is two, - this record is derived from a parent record and thus inherits its layout; - only make a pass on the fields to finalize them. If DO_NOT_FINALIZE is - true, the record type is expected to be modified afterwards so it will - not be sent to the back-end for finalization. */ - extern void finish_record_type (tree record_type, tree fieldlist, - int rep_level, bool do_not_finalize); - - /* Wrap up compilation of RECORD_TYPE, i.e. most notably output all - the debug information associated with it. It need not be invoked - directly in most cases since finish_record_type takes care of doing - so, unless explicitly requested not to through DO_NOT_FINALIZE. */ - extern void rest_of_record_type_compilation (tree record_type); - - /* Returns a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the - subprogram. If it is void_type_node, then we are dealing with a procedure, - otherwise we are dealing with a function. PARAM_DECL_LIST is a list of - PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the - copy-in/copy-out list to be stored into TYPE_CI_CO_LIST. - RETURNS_UNCONSTRAINED is true if the function returns an unconstrained - object. RETURNS_BY_REF is true if the function returns by reference. - RETURNS_WITH_DSP is true if the function is to return with a - depressed stack pointer. RETURNS_BY_TARGET_PTR is true if the function - is to be passed (as its first parameter) the address of the place to copy - its result. */ - extern tree create_subprog_type (tree return_type, tree param_decl_list, - tree cico_list, bool returns_unconstrained, - bool returns_by_ref, bool returns_with_dsp, - bool returns_by_target_ptr); - - /* Return a copy of TYPE, but safe to modify in any way. */ - extern tree copy_type (tree type); - - /* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose - TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position of - the decl. */ - extern tree create_index_type (tree min, tree max, tree index, - Node_Id gnat_node); - - /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character - string) and TYPE is a ..._TYPE node giving its data type. - ARTIFICIAL_P is true if this is a declaration that was generated - by the compiler. DEBUG_INFO_P is true if we need to write debugging - information about this type. GNAT_NODE is used for the position of - the decl. */ - extern tree create_type_decl (tree type_name, tree type, - struct attrib *attr_list, - bool artificial_p, bool debug_info_p, - Node_Id gnat_node); - - /* Returns a GCC VAR_DECL or CONST_DECL node. - - VAR_NAME gives the name of the variable. ASM_NAME is its assembler name - (if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is - the GCC tree for an optional initial expression; NULL_TREE if none. - - CONST_FLAG is true if this variable is constant. - - PUBLIC_FLAG is true if this definition is to be made visible outside of - the current compilation unit. This flag should be set when processing the - variable definitions in a package specification. EXTERN_FLAG is nonzero - when processing an external variable declaration (as opposed to a - definition: no storage is to be allocated for the variable here). - - STATIC_FLAG is only relevant when not at top level. In that case - it indicates whether to always allocate storage to the variable. - - GNAT_NODE is used for the position of the decl. */ - extern tree create_var_decl (tree var_name, tree asm_name, tree type, - tree var_init, bool const_flag, - bool public_flag, bool extern_flag, - bool static_flag, - struct attrib *attr_list, Node_Id gnat_node); - - /* Similar to create_var_decl, forcing the creation of a VAR_DECL node. */ - extern tree create_true_var_decl (tree var_name, tree asm_name, tree type, - tree var_init, bool const_flag, - bool public_flag, bool extern_flag, - bool static_flag, - struct attrib *attr_list, Node_Id gnat_node); - - /* Given a DECL and ATTR_LIST, apply the listed attributes. */ - extern void process_attributes (tree decl, struct attrib *attr_list); - - /* Record a global renaming pointer. */ - void record_global_renaming_pointer (tree); - - /* Invalidate the global renaming pointers. */ - void invalidate_global_renaming_pointers (void); - - /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its - type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if - this field is in a record type with a "pragma pack". If SIZE is nonzero - it is the specified size for this field. If POS is nonzero, it is the bit - position. If ADDRESSABLE is nonzero, it means we are allowed to take - the address of this field for aliasing purposes. */ - extern tree create_field_decl (tree field_name, tree field_type, - tree record_type, int packed, tree size, - tree pos, int addressable); - - /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter, - PARAM_TYPE is its type. READONLY is true if the parameter is - readonly (either an In parameter or an address of a pass-by-ref - parameter). */ - extern tree create_param_decl (tree param_name, tree param_type, - bool readonly); - - /* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram, - ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE - node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of - PARM_DECL nodes chained through the TREE_CHAIN field). - - INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the - appropriate fields in the FUNCTION_DECL. GNAT_NODE gives the location. */ - extern tree create_subprog_decl (tree subprog_name, tree asm_name, - tree subprog_type, tree param_decl_list, - bool inlinee_flag, bool public_flag, - bool extern_flag, - struct attrib *attr_list, Node_Id gnat_node); - - /* Returns a LABEL_DECL node for LABEL_NAME. */ - extern tree create_label_decl (tree label_name); - - /* Set up the framework for generating code for SUBPROG_DECL, a subprogram - body. This routine needs to be invoked before processing the declarations - appearing in the subprogram. */ - extern void begin_subprog_body (tree subprog_decl); - - /* Finish the definition of the current subprogram and compile it all the way - to assembler language output. BODY is the tree corresponding to - the subprogram. */ - extern void end_subprog_body (tree body); - - /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE. - EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs. - Return a constructor for the template. */ - extern tree build_template (tree template_type, tree array_type, tree expr); - - /* Build a VMS descriptor from a Mechanism_Type, which must specify - a descriptor type, and the GCC type of an object. Each FIELD_DECL - in the type contains in its DECL_INITIAL the expression to use when - a constructor is made for the type. GNAT_ENTITY is a gnat node used - to print out an error message if the mechanism cannot be applied to - an object of that type and also for the name. */ - extern tree build_vms_descriptor (tree type, Mechanism_Type mech, - Entity_Id gnat_entity); - - /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG - and the GNAT node GNAT_SUBPROG. */ - extern void build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog); - - /* Build a type to be used to represent an aliased object whose nominal - type is an unconstrained array. This consists of a RECORD_TYPE containing - a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an - ARRAY_TYPE. If ARRAY_TYPE is that of the unconstrained array, this - is used to represent an arbitrary unconstrained object. Use NAME - as the name of the record. */ - extern tree build_unc_object_type (tree template_type, tree object_type, - tree name); - - /* Same as build_unc_object_type, but taking a thin or fat pointer type - instead of the template type. */ - extern tree build_unc_object_type_from_ptr (tree thin_fat_ptr_type, - tree object_type, tree name); - - /* Shift the component offsets within an unconstrained object TYPE to make it - suitable for use as a designated type for thin pointers. */ - extern void shift_unc_components_for_thin_pointers (tree type); - - /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In - the normal case this is just two adjustments, but we have more to do - if NEW is an UNCONSTRAINED_ARRAY_TYPE. */ - extern void update_pointer_to (tree old_type, tree new_type); - - /* EXP is an expression for the size of an object. If this size contains - discriminant references, replace them with the maximum (if MAX_P) or - minimum (if !MAX_P) possible value of the discriminant. */ - extern tree max_size (tree exp, bool max_p); - - /* Remove all conversions that are done in EXP. This includes converting - from a padded type or to a left-justified modular type. If TRUE_ADDRESS - is true, always return the address of the containing object even if - the address is not bit-aligned. */ - extern tree remove_conversions (tree exp, bool true_address); - - /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that - refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P, - likewise return an expression pointing to the underlying array. */ - extern tree maybe_unconstrained_array (tree exp); - - /* Return an expression that does an unchecked conversion of EXPR to TYPE. - If NOTRUNC_P is true, truncation operations should be suppressed. */ - extern tree unchecked_convert (tree type, tree expr, bool notrunc_p); - - /* Return the appropriate GCC tree code for the specified GNAT type, - the latter being a record type as predicated by Is_Record_Type. */ - extern enum tree_code tree_code_for_record_type (Entity_Id); - - /* Return true if GNU_TYPE is suitable as the type of a non-aliased - component of an aggregate type. */ - extern bool type_for_nonaliased_component_p (tree); - - /* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical - operation. - - This preparation consists of taking the ordinary - representation of an expression EXPR and producing a valid tree - boolean expression describing whether EXPR is nonzero. We could - simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1), - but we optimize comparisons, &&, ||, and !. - - The resulting type should always be the same as the input type. - This function is simpler than the corresponding C version since - the only possible operands will be things of Boolean type. */ - extern tree gnat_truthvalue_conversion (tree expr); - - /* Return the base type of TYPE. */ - extern tree get_base_type (tree type); - - /* EXP is a GCC tree representing an address. See if we can find how - strictly the object at that address is aligned. Return that alignment - strictly the object at that address is aligned. Return that alignment - in bits. If we don't know anything about the alignment, return 0. */ - extern unsigned int known_alignment (tree exp); - - /* Return true if VALUE is a multiple of FACTOR. FACTOR must be a power - of 2. */ - extern bool value_factor_p (tree value, HOST_WIDE_INT factor); - - /* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type - desired for the result. Usually the operation is to be performed - in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0 - in which case the type to be used will be derived from the operands. */ - extern tree build_binary_op (enum tree_code op_code, tree retult_type, - tree left_operand, tree right_operand); - - /* Similar, but make unary operation. */ - extern tree build_unary_op (enum tree_code op_code, tree result_type, - tree operand); - - /* Similar, but for COND_EXPR. */ - extern tree build_cond_expr (tree result_type, tree condition_operand, - tree true_operand, tree false_operand); - - /* Similar, but for RETURN_EXPR. */ - extern tree build_return_expr (tree result_decl, tree ret_val); - - /* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return - the CALL_EXPR. */ - extern tree build_call_1_expr (tree fundecl, tree arg); - - /* Build a CALL_EXPR to call FUNDECL with two argument, ARG1 & ARG2. Return - the CALL_EXPR. */ - extern tree build_call_2_expr (tree fundecl, tree arg1, tree arg2); - - /* Likewise to call FUNDECL with no arguments. */ - extern tree build_call_0_expr (tree fundecl); - - /* Call a function that raises an exception and pass the line number and file - name, if requested. MSG says which exception function to call. - - GNAT_NODE is the gnat node conveying the source location for which the - error should be signaled, or Empty in which case the error is signaled on - the current ref_file_name/input_line. - - KIND says which kind of exception this is for - (N_Raise_{Constraint,Storage,Program}_Error). */ - extern tree build_call_raise (int msg, Node_Id gnat_node, char kind); - - /* Return a CONSTRUCTOR of TYPE whose list is LIST. This is not the - same as build_constructor in the language-independent tree.c. */ - extern tree gnat_build_constructor (tree type, tree list); - - /* Return a COMPONENT_REF to access a field that is given by COMPONENT, - an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL, - for the field, or both. Don't fold the result if NO_FOLD_P. */ - extern tree build_component_ref (tree record_variable, tree component, - tree field, bool no_fold_p); - - /* Build a GCC tree to call an allocation or deallocation function. - If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise, - genrate an allocator. - - GNU_SIZE is the size of the object and ALIGN is the alignment. - GNAT_PROC, if present is a procedure to call and GNAT_POOL is the - storage pool to use. If not preset, malloc and free will be used. */ - extern tree build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, - unsigned align, Entity_Id gnat_proc, - Entity_Id gnat_pool, Node_Id gnat_node); - - /* Build a GCC tree to correspond to allocating an object of TYPE whose - initial value if INIT, if INIT is nonzero. Convert the expression to - RESULT_TYPE, which must be some type of pointer. Return the tree. - GNAT_PROC and GNAT_POOL optionally give the procedure to call and - the storage pool to use. GNAT_NODE is used to provide an error - location for restriction violations messages. If IGNORE_INIT_TYPE is - true, ignore the type of INIT for the purpose of determining the size; - this will cause the maximum size to be allocated if TYPE is of - self-referential size. */ - extern tree build_allocator (tree type, tree init, tree result_type, - Entity_Id gnat_proc, Entity_Id gnat_pool, - Node_Id gnat_node, bool); - - /* Fill in a VMS descriptor for EXPR and return a constructor for it. - GNAT_FORMAL is how we find the descriptor record. */ - - extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal); - - /* Indicate that we need to make the address of EXPR_NODE and it therefore - should not be allocated in a register. Return true if successful. */ - extern bool gnat_mark_addressable (tree expr_node); - - /* Implementation of the builtin_function langhook. */ - extern tree gnat_builtin_function (tree decl); - - /* Search the chain of currently reachable declarations for a builtin - FUNCTION_DECL node corresponding to function NAME (an IDENTIFIER_NODE). - Return the first node found, if any, or NULL_TREE otherwise. */ - extern tree builtin_decl_for (tree name ATTRIBUTE_UNUSED); - - /* This function is called by the front end to enumerate all the supported - modes for the machine. We pass a function which is called back with - the following integer parameters: - - FLOAT_P nonzero if this represents a floating-point mode - COMPLEX_P nonzero is this represents a complex mode - COUNT count of number of items, nonzero for vector mode - PRECISION number of bits in data representation - MANTISSA number of bits in mantissa, if FP and known, else zero. - SIZE number of bits used to store data - ALIGN number of bits to which mode is aligned. */ - extern void enumerate_modes (void (*f) (int, int, int, int, int, int, - unsigned int)); - - /* These are temporary function to deal with recent GCC changes related to - FP type sizes and precisions. */ - extern int fp_prec_to_size (int prec); - extern int fp_size_to_prec (int size); - - /* These functions return the basic data type sizes and related parameters - about the target machine. */ - - extern Pos get_target_bits_per_unit (void); - extern Pos get_target_bits_per_word (void); - extern Pos get_target_char_size (void); - extern Pos get_target_wchar_t_size (void); - extern Pos get_target_short_size (void); - extern Pos get_target_int_size (void); - extern Pos get_target_long_size (void); - extern Pos get_target_long_long_size (void); - extern Pos get_target_float_size (void); - extern Pos get_target_double_size (void); - extern Pos get_target_long_double_size (void); - extern Pos get_target_pointer_size (void); - extern Pos get_target_maximum_alignment (void); - extern Pos get_target_default_allocator_alignment (void); - extern Pos get_target_maximum_default_alignment (void); - extern Pos get_target_maximum_allowed_alignment (void); - extern Nat get_float_words_be (void); - extern Nat get_words_be (void); - extern Nat get_bytes_be (void); - extern Nat get_bits_be (void); - extern Nat get_strict_alignment (void); --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/gmem.c gcc-4.4.0/gcc/ada/gmem.c *** gcc-4.3.3/gcc/ada/gmem.c Wed Jun 6 10:30:04 2007 --- gcc-4.4.0/gcc/ada/gmem.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 2000-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 2000-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** *** 50,55 **** --- 49,61 ---- */ + #ifdef VMS + #include + #define xstrdup32(S) strcpy ((__char_ptr32) _malloc32 (strlen (S) + 1), S) + #else + #define xstrdup32(S) S + #endif + #include static FILE *gmemfile; *************** __gnat_convert_addresses (void *addrs[], *** 79,85 **** routine. The latter examines debug info from a provided executable file name to perform the translation into symbolic form of an input sequence of raw binary addresses. It attempts to open the file from the provided name ! "as is", so an an absolute path must be provided to ensure the file is always found. We compute this name once, at initialization time. */ static const char * exename = 0; --- 85,91 ---- routine. The latter examines debug info from a provided executable file name to perform the translation into symbolic form of an input sequence of raw binary addresses. It attempts to open the file from the provided name ! "as is", so an absolute path must be provided to ensure the file is always found. We compute this name once, at initialization time. */ static const char * exename = 0; *************** long long __gnat_gmem_initialize (char * *** 141,148 **** void __gnat_gmem_a2l_initialize (char *exearg) { /* Resolve the executable filename to use in later invocations of ! the libaddr2line symbolization service. */ ! exename = __gnat_locate_exec_on_path (exearg); } /* Read next allocation of deallocation information from the GMEM file and --- 147,156 ---- void __gnat_gmem_a2l_initialize (char *exearg) { /* Resolve the executable filename to use in later invocations of ! the libaddr2line symbolization service. Ensure that on VMS ! exename is allocated in 32 bit memory for compatibility ! with libaddr2line. */ ! exename = xstrdup32 (__gnat_locate_exec_on_path (exearg)); } /* Read next allocation of deallocation information from the GMEM file and diff -Nrcpad gcc-4.3.3/gcc/ada/gnat-style.texi gcc-4.4.0/gcc/ada/gnat-style.texi *** gcc-4.3.3/gcc/ada/gnat-style.texi Wed Jun 6 10:51:44 2007 --- gcc-4.4.0/gcc/ada/gnat-style.texi Fri Feb 20 15:20:38 2009 *************** *** 7,29 **** @c o @c G N A T C O D I N G S T Y L E o @c o ! @c Copyright (C) 1992-2007, AdaCore o ! @c o ! @c GNAT is free software; you can redistribute it and/or modify it under o ! @c terms of the GNU General Public License as published by the Free Soft- o ! @c ware Foundation; either version 2, or (at your option) any later ver- o ! @c sion. GNAT is distributed in the hope that it will be useful, but WITH- o ! @c OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY o ! @c or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License o ! @c for more details. You should have received a copy of the GNU General o ! @c Public License distributed with GNAT; see file COPYING. If not, write o ! @c to the Free Software Foundation, 51 Franklin Street, Fifth Floor, o ! @c Boston, MA 02110-1301, USA. o @c o @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo @setfilename gnat-style.info @settitle GNAT Coding Style @setchapternewpage odd --- 7,29 ---- @c o @c G N A T C O D I N G S T Y L E o @c o ! @c GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). o @c o @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo @setfilename gnat-style.info + @copying + Copyright @copyright{} 1992-2008, Free Software Foundation, Inc. + + Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Free Documentation License, Version 1.2 or + any later version published by the Free Software Foundation; with no + Invariant Sections, with no Front-Cover Texts and with no Back-Cover + Texts. A copy of the license is included in the section entitled + ``GNU Free Documentation License''. + @end copying + @settitle GNAT Coding Style @setchapternewpage odd *************** *** 49,65 **** @page @vskip 0pt plus 1filll ! Copyright @copyright{} 1995-2007, Free Software Foundation ! ! Permission is granted to copy, distribute and/or modify this document ! under the terms of the GNU Free Documentation License, Version 1.1 ! or any later version published by the Free Software Foundation; ! with the Invariant Sections being ``GNU Free Documentation License'', with the ! Front-Cover Texts being ! ``GNAT Coding Style'' and ``A Guide for GNAT Developers'', ! and with no Back-Cover Texts. ! A copy of the license is included in the section entitled ! ``GNU Free Documentation License''. @end titlepage @raisesections --- 49,55 ---- @page @vskip 0pt plus 1filll ! @insertcopying @end titlepage @raisesections *************** A Guide for GNAT Developers *** 76,90 **** GNAT, The GNU Ada Compiler@* @noindent ! Permission is granted to copy, distribute and/or modify this document ! under the terms of the GNU Free Documentation License, Version 1.1 ! or any later version published by the Free Software Foundation; ! with the Invariant Sections being ``GNU Free Documentation License'', with the ! Front-Cover Texts being ! ``GNAT Coding Style'' and ``A Guide for GNAT Developers'' ! and with no Back-Cover Texts. ! A copy of the license is included in the section entitled ! ``GNU Free Documentation License''. @end ifnottex --- 66,72 ---- GNAT, The GNU Ada Compiler@* @noindent ! @insertcopying @end ifnottex diff -Nrcpad gcc-4.3.3/gcc/ada/gnat1drv.adb gcc-4.4.0/gcc/ada/gnat1drv.adb *** gcc-4.3.3/gcc/ada/gnat1drv.adb Thu Dec 13 10:27:21 2007 --- gcc-4.4.0/gcc/ada/gnat1drv.adb Tue Apr 8 06:51:42 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** procedure Gnat1drv is *** 241,251 **** --- 241,253 ---- if List_Representation_Info /= 0 or else List_Representation_Info_Mechanisms then + Set_Standard_Error; Write_Eol; Write_Str ("cannot generate representation information, no code generated"); Write_Eol; Write_Eol; + Set_Standard_Output; end if; end Check_Rep_Info; *************** begin *** 584,589 **** --- 586,592 ---- -- generate code). if Back_End_Mode = Skip then + Set_Standard_Error; Write_Str ("cannot generate code for "); Write_Str ("file "); Write_Name (Unit_File_Name (Main_Unit)); *************** begin *** 627,632 **** --- 630,636 ---- end if; Write_Eol; + Set_Standard_Output; Sem_Ch13.Validate_Unchecked_Conversions; Sem_Ch13.Validate_Address_Clauses; diff -Nrcpad gcc-4.3.3/gcc/ada/gnat_rm.texi gcc-4.4.0/gcc/ada/gnat_rm.texi *** gcc-4.3.3/gcc/ada/gnat_rm.texi Sun Feb 17 21:20:01 2008 --- gcc-4.4.0/gcc/ada/gnat_rm.texi Fri Aug 8 13:00:00 2008 *************** *** 8,22 **** @c o @c G N A T _ RM o @c o - @c Copyright (C) 1995-2007, Free Software Foundation o - @c o - @c o @c GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). o @c o @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo @setfilename gnat_rm.info @set EDITION GNAT @set DEFAULTLANGUAGEVERSION Ada 2005 @set NONDEFAULTLANGUAGEVERSION Ada 95 --- 8,30 ---- @c o @c G N A T _ RM o @c o @c GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). o @c o @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo @setfilename gnat_rm.info + @copying + Copyright @copyright{} 1995-2008, Free Software Foundation, Inc. + + Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Free Documentation License, Version 1.2 or + any later version published by the Free Software Foundation; with no + Invariant Sections, with the Front-Cover Texts being ``GNAT Reference + Manual'', and with no Back-Cover Texts. A copy of the license is + included in the section entitled ``GNU Free Documentation License''. + @end copying + @set EDITION GNAT @set DEFAULTLANGUAGEVERSION Ada 2005 @set NONDEFAULTLANGUAGEVERSION Ada 95 *************** *** 33,50 **** * GNAT Reference Manual: (gnat_rm). Reference Manual for GNU Ada tools. @end direntry - @copying - Copyright @copyright{} 1995-2007, 2008 Free Software Foundation - - Permission is granted to copy, distribute and/or modify this document - under the terms of the GNU Free Documentation License, Version 1.2 - or any later version published by the Free Software Foundation; - with the Invariant Sections being ``GNU Free Documentation License'', - with the Front-Cover Texts being ``GNAT Reference Manual'', and with - no Back-Cover Texts. A copy of the license is included in the section - entitled ``GNU Free Documentation License''. - @end copying - @titlepage @title GNAT Reference Manual @subtitle GNAT, The GNU Ada Compiler --- 41,46 ---- *************** Implementation Defined Pragmas *** 108,114 **** --- 104,112 ---- * Pragma Assert:: * Pragma Ast_Entry:: * Pragma C_Pass_By_Copy:: + * Pragma Check:: * Pragma Check_Name:: + * Pragma Check_Policy:: * Pragma Comment:: * Pragma Common_Object:: * Pragma Compile_Time_Error:: *************** Implementation Defined Pragmas *** 170,178 **** --- 168,179 ---- * Pragma No_Strict_Aliasing :: * Pragma Normalize_Scalars:: * Pragma Obsolescent:: + * Pragma Optimize_Alignment:: * Pragma Passive:: * Pragma Persistent_BSS:: * Pragma Polling:: + * Pragma Postcondition:: + * Pragma Precondition:: * Pragma Profile (Ravenscar):: * Pragma Profile (Restricted):: * Pragma Psect_Object:: *************** Implementation Defined Pragmas *** 198,203 **** --- 199,205 ---- * Pragma Unimplemented_Unit:: * Pragma Universal_Aliasing :: * Pragma Universal_Data:: + * Pragma Unmodified:: * Pragma Unreferenced:: * Pragma Unreferenced_Objects:: * Pragma Unreserve_All_Interrupts:: *************** Implementation Defined Attributes *** 226,237 **** --- 228,241 ---- * Emax:: * Enabled:: * Enum_Rep:: + * Enum_Val:: * Epsilon:: * Fixed_Value:: * Has_Access_Values:: * Has_Discriminants:: * Img:: * Integer_Value:: + * Invalid_Value:: * Large:: * Machine_Size:: * Mantissa:: *************** Implementation Defined Attributes *** 241,246 **** --- 245,251 ---- * Mechanism_Code:: * Null_Parameter:: * Object_Size:: + * Old:: * Passed_By_Reference:: * Pool_Address:: * Range_Length:: *************** The GNAT Library *** 283,294 **** * Ada.Characters.Latin_9 (a-chlat9.ads):: * Ada.Characters.Wide_Latin_1 (a-cwila1.ads):: * Ada.Characters.Wide_Latin_9 (a-cwila9.ads):: ! * Ada.Characters.Wide_Wide_Latin_1 (a-czila1.ads):: ! * Ada.Characters.Wide_Wide_Latin_9 (a-czila9.ads):: ! * Ada.Command_Line.Remove (a-colire.ads):: * Ada.Command_Line.Environment (a-colien.ads):: * Ada.Direct_IO.C_Streams (a-diocst.ads):: * Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads):: * Ada.Exceptions.Traceback (a-exctra.ads):: * Ada.Sequential_IO.C_Streams (a-siocst.ads):: * Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads):: --- 288,301 ---- * Ada.Characters.Latin_9 (a-chlat9.ads):: * Ada.Characters.Wide_Latin_1 (a-cwila1.ads):: * Ada.Characters.Wide_Latin_9 (a-cwila9.ads):: ! * Ada.Characters.Wide_Wide_Latin_1 (a-chzla1.ads):: ! * Ada.Characters.Wide_Wide_Latin_9 (a-chzla9.ads):: * Ada.Command_Line.Environment (a-colien.ads):: + * Ada.Command_Line.Remove (a-colire.ads):: + * Ada.Command_Line.Response_File (a-clrefi.ads):: * Ada.Direct_IO.C_Streams (a-diocst.ads):: * Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads):: + * Ada.Exceptions.Last_Chance_Handler (a-elchha.ads):: * Ada.Exceptions.Traceback (a-exctra.ads):: * Ada.Sequential_IO.C_Streams (a-siocst.ads):: * Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads):: *************** The GNAT Library *** 296,302 **** --- 303,311 ---- * Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads):: * Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO (a-szuzti.ads):: * Ada.Text_IO.C_Streams (a-tiocst.ads):: + * Ada.Wide_Characters.Unicode (a-wichun.ads):: * Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads):: + * Ada.Wide_Wide_Characters.Unicode (a-zchuni.ads):: * Ada.Wide_Wide_Text_IO.C_Streams (a-ztcstr.ads):: * GNAT.Altivec (g-altive.ads):: * GNAT.Altivec.Conversions (g-altcon.ads):: *************** The GNAT Library *** 350,361 **** * GNAT.Most_Recent_Exception (g-moreex.ads):: * GNAT.OS_Lib (g-os_lib.ads):: * GNAT.Perfect_Hash_Generators (g-pehage.ads):: ! * GNAT.Random_Numbers (g-rannum.ads) * GNAT.Regexp (g-regexp.ads):: * GNAT.Registry (g-regist.ads):: * GNAT.Regpat (g-regpat.ads):: * GNAT.Secondary_Stack_Info (g-sestin.ads):: * GNAT.Semaphores (g-semaph.ads):: * GNAT.SHA1 (g-sha1.ads):: * GNAT.Signals (g-signal.ads):: * GNAT.Sockets (g-socket.ads):: --- 359,371 ---- * GNAT.Most_Recent_Exception (g-moreex.ads):: * GNAT.OS_Lib (g-os_lib.ads):: * GNAT.Perfect_Hash_Generators (g-pehage.ads):: ! * GNAT.Random_Numbers (g-rannum.ads):: * GNAT.Regexp (g-regexp.ads):: * GNAT.Registry (g-regist.ads):: * GNAT.Regpat (g-regpat.ads):: * GNAT.Secondary_Stack_Info (g-sestin.ads):: * GNAT.Semaphores (g-semaph.ads):: + * GNAT.Serial_Communications (g-sercom.ads):: * GNAT.SHA1 (g-sha1.ads):: * GNAT.Signals (g-signal.ads):: * GNAT.Sockets (g-socket.ads):: *************** The GNAT Library *** 372,377 **** --- 382,388 ---- * GNAT.Table (g-table.ads):: * GNAT.Task_Lock (g-tasloc.ads):: * GNAT.Threads (g-thread.ads):: + * GNAT.Time_Stamp (g-timsta.ads):: * GNAT.Traceback (g-traceb.ads):: * GNAT.Traceback.Symbolic (g-trasym.ads):: * GNAT.UTF_32 (g-utf_32.ads):: *************** The GNAT Library *** 383,392 **** * Interfaces.C.Extensions (i-cexten.ads):: * Interfaces.C.Streams (i-cstrea.ads):: * Interfaces.CPP (i-cpp.ads):: - * Interfaces.Os2lib (i-os2lib.ads):: - * Interfaces.Os2lib.Errors (i-os2err.ads):: - * Interfaces.Os2lib.Synchronization (i-os2syn.ads):: - * Interfaces.Os2lib.Threads (i-os2thr.ads):: * Interfaces.Packed_Decimal (i-pacdec.ads):: * Interfaces.VxWorks (i-vxwork.ads):: * Interfaces.VxWorks.IO (i-vxwoio.ads):: --- 394,399 ---- *************** The GNAT Library *** 394,399 **** --- 401,408 ---- * System.Assertions (s-assert.ads):: * System.Memory (s-memory.ads):: * System.Partition_Interface (s-parint.ads):: + * System.Pool_Global (s-pooglo.ads):: + * System.Pool_Local (s-pooloc.ads):: * System.Restrictions (s-restri.ads):: * System.Rident (s-rident.ads):: * System.Task_Info (s-tasinf.ads):: *************** Ada 83 compatibility mode. *** 462,469 **** By default, @value{EDITION} assumes @value{DEFAULTLANGUAGEVERSION}, but you can override with a compiler switch to explicitly specify the language version. ! (Please refer to the section ``Compiling Different Versions of Ada'', in ! @cite{@value{EDITION} User's Guide}, for details on these switches.) Throughout this manual, references to ``Ada'' without a year suffix apply to both the Ada 95 and Ada 2005 versions of the language. --- 471,478 ---- By default, @value{EDITION} assumes @value{DEFAULTLANGUAGEVERSION}, but you can override with a compiler switch to explicitly specify the language version. ! (Please refer to @ref{Compiling Different Versions of Ada,,, gnat_ugn, ! @value{EDITION} User's Guide}, for details on these switches.) Throughout this manual, references to ``Ada'' without a year suffix apply to both the Ada 95 and Ada 2005 versions of the language. *************** and @code{classes}. *** 597,606 **** @code{Option flags} @item ! @file{File Names}, @samp{button names}, and @samp{field names}. @item ! @code{Variables}. @item @emph{Emphasis}. --- 606,616 ---- @code{Option flags} @item ! @file{File names}, @samp{button names}, and @samp{field names}. @item ! @code{Variables}, @env{environment variables}, and @var{metasyntactic ! variables}. @item @emph{Emphasis}. *************** See the following documents for further *** 629,636 **** @itemize @bullet @item ! @cite{GNAT User's Guide}, which provides information on how to use ! the GNAT compiler system. @item @cite{Ada 95 Reference Manual}, which contains all reference --- 639,647 ---- @itemize @bullet @item ! @xref{Top, @value{EDITION} User's Guide, About This Guide, gnat_ugn, ! @value{EDITION} User's Guide}, which provides information on how to use the ! GNAT compiler system. @item @cite{Ada 95 Reference Manual}, which contains all reference *************** consideration, the use of these pragmas *** 694,700 **** --- 705,713 ---- * Pragma Assert:: * Pragma Ast_Entry:: * Pragma C_Pass_By_Copy:: + * Pragma Check:: * Pragma Check_Name:: + * Pragma Check_Policy:: * Pragma Comment:: * Pragma Common_Object:: * Pragma Compile_Time_Error:: *************** consideration, the use of these pragmas *** 756,764 **** --- 769,780 ---- * Pragma No_Strict_Aliasing:: * Pragma Normalize_Scalars:: * Pragma Obsolescent:: + * Pragma Optimize_Alignment:: * Pragma Passive:: * Pragma Persistent_BSS:: * Pragma Polling:: + * Pragma Postcondition:: + * Pragma Precondition:: * Pragma Profile (Ravenscar):: * Pragma Profile (Restricted):: * Pragma Psect_Object:: *************** consideration, the use of these pragmas *** 784,789 **** --- 800,806 ---- * Pragma Unimplemented_Unit:: * Pragma Universal_Aliasing :: * Pragma Universal_Data:: + * Pragma Unmodified:: * Pragma Unreferenced:: * Pragma Unreferenced_Objects:: * Pragma Unreserve_All_Interrupts:: *************** Syntax: *** 923,929 **** @smallexample @c ada pragma Assert ( boolean_EXPRESSION ! [, static_string_EXPRESSION]); @end smallexample @noindent --- 940,946 ---- @smallexample @c ada pragma Assert ( boolean_EXPRESSION ! [, string_EXPRESSION]); @end smallexample @noindent *************** Note that, as with the @code{if} stateme *** 962,968 **** type of the expression is either @code{Standard.Boolean}, or any type derived from this standard type. ! If assertions are disabled (switch @code{-gnata} not used), then there is no run-time effect (and in particular, any side effects from the expression will not occur at run time). (The expression is still analyzed at compile time, and may cause types to be frozen if they are --- 979,985 ---- type of the expression is either @code{Standard.Boolean}, or any type derived from this standard type. ! If assertions are disabled (switch @option{-gnata} not used), then there is no run-time effect (and in particular, any side effects from the expression will not occur at run time). (The expression is still analyzed at compile time, and may cause types to be frozen if they are *************** You can also pass records by copy by spe *** 1040,1045 **** --- 1057,1090 ---- @code{Import} and @code{Export} pragmas, which allow specification of passing mechanisms on a parameter by parameter basis. + @node Pragma Check + @unnumberedsec Pragma Check + @cindex Assertions + @cindex Named assertions + @findex Check + @noindent + Syntax: + @smallexample @c ada + pragma Check ( + [Name =>] Identifier, + [Check =>] Boolean_EXPRESSION + [, [Message =>] string_EXPRESSION] ); + @end smallexample + + @noindent + This pragma is similar to the predefined pragma @code{Assert} except that an + extra identifier argument is present. In conjunction with pragma + @code{Check_Policy}, this can be used to define groups of assertions that can + be independently controlled. The identifier @code{Assertion} is special, it + refers to the normal set of pragma @code{Assert} statements. The identifiers + @code{Precondition} and @code{Postcondition} correspond to the pragmas of these + names, so these three names would normally not be used directly in a pragma + @code{Check}. + + Checks introduced by this pragma are normally deactivated by default. They can + be activated either by the command line option @option{-gnata}, which turns on + all checks, or individually controlled using pragma @code{Check_Policy}. + @node Pragma Check_Name @unnumberedsec Pragma Check_Name @cindex Defining check names *************** pragma Check_Name (check_name_IDENTIFIER *** 1055,1061 **** This is a configuration pragma that defines a new implementation defined check name (unless IDENTIFIER matches one of the predefined check names, in which case the pragma has no effect). Check names ! are global to a partition, so if two more more configuration pragmas are present in a partition mentioning the same name, only one new check name is introduced. --- 1100,1106 ---- This is a configuration pragma that defines a new implementation defined check name (unless IDENTIFIER matches one of the predefined check names, in which case the pragma has no effect). Check names ! are global to a partition, so if two or more configuration pragmas are present in a partition mentioning the same name, only one new check name is introduced. *************** and as the prefix of a @code{Check_Name' *** 1066,1073 **** any of these three cases, the check name must be visible. A check name is visible if it is in the configuration pragmas applying to the current unit, or if it appears at the start of any unit that ! is part of the dependency set of the current unit (e.g. units that ! are mentioned in @code{with} clauses. @node Pragma Comment @unnumberedsec Pragma Comment --- 1111,1172 ---- any of these three cases, the check name must be visible. A check name is visible if it is in the configuration pragmas applying to the current unit, or if it appears at the start of any unit that ! is part of the dependency set of the current unit (e.g., units that ! are mentioned in @code{with} clauses). ! ! @node Pragma Check_Policy ! @unnumberedsec Pragma Check_Policy ! @cindex Controlling assertions ! @cindex Assertions, control ! @cindex Check pragma control ! @cindex Named assertions ! @findex Check ! @noindent ! Syntax: ! @smallexample @c ada ! pragma Check_Policy ([Name =>] Identifier, POLICY_IDENTIFIER); ! ! POLICY_IDENTIFIER ::= On | Off | Check | Ignore ! @end smallexample ! ! @noindent ! This pragma is similar to the predefined pragma @code{Assertion_Policy}, ! except that it controls sets of named assertions introduced using the ! @code{Check} pragmas. It can be used as a configuration pragma or (unlike ! @code{Assertion_Policy}) can be used within a declarative part, in which case ! it controls the status to the end of the corresponding construct (in a manner ! identical to pragma @code{Suppress)}. ! ! The identifier given as the first argument corresponds to a name used in ! associated @code{Check} pragmas. For example, if the pragma: ! ! @smallexample @c ada ! pragma Check_Policy (Critical_Error, Off); ! @end smallexample ! ! @noindent ! is given, then subsequent @code{Check} pragmas whose first argument is also ! @code{Critical_Error} will be disabled. The special identifier @code{Assertion} ! controls the behavior of normal @code{Assert} pragmas (thus a pragma ! @code{Check_Policy} with this identifier is similar to the normal ! @code{Assertion_Policy} pragma except that it can appear within a ! declarative part). ! ! The special identifiers @code{Precondition} and @code{Postcondition} control ! the status of preconditions and postconditions. If a @code{Precondition} pragma ! is encountered, it is ignored if turned off by a @code{Check_Policy} specifying ! that @code{Precondition} checks are @code{Off} or @code{Ignored}. Similarly use ! of the name @code{Postcondition} controls whether @code{Postcondition} pragmas ! are recognized. ! ! The check policy is @code{Off} to turn off corresponding checks, and @code{On} ! to turn on corresponding checks. The default for a set of checks for which no ! @code{Check_Policy} is given is @code{Off} unless the compiler switch ! @option{-gnata} is given, which turns on all checks by default. ! ! The check policy settings @code{Check} and @code{Ignore} are also recognized ! as synonyms for @code{On} and @code{Off}. These synonyms are provided for ! compatibility with the standard @code{Assertion_Policy} pragma. @node Pragma Comment @unnumberedsec Pragma Comment *************** expression. The pragma is effective only *** 1140,1146 **** is known at compile time, and has the value True. The set of expressions whose values are known at compile time includes all static boolean expressions, and also other values which the compiler can determine ! at compile time (e.g. the size of a record type set by an explicit size representation clause, or the value of a variable which was initialized to a constant and is known not to have been modified). If these conditions are met, an error message is generated using --- 1239,1245 ---- is known at compile time, and has the value True. The set of expressions whose values are known at compile time includes all static boolean expressions, and also other values which the compiler can determine ! at compile time (e.g., the size of a record type set by an explicit size representation clause, or the value of a variable which was initialized to a constant and is known not to have been modified). If these conditions are met, an error message is generated using *************** pragma Compile_Time_Warning *** 1160,1166 **** @noindent Same as pragma Compile_Time_Error, except a warning is issued instead ! of an error message. @node Pragma Complete_Representation @unnumberedsec Pragma Complete_Representation --- 1259,1273 ---- @noindent Same as pragma Compile_Time_Error, except a warning is issued instead ! of an error message. Note that if this pragma is used in a package that ! is with'ed by a client, the client will get the warning even though it ! is issued by a with'ed package (normally warnings in with'ed units are ! suppressed, but this is a special exception to that rule). ! ! One typical use is within a generic where compile time known characteristics ! of formal parameters are tested, and warnings given appropriately. Another use ! with a first parameter of True is to warn a client about use of a package, ! for example that it is not fully implemented. @node Pragma Complete_Representation @unnumberedsec Pragma Complete_Representation *************** semantics of the pragma is exactly equiv *** 1468,1474 **** corresponding to the argument with a terminating semicolon. Pragmas are permitted in sequences of declarations, so you can use pragma @code{Debug} to intersperse calls to debug procedures in the middle of declarations. Debug ! pragmas can be enabled either by use of the command line switch @code{-gnata} or by use of the configuration pragma @code{Debug_Policy}. @node Pragma Debug_Policy --- 1575,1581 ---- corresponding to the argument with a terminating semicolon. Pragmas are permitted in sequences of declarations, so you can use pragma @code{Debug} to intersperse calls to debug procedures in the middle of declarations. Debug ! pragmas can be enabled either by use of the command line switch @option{-gnata} or by use of the configuration pragma @code{Debug_Policy}. @node Pragma Debug_Policy *************** pragma Debug_Policy (CHECK | IGNORE); *** 1484,1490 **** @noindent If the argument is @code{CHECK}, then pragma @code{DEBUG} is enabled. If the argument is @code{IGNORE}, then pragma @code{DEBUG} is ignored. ! This pragma overrides the effect of the @code{-gnata} switch on the command line. @node Pragma Detect_Blocking --- 1591,1597 ---- @noindent If the argument is @code{CHECK}, then pragma @code{DEBUG} is enabled. If the argument is @code{IGNORE}, then pragma @code{DEBUG} is ignored. ! This pragma overrides the effect of the @option{-gnata} switch on the command line. @node Pragma Detect_Blocking *************** elaboration model used by the compilatio *** 1519,1530 **** pragma. If the parameter is @code{Dynamic}, then the dynamic elaboration model described in the Ada Reference Manual is used, as though ! the @code{-gnatE} switch had been specified on the command line. If the parameter is @code{Static}, then the default GNAT static model is used. This configuration pragma overrides the setting of the command line. For full details on the elaboration models ! used by the GNAT compiler, see section ``Elaboration Order ! Handling in GNAT'' in the @cite{GNAT User's Guide}. @node Pragma Eliminate @unnumberedsec Pragma Eliminate --- 1626,1637 ---- pragma. If the parameter is @code{Dynamic}, then the dynamic elaboration model described in the Ada Reference Manual is used, as though ! the @option{-gnatE} switch had been specified on the command line. If the parameter is @code{Static}, then the default GNAT static model is used. This configuration pragma overrides the setting of the command line. For full details on the elaboration models ! used by the GNAT compiler, see @ref{Elaboration Order Handling in GNAT,,, ! gnat_ugn, @value{EDITION} User's Guide}. @node Pragma Eliminate @unnumberedsec Pragma Eliminate *************** MECHANISM_NAME ::= *** 1722,1727 **** --- 1829,1835 ---- Value | Reference | Descriptor [([Class =>] CLASS_NAME)] + | Short_Descriptor [([Class =>] CLASS_NAME)] CLASS_NAME ::= ubs | ubsb | uba | s | sb | a @end smallexample *************** anonymous access parameter. *** 1754,1759 **** --- 1862,1870 ---- @cindex OpenVMS @cindex Passing by descriptor Passing by descriptor is supported only on the OpenVMS ports of GNAT@. + The default behavior for Export_Function is to accept either 64bit or + 32bit descriptors unless short_descriptor is specified, then only 32bit + descriptors are accepted. @cindex Suppressing external name Special treatment is given if the EXTERNAL is an explicit null *************** MECHANISM_NAME ::= *** 1823,1828 **** --- 1934,1940 ---- Value | Reference | Descriptor [([Class =>] CLASS_NAME)] + | Short_Descriptor [([Class =>] CLASS_NAME)] CLASS_NAME ::= ubs | ubsb | uba | s | sb | a @end smallexample *************** pragma that specifies the desired foreig *** 1840,1845 **** --- 1952,1960 ---- @cindex OpenVMS @cindex Passing by descriptor Passing by descriptor is supported only on the OpenVMS ports of GNAT@. + The default behavior for Export_Procedure is to accept either 64bit or + 32bit descriptors unless short_descriptor is specified, then only 32bit + descriptors are accepted. @cindex Suppressing external name Special treatment is given if the EXTERNAL is an explicit null *************** MECHANISM_NAME ::= *** 1905,1910 **** --- 2020,2026 ---- Value | Reference | Descriptor [([Class =>] CLASS_NAME)] + | Short_Descriptor [([Class =>] CLASS_NAME)] CLASS_NAME ::= ubs | ubsb | uba | s | sb | a @end smallexample *************** pragma that specifies the desired foreig *** 1927,1932 **** --- 2043,2051 ---- @cindex OpenVMS @cindex Passing by descriptor Passing by descriptor is supported only on the OpenVMS ports of GNAT@. + The default behavior for Export_Valued_Procedure is to accept either 64bit or + 32bit descriptors unless short_descriptor is specified, then only 32bit + descriptors are accepted. @cindex Suppressing external name Special treatment is given if the EXTERNAL is an explicit null *************** you can construct your own extension uni *** 1979,1985 **** definition. Note that such a package is a child of @code{System} and thus is considered part of the implementation. To compile it you will have to use the appropriate switch for compiling ! system units. See the GNAT User's Guide for details. @node Pragma External @unnumberedsec Pragma External --- 2098,2105 ---- definition. Note that such a package is a child of @code{System} and thus is considered part of the implementation. To compile it you will have to use the appropriate switch for compiling ! system units. @xref{Top, @value{EDITION} User's Guide, About This ! Guide,, gnat_ugn, @value{EDITION} User's Guide}, for details. @node Pragma External @unnumberedsec Pragma External *************** floating point types declared in the pac *** 2169,2177 **** be @code{IEEE_Float} and the pragma has no effect. On OpenVMS, the argument may be @code{VAX_Float} to specify the use of the VAX float format for the floating-point types in Standard. This requires that ! the standard runtime libraries be recompiled. See the ! description of the @code{GNAT LIBRARY} command in the OpenVMS version ! of the GNAT Users Guide for details on the use of this command. The two argument form specifies the representation to be used for the specified floating-point type. On all systems other than OpenVMS, --- 2289,2297 ---- be @code{IEEE_Float} and the pragma has no effect. On OpenVMS, the argument may be @code{VAX_Float} to specify the use of the VAX float format for the floating-point types in Standard. This requires that ! the standard runtime libraries be recompiled. @xref{The GNAT Run-Time ! Library Builder gnatlbr,,, gnat_ugn, @value{EDITION} User's Guide ! OpenVMS}, for a description of the @code{GNAT LIBRARY} command. The two argument form specifies the representation to be used for the specified floating-point type. On all systems other than OpenVMS, *************** MECHANISM_NAME ::= *** 2352,2357 **** --- 2472,2478 ---- Value | Reference | Descriptor [([Class =>] CLASS_NAME)] + | Short_Descriptor [([Class =>] CLASS_NAME)] CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca @end smallexample *************** is used. *** 2385,2390 **** --- 2506,2513 ---- @cindex OpenVMS @cindex Passing by descriptor Passing by descriptor is supported only on the OpenVMS ports of GNAT@. + The default behavior for Import_Function is to pass a 64bit descriptor + unless short_descriptor is specified, then a 32bit descriptor is passed. @code{First_Optional_Parameter} applies only to OpenVMS ports of GNAT@. It specifies that the designated parameter and all following parameters *************** MECHANISM_NAME ::= *** 2458,2463 **** --- 2581,2587 ---- Value | Reference | Descriptor [([Class =>] CLASS_NAME)] + | Short_Descriptor [([Class =>] CLASS_NAME)] CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca @end smallexample *************** MECHANISM_NAME ::= *** 2504,2509 **** --- 2628,2634 ---- Value | Reference | Descriptor [([Class =>] CLASS_NAME)] + | Short_Descriptor [([Class =>] CLASS_NAME)] CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca @end smallexample *************** See the GNAT users guide for details. *** 2575,2581 **** Note that pragma @code{Initialize_Scalars} is particularly useful in conjunction with the enhanced validity checking that is now provided in GNAT, which checks for invalid values under more conditions. ! Using this feature (see description of the @code{-gnatV} flag in the users guide) in conjunction with pragma @code{Initialize_Scalars} provides a powerful new tool to assist in the detection of problems caused by uninitialized variables. --- 2700,2706 ---- Note that pragma @code{Initialize_Scalars} is particularly useful in conjunction with the enhanced validity checking that is now provided in GNAT, which checks for invalid values under more conditions. ! Using this feature (see description of the @option{-gnatV} flag in the users guide) in conjunction with pragma @code{Initialize_Scalars} provides a powerful new tool to assist in the detection of problems caused by uninitialized variables. *************** pragma Inline_Always (NAME [, NAME]); *** 2599,2605 **** @noindent Similar to pragma @code{Inline} except that inlining is not subject to ! the use of option @code{-gnatn} and the inlining happens regardless of whether this option is used. @node Pragma Inline_Generic --- 2724,2730 ---- @noindent Similar to pragma @code{Inline} except that inlining is not subject to ! the use of option @option{-gnatn} and the inlining happens regardless of whether this option is used. @node Pragma Inline_Generic *************** a handler. *** 2748,2754 **** Note that certain signals on many operating systems cannot be caught and handled by applications. In such cases, the pragma is ignored. See the operating system documentation, or the value of the array @code{Reserved} ! declared in the specification of package @code{System.OS_Interface}. Overriding the default state of signals used by the Ada runtime may interfere with an application's runtime behavior in the cases of the synchronous signals, --- 2873,2879 ---- Note that certain signals on many operating systems cannot be caught and handled by applications. In such cases, the pragma is ignored. See the operating system documentation, or the value of the array @code{Reserved} ! declared in the spec of package @code{System.OS_Interface}. Overriding the default state of signals used by the Ada runtime may interfere with an application's runtime behavior in the cases of the synchronous signals, *************** and causes @var{LOCAL_NAME} to be emitte *** 2916,2922 **** is reserved for @var{LOCAL_NAME} by the assembler and it will be resolved to the same address as @var{static_string_EXPRESSION} by the linker. ! The actual linker name for the target must be used (e.g. the fully encoded name with qualification in Ada, or the mangled name in C++), or it must be declared using the C convention with @code{pragma Import} or @code{pragma Export}. --- 3041,3047 ---- is reserved for @var{LOCAL_NAME} by the assembler and it will be resolved to the same address as @var{static_string_EXPRESSION} by the linker. ! The actual linker name for the target must be used (e.g.@: the fully encoded name with qualification in Ada, or the mangled name in C++), or it must be declared using the C convention with @code{pragma Import} or @code{pragma Export}. *************** at the symbolic level with the compiler. *** 3021,3027 **** Some file formats do not support arbitrary sections so not all target machines support this pragma. The use of this pragma may cause a program execution to be erroneous if it is used to place an entity into an ! inappropriate section (e.g. a modified variable into the @code{.text} section). See also @code{pragma Persistent_BSS}. @smallexample @c ada --- 3146,3152 ---- Some file formats do not support arbitrary sections so not all target machines support this pragma. The use of this pragma may cause a program execution to be erroneous if it is used to place an entity into an ! inappropriate section (e.g.@: a modified variable into the @code{.text} section). See also @code{pragma Persistent_BSS}. @smallexample @c ada *************** type @code{Long_Float} and for floating *** 3058,3066 **** @code{digits} specified in the range 7 through 15. For further details on this pragma, see the @cite{DEC Ada Language Reference Manual}, section 3.5.7b. Note that to use ! this pragma, the standard runtime libraries must be recompiled. See the ! description of the @code{GNAT LIBRARY} command in the OpenVMS version ! of the GNAT User's Guide for details on the use of this command. @node Pragma Machine_Attribute @unnumberedsec Pragma Machine_Attribute --- 3183,3192 ---- @code{digits} specified in the range 7 through 15. For further details on this pragma, see the @cite{DEC Ada Language Reference Manual}, section 3.5.7b. Note that to use ! this pragma, the standard runtime libraries must be recompiled. ! @xref{The GNAT Run-Time Library Builder gnatlbr,,, gnat_ugn, ! @value{EDITION} User's Guide OpenVMS}, for a description of the ! @code{GNAT LIBRARY} command. @node Pragma Machine_Attribute @unnumberedsec Pragma Machine_Attribute *************** in GNU C, where @code{@var{attribute_nam *** 3084,3091 **** target macro @code{TARGET_ATTRIBUTE_TABLE} which is defined for each machine. The optional parameter @var{info} is transformed into an identifier, which may make this pragma unusable for some attributes ! (parameter of some attributes must be a number or a string). See the ! GCC manual for further information. It is not possible to specify attributes defined by other languages, only attributes defined by the machine the code is intended to run on. --- 3210,3219 ---- target macro @code{TARGET_ATTRIBUTE_TABLE} which is defined for each machine. The optional parameter @var{info} is transformed into an identifier, which may make this pragma unusable for some attributes ! (parameter of some attributes must be a number or a string). ! @xref{Target Attributes,, Defining target-specific uses of ! @code{__attribute__}, gccint, GNU Compiler Colletion (GCC) Internals}, ! further information. It is not possible to specify attributes defined by other languages, only attributes defined by the machine the code is intended to run on. *************** strict aliasing optimization for the giv *** 3197,3204 **** arguments is a configuration pragma which applies to all access types declared in units to which the pragma applies. For a detailed description of the strict aliasing optimization, and the situations ! in which it must be suppressed, see section ! ``Optimization and Strict Aliasing'' in the @value{EDITION} User's Guide. @node Pragma Normalize_Scalars @unnumberedsec Pragma Normalize_Scalars --- 3325,3332 ---- arguments is a configuration pragma which applies to all access types declared in units to which the pragma applies. For a detailed description of the strict aliasing optimization, and the situations ! in which it must be suppressed, see @ref{Optimization and Strict ! Aliasing,,, gnat_ugn, @value{EDITION} User's Guide}. @node Pragma Normalize_Scalars @unnumberedsec Pragma Normalize_Scalars *************** Syntax: *** 3285,3291 **** @smallexample @c ada pragma Obsolescent ! (Entity => NAME [, static_string_EXPRESSION [,Ada_05]]); @end smallexample @noindent --- 3413,3419 ---- @smallexample @c ada pragma Obsolescent ! [(Entity => NAME [, static_string_EXPRESSION [,Ada_05]])]; @end smallexample @noindent *************** indication of obsolescence applies only *** 3324,3330 **** mode. This is primarily intended for dealing with the situations in the predefined library where subprograms or packages have become defined as obsolescent in Ada 2005 ! (e.g. in Ada.Characters.Handling), but may be used anywhere. The following examples show typical uses of this pragma: --- 3452,3458 ---- mode. This is primarily intended for dealing with the situations in the predefined library where subprograms or packages have become defined as obsolescent in Ada 2005 ! (e.g.@: in Ada.Characters.Handling), but may be used anywhere. The following examples show typical uses of this pragma: *************** Entity parameter is omitted, then the pr *** 3367,3372 **** --- 3495,3572 ---- immediately preceding the pragma (this form cannot be used for the enumeration literal case). + @node Pragma Optimize_Alignment + @unnumberedsec Pragma Optimize_Alignment + @findex Optimize_Alignment + @cindex Alignment, default settings + @noindent + Syntax: + + @smallexample @c ada + pragma Optimize_Alignment (TIME | SPACE | OFF); + @end smallexample + + @noindent + This is a configuration pragma which affects the choice of default alignments + for types where no alignment is explicitly specified. There is a time/space + trade-off in the selection of these values. Large alignments result in more + efficient code, at the expense of larger data space, since sizes have to be + increased to match these alignments. Smaller alignments save space, but the + access code is slower. The normal choice of default alignments (which is what + you get if you do not use this pragma, or if you use an argument of OFF), + tries to balance these two requirements. + + Specifying SPACE causes smaller default alignments to be chosen in two cases. + First any packed record is given an alignment of 1. Second, if a size is given + for the type, then the alignment is chosen to avoid increasing this size. For + example, consider: + + @smallexample @c ada + type R is record + X : Integer; + Y : Character; + end record; + + for R'Size use 5*8; + @end smallexample + + @noindent + In the default mode, this type gets an alignment of 4, so that access to the + Integer field X are efficient. But this means that objects of the type end up + with a size of 8 bytes. This is a valid choice, since sizes of objects are + allowed to be bigger than the size of the type, but it can waste space if for + example fields of type R appear in an enclosing record. If the above type is + compiled in @code{Optimize_Alignment (Space)} mode, the alignment is set to 1. + + Specifying TIME causes larger default alignments to be chosen in the case of + small types with sizes that are not a power of 2. For example, consider: + + @smallexample @c ada + type R is record + A : Character; + B : Character; + C : Boolean; + end record; + + pragma Pack (R); + for R'Size use 17; + @end smallexample + + @noindent + The default alignment for this record is normally 1, but if this type is + compiled in @code{Optimize_Alignment (Time)} mode, then the alignment is set + to 4, which wastes space for objects of the type, since they are now 4 bytes + long, but results in more efficient access when the whole record is referenced. + + As noted above, this is a configuration pragma, and there is a requirement + that all units in a partition be compiled with a consistent setting of the + optimization setting. This would normally be achieved by use of a configuration + pragma file containing the appropriate setting. The exception to this rule is + that units with an explicit configuration pragma in the same file as the source + unit are excluded from the consistency check, as are all predefined units. The + latter are compiled by default in pragma Optimize_Alignment (Off) mode if no + pragma appears at the start of the file. + @node Pragma Passive @unnumberedsec Pragma Passive @findex Passive *************** targets that do not normally support the *** 3458,3465 **** @code{Poll} in this file makes a call to the appropriate runtime routine to test for an abort condition. ! Note that polling can also be enabled by use of the @code{-gnatP} switch. See ! the @cite{GNAT User's Guide} for details. @node Pragma Profile (Ravenscar) @unnumberedsec Pragma Profile (Ravenscar) --- 3658,3870 ---- @code{Poll} in this file makes a call to the appropriate runtime routine to test for an abort condition. ! Note that polling can also be enabled by use of the @option{-gnatP} switch. ! @xref{Switches for gcc,,, gnat_ugn, @value{EDITION} User's Guide}, for ! details. ! ! @node Pragma Postcondition ! @unnumberedsec Pragma Postcondition ! @cindex Postconditions ! @cindex Checks, postconditions ! @findex Postconditions ! @noindent ! Syntax: ! ! @smallexample @c ada ! pragma Postcondition ( ! [Check =>] Boolean_Expression ! [,[Message =>] String_Expression]); ! @end smallexample ! ! @noindent ! The @code{Postcondition} pragma allows specification of automatic ! postcondition checks for subprograms. These checks are similar to ! assertions, but are automatically inserted just prior to the return ! statements of the subprogram with which they are associated. ! Furthermore, the boolean expression which is the condition which ! must be true may contain references to function'Result in the case ! of a function to refer to the returned value. ! ! @code{Postcondition} pragmas may appear either immediate following the ! (separate) declaration of a subprogram, or at the start of the ! declarations of a subprogram body. Only other pragmas may intervene ! (that is appear between the subprogram declaration and its ! postconditions, or appear before the postcondition in the ! declaration sequence in a subprogram body). In the case of a ! postcondition appearing after a subprogram declaration, the ! formal arguments of the subprogram are visible, and can be ! referenced in the postcondition expressions. ! ! The postconditions are collected and automatically tested just ! before any return (implicit or explicit) in the subprogram body. ! A postcondition is only recognized if postconditions are active ! at the time the pragma is encountered. The compiler switch @option{gnata} ! turns on all postconditions by default, and pragma @code{Check_Policy} ! with an identifier of @code{Postcondition} can also be used to ! control whether postconditions are active. ! ! The general approach is that postconditions are placed in the spec ! if they represent functional aspects which make sense to the client. ! For example we might have: ! ! @smallexample @c ada ! function Direction return Integer; ! pragma Postcondition ! (Direction'Result = +1 ! or else ! Direction'Result = -1); ! @end smallexample ! ! @noindent ! which serves to document that the result must be +1 or -1, and ! will test that this is the case at run time if postcondition ! checking is active. ! ! Postconditions within the subprogram body can be used to ! check that some internal aspect of the implementation, ! not visible to the client, is operating as expected. ! For instance if a square root routine keeps an internal ! counter of the number of times it is called, then we ! might have the following postcondition: ! ! @smallexample @c ada ! Sqrt_Calls : Natural := 0; ! ! function Sqrt (Arg : Float) return Float is ! pragma Postcondition ! (Sqrt_Calls = Sqrt_Calls'Old + 1); ! ... ! end Sqrt ! @end smallexample ! ! @noindent ! As this example, shows, the use of the @code{Old} attribute ! is often useful in postconditions to refer to the state on ! entry to the subprogram. ! ! Note that postconditions are only checked on normal returns ! from the subprogram. If an abnormal return results from ! raising an exception, then the postconditions are not checked. ! ! If a postcondition fails, then the exception ! @code{System.Assertions.Assert_Failure} is raised. If ! a message argument was supplied, then the given string ! will be used as the exception message. If no message ! argument was supplied, then the default message has ! the form "Postcondition failed at file:line". The ! exception is raised in the context of the subprogram ! body, so it is possible to catch postcondition failures ! within the subprogram body itself. ! ! Within a package spec, normal visibility rules ! in Ada would prevent forward references within a ! postcondition pragma to functions defined later in ! the same package. This would introduce undesirable ! ordering constraints. To avoid this problem, all ! postcondition pragmas are analyzed at the end of ! the package spec, allowing forward references. ! ! The following example shows that this even allows ! mutually recursive postconditions as in: ! ! @smallexample @c ada ! package Parity_Functions is ! function Odd (X : Natural) return Boolean; ! pragma Postcondition ! (Odd'Result = ! (x = 1 ! or else ! (x /= 0 and then Even (X - 1)))); ! ! function Even (X : Natural) return Boolean; ! pragma Postcondition ! (Even'Result = ! (x = 0 ! or else ! (x /= 1 and then Odd (X - 1)))); ! ! end Parity_Functions; ! @end smallexample ! ! @noindent ! There are no restrictions on the complexity or form of ! conditions used within @code{Postcondition} pragmas. ! The following example shows that it is even possible ! to verify performance behavior. ! ! @smallexample @c ada ! package Sort is ! ! Performance : constant Float; ! -- Performance constant set by implementation ! -- to match target architecture behavior. ! ! procedure Treesort (Arg : String); ! -- Sorts characters of argument using N*logN sort ! pragma Postcondition ! (Float (Clock - Clock'Old) <= ! Float (Arg'Length) * ! log (Float (Arg'Length)) * ! Performance); ! end Sort; ! @end smallexample ! ! @noindent ! Note: postcondition pragmas associated with subprograms that are ! marked as Inline_Always, or those marked as Inline with front-end ! inlining (-gnatN option set) are accepted and legality-checked ! by the compiler, but are ignored at run-time even if postcondition ! checking is enabled. ! ! @node Pragma Precondition ! @unnumberedsec Pragma Precondition ! @cindex Preconditions ! @cindex Checks, preconditions ! @findex Preconditions ! @noindent ! Syntax: ! ! @smallexample @c ada ! pragma Precondition ( ! [Check =>] Boolean_Expression ! [,[Message =>] String_Expression]); ! @end smallexample ! ! @noindent ! The @code{Precondition} pragma is similar to @code{Postcondition} ! except that the corresponding checks take place immediately upon ! entry to the subprogram, and if a precondition fails, the exception ! is raised in the context of the caller, and the attribute 'Result ! cannot be used within the precondition expression. ! ! Otherwise, the placement and visibility rules are identical to those ! described for postconditions. The following is an example of use ! within a package spec: ! ! @smallexample @c ada ! package Math_Functions is ! ... ! function Sqrt (Arg : Float) return Float; ! pragma Precondition (Arg >= 0.0) ! ... ! end Math_Functions; ! @end smallexample ! ! @noindent ! @code{Precondition} pragmas may appear either immediate following the ! (separate) declaration of a subprogram, or at the start of the ! declarations of a subprogram body. Only other pragmas may intervene ! (that is appear between the subprogram declaration and its ! postconditions, or appear before the postcondition in the ! declaration sequence in a subprogram body). ! ! Note: postcondition pragmas associated with subprograms that are ! marked as Inline_Always, or those marked as Inline with front-end ! inlining (-gnatN option set) are accepted and legality-checked ! by the compiler, but are ignored at run-time even if postcondition ! checking is enabled. ! ! @node Pragma Profile (Ravenscar) @unnumberedsec Pragma Profile (Ravenscar) *************** the Profile (Ravenscar), the value of Ma *** 3521,3527 **** no calls to Task_Identification.Abort_Task. @item No_Asynchronous_Control ! [RM D.7] There are no semantic dependences on the package Asynchronous_Task_Control. @item No_Calendar --- 3926,3932 ---- no calls to Task_Identification.Abort_Task. @item No_Asynchronous_Control ! There are no semantic dependences on the package Asynchronous_Task_Control. @item No_Calendar *************** Detach_Handler, and Reference). *** 3542,3547 **** --- 3947,3956 ---- Protected objects and access types that designate such objects shall be declared only at library level. + @item No_Local_Timing_Events + [RM D.7] All objects of type Ada.Timing_Events.Timing_Event are + declared at the library level. + @item No_Protected_Type_Allocators There are no allocators for protected types or types containing protected subcomponents. *************** Requeue statements are not allowed. *** 3555,3560 **** --- 3964,3973 ---- @item No_Select_Statements There are no select_statements. + @item No_Specific_Termination_Handlers + [RM D.7] There are no calls to Ada.Task_Termination.Set_Specific_Handler + or to Ada.Task_Termination.Specific_Handler. + @item No_Task_Allocators [RM D.7] There are no allocators for task types or types containing task subcomponents. *************** directly on the environment task of the *** 3569,3574 **** --- 3982,3993 ---- @item No_Task_Termination Tasks which terminate are erroneous. + @item No_Unchecked_Conversion + There are no semantic dependencies on the Ada.Unchecked_Conversion package. + + @item No_Unchecked_Deallocation + There are no semantic dependencies on the Ada.Unchecked_Deallocation package. + @item Simple_Barriers Entry barrier condition expressions shall be either static boolean expressions or boolean objects which are declared in *************** A pragma Source_File_Name cannot appear *** 3801,3808 **** @ref{Pragma Source_File_Name_Project}. For more details on the use of the @code{Source_File_Name} pragma, ! see the sections ``Using Other File Names'' and ! ``Alternative File Naming Schemes'' in the @cite{GNAT User's Guide}. @node Pragma Source_File_Name_Project @unnumberedsec Pragma Source_File_Name_Project --- 4220,4228 ---- @ref{Pragma Source_File_Name_Project}. For more details on the use of the @code{Source_File_Name} pragma, ! @xref{Using Other File Names,,, gnat_ugn, @value{EDITION} User's Guide}, ! and @ref{Alternative File Naming Schemes,,, gnat_ugn, @value{EDITION} ! User's Guide}. @node Pragma Source_File_Name_Project @unnumberedsec Pragma Source_File_Name_Project *************** the pragma line (for use in error messag *** 3838,3844 **** information). @var{string_literal} is a static string constant that specifies the file name to be used in error messages and debugging information. This is most notably used for the output of @code{gnatchop} ! with the @code{-r} switch, to make sure that the original unchopped source file is the one referred to. The second argument must be a string literal, it cannot be a static --- 4258,4264 ---- information). @var{string_literal} is a static string constant that specifies the file name to be used in error messages and debugging information. This is most notably used for the output of @code{gnatchop} ! with the @option{-r} switch, to make sure that the original unchopped source file is the one referred to. The second argument must be a string literal, it cannot be a static *************** the @file{gnat.adc} file). *** 3942,3948 **** The form with a string literal specifies which style options are to be activated. These are additive, so they apply in addition to any previously set style check options. The codes for the options are the same as those ! used in the @code{-gnaty} switch to @code{gcc} or @code{gnatmake}. For example the following two methods can be used to enable layout checking: --- 4362,4368 ---- The form with a string literal specifies which style options are to be activated. These are additive, so they apply in addition to any previously set style check options. The codes for the options are the same as those ! used in the @option{-gnaty} switch to @command{gcc} or @command{gnatmake}. For example the following two methods can be used to enable layout checking: *************** gcc -c -gnatyl @dots{} *** 3960,3967 **** @noindent The form ALL_CHECKS activates all standard checks (its use is equivalent ! to the use of the @code{gnaty} switch with no options. See GNAT User's ! Guide for details. The forms with @code{Off} and @code{On} can be used to temporarily disable style checks --- 4380,4388 ---- @noindent The form ALL_CHECKS activates all standard checks (its use is equivalent ! to the use of the @code{gnaty} switch with no options. @xref{Top, ! @value{EDITION} User's Guide, About This Guide, gnat_ugn, ! @value{EDITION} User's Guide}, for details. The forms with @code{Off} and @code{On} can be used to temporarily disable style checks *************** on addresses used in address clauses. Su *** 4026,4031 **** --- 4447,4463 ---- by suppressing range checks, but the specific use of @code{Alignment_Check} allows suppression of alignment checks without suppressing other range checks. + Note that pragma Suppress gives the compiler permission to omit + checks, but does not require the compiler to omit checks. The compiler + will generate checks if they are essentially free, even when they are + suppressed. In particular, if the compiler can prove that a certain + check will necessarily fail, it will generate code to do an + unconditional ``raise'', even if checks are suppressed. The compiler + warns in this case. + + Of course, run-time checks are omitted whenever the compiler can prove + that they will not fail, whether or not checks are suppressed. + @node Pragma Suppress_All @unnumberedsec Pragma Suppress_All @findex Suppress_All *************** The @code{Task_Info} pragma provides sys *** 4100,4106 **** aspects of tasking implementation, for example, the ability to map tasks to specific processors. For details on the facilities available for the version of GNAT that you are using, see the documentation ! in the specification of package System.Task_Info in the runtime library. @node Pragma Task_Name --- 4532,4538 ---- aspects of tasking implementation, for example, the ability to map tasks to specific processors. For details on the facilities available for the version of GNAT that you are using, see the documentation ! in the spec of package System.Task_Info in the runtime library. @node Pragma Task_Name *************** declarative part. The effect is to inhi *** 4277,4284 **** optimization for the given type. In other words, the effect is as though access types designating this type were subject to pragma No_Strict_Aliasing. For a detailed description of the strict aliasing optimization, and the ! situations in which it must be suppressed, see section ! ``Optimization and Strict Aliasing'' in the @value{EDITION} User's Guide. @node Pragma Universal_Data @unnumberedsec Pragma Universal_Data --- 4709,4716 ---- optimization for the given type. In other words, the effect is as though access types designating this type were subject to pragma No_Strict_Aliasing. For a detailed description of the strict aliasing optimization, and the ! situations in which it must be suppressed, @xref{Optimization and Strict ! Aliasing,,, gnat_ugn, @value{EDITION} User's Guide}. @node Pragma Universal_Data @unnumberedsec Pragma Universal_Data *************** a library unit pragma, but can also be u *** 4304,4309 **** --- 4736,4766 ---- of this pragma is also available by applying the -univ switch on the compilations of units where universal addressing of the data is desired. + @node Pragma Unmodified + @unnumberedsec Pragma Unmodified + @findex Unmodified + @cindex Warnings, unmodified + @noindent + Syntax: + + @smallexample @c ada + pragma Unmodified (LOCAL_NAME @{, LOCAL_NAME@}); + @end smallexample + + @noindent + This pragma signals that the assignable entities (variables, + @code{out} parameters, @code{in out} parameters) whose names are listed are + deliberately not assigned in the current source unit. This + suppresses warnings about the + entities being referenced but not assigned, and in addition a warning will be + generated if one of these entities is in fact assigned in the + same unit as the pragma (or in the corresponding body, or one + of its subunits). + + This is particularly useful for clearly signaling that a particular + parameter is not modified, even though the spec suggests that it might + be. + @node Pragma Unreferenced @unnumberedsec Pragma Unreferenced @findex Unreferenced *************** functions. For example, if this pragma *** 4403,4409 **** a program can then handle the @code{SIGINT} interrupt as it chooses. For a full list of the interrupts handled in a specific implementation, ! see the source code for the specification of @code{Ada.Interrupts.Names} in file @file{a-intnam.ads}. This is a target dependent file that contains the list of interrupts recognized for a given target. The documentation in this file also specifies what interrupts are affected by the use of --- 4860,4866 ---- a program can then handle the @code{SIGINT} interrupt as it chooses. For a full list of the interrupts handled in a specific implementation, ! see the source code for the spec of @code{Ada.Interrupts.Names} in file @file{a-intnam.ads}. This is a target dependent file that contains the list of interrupts recognized for a given target. The documentation in this file also specifies what interrupts are affected by the use of *************** The form with a string literal specifies *** 4478,4484 **** activated. The validity checks are first set to include only the default reference manual settings, and then a string of letters in the string specifies the exact set of options required. The form of this string ! is exactly as described for the @code{-gnatVx} compiler switch (see the GNAT users guide for details). For example the following two methods can be used to enable validity checking for mode @code{in} and @code{in out} subprogram parameters: --- 4935,4941 ---- activated. The validity checks are first set to include only the default reference manual settings, and then a string of letters in the string specifies the exact set of options required. The form of this string ! is exactly as described for the @option{-gnatVx} compiler switch (see the GNAT users guide for details). For example the following two methods can be used to enable validity checking for mode @code{in} and @code{in out} subprogram parameters: *************** control over which warnings are active. *** 4565,4622 **** specifying which warnings are to be activated and which deactivated. The code for these letters is the same as the string used in the command line switch controlling warnings. The following is a brief summary. For ! full details see the GNAT Users Guide: @smallexample ! a turn on all optional warnings (except d,h,l) ! A turn off all optional warnings ! b turn on warnings for bad fixed value (not multiple of small) ! B turn off warnings for bad fixed value (not multiple of small) ! c turn on warnings for constant conditional ! C turn off warnings for constant conditional ! d turn on warnings for implicit dereference ! D turn off warnings for implicit dereference ! e treat all warnings as errors ! f turn on warnings for unreferenced formal ! F turn off warnings for unreferenced formal ! g turn on warnings for unrecognized pragma ! G turn off warnings for unrecognized pragma ! h turn on warnings for hiding variable ! H turn off warnings for hiding variable ! i turn on warnings for implementation unit ! I turn off warnings for implementation unit ! j turn on warnings for obsolescent (annex J) feature ! J turn off warnings for obsolescent (annex J) feature ! k turn on warnings on constant variable ! K turn off warnings on constant variable ! l turn on warnings for missing elaboration pragma ! L turn off warnings for missing elaboration pragma ! m turn on warnings for variable assigned but not read ! M turn off warnings for variable assigned but not read ! n normal warning mode (cancels -gnatws/-gnatwe) ! o turn on warnings for address clause overlay ! O turn off warnings for address clause overlay ! p turn on warnings for ineffective pragma Inline ! P turn off warnings for ineffective pragma Inline ! q turn on warnings for questionable missing parentheses ! Q turn off warnings for questionable missing parentheses ! r turn on warnings for redundant construct ! R turn off warnings for redundant construct ! s suppress all warnings ! t turn on warnings for tracking deleted code ! T turn off warnings for tracking deleted code ! u turn on warnings for unused entity ! U turn off warnings for unused entity ! v turn on warnings for unassigned variable ! V turn off warnings for unassigned variable ! w turn on warnings for wrong low bound assumption ! W turn off warnings for wrong low bound assumption ! x turn on warnings for export/import ! X turn off warnings for export/import ! y turn on warnings for Ada 2005 incompatibility ! Y turn off warnings for Ada 2005 incompatibility ! z turn on size/align warnings for unchecked conversion ! Z turn off size/align warnings for unchecked conversion @end smallexample @noindent --- 5022,5091 ---- specifying which warnings are to be activated and which deactivated. The code for these letters is the same as the string used in the command line switch controlling warnings. The following is a brief summary. For ! full details see @ref{Warning Message Control,,, gnat_ugn, @value{EDITION} ! User's Guide}. @smallexample ! a turn on all optional warnings (except d h l .o) ! A turn off all optional warnings ! .a* turn on warnings for failing assertions ! .A turn off warnings for failing assertions ! b turn on warnings for bad fixed value (not multiple of small) ! B* turn off warnings for bad fixed value (not multiple of small) ! c turn on warnings for constant conditional ! C* turn off warnings for constant conditional ! .c turn on warnings for unrepped components ! .C* turn off warnings for unrepped components ! d turn on warnings for implicit dereference ! D* turn off warnings for implicit dereference ! e treat all warnings as errors ! f turn on warnings for unreferenced formal ! F* turn off warnings for unreferenced formal ! g* turn on warnings for unrecognized pragma ! G turn off warnings for unrecognized pragma ! h turn on warnings for hiding variable ! H* turn off warnings for hiding variable ! i* turn on warnings for implementation unit ! I turn off warnings for implementation unit ! j turn on warnings for obsolescent (annex J) feature ! J* turn off warnings for obsolescent (annex J) feature ! k turn on warnings on constant variable ! K* turn off warnings on constant variable ! l turn on warnings for missing elaboration pragma ! L* turn off warnings for missing elaboration pragma ! m turn on warnings for variable assigned but not read ! M* turn off warnings for variable assigned but not read ! n* normal warning mode (cancels -gnatws/-gnatwe) ! o* turn on warnings for address clause overlay ! O turn off warnings for address clause overlay ! .o turn on warnings for out parameters assigned but not read ! .O* turn off warnings for out parameters assigned but not read ! p turn on warnings for ineffective pragma Inline in frontend ! P* turn off warnings for ineffective pragma Inline in frontend ! q* turn on warnings for questionable missing parentheses ! Q turn off warnings for questionable missing parentheses ! r turn on warnings for redundant construct ! R* turn off warnings for redundant construct ! .r turn on warnings for object renaming function ! .R* turn off warnings for object renaming function ! s suppress all warnings ! t turn on warnings for tracking deleted code ! T* turn off warnings for tracking deleted code ! u turn on warnings for unused entity ! U* turn off warnings for unused entity ! v* turn on warnings for unassigned variable ! V turn off warnings for unassigned variable ! w* turn on warnings for wrong low bound assumption ! W turn off warnings for wrong low bound assumption ! x* turn on warnings for export/import ! X turn off warnings for export/import ! .x turn on warnings for non-local exceptions ! .X* turn off warnings for non-local exceptions ! y* turn on warnings for Ada 2005 incompatibility ! Y turn off warnings for Ada 2005 incompatibility ! z* turn on convention/size/align warnings for unchecked conversion ! Z turn off convention/size/align warnings for unchecked conversion ! * indicates default in above list @end smallexample @noindent *************** control individual messages, based on th *** 4632,4643 **** is a pattern that is used to match against the text of individual warning messages (not including the initial "warnings: " tag). ! The pattern may start with an asterisk, which matches otherwise unmatched ! characters at the start of the message, and it may also end with an asterisk ! which matches otherwise unmatched characters at the end of the message. For ! example, the string "*alignment*" could be used to match any warnings about ! alignment problems. Within the string, the sequence "*" can be used to match ! any sequence of characters enclosed in quotation marks. No other regular expression notations are permitted. All characters other than asterisk in these three specific cases are treated as literal characters in the match. --- 5101,5110 ---- is a pattern that is used to match against the text of individual warning messages (not including the initial "warnings: " tag). ! The pattern may contain asterisks which match zero or more characters in ! the message. For example, you can use ! @code{pragma Warnings (Off, "*bits of*unused")} to suppress the warning ! message @code{warning: 960 bits of "a" unused}. No other regular expression notations are permitted. All characters other than asterisk in these three specific cases are treated as literal characters in the match. *************** pragmas must appear in sequence: *** 4650,4656 **** @smallexample @c ada pragma Warnings (Off, Pattern); ! .. code where given warning is to be suppressed pragma Warnings (On, Pattern); @end smallexample --- 5117,5123 ---- @smallexample @c ada pragma Warnings (Off, Pattern); ! @dots{} code where given warning is to be suppressed pragma Warnings (On, Pattern); @end smallexample *************** to appear within the same file. *** 4729,4735 **** The argument can be an identifier or a character literal. In the identifier case, it is one of @code{HEX}, @code{UPPER}, @code{SHIFT_JIS}, @code{EUC}, @code{UTF8}, or @code{BRACKETS}. In the character literal ! case it is correspondingly one of the characters h,u,s,e,8,b. Note that when the pragma is used within a file, it affects only the encoding within that file, and does not affect withed units, specs, --- 5196,5203 ---- The argument can be an identifier or a character literal. In the identifier case, it is one of @code{HEX}, @code{UPPER}, @code{SHIFT_JIS}, @code{EUC}, @code{UTF8}, or @code{BRACKETS}. In the character literal ! case it is correspondingly one of the characters @samp{h}, @samp{u}, ! @samp{s}, @samp{e}, @samp{8}, or @samp{b}. Note that when the pragma is used within a file, it affects only the encoding within that file, and does not affect withed units, specs, *************** consideration, you should minimize the u *** 4770,4781 **** --- 5238,5251 ---- * Emax:: * Enabled:: * Enum_Rep:: + * Enum_Val:: * Epsilon:: * Fixed_Value:: * Has_Access_Values:: * Has_Discriminants:: * Img:: * Integer_Value:: + * Invalid_Value:: * Large:: * Machine_Size:: * Mantissa:: *************** consideration, you should minimize the u *** 4785,4790 **** --- 5255,5261 ---- * Mechanism_Code:: * Null_Parameter:: * Object_Size:: + * Old:: * Passed_By_Reference:: * Pool_Address:: * Range_Length:: *************** error. *** 4993,4999 **** @noindent This attribute can only be applied to a program unit name. It returns the entity for the corresponding elaboration procedure for elaborating ! the specification of the referenced unit. This is used in the main generated elaboration procedure by the binder and is not normally used in any other context. However, there may be specialized situations in which it is useful to be able to call this elaboration procedure from --- 5464,5470 ---- @noindent This attribute can only be applied to a program unit name. It returns the entity for the corresponding elaboration procedure for elaborating ! the spec of the referenced unit. This is used in the main generated elaboration procedure by the binder and is not normally used in any other context. However, there may be specialized situations in which it is useful to be able to call this elaboration procedure from *************** integer type, and the argument is a vari *** 5065,5070 **** --- 5536,5562 ---- integer calculation is done at run time, then the call to @code{Enum_Rep} may raise @code{Constraint_Error}. + @node Enum_Val + @unnumberedsec Enum_Val + @cindex Representation of enums + @findex Enum_Val + @noindent + For every enumeration subtype @var{S}, @code{@var{S}'Enum_Rep} denotes a + function with the following spec: + + @smallexample @c ada + function @var{S}'Enum_Rep (Arg : @i{Universal_Integer) + return @var{S}'Base}; + @end smallexample + + @noindent + The function returns the enumeration value whose representation matches the + argument, or raises Constraint_Error if no enumeration literal of the type + has the matching value. + This will be equal to value of the @code{Val} attribute in the + absence of an enumeration representation clause. This is a static + attribute (i.e.@: the result is static if the argument is static). + @node Epsilon @unnumberedsec Epsilon @cindex Ada 83 attributes *************** that there are full range checks, to ens *** 5176,5181 **** --- 5668,5684 ---- This attribute is primarily intended for use in implementation of the standard input-output functions for fixed-point values. + @node Invalid_Value + @unnumberedsec Invalid_Value + @findex Invalid_Value + @noindent + For every scalar type S, S'Invalid_Value returns an undefined value of the + type. If possible this value is an invalid representation for the type. The + value returned is identical to the value used to initialize an otherwise + uninitialized value of the type if pragma Initialize_Scalars is used, + including the ability to modify the value with the binder -Sxx flag and + relevant environment variables at run time. + @node Large @unnumberedsec Large @cindex Ada 83 attributes *************** alignment will be 4, because of the *** 5313,5351 **** integer field, and so the default size of record objects for this type will be 64 (8 bytes). ! The @code{@var{type}'Object_Size} attribute ! has been added to GNAT to allow the ! default object size of a type to be easily determined. For example, ! @code{Natural'Object_Size} is 32, and ! @code{Rec'Object_Size} (for the record type in the above example) will be ! 64. Note also that, unlike the situation with the ! @code{Size} attribute as defined in the Ada RM, the ! @code{Object_Size} attribute can be specified individually ! for different subtypes. For example: @smallexample @c ada ! type R is new Integer; ! subtype R1 is R range 1 .. 10; ! subtype R2 is R range 1 .. 10; ! for R2'Object_Size use 8; @end smallexample @noindent ! In this example, @code{R'Object_Size} and @code{R1'Object_Size} are both ! 32 since the default object size for a subtype is the same as the object size ! for the parent subtype. This means that objects of type @code{R} ! or @code{R1} will ! by default be 32 bits (four bytes). But objects of type ! @code{R2} will be only ! 8 bits (one byte), since @code{R2'Object_Size} has been set to 8. ! ! Although @code{Object_Size} does properly reflect the default object size ! value, it is not necessarily the case that all objects will be of this size ! in a case where it is not specified explicitly. The compiler is free to ! increase the size and alignment of stand alone objects to improve efficiency ! of the generated code and sometimes does so in the case of large composite ! objects. If the size of a stand alone object is critical to the ! application, it should be specified explicitly. @node Passed_By_Reference @unnumberedsec Passed_By_Reference --- 5816,5865 ---- integer field, and so the default size of record objects for this type will be 64 (8 bytes). ! @node Old ! @unnumberedsec Old ! @cindex Capturing Old values ! @cindex Postconditions ! @noindent ! The attribute Prefix'Old can be used within a ! subprogram to refer to the value of the prefix on entry. So for ! example if you have an argument of a record type X called Arg1, ! you can refer to Arg1.Field'Old which yields the value of ! Arg1.Field on entry. The implementation simply involves generating ! an object declaration which captures the value on entry. Any ! prefix is allowed except one of a limited type (since limited ! types cannot be copied to capture their values) or a local variable ! (since it does not exist at subprogram entry time). ! ! The following example shows the use of 'Old to implement ! a test of a postcondition: @smallexample @c ada ! with Old_Pkg; ! procedure Old is ! begin ! Old_Pkg.Incr; ! end Old; ! ! package Old_Pkg is ! procedure Incr; ! end Old_Pkg; ! ! package body Old_Pkg is ! Count : Natural := 0; ! ! procedure Incr is ! begin ! ... code manipulating the value of Count ! ! pragma Assert (Count = Count'Old + 1); ! end Incr; ! end Old_Pkg; @end smallexample @noindent ! Note that it is allowed to apply 'Old to a constant entity, but this will ! result in a warning, since the old and new values will always be the same. @node Passed_By_Reference @unnumberedsec Passed_By_Reference *************** $ mv s-strxdr.adb s-stratt.adb *** 6381,6388 **** @end smallexample @item ! Rebuild the GNAT run-time library as documented in the ! @cite{GNAT User's Guide} @end enumerate @unnumberedsec A.1(52): Names of Predefined Numeric Types --- 6895,6902 ---- @end smallexample @item ! Rebuild the GNAT run-time library as documented in ! @ref{GNAT and Libraries,,, gnat_ugn, @value{EDITION} User's Guide}. @end enumerate @unnumberedsec A.1(52): Names of Predefined Numeric Types *************** There are no such limits. *** 7348,7354 **** @sp 1 @cartouche @noindent ! @strong{27}. Whether or not two non overlapping parts of a composite object are independently addressable, in the case where packing, record layout, or @code{Component_Size} is specified for the object. See 9.10(1). --- 7862,7868 ---- @sp 1 @cartouche @noindent ! @strong{27}. Whether or not two non-overlapping parts of a composite object are independently addressable, in the case where packing, record layout, or @code{Component_Size} is specified for the object. See 9.10(1). *************** overlapping storage units. *** 7364,7370 **** @end cartouche @noindent A compilation is represented by a sequence of files presented to the ! compiler in a single invocation of the @code{gcc} command. @sp 1 @cartouche --- 7878,7884 ---- @end cartouche @noindent A compilation is represented by a sequence of files presented to the ! compiler in a single invocation of the @command{gcc} command. @sp 1 @cartouche *************** mentioned in the context clause of one o *** 7405,7416 **** If the partition contains no main program, or if the main program is in a language other than Ada, then GNAT ! provides the binder options @code{-z} and @code{-n} respectively, and in this case a list of units can be explicitly supplied to the binder for inclusion in the partition (all units needed by these units will also be included automatically). For full details on the use of these ! options, refer to the @cite{GNAT User's Guide} sections on Binding ! and Linking. @sp 1 @cartouche --- 7919,7930 ---- If the partition contains no main program, or if the main program is in a language other than Ada, then GNAT ! provides the binder options @option{-z} and @option{-n} respectively, and in this case a list of units can be explicitly supplied to the binder for inclusion in the partition (all units needed by these units will also be included automatically). For full details on the use of these ! options, refer to @ref{The GNAT Make Program gnatmake,,, gnat_ugn, ! @value{EDITION} User's Guide}. @sp 1 @cartouche *************** is made to queue more than the specified *** 7769,7774 **** --- 8283,8300 ---- This restriction ensures at compile time that there is no implicit or explicit dependence on the package @code{Ada.Calendar}. + @item No_Default_Initialization + @findex No_Default_Initialization + + This restriction prohibits any instance of default initialization of variables. + The binder implements a consistency rule which prevents any unit compiled + without the restriction from with'ing a unit with the restriction (this allows + the generation of initialization procedures to be skipped, since you can be + sure that no call is ever generated to an initialization procedure in a unit + with the restriction active). If used in conjunction with Initialize_Scalars or + Normalize_Scalars, the effect is to prohibit all cases of variables declared + without a specific initializer (including the case of OUT scalar parameters). + @item No_Direct_Boolean_Operators @findex No_Direct_Boolean_Operators This restriction ensures that no logical (and/or/xor) or comparison *************** be provided. In this mode, exceptions ma *** 7859,7873 **** an immediate call to the last chance handler, a routine that the user must define with the following profile: ! procedure Last_Chance_Handler ! (Source_Location : System.Address; Line : Integer); ! pragma Export (C, Last_Chance_Handler, ! "__gnat_last_chance_handler"); ! The parameter is a C null-terminated string representing a message to be ! associated with the exception (typically the source location of the raise ! statement generated by the compiler). The Line parameter when nonzero ! represents the line number in the source program where the raise occurs. @item No_Exception_Propagation @findex No_Exception_Propagation --- 8385,8401 ---- an immediate call to the last chance handler, a routine that the user must define with the following profile: ! @smallexample @c ada ! procedure Last_Chance_Handler ! (Source_Location : System.Address; Line : Integer); ! pragma Export (C, Last_Chance_Handler, ! "__gnat_last_chance_handler"); ! @end smallexample ! The parameter is a C null-terminated string representing a message to be ! associated with the exception (typically the source location of the raise ! statement generated by the compiler). The Line parameter when nonzero ! represents the line number in the source program where the raise occurs. @item No_Exception_Propagation @findex No_Exception_Propagation *************** of composite objects and the Max/Min att *** 7902,7907 **** --- 8430,8436 ---- @item No_Implicit_Dynamic_Code @findex No_Implicit_Dynamic_Code + @cindex trampoline This restriction prevents the compiler from building ``trampolines''. This is a structure that is built on the stack and contains dynamic code to be executed at run time. On some targets, a trampoline is *************** nested task bodies; primitive operations *** 7911,7916 **** --- 8440,8456 ---- Trampolines do not work on machines that prevent execution of stack data. For example, on windows systems, enabling DEP (data execution protection) will cause trampolines to raise an exception. + Trampolines are also quite slow at run time. + + On many targets, trampolines have been largely eliminated. Look at the + version of system.ads for your target --- if it has + Always_Compatible_Rep equal to False, then trampolines are largely + eliminated. In particular, a trampoline is built for the following + features: @code{Address} of a nested subprogram; + @code{Access} or @code{Unrestricted_Access} of a nested subprogram, + but only if pragma Favor_Top_Level applies, or the access type has a + foreign-language convention; primitive operations of nested tagged + types. @item No_Implicit_Loops @findex No_Implicit_Loops *************** letters. *** 8344,8354 **** @end cartouche @noindent The string passed to @code{Linker_Options} is presented uninterpreted as ! an argument to the link command, unless it contains Ascii.NUL characters. NUL characters if they appear act as argument separators, so for example @smallexample @c ada ! pragma Linker_Options ("-labc" & ASCII.Nul & "-ldef"); @end smallexample @noindent --- 8884,8894 ---- @end cartouche @noindent The string passed to @code{Linker_Options} is presented uninterpreted as ! an argument to the link command, unless it contains ASCII.NUL characters. NUL characters if they appear act as argument separators, so for example @smallexample @c ada ! pragma Linker_Options ("-labc" & ASCII.NUL & "-ldef"); @end smallexample @noindent *************** attribute. See C.7.1(7). *** 8462,8474 **** @end cartouche @noindent The result of this attribute is a string that identifies ! the object or component that denotes a given task. If a variable Var has a task ! type, the image for this task will have the form Var_XXXXXXXX, where the ! suffix is the hexadecimal representation of the virtual address of the corresponding task control block. If the variable is an array of tasks, the image of each task will have the form of an indexed component indicating the position of a ! given task in the array, eg. Group(5)_XXXXXXX. If the task is a component of a record, the image of the task will have the form of a selected component. These rules are fully recursive, so that the image of a task that is a subcomponent of a composite object corresponds to the expression that --- 9002,9014 ---- @end cartouche @noindent The result of this attribute is a string that identifies ! the object or component that denotes a given task. If a variable @code{Var} ! has a task type, the image for this task will have the form @code{Var_@var{XXXXXXXX}}, ! where the suffix is the hexadecimal representation of the virtual address of the corresponding task control block. If the variable is an array of tasks, the image of each task will have the form of an indexed component indicating the position of a ! given task in the array, e.g.@: @code{Group(5)_@var{XXXXXXX}}. If the task is a component of a record, the image of the task will have the form of a selected component. These rules are fully recursive, so that the image of a task that is a subcomponent of a composite object corresponds to the expression that *************** There are no implementation-defined aspe *** 8522,8528 **** @noindent The metrics information for GNAT depends on the performance of the underlying operating system. The sources of the run-time for tasking ! implementation, together with the output from @code{-gnatG} can be used to determine the exact sequence of operating systems calls made to implement various tasking constructs. Together with appropriate information on the performance of the underlying operating system, --- 9062,9068 ---- @noindent The metrics information for GNAT depends on the performance of the underlying operating system. The sources of the run-time for tasking ! implementation, together with the output from @option{-gnatG} can be used to determine the exact sequence of operating systems calls made to implement various tasking constructs. Together with appropriate information on the performance of the underlying operating system, *************** will be as described for primitive types *** 9294,9302 **** @item @emph{Records}. For the normal non-packed case, the alignment of a record is equal to the maximum alignment of any of its components. For tagged records, this ! includes the implicit access type used for the tag. If a pragma @code{Pack} is ! used and all fields are packable (see separate section on pragma @code{Pack}), ! then the resulting alignment is 1. A special case is when: @itemize @bullet --- 9834,9843 ---- @item @emph{Records}. For the normal non-packed case, the alignment of a record is equal to the maximum alignment of any of its components. For tagged records, this ! includes the implicit access type used for the tag. If a pragma @code{Pack} ! is used and all components are packable (see separate section on pragma ! @code{Pack}), then the resulting alignment is 1, unless the layout of the ! record makes it profitable to increase it. A special case is when: @itemize @bullet *************** strict alignment. *** 9329,9335 **** An alignment clause may specify a larger alignment than the default value up to some maximum value dependent on the target (obtainable by using the attribute reference @code{Standard'Maximum_Alignment}). It may also specify ! a smaller alignment than the default value, for example @smallexample @c ada type V is record --- 9870,9877 ---- An alignment clause may specify a larger alignment than the default value up to some maximum value dependent on the target (obtainable by using the attribute reference @code{Standard'Maximum_Alignment}). It may also specify ! a smaller alignment than the default value for enumeration, integer and ! fixed point types, as well as for record types, for example @smallexample @c ada type V is record *************** Then @code{Default_Stack_Size} can be de *** 9443,9449 **** modified as required. Any tasks requiring stack sizes different from the default can have an appropriate alternative reference in the pragma. ! You can also use the @code{-d} binder switch to modify the default stack size. For access types, the @code{Storage_Size} clause specifies the maximum --- 9985,9991 ---- modified as required. Any tasks requiring stack sizes different from the default can have an appropriate alternative reference in the pragma. ! You can also use the @option{-d} binder switch to modify the default stack size. For access types, the @code{Storage_Size} clause specifies the maximum *************** In other words, the value specified must *** 9852,9862 **** of this subtype, and must be a multiple of the alignment value. In addition, component size clauses are allowed which cause the array ! to be packed, by specifying a smaller value. The cases in which this ! is allowed are for component size values in the range 1 through 63. The value ! specified must not be smaller than the Size of the subtype. GNAT will ! accurately honor all packing requests in this range. For example, if ! we have: @smallexample @c ada type r is array (1 .. 8) of Natural; --- 10394,10403 ---- of this subtype, and must be a multiple of the alignment value. In addition, component size clauses are allowed which cause the array ! to be packed, by specifying a smaller value. A first case is for ! component size values in the range 1 through 63. The value specified ! must not be smaller than the Size of the subtype. GNAT will accurately ! honor all packing requests in this range. For example, if we have: @smallexample @c ada type r is array (1 .. 8) of Natural; *************** for r'Component_Size use 31; *** 9867,9872 **** --- 10408,10430 ---- then the resulting array has a length of 31 bytes (248 bits = 8 * 31). Of course access to the components of such an array is considerably less efficient than if the natural component size of 32 is used. + A second case is when the subtype of the component is a record type + padded because of its default alignment. For example, if we have: + + @smallexample @c ada + type r is record + i : Integer; + j : Integer; + b : Boolean; + end record; + + type a is array (1 .. 8) of r; + for a'Component_Size use 72; + @end smallexample + + @noindent + then the resulting array has a length of 72 bytes, instead of 96 bytes + if the alignment of the record (4) was obeyed. Note that there is no point in giving both a component size clause and a pragma Pack for the same array type. if such duplicate *************** Any scalar type *** 10248,10253 **** --- 10806,10813 ---- Any type whose size is specified with a size clause @item Any packed array type with a static size + @item + Any record type padded because of its default alignment @end itemize @noindent *************** including the important case of single b *** 10458,10464 **** there are no limitations on placement of such components, and they may start and end at arbitrary bit boundaries. ! If the component size is not a power of 2 (e.g. 3 or 5), then an array of this type longer than 64 bits must always be placed on on a storage unit (byte) boundary and occupy an integral number of storage units (bytes). Any component clause that does not --- 11018,11024 ---- there are no limitations on placement of such components, and they may start and end at arbitrary bit boundaries. ! If the component size is not a power of 2 (e.g.@: 3 or 5), then an array of this type longer than 64 bits must always be placed on on a storage unit (byte) boundary and occupy an integral number of storage units (bytes). Any component clause that does not *************** representation values are negative, all *** 10518,10524 **** @end smallexample @noindent ! For the unsigned case, where all values are non negative, the values must be in the range: @smallexample @c ada --- 11078,11084 ---- @end smallexample @noindent ! For the unsigned case, where all values are nonnegative, the values must be in the range: @smallexample @c ada *************** code. size clause specifying 64-bits mus *** 10866,10872 **** @node Determining the Representations chosen by GNAT @section Determining the Representations chosen by GNAT @cindex Representation, determination of ! @cindex @code{-gnatR} switch @noindent Although the descriptions in this section are intended to be complete, it is --- 11426,11432 ---- @node Determining the Representations chosen by GNAT @section Determining the Representations chosen by GNAT @cindex Representation, determination of ! @cindex @option{-gnatR} switch @noindent Although the descriptions in this section are intended to be complete, it is *************** fields placed? The section on pragma @co *** 10884,10890 **** used to answer the second question, but it is often easier to just see what the compiler does. ! For this purpose, GNAT provides the option @code{-gnatR}. If you compile with this option, then the compiler will output information on the actual representations chosen, in a format similar to source representation clauses. For example, if we compile the package: --- 11444,11450 ---- used to answer the second question, but it is often easier to just see what the compiler does. ! For this purpose, GNAT provides the option @option{-gnatR}. If you compile with this option, then the compiler will output information on the actual representations chosen, in a format similar to source representation clauses. For example, if we compile the package: *************** end q; *** 10934,10940 **** @end smallexample @noindent ! using the switch @code{-gnatR} we obtain the following output: @smallexample Representation information for unit q --- 11494,11500 ---- @end smallexample @noindent ! using the switch @option{-gnatR} we obtain the following output: @smallexample Representation information for unit q *************** system-independent manner. *** 11073,11079 **** @item Ada.Decimal (F.2) This package provides constants describing the range of decimal numbers implemented, and also a decimal divide routine (analogous to the COBOL ! verb DIVIDE .. GIVING .. REMAINDER ..) @item Ada.Direct_IO (A.8.4) This package provides input-output using a model of a set of records of --- 11633,11639 ---- @item Ada.Decimal (F.2) This package provides constants describing the range of decimal numbers implemented, and also a decimal divide routine (analogous to the COBOL ! verb DIVIDE @dots{} GIVING @dots{} REMAINDER @dots{}) @item Ada.Direct_IO (A.8.4) This package provides input-output using a model of a set of records of *************** The following predefined instantiations *** 11145,11152 **** @item Float @code{Ada.Numerics.Complex_Elementary_Functions} @item Long_Float ! @code{Ada.Numerics. ! Long_Complex_Elementary_Functions} @end table @item Ada.Numerics.Generic_Complex_Types --- 11705,11711 ---- @item Float @code{Ada.Numerics.Complex_Elementary_Functions} @item Long_Float ! @code{Ada.Numerics.Long_Complex_Elementary_Functions} @end table @item Ada.Numerics.Generic_Complex_Types *************** library routines that support streams. T *** 11615,11621 **** streams by mixed language programs. Note though that system level buffering is explicitly enabled at elaboration of the standard I/O packages and that can have an impact on mixed language programs, in particular those using I/O before ! calling the Ada elaboration routine (e.g. adainit). It is recommended to call the Ada elaboration routine before performing any I/O or when impractical, flush the common I/O streams and in particular Standard_Output before elaborating the Ada code. --- 12174,12180 ---- streams by mixed language programs. Note though that system level buffering is explicitly enabled at elaboration of the standard I/O packages and that can have an impact on mixed language programs, in particular those using I/O before ! calling the Ada elaboration routine (e.g.@: adainit). It is recommended to call the Ada elaboration routine before performing any I/O or when impractical, flush the common I/O streams and in particular Standard_Output before elaborating the Ada code. *************** is a one, two, or three byte sequence: *** 12061,12067 **** @end smallexample @noindent ! where the xxx bits correspond to the left-padded bits of the 16-bit character value. Note that all lower half ASCII characters are represented as ASCII bytes and all upper half characters and other wide characters are represented as sequences of upper-half --- 12620,12626 ---- @end smallexample @noindent ! where the @var{xxx} bits correspond to the left-padded bits of the 16-bit character value. Note that all lower half ASCII characters are represented as ASCII bytes and all upper half characters and other wide characters are represented as sequences of upper-half *************** is a one, two, three, or four byte seque *** 12236,12242 **** @end smallexample @noindent ! where the xxx bits correspond to the left-padded bits of the 21-bit character value. Note that all lower half ASCII characters are represented as ASCII bytes and all upper half characters and other wide characters are represented as sequences of upper-half --- 12795,12801 ---- @end smallexample @noindent ! where the @var{xxx} bits correspond to the left-padded bits of the 21-bit character value. Note that all lower half ASCII characters are represented as ASCII bytes and all upper half characters and other wide characters are represented as sequences of upper-half *************** package Interfaces.C_Streams is *** 12586,12592 **** -- If text_translation_required is true, then the following -- functions may be used to dynamically switch a file from -- binary to text mode or vice versa. These functions have ! -- no effect if text_translation_required is false (i.e. in -- normal UNIX mode). Use fileno to get a stream handle. procedure set_binary_mode (handle : int); procedure set_text_mode (handle : int); --- 13145,13151 ---- -- If text_translation_required is true, then the following -- functions may be used to dynamically switch a file from -- binary to text mode or vice versa. These functions have ! -- no effect if text_translation_required is false (i.e.@: in -- normal UNIX mode). Use fileno to get a stream handle. procedure set_binary_mode (handle : int); procedure set_text_mode (handle : int); *************** of GNAT, and will generate a warning mes *** 12738,12749 **** * Ada.Characters.Latin_9 (a-chlat9.ads):: * Ada.Characters.Wide_Latin_1 (a-cwila1.ads):: * Ada.Characters.Wide_Latin_9 (a-cwila9.ads):: ! * Ada.Characters.Wide_Wide_Latin_1 (a-czila1.ads):: ! * Ada.Characters.Wide_Wide_Latin_9 (a-czila9.ads):: ! * Ada.Command_Line.Remove (a-colire.ads):: * Ada.Command_Line.Environment (a-colien.ads):: * Ada.Direct_IO.C_Streams (a-diocst.ads):: * Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads):: * Ada.Exceptions.Traceback (a-exctra.ads):: * Ada.Sequential_IO.C_Streams (a-siocst.ads):: * Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads):: --- 13297,13310 ---- * Ada.Characters.Latin_9 (a-chlat9.ads):: * Ada.Characters.Wide_Latin_1 (a-cwila1.ads):: * Ada.Characters.Wide_Latin_9 (a-cwila9.ads):: ! * Ada.Characters.Wide_Wide_Latin_1 (a-chzla1.ads):: ! * Ada.Characters.Wide_Wide_Latin_9 (a-chzla9.ads):: * Ada.Command_Line.Environment (a-colien.ads):: + * Ada.Command_Line.Remove (a-colire.ads):: + * Ada.Command_Line.Response_File (a-clrefi.ads):: * Ada.Direct_IO.C_Streams (a-diocst.ads):: * Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads):: + * Ada.Exceptions.Last_Chance_Handler (a-elchha.ads):: * Ada.Exceptions.Traceback (a-exctra.ads):: * Ada.Sequential_IO.C_Streams (a-siocst.ads):: * Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads):: *************** of GNAT, and will generate a warning mes *** 12751,12757 **** --- 13312,13320 ---- * Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads):: * Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO (a-szuzti.ads):: * Ada.Text_IO.C_Streams (a-tiocst.ads):: + * Ada.Wide_Characters.Unicode (a-wichun.ads):: * Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads):: + * Ada.Wide_Wide_Characters.Unicode (a-zchuni.ads):: * Ada.Wide_Wide_Text_IO.C_Streams (a-ztcstr.ads):: * GNAT.Altivec (g-altive.ads):: * GNAT.Altivec.Conversions (g-altcon.ads):: *************** of GNAT, and will generate a warning mes *** 12769,12775 **** * GNAT.Byte_Swapping (g-bytswa.ads):: * GNAT.Calendar (g-calend.ads):: * GNAT.Calendar.Time_IO (g-catiio.ads):: - * GNAT.CRC32 (g-crc32.ads):: * GNAT.Case_Util (g-casuti.ads):: * GNAT.CGI (g-cgi.ads):: * GNAT.CGI.Cookie (g-cgicoo.ads):: --- 13332,13337 ---- *************** of GNAT, and will generate a warning mes *** 12777,12782 **** --- 13339,13345 ---- * GNAT.Command_Line (g-comlin.ads):: * GNAT.Compiler_Version (g-comver.ads):: * GNAT.Ctrl_C (g-ctrl_c.ads):: + * GNAT.CRC32 (g-crc32.ads):: * GNAT.Current_Exception (g-curexc.ads):: * GNAT.Debug_Pools (g-debpoo.ads):: * GNAT.Debug_Utilities (g-debuti.ads):: *************** of GNAT, and will generate a warning mes *** 12811,12816 **** --- 13374,13380 ---- * GNAT.Regpat (g-regpat.ads):: * GNAT.Secondary_Stack_Info (g-sestin.ads):: * GNAT.Semaphores (g-semaph.ads):: + * GNAT.Serial_Communications (g-sercom.ads):: * GNAT.SHA1 (g-sha1.ads):: * GNAT.Signals (g-signal.ads):: * GNAT.Sockets (g-socket.ads):: *************** of GNAT, and will generate a warning mes *** 12827,12832 **** --- 13391,13397 ---- * GNAT.Table (g-table.ads):: * GNAT.Task_Lock (g-tasloc.ads):: * GNAT.Threads (g-thread.ads):: + * GNAT.Time_Stamp (g-timsta.ads):: * GNAT.Traceback (g-traceb.ads):: * GNAT.Traceback.Symbolic (g-trasym.ads):: * GNAT.UTF_32 (g-utf_32.ads):: *************** of GNAT, and will generate a warning mes *** 12838,12847 **** * Interfaces.C.Extensions (i-cexten.ads):: * Interfaces.C.Streams (i-cstrea.ads):: * Interfaces.CPP (i-cpp.ads):: - * Interfaces.Os2lib (i-os2lib.ads):: - * Interfaces.Os2lib.Errors (i-os2err.ads):: - * Interfaces.Os2lib.Synchronization (i-os2syn.ads):: - * Interfaces.Os2lib.Threads (i-os2thr.ads):: * Interfaces.Packed_Decimal (i-pacdec.ads):: * Interfaces.VxWorks (i-vxwork.ads):: * Interfaces.VxWorks.IO (i-vxwoio.ads):: --- 13403,13408 ---- *************** of GNAT, and will generate a warning mes *** 12849,12854 **** --- 13410,13417 ---- * System.Assertions (s-assert.ads):: * System.Memory (s-memory.ads):: * System.Partition_Interface (s-parint.ads):: + * System.Pool_Global (s-pooglo.ads):: + * System.Pool_Local (s-pooloc.ads):: * System.Restrictions (s-restri.ads):: * System.Rident (s-rident.ads):: * System.Task_Info (s-tasinf.ads):: *************** instead of @code{Character}. The provis *** 12898,12906 **** is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). ! @node Ada.Characters.Wide_Wide_Latin_1 (a-czila1.ads) ! @section @code{Ada.Characters.Wide_Wide_Latin_1} (@file{a-czila1.ads}) ! @cindex @code{Ada.Characters.Wide_Wide_Latin_1} (@file{a-czila1.ads}) @cindex Latin_1 constants for Wide_Wide_Character @noindent --- 13461,13469 ---- is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). ! @node Ada.Characters.Wide_Wide_Latin_1 (a-chzla1.ads) ! @section @code{Ada.Characters.Wide_Wide_Latin_1} (@file{a-chzla1.ads}) ! @cindex @code{Ada.Characters.Wide_Wide_Latin_1} (@file{a-chzla1.ads}) @cindex Latin_1 constants for Wide_Wide_Character @noindent *************** instead of @code{Character}. The provis *** 12912,12920 **** is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). ! @node Ada.Characters.Wide_Wide_Latin_9 (a-czila9.ads) ! @section @code{Ada.Characters.Wide_Wide_Latin_9} (@file{a-czila9.ads}) ! @cindex @code{Ada.Characters.Wide_Wide_Latin_9} (@file{a-czila9.ads}) @cindex Latin_9 constants for Wide_Wide_Character @noindent --- 13475,13483 ---- is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). ! @node Ada.Characters.Wide_Wide_Latin_9 (a-chzla9.ads) ! @section @code{Ada.Characters.Wide_Wide_Latin_9} (@file{a-chzla9.ads}) ! @cindex @code{Ada.Characters.Wide_Wide_Latin_9} (@file{a-chzla9.ads}) @cindex Latin_9 constants for Wide_Wide_Character @noindent *************** instead of @code{Character}. The provis *** 12926,12931 **** --- 13489,13504 ---- is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). + @node Ada.Command_Line.Environment (a-colien.ads) + @section @code{Ada.Command_Line.Environment} (@file{a-colien.ads}) + @cindex @code{Ada.Command_Line.Environment} (@file{a-colien.ads}) + @cindex Environment entries + + @noindent + This child of @code{Ada.Command_Line} + provides a mechanism for obtaining environment values on systems + where this concept makes sense. + @node Ada.Command_Line.Remove (a-colire.ads) @section @code{Ada.Command_Line.Remove} (@file{a-colire.ads}) @cindex @code{Ada.Command_Line.Remove} (@file{a-colire.ads}) *************** arguments from the argument list. Once *** 12939,12953 **** to further calls on the subprograms in @code{Ada.Command_Line} will not see the removed argument. ! @node Ada.Command_Line.Environment (a-colien.ads) ! @section @code{Ada.Command_Line.Environment} (@file{a-colien.ads}) ! @cindex @code{Ada.Command_Line.Environment} (@file{a-colien.ads}) ! @cindex Environment entries @noindent ! This child of @code{Ada.Command_Line} ! provides a mechanism for obtaining environment values on systems ! where this concept makes sense. @node Ada.Direct_IO.C_Streams (a-diocst.ads) @section @code{Ada.Direct_IO.C_Streams} (@file{a-diocst.ads}) --- 13512,13529 ---- to further calls on the subprograms in @code{Ada.Command_Line} will not see the removed argument. ! @node Ada.Command_Line.Response_File (a-clrefi.ads) ! @section @code{Ada.Command_Line.Response_File} (@file{a-clrefi.ads}) ! @cindex @code{Ada.Command_Line.Response_File} (@file{a-clrefi.ads}) ! @cindex Response file for command line ! @cindex Command line, response file ! @cindex Command line, handling long command lines @noindent ! This child of @code{Ada.Command_Line} provides a mechanism facilities for ! getting command line arguments from a text file, called a "response file". ! Using a response file allow passing a set of arguments to an executable longer ! than the maximum allowed by the system on the command line. @node Ada.Direct_IO.C_Streams (a-diocst.ads) @section @code{Ada.Direct_IO.C_Streams} (@file{a-diocst.ads}) *************** This child subprogram provides a way of *** 12970,12975 **** --- 13546,13561 ---- exception occurrence (@code{Null_Occurrence}) without raising an exception. + @node Ada.Exceptions.Last_Chance_Handler (a-elchha.ads) + @section @code{Ada.Exceptions.Last_Chance_Handler} (@file{a-elchha.ads}) + @cindex @code{Ada.Exceptions.Last_Chance_Handler} (@file{a-elchha.ads}) + @cindex Null_Occurrence, testing for + + @noindent + This child subprogram is used for handling otherwise unhandled + exceptions (hence the name last chance), and perform clean ups before + terminating the program. Note that this subprogram never returns. + @node Ada.Exceptions.Traceback (a-exctra.ads) @section @code{Ada.Exceptions.Traceback} (@file{a-exctra.ads}) @cindex @code{Ada.Exceptions.Traceback} (@file{a-exctra.ads}) *************** C streams and @code{Text_IO}. The strea *** 13046,13051 **** --- 13632,13646 ---- extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. + @node Ada.Wide_Characters.Unicode (a-wichun.ads) + @section @code{Ada.Wide_Characters.Unicode} (@file{a-wichun.ads}) + @cindex @code{Ada.Wide_Characters.Unicode} (@file{a-wichun.ads}) + @cindex Unicode categorization, Wide_Character + + @noindent + This package provides subprograms that allow categorization of + Wide_Character values according to Unicode categories. + @node Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads) @section @code{Ada.Wide_Text_IO.C_Streams} (@file{a-wtcstr.ads}) @cindex @code{Ada.Wide_Text_IO.C_Streams} (@file{a-wtcstr.ads}) *************** C streams and @code{Wide_Text_IO}. The *** 13057,13062 **** --- 13652,13666 ---- extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. + @node Ada.Wide_Wide_Characters.Unicode (a-zchuni.ads) + @section @code{Ada.Wide_Wide_Characters.Unicode} (@file{a-zchuni.ads}) + @cindex @code{Ada.Wide_Wide_Characters.Unicode} (@file{a-zchuni.ads}) + @cindex Unicode categorization, Wide_Wide_Character + + @noindent + This package provides subprograms that allow categorization of + Wide_Wide_Character values according to Unicode categories. + @node Ada.Wide_Wide_Text_IO.C_Streams (a-ztcstr.ads) @section @code{Ada.Wide_Wide_Text_IO.C_Streams} (@file{a-ztcstr.ads}) @cindex @code{Ada.Wide_Wide_Text_IO.C_Streams} (@file{a-ztcstr.ads}) *************** obtaining information about exceptions p *** 13342,13349 **** @noindent Provide a debugging storage pools that helps tracking memory corruption ! problems. See section ``Finding memory problems with GNAT Debug Pool'' in ! the @cite{GNAT User's Guide}. @node GNAT.Debug_Utilities (g-debuti.ads) @section @code{GNAT.Debug_Utilities} (@file{g-debuti.ads}) --- 13946,13953 ---- @noindent Provide a debugging storage pools that helps tracking memory corruption ! problems. @xref{The GNAT Debug Pool Facility,,, gnat_ugn, ! @value{EDITION} User's Guide}. @node GNAT.Debug_Utilities (g-debuti.ads) @section @code{GNAT.Debug_Utilities} (@file{g-debuti.ads}) *************** secondary stack. *** 13715,13720 **** --- 14319,14333 ---- @noindent Provides classic counting and binary semaphores using protected types. + @node GNAT.Serial_Communications (g-sercom.ads) + @section @code{GNAT.Serial_Communications} (@file{g-sercom.ads}) + @cindex @code{GNAT.Serial_Communications} (@file{g-sercom.ads}) + @cindex Serial_Communications + + @noindent + Provides a simple interface to send and receive data over a serial + port. This is only supported on GNU/Linux and Windows. + @node GNAT.SHA1 (g-sha1.ads) @section @code{GNAT.SHA1} (@file{g-sha1.ads}) @cindex @code{GNAT.SHA1} (@file{g-sha1.ads}) *************** A very simple facility for locking and u *** 13878,13883 **** --- 14491,14507 ---- single global task lock. Appropriate for use in situations where contention between tasks is very rarely expected. + @node GNAT.Time_Stamp (g-timsta.ads) + @section @code{GNAT.Time_Stamp} (@file{g-timsta.ads}) + @cindex @code{GNAT.Time_Stamp} (@file{g-timsta.ads}) + @cindex Time stamp + @cindex Current time + + @noindent + Provides a simple function that returns a string YYYY-MM-DD HH:MM:SS.SS that + represents the current date and time in ISO 8601 format. This is a very simple + routine with minimal code and there are no dependencies on any other unit. + @node GNAT.Threads (g-thread.ads) @section @code{GNAT.Threads} (@file{g-thread.ads}) @cindex @code{GNAT.Threads} (@file{g-thread.ads}) *************** This package provides facilities for use *** 13999,14047 **** is primarily intended to be used in connection with automated tools for the generation of C++ interfaces. - @node Interfaces.Os2lib (i-os2lib.ads) - @section @code{Interfaces.Os2lib} (@file{i-os2lib.ads}) - @cindex @code{Interfaces.Os2lib} (@file{i-os2lib.ads}) - @cindex Interfacing, to OS/2 - @cindex OS/2 interfacing - - @noindent - This package provides interface definitions to the OS/2 library. - It is a thin binding which is a direct translation of the - various @file{} files. - - @node Interfaces.Os2lib.Errors (i-os2err.ads) - @section @code{Interfaces.Os2lib.Errors} (@file{i-os2err.ads}) - @cindex @code{Interfaces.Os2lib.Errors} (@file{i-os2err.ads}) - @cindex OS/2 Error codes - @cindex Interfacing, to OS/2 - @cindex OS/2 interfacing - - @noindent - This package provides definitions of the OS/2 error codes. - - @node Interfaces.Os2lib.Synchronization (i-os2syn.ads) - @section @code{Interfaces.Os2lib.Synchronization} (@file{i-os2syn.ads}) - @cindex @code{Interfaces.Os2lib.Synchronization} (@file{i-os2syn.ads}) - @cindex Interfacing, to OS/2 - @cindex Synchronization, OS/2 - @cindex OS/2 synchronization primitives - - @noindent - This is a child package that provides definitions for interfacing - to the @code{OS/2} synchronization primitives. - - @node Interfaces.Os2lib.Threads (i-os2thr.ads) - @section @code{Interfaces.Os2lib.Threads} (@file{i-os2thr.ads}) - @cindex @code{Interfaces.Os2lib.Threads} (@file{i-os2thr.ads}) - @cindex Interfacing, to OS/2 - @cindex Thread control, OS/2 - @cindex OS/2 thread interfacing - - @noindent - This is a child package that provides definitions for interfacing - to the @code{OS/2} thread primitives. - @node Interfaces.Packed_Decimal (i-pacdec.ads) @section @code{Interfaces.Packed_Decimal} (@file{i-pacdec.ads}) @cindex @code{Interfaces.Packed_Decimal} (@file{i-pacdec.ads}) --- 14623,14628 ---- *************** This package provides facilities for par *** 14125,14130 **** --- 14706,14735 ---- is used primarily in a distribution context when using Annex E with @code{GLADE}. + @node System.Pool_Global (s-pooglo.ads) + @section @code{System.Pool_Global} (@file{s-pooglo.ads}) + @cindex @code{System.Pool_Global} (@file{s-pooglo.ads}) + @cindex Storage pool, global + @cindex Global storage pool + + @noindent + This package provides a storage pool that is equivalent to the default + storage pool used for access types for which no pool is specifically + declared. It uses malloc/free to allocate/free and does not attempt to + do any automatic reclamation. + + @node System.Pool_Local (s-pooloc.ads) + @section @code{System.Pool_Local} (@file{s-pooloc.ads}) + @cindex @code{System.Pool_Local} (@file{s-pooloc.ads}) + @cindex Storage pool, local + @cindex Local storage pool + + @noindent + This package provides a storage pool that is intended for use with locally + defined access types. It uses malloc/free for allocate/free, and maintains + a list of allocated blocks, so that all storage allocated for the pool can + be freed automatically when the pool is finalized. + @node System.Restrictions (s-restri.ads) @section @code{System.Restrictions} (@file{s-restri.ads}) @cindex @code{System.Restrictions} (@file{s-restri.ads}) *************** including machine instructions in a subp *** 14403,14412 **** The two features are similar, and both are closely related to the mechanism provided by the asm instruction in the GNU C compiler. Full understanding and use of the facilities in this package requires understanding the asm ! instruction as described in @cite{Using the GNU Compiler Collection (GCC)} ! by Richard Stallman. The relevant section is titled ``Extensions to the C ! Language Family'' @result{} ``Assembler Instructions with C Expression ! Operands''. Calls to the function @code{Asm} and the procedure @code{Asm} have identical semantic restrictions and effects as described below. Both are provided so --- 15008,15015 ---- The two features are similar, and both are closely related to the mechanism provided by the asm instruction in the GNU C compiler. Full understanding and use of the facilities in this package requires understanding the asm ! instruction, see @ref{Extended Asm,, Assembler Instructions with C Expression ! Operands, gcc, Using the GNU Compiler Collection (GCC)}. Calls to the function @code{Asm} and the procedure @code{Asm} have identical semantic restrictions and effects as described below. Both are provided so *************** the literal value @code{True} to indicat *** 14480,14486 **** optimizations with respect to the instruction specified should be suppressed, and that in particular, for an instruction that has outputs, the instruction will still be generated, even if none of the outputs are ! used. See the full description in the GCC manual for further details. Generally it is strongly advisable to use Volatile for any ASM statement that is missing either input or output operands, or when two or more ASM statements appear in sequence, to avoid unwanted optimizations. A warning --- 15083,15090 ---- optimizations with respect to the instruction specified should be suppressed, and that in particular, for an instruction that has outputs, the instruction will still be generated, even if none of the outputs are ! used. @xref{Extended Asm,, Assembler Instructions with C Expression Operands, ! gcc, Using the GNU Compiler Collection (GCC)}, for the full description. Generally it is strongly advisable to use Volatile for any ASM statement that is missing either input or output operands, or when two or more ASM statements appear in sequence, to avoid unwanted optimizations. A warning *************** GNAT fully implements the pragma @code{S *** 14675,14681 **** @cindex pragma @code{Shared_Passive} the purpose of designating shared passive packages. This allows the use of passive partitions in the ! context described in the Ada Reference Manual; i.e. for communication between separate partitions of a distributed application using the features in Annex E. @cindex Annex E --- 15279,15285 ---- @cindex pragma @code{Shared_Passive} the purpose of designating shared passive packages. This allows the use of passive partitions in the ! context described in the Ada Reference Manual; i.e., for communication between separate partitions of a distributed application using the features in Annex E. @cindex Annex E *************** partitions, using protected objects for *** 14692,14698 **** needed. The only requirement is that the two programs have a common shared file system. It is even possible for programs running on different machines with different architectures ! (e.g. different endianness) to communicate via the data in a passive partition. @item Persistence between program runs --- 15296,15302 ---- needed. The only requirement is that the two programs have a common shared file system. It is even possible for programs running on different machines with different architectures ! (e.g.@: different endianness) to communicate via the data in a passive partition. @item Persistence between program runs *************** This chapter describes the syntax and se *** 15057,15063 **** Project files specify the options to be used when building a system. Project files can specify global settings for all tools, as well as tool-specific settings. ! See the chapter on project files in the GNAT Users guide for examples of use. @menu * Reserved Words:: --- 15661,15668 ---- Project files specify the options to be used when building a system. Project files can specify global settings for all tools, as well as tool-specific settings. ! @xref{Examples of Project Files,,, gnat_ugn, @value{EDITION} User's Guide}, ! for examples of use. @menu * Reserved Words:: *************** available after the assignment symbol. *** 15193,15199 **** A typed_variable can only be declare once. @noindent ! a non typed variable can be declared multiple times. @noindent Before the completion of its first declaration, the value of variable --- 15798,15804 ---- A typed_variable can only be declare once. @noindent ! a non-typed variable can be declared multiple times. @noindent Before the completion of its first declaration, the value of variable *************** Syntax: *** 15552,15560 **** @smallexample package_declaration ::= ! package_specification | package_renaming ! package_specification ::= @b{package} package_identifier @b{is} @{simple_declarative_item@} @b{end} package_identifier ; --- 16157,16165 ---- @smallexample package_declaration ::= ! package_spec | package_renaming ! package_spec ::= @b{package} package_identifier @b{is} @{simple_declarative_item@} @b{end} package_identifier ; *************** The following attributes apply to packag *** 15778,15784 **** @table @code @item Switches ! This is a single attribute with a string list value. Each non empty string in the list is an option when invoking @code{gnatls}. @end table --- 16383,16389 ---- @table @code @item Switches ! This is a single attribute with a string list value. Each nonempty string in the list is an option when invoking @code{gnatls}. @end table *************** on which the program should execute. *** 16004,16010 **** @item Communication_Protocol This is a simple string attribute. Its value is the name of the protocol to use to communicate with the target in a cross-compilation environment, ! e.g. @code{"wtx"} or @code{"vxworks"}. @item Compiler_Command This is an associative array attribute, whose domain is a language name. Its --- 16609,16615 ---- @item Communication_Protocol This is a simple string attribute. Its value is the name of the protocol to use to communicate with the target in a cross-compilation environment, ! e.g.@: @code{"wtx"} or @code{"vxworks"}. @item Compiler_Command This is an associative array attribute, whose domain is a language name. Its *************** predefined path; e.g., @code{"gnatls"}, *** 16028,16034 **** @item VCS_Kind This is a simple attribute. Its value is a string used to specify the ! Version Control System (VCS) to be used for this project, e.g CVS, RCS ClearCase or Perforce. @item VCS_File_Check --- 16633,16639 ---- @item VCS_Kind This is a simple attribute. Its value is a string used to specify the ! Version Control System (VCS) to be used for this project, e.g.@: CVS, RCS ClearCase or Perforce. @item VCS_File_Check diff -Nrcpad gcc-4.3.3/gcc/ada/gnat_ugn.texi gcc-4.4.0/gcc/ada/gnat_ugn.texi *** gcc-4.3.3/gcc/ada/gnat_ugn.texi Sun Feb 17 21:20:01 2008 --- gcc-4.4.0/gcc/ada/gnat_ugn.texi Wed Sep 17 07:58:12 2008 *************** *** 1,26 **** \input texinfo @c -*-texinfo-*- @c %**start of header @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo @c o @c GNAT DOCUMENTATION o @c o @c G N A T _ U G N o @c o ! @c Copyright (C) 1992-2007, AdaCore o ! @c o ! @c GNAT is free software; you can redistribute it and/or modify it under o ! @c terms of the GNU General Public License as published by the Free Soft- o ! @c ware Foundation; either version 2, or (at your option) any later ver- o ! @c sion. GNAT is distributed in the hope that it will be useful, but WITH- o ! @c OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY o ! @c or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License o ! @c for more details. You should have received a copy of the GNU General o ! @c Public License distributed with GNAT; see file COPYING. If not, write o ! @c to the Free Software Foundation, 51 Franklin Street, Fifth Floor, o ! @c Boston, MA 02110-1301, USA. o @c o @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo @c @c GNAT_UGN Style Guide --- 1,30 ---- \input texinfo @c -*-texinfo-*- @c %**start of header + @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo @c o @c GNAT DOCUMENTATION o @c o @c G N A T _ U G N o @c o ! @c GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). o @c o @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + @setfilename gnat_ugn.info + + @copying + Copyright @copyright{} 1995-2005, 2006, 2007, 2008 Free Software Foundation, + Inc. + + Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Free Documentation License, Version 1.2 or + any later version published by the Free Software Foundation; with no + Invariant Sections, with no Front-Cover Texts and with no Back-Cover + Texts. A copy of the license is included in the section entitled + ``GNU Free Documentation License''. + @end copying + @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo @c @c GNAT_UGN Style Guide *************** *** 76,83 **** @c @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo - @setfilename gnat_ugn.info - @set NOW January 2007 @c This flag is used where the text refers to conditions that exist when the @c text was entered into the document but which may change over time. --- 80,85 ---- *************** *** 91,113 **** @set NONDEFAULTLANGUAGEVERSION Ada 95 @ifset unw - @setfilename gnat_ugn_unw.info - @end ifset - - @ifset unw @set PLATFORM - @set FILE gnat_ugn_unw @end ifset @ifset vms @set PLATFORM OpenVMS - @set FILE gnat_ugn_vms @end ifset @settitle @value{EDITION} User's Guide @value{PLATFORM} @dircategory GNU Ada tools @direntry ! * @value{EDITION} User's Guide (@value{FILE}) @value{PLATFORM} @end direntry @include gcc-common.texi --- 93,117 ---- @set NONDEFAULTLANGUAGEVERSION Ada 95 @ifset unw @set PLATFORM @end ifset @ifset vms @set PLATFORM OpenVMS @end ifset + @c @ovar(ARG) + @c ---------- + @c The ARG is an optional argument. To be used for macro arguments in + @c their documentation (@defmac). + @macro ovar{varname} + @r{[}@var{\varname\}@r{]}@c + @end macro + @settitle @value{EDITION} User's Guide @value{PLATFORM} @dircategory GNU Ada tools @direntry ! * @value{EDITION} User's Guide: (gnat_ugn). @value{PLATFORM} @end direntry @include gcc-common.texi *************** *** 116,135 **** @syncodeindex fn cp @c %**end of header - @copying - Copyright @copyright{} 1995-2005, 2006, 2007, 2008 Free Software Foundation - - Permission is granted to copy, distribute and/or modify this document - under the terms of the GNU Free Documentation License, Version 1.2 - or any later version published by the Free Software Foundation; - with the Invariant Sections being ``GNU Free Documentation License'', with the - Front-Cover Texts being - ``@value{EDITION} User's Guide'', - and with no Back-Cover Texts. - A copy of the license is included in the section entitled - ``GNU Free Documentation License''. - @end copying - @titlepage @title @value{EDITION} User's Guide @ifset vms --- 120,125 ---- *************** AdaCore@* *** 199,204 **** --- 189,197 ---- * Creating Sample Bodies Using gnatstub:: * Other Utility Programs:: * Running and Debugging Ada Programs:: + @ifclear vms + * Code Coverage and Profiling:: + @end ifclear @ifset vms * Compatibility with HP Ada:: @end ifset *************** The GNAT Make Program gnatmake *** 327,332 **** --- 320,326 ---- Improving Performance * Performance Considerations:: + * Text_IO Suggestions:: * Reducing Size of Ada Executables with gnatelim:: * Reducing Size of Executables with unused subprogram/data elimination:: *************** File Name Krunching Using gnatkr *** 419,424 **** --- 413,419 ---- * Examples of gnatkr Usage:: Preprocessing Using gnatprep + * Preprocessing Symbols:: * Using gnatprep:: * Switches for gnatprep:: * Form of Definitions File:: *************** Other Utility Programs *** 507,512 **** --- 502,514 ---- * The External Symbol Naming Scheme of GNAT:: * Converting Ada Files to html with gnathtml:: + @ifclear vms + Code Coverage and Profiling + + * Code Coverage of Ada Programs using gcov:: + * Profiling an Ada Program using gprof:: + @end ifclear + Running and Debugging Ada Programs * The GNAT Debugger GDB:: *************** Platform-Specific Information for the Ru *** 591,596 **** --- 593,599 ---- * Solaris-Specific Considerations:: * Linux-Specific Considerations:: * AIX-Specific Considerations:: + * Irix-Specific Considerations:: Example of Binder Output File *************** a utility that generates empty but compi *** 846,851 **** --- 849,860 ---- @ref{Other Utility Programs}, discusses several other GNAT utilities, including @code{gnathtml}. + @ifclear vms + @item + @ref{Code Coverage and Profiling}, describes how to perform a structural + coverage and profile the execution of Ada programs. + @end ifclear + @item @ref{Running and Debugging Ada Programs}, describes how to run and debug Ada programs. *************** documents: *** 922,929 **** @itemize @bullet @item ! @cite{GNAT Reference Manual}, which contains all reference ! material for the GNAT implementation of Ada. @ifset unw @item --- 931,939 ---- @itemize @bullet @item ! @xref{Top, GNAT Reference Manual, About This Guide, gnat_rm, GNAT ! Reference Manual}, which contains all reference material for the GNAT ! implementation of Ada. @ifset unw @item *************** material for the Ada 95 programming lang *** 944,961 **** material for the Ada 2005 programming language. @item ! @cite{Debugging with GDB} @ifset vms ! , located in the GNU:[DOCS] directory, @end ifset ! contains all details on the use of the GNU source-level debugger. @item ! @cite{GNU Emacs Manual} @ifset vms ! , located in the GNU:[DOCS] directory if the EMACS kit is installed, @end ifset ! contains full information on the extensible editor and programming environment Emacs. @end itemize --- 954,972 ---- material for the Ada 2005 programming language. @item ! @xref{Top,, Debugging with GDB, gdb, Debugging with GDB}, @ifset vms ! in the GNU:[DOCS] directory, @end ifset ! for all details on the use of the GNU source-level debugger. @item ! @xref{Top,, The extensible self-documenting text editor, emacs, ! GNU Emacs Manual}, @ifset vms ! located in the GNU:[DOCS] directory if the EMACS kit is installed, @end ifset ! for full information on the extensible editor and programming environment Emacs. @end itemize *************** in this guide: *** 972,994 **** @itemize @bullet @item ! @code{Functions}, @code{utility program names}, @code{standard names}, and @code{classes}. @item ! @samp{Option flags} @item ! @file{File Names}, @file{button names}, and @file{field names}. @item ! @var{Variables}. @item @emph{Emphasis}. @item ! [optional information or parameters] @item Examples are described by text --- 983,1006 ---- @itemize @bullet @item ! @code{Functions}, @command{utility program names}, @code{standard names}, and @code{classes}. @item ! @option{Option flags} @item ! @file{File names}, @samp{button names}, and @samp{field names}. @item ! @code{Variables}, @env{environment variables}, and @var{metasyntactic ! variables}. @item @emph{Emphasis}. @item ! @r{[}optional information or parameters@r{]} @item Examples are described by text *************** written as @kbd{C-h}), and the tutorial *** 1346,1352 **** Documentation on Emacs and other tools is available in Emacs under the pull-down menu button: @code{Help - Info}. After selecting @code{Info}, ! use the middle mouse button to select a topic (e.g. Emacs). In a character cell terminal, do @kbd{C-h i} to invoke info, and then @kbd{m} (stands for menu) followed by the menu item desired, as in @kbd{m Emacs}, to --- 1358,1364 ---- Documentation on Emacs and other tools is available in Emacs under the pull-down menu button: @code{Help - Info}. After selecting @code{Info}, ! use the middle mouse button to select a topic (e.g.@: Emacs). In a character cell terminal, do @kbd{C-h i} to invoke info, and then @kbd{m} (stands for menu) followed by the menu item desired, as in @kbd{m Emacs}, to *************** statement @code{Put_Line@ (Line@ (1..N)) *** 1622,1628 **** Select @code{Debug}, then @code{Run}. When the @code{Program Arguments} window appears, click @code{OK}. A console window will appear; enter some line of text, ! e.g. @code{abcde}, at the prompt. The program will pause execution when it gets to the breakpoint, and the corresponding line is highlighted. --- 1634,1640 ---- Select @code{Debug}, then @code{Run}. When the @code{Program Arguments} window appears, click @code{OK}. A console window will appear; enter some line of text, ! e.g.@: @code{abcde}, at the prompt. The program will pause execution when it gets to the breakpoint, and the corresponding line is highlighted. *************** of the compiler (@pxref{Character Set Co *** 1785,1791 **** @noindent The basic character set is Latin-1. This character set is defined by ISO standard 8859, part 1. The lower half (character codes @code{16#00#} ! ... @code{16#7F#)} is identical to standard ASCII coding, but the upper half is used to represent additional characters. These include extended letters used by European languages, such as French accents, the vowels with umlauts used in German, and the extra letter A-ring used in Swedish. --- 1797,1803 ---- @noindent The basic character set is Latin-1. This character set is defined by ISO standard 8859, part 1. The lower half (character codes @code{16#00#} ! @dots{} @code{16#7F#)} is identical to standard ASCII coding, but the upper half is used to represent additional characters. These include extended letters used by European languages, such as French accents, the vowels with umlauts used in German, and the extra letter A-ring used in Swedish. *************** lowercase equivalence. *** 1854,1860 **** Any character in the range 80-FF allowed in identifiers, and all are considered distinct. In other words, there are no uppercase and lowercase equivalences in this range. This is useful in conjunction with ! certain encoding schemes used for some foreign character sets (e.g. the typical method of representing Chinese characters on the PC). @item No Upper-Half --- 1866,1872 ---- Any character in the range 80-FF allowed in identifiers, and all are considered distinct. In other words, there are no uppercase and lowercase equivalences in this range. This is useful in conjunction with ! certain encoding schemes used for some foreign character sets (e.g., the typical method of representing Chinese characters on the PC). @item No Upper-Half *************** is a one, two, or three byte sequence: *** 1930,1943 **** @iftex @leftskip=.7cm @end iftex ! 16#0000#-16#007f#: 2#0xxxxxxx# ! 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx# ! 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx# @end smallexample @noindent ! where the xxx bits correspond to the left-padded bits of the 16-bit character value. Note that all lower half ASCII characters are represented as ASCII bytes and all upper half characters and other wide characters are represented as sequences of upper-half --- 1942,1955 ---- @iftex @leftskip=.7cm @end iftex ! 16#0000#-16#007f#: 2#0@var{xxxxxxx}# ! 16#0080#-16#07ff#: 2#110@var{xxxxx}# 2#10@var{xxxxxx}# ! 16#0800#-16#ffff#: 2#1110@var{xxxx}# 2#10@var{xxxxxx}# 2#10@var{xxxxxx}# @end smallexample @noindent ! where the @var{xxx} bits correspond to the left-padded bits of the 16-bit character value. Note that all lower half ASCII characters are represented as ASCII bytes and all upper half characters and other wide characters are represented as sequences of upper-half *************** the unit and replacing the separating do *** 1983,1992 **** An exception arises if the file name generated by the above rules starts with one of the characters @ifset vms ! A,G,I, or S, @end ifset @ifclear vms ! a,g,i, or s, @end ifclear and the second character is a minus. In this case, the character ^tilde^dollar sign^ is used in place --- 1995,2004 ---- An exception arises if the file name generated by the above rules starts with one of the characters @ifset vms ! @samp{A}, @samp{G}, @samp{I}, or @samp{S}, @end ifset @ifclear vms ! @samp{a}, @samp{g}, @samp{i}, or @samp{s}, @end ifclear and the second character is a minus. In this case, the character ^tilde^dollar sign^ is used in place *************** of the minus. The reason for this specia *** 1994,2003 **** the standard names for child units of the packages System, Ada, Interfaces, and GNAT, which use the prefixes @ifset vms ! S- A- I- and G- @end ifset @ifclear vms ! s- a- i- and g- @end ifclear respectively. --- 2006,2015 ---- the standard names for child units of the packages System, Ada, Interfaces, and GNAT, which use the prefixes @ifset vms ! @samp{S-}, @samp{A-}, @samp{I-}, and @samp{G-}, @end ifset @ifclear vms ! @samp{s-}, @samp{a-}, @samp{i-}, and @samp{g-}, @end ifclear respectively. *************** GNAT allows completely arbitrary file na *** 2097,2103 **** source file name pragma. However, if the file name specified has an extension other than @file{.ads} or @file{.adb} it is necessary to use a special syntax when compiling the file. The name in this case must be ! preceded by the special sequence @code{-x} followed by a space and the name of the language, here @code{ada}, as in: @smallexample --- 2109,2115 ---- source file name pragma. However, if the file name specified has an extension other than @file{.ads} or @file{.adb} it is necessary to use a special syntax when compiling the file. The name in this case must be ! preceded by the special sequence @option{-x} followed by a space and the name of the language, here @code{ada}, as in: @smallexample *************** $ gcc -c -x ada peculiar_file_name.sim *** 2109,2115 **** @command{gnatmake} handles non-standard file names in the usual manner (the non-standard file name for the main program is simply used as the argument to gnatmake). Note that if the extension is also non-standard, ! then it must be included in the gnatmake command, it may not be omitted. @node Alternative File Naming Schemes @section Alternative File Naming Schemes --- 2121,2128 ---- @command{gnatmake} handles non-standard file names in the usual manner (the non-standard file name for the main program is simply used as the argument to gnatmake). Note that if the extension is also non-standard, ! then it must be included in the @command{gnatmake} command, it may not ! be omitted. @node Alternative File Naming Schemes @section Alternative File Naming Schemes *************** alternative scheme for naming is specifi *** 2131,2148 **** @smallexample @c ada pragma Source_File_Name ( Spec_File_Name => FILE_NAME_PATTERN ! [,Casing => CASING_SPEC] ! [,Dot_Replacement => STRING_LITERAL]); pragma Source_File_Name ( Body_File_Name => FILE_NAME_PATTERN ! [,Casing => CASING_SPEC] ! [,Dot_Replacement => STRING_LITERAL]); pragma Source_File_Name ( Subunit_File_Name => FILE_NAME_PATTERN ! [,Casing => CASING_SPEC] ! [,Dot_Replacement => STRING_LITERAL]); FILE_NAME_PATTERN ::= STRING_LITERAL CASING_SPEC ::= Lowercase | Uppercase | Mixedcase --- 2144,2161 ---- @smallexample @c ada pragma Source_File_Name ( Spec_File_Name => FILE_NAME_PATTERN ! @r{[},Casing => CASING_SPEC@r{]} ! @r{[},Dot_Replacement => STRING_LITERAL@r{]}); pragma Source_File_Name ( Body_File_Name => FILE_NAME_PATTERN ! @r{[},Casing => CASING_SPEC@r{]} ! @r{[},Dot_Replacement => STRING_LITERAL@r{]}); pragma Source_File_Name ( Subunit_File_Name => FILE_NAME_PATTERN ! @r{[},Casing => CASING_SPEC@r{]} ! @r{[},Dot_Replacement => STRING_LITERAL@r{]}); FILE_NAME_PATTERN ::= STRING_LITERAL CASING_SPEC ::= Lowercase | Uppercase | Mixedcase *************** a separate @code{Subunit_File_Name} rule *** 2174,2180 **** @code{Body_File_name} rule is used for subunits as well. The separate rule for subunits can also be used to implement the rather ! unusual case of a compilation environment (e.g. a single directory) which contains a subunit and a child unit with the same unit name. Although both units cannot appear in the same partition, the Ada Reference Manual allows (but does not require) the possibility of the two units coexisting --- 2187,2193 ---- @code{Body_File_name} rule is used for subunits as well. The separate rule for subunits can also be used to implement the rather ! unusual case of a compilation environment (e.g.@: a single directory) which contains a subunit and a child unit with the same unit name. Although both units cannot appear in the same partition, the Ada Reference Manual allows (but does not require) the possibility of the two units coexisting *************** that for inlining to actually occur as a *** 2355,2361 **** it is necessary to compile in optimizing mode. @cindex @option{-gnatN} switch ! The use of @option{-gnatN} activates a more extensive inlining optimization that is performed by the front end of the compiler. This inlining does not require that the code generation be optimized. Like @option{-gnatn}, the use of this switch generates additional dependencies. --- 2368,2374 ---- it is necessary to compile in optimizing mode. @cindex @option{-gnatN} switch ! The use of @option{-gnatN} activates inlining optimization that is performed by the front end of the compiler. This inlining does not require that the code generation be optimized. Like @option{-gnatn}, the use of this switch generates additional dependencies. *************** Note that *** 2363,2368 **** --- 2376,2387 ---- @option{-gnatN} automatically implies @option{-gnatn} so it is not necessary to specify both options. + When using a gcc-based back end (in practice this means using any version + of GNAT other than the JGNAT, .NET or GNAAMP versions), then the use of + @option{-gnatN} is deprecated, and the use of @option{-gnatn} is preferred. + Historically front end inlining was more extensive than the gcc back end + inlining, but that is no longer the case. + @item If an object file @file{O} depends on the proper body of a subunit through inlining or instantiation, it depends on the parent unit of the subunit. *************** A list of relevant restrictions applying *** 2431,2437 **** checking. @item ! Categorization information (e.g. use of pragma @code{Pure}). @item Information on all @code{with}'ed units, including presence of --- 2450,2456 ---- checking. @item ! Categorization information (e.g.@: use of pragma @code{Pure}). @item Information on all @code{with}'ed units, including presence of *************** This applies to an intrinsic operation, *** 2837,2845 **** Reference Manual. If a pragma Import (Intrinsic) applies to a subprogram, this means that the body of the subprogram is provided by the compiler itself, usually by means of an efficient code sequence, and that the user does not ! supply an explicit body for it. In an application program, the pragma can ! only be applied to the following two sets of names, which the GNAT compiler ! recognizes. @itemize @bullet @item --- 2856,2863 ---- Reference Manual. If a pragma Import (Intrinsic) applies to a subprogram, this means that the body of the subprogram is provided by the compiler itself, usually by means of an efficient code sequence, and that the user does not ! supply an explicit body for it. In an application program, the pragma may ! be applied to the following sets of names: @itemize @bullet @item *************** first one must be a signed integer type *** 2850,2856 **** modulus, and the second parameter must be of type Natural. The return type must be the same as the type of the first argument. The size of this type can only be 8, 16, 32, or 64. ! @item binary arithmetic operators: ``+'', ``-'', ``*'', ``/'' The corresponding operator declaration must have parameters and result type that have the same root numeric type (for example, all three are long_float types). This simplifies the definition of operations that use type checking --- 2868,2876 ---- modulus, and the second parameter must be of type Natural. The return type must be the same as the type of the first argument. The size of this type can only be 8, 16, 32, or 64. ! ! @item ! Binary arithmetic operators: ``+'', ``-'', ``*'', ``/'' The corresponding operator declaration must have parameters and result type that have the same root numeric type (for example, all three are long_float types). This simplifies the definition of operations that use type checking *************** This common idiom is often programmed wi *** 2870,2876 **** --- 2890,2913 ---- explicit body. The pragma makes it simpler to introduce such declarations. It incurs no overhead in compilation time or code size, because it is implemented as a single machine instruction. + + @item + General subprogram entities, to bind an Ada subprogram declaration to + a compiler builtin by name with back-ends where such interfaces are + available. A typical example is the set of ``__builtin'' functions + exposed by the GCC back-end, as in the following example: + + @smallexample @c ada + function builtin_sqrt (F : Float) return Float; + pragma Import (Intrinsic, builtin_sqrt, "__builtin_sqrtf"); + @end smallexample + + Most of the GCC builtins are accessible this way, and as for other + import conventions (e.g. C), it is the user's responsibility to ensure + that the Ada subprogram profile matches the underlying builtin + expectations. @end itemize + @noindent @ifset unw *************** This is relevant only to Windows XP/2000 *** 2881,2887 **** and specifies that the @code{Stdcall} calling sequence will be used, as defined by the NT API. Nevertheless, to ease building cross-platform bindings this convention will be handled as a @code{C} calling ! convention on non Windows platforms. @findex DLL @cindex Convention DLL --- 2918,2924 ---- and specifies that the @code{Stdcall} calling sequence will be used, as defined by the NT API. Nevertheless, to ease building cross-platform bindings this convention will be handled as a @code{C} calling ! convention on non-Windows platforms. @findex DLL @cindex Convention DLL *************** Interface ---see http://www.codesourcery *** 2950,2957 **** @noindent Interfacing can be done at 3 levels: simple data, subprograms, and ! classes. In the first two cases, GNAT offers a specific @var{Convention ! C_Plus_Plus} (or @var{CPP}) that behaves exactly like @var{Convention C}. Usually, C++ mangles the names of subprograms, and currently, GNAT does not provide any help to solve the demangling problem. This problem can be addressed in two ways: --- 2987,2994 ---- @noindent Interfacing can be done at 3 levels: simple data, subprograms, and ! classes. In the first two cases, GNAT offers a specific @code{Convention ! C_Plus_Plus} (or @code{CPP}) that behaves exactly like @code{Convention C}. Usually, C++ mangles the names of subprograms, and currently, GNAT does not provide any help to solve the demangling problem. This problem can be addressed in two ways: *************** the pragma import. *** 2967,2974 **** @noindent Interfacing at the class level can be achieved by using the GNAT specific ! pragmas such as @code{CPP_Constructor}. See the GNAT Reference Manual for ! additional information. @node Linking a Mixed C++ & Ada Program @subsection Linking a Mixed C++ & Ada Program --- 3004,3011 ---- @noindent Interfacing at the class level can be achieved by using the GNAT specific ! pragmas such as @code{CPP_Constructor}. @xref{Interfacing to C++,,, ! gnat_rm, GNAT Reference Manual}, for additional information. @node Linking a Mixed C++ & Ada Program @subsection Linking a Mixed C++ & Ada Program *************** $ gnatmake ada_unit -largs file1.o file2 *** 2998,3013 **** @item Using GNAT and G++ from two different GCC installations: If both ! compilers are on the PATH, the previous method may be used. It is ! important to note that environment variables such as C_INCLUDE_PATH, ! GCC_EXEC_PREFIX, BINUTILS_ROOT, and GCC_ROOT will affect both compilers at the same time and may make one of the two compilers operate improperly if set during invocation of the wrong compiler. It is also very important that the linker uses the proper @file{libgcc.a} GCC library -- that is, the one from the C++ compiler installation. The ! implicit link command as suggested in the gnatmake command from the ! former example can be replaced by an explicit link command with the ! full-verbosity option in order to verify which library is used: @smallexample $ gnatbind ada_unit $ gnatlink -v -v ada_unit file1.o file2.o --LINK=c++ --- 3035,3051 ---- @item Using GNAT and G++ from two different GCC installations: If both ! compilers are on the @env{PATH}, the previous method may be used. It is ! important to note that environment variables such as ! @env{C_INCLUDE_PATH}, @env{GCC_EXEC_PREFIX}, @env{BINUTILS_ROOT}, and ! @env{GCC_ROOT} will affect both compilers at the same time and may make one of the two compilers operate improperly if set during invocation of the wrong compiler. It is also very important that the linker uses the proper @file{libgcc.a} GCC library -- that is, the one from the C++ compiler installation. The ! implicit link command as suggested in the @command{gnatmake} command ! from the former example can be replaced by an explicit link command with ! the full-verbosity option in order to verify which library is used: @smallexample $ gnatbind ada_unit $ gnatlink -v -v ada_unit file1.o file2.o --LINK=c++ *************** $ gnatlink ada_unit file1.o file2.o --LI *** 3045,3051 **** Where CC is the name of the non-GNU C++ compiler. If the @code{zero cost} exception mechanism is used, and the platform ! supports automatic registration of exception tables (e.g. Solaris or IRIX), paths to more objects are required: @smallexample --- 3083,3089 ---- Where CC is the name of the non-GNU C++ compiler. If the @code{zero cost} exception mechanism is used, and the platform ! supports automatic registration of exception tables (e.g.@: Solaris or IRIX), paths to more objects are required: @smallexample *************** $ gnatlink ada_unit file1.o file2.o --LI *** 3058,3064 **** @end smallexample If the @code{zero cost} exception mechanism is used, and the platform ! doesn't support automatic registration of exception tables (e.g. HP-UX, Tru64 or AIX), the simple approach described above will not work and a pre-linking phase using GNAT will be necessary. --- 3096,3102 ---- @end smallexample If the @code{zero cost} exception mechanism is used, and the platform ! doesn't support automatic registration of exception tables (e.g.@: HP-UX, Tru64 or AIX), the simple approach described above will not work and a pre-linking phase using GNAT will be necessary. *************** finalizing the Ada run-time system along *** 3396,3405 **** @b{#include} @b{using namespace} std; ! void Check_Carnivore (Carnivore *obj) @{ ... @} ! void Check_Domestic (Domestic *obj) @{ ... @} ! void Check_Animal (Animal *obj) @{ ... @} ! void Check_Dog (Dog *obj) @{ ... @} @b{extern} "C" @{ void adainit (void); --- 3434,3443 ---- @b{#include} @b{using namespace} std; ! void Check_Carnivore (Carnivore *obj) @{@dots{}@} ! void Check_Domestic (Domestic *obj) @{@dots{}@} ! void Check_Animal (Animal *obj) @{@dots{}@} ! void Check_Dog (Dog *obj) @{@dots{}@} @b{extern} "C" @{ void adainit (void); *************** compiled. *** 3608,3614 **** @cindex cannot generate code If you attempt to compile any of these files, you will get one of the ! following error messages (where fff is the name of the file you compiled): @smallexample cannot generate code for file @var{fff} (package spec) --- 3646,3652 ---- @cindex cannot generate code If you attempt to compile any of these files, you will get one of the ! following error messages (where @var{fff} is the name of the file you compiled): @smallexample cannot generate code for file @var{fff} (package spec) *************** without generating code, then use the @o *** 3632,3638 **** The basic command for compiling a file containing an Ada unit is @smallexample ! $ gcc -c [@var{switches}] @file{file name} @end smallexample @noindent --- 3670,3676 ---- The basic command for compiling a file containing an Ada unit is @smallexample ! $ gcc -c @ovar{switches} @file{file name} @end smallexample @noindent *************** system configuration. You must have a GN *** 3733,3741 **** @cindex @option{-B} (@command{gcc}) Load compiler executables (for example, @code{gnat1}, the Ada compiler) from @var{dir} instead of the default location. Only use this switch ! when multiple versions of the GNAT compiler are available. See the ! @command{gcc} manual page for further details. You would normally use the ! @option{-b} or @option{-V} switch instead. @item -c @cindex @option{-c} (@command{gcc}) --- 3771,3780 ---- @cindex @option{-B} (@command{gcc}) Load compiler executables (for example, @code{gnat1}, the Ada compiler) from @var{dir} instead of the default location. Only use this switch ! when multiple versions of the GNAT compiler are available. ! @xref{Directory Options,, Options for Directory Search, gcc, Using the ! GNU Compiler Collection (GCC)}, for further details. You would normally ! use the @option{-b} or @option{-V} switch instead. @item -c @cindex @option{-c} (@command{gcc}) *************** Any occurrences of pragma @code{Inline} *** 3759,3764 **** --- 3798,3813 ---- are ignored, and @option{-gnatn} and @option{-gnatN} have no effect if this switch is present. + @item -fno-inline-functions + @cindex @option{-fno-inline-functions} (@command{gcc}) + Suppresses automatic inlining of small subprograms, which is enabled + if @option{-O3} is used. + + @item -fno-inline-functions-called-once + @cindex @option{-fno-inline-functions-called-once} (@command{gcc}) + Suppresses inlining of subprograms local to the unit and called once + from within it, which is enabled if @option{-O1} is used. + @item -fno-strict-aliasing @cindex @option{-fno-strict-aliasing} (@command{gcc}) Causes the compiler to avoid assumptions regarding non-aliasing *************** See @ref{Stack Overflow Checking} for de *** 3775,3781 **** Makes the compiler output stack usage information for the program, on a per-function basis. See @ref{Static Stack Usage Analysis} for details. ! @item -fcallgraph-info[=su] @cindex @option{-fcallgraph-info} (@command{gcc}) Makes the compiler output callgraph information for the program, on a per-file basis. The information is generated in the VCG format. It can --- 3824,3830 ---- Makes the compiler output stack usage information for the program, on a per-function basis. See @ref{Static Stack Usage Analysis} for details. ! @item -fcallgraph-info@r{[}=su@r{]} @cindex @option{-fcallgraph-info} (@command{gcc}) Makes the compiler output callgraph information for the program, on a per-file basis. The information is generated in the VCG format. It can *************** Allow full Ada 2005 features. *** 3805,3814 **** Assertions enabled. @code{Pragma Assert} and @code{pragma Debug} to be activated. Note that these pragmas can also be controlled using the configuration pragmas @code{Assertion_Policy} and @code{Debug_Policy}. @item -gnatA @cindex @option{-gnatA} (@command{gcc}) ! Avoid processing @file{gnat.adc}. If a gnat.adc file is present, it will be ignored. @item -gnatb --- 3854,3866 ---- Assertions enabled. @code{Pragma Assert} and @code{pragma Debug} to be activated. Note that these pragmas can also be controlled using the configuration pragmas @code{Assertion_Policy} and @code{Debug_Policy}. + It also activates pragmas @code{Check}, @code{Precondition}, and + @code{Postcondition}. Note that these pragmas can also be controlled + using the configuration pragma @code{Check_Policy}. @item -gnatA @cindex @option{-gnatA} (@command{gcc}) ! Avoid processing @file{gnat.adc}. If a @file{gnat.adc} file is present, it will be ignored. @item -gnatb *************** Specify a configuration pragma file *** 3843,3857 **** @end ifclear (@pxref{The Configuration Pragmas Files}). ! @item ^-gnateD^/DATA_PREPROCESSING=^symbol[=value] @cindex @option{-gnateD} (@command{gcc}) ! Defines a symbol, associated with value, for preprocessing. (@pxref{Integrated Preprocessing}). @item -gnatef @cindex @option{-gnatef} (@command{gcc}) Display full source path name in brief error messages. @item -gnatem=@var{path} @cindex @option{-gnatem} (@command{gcc}) Specify a mapping file --- 3895,3913 ---- @end ifclear (@pxref{The Configuration Pragmas Files}). ! @item ^-gnateD^/DATA_PREPROCESSING=^symbol@r{[}=@var{value}@r{]} @cindex @option{-gnateD} (@command{gcc}) ! Defines a symbol, associated with @var{value}, for preprocessing. (@pxref{Integrated Preprocessing}). @item -gnatef @cindex @option{-gnatef} (@command{gcc}) Display full source path name in brief error messages. + @item -gnateG + @cindex @option{-gnateG} (@command{gcc}) + Save result of preprocessing in a text file. + @item -gnatem=@var{path} @cindex @option{-gnatem} (@command{gcc}) Specify a mapping file *************** catches that cannot be dealt with in the *** 3966,3994 **** @item -gnato @cindex @option{-gnato} (@command{gcc}) Enable numeric overflow checking (which is not normally enabled by ! default). Not that division by zero is a separate check that is not controlled by this switch (division by zero checking is on by default). @item -gnatp @cindex @option{-gnatp} (@command{gcc}) ! Suppress all checks. @item -gnatP @cindex @option{-gnatP} (@command{gcc}) Enable polling. This is required on some systems (notably Windows NT) to obtain asynchronous abort and asynchronous transfer of control capability. ! See the description of pragma Polling in the GNAT Reference Manual for ! full details. @item -gnatq @cindex @option{-gnatq} (@command{gcc}) ! Don't quit; try semantics, even if parse errors. @item -gnatQ @cindex @option{-gnatQ} (@command{gcc}) ! Don't quit; generate @file{ALI} and tree files even if illegalities. ! @item ^-gnatR[0/1/2/3[s]]^/REPRESENTATION_INFO^ @cindex @option{-gnatR} (@command{gcc}) Output representation information for declared types and objects. --- 4022,4054 ---- @item -gnato @cindex @option{-gnato} (@command{gcc}) Enable numeric overflow checking (which is not normally enabled by ! default). Note that division by zero is a separate check that is not controlled by this switch (division by zero checking is on by default). @item -gnatp @cindex @option{-gnatp} (@command{gcc}) ! Suppress all checks. See @ref{Run-Time Checks} for details. @item -gnatP @cindex @option{-gnatP} (@command{gcc}) Enable polling. This is required on some systems (notably Windows NT) to obtain asynchronous abort and asynchronous transfer of control capability. ! @xref{Pragma Polling,,, gnat_rm, GNAT Reference Manual}, for full ! details. @item -gnatq @cindex @option{-gnatq} (@command{gcc}) ! Don't quit. Try semantics, even if parse errors. @item -gnatQ @cindex @option{-gnatQ} (@command{gcc}) ! Don't quit. Generate @file{ALI} and tree files even if illegalities. ! @item -gnatr ! @cindex @option{-gnatr} (@command{gcc}) ! Treat pragma Restrictions as Restriction_Warnings. ! ! @item ^-gnatR@r{[}0@r{/}1@r{/}2@r{/}3@r{[}s@r{]]}^/REPRESENTATION_INFO^ @cindex @option{-gnatR} (@command{gcc}) Output representation information for declared types and objects. *************** Verbose mode. Full error output with sou *** 4025,4031 **** Control level of validity checking. See separate section describing this feature. ! @item ^-gnatw@var{xxx}^/WARNINGS=(@var{option}[,...])^ @cindex @option{^-gnatw^/WARNINGS^} (@command{gcc}) Warning mode where ^@var{xxx} is a string of option letters that^the list of options^ denotes --- 4085,4091 ---- Control level of validity checking. See separate section describing this feature. ! @item ^-gnatw@var{xxx}^/WARNINGS=(@var{option}@r{[},@dots{}@r{]})^ @cindex @option{^-gnatw^/WARNINGS^} (@command{gcc}) Warning mode where ^@var{xxx} is a string of option letters that^the list of options^ denotes *************** Wide character encoding method *** 4046,4052 **** @cindex @option{-gnatx} (@command{gcc}) Suppress generation of cross-reference information. ! @item ^-gnaty^/STYLE_CHECKS=(option,option..)^ @cindex @option{^-gnaty^/STYLE_CHECKS^} (@command{gcc}) Enable built-in style checks (@pxref{Style Checking}). --- 4106,4112 ---- @cindex @option{-gnatx} (@command{gcc}) Suppress generation of cross-reference information. ! @item ^-gnaty^/STYLE_CHECKS=(option,option@dots{})^ @cindex @option{^-gnaty^/STYLE_CHECKS^} (@command{gcc}) Enable built-in style checks (@pxref{Style Checking}). *************** Inhibit the search of the default locati *** 4105,4111 **** Library (RTL) ALI files. @ifclear vms ! @item -O[@var{n}] @cindex @option{-O} (@command{gcc}) @var{n} controls the optimization level. --- 4165,4171 ---- Library (RTL) ALI files. @ifclear vms ! @item -O@ovar{n} @cindex @option{-O} (@command{gcc}) @var{n} controls the optimization level. *************** Equivalent to @option{/OPTIMIZE=NONE}. *** 4141,4147 **** This is the default behavior in the absence of an @option{/OPTIMIZE} qualifier. ! @item /OPTIMIZE[=(keyword[,...])] @cindex @option{/OPTIMIZE} (@code{GNAT COMPILE}) Selects the level of optimization for your program. The supported keywords are as follows: --- 4201,4207 ---- This is the default behavior in the absence of an @option{/OPTIMIZE} qualifier. ! @item /OPTIMIZE@r{[}=(keyword@r{[},@dots{}@r{]})@r{]} @cindex @option{/OPTIMIZE} (@code{GNAT COMPILE}) Selects the level of optimization for your program. The supported keywords are as follows: *************** version, not the GNAT version. *** 4222,4228 **** Turn off warnings generated by the back end of the compiler. Use of this switch also causes the default for front end warnings to be set to suppress (as though @option{-gnatws} had appeared at the start of ! the options. @end table --- 4282,4288 ---- Turn off warnings generated by the back end of the compiler. Use of this switch also causes the default for front end warnings to be set to suppress (as though @option{-gnatws} had appeared at the start of ! the options). @end table *************** warning messages generated. *** 4397,4403 **** @item -^gnatl^OUTPUT_FILE^=file @cindex @option{^-gnatl^OUTPUT_FILE^=fname} (@command{gcc}) ! This has the same effect as @code{-gnatl} except that the output is written to a file instead of to standard output. If the given name @file{fname} does not start with a period, then it is the full name of the file to be written. If @file{fname} is an extension, it is --- 4457,4463 ---- @item -^gnatl^OUTPUT_FILE^=file @cindex @option{^-gnatl^OUTPUT_FILE^=fname} (@command{gcc}) ! This has the same effect as @option{-gnatl} except that the output is written to a file instead of to standard output. If the given name @file{fname} does not start with a period, then it is the full name of the file to be written. If @file{fname} is an extension, it is *************** illegalities are detected in the program *** 4521,4527 **** generation of the @file{ALI} file. This file is marked as being in error, so it cannot be used for binding purposes, but it does contain reasonably complete cross-reference information, and thus may be useful ! for use by tools (e.g. semantic browsing tools or integrated development environments) that are driven from the @file{ALI} file. This switch implies @option{-gnatq}, since the semantic phase must be run to get a meaningful ALI file. --- 4581,4587 ---- generation of the @file{ALI} file. This file is marked as being in error, so it cannot be used for binding purposes, but it does contain reasonably complete cross-reference information, and thus may be useful ! for use by tools (e.g., semantic browsing tools or integrated development environments) that are driven from the @file{ALI} file. This switch implies @option{-gnatq}, since the semantic phase must be run to get a meaningful ALI file. *************** A range in a @code{for} loop that is kno *** 4714,4721 **** The following section lists compiler switches that are available to control the handling of warning messages. It is also possible to exercise much finer control over what warnings are issued and ! suppressed using the GNAT pragma Warnings, which is documented ! in the GNAT Reference manual. @table @option @c !sort! --- 4774,4781 ---- The following section lists compiler switches that are available to control the handling of warning messages. It is also possible to exercise much finer control over what warnings are issued and ! suppressed using the GNAT pragma Warnings, @xref{Pragma Warnings,,, ! gnat_rm, GNAT Reference manual}. @table @option @c !sort! *************** are not generated. *** 4776,4781 **** --- 4836,4856 ---- This switch suppresses warnings for static fixed-point expressions whose value is not an exact multiple of Small. + @item -gnatw.b + @emph{Activate warnings on biased representation.} + @cindex @option{-gnatw.b} (@command{gcc}) + @cindex Biased representation + This switch activates warnings when a size clause, value size clause, component + clause, or component size clause forces the use of biased representation for an + integer type (e.g. representing a range of 10..11 in a single bit by using 0/1 + to represent 10/11). The default is that such warnings are generated. + + @item -gnatw.B + @emph{Suppress warnings on biased representation.} + @cindex @option{-gnatwB} (@command{gcc}) + This switch suppresses warnings for representation clauses that force the use + of biased representation. + @item -gnatwc @emph{Activate warnings on conditionals.} @cindex @option{-gnatwc} (@command{gcc}) *************** This switch causes warning messages to b *** 4856,4861 **** --- 4931,4943 ---- The warning string still appears, but the warning messages are counted as errors, and prevent the generation of an object file. + @item -gnatw.e + @emph{Activate every optional warning} + @cindex @option{-gnatw.e} (@command{gcc}) + @cindex Warnings, activate every optional warning + This switch activates all optional warnings, including those which + are not activated by @code{-gnatwa}. + @item -gnatwf @emph{Activate warnings on unreferenced formals.} @cindex @option{-gnatwf} (@command{gcc}) *************** This warning can also be turned on using *** 4971,4990 **** This switch disables warnings on variables that could be declared constants. @item -gnatwl ! @emph{Activate warnings for missing elaboration pragmas.} @cindex @option{-gnatwl} (@command{gcc}) @cindex Elaboration, warnings This switch activates warnings on missing @code{Elaborate_All} and @code{Elaborate} pragmas. See the section in this guide on elaboration checking for details on ! when such pragmas should be used. Warnings are also generated if you are using the static mode of elaboration, and a @code{pragma Elaborate} is encountered. The default is that such warnings are not generated. This warning is not automatically turned on by the use of @option{-gnatwa}. @item -gnatwL ! @emph{Suppress warnings for missing elaboration pragmas.} @cindex @option{-gnatwL} (@command{gcc}) This switch suppresses warnings on missing Elaborate and Elaborate_All pragmas. See the section in this guide on elaboration checking for details on --- 5053,5084 ---- This switch disables warnings on variables that could be declared constants. @item -gnatwl ! @emph{Activate warnings for elaboration pragmas.} @cindex @option{-gnatwl} (@command{gcc}) @cindex Elaboration, warnings This switch activates warnings on missing @code{Elaborate_All} and @code{Elaborate} pragmas. See the section in this guide on elaboration checking for details on ! when such pragmas should be used. In dynamic elaboration mode, this switch ! generations warnings about the need to add elaboration pragmas. Note however, ! that if you blindly follow these warnings, and add @code{Elaborate_All} ! warnings wherever they are recommended, you basically end up with the ! equivalent of the static elaboration model, which may not be what you want for ! legacy code for which the static model does not work. ! ! For the static model, the messages generated are labeled "info:" (for ! information messages). They are not warnings to add elaboration pragmas, ! merely informational messages showing what implicit elaboration pragmas ! have been added, for use in analyzing elaboration circularity problems. ! ! Warnings are also generated if you are using the static mode of elaboration, and a @code{pragma Elaborate} is encountered. The default is that such warnings are not generated. This warning is not automatically turned on by the use of @option{-gnatwa}. @item -gnatwL ! @emph{Suppress warnings for elaboration pragmas.} @cindex @option{-gnatwL} (@command{gcc}) This switch suppresses warnings on missing Elaborate and Elaborate_All pragmas. See the section in this guide on elaboration checking for details on *************** This switch suppresses warnings on ineff *** 5075,5080 **** --- 5169,5194 ---- inlining mechanism cannot inline a call, it will simply ignore the request silently. + @item -gnatw.p + @emph{Activate warnings on parameter ordering.} + @cindex @option{-gnatw.p} (@command{gcc}) + @cindex Parameter order, warnings + This switch activates warnings for cases of suspicious parameter + ordering when the list of arguments are all simple identifiers that + match the names of the formals, but are in a different order. The + warning is suppressed if any use of named parameter notation is used, + so this is the appropriate way to suppress a false positive (and + serves to emphasize that the "misordering" is deliberate). The + default is + that such warnings are not given. + This warning can also be turned on using @option{-gnatwa}. + + @item -gnatw.P + @emph{Suppress warnings on parameter ordering.} + @cindex @option{-gnatw.P} (@command{gcc}) + This switch suppresses warnings on cases of suspicious parameter + ordering. + @item -gnatwq @emph{Activate warnings on questionable missing parentheses.} @cindex @option{-gnatwq} (@command{gcc}) *************** This warning can also be turned on using *** 5223,5238 **** @item -gnatwW @emph{Suppress warnings on wrong low bound assumption.} @cindex @option{-gnatwW} (@command{gcc}) ! This switch activates warnings for indexing an unconstrained string parameter ! with a literal or S'Length. This warning can also be suppressed by providing ! an Assert pragma that checks the low bound, for example: @smallexample @c ada procedure K (S : String) is pragma Assert (S'First = 1); ! ... @end smallexample @item -gnatwx @emph{Activate warnings on Export/Import pragmas.} @cindex @option{-gnatwx} (@command{gcc}) --- 5337,5370 ---- @item -gnatwW @emph{Suppress warnings on wrong low bound assumption.} @cindex @option{-gnatwW} (@command{gcc}) ! This switch suppresses warnings for indexing an unconstrained string parameter ! with a literal or S'Length. Note that this warning can also be suppressed ! in a particular case by adding an ! assertion that the lower bound is 1, ! as shown in the following example. @smallexample @c ada procedure K (S : String) is pragma Assert (S'First = 1); ! @dots{} @end smallexample + @item -gnatw.w + @emph{Activate warnings on unnecessary Warnings Off pragmas} + @cindex @option{-gnatw.w} (@command{gcc}) + @cindex Warnings Off control + This switch activates warnings for use of @code{pragma Warnings (Off, entity} + where either the pragma is entirely useless (because it suppresses no + warnings), or it could be replaced by @code{pragma Unreferenced} or + @code{pragma Unmodified}.The default is that these warnings are not given. + Note that this warning is not included in -gnatwa, it must be + activated explicitly. + + @item -gnatw.W + @emph{Suppress warnings on unnecessary Warnings Off pragmas} + @cindex @option{-gnatw.W} (@command{gcc}) + This switch suppresses warnings for use of @code{pragma Warnings (Off, entity}. + @item -gnatwx @emph{Activate warnings on Export/Import pragmas.} @cindex @option{-gnatwx} (@command{gcc}) *************** incompatibilities between Ada 95 and Ada *** 5295,5301 **** This switch activates warnings for unchecked conversions where the types are known at compile time to have different sizes. The default ! is that such warnings are generated. This warning can also be turned on using @option{-gnatwa}. @item -gnatwZ --- 5427,5435 ---- This switch activates warnings for unchecked conversions where the types are known at compile time to have different sizes. The default ! is that such warnings are generated. Warnings are also ! generated for subprogram pointers with different conventions, ! and, on VMS only, for data pointers with different conventions. This warning can also be turned on using @option{-gnatwa}. @item -gnatwZ *************** This warning can also be turned on using *** 5303,5325 **** @cindex @option{-gnatwZ} (@command{gcc}) This switch suppresses warnings for unchecked conversions where the types are known at compile time to have different ! sizes. @item ^-Wuninitialized^WARNINGS=UNINITIALIZED^ @cindex @option{-Wuninitialized} ! The warnings controlled by the @option{-gnatw} switch are generated by the ! front end of the compiler. In some cases, the @option{^gcc^GCC^} back end ! can provide additional warnings. One such useful warning is provided by ! @option{^-Wuninitialized^WARNINGS=UNINITIALIZED^}. This must be used in ! conjunction with turning on optimization mode. This causes the flow ! analysis circuits of the back end optimizer to output additional ! warnings about uninitialized variables. @item ^-w^/NO_BACK_END_WARNINGS^ @cindex @option{-w} ! This switch suppresses warnings from the @option{^gcc^GCC^} back end. The ! code generator detects a number of warning situations that are missed ! by the @option{GNAT} front end, and this switch can be used to suppress them. The use of this switch also sets the default front end warning mode to @option{-gnatws}, that is, front end warnings suppressed as well. --- 5437,5469 ---- @cindex @option{-gnatwZ} (@command{gcc}) This switch suppresses warnings for unchecked conversions where the types are known at compile time to have different ! sizes or conventions. ! ! @item ^-Wunused^WARNINGS=UNUSED^ ! @cindex @option{-Wunused} ! The warnings controlled by the @option{-gnatw} switch are generated by ! the front end of the compiler. The @option{GCC} back end can provide ! additional warnings and they are controlled by the @option{-W} switch. ! For example, @option{^-Wunused^WARNINGS=UNUSED^} activates back end ! warnings for entities that are declared but not referenced. @item ^-Wuninitialized^WARNINGS=UNINITIALIZED^ @cindex @option{-Wuninitialized} ! Similarly, @option{^-Wuninitialized^WARNINGS=UNINITIALIZED^} activates ! the back end warning for uninitialized variables. This switch must be ! used in conjunction with an optimization level greater than zero. ! ! @item ^-Wall^/ALL_BACK_END_WARNINGS^ ! @cindex @option{-Wall} ! This switch enables all the above warnings from the @option{GCC} back end. ! The code generator detects a number of warning situations that are missed ! by the @option{GNAT} front end, and this switch can be used to activate them. ! The use of this switch also sets the default front end warning mode to ! @option{-gnatwa}, that is, most front end warnings activated as well. @item ^-w^/NO_BACK_END_WARNINGS^ @cindex @option{-w} ! Conversely, this switch suppresses warnings from the @option{GCC} back end. The use of this switch also sets the default front end warning mode to @option{-gnatws}, that is, front end warnings suppressed as well. *************** The pragmas have the form: *** 5381,5388 **** @smallexample @cartouche ! @b{pragma} Assert (@var{Boolean-expression} [, ! @var{static-string-expression}]) @b{pragma} Debug (@var{procedure call}) @end cartouche @end smallexample --- 5525,5532 ---- @smallexample @cartouche ! @b{pragma} Assert (@var{Boolean-expression} @r{[}, ! @var{static-string-expression}@r{]}) @b{pragma} Debug (@var{procedure call}) @end cartouche @end smallexample *************** The @code{Debug} pragma causes @var{proc *** 5403,5409 **** debugging procedures to be called between declarations. @ifset vms ! @item /DEBUG[=debug-level] @itemx /NODEBUG Specifies how much debugging information is to be included in the resulting object file where 'debug-level' is one of the following: --- 5547,5553 ---- debugging procedures to be called between declarations. @ifset vms ! @item /DEBUG@r{[}=debug-level@r{]} @itemx /NODEBUG Specifies how much debugging information is to be included in the resulting object file where 'debug-level' is one of the following: *************** the shift operators defined as intrinsic *** 5551,5557 **** and operands for attributes such as @code{Pos}. Checks are also made on individual component values for composite comparisons, and on the expressions in type conversions and qualified expressions. Checks are ! also made on explicit ranges using .. (e.g. slices, loops etc). @item -gnatVp @emph{Validity checks for parameters.} --- 5695,5701 ---- and operands for attributes such as @code{Pos}. Checks are also made on individual component values for composite comparisons, and on the expressions in type conversions and qualified expressions. Checks are ! also made on explicit ranges using @samp{..} (e.g.@: slices, loops etc). @item -gnatVp @emph{Validity checks for parameters.} *************** turns on all validity checking options e *** 5621,5627 **** checking of @code{@b{in out}} procedure arguments. The specification of additional validity checking generates extra code (and ! in the case of @option{-gnatVa} the code expansion can be substantial. However, these additional checks can be very useful in detecting uninitialized variables, incorrect use of unchecked conversion, and other errors leading to invalid values. The use of pragma @code{Initialize_Scalars} --- 5765,5771 ---- checking of @code{@b{in out}} procedure arguments. The specification of additional validity checking generates extra code (and ! in the case of @option{-gnatVa} the code expansion can be substantial). However, these additional checks can be very useful in detecting uninitialized variables, incorrect use of unchecked conversion, and other errors leading to invalid values. The use of pragma @code{Initialize_Scalars} *************** temporary disabling of validity checks. *** 5637,5643 **** @findex Style checking @noindent ! The @option{-gnaty^x^(option,option,...)^} switch @cindex @option{-gnaty} (@command{gcc}) causes the compiler to enforce specified style rules. A limited set of style rules has been used --- 5781,5787 ---- @findex Style checking @noindent ! The @option{-gnaty^x^(option,option,@dots{})^} switch @cindex @option{-gnaty} (@command{gcc}) causes the compiler to enforce specified style rules. A limited set of style rules has been used *************** to activate all or some of these checks. *** 5646,5652 **** specified style check, an appropriate warning message is given, preceded by the character sequence ``(style)''. @ifset vms ! @code{(option,option,...)} is a sequence of keywords @end ifset @ifclear vms The string @var{x} is a sequence of letters or digits --- 5790,5796 ---- specified style check, an appropriate warning message is given, preceded by the character sequence ``(style)''. @ifset vms ! @code{(option,option,@dots{})} is a sequence of keywords @end ifset @ifclear vms The string @var{x} is a sequence of letters or digits *************** checks to be performed. The following ch *** 5656,5667 **** @table @option @c !sort! ! @item 1-9 @emph{Specify indentation level.} If a digit from 1-9 appears ^in the string after @option{-gnaty}^as an option for /STYLE_CHECKS^ then proper indentation is checked, with the digit indicating the ! indentation level required. The general style of required indentation is as specified by the examples in the Ada Reference Manual. Full line comments must be aligned with the @code{--} starting on a column that is a multiple of --- 5800,5811 ---- @table @option @c !sort! ! @item 0-9 @emph{Specify indentation level.} If a digit from 1-9 appears ^in the string after @option{-gnaty}^as an option for /STYLE_CHECKS^ then proper indentation is checked, with the digit indicating the ! indentation level required. A value of zero turns off this style check. The general style of required indentation is as specified by the examples in the Ada Reference Manual. Full line comments must be aligned with the @code{--} starting on a column that is a multiple of *************** of a statement. *** 5671,5700 **** @item ^a^ATTRIBUTE^ @emph{Check attribute casing.} ! If the ^letter a^word ATTRIBUTE^ appears in the string after @option{-gnaty} ! then attribute names, including the case of keywords such as @code{digits} used as attributes names, must be written in mixed case, that is, the initial letter and any letter following an underscore must be uppercase. All other letters must be lowercase. @item ^A^ARRAY_INDEXES^ @emph{Use of array index numbers in array attributes.} ! If the ^letter A^word ARRAY_INDEXES^ appears in the string after ! @option{-gnaty} then when using the array attributes First, Last, Range, or Length, the index number must be omitted for one-dimensional arrays and is required for multi-dimensional arrays. @item ^b^BLANKS^ @emph{Blanks not allowed at statement end.} ! If the ^letter b^word BLANKS^ appears in the string after @option{-gnaty} then ! trailing blanks are not allowed at the end of statements. The purpose of this rule, together with h (no horizontal tabs), is to enforce a canonical format for the use of blanks to separate source tokens. @item ^c^COMMENTS^ @emph{Check comments.} ! If the ^letter c^word COMMENTS^ appears in the string after @option{-gnaty} ! then comments must meet the following set of rules: @itemize @bullet --- 5815,5840 ---- @item ^a^ATTRIBUTE^ @emph{Check attribute casing.} ! Attribute names, including the case of keywords such as @code{digits} used as attributes names, must be written in mixed case, that is, the initial letter and any letter following an underscore must be uppercase. All other letters must be lowercase. @item ^A^ARRAY_INDEXES^ @emph{Use of array index numbers in array attributes.} ! When using the array attributes First, Last, Range, or Length, the index number must be omitted for one-dimensional arrays and is required for multi-dimensional arrays. @item ^b^BLANKS^ @emph{Blanks not allowed at statement end.} ! Trailing blanks are not allowed at the end of statements. The purpose of this rule, together with h (no horizontal tabs), is to enforce a canonical format for the use of blanks to separate source tokens. @item ^c^COMMENTS^ @emph{Check comments.} ! Comments must meet the following set of rules: @itemize @bullet *************** including @command{gnatprep} (where ``@c *** 5722,5730 **** annotation language (where ``@code{--#}'' is used). For the purposes of this rule, a special character is defined as being in one of the ASCII ranges ! @code{16#21#..16#2F#} or @code{16#3A#..16#3F#}. Note that this usage is not permitted ! in GNAT implementation units (i.e. when @option{-gnatg} is used). @item A line consisting entirely of minus signs, possibly preceded by blanks, is --- 5862,5870 ---- annotation language (where ``@code{--#}'' is used). For the purposes of this rule, a special character is defined as being in one of the ASCII ranges ! @code{16#21#@dots{}16#2F#} or @code{16#3A#@dots{}16#3F#}. Note that this usage is not permitted ! in GNAT implementation units (i.e., when @option{-gnatg} is used). @item A line consisting entirely of minus signs, possibly preceded by blanks, is *************** example: *** 5746,5809 **** @item ^d^DOS_LINE_ENDINGS^ @emph{Check no DOS line terminators present.} ! If the ^letter d^word DOS_LINE_ENDINGS^ appears in the string after ! @option{-gnaty} then all lines must be terminated by a single ASCII.LF character (in particular the DOS line terminator sequence CR/LF is not allowed). @item ^e^END^ @emph{Check end/exit labels.} ! If the ^letter e^word END^ appears in the string after @option{-gnaty} then ! optional labels on @code{end} statements ending subprograms and on @code{exit} statements exiting named loops, are required to be present. @item ^f^VTABS^ @emph{No form feeds or vertical tabs.} ! If the ^letter f^word VTABS^ appears in the string after @option{-gnaty} then ! neither form feeds nor vertical tab characters are permitted in the source text. @item ^g^GNAT^ @emph{GNAT style mode} ! If the ^letter g^word GNAT^ appears in the string after @option{-gnaty} then ! the set of style check switches is set to match that used by the GNAT sources. This may be useful when developing code that is eventually intended to be incorporated into GNAT. For further details, see GNAT sources. @item ^h^HTABS^ @emph{No horizontal tabs.} ! If the ^letter h^word HTABS^ appears in the string after @option{-gnaty} then ! horizontal tab characters are not permitted in the source text. Together with the b (no blanks at end of line) check, this enforces a canonical form for the use of blanks to separate source tokens. @item ^i^IF_THEN^ @emph{Check if-then layout.} ! If the ^letter i^word IF_THEN^ appears in the string after @option{-gnaty}, ! then the keyword @code{then} must appear either on the same line as corresponding @code{if}, or on a line on its own, lined up under the @code{if} with at least one non-blank line in between containing all or part of the condition to be tested. @item ^I^IN_MODE^ @emph{check mode IN keywords} ! If the ^letter I (upper case)^word IN_MODE^ appears in the string ! after @option{-gnaty} then mode @code{in} (the default mode) is not allowed to be given explicitly. @code{in out} is fine, but not @code{in} on its own. @item ^k^KEYWORD^ @emph{Check keyword casing.} ! If the ^letter k^word KEYWORD^ appears in the string after @option{-gnaty} then ! all keywords must be in lower case (with the exception of keywords such as @code{digits} used as attribute names to which this check does not apply). @item ^l^LAYOUT^ @emph{Check layout.} ! If the ^letter l^word LAYOUT^ appears in the string after @option{-gnaty} then ! layout of statement and declaration constructs must follow the recommendations in the Ada Reference Manual, as indicated by the form of the syntax rules. For example an @code{else} keyword must be lined up with the corresponding @code{if} keyword. --- 5886,5940 ---- @item ^d^DOS_LINE_ENDINGS^ @emph{Check no DOS line terminators present.} ! All lines must be terminated by a single ASCII.LF character (in particular the DOS line terminator sequence CR/LF is not allowed). @item ^e^END^ @emph{Check end/exit labels.} ! Optional labels on @code{end} statements ending subprograms and on @code{exit} statements exiting named loops, are required to be present. @item ^f^VTABS^ @emph{No form feeds or vertical tabs.} ! Neither form feeds nor vertical tab characters are permitted in the source text. @item ^g^GNAT^ @emph{GNAT style mode} ! The set of style check switches is set to match that used by the GNAT sources. This may be useful when developing code that is eventually intended to be incorporated into GNAT. For further details, see GNAT sources. @item ^h^HTABS^ @emph{No horizontal tabs.} ! Horizontal tab characters are not permitted in the source text. Together with the b (no blanks at end of line) check, this enforces a canonical form for the use of blanks to separate source tokens. @item ^i^IF_THEN^ @emph{Check if-then layout.} ! The keyword @code{then} must appear either on the same line as corresponding @code{if}, or on a line on its own, lined up under the @code{if} with at least one non-blank line in between containing all or part of the condition to be tested. @item ^I^IN_MODE^ @emph{check mode IN keywords} ! Mode @code{in} (the default mode) is not allowed to be given explicitly. @code{in out} is fine, but not @code{in} on its own. @item ^k^KEYWORD^ @emph{Check keyword casing.} ! All keywords must be in lower case (with the exception of keywords such as @code{digits} used as attribute names to which this check does not apply). @item ^l^LAYOUT^ @emph{Check layout.} ! Layout of statement and declaration constructs must follow the recommendations in the Ada Reference Manual, as indicated by the form of the syntax rules. For example an @code{else} keyword must be lined up with the corresponding @code{if} keyword. *************** Clear : *** 5880,5895 **** @item ^Lnnn^MAX_NESTING=nnn^ @emph{Set maximum nesting level} ! If the sequence ^Lnnn^MAX_NESTING=nnn^, where nnn is a decimal number in ! the range 0-999, appears in the string after @option{-gnaty} then the ! maximum level of nesting of constructs (including subprograms, loops, ! blocks, packages, and conditionals) may not exceed the given value. A ! value of zero disconnects this style check. @item ^m^LINE_LENGTH^ @emph{Check maximum line length.} ! If the ^letter m^word LINE_LENGTH^ appears in the string after @option{-gnaty} ! then the length of source lines must not exceed 79 characters, including any trailing blanks. The value of 79 allows convenient display on an 80 character wide device or window, allowing for possible special treatment of 80 character lines. Note that this count is of --- 6011,6023 ---- @item ^Lnnn^MAX_NESTING=nnn^ @emph{Set maximum nesting level} ! The maximum level of nesting of constructs (including subprograms, loops, ! blocks, packages, and conditionals) may not exceed the given value ! @option{nnn}. A value of zero disconnects this style check. @item ^m^LINE_LENGTH^ @emph{Check maximum line length.} ! The length of source lines must not exceed 79 characters, including any trailing blanks. The value of 79 allows convenient display on an 80 character wide device or window, allowing for possible special treatment of 80 character lines. Note that this count is of *************** a single character (however many bytes a *** 5899,5952 **** @item ^Mnnn^MAX_LENGTH=nnn^ @emph{Set maximum line length.} ! If the sequence ^M^MAX_LENGTH=^nnn, where nnn is a decimal number, appears in ! the string after @option{-gnaty} then the length of lines must not exceed the ! given value. The maximum value that can be specified is 32767. @item ^n^STANDARD_CASING^ @emph{Check casing of entities in Standard.} ! If the ^letter n^word STANDARD_CASING^ appears in the string ! after @option{-gnaty} then any identifier from Standard must be cased to match the presentation in the Ada Reference Manual (for example, @code{Integer} and @code{ASCII.NUL}). @item ^o^ORDERED_SUBPROGRAMS^ @emph{Check order of subprogram bodies.} ! If the ^letter o^word ORDERED_SUBPROGRAMS^ appears in the string ! after @option{-gnaty} then all subprogram bodies in a given scope ! (e.g. a package body) must be in alphabetical order. The ordering rule uses normal Ada rules for comparing strings, ignoring casing of letters, except that if there is a trailing numeric suffix, then ! the value of this suffix is used in the ordering (e.g. Junk2 comes before Junk10). @item ^p^PRAGMA^ @emph{Check pragma casing.} ! If the ^letter p^word PRAGMA^ appears in the string after @option{-gnaty} then ! pragma names must be written in mixed case, that is, the initial letter and any letter following an underscore must be uppercase. All other letters must be lowercase. @item ^r^REFERENCES^ @emph{Check references.} ! If the ^letter r^word REFERENCES^ appears in the string after @option{-gnaty} ! then all identifier references must be cased in the same way as the corresponding declaration. No specific casing style is imposed on identifiers. The only requirement is for consistency of references with declarations. @item ^S^STATEMENTS_AFTER_THEN_ELSE^ @emph{Check no statements after THEN/ELSE.} ! If the ^letter S^word STATEMENTS_AFTER_THEN_ELSE^ appears in the ! string after @option{-gnaty} then it is not permitted to write any ! statements on the same line as a THEN OR ELSE keyword following the keyword in an IF statement. OR ELSE and AND THEN are not affected, and a special exception allows a pragma to appear after ELSE. @item ^s^SPECS^ @emph{Check separate specs.} ! If the ^letter s^word SPECS^ appears in the string after @option{-gnaty} then ! separate declarations (``specs'') are required for subprograms (a body is not allowed to serve as its own declaration). The only exception is that parameterless library level procedures are not required to have a separate declaration. This exception covers --- 6027,6077 ---- @item ^Mnnn^MAX_LENGTH=nnn^ @emph{Set maximum line length.} ! The length of lines must not exceed the ! given value @option{nnn}. The maximum value that can be specified is 32767. @item ^n^STANDARD_CASING^ @emph{Check casing of entities in Standard.} ! Any identifier from Standard must be cased to match the presentation in the Ada Reference Manual (for example, @code{Integer} and @code{ASCII.NUL}). + @item ^N^NONE^ + @emph{Turn off all style checks} + All style check options are turned off. + @item ^o^ORDERED_SUBPROGRAMS^ @emph{Check order of subprogram bodies.} ! All subprogram bodies in a given scope ! (e.g.@: a package body) must be in alphabetical order. The ordering rule uses normal Ada rules for comparing strings, ignoring casing of letters, except that if there is a trailing numeric suffix, then ! the value of this suffix is used in the ordering (e.g.@: Junk2 comes before Junk10). @item ^p^PRAGMA^ @emph{Check pragma casing.} ! Pragma names must be written in mixed case, that is, the initial letter and any letter following an underscore must be uppercase. All other letters must be lowercase. @item ^r^REFERENCES^ @emph{Check references.} ! All identifier references must be cased in the same way as the corresponding declaration. No specific casing style is imposed on identifiers. The only requirement is for consistency of references with declarations. @item ^S^STATEMENTS_AFTER_THEN_ELSE^ @emph{Check no statements after THEN/ELSE.} ! No statements are allowed ! on the same line as a THEN or ELSE keyword following the keyword in an IF statement. OR ELSE and AND THEN are not affected, and a special exception allows a pragma to appear after ELSE. @item ^s^SPECS^ @emph{Check separate specs.} ! Separate declarations (``specs'') are required for subprograms (a body is not allowed to serve as its own declaration). The only exception is that parameterless library level procedures are not required to have a separate declaration. This exception covers *************** the most frequent form of main program p *** 5954,5961 **** @item ^t^TOKEN^ @emph{Check token spacing.} ! If the ^letter t^word TOKEN^ appears in the string after @option{-gnaty} then ! the following token spacing rules are enforced: @itemize @bullet --- 6079,6085 ---- @item ^t^TOKEN^ @emph{Check token spacing.} ! The following token spacing rules are enforced: @itemize @bullet *************** A vertical bar must be surrounded by spa *** 6004,6019 **** @item ^u^UNNECESSARY_BLANK_LINES^ @emph{Check unnecessary blank lines.} ! Check for unnecessary blank lines. A blank line is considered unnecessary if it appears at the end of the file, or if more than one blank line occurs in sequence. @item ^x^XTRA_PARENS^ @emph{Check extra parentheses.} ! Check for the use of an unnecessary extra level of parentheses (C-style) around conditions in @code{if} statements, @code{while} statements and @code{exit} statements. @end table @noindent --- 6128,6174 ---- @item ^u^UNNECESSARY_BLANK_LINES^ @emph{Check unnecessary blank lines.} ! Unnecessary blank lines are not allowed. A blank line is considered unnecessary if it appears at the end of the file, or if more than one blank line occurs in sequence. @item ^x^XTRA_PARENS^ @emph{Check extra parentheses.} ! Unnecessary extra level of parentheses (C-style) are not allowed around conditions in @code{if} statements, @code{while} statements and @code{exit} statements. + @item ^y^ALL_BUILTIN^ + @emph{Set all standard style check options} + This is equivalent to @code{gnaty3aAbcefhiklmnprst}, that is all checking + options enabled with the exception of @option{-gnatyo}, @option{-gnatyI}, + @option{-gnatyS}, @option{-gnatyLnnn}, + @option{-gnatyd}, @option{-gnatyu}, and @option{-gnatyx}. + + @ifclear vms + @item - + @emph{Remove style check options} + This causes any subsequent options in the string to act as canceling the + corresponding style check option. To cancel maximum nesting level control, + use @option{L} parameter witout any integer value after that, because any + digit following @option{-} in the parameter string of the @option{-gnaty} + option will be threated as canceling indentation check. The same is true + for @option{M} parameter. @option{y} and @option{N} parameters are not + allowed after @option{-}. + + @item + + This causes any subsequent options in the string to enable the corresponding + style check option. That is, it cancels the effect of a previous ^-^REMOVE^, + if any. + @end ifclear + + @ifset vms + @item NOxxx + @emph{Removing style check options} + If the name of a style check is preceded by @option{NO} then the corresponding + style check is turned off. For example @option{NOCOMMENTS} turns off style + checking for comments. + @end ifset @end table @noindent *************** including style messages, as fatal error *** 6036,6053 **** The switch @ifclear vms @option{-gnaty} on its own (that is not ! followed by any letters or digits), ! is equivalent to @code{gnaty3aAbcefhiklmnprst}, that is all checking ! options enabled with the exception of @option{-gnatyo}, ! @option{-gnatyd}, @option{-gnatyu}, and @option{-gnatyx}. @end ifclear @ifset vms /STYLE_CHECKS=ALL_BUILTIN enables all checking options with the exception of ORDERED_SUBPROGRAMS, UNNECESSARY_BLANK_LINES, XTRA_PARENS, and DOS_LINE_ENDINGS. In addition @end ifset ! an indentation level of 3 is set. This is similar to the standard ! checking option that is used for the GNAT sources. The switch @ifclear vms --- 6191,6208 ---- The switch @ifclear vms @option{-gnaty} on its own (that is not ! followed by any letters or digits), then the effect is equivalent ! to the use of @option{-gnatyy}, as described above, that is all ! built-in standard style check options are enabled. ! @end ifclear @ifset vms /STYLE_CHECKS=ALL_BUILTIN enables all checking options with the exception of ORDERED_SUBPROGRAMS, UNNECESSARY_BLANK_LINES, XTRA_PARENS, and DOS_LINE_ENDINGS. In addition @end ifset ! ! The switch @ifclear vms *************** clears any previously set style checks. *** 6067,6080 **** @cindex Checks, stack overflow checking @noindent ! If you compile with the default options, GNAT will insert many run-time ! checks into the compiled code, including code that performs range ! checking against constraints, but not arithmetic overflow checking for ! integer operations (including division by zero), checks for access ! before elaboration on subprogram calls, or stack overflow checking. All ! other run-time checks, as required by the Ada Reference Manual, are ! generated by default. The following @command{gcc} switches refine this ! default behavior: @table @option @c !sort! --- 6222,6232 ---- @cindex Checks, stack overflow checking @noindent ! By default, the following checks are suppressed: integer overflow ! checks, stack overflow checks, and checks for access before ! elaboration on subprogram calls. All other checks, including range ! checks and array bounds checks, are turned on by default. The ! following @command{gcc} switches refine this default behavior. @table @option @c !sort! *************** default behavior: *** 6083,6095 **** @cindex Suppressing checks @cindex Checks, suppressing @findex Suppress ! Suppress all run-time checks as though @code{pragma Suppress (all_checks}) had been present in the source. Validity checks are also suppressed (in other words @option{-gnatp} also implies @option{-gnatVn}. Use this switch to improve the performance of the code at the expense of safety in the presence of invalid data or program bugs. @item -gnato @cindex @option{-gnato} (@command{gcc}) @cindex Overflow checks --- 6235,6267 ---- @cindex Suppressing checks @cindex Checks, suppressing @findex Suppress ! Suppress all run-time checks as though @code{pragma Suppress (All_checks)} had been present in the source. Validity checks are also suppressed (in other words @option{-gnatp} also implies @option{-gnatVn}. Use this switch to improve the performance of the code at the expense of safety in the presence of invalid data or program bugs. + Note that when checks are suppressed, the compiler is allowed, but not + required, to omit the checking code. If the run-time cost of the + checking code is zero or near-zero, the compiler will generate it even + if checks are suppressed. In particular, if the compiler can prove + that a certain check will necessarily fail, it will generate code to + do an unconditional ``raise'', even if checks are suppressed. The + compiler warns in this case. + + Of course, run-time checks are omitted whenever the compiler can prove + that they will not fail, whether or not checks are suppressed. + + Note that if you suppress a check that would have failed, program + execution is erroneous, which means the behavior is totally + unpredictable. The program might crash, or print wrong answers, or + do anything else. It might even do exactly what you wanted it to do + (and then it might start failing mysteriously next week or next + year). The compiler will generate code based on the assumption that + the condition being checked is true, which can result in disaster if + that assumption is wrong. + @item -gnato @cindex @option{-gnato} (@command{gcc}) @cindex Overflow checks *************** the true value of the result of an opera *** 6103,6114 **** range of the result type. The following example shows the distinction: @smallexample @c ada ! X1 : Integer := Integer'Last; ! X2 : Integer range 1 .. 5 := 5; ! X3 : Integer := Integer'Last; ! X4 : Integer range 1 .. 5 := 5; ! F : Float := 2.0E+20; ! ... X1 := X1 + 1; X2 := X2 + 1; X3 := Integer (F); --- 6275,6286 ---- range of the result type. The following example shows the distinction: @smallexample @c ada ! X1 : Integer := "Integer'Last"; ! X2 : Integer range 1 .. 5 := "5"; ! X3 : Integer := "Integer'Last"; ! X4 : Integer range 1 .. 5 := "5"; ! F : Float := "2.0E+20"; ! @dots{} X1 := X1 + 1; X2 := X2 + 1; X3 := Integer (F); *************** X4 := Integer (F); *** 6116,6130 **** @end smallexample @noindent Here the first addition results in a value that is outside the base range of Integer, and hence requires an overflow check for detection of the constraint error. Thus the first assignment to @code{X1} raises a @code{Constraint_Error} exception only if @option{-gnato} is set. ! The second increment operation results in a violation ! of the explicit range constraint, and such range checks are always ! performed (unless specifically suppressed with a pragma @code{suppress} ! or the use of @option{-gnatp}). The two conversions of @code{F} both result in values that are outside the base range of type @code{Integer} and thus will raise --- 6288,6310 ---- @end smallexample @noindent + Note that if explicit values are assigned at compile time, the + compiler may be able to detect overflow at compile time, in which case + no actual run-time checking code is required, and Constraint_Error + will be raised unconditionally, with or without + @option{-gnato}. That's why the assigned values in the above fragment + are in quotes, the meaning is "assign a value not known to the + compiler that happens to be equal to ...". The remaining discussion + assumes that the compiler cannot detect the values at compile time. + Here the first addition results in a value that is outside the base range of Integer, and hence requires an overflow check for detection of the constraint error. Thus the first assignment to @code{X1} raises a @code{Constraint_Error} exception only if @option{-gnato} is set. ! The second increment operation results in a violation of the explicit ! range constraint; such range checks are performed by default, and are ! unaffected by @option{-gnato}. The two conversions of @code{F} both result in values that are outside the base range of type @code{Integer} and thus will raise *************** generate IEEE NaN and infinite values on *** 6159,6170 **** (such as dividing 0.0 by 0.0). The reason that we distinguish overflow checking from other kinds of ! range constraint checking is that a failure of an overflow check can ! generate an incorrect value, but cannot cause erroneous behavior. This ! is unlike the situation with a constraint check on an array subscript, ! where failure to perform the check can result in random memory description, ! or the range check on a case statement, where failure to perform the check ! can cause a wild jump. Note again that @option{-gnato} is off by default, so overflow checking is not performed in default mode. This means that out of the box, with the --- 6339,6350 ---- (such as dividing 0.0 by 0.0). The reason that we distinguish overflow checking from other kinds of ! range constraint checking is that a failure of an overflow check, unlike ! for example the failure of a range check, can result in an incorrect ! value, but cannot cause random memory destruction (like an out of range ! subscript), or a wild jump (from an out of range case value). Overflow ! checking is also quite expensive in time and space, since in general it ! requires the use of double length arithmetic. Note again that @option{-gnato} is off by default, so overflow checking is not performed in default mode. This means that out of the box, with the *************** explicitly use the -gnato switch either *** 6180,6185 **** --- 6360,6367 ---- @cindex Check, elaboration Enables dynamic checks for access-before-elaboration on subprogram calls and generic instantiations. + Note that @option{-gnatE} is not necessary for safety, because in the + default mode, GNAT ensures statically that the checks would not fail. For full details of the effect and use of this switch, @xref{Compiling Using gcc}. *************** into calls to the tasking run-time routi *** 6599,6605 **** is to list this expanded code in a form very close to normal Ada source. This is very useful in understanding the implications of various Ada usage on the efficiency of the generated code. There are many cases in ! Ada (e.g. the use of controlled types), where simple Ada statements can generate a lot of run-time code. By using @option{-gnatG} you can identify these cases, and consider whether it may be desirable to modify the coding approach to improve efficiency. --- 6781,6787 ---- is to list this expanded code in a form very close to normal Ada source. This is very useful in understanding the implications of various Ada usage on the efficiency of the generated code. There are many cases in ! Ada (e.g.@: the use of controlled types), where simple Ada statements can generate a lot of run-time code. By using @option{-gnatG} you can identify these cases, and consider whether it may be desirable to modify the coding approach to improve efficiency. *************** The format of the output is very similar *** 6608,6614 **** easily understood by an Ada programmer. The following special syntactic additions correspond to low level features used in the generated code that do not have any exact analogies in pure Ada source form. The following ! is a partial list of these special constructions. See the specification of package @code{Sprint} in file @file{sprint.ads} for a full list. If the switch @option{-gnatL} is used in conjunction with --- 6790,6796 ---- easily understood by an Ada programmer. The following special syntactic additions correspond to low level features used in the generated code that do not have any exact analogies in pure Ada source form. The following ! is a partial list of these special constructions. See the spec of package @code{Sprint} in file @file{sprint.ads} for a full list. If the switch @option{-gnatL} is used in conjunction with *************** If the switch @option{-gnatL} is used in *** 6617,6623 **** in the expanded source (as comment lines with the original line number). @table @code ! @item new @var{xxx} [storage_pool = @var{yyy}] Shows the storage pool being used for an allocator. @item at end @var{procedure-name}; --- 6799,6805 ---- in the expanded source (as comment lines with the original line number). @table @code ! @item new @var{xxx} @r{[}storage_pool = @var{yyy}@r{]} Shows the storage pool being used for an allocator. @item at end @var{procedure-name}; *************** Combines the above two cases. *** 6643,6656 **** A division or multiplication of fixed-point values which are treated as integers without any kind of scaling. ! @item free @var{expr} [storage_pool = @var{xxx}] Shows the storage pool associated with a @code{free} statement. @item [subtype or type declaration] Used to list an equivalent declaration for an internally generated type that is referenced elsewhere in the listing. ! @item freeze @var{type-name} [@var{actions}] Shows the point at which @var{type-name} is frozen, with possible associated actions to be performed at the freeze point. --- 6825,6838 ---- A division or multiplication of fixed-point values which are treated as integers without any kind of scaling. ! @item free @var{expr} @r{[}storage_pool = @var{xxx}@r{]} Shows the storage pool associated with a @code{free} statement. @item [subtype or type declaration] Used to list an equivalent declaration for an internally generated type that is referenced elsewhere in the listing. ! @item freeze @var{type-name} @ovar{actions} Shows the point at which @var{type-name} is frozen, with possible associated actions to be performed at the freeze point. *************** An implicit call to a run-time support r *** 6668,6674 **** (to meet the requirement of H.3.1(9) in a convenient manner). ! @item @var{expr} && @var{expr} && @var{expr} ... && @var{expr} A multiple concatenation (same effect as @var{expr} & @var{expr} & @var{expr}, but handled more efficiently). --- 6850,6856 ---- (to meet the requirement of H.3.1(9) in a convenient manner). ! @item @var{expr} && @var{expr} && @var{expr} @dots{} && @var{expr} A multiple concatenation (same effect as @var{expr} & @var{expr} & @var{expr}, but handled more efficiently). *************** If the switch @option{-gnatL} is used in *** 6715,6722 **** @option{-gnatDG}, then the original source lines are interspersed in the expanded source (as comment lines with the original line number). @ifclear vms ! @item -gnatR[0|1|2|3[s]] @cindex @option{-gnatR} (@command{gcc}) This switch controls output from the compiler of a listing showing representation information for declared types and objects. For --- 6897,6914 ---- @option{-gnatDG}, then the original source lines are interspersed in the expanded source (as comment lines with the original line number). + @item -gnatr + @cindex @option{-gnatr} (@command{gcc}) + @cindex pragma Restrictions + This switch causes pragma Restrictions to be treated as Restriction_Warnings + so that violation of restrictions causes warnings rather than illegalities. + This is useful during the development process when new restrictions are added + or investigated. The switch also causes pragma Profile to be treated as + Profile_Warnings, and pragma Restricted_Run_Time and pragma Ravenscar set + restriction warnings rather than restrictions. + @ifclear vms ! @item -gnatR@r{[}0@r{|}1@r{|}2@r{|}3@r{[}s@r{]]} @cindex @option{-gnatR} (@command{gcc}) This switch controls output from the compiler of a listing showing representation information for declared types and objects. For *************** the @option{-gnatR} switch). For @option *** 6725,6737 **** so @option{-gnatR} with no parameter has the same effect), size and alignment information is listed for declared array and record types. For @option{-gnatR2}, size and alignment information is listed for all ! declared types and objects. Finally @code{-gnatR3} includes symbolic expressions for values that are computed at run time for variant records. These symbolic expressions have a mostly obvious format with #n being used to represent the value of the n'th discriminant. See source files @file{repinfo.ads/adb} in the @code{GNAT} sources for full details on the format of @option{-gnatR3} ! output. If the switch is followed by an s (e.g. @option{-gnatR2s}), then the output is to a file with the name @file{^file.rep^file_REP^} where file is the name of the corresponding source file. @end ifclear --- 6917,6929 ---- so @option{-gnatR} with no parameter has the same effect), size and alignment information is listed for declared array and record types. For @option{-gnatR2}, size and alignment information is listed for all ! declared types and objects. Finally @option{-gnatR3} includes symbolic expressions for values that are computed at run time for variant records. These symbolic expressions have a mostly obvious format with #n being used to represent the value of the n'th discriminant. See source files @file{repinfo.ads/adb} in the @code{GNAT} sources for full details on the format of @option{-gnatR3} ! output. If the switch is followed by an s (e.g.@: @option{-gnatR2s}), then the output is to a file with the name @file{^file.rep^file_REP^} where file is the name of the corresponding source file. @end ifclear *************** discriminant. See source files @file{REP *** 6754,6760 **** @code{GNAT} sources for full details on the format of @option{/REPRESENTATION_INFO=SYMBOLIC} output. If _FILE is added at the end of an option ! (e.g. @option{/REPRESENTATION_INFO=ARRAYS_FILE}), then the output is to a file with the name @file{file_REP} where file is the name of the corresponding source file. @end ifset --- 6946,6952 ---- @code{GNAT} sources for full details on the format of @option{/REPRESENTATION_INFO=SYMBOLIC} output. If _FILE is added at the end of an option ! (e.g.@: @option{/REPRESENTATION_INFO=ARRAYS_FILE}), then the output is to a file with the name @file{file_REP} where file is the name of the corresponding source file. @end ifset *************** for completeness and for possible use by *** 6878,6884 **** A mapping file is a sequence of sets of three lines. In each set, the first line is the unit name, in lower case, with ``@code{%s}'' appended for ! specifications and ``@code{%b}'' appended for bodies; the second line is the file name; and the third line is the path name. Example: --- 7070,7076 ---- A mapping file is a sequence of sets of three lines. In each set, the first line is the unit name, in lower case, with ``@code{%s}'' appended for ! specs and ``@code{%b}'' appended for bodies; the second line is the file name; and the third line is the path name. Example: *************** Example: *** 6890,6897 **** When the switch @option{-gnatem} is specified, the compiler will create in memory the two mappings from the specified file. If there is any problem ! (non existent file, truncated file or duplicate entries), no mapping ! will be created. Several @option{-gnatem} switches may be specified; however, only the last one on the command line will be taken into account. --- 7082,7089 ---- When the switch @option{-gnatem} is specified, the compiler will create in memory the two mappings from the specified file. If there is any problem ! (nonexistent file, truncated file or duplicate entries), no mapping will ! be created. Several @option{-gnatem} switches may be specified; however, only the last one on the command line will be taken into account. *************** should be found in the source directorie *** 6948,6954 **** @noindent A preprocessing data file is a text file with significant lines indicating how should be preprocessed either a specific source or all sources not ! mentioned in other lines. A significant line is a non empty, non comment line. Comments are similar to Ada comments. @noindent --- 7140,7146 ---- @noindent A preprocessing data file is a text file with significant lines indicating how should be preprocessed either a specific source or all sources not ! mentioned in other lines. A significant line is a nonempty, non-comment line. Comments are similar to Ada comments. @noindent *************** Examples of valid lines in a preprocesso *** 7023,7029 **** -- list all symbols with their values. @end smallexample ! @item ^-gnateD^/DATA_PREPROCESSING=^symbol[=value] @cindex @option{-gnateD} (@command{gcc}) Define or redefine a preprocessing symbol, associated with value. If no value is given on the command line, then the value of the symbol is @code{True}. --- 7215,7221 ---- -- list all symbols with their values. @end smallexample ! @item ^-gnateD^/DATA_PREPROCESSING=^symbol@r{[}=value@r{]} @cindex @option{-gnateD} (@command{gcc}) Define or redefine a preprocessing symbol, associated with value. If no value is given on the command line, then the value of the symbol is @code{True}. *************** symbol with the same name either in a de *** 7041,7046 **** --- 7233,7243 ---- @noindent This switch is similar to switch @option{^-D^/ASSOCIATE^} of @code{gnatprep}. + @item -gnateG + When integrated preprocessing is performed and the preprocessor modifies + the source text, write the result of this preprocessing into a file + ^.prep^_prep^. + @end table @node Code Generation Control *************** This switch is similar to switch @option *** 7051,7059 **** The GCC technology provides a wide range of target dependent @option{-m} switches for controlling details of code generation with respect to different versions of ! architectures. This includes variations in instruction sets (e.g. different members of the power pc family), and different requirements ! for optimal arrangement of instructions (e.g. different members of the x86 family). The list of available @option{-m} switches may be found in the GCC documentation. --- 7248,7256 ---- The GCC technology provides a wide range of target dependent @option{-m} switches for controlling details of code generation with respect to different versions of ! architectures. This includes variations in instruction sets (e.g.@: different members of the power pc family), and different requirements ! for optimal arrangement of instructions (e.g.@: different members of the x86 family). The list of available @option{-m} switches may be found in the GCC documentation. *************** unless you actually see a performance im *** 7080,7086 **** @noindent On VMS, GNAT compiled programs return POSIX-style codes by default, ! e.g. @option{/RETURN_CODES=POSIX}. To enable VMS style return codes, use GNAT BIND and LINK with the option @option{/RETURN_CODES=VMS}. For example: --- 7277,7283 ---- @noindent On VMS, GNAT compiled programs return POSIX-style codes by default, ! e.g.@: @option{/RETURN_CODES=POSIX}. To enable VMS style return codes, use GNAT BIND and LINK with the option @option{/RETURN_CODES=VMS}. For example: *************** Each directory named by an @option{^-I^/ *** 7123,7142 **** @item @findex ADA_PRJ_INCLUDE_FILE Each of the directories listed in the text file whose name is given ! by the @code{ADA_PRJ_INCLUDE_FILE} ^environment variable^logical name^. @noindent ! @code{ADA_PRJ_INCLUDE_FILE} is normally set by gnatmake or by the ^gnat^GNAT^ driver when project files are used. It should not normally be set by other means. @item @findex ADA_INCLUDE_PATH Each of the directories listed in the value of the ! @code{ADA_INCLUDE_PATH} ^environment variable^logical name^. @ifclear vms Construct this value ! exactly as the @code{PATH} environment variable: a list of directory names separated by colons (semicolons when working with the NT version). @end ifclear @ifset vms --- 7320,7339 ---- @item @findex ADA_PRJ_INCLUDE_FILE Each of the directories listed in the text file whose name is given ! by the @env{ADA_PRJ_INCLUDE_FILE} ^environment variable^logical name^. @noindent ! @env{ADA_PRJ_INCLUDE_FILE} is normally set by gnatmake or by the ^gnat^GNAT^ driver when project files are used. It should not normally be set by other means. @item @findex ADA_INCLUDE_PATH Each of the directories listed in the value of the ! @env{ADA_INCLUDE_PATH} ^environment variable^logical name^. @ifclear vms Construct this value ! exactly as the @env{PATH} environment variable: a list of directory names separated by colons (semicolons when working with the NT version). @end ifclear @ifset vms *************** the built-in defaults cause these files *** 7203,7210 **** In addition to the language-defined hierarchies (@code{System}, @code{Ada} and @code{Interfaces}), the GNAT distribution provides a fourth hierarchy, consisting of child units of @code{GNAT}. This is a collection of generally ! useful types, subprograms, etc. See the @cite{GNAT Reference Manual} for ! further details. Besides simplifying access to the RTL, a major use of search paths is in compiling sources from multiple directories. This can make --- 7400,7407 ---- In addition to the language-defined hierarchies (@code{System}, @code{Ada} and @code{Interfaces}), the GNAT distribution provides a fourth hierarchy, consisting of child units of @code{GNAT}. This is a collection of generally ! useful types, subprograms, etc. @xref{Top, GNAT Reference Manual, About ! This Guid, gnat_rm, GNAT Reference Manual}, for further details. Besides simplifying access to the RTL, a major use of search paths is in compiling sources from multiple directories. This can make *************** to be read by the @command{gnatlink} uti *** 7330,7343 **** The form of the @code{gnatbind} command is @smallexample ! $ gnatbind [@i{switches}] @i{mainprog}[.ali] [@i{switches}] @end smallexample @noindent ! where @file{@i{mainprog}.adb} is the Ada file containing the main program unit body. If no switches are specified, @code{gnatbind} constructs an Ada package in two files whose names are ! @file{b~@i{mainprog}.ads}, and @file{b~@i{mainprog}.adb}. For example, if given the parameter @file{hello.ali}, for a main program contained in file @file{hello.adb}, the binder output files would be @file{b~hello.ads} --- 7527,7540 ---- The form of the @code{gnatbind} command is @smallexample ! $ gnatbind @ovar{switches} @var{mainprog}@r{[}.ali@r{]} @ovar{switches} @end smallexample @noindent ! where @file{@var{mainprog}.adb} is the Ada file containing the main program unit body. If no switches are specified, @code{gnatbind} constructs an Ada package in two files whose names are ! @file{b~@var{mainprog}.ads}, and @file{b~@var{mainprog}.adb}. For example, if given the parameter @file{hello.ali}, for a main program contained in file @file{hello.adb}, the binder output files would be @file{b~hello.ads} *************** Check only, no generation of binder outp *** 7473,7492 **** @cindex @option{^-C^/BIND_FILE=C^} (@command{gnatbind}) Generate binder program in C ! @item ^-d^/DEFAULT_STACK_SIZE=^@var{nn}[k|m] ! @cindex @option{^-d^/DEFAULT_STACK_SIZE=^@var{nn}[k|m]} (@command{gnatbind}) This switch can be used to change the default task stack size value to a specified size @var{nn}, which is expressed in bytes by default, or in kilobytes when suffixed with @var{k} or in megabytes when suffixed with @var{m}. ! In the absence of a [k|m] suffix, this switch is equivalent, in effect, ! to completing all task specs with @smallexample @c ada pragma Storage_Size (nn); @end smallexample When they do not already have such a pragma. ! @item ^-D^/DEFAULT_SECONDARY_STACK_SIZE=^@var{nn}[k|m] @cindex @option{^-D^/DEFAULT_SECONDARY_STACK_SIZE=nnnnn^} (@command{gnatbind}) This switch can be used to change the default secondary stack size value to a specified size @var{nn}, which is expressed in bytes by default, or --- 7670,7689 ---- @cindex @option{^-C^/BIND_FILE=C^} (@command{gnatbind}) Generate binder program in C ! @item ^-d^/DEFAULT_STACK_SIZE=^@var{nn}@r{[}k@r{|}m@r{]} ! @cindex @option{^-d^/DEFAULT_STACK_SIZE=^@var{nn}@r{[}k@r{|}m@r{]}} (@command{gnatbind}) This switch can be used to change the default task stack size value to a specified size @var{nn}, which is expressed in bytes by default, or in kilobytes when suffixed with @var{k} or in megabytes when suffixed with @var{m}. ! In the absence of a @samp{@r{[}k@r{|}m@r{]}} suffix, this switch is equivalent, ! in effect, to completing all task specs with @smallexample @c ada pragma Storage_Size (nn); @end smallexample When they do not already have such a pragma. ! @item ^-D^/DEFAULT_SECONDARY_STACK_SIZE=^@var{nn}@r{[}k@r{|}m@r{]} @cindex @option{^-D^/DEFAULT_SECONDARY_STACK_SIZE=nnnnn^} (@command{gnatbind}) This switch can be used to change the default secondary stack size value to a specified size @var{nn}, which is expressed in bytes by default, or *************** ALI file named in the @code{gnatbind} co *** 7556,7567 **** @cindex @option{^-l^/ORDER_OF_ELABORATION^} (@command{gnatbind}) Output chosen elaboration order. ! @item ^-Lxxx^/BUILD_LIBRARY=xxx^ @cindex @option{^-L^/BUILD_LIBRARY^} (@command{gnatbind}) Bind the units for library building. In this case the adainit and adafinal procedures (@pxref{Binding with Non-Ada Main Programs}) ! are renamed to ^xxxinit^XXXINIT^ and ! ^xxxfinal^XXXFINAL^. Implies ^-n^/NOCOMPILE^. @ifclear vms (@xref{GNAT and Libraries}, for more details.) --- 7753,7764 ---- @cindex @option{^-l^/ORDER_OF_ELABORATION^} (@command{gnatbind}) Output chosen elaboration order. ! @item ^-L@var{xxx}^/BUILD_LIBRARY=@var{xxx}^ @cindex @option{^-L^/BUILD_LIBRARY^} (@command{gnatbind}) Bind the units for library building. In this case the adainit and adafinal procedures (@pxref{Binding with Non-Ada Main Programs}) ! are renamed to ^@var{xxx}init^@var{XXX}INIT^ and ! ^@var{xxx}final^@var{XXX}FINAL^. Implies ^-n^/NOCOMPILE^. @ifclear vms (@xref{GNAT and Libraries}, for more details.) *************** The @var{xxx} ^string specified with the *** 7636,7650 **** @item ``@option{^in^INVALID^}'' requesting an invalid value where possible @item ``@option{^lo^LOW^}'' for the lowest possible value @item ``@option{^hi^HIGH^}'' for the highest possible value ! @item ``@option{xx}'' for a value consisting of repeated bytes with the ! value 16#xx# (i.e. xx is a string of two hexadecimal digits). @end itemize In addition, you can specify @option{-Sev} to indicate that the value is to be set at run time. In this case, the program will look for an environment @cindex GNAT_INIT_SCALARS ! variable of the form @code{GNAT_INIT_SCALARS=xx}, where xx is one ! of @option{in/lo/hi/xx} with the same meanings as above. If no environment variable is found, or if it does not have a valid value, then the default is @option{in} (invalid values). --- 7833,7847 ---- @item ``@option{^in^INVALID^}'' requesting an invalid value where possible @item ``@option{^lo^LOW^}'' for the lowest possible value @item ``@option{^hi^HIGH^}'' for the highest possible value ! @item ``@option{@var{xx}}'' for a value consisting of repeated bytes with the ! value @code{16#@var{xx}#} (i.e., @var{xx} is a string of two hexadecimal digits). @end itemize In addition, you can specify @option{-Sev} to indicate that the value is to be set at run time. In this case, the program will look for an environment @cindex GNAT_INIT_SCALARS ! variable of the form @env{GNAT_INIT_SCALARS=@var{xx}}, where @var{xx} is one ! of @option{in/lo/hi/@var{xx}} with the same meanings as above. If no environment variable is found, or if it does not have a valid value, then the default is @option{in} (invalid values). *************** specify this switch, the binder will not *** 7779,7785 **** file is out of date with respect to the source file. Note that this is the mode that is automatically used by @command{gnatmake} because in this case the checking against sources has already been performed by ! @command{gnatmake} in the course of compilation (i.e. before binding). @ifset vms @item /READ_SOURCES=AVAILABLE --- 7976,7982 ---- file is out of date with respect to the source file. Note that this is the mode that is automatically used by @command{gnatmake} because in this case the checking against sources has already been performed by ! @command{gnatmake} in the course of compilation (i.e.@: before binding). @ifset vms @item /READ_SOURCES=AVAILABLE *************** command line, in the order given. *** 8129,8148 **** @item @findex ADA_PRJ_OBJECTS_FILE Each of the directories listed in the text file whose name is given ! by the @code{ADA_PRJ_OBJECTS_FILE} ^environment variable^logical name^. @noindent ! @code{ADA_PRJ_OBJECTS_FILE} is normally set by gnatmake or by the ^gnat^GNAT^ driver when project files are used. It should not normally be set by other means. @item @findex ADA_OBJECTS_PATH Each of the directories listed in the value of the ! @code{ADA_OBJECTS_PATH} ^environment variable^logical name^. @ifset unw Construct this value ! exactly as the @code{PATH} environment variable: a list of directory names separated by colons (semicolons when working with the NT version of GNAT). @end ifset --- 8326,8345 ---- @item @findex ADA_PRJ_OBJECTS_FILE Each of the directories listed in the text file whose name is given ! by the @env{ADA_PRJ_OBJECTS_FILE} ^environment variable^logical name^. @noindent ! @env{ADA_PRJ_OBJECTS_FILE} is normally set by gnatmake or by the ^gnat^GNAT^ driver when project files are used. It should not normally be set by other means. @item @findex ADA_OBJECTS_PATH Each of the directories listed in the value of the ! @env{ADA_OBJECTS_PATH} ^environment variable^logical name^. @ifset unw Construct this value ! exactly as the @env{PATH} environment variable: a list of directory names separated by colons (semicolons when working with the NT version of GNAT). @end ifset *************** driver (see @ref{The GNAT Driver and Pro *** 8303,8310 **** The form of the @command{gnatlink} command is @smallexample ! $ gnatlink [@var{switches}] @var{mainprog}[.ali] ! [@var{non-Ada objects}] [@var{linker options}] @end smallexample @noindent --- 8500,8507 ---- The form of the @command{gnatlink} command is @smallexample ! $ gnatlink @ovar{switches} @var{mainprog}@r{[}.ali@r{]} ! @ovar{non-Ada objects} @ovar{linker options} @end smallexample @noindent *************** units, or in @code{Import} pragmas in an *** 8333,8345 **** @var{linker options} is an optional list of linker specific switches. ! The default linker called by gnatlink is @var{gcc} which in turn calls the appropriate system linker. Standard options for the linker such as @option{-lmy_lib} or @option{-Ldir} can be added as is. For options that are not recognized by ! @var{gcc} as linker options, use the @var{gcc} switches @option{-Xlinker} or ! @option{-Wl,}. Refer to the GCC documentation for details. Here is an example showing how to generate a linker map: --- 8530,8542 ---- @var{linker options} is an optional list of linker specific switches. ! The default linker called by gnatlink is @command{gcc} which in turn calls the appropriate system linker. Standard options for the linker such as @option{-lmy_lib} or @option{-Ldir} can be added as is. For options that are not recognized by ! @command{gcc} as linker options, use the @command{gcc} switches ! @option{-Xlinker} or @option{-Wl,}. Refer to the GCC documentation for details. Here is an example showing how to generate a linker map: *************** $ ^gnatlink my_prog -Wl,-Map,MAPFILE^GNA *** 8349,8358 **** Using @var{linker options} it is possible to set the program stack and heap size. ! @ifclear vms See @ref{Setting Stack Size from gnatlink} and @ref{Setting Heap Size from gnatlink}. ! @end ifclear @command{gnatlink} determines the list of objects required by the Ada program and prepends them to the list of objects passed to the linker. --- 8546,8555 ---- Using @var{linker options} it is possible to set the program stack and heap size. ! @ifset unw See @ref{Setting Stack Size from gnatlink} and @ref{Setting Heap Size from gnatlink}. ! @end ifset @command{gnatlink} determines the list of objects required by the Ada program and prepends them to the list of objects passed to the linker. *************** presented to the linker. *** 8362,8370 **** @ifset vms @command{gnatlink} accepts the following types of extra files on the command ! line: objects (.OBJ), libraries (.OLB), sharable images (.EXE), and ! options files (.OPT). These are recognized and handled according to their ! extension. @end ifset @node Switches for gnatlink --- 8559,8567 ---- @ifset vms @command{gnatlink} accepts the following types of extra files on the command ! line: objects (@file{.OBJ}), libraries (@file{.OLB}), sharable images ! (@file{.EXE}), and options files (@file{.OPT}). These are recognized and ! handled according to their extension. @end ifset @node Switches for gnatlink *************** system configuration. You must have a GN *** 8455,8463 **** @cindex @option{-B} (@command{gnatlink}) Load compiler executables (for example, @code{gnat1}, the Ada compiler) from @var{dir} instead of the default location. Only use this switch ! when multiple versions of the GNAT compiler are available. See the ! @command{gcc} manual page for further details. You would normally use the ! @option{-b} or @option{-V} switch instead. @item --GCC=@var{compiler_name} @cindex @option{--GCC=compiler_name} (@command{gnatlink}) --- 8652,8661 ---- @cindex @option{-B} (@command{gnatlink}) Load compiler executables (for example, @code{gnat1}, the Ada compiler) from @var{dir} instead of the default location. Only use this switch ! when multiple versions of the GNAT compiler are available. ! @xref{Directory Options,,, gcc, The GNU Compiler Collection}, ! for further details. You would normally use the @option{-b} or ! @option{-V} switch instead. @item --GCC=@var{compiler_name} @cindex @option{--GCC=compiler_name} (@command{gnatlink}) *************** use @code{foo -x -y} as your compiler. N *** 8469,8475 **** inserted after your command name. Thus in the above example the compiler command that will be used by @command{gnatlink} will be @code{foo -c -x -y}. A limitation of this syntax is that the name and path name of the executable ! itself must not include any embedded spaces. If several @option{--GCC=compiler_name} are used, only the last @var{compiler_name} is taken into account. However, all the additional switches are also taken into account. Thus, --- 8667,8677 ---- inserted after your command name. Thus in the above example the compiler command that will be used by @command{gnatlink} will be @code{foo -c -x -y}. A limitation of this syntax is that the name and path name of the executable ! itself must not include any embedded spaces. If the compiler executable is ! different from the default one (gcc or -gcc), then the back-end ! switches in the ALI file are not used to compile the binder generated source. ! For example, this is the case with @option{--GCC="foo -x -y"}. But the back end ! switches will be used for @option{--GCC="gcc -gnatv"}. If several @option{--GCC=compiler_name} are used, only the last @var{compiler_name} is taken into account. However, all the additional switches are also taken into account. Thus, *************** dependencies, they will always be tracke *** 8577,8584 **** The usual form of the @command{gnatmake} command is @smallexample ! $ gnatmake [@var{switches}] @var{file_name} ! [@var{file_names}] [@var{mode_switches}] @end smallexample @noindent --- 8779,8786 ---- The usual form of the @command{gnatmake} command is @smallexample ! $ gnatmake @ovar{switches} @var{file_name} ! @ovar{file_names} @ovar{mode_switches} @end smallexample @noindent *************** If @code{switches} are present, they can *** 8590,8596 **** If @var{mode_switches} are present, they must always be placed after the last @var{file_name} and all @code{switches}. ! If you are using standard file extensions (.adb and .ads), then the extension may be omitted from the @var{file_name} arguments. However, if you are using non-standard extensions, then it is required that the extension be given. A relative or absolute directory path can be --- 8792,8798 ---- If @var{mode_switches} are present, they must always be placed after the last @var{file_name} and all @code{switches}. ! If you are using standard file extensions (@file{.adb} and @file{.ads}), then the extension may be omitted from the @var{file_name} arguments. However, if you are using non-standard extensions, then it is required that the extension be given. A relative or absolute directory path can be *************** Project File is specified, with the ALI *** 8712,8718 **** Compile only. Do not perform binding, except when @option{^-b^/ACTIONS=BIND^} is also specified. Do not perform linking, except if both @option{^-b^/ACTIONS=BIND^} and ! @option{^-l^/ACTIONS=LINK^} are also specified. If the root unit specified by @var{file_name} is not a main unit, this is the default. Otherwise @command{gnatmake} will attempt binding and linking unless all objects are up to date and the executable is more recent than --- 8914,8920 ---- Compile only. Do not perform binding, except when @option{^-b^/ACTIONS=BIND^} is also specified. Do not perform linking, except if both @option{^-b^/ACTIONS=BIND^} and ! @option{^-l^/ACTIONS=LINK^} are also specified. If the root unit specified by @var{file_name} is not a main unit, this is the default. Otherwise @command{gnatmake} will attempt binding and linking unless all objects are up to date and the executable is more recent than *************** This switch is not compatible with a pro *** 8740,8745 **** --- 8942,8958 ---- (^-P^/PROJECT_FILE=^@var{file}) or with multiple compiling processes (^-j^/PROCESSES=^nnn, when nnn is greater than 1). + @item ^-d^/DISPLAY_PROGRESS^ + @cindex @option{^-d^/DISPLAY_PROGRESS^} (@command{gnatmake}) + Display progress for each source, up to date or not, as a single line + + @smallexample + completed x out of y (zz%) + @end smallexample + + If the file needs to be compiled this is displayed after the invocation of + the compiler. These lines are displayed even in quiet output mode. + @item ^-D ^/DIRECTORY_OBJECTS=^@var{dir} @cindex @option{^-D^/DIRECTORY_OBJECTS^} (@command{gnatmake}) Put all object files and ALI file in directory @var{dir}. *************** stamp differences when the only *** 8838,8844 **** modifications to a source file consist in adding/removing comments, empty lines, spaces or tabs. This means that if you have changed the comments in a source file or have simply reformatted it, using this ! switch will tell gnatmake not to recompile files that depend on it (provided other sources on which these files depend have undergone no semantic modifications). Note that the debugging information may be out of date with respect to the sources if the @option{-m} switch causes --- 9051,9057 ---- modifications to a source file consist in adding/removing comments, empty lines, spaces or tabs. This means that if you have changed the comments in a source file or have simply reformatted it, using this ! switch will tell @command{gnatmake} not to recompile files that depend on it (provided other sources on which these files depend have undergone no semantic modifications). Note that the debugging information may be out of date with respect to the sources if the @option{-m} switch causes *************** Normally, when using Project Files, only *** 8955,8961 **** File may be compile. When this switch is used, a source outside of all Project Files may be compiled. The ALI file and the object file will be put in the object directory of the main Project. The compilation switches used will only ! be those specified on the command line. @item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} Indicate that external variable @var{name} has the value @var{value}. --- 9168,9176 ---- File may be compile. When this switch is used, a source outside of all Project Files may be compiled. The ALI file and the object file will be put in the object directory of the main Project. The compilation switches used will only ! be those specified on the command line. Even when ! @option{^-x^/NON_PROJECT_UNIT_COMPILATION^} is used, mains specified on the ! command line need to be sources of a project file. @item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} Indicate that external variable @var{name} has the value @var{value}. *************** then the finalization routines. *** 8976,8982 **** @item @command{gcc} @asis{switches} @ifclear vms Any uppercase or multi-character switch that is not a @command{gnatmake} switch ! is passed to @command{gcc} (e.g. @option{-O}, @option{-gnato,} etc.) @end ifclear @ifset vms Any qualifier that cannot be recognized as a qualifier for @code{GNAT MAKE} --- 9191,9197 ---- @item @command{gcc} @asis{switches} @ifclear vms Any uppercase or multi-character switch that is not a @command{gnatmake} switch ! is passed to @command{gcc} (e.g.@: @option{-O}, @option{-gnato,} etc.) @end ifclear @ifset vms Any qualifier that cannot be recognized as a qualifier for @code{GNAT MAKE} *************** and @file{^main3^MAIN3.EXE^}. *** 9258,9265 **** @ifset vms @item gnatmake Main_Unit /QUIET ! /COMPILER_QUALIFIERS /OPTIMIZE=ALL ! /BINDER_QUALIFIERS /ORDER_OF_ELABORATION @end ifset Compile all files necessary to bind and link the main program unit @code{Main_Unit} (from file @file{main_unit.adb}). All compilations will --- 9473,9480 ---- @ifset vms @item gnatmake Main_Unit /QUIET ! /COMPILER_QUALIFIERS /OPTIMIZE=ALL ! /BINDER_QUALIFIERS /ORDER_OF_ELABORATION @end ifset Compile all files necessary to bind and link the main program unit @code{Main_Unit} (from file @file{main_unit.adb}). All compilations will *************** driver (see @ref{The GNAT Driver and Pro *** 9286,9291 **** --- 9501,9507 ---- @ifnottex @menu * Performance Considerations:: + * Text_IO Suggestions:: * Reducing Size of Ada Executables with gnatelim:: * Reducing Size of Executables with unused subprogram/data elimination:: @end menu *************** some guidelines on debugging optimized c *** 9352,9359 **** @subsection Controlling Run-Time Checks @noindent ! By default, GNAT generates all run-time checks, except arithmetic overflow ! checking for integer operations and checks for access before elaboration on subprogram calls. The latter are not required in default mode, because all necessary checking is done at compile time. @cindex @option{-gnatp} (@command{gcc}) --- 9568,9575 ---- @subsection Controlling Run-Time Checks @noindent ! By default, GNAT generates all run-time checks, except integer overflow ! checks, stack overflow checks, and checks for access before elaboration on subprogram calls. The latter are not required in default mode, because all necessary checking is done at compile time. @cindex @option{-gnatp} (@command{gcc}) *************** exception handlers are used. The reason *** 9411,9417 **** have to be marked as non-abortable. If you use neither the @code{abort} statement, nor asynchronous transfer ! of control (@code{select .. then abort}), then this distributed overhead is removed, which may have a general positive effect in improving overall performance. Especially code involving frequent use of tasking constructs and controlled types will show much improved performance. --- 9627,9633 ---- have to be marked as non-abortable. If you use neither the @code{abort} statement, nor asynchronous transfer ! of control (@code{select @dots{} then abort}), then this distributed overhead is removed, which may have a general positive effect in improving overall performance. Especially code involving frequent use of tasking constructs and controlled types will show much improved performance. *************** possibility of an immediate abort at any *** 9432,9437 **** --- 9648,9670 ---- @cindex @option{^-O^/OPTIMIZE^} (@command{gcc}) @noindent + Without any optimization ^option,^qualifier,^ + the compiler's goal is to reduce the cost of + compilation and to make debugging produce the expected results. + Statements are independent: if you stop the program with a breakpoint between + statements, you can then assign a new value to any variable or change + the program counter to any other statement in the subprogram and get exactly + the results you would expect from the source code. + + Turning on optimization makes the compiler attempt to improve the + performance and/or code size at the expense of compilation time and + possibly the ability to debug the program. + + If you use multiple + ^-O options, with or without level numbers,^/OPTIMIZE qualifiers,^ + the last such option is the one that is effective. + + @noindent The default is optimization off. This results in the fastest compile times, but GNAT makes absolutely no attempt to optimize, and the generated programs are considerably larger and slower than when *************** generates unoptimized code but has *** 9452,9458 **** the fastest compilation time. Note that many other compilers do fairly extensive optimization ! even if "no optimization" is specified. When using gcc, it is very unusual to use ^-O0^/OPTIMIZE=NONE^ for production if execution time is of any concern, since ^-O0^/OPTIMIZE=NONE^ really does mean no optimization at all. This difference between --- 9685,9691 ---- the fastest compilation time. Note that many other compilers do fairly extensive optimization ! even if ``no optimization'' is specified. With gcc, it is very unusual to use ^-O0^/OPTIMIZE=NONE^ for production if execution time is of any concern, since ^-O0^/OPTIMIZE=NONE^ really does mean no optimization at all. This difference between *************** resulting improvement in execution time, *** 9489,9502 **** both depend on the particular application and the hardware environment. You should experiment to find the best level for your application. - The @option{^-Os^/OPTIMIZE=SPACE^} switch is independent of the time - optimizations, so you can specify both @option{^-Os^/OPTIMIZE=SPACE^} - and a time optimization on the same compile command. - Since the precise set of optimizations done at each level will vary from release to release (and sometime from target to target), it is best to think of the optimization settings in general terms. ! The @cite{Using GNU GCC} manual contains details about ^the @option{-O} settings and a number of @option{-f} options that^how to^ individually enable or disable specific optimizations. --- 9722,9732 ---- both depend on the particular application and the hardware environment. You should experiment to find the best level for your application. Since the precise set of optimizations done at each level will vary from release to release (and sometime from target to target), it is best to think of the optimization settings in general terms. ! @xref{Optimize Options,, Options That Control Optimization, gcc, Using ! the GNU Compiler Collection (GCC)}, for details about ^the @option{-O} settings and a number of @option{-f} options that^how to^ individually enable or disable specific optimizations. *************** The optimization level is at least @opti *** 9654,9671 **** @item The called subprogram is suitable for inlining: It must be small enough ! and not contain nested subprograms or anything else that @command{gcc} ! cannot support in inlined subprograms. ! ! @item ! The call occurs after the definition of the body of the subprogram. @item @cindex pragma Inline @findex Inline ! Either @code{pragma Inline} applies to the subprogram or it is ! small and automatic inlining (optimization level @option{-O3}) is ! specified. @end itemize @noindent --- 9884,9898 ---- @item The called subprogram is suitable for inlining: It must be small enough ! and not contain something that @command{gcc} cannot support in inlined ! subprograms. @item @cindex pragma Inline @findex Inline ! Either @code{pragma Inline} applies to the subprogram, or it is local ! to the unit and called once from within it, or it is small and automatic ! inlining (optimization level @option{-O3}) is specified. @end itemize @noindent *************** The optimization level is at least @opti *** 9679,9686 **** @item The called subprogram is suitable for inlining: It must be small enough ! and not contain nested subprograms or anything else @command{gcc} cannot ! support in inlined subprograms. @item The call appears in a body (not in a package spec). --- 9906,9913 ---- @item The called subprogram is suitable for inlining: It must be small enough ! and not contain something that @command{gcc} cannot support in inlined ! subprograms. @item The call appears in a body (not in a package spec). *************** package R is *** 9709,9721 **** pragma Inline (Q); end R; package body R is ! ... end R; with R; procedure Main is begin ! ... R.Q; end Main; @end cartouche --- 9936,9948 ---- pragma Inline (Q); end R; package body R is ! @dots{} end R; with R; procedure Main is begin ! @dots{} R.Q; end Main; @end cartouche *************** that no inlining occurs. The extra depen *** 9747,9752 **** --- 9974,9988 ---- @option{-gnatn} will still be active, even if this switch is used to suppress the resulting inlining actions. + @cindex @option{-fno-inline-functions} (@command{gcc}) + Note: The @option{-fno-inline-functions} switch can be used to prevent + automatic inlining of small subprograms if @option{-O3} is used. + + @cindex @option{-fno-inline-functions-called-once} (@command{gcc}) + Note: The @option{-fno-inline-functions-called-once} switch + can be used to prevent inlining of subprograms local to the unit + and called once from within it if @option{-O1} is used. + Note regarding the use of @option{-O3}: There is no difference in inlining behavior between @option{-O2} and @option{-O3} for subprograms with an explicit pragma @code{Inline} assuming the use of @option{-gnatn} *************** it actually improves performance. *** 9765,9779 **** @subsection Other Optimization Switches @cindex Optimization Switches ! Since @code{GNAT} uses the @code{gcc} back end, all the specialized ! @code{gcc} optimization switches are potentially usable. These switches have not been extensively tested with GNAT but can generally be expected to work. Examples of switches in this category are @option{-funroll-loops} and the various target-specific @option{-m} options (in particular, it has been observed that @option{-march=pentium4} can significantly improve performance ! on appropriate machines). For full details of these switches, see the ! @code{gcc} manual. @node Optimization and Strict Aliasing @subsection Optimization and Strict Aliasing --- 10001,10016 ---- @subsection Other Optimization Switches @cindex Optimization Switches ! Since @code{GNAT} uses the @command{gcc} back end, all the specialized ! @command{gcc} optimization switches are potentially usable. These switches have not been extensively tested with GNAT but can generally be expected to work. Examples of switches in this category are @option{-funroll-loops} and the various target-specific @option{-m} options (in particular, it has been observed that @option{-march=pentium4} can significantly improve performance ! on appropriate machines). For full details of these switches, see ! @ref{Submodel Options,, Hardware Models and Configurations, gcc, Using ! the GNU Compiler Collection (GCC)}. @node Optimization and Strict Aliasing @subsection Optimization and Strict Aliasing *************** procedure R is *** 9796,9811 **** type Int2A is access Int2; Int1V : Int1A; Int2V : Int2A; ! ... begin ! ... for J in Data'Range loop if Data (J) = Int1V.all then Int2V.all := Int2V.all + 1; end if; end loop; ! ... end R; @end cartouche @end smallexample --- 10033,10048 ---- type Int2A is access Int2; Int1V : Int1A; Int2V : Int2A; ! @dots{} begin ! @dots{} for J in Data'Range loop if Data (J) = Int1V.all then Int2V.all := Int2V.all + 1; end if; end loop; ! @dots{} end R; @end cartouche @end smallexample *************** end; *** 9868,9875 **** @end smallexample @noindent ! This program prints out 0 in @code{-O0} or @code{-O1} ! mode, but it prints out 1 in @code{-O2} mode. That's because in strict aliasing mode, the compiler can and does assume that the assignment to @code{v2.all} could not affect the value of @code{v1.all}, since different types --- 10105,10112 ---- @end smallexample @noindent ! This program prints out 0 in @option{-O0} or @option{-O1} ! mode, but it prints out 1 in @option{-O2} mode. That's because in strict aliasing mode, the compiler can and does assume that the assignment to @code{v2.all} could not affect the value of @code{v1.all}, since different types *************** the suspicious @code{Unchecked_Conversio *** 9907,9925 **** As implied by the warning message, there are approaches you can use to avoid the unwanted strict aliasing optimization in a case like this. ! One possibility is to simply avoid the use of @code{-O2}, but that is a bit drastic, since it throws away a number of useful optimizations that do not involve strict aliasing assumptions. A less drastic approach is to compile the program using the ! option @code{-fno-strict-aliasing}. Actually it is only the unit containing the dereferencing of the suspicious pointer that needs to be compiled. So in this case, if we compile unit @code{m} with this switch, then we get the expected value of zero printed. Analyzing which units might need the switch can be painful, so a more reasonable approach ! is to compile the entire program with options @code{-O2} ! and @code{-fno-strict-aliasing}. If the performance is satisfactory with this combination of options, then the advantage is that the entire issue of possible "wrong" optimization due to strict aliasing is avoided. --- 10144,10162 ---- As implied by the warning message, there are approaches you can use to avoid the unwanted strict aliasing optimization in a case like this. ! One possibility is to simply avoid the use of @option{-O2}, but that is a bit drastic, since it throws away a number of useful optimizations that do not involve strict aliasing assumptions. A less drastic approach is to compile the program using the ! option @option{-fno-strict-aliasing}. Actually it is only the unit containing the dereferencing of the suspicious pointer that needs to be compiled. So in this case, if we compile unit @code{m} with this switch, then we get the expected value of zero printed. Analyzing which units might need the switch can be painful, so a more reasonable approach ! is to compile the entire program with options @option{-O2} ! and @option{-fno-strict-aliasing}. If the performance is satisfactory with this combination of options, then the advantage is that the entire issue of possible "wrong" optimization due to strict aliasing is avoided. *************** the user to determine the distribution o *** 10000,10005 **** --- 10237,10266 ---- @pxref{Profiling} for details of usage. @end ifset + + @node Text_IO Suggestions + @section @code{Text_IO} Suggestions + @cindex @code{Text_IO} and performance + + @noindent + The @code{Ada.Text_IO} package has fairly high overheads due in part to + the requirement of maintaining page and line counts. If performance + is critical, a recommendation is to use @code{Stream_IO} instead of + @code{Text_IO} for volume output, since this package has less overhead. + + If @code{Text_IO} must be used, note that by default output to the standard + output and standard error files is unbuffered (this provides better + behavior when output statements are used for debugging, or if the + progress of a program is observed by tracking the output, e.g. by + using the Unix @command{tail -f} command to watch redirected output. + + If you are generating large volumes of output with @code{Text_IO} and + performance is an important factor, use a designated file instead + of the standard output file, or change the standard output file to + be buffered using @code{Interfaces.C_Streams.setvbuf}. + + + @node Reducing Size of Ada Executables with gnatelim @section Reducing Size of Ada Executables with @code{gnatelim} @findex gnatelim *************** subprograms that are declared but never *** 10032,10038 **** @code{Eliminate} pragmas in the GNAT configuration file @file{gnat.adc} and recompiling your program, you may decrease the size of its executable, because the compiler will not generate the code for 'eliminated' subprograms. ! See GNAT Reference Manual for more information about this pragma. @code{gnatelim} needs as its input data the name of the main subprogram and a bind file for a main subprogram. --- 10293,10300 ---- @code{Eliminate} pragmas in the GNAT configuration file @file{gnat.adc} and recompiling your program, you may decrease the size of its executable, because the compiler will not generate the code for 'eliminated' subprograms. ! @xref{Pragma Eliminate,,, gnat_rm, GNAT Reference Manual}, for more ! information about this pragma. @code{gnatelim} needs as its input data the name of the main subprogram and a bind file for a main subprogram. *************** Note that @code{gnatelim} needs neither *** 10056,10062 **** @code{gnatelim} has the following command-line interface: @smallexample ! $ gnatelim [options] name @end smallexample @noindent --- 10318,10324 ---- @code{gnatelim} has the following command-line interface: @smallexample ! $ gnatelim @ovar{options} name @end smallexample @noindent *************** Generate a list of @code{Eliminate} prag *** 10207,10213 **** $ PIPE GNAT ELIM MAIN_PROG > GNAT.ADC @end ifset @ifclear vms ! $ gnatelim main_prog >[>] gnat.adc @end ifclear @end smallexample --- 10469,10475 ---- $ PIPE GNAT ELIM MAIN_PROG > GNAT.ADC @end ifset @ifclear vms ! $ gnatelim main_prog >@r{[}>@r{]} gnat.adc @end ifclear @end smallexample *************** function or data in a separate section i *** 10268,10275 **** Once the objects and static libraries are created with these options, the linker can perform the dead code elimination. You can do this by setting the @option{-Wl,--gc-sections} option to gcc command or in the ! @option{-largs} section of gnatmake. This will perform a garbage collection of ! code and data never referenced. If the linker performs a partial link (@option{-r} ld linker option), then you will need to provide one or several entry point using the --- 10530,10537 ---- Once the objects and static libraries are created with these options, the linker can perform the dead code elimination. You can do this by setting the @option{-Wl,--gc-sections} option to gcc command or in the ! @option{-largs} section of @command{gnatmake}. This will perform a ! garbage collection of code and data never referenced. If the linker performs a partial link (@option{-r} ld linker option), then you will need to provide one or several entry point using the *************** in which GNAT processes the ACVC tests. *** 10455,10462 **** The @code{gnatchop} command has the form: @smallexample ! $ gnatchop switches @var{file name} [@var{file name} @var{file name} ...] ! [@var{directory}] @end smallexample @noindent --- 10717,10724 ---- The @code{gnatchop} command has the form: @smallexample ! $ gnatchop switches @var{file name} @r{[}@var{file name} @dots{}@r{]} ! @ovar{directory} @end smallexample @noindent *************** configuration pragmas are handled accord *** 10560,10568 **** previous section for a full description of this mode. @ifclear vms ! @item -gnatxxx ! This passes the given @option{-gnatxxx} switch to @code{gnat} which is ! used to parse the given file. Not all @code{xxx} options make sense, but for example, the use of @option{-gnati2} allows @code{gnatchop} to process a source file that uses Latin-2 coding for identifiers. @end ifclear --- 10822,10830 ---- previous section for a full description of this mode. @ifclear vms ! @item -gnat@var{xxx} ! This passes the given @option{-gnat@var{xxx}} switch to @code{gnat} which is ! used to parse the given file. Not all @var{xxx} options make sense, but for example, the use of @option{-gnati2} allows @code{gnatchop} to process a source file that uses Latin-2 coding for identifiers. @end ifclear *************** check, and causes all but the last insta *** 10646,10652 **** units to be skipped. @ifclear vms ! @item --GCC=xxxx @cindex @option{--GCC=} (@code{gnatchop}) Specify the path of the GNAT parser to be used. When this switch is used, no attempt is made to add the prefix to the GNAT parser executable. --- 10908,10914 ---- units to be skipped. @ifclear vms ! @item --GCC=@var{xxxx} @cindex @option{--GCC=} (@code{gnatchop}) Specify the path of the GNAT parser to be used. When this switch is used, no attempt is made to add the prefix to the GNAT parser executable. *************** unit will be skipped. *** 10699,10708 **** @noindent Configuration pragmas include those pragmas described as such in the Ada Reference Manual, as well as ! implementation-dependent pragmas that are configuration pragmas. See the ! individual descriptions of pragmas in the @cite{GNAT Reference Manual} for ! details on these additional GNAT-specific configuration pragmas. Most ! notably, the pragma @code{Source_File_Name}, which allows specifying non-default names for source files, is a configuration pragma. The following is a complete list of configuration pragmas recognized by GNAT: --- 10961,10970 ---- @noindent Configuration pragmas include those pragmas described as such in the Ada Reference Manual, as well as ! implementation-dependent pragmas that are configuration pragmas. ! @xref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference Manual}, ! for details on these additional GNAT-specific configuration pragmas. ! Most notably, the pragma @code{Source_File_Name}, which allows specifying non-default names for source files, is a configuration pragma. The following is a complete list of configuration pragmas recognized by GNAT: *************** recognized by GNAT: *** 10711,10733 **** --- 10973,11010 ---- Ada_83 Ada_95 Ada_05 + Ada_2005 + Assertion_Policy C_Pass_By_Copy + Check_Name + Check_Policy + Compile_Time_Error + Compile_Time_Warning + Compiler_Unit Component_Alignment + Debug_Policy Detect_Blocking Discard_Names Elaboration_Checks Eliminate Extend_System External_Name_Casing + Fast_Math + Favor_Top_Level Float_Representation + Implicit_Packing Initialize_Scalars Interrupt_State License Locking_Policy Long_Float + No_Run_Time + No_Strict_Aliasing Normalize_Scalars + Optimize_Alignment Persistent_BSS Polling + Priority_Specific_Dispatching Profile Profile_Warnings Propagate_Exceptions *************** recognized by GNAT: *** 10738,10751 **** Restrictions_Warnings Reviewable Source_File_Name Style_Checks Suppress Task_Dispatching_Policy Universal_Data Unsuppress Use_VADS_Size - Warnings Validity_Checks @end smallexample @menu --- 11015,11032 ---- Restrictions_Warnings Reviewable Source_File_Name + Source_File_Name_Project Style_Checks Suppress + Suppress_Exception_Locations Task_Dispatching_Policy Universal_Data Unsuppress Use_VADS_Size Validity_Checks + Warnings + Wide_Character_Encoding + @end smallexample @menu *************** When the source file names do not follow *** 10842,10848 **** conventions, the GNAT compiler must be given additional information through a configuration pragmas file (@pxref{Configuration Pragmas}) or a project file. ! When the non standard file naming conventions are well-defined, a small number of pragmas @code{Source_File_Name} specifying a naming pattern (@pxref{Alternative File Naming Schemes}) may be sufficient. However, if the file naming conventions are irregular or arbitrary, a number --- 11123,11129 ---- conventions, the GNAT compiler must be given additional information through a configuration pragmas file (@pxref{Configuration Pragmas}) or a project file. ! When the non-standard file naming conventions are well-defined, a small number of pragmas @code{Source_File_Name} specifying a naming pattern (@pxref{Alternative File Naming Schemes}) may be sufficient. However, if the file naming conventions are irregular or arbitrary, a number *************** set of files. *** 10860,10866 **** The usual form of the @code{gnatname} command is @smallexample ! $ gnatname [@var{switches}] @var{naming_pattern} [@var{naming_patterns}] @end smallexample @noindent --- 11141,11148 ---- The usual form of the @code{gnatname} command is @smallexample ! $ gnatname @ovar{switches} @var{naming_pattern} @ovar{naming_patterns} ! @r{[}--and @ovar{switches} @var{naming_pattern} @ovar{naming_patterns}@r{]} @end smallexample @noindent *************** A Naming Pattern is a regular expression *** 10881,10886 **** --- 11163,11176 ---- used in file names by the Unix shells or the DOS prompt. @noindent + @code{gnatname} may be called with several sections of directories/patterns. + Sections are separated by switch @code{--and}. In each section, there must be + at least one pattern. If no directory is specified in a section, the current + directory (or the project directory is @code{-P} is used) is implied. + The options other that the directory switches and the patterns apply globally + even if they are in different sections. + + @noindent Examples of Naming Patterns are @smallexample *************** see the second kind of regular expressio *** 10895,10903 **** (the ``Glob'' regular expressions). @noindent ! When invoked with no switches, @code{gnatname} will create a configuration ! pragmas file @file{gnat.adc} in the current working directory, with pragmas ! @code{Source_File_Name} for each file that contains a valid Ada unit. @node Switches for gnatname @section Switches for @code{gnatname} --- 11185,11194 ---- (the ``Glob'' regular expressions). @noindent ! When invoked with no switch @code{-P}, @code{gnatname} will create a ! configuration pragmas file @file{gnat.adc} in the current working directory, ! with pragmas @code{Source_File_Name} for each file that contains a valid Ada ! unit. @node Switches for gnatname @section Switches for @code{gnatname} *************** Display Copyright and version, then exit *** 10920,10925 **** --- 11211,11219 ---- If @option{--version} was not used, display usage, then exit disregarding all other options. + @item --and + Start another section of directories/patterns. + @item ^-c^/CONFIG_FILE=^@file{file} @cindex @option{^-c^/CONFIG_FILE^} (@code{gnatname}) Create a configuration pragmas file @file{file} (instead of the default *************** Look for source files in all directories *** 10958,10966 **** There may be zero, one or more spaces between @option{^-D^/DIRS_FILE=^} and @file{file}. @file{file} must be an existing, readable text file. ! Each non empty line in @file{file} must be a directory. Specifying switch @option{^-D^/DIRS_FILE^} is equivalent to specifying as many ! switches @option{^-d^/SOURCE_DIRS^} as there are non empty lines in @file{file}. @item ^-f^/FOREIGN_PATTERN=^@file{pattern} --- 11252,11260 ---- There may be zero, one or more spaces between @option{^-D^/DIRS_FILE=^} and @file{file}. @file{file} must be an existing, readable text file. ! Each nonempty line in @file{file} must be a directory. Specifying switch @option{^-D^/DIRS_FILE^} is equivalent to specifying as many ! switches @option{^-d^/SOURCE_DIRS^} as there are nonempty lines in @file{file}. @item ^-f^/FOREIGN_PATTERN=^@file{pattern} *************** gnatname ^-Pprj -f"*.c"^/PROJECT_FILE=PR *** 10975,10981 **** @noindent will look for Ada units in all files with the @file{.ada} extension, and will add to the list of file for project @file{prj.gpr} the C files ! with extension ".^c^C^". @item ^-h^/HELP^ @cindex @option{^-h^/HELP^} (@code{gnatname}) --- 11269,11275 ---- @noindent will look for Ada units in all files with the @file{.ada} extension, and will add to the list of file for project @file{prj.gpr} the C files ! with extension @file{.^c^C^}. @item ^-h^/HELP^ @cindex @option{^-h^/HELP^} (@code{gnatname}) *************** that might be used by the developers. *** 11210,11216 **** The next section introduces the main features of GNAT's project facility through a sequence of examples; subsequent sections will present the syntax and semantics in more detail. A more formal description of the project ! facility appears in the GNAT Reference Manual. @c ***************************** @c * Examples of Project Files * --- 11504,11511 ---- The next section introduces the main features of GNAT's project facility through a sequence of examples; subsequent sections will present the syntax and semantics in more detail. A more formal description of the project ! facility appears in @ref{Project File Reference,,, gnat_rm, GNAT ! Reference Manual}. @c ***************************** @c * Examples of Project Files * *************** Attribute @code{Executable_Suffix}, when *** 11480,11486 **** of the executable files, when no attribute @code{Executable} applies: its value replace the platform-specific executable suffix. Attributes @code{Executable} and @code{Executable_Suffix} are the only ways to ! specify a non default executable file name when several mains are built at once in a single @command{gnatmake} command. @node Source File Naming Conventions --- 11775,11781 ---- of the executable files, when no attribute @code{Executable} applies: its value replace the platform-specific executable suffix. Attributes @code{Executable} and @code{Executable_Suffix} are the only ways to ! specify a non-default executable file name when several mains are built at once in a single @command{gnatmake} command. @node Source File Naming Conventions *************** files is located in its respective proje *** 11666,11672 **** @noindent We want to develop an application in directory @file{^/app^[APP]^} that @code{with} the packages @code{GUI} and @code{Comm}, using the properties of ! the corresponding project files (e.g. the ^switch^switch^ settings and object directory). Skeletal code for a main procedure might be something like the following: --- 11961,11967 ---- @noindent We want to develop an application in directory @file{^/app^[APP]^} that @code{with} the packages @code{GUI} and @code{Comm}, using the properties of ! the corresponding project files (e.g.@: the ^switch^switch^ settings and object directory). Skeletal code for a main procedure might be something like the following: *************** Skeletal code for a main procedure might *** 11674,11682 **** @group with GUI, Comm; procedure App_Main is ! ... begin ! ... end App_Main; @end group @end smallexample --- 11969,11977 ---- @group with GUI, Comm; procedure App_Main is ! @dots{} begin ! @dots{} end App_Main; @end group @end smallexample *************** relaxed in a future release. *** 11750,11756 **** @noindent In large software systems it is common to have multiple implementations of a common interface; in Ada terms, multiple versions of a ! package body for the same specification. For example, one implementation might be safe for use in tasking programs, while another might only be used in sequential applications. This can be modeled in GNAT using the concept of @emph{project extension}. If one project (the ``child'') @emph{extends} --- 12045,12051 ---- @noindent In large software systems it is common to have multiple implementations of a common interface; in Ada terms, multiple versions of a ! package body for the same spec. For example, one implementation might be safe for use in tasking programs, while another might only be used in sequential applications. This can be modeled in GNAT using the concept of @emph{project extension}. If one project (the ``child'') @emph{extends} *************** the inherited body is not part of the so *** 11831,11837 **** will be a compilation error when compiling the spec. For that purpose, the attribute @code{Excluded_Source_Files} is used. ! Its value is a string list: a list of file names. @smallexample @c @projectfile project B extends "a" is --- 12126,12134 ---- will be a compilation error when compiling the spec. For that purpose, the attribute @code{Excluded_Source_Files} is used. ! Its value is a string list: a list of file names. It is also possible to use ! attribute @code{Excluded_Source_List_File}. Its value is a single string: ! the file name of a text file containing a list of file names, one per line. @smallexample @c @projectfile project B extends "a" is *************** project P. *** 11856,11861 **** --- 12153,12159 ---- @menu * Basic Syntax:: + * Qualified Projects:: * Packages:: * Expressions:: * String Types:: *************** word @code{end} at the end of the projec *** 11913,11924 **** Any name in a project file, such as the project name or a variable name, has the same syntax as an Ada identifier. ! The reserved words of project files are the Ada reserved words plus @code{extends}, @code{external}, and @code{project}. Note that the only Ada reserved words currently used in project file syntax are: @itemize @bullet @item @code{case} @item @code{end} --- 12211,12226 ---- Any name in a project file, such as the project name or a variable name, has the same syntax as an Ada identifier. ! The reserved words of project files are the Ada 95 reserved words plus @code{extends}, @code{external}, and @code{project}. Note that the only Ada reserved words currently used in project file syntax are: @itemize @bullet @item + @code{all} + @item + @code{at} + @item @code{case} @item @code{end} *************** reserved words currently used in project *** 11927,11932 **** --- 12229,12238 ---- @item @code{is} @item + @code{limited} + @item + @code{null} + @item @code{others} @item @code{package} *************** reserved words currently used in project *** 11946,11951 **** --- 12252,12290 ---- Comments in project files have the same syntax as in Ada, two consecutive hyphens through the end of the line. + @node Qualified Projects + @subsection Qualified Projects + + @noindent + Before the reserved @code{project}, there may be one or two "qualifiers", that + is identifiers or other reserved words, to qualify the project. + + The current list of qualifiers is: + + @itemize @bullet + @item + @code{abstract}: qualify a project with no sources. An abstract project must + have a declaration specifying that there are no sources in the project, and, + if it extends another project, the project it extends must also be a qualified + abstract project. + + @item + @code{standard}: a standard project is a non library project with sources. + + @item + @code{aggregate}: for future extension + + @item + @code{aggregate library}: for future extension + + @item + @code{library}: a library project must declare both attributes + @code{Library_Name} and @code{Library_Dir}. + + @item + @code{configuration}: a configuration project cannot be in a project tree. + @end itemize + @node Packages @subsection Packages *************** A @emph{string expression} is either a @ *** 12020,12026 **** A @emph{simple string expression} is one of the following: @itemize @bullet ! @item A literal string; e.g.@code{"comm/my_proj.gpr"} @item A string-valued variable reference (@pxref{Variables}) @item A string-valued attribute reference (@pxref{Attributes}) @item An external reference (@pxref{External References in Project Files}) --- 12359,12365 ---- A @emph{simple string expression} is one of the following: @itemize @bullet ! @item A literal string; e.g.@: @code{"comm/my_proj.gpr"} @item A string-valued variable reference (@pxref{Variables}) @item A string-valued attribute reference (@pxref{Attributes}) @item An external reference (@pxref{External References in Project Files}) *************** The following attributes are defined on *** 12212,12217 **** --- 12551,12558 ---- @tab string list @item @code{Excluded_Source_Files} @tab string list + @item @code{Excluded_Source_List_File} + @tab string @item @code{Languages} @tab string list @item @code{Main} *************** The prefix of an attribute may be: *** 12353,12359 **** @item The name of an imported project @item The name of a parent project that is extended by the current project @item An expanded name whose prefix is imported/parent project name, ! and whose selector is a package name @end itemize @noindent --- 12694,12700 ---- @item The name of an imported project @item The name of a parent project that is extended by the current project @item An expanded name whose prefix is imported/parent project name, ! and whose selector is a package name @end itemize @noindent *************** in the project file. *** 12518,12524 **** @end smallexample @noindent ! The attribute @var{Object_Dir} has a string value, the path name of the object directory. The path name may be absolute or relative to the directory of the project file. This directory must already exist, and be readable and writable. --- 12859,12865 ---- @end smallexample @noindent ! The attribute @code{Object_Dir} has a string value, the path name of the object directory. The path name may be absolute or relative to the directory of the project file. This directory must already exist, and be readable and writable. *************** in the project file. *** 12541,12547 **** @end smallexample @noindent ! The attribute @var{Exec_Dir} has a string value, the path name of the exec directory. The path name may be absolute or relative to the directory of the project file. This directory must already exist, and be writable. --- 12882,12888 ---- @end smallexample @noindent ! The attribute @code{Exec_Dir} has a string value, the path name of the exec directory. The path name may be absolute or relative to the directory of the project file. This directory must already exist, and be writable. *************** source files. *** 12688,12694 **** with "project1", "utilities.gpr"; with "/namings/apex.gpr"; project Main is ! ... @end group @end smallexample --- 13029,13035 ---- with "project1", "utilities.gpr"; with "/namings/apex.gpr"; project Main is ! @dots{} @end group @end smallexample *************** modified versions of some of the source *** 12815,12821 **** sources. This can be achieved through the @emph{project extension} facility. @smallexample @c projectfile ! project Modified_Utilities extends "/baseline/utilities.gpr" is ... @end smallexample @noindent --- 13156,13162 ---- sources. This can be achieved through the @emph{project extension} facility. @smallexample @c projectfile ! project Modified_Utilities extends "/baseline/utilities.gpr" is @dots{} @end smallexample @noindent *************** of the child project; see @ref{Project F *** 12831,12845 **** An inherited source file retains any switches specified in the parent project. ! For example if the project @code{Utilities} contains the specification and the body of an Ada package @code{Util_IO}, then the project @code{Modified_Utilities} can contain a new body for package @code{Util_IO}. The original body of @code{Util_IO} will not be considered in program builds. ! However, the package specification will still be found in the project @code{Utilities}. ! A child project can have only one parent but it may import any number of other ! projects. A project is not allowed to import directly or indirectly at the same time a child project and any of its ancestors. --- 13172,13186 ---- An inherited source file retains any switches specified in the parent project. ! For example if the project @code{Utilities} contains the spec and the body of an Ada package @code{Util_IO}, then the project @code{Modified_Utilities} can contain a new body for package @code{Util_IO}. The original body of @code{Util_IO} will not be considered in program builds. ! However, the package spec will still be found in the project @code{Utilities}. ! A child project can have only one parent, except when it is qualified as ! abstract. But it may import any number of other projects. A project is not allowed to import directly or indirectly at the same time a child project and any of its ancestors. *************** This project hierarchy will need to be e *** 12894,12900 **** Create project A1 that extends A, placing modified P1 there: @smallexample @c 0projectfile ! project A1 extends "(...)/A" is end A1; @end smallexample --- 13235,13241 ---- Create project A1 that extends A, placing modified P1 there: @smallexample @c 0projectfile ! project A1 extends "(@dots{})/A" is end A1; @end smallexample *************** Create project C1 that "extends all" C a *** 12903,12910 **** P3 there: @smallexample @c 0projectfile ! with "(...)/A1"; ! project C1 extends all "(...)/C" is end C1; @end smallexample @end enumerate --- 13244,13251 ---- P3 there: @smallexample @c 0projectfile ! with "(@dots{})/A1"; ! project C1 extends all "(@dots{})/C" is end C1; @end smallexample @end enumerate *************** an attribute declaration. *** 12969,12975 **** Mode : Mode_Type := external ("MODE"); case Mode is when "Debug" => ! ... @end group @end smallexample --- 13310,13316 ---- Mode : Mode_Type := external ("MODE"); case Mode is when "Debug" => ! @dots{} @end group @end smallexample *************** the project file for an imported project *** 13029,13035 **** with "/global/apex.gpr"; project Example is package Naming renames Apex.Naming; ! ... end Example; @end group @end smallexample --- 13370,13376 ---- with "/global/apex.gpr"; project Example is package Naming renames Apex.Naming; ! @dots{} end Example; @end group @end smallexample *************** You can define the following attributes *** 13169,13182 **** @table @code ! @item @var{Casing} This must be a string with one of the three values @code{"lowercase"}, @code{"uppercase"} or @code{"mixedcase"}; these strings are case insensitive. @noindent ! If @var{Casing} is not specified, then the default is @code{"lowercase"}. ! @item @var{Dot_Replacement} This must be a string whose value satisfies the following conditions: @itemize @bullet --- 13510,13523 ---- @table @code ! @item @code{Casing} This must be a string with one of the three values @code{"lowercase"}, @code{"uppercase"} or @code{"mixedcase"}; these strings are case insensitive. @noindent ! If @code{Casing} is not specified, then the default is @code{"lowercase"}. ! @item @code{Dot_Replacement} This must be a string whose value satisfies the following conditions: @itemize @bullet *************** is @code{"."} *** 13191,13197 **** @noindent If @code{Dot_Replacement} is not specified, then the default is @code{"-"}. ! @item @var{Spec_Suffix} This is an associative array (indexed by the programming language name, case insensitive) whose value is a string that must satisfy the following conditions: --- 13532,13538 ---- @noindent If @code{Dot_Replacement} is not specified, then the default is @code{"-"}. ! @item @code{Spec_Suffix} This is an associative array (indexed by the programming language name, case insensitive) whose value is a string that must satisfy the following conditions: *************** conditions: *** 13204,13210 **** If @code{Spec_Suffix ("Ada")} is not specified, then the default is @code{"^.ads^.ADS^"}. ! @item @var{Body_Suffix} This is an associative array (indexed by the programming language name, case insensitive) whose value is a string that must satisfy the following conditions: --- 13545,13551 ---- If @code{Spec_Suffix ("Ada")} is not specified, then the default is @code{"^.ads^.ADS^"}. ! @item @code{Body_Suffix} This is an associative array (indexed by the programming language name, case insensitive) whose value is a string that must satisfy the following conditions: *************** if the longest suffix is @code{Spec_Suff *** 13223,13229 **** If @code{Body_Suffix ("Ada")} is not specified, then the default is @code{"^.adb^.ADB^"}. ! @item @var{Separate_Suffix} This must be a string whose value satisfies the same conditions as @code{Body_Suffix}. The same "longest suffix" rules apply. --- 13564,13570 ---- If @code{Body_Suffix ("Ada")} is not specified, then the default is @code{"^.adb^.ADB^"}. ! @item @code{Separate_Suffix} This must be a string whose value satisfies the same conditions as @code{Body_Suffix}. The same "longest suffix" rules apply. *************** This must be a string whose value satisf *** 13231,13237 **** If @code{Separate_Suffix ("Ada")} is not specified, then it defaults to same value as @code{Body_Suffix ("Ada")}. ! @item @var{Spec} @noindent You can use the associative array attribute @code{Spec} to define the source file name for an individual Ada compilation unit's spec. The array --- 13572,13578 ---- If @code{Separate_Suffix ("Ada")} is not specified, then it defaults to same value as @code{Body_Suffix ("Ada")}. ! @item @code{Spec} @noindent You can use the associative array attribute @code{Spec} to define the source file name for an individual Ada compilation unit's spec. The array *************** operating system). *** 13244,13250 **** for Spec ("MyPack.MyChild") use "mypack.mychild.spec"; @end smallexample ! @item @var{Body} You can use the associative array attribute @code{Body} to define the source file name for an individual Ada compilation unit's body --- 13585,13591 ---- for Spec ("MyPack.MyChild") use "mypack.mychild.spec"; @end smallexample ! @item @code{Body} You can use the associative array attribute @code{Body} to define the source file name for an individual Ada compilation unit's body *************** that make a project a Library Project (@ *** 13414,13420 **** @end group @end smallexample ! Attribute @code{Library_Interface} has a non empty string list value, each string in the list designating a unit contained in an immediate source of the project file. --- 13755,13761 ---- @end group @end smallexample ! Attribute @code{Library_Interface} has a nonempty string list value, each string in the list designating a unit contained in an immediate source of the project file. *************** two possible values: "false" or "true" ( *** 13437,13443 **** "false" for attribute @code{Library_Auto_Init} will prevent automatic initialization of dynamic or relocatable libraries. ! When a non automatically initialized Stand-alone Library is used in an executable, its initialization procedure must be called before any service of the library is used. When the main subprogram is in Ada, it may mean that the initialization --- 13778,13784 ---- "false" for attribute @code{Library_Auto_Init} will prevent automatic initialization of dynamic or relocatable libraries. ! When a non-automatically initialized Stand-alone Library is used in an executable, its initialization procedure must be called before any service of the library is used. When the main subprogram is in Ada, it may mean that the initialization *************** The following switches are used by GNAT *** 13482,13488 **** @table @option @item ^-P^/PROJECT_FILE=^@var{project} ! @cindex @option{^-P^/PROJECT_FILE^} (any tool supporting project files) Indicates the name of a project file. This project file will be parsed with the verbosity indicated by @option{^-vP^MESSAGE_PROJECT_FILES=^@emph{x}}, if any, and using the external references indicated --- 13823,13829 ---- @table @option @item ^-P^/PROJECT_FILE=^@var{project} ! @cindex @option{^-P^/PROJECT_FILE^} (any project-aware tool) Indicates the name of a project file. This project file will be parsed with the verbosity indicated by @option{^-vP^MESSAGE_PROJECT_FILES=^@emph{x}}, if any, and using the external references indicated *************** on the command line are checked, the ord *** 13502,13508 **** or @option{^-X^/EXTERNAL_REFERENCE^} is not significant. @item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} ! @cindex @option{^-X^/EXTERNAL_REFERENCE^} (any tool supporting project files) Indicates that external variable @var{name} has the value @var{value}. The Project Manager will use this value for occurrences of @code{external(name)} when parsing the project file. --- 13843,13849 ---- or @option{^-X^/EXTERNAL_REFERENCE^} is not significant. @item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} ! @cindex @option{^-X^/EXTERNAL_REFERENCE^} (any project-aware tool) Indicates that external variable @var{name} has the value @var{value}. The Project Manager will use this value for occurrences of @code{external(name)} when parsing the project file. *************** An external variable specified with a @o *** 13527,13534 **** takes precedence over the value of the same name in the environment. @item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} ! @cindex @code{^-vP^/MESSAGES_PROJECT_FILE^} (any tool supporting project files) ! @c Previous line uses code vs option command, to stay less than 80 chars Indicates the verbosity of the parsing of GNAT project files. @ifclear vms --- 13868,13874 ---- takes precedence over the value of the same name in the environment. @item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} ! @cindex @option{^-vP^/MESSAGES_PROJECT_FILE^} (any project-aware tool) Indicates the verbosity of the parsing of GNAT project files. @ifclear vms *************** project files. *** 13549,13554 **** --- 13889,13913 ---- If several @option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} switches are present, only the last one is used. + @item ^-aP^/ADD_PROJECT_SEARCH_DIR=^ + @cindex @option{^-aP^/ADD_PROJECT_SEARCH_DIR=^} (any project-aware tool) + Add directory at the beginning of the project search path, in order, + after the current working directory. + + @ifclear vms + @item -eL + @cindex @option{-eL} (any project-aware tool) + Follow all symbolic links when processing project files. + @end ifclear + + @item ^--subdirs^/SUBDIRS^= + @cindex @option{^--subdirs^/SUBDIRS^=} (gnatmake and gnatclean) + This switch is recognized by gnatmake and gnatclean. It indicate that the real + directories (except the source directories) are the subdirectories + of the directories specified in the project files. This applies in particular + to object directories, library directories and exec directories. If the + subdirectories do not exist, they are created automatically. + @end table @c ********************************** *************** end Proj4; *** 13799,13805 **** -- Ada source file: with Pack; procedure Foo_Main is ! ... end Foo_Main; @end group @end smallexample --- 14158,14164 ---- -- Ada source file: with Pack; procedure Foo_Main is ! @dots{} end Foo_Main; @end group @end smallexample *************** XREF to invoke @command{^gnatxref^gnatxr *** 14028,14034 **** @command{^gnatmake -f -u -c^gnatmake -f -u -c^}). @noindent ! On non VMS platforms, between @command{gnat} and the command, two special switches may be used: @itemize @bullet --- 14387,14393 ---- @command{^gnatmake -f -u -c^gnatmake -f -u -c^}). @noindent ! On non-VMS platforms, between @command{gnat} and the command, two special switches may be used: @itemize @bullet *************** It is also possible to invoke some of th *** 14252,14258 **** @code{^gnatmetric^gnatmetric^}), and @code{^gnatpp^gnatpp^}) on a set of project units thanks to the combination of the switches ! @code{-P}, @code{-U} and possibly the main unit when one is interested in its closure. For instance, @smallexample gnat metric -Pproj --- 14611,14617 ---- @code{^gnatmetric^gnatmetric^}), and @code{^gnatpp^gnatpp^}) on a set of project units thanks to the combination of the switches ! @option{-P}, @option{-U} and possibly the main unit when one is interested in its closure. For instance, @smallexample gnat metric -Pproj *************** declarative_item ::= *** 14457,14465 **** other_declarative_item package_declaration ::= ! package_specification | package_renaming ! package_specification ::= @b{package} package_identifier @b{is} @{simple_declarative_item@} @b{end} package_identifier ; --- 14816,14824 ---- other_declarative_item package_declaration ::= ! package_spec | package_renaming ! package_spec ::= @b{package} package_identifier @b{is} @{simple_declarative_item@} @b{end} package_identifier ; *************** use the @code{gnat} driver (see @ref{The *** 14596,14609 **** @noindent The command invocation for @code{gnatxref} is: @smallexample ! $ gnatxref [switches] sourcefile1 [sourcefile2 ...] @end smallexample @noindent where ! @table @code ! @item sourcefile1, sourcefile2 identifies the source files for which a report is to be generated. The ``with''ed units will be processed too. You must provide at least one file. --- 14955,14969 ---- @noindent The command invocation for @code{gnatxref} is: @smallexample ! $ gnatxref @ovar{switches} @var{sourcefile1} @r{[}@var{sourcefile2} @dots{}@r{]} @end smallexample @noindent where ! @table @var ! @item sourcefile1 ! @itemx sourcefile2 identifies the source files for which a report is to be generated. The ``with''ed units will be processed too. You must provide at least one file. *************** you can say @samp{gnatxref ^-ag^/ALL_FIL *** 14727,14743 **** The command line for @code{gnatfind} is: @smallexample ! $ gnatfind [switches] pattern[:sourcefile[:line[:column]]] ! [file1 file2 ...] @end smallexample @noindent where ! @table @code @item pattern An entity will be output only if it matches the regular expression found ! in @samp{pattern}, see @ref{Regular Expressions in gnatfind and gnatxref}. Omitting the pattern is equivalent to specifying @samp{*}, which will match any entity. Note that if you do not provide a pattern, you --- 15087,15103 ---- The command line for @code{gnatfind} is: @smallexample ! $ gnatfind @ovar{switches} @var{pattern}@r{[}:@var{sourcefile}@r{[}:@var{line}@r{[}:@var{column}@r{]]]} ! @r{[}@var{file1} @var{file2} @dots{}] @end smallexample @noindent where ! @table @var @item pattern An entity will be output only if it matches the regular expression found ! in @var{pattern}, see @ref{Regular Expressions in gnatfind and gnatxref}. Omitting the pattern is equivalent to specifying @samp{*}, which will match any entity. Note that if you do not provide a pattern, you *************** for matching purposes. At the current ti *** 14749,14756 **** @item sourcefile @code{gnatfind} will look for references, bodies or declarations ! of symbols referenced in @file{sourcefile}, at line @samp{line} ! and column @samp{column}. See @ref{Examples of gnatfind Usage} for syntax examples. @item line --- 15109,15116 ---- @item sourcefile @code{gnatfind} will look for references, bodies or declarations ! of symbols referenced in @file{@var{sourcefile}}, at line @var{line} ! and column @var{column}. See @ref{Examples of gnatfind Usage} for syntax examples. @item line *************** is a decimal integer identifying the exa *** 14762,14782 **** line of the first character of the identifier for the entity reference. Columns are numbered from 1. ! @item file1 file2 ... The search will be restricted to these source files. If none are given, then the search will be done for every library file in the search path. These file must appear only after the pattern or sourcefile. These file names are considered to be regular expressions, so for instance ! specifying 'source*.adb' is the same as giving every file in the current ! directory whose name starts with 'source' and whose extension is 'adb'. The location of the spec of the entity will always be displayed, even if it ! isn't in one of file1, file2,... The occurrences of the entity in the ! separate units of the ones given on the command line will also be displayed. Note that if you specify at least one file in this part, @code{gnatfind} may ! sometimes not be able to find the body of the subprograms... @end table --- 15122,15144 ---- line of the first character of the identifier for the entity reference. Columns are numbered from 1. ! @item file1 file2 @dots{} The search will be restricted to these source files. If none are given, then the search will be done for every library file in the search path. These file must appear only after the pattern or sourcefile. These file names are considered to be regular expressions, so for instance ! specifying @file{source*.adb} is the same as giving every file in the current ! directory whose name starts with @file{source} and whose extension is ! @file{adb}. The location of the spec of the entity will always be displayed, even if it ! isn't in one of @file{@var{file1}}, @file{@var{file2}},@enddots{} The ! occurrences of the entity in the separate units of the ones given on the ! command line will also be displayed. Note that if you specify at least one file in this part, @code{gnatfind} may ! sometimes not be able to find the body of the subprograms. @end table *************** specifies the command used to compile a *** 14980,14987 **** @ifclear vms @item make_cmd=COMMAND [default: @code{"gnatmake $@{main@} -aI$@{src_dir@} ! -aO$@{obj_dir@} -g -gnatq -cargs $@{comp_opt@} ! -bargs $@{bind_opt@} -largs $@{link_opt@}"}] @end ifclear specifies the command used to recompile the whole application. --- 15342,15349 ---- @ifclear vms @item make_cmd=COMMAND [default: @code{"gnatmake $@{main@} -aI$@{src_dir@} ! -aO$@{obj_dir@} -g -gnatq -cargs $@{comp_opt@} ! -bargs $@{bind_opt@} -largs $@{link_opt@}"}] @end ifclear specifies the command used to recompile the whole application. *************** reference manual style BNF is as follows *** 15040,15046 **** @leftskip=.5cm @end iftex @group ! regexp ::= term @{| term@} -- alternation (term or term ...) term ::= item @{item@} -- concatenation (item then item) --- 15402,15408 ---- @leftskip=.5cm @end iftex @group ! regexp ::= term @{| term@} -- alternation (term or term @dots{}) term ::= item @{item@} -- concatenation (item then item) *************** Following are a few examples: *** 15067,15076 **** @table @samp @item abcde|fghi ! will match any of the two strings 'abcde' and 'fghi'. @item abc*d ! will match any string like 'abd', 'abcd', 'abccd', 'abcccd', and so on @item [a-z]+ will match any string which has only lowercase characters in it (and at --- 15429,15439 ---- @table @samp @item abcde|fghi ! will match any of the two strings @samp{abcde} and @samp{fghi}, @item abc*d ! will match any string like @samp{abd}, @samp{abcd}, @samp{abccd}, ! @samp{abcccd}, and so on, @item [a-z]+ will match any string which has only lowercase characters in it (and at *************** $ gnatxref -v gnatfind.adb > tags *** 15193,15200 **** will generate the tags file for @code{gnatfind} itself (if the sources are in the search path!). ! From @command{vi}, you can then use the command @samp{:tag @i{entity}} ! (replacing @i{entity} by whatever you are looking for), and vi will display a new file with the corresponding declaration of entity. @end ifclear --- 15556,15563 ---- will generate the tags file for @code{gnatfind} itself (if the sources are in the search path!). ! From @command{vi}, you can then use the command @samp{:tag @var{entity}} ! (replacing @var{entity} by whatever you are looking for), and vi will display a new file with the corresponding declaration of entity. @end ifclear *************** call @command{gnatpp} through the @comma *** 15304,15310 **** The @command{gnatpp} command has the form @smallexample ! $ gnatpp [@var{switches}] @var{filename} @end smallexample @noindent --- 15667,15673 ---- The @command{gnatpp} command has the form @smallexample ! $ gnatpp @ovar{switches} @var{filename} @end smallexample @noindent *************** stops. *** 15571,15577 **** @cindex @option{^--no-separate-is^/NO_SEPARATE_IS^} (@command{gnatpp}) @item ^--no-separate-is^/NO_SEPARATE_IS^ Do not place the keyword @code{is} on a separate line in a subprogram body in ! case if the specification occupies more then one line. @cindex @option{^--separate-loop-then^/SEPARATE_LOOP_THEN^} (@command{gnatpp}) @item ^--separate-loop-then^/SEPARATE_LOOP_THEN^ --- 15934,15940 ---- @cindex @option{^--no-separate-is^/NO_SEPARATE_IS^} (@command{gnatpp}) @item ^--no-separate-is^/NO_SEPARATE_IS^ Do not place the keyword @code{is} on a separate line in a subprogram body in ! case if the spec occupies more then one line. @cindex @option{^--separate-loop-then^/SEPARATE_LOOP_THEN^} (@command{gnatpp}) @item ^--separate-loop-then^/SEPARATE_LOOP_THEN^ *************** The @option{GNAT}, @option{COMPACT}, and *** 15628,15645 **** These switches allow control over line length and indentation. @table @option ! @item ^-M@i{nnn}^/LINE_LENGTH_MAX=@i{nnn}^ @cindex @option{^-M^/LINE_LENGTH^} (@command{gnatpp}) ! Maximum line length, @i{nnn} from 32 ..256, the default value is 79 ! @item ^-i@i{nnn}^/INDENTATION_LEVEL=@i{nnn}^ @cindex @option{^-i^/INDENTATION_LEVEL^} (@command{gnatpp}) ! Indentation level, @i{nnn} from 1 .. 9, the default value is 3 ! @item ^-cl@i{nnn}^/CONTINUATION_INDENT=@i{nnn}^ @cindex @option{^-cl^/CONTINUATION_INDENT^} (@command{gnatpp}) Indentation level for continuation lines (relative to the line being ! continued), @i{nnn} from 1 .. 9. The default value is one less then the (normal) indentation level, unless the indentation is set to 1 (in which case the default value for continuation --- 15991,16008 ---- These switches allow control over line length and indentation. @table @option ! @item ^-M@var{nnn}^/LINE_LENGTH_MAX=@var{nnn}^ @cindex @option{^-M^/LINE_LENGTH^} (@command{gnatpp}) ! Maximum line length, @var{nnn} from 32@dots{}256, the default value is 79 ! @item ^-i@var{nnn}^/INDENTATION_LEVEL=@var{nnn}^ @cindex @option{^-i^/INDENTATION_LEVEL^} (@command{gnatpp}) ! Indentation level, @var{nnn} from 1@dots{}9, the default value is 3 ! @item ^-cl@var{nnn}^/CONTINUATION_INDENT=@var{nnn}^ @cindex @option{^-cl^/CONTINUATION_INDENT^} (@command{gnatpp}) Indentation level for continuation lines (relative to the line being ! continued), @var{nnn} from 1@dots{}9. The default value is one less then the (normal) indentation level, unless the indentation is set to 1 (in which case the default value for continuation *************** insertion, so that the formatted source *** 15670,15681 **** @cindex @option{^-ff^/FORM_FEED_AFTER_PRAGMA_PAGE^} (@command{gnatpp}) Insert a Form Feed character after a pragma Page. ! @item ^-T@i{nnn}^/MAX_INDENT=@i{nnn}^ @cindex @option{^-T^/MAX_INDENT^} (@command{gnatpp}) Do not use an additional indentation level for @b{case} alternatives ! and variants if there are @i{nnn} or more (the default value is 10). ! If @i{nnn} is 0, an additional indentation level is used for @b{case} alternatives and variants regardless of their number. @end table --- 16033,16044 ---- @cindex @option{^-ff^/FORM_FEED_AFTER_PRAGMA_PAGE^} (@command{gnatpp}) Insert a Form Feed character after a pragma Page. ! @item ^-T@var{nnn}^/MAX_INDENT=@var{nnn}^ @cindex @option{^-T^/MAX_INDENT^} (@command{gnatpp}) Do not use an additional indentation level for @b{case} alternatives ! and variants if there are @var{nnn} or more (the default value is 10). ! If @var{nnn} is 0, an additional indentation level is used for @b{case} alternatives and variants regardless of their number. @end table *************** reading or processing the input file. *** 15746,15753 **** Like @option{^-r^/REPLACE^} except that if the file with the specified name already exists, it is overwritten. ! @item ^-rnb^/NO_BACKUP^ ! @cindex @option{^-rnb^/NO_BACKUP^} (@code{gnatpp}) Replace the input source file with the reformatted output without creating any backup copy of the input source. --- 16109,16116 ---- Like @option{^-r^/REPLACE^} except that if the file with the specified name already exists, it is overwritten. ! @item ^-rnb^/REPLACE_NO_BACKUP^ ! @cindex @option{^-rnb^/REPLACE_NO_BACKUP^} (@code{gnatpp}) Replace the input source file with the reformatted output without creating any backup copy of the input source. *************** that has a special format (that is, a ch *** 16030,16036 **** not white space nor line break immediately following the leading @code{--} of the comment) should be without any change moved from the argument source into reformatted source. This switch allows to preserve comments that are used ! as a special marks in the code (e.g. SPARK annotation). @node Construct Layout @subsection Construct Layout --- 16393,16399 ---- not white space nor line break immediately following the leading @code{--} of the comment) should be without any change moved from the argument source into reformatted source. This switch allows to preserve comments that are used ! as a special marks in the code (e.g.@: SPARK annotation). @node Construct Layout @subsection Construct Layout *************** through the @command{gnat} driver. *** 16401,16428 **** The @command{gnatmetric} command has the form @smallexample ! $ gnatmetric [@i{switches}] @{@i{filename}@} [@i{-cargs gcc_switches}] @end smallexample @noindent where @itemize @bullet @item ! @i{switches} specify the metrics to compute and define the destination for the output @item ! Each @i{filename} is the name (including the extension) of a source file to process. ``Wildcards'' are allowed, and the file name may contain path information. ! If no @i{filename} is supplied, then the @i{switches} list must contain at least one @option{-files} switch (@pxref{Other gnatmetric Switches}). Including both a @option{-files} switch and one or more ! @i{filename} arguments is permitted. @item ! @i{-cargs gcc_switches} is a list of switches for @command{gcc}. They will be passed on to all compiler invocations made by @command{gnatmetric} to generate the ASIS trees. Here you can provide @option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, --- 16764,16791 ---- The @command{gnatmetric} command has the form @smallexample ! $ gnatmetric @ovar{switches} @{@var{filename}@} @r{[}-cargs @var{gcc_switches}@r{]} @end smallexample @noindent where @itemize @bullet @item ! @var{switches} specify the metrics to compute and define the destination for the output @item ! Each @var{filename} is the name (including the extension) of a source file to process. ``Wildcards'' are allowed, and the file name may contain path information. ! If no @var{filename} is supplied, then the @var{switches} list must contain at least one @option{-files} switch (@pxref{Other gnatmetric Switches}). Including both a @option{-files} switch and one or more ! @var{filename} arguments is permitted. @item ! @samp{-cargs @var{gcc_switches}} is a list of switches for @command{gcc}. They will be passed on to all compiler invocations made by @command{gnatmetric} to generate the ASIS trees. Here you can provide @option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, *************** kinds of locally declared program units: *** 16533,16539 **** subprogram (and generic subprogram) bodies; @item ! package (and generic package) specifications and bodies; @item task object and type specifications and bodies; --- 16896,16902 ---- subprogram (and generic subprogram) bodies; @item ! package (and generic package) specs and bodies; @item task object and type specifications and bodies; *************** explicitly specified metrics are reporte *** 16579,16584 **** --- 16942,16948 ---- * Line Metrics Control:: * Syntax Metrics Control:: * Complexity Metrics Control:: + * Object-Oriented Metrics Control:: @end menu @node Line Metrics Control *************** the following metrics: *** 16720,16726 **** @table @emph @item Public subprograms ! This metric is computed for package specifications. It is the number of subprograms and generic subprograms declared in the visible part (including the visible part of nested packages, protected objects, and protected types). --- 17084,17090 ---- @table @emph @item Public subprograms ! This metric is computed for package specs. It is the number of subprograms and generic subprograms declared in the visible part (including the visible part of nested packages, protected objects, and protected types). *************** level and enclosing constructs. Generic *** 16735,16741 **** subprograms are counted in the same way as ``usual'' subprogram bodies. @item Public types ! This metric is computed for package specifications and generic package declarations. It is the total number of types that can be referenced from outside this compilation unit, plus the number of types from all the visible parts of all the visible generic --- 17099,17105 ---- subprograms are counted in the same way as ``usual'' subprogram bodies. @item Public types ! This metric is computed for package specs and generic package declarations. It is the total number of types that can be referenced from outside this compilation unit, plus the number of types from all the visible parts of all the visible generic *************** following switches to select specific sy *** 16785,16791 **** @cindex @option{^--syntax@var{x}^/SYNTAX_METRICS^} (@command{gnatmetric}) @ifclear vms ! @cindex @option{--no-syntax@var{x}} @end ifclear @item ^--syntax-all^/SYNTAX_METRICS=ALL_ON^ --- 17149,17155 ---- @cindex @option{^--syntax@var{x}^/SYNTAX_METRICS^} (@command{gnatmetric}) @ifclear vms ! @cindex @option{--no-syntax@var{x}} (@command{gnatmetric}) @end ifclear @item ^--syntax-all^/SYNTAX_METRICS=ALL_ON^ *************** computing Essential Complexity *** 16943,16948 **** --- 17307,17413 ---- @end table + + @node Object-Oriented Metrics Control + @subsubsection Object-Oriented Metrics Control + @cindex Object-Oriented metrics control in @command{gnatmetric} + + @noindent + @cindex Coupling metrics (in in @command{gnatmetric}) + Coupling metrics are object-oriented metrics that measure the + dependencies between a given class (or a group of classes) and the + ``external world'' (that is, the other classes in the program). In this + subsection the term ``class'' is used in its + traditional object-oriented programming sense + (an instantiable module that contains data and/or method members). + A @emph{category} (of classes) + is a group of closely related classes that are reused and/or + modified together. + + A class @code{K}'s @emph{efferent coupling} is the number of classes + that @code{K} depends upon. + A category's efferent coupling is the number of classes outside the + category that the classes inside the category depend upon. + + A class @code{K}'s @emph{afferent coupling} is the number of classes + that depend upon @code{K}. + A category's afferent coupling is the number of classes outside the + category that depend on classes belonging to the category. + + Ada's implementation of the object-oriented paradigm does not use the + traditional class notion, so the definition of the coupling + metrics for Ada maps the class and class category notions + onto Ada constructs. + + For the coupling metrics, several kinds of modules -- a library package, + a library generic package, and a library generic package instantiation -- + that define a tagged type or an interface type are + considered to be a class. A category consists of a library package (or + a library generic package) that defines a tagged or an interface type, + together with all its descendant (generic) packages that define tagged + or interface types. For any package counted as a class, + its body (if any) is considered + together with its spec when counting the dependencies. For dependencies + between classes, the Ada semantic dependencies are considered. + For coupling metrics, only dependencies on units that are considered as + classes, are considered. + + When computing coupling metrics, @command{gnatmetric} counts only + dependencies between units that are arguments of the gnatmetric call. + Coupling metrics are program-wide (or project-wide) metrics, so to + get a valid result, you should call @command{gnatmetric} for + the whole set of sources that make up your program. It can be done + by calling @command{gnatmetric} from the GNAT driver with @option{-U} + option (see See @ref{The GNAT Driver and Project Files} for details. + + By default, all the coupling metrics are disabled. You can use the following + switches to specify the coupling metrics to be computed and reported: + + @table @option + + @ifclear vms + @cindex @option{--package@var{x}} (@command{gnatmetric}) + @cindex @option{--no-package@var{x}} (@command{gnatmetric}) + @cindex @option{--category@var{x}} (@command{gnatmetric}) + @cindex @option{--no-category@var{x}} (@command{gnatmetric}) + @end ifclear + + @ifset vms + @cindex @option{/COUPLING_METRICS} (@command{gnatmetric}) + @end ifset + + @item ^--coupling-all^/COUPLING_METRICS=ALL_ON^ + Report all the coupling metrics + + @item ^--no-coupling-all^/COUPLING_METRICS=ALL_OFF^ + Do not report any of metrics + + @item ^--package-efferent-coupling^/COUPLING_METRICS=PACKAGE_EFFERENT_ON^ + Report package efferent coupling + + @item ^--no-package-efferent-coupling^/COUPLING_METRICS=PACKAGE_EFFERENT_OFF^ + Do not report package efferent coupling + + @item ^--package-afferent-coupling^/COUPLING_METRICS=PACKAGE_AFFERENT_ON^ + Report package afferent coupling + + @item ^--no-package-afferent-coupling^/COUPLING_METRICS=PACKAGE_AFFERENT_OFF^ + Do not report package afferent coupling + + @item ^--category-efferent-coupling^/COUPLING_METRICS=CATEGORY_EFFERENT_ON^ + Report category efferent coupling + + @item ^--no-category-efferent-coupling^/COUPLING_METRICS=CATEGORY_EFFERENT_OFF^ + Do not report category efferent coupling + + @item ^--category-afferent-coupling^/COUPLING_METRICS=CATEGORY_AFFERENT_ON^ + Report category afferent coupling + + @item ^--no-category-afferent-coupling^/COUPLING_METRICS=CATEGORY_AFFERENT_OFF^ + Do not report category afferent coupling + + @end table + @node Other gnatmetric Switches @subsection Other @code{gnatmetric} Switches *************** Take the unit name and replace all dots *** 17032,17044 **** @item If such a replacement occurs in the second character position of a name, and the first character is ! ^a, g, s, or i^A, G, S, or I^ then replace the dot by the character ! ^~ (tilde)^$ (dollar sign)^ instead of a minus. @end itemize The reason for this exception is to avoid clashes with the standard names for children of System, Ada, Interfaces, ! and GNAT, which use the prefixes ^s- a- i- and g-^S- A- I- and G-^ respectively. The @option{^-gnatk^/FILE_NAME_MAX_LENGTH=^@var{nn}} --- 17497,17511 ---- @item If such a replacement occurs in the second character position of a name, and the first character is ! ^@samp{a}, @samp{g}, @samp{s}, or @samp{i}, ^@samp{A}, @samp{G}, @samp{S}, or @samp{I},^ ! then replace the dot by the character ! ^@samp{~} (tilde)^@samp{$} (dollar sign)^ instead of a minus. @end itemize The reason for this exception is to avoid clashes with the standard names for children of System, Ada, Interfaces, ! and GNAT, which use the prefixes ! ^@samp{s-}, @samp{a-}, @samp{i-}, and @samp{g-},^@samp{S-}, @samp{A-}, @samp{I-}, and @samp{G-},^ respectively. The @option{^-gnatk^/FILE_NAME_MAX_LENGTH=^@var{nn}} *************** The @code{gnatkr} command has the form *** 17062,17068 **** @ifclear vms @smallexample ! $ gnatkr @var{name} [@var{length}] @end smallexample @end ifclear --- 17529,17535 ---- @ifclear vms @smallexample ! $ gnatkr @var{name} @ovar{length} @end smallexample @end ifclear *************** $ gnatkr @var{name} /COUNT=nn *** 17074,17080 **** @noindent @var{name} is the uncrunched file name, derived from the name of the unit ! in the standard manner described in the previous section (i.e. in particular all dots are replaced by hyphens). The file name may or may not have an extension (defined as a suffix of the form period followed by arbitrary characters other than period). If an extension is present then it will --- 17541,17547 ---- @noindent @var{name} is the uncrunched file name, derived from the name of the unit ! in the standard manner described in the previous section (i.e., in particular all dots are replaced by hyphens). The file name may or may not have an extension (defined as a suffix of the form period followed by arbitrary characters other than period). If an extension is present then it will *************** unit and replacing the separating dots w *** 17110,17118 **** using ^lowercase^uppercase^ for all letters, except that a hyphen in the second character position is replaced by a ^tilde^dollar sign^ if the first character is ! ^a, i, g, or s^A, I, G, or S^. The extension is @code{.ads} for a ! specification and @code{.adb} for a body. Krunching does not affect the extension, but the file name is shortened to the specified length by following these rules: --- 17577,17585 ---- using ^lowercase^uppercase^ for all letters, except that a hyphen in the second character position is replaced by a ^tilde^dollar sign^ if the first character is ! ^@samp{a}, @samp{i}, @samp{g}, or @samp{s}^@samp{A}, @samp{I}, @samp{G}, or @samp{S}^. The extension is @code{.ads} for a ! spec and @code{.adb} for a body. Krunching does not affect the extension, but the file name is shortened to the specified length by following these rules: *************** For further discussion of conditional co *** 17227,17238 **** --- 17694,17714 ---- @ref{Conditional Compilation}. @menu + * Preprocessing Symbols:: * Using gnatprep:: * Switches for gnatprep:: * Form of Definitions File:: * Form of Input Text for gnatprep:: @end menu + @node Preprocessing Symbols + @section Preprocessing Symbols + + @noindent + Preprocessing symbols are defined in definition files and referred to in + sources to be preprocessed. A Preprocessing symbol is an identifier, following + normal Ada (case-insensitive) rules for its syntax, with the restriction that + all characters need to be in the ASCII set (no accented letters). @node Using gnatprep @section Using @code{gnatprep} *************** For further discussion of conditional co *** 17241,17252 **** To call @code{gnatprep} use @smallexample ! $ gnatprep [switches] infile outfile [deffile] @end smallexample @noindent where ! @table @code @item switches is an optional sequence of switches as described in the next section. --- 17717,17728 ---- To call @code{gnatprep} use @smallexample ! $ gnatprep @ovar{switches} @var{infile} @var{outfile} @ovar{deffile} @end smallexample @noindent where ! @table @var @item switches is an optional sequence of switches as described in the next section. *************** normally have an ads or adb suffix. *** 17261,17267 **** @item deffile is the full name of a text file containing definitions of ! symbols to be referenced by the preprocessor. This argument is optional, and can be replaced by the use of the @option{-D} switch. @end table --- 17737,17743 ---- @item deffile is the full name of a text file containing definitions of ! preprocessing symbols to be referenced by the preprocessor. This argument is optional, and can be replaced by the use of the @option{-D} switch. @end table *************** being preserved in the output file. *** 17290,17304 **** Causes comments to be scanned. Normally comments are ignored by gnatprep. If this option is specified, then comments are scanned and any $symbol substitutions performed as in program text. This is particularly useful ! when structured comments are used (e.g. when writing programs in the SPARK dialect of Ada). Note that this switch is not available when doing integrated preprocessing (it would be useless in this context since comments are ignored by the compiler in any case). @item ^-Dsymbol=value^/ASSOCIATE="symbol=value"^ @cindex @option{^-D^/ASSOCIATE^} (@command{gnatprep}) ! Defines a new symbol, associated with value. If no value is given on the ! command line, then symbol is considered to be @code{True}. This switch can be used in place of a definition file. @ifset vms --- 17766,17780 ---- Causes comments to be scanned. Normally comments are ignored by gnatprep. If this option is specified, then comments are scanned and any $symbol substitutions performed as in program text. This is particularly useful ! when structured comments are used (e.g., when writing programs in the SPARK dialect of Ada). Note that this switch is not available when doing integrated preprocessing (it would be useless in this context since comments are ignored by the compiler in any case). @item ^-Dsymbol=value^/ASSOCIATE="symbol=value"^ @cindex @option{^-D^/ASSOCIATE^} (@command{gnatprep}) ! Defines a new preprocessing symbol, associated with value. If no value is given ! on the command line, then symbol is considered to be @code{True}. This switch can be used in place of a definition file. @ifset vms *************** symbol := value *** 17358,17365 **** @end smallexample @noindent ! where symbol is an identifier, following normal Ada (case-insensitive) ! rules for its syntax, and value is one of the following: @itemize @bullet @item --- 17834,17840 ---- @end smallexample @noindent ! where symbol is a preprocessing symbol, and value is one of the following: @itemize @bullet @item *************** The preprocessor conditional inclusion c *** 17388,17400 **** @smallexample @group @cartouche ! #if @i{expression} [then] lines ! #elsif @i{expression} [then] lines ! #elsif @i{expression} [then] lines ! ... #else lines #end if; --- 17863,17875 ---- @smallexample @group @cartouche ! #if @i{expression} @r{[}then@r{]} lines ! #elsif @i{expression} @r{[}then@r{]} lines ! #elsif @i{expression} @r{[}then@r{]} lines ! @dots{} #else lines #end if; *************** In this example, @i{expression} is defin *** 17417,17422 **** --- 17892,17912 ---- @i{expression} ::= ( @i{expression} ) @end smallexample + The following restriction exists: it is not allowed to have "and" or "or" + following "not" in the same expression without parentheses. For example, this + is not allowed: + + @smallexample + not X or Y + @end smallexample + + This should be one of the following: + + @smallexample + (not X) or Y + not (X or Y) + @end smallexample + @noindent For the first test (@i{expression} ::= ) the symbol must have either the value true or false, that is to say the right-hand of the *************** preprocessor line. Any number of @code{e *** 17455,17461 **** including none at all. The @code{else} is optional, as in Ada. The @code{#} marking the start of a preprocessor line must be the first ! non-blank character on the line, i.e. it must be preceded only by spaces or horizontal tabs. Symbol substitution outside of preprocessor lines is obtained by using --- 17945,17951 ---- including none at all. The @code{else} is optional, as in Ada. The @code{#} marking the start of a preprocessor line must be the first ! non-blank character on the line, i.e., it must be preceded only by spaces or horizontal tabs. Symbol substitution outside of preprocessor lines is obtained by using *************** supplied configuration pragmas. *** 17513,17519 **** The @code{gnatlbr} command has the form @smallexample ! $ GNAT LIBRARY /[CREATE | SET | DELETE]=directory [/CONFIG=file] @end smallexample @node Switches for gnatlbr --- 18003,18009 ---- The @code{gnatlbr} command has the form @smallexample ! $ GNAT LIBRARY /@r{[}CREATE@r{|}SET@r{|}DELETE@r{]}=directory @r{[}/CONFIG=file@r{]} @end smallexample @node Switches for gnatlbr *************** $ GNAT LIBRARY /[CREATE | SET | DELETE]= *** 17526,17550 **** @c !sort! @item /CREATE=directory @cindex @code{/CREATE} (@code{gnatlbr}) ! Create the new run-time library in the specified directory. @item /SET=directory @cindex @code{/SET} (@code{gnatlbr}) ! Make the library in the specified directory the current run-time ! library. @item /DELETE=directory @cindex @code{/DELETE} (@code{gnatlbr}) ! Delete the run-time library in the specified directory. @item /CONFIG=file @cindex @code{/CONFIG} (@code{gnatlbr}) ! With /CREATE: ! Use the configuration pragmas in the specified file when building ! the library. ! With /SET: ! Use the configuration pragmas in the specified file when compiling. @end table --- 18016,18038 ---- @c !sort! @item /CREATE=directory @cindex @code{/CREATE} (@code{gnatlbr}) ! Create the new run-time library in the specified directory. @item /SET=directory @cindex @code{/SET} (@code{gnatlbr}) ! Make the library in the specified directory the current run-time library. @item /DELETE=directory @cindex @code{/DELETE} (@code{gnatlbr}) ! Delete the run-time library in the specified directory. @item /CONFIG=file @cindex @code{/CONFIG} (@code{gnatlbr}) ! With /CREATE: Use the configuration pragmas in the specified file when ! building the library. ! With /SET: Use the configuration pragmas in the specified file when ! compiling. @end table *************** Only output information about compilatio *** 17696,17702 **** @cindex @option{^-files^/FILES^} (@code{gnatls}) Take as arguments the files listed in text file @var{file}. Text file @var{file} may contain empty lines that are ignored. ! Each non empty line should contain the name of an existing file. Several such switches may be specified simultaneously. @item ^-aO^/OBJECT_SEARCH=^@var{dir} --- 18184,18190 ---- @cindex @option{^-files^/FILES^} (@code{gnatls}) Take as arguments the files listed in text file @var{file}. Text file @var{file} may contain empty lines that are ignored. ! Each nonempty line should contain the name of an existing file. Several such switches may be specified simultaneously. @item ^-aO^/OBJECT_SEARCH=^@var{dir} *************** $ chmod -w *.ali *** 18178,18186 **** @end smallexample @noindent ! Please note that the library must have a name of the form @file{libxxx.a} or ! @file{libxxx.so} (or @file{libxxx.dll} on Windows) in order to be accessed by ! the directive @option{-lxxx} at link time. @node Installing a library @subsection Installing a library --- 18666,18674 ---- @end smallexample @noindent ! Please note that the library must have a name of the form @file{lib@var{xxx}.a} ! or @file{lib@var{xxx}.so} (or @file{lib@var{xxx}.dll} on Windows) in order to ! be accessed by the directive @option{-l@var{xxx}} at link time. @node Installing a library @subsection Installing a library *************** responsibility of the library provider t *** 18224,18230 **** files and libraries in the directories mentioned in the project file. For convenience, the user's library project file should be installed in a location that will be searched automatically by the GNAT ! builder. These are the directories referenced in the @code{ADA_PROJECT_PATH} environment variable (@pxref{Importing Projects}), and also the default GNAT library location that can be queried with @command{gnatls -v} and is usually of the form $gnat_install_root/lib/gnat. --- 18712,18718 ---- files and libraries in the directories mentioned in the project file. For convenience, the user's library project file should be installed in a location that will be searched automatically by the GNAT ! builder. These are the directories referenced in the @env{ADA_PROJECT_PATH} environment variable (@pxref{Importing Projects}), and also the default GNAT library location that can be queried with @command{gnatls -v} and is usually of the form $gnat_install_root/lib/gnat. *************** write: *** 18285,18291 **** @smallexample @c projectfile with "my_lib"; project My_Proj is ! ... end My_Proj; @end smallexample --- 18773,18779 ---- @smallexample @c projectfile with "my_lib"; project My_Proj is ! @dots{} end My_Proj; @end smallexample *************** when the following conditions are met: *** 18336,18346 **** @itemize @bullet @item @file{/dir/my_lib_src} has been added by the user to the environment ! variable @code{ADA_INCLUDE_PATH}, or by the administrator to the file @file{ada_source_path} @item @file{/dir/my_lib_obj} has been added by the user to the environment ! variable @code{ADA_OBJECTS_PATH}, or by the administrator to the file @file{ada_object_path} @item a pragma @code{Linker_Options} has been added to one of the sources. --- 18824,18834 ---- @itemize @bullet @item @file{/dir/my_lib_src} has been added by the user to the environment ! variable @env{ADA_INCLUDE_PATH}, or by the administrator to the file @file{ada_source_path} @item @file{/dir/my_lib_obj} has been added by the user to the environment ! variable @env{ADA_OBJECTS_PATH}, or by the administrator to the file @file{ada_object_path} @item a pragma @code{Linker_Options} has been added to one of the sources. *************** the object directory. *** 18486,18492 **** @item Copy the @code{ALI} files of the interface to the library directory, add in this copy an indication that it is an interface to a SAL ! (i.e. add a word @option{SL} on the line in the @file{ALI} file that starts with letter ``P'') and make the modified copy of the @file{ALI} file read-only. @end itemize --- 18974,18980 ---- @item Copy the @code{ALI} files of the interface to the library directory, add in this copy an indication that it is an interface to a SAL ! (i.e., add a word @option{SL} on the line in the @file{ALI} file that starts with letter ``P'') and make the modified copy of the @file{ALI} file read-only. @end itemize *************** to use it. *** 18640,18651 **** @noindent This chapter offers some examples of makefiles that solve specific ! problems. It does not explain how to write a makefile (see the GNU make ! documentation), nor does it try to replace the @command{gnatmake} utility ! (@pxref{The GNAT Make Program gnatmake}). All the examples in this section are specific to the GNU version of ! make. Although @code{make} is a standard utility, and the basic language is the same, these examples use some advanced features found only in @code{GNU make}. --- 19128,19139 ---- @noindent This chapter offers some examples of makefiles that solve specific ! problems. It does not explain how to write a makefile (@pxref{Top,, GNU ! make, make, GNU @code{make}}), nor does it try to replace the ! @command{gnatmake} utility (@pxref{The GNAT Make Program gnatmake}). All the examples in this section are specific to the GNU version of ! make. Although @command{make} is a standard utility, and the basic language is the same, these examples use some advanced features found only in @code{GNU make}. *************** which might help you in case your projec *** 18695,18701 **** ## csc is put in the top level directory (where the Makefile is). ## toplevel_dir __ first_csc (sources) __ lib (will contain the library) ## \_ second_csc (sources) __ lib (will contain the library) ! ## \_ ... ## Although this Makefile is build for shared library, it is easy to modify ## to build partial link objects instead (modify the lines with -shared and ## gnatlink below) --- 19183,19189 ---- ## csc is put in the top level directory (where the Makefile is). ## toplevel_dir __ first_csc (sources) __ lib (will contain the library) ## \_ second_csc (sources) __ lib (will contain the library) ! ## \_ @dots{} ## Although this Makefile is build for shared library, it is easy to modify ## to build partial link objects instead (modify the lines with -shared and ## gnatlink below) *************** MAIN=main *** 18717,18723 **** # The following variable should give the directory containing libgnat.so # You can get this directory through 'gnatls -v'. This is usually the last # directory in the Object_Path. ! GLIB=... # The directories for the libraries # (This macro expands the list of CSC to the list of shared libraries, you --- 19205,19211 ---- # The following variable should give the directory containing libgnat.so # You can get this directory through 'gnatls -v'. This is usually the last # directory in the Object_Path. ! GLIB=@dots{} # The directories for the libraries # (This macro expands the list of CSC to the list of shared libraries, you *************** objects:: *** 18737,18744 **** # by a new tool, gnatmlib $@{LIB_DIR@}: mkdir -p $@{dir $@@ @} ! cd $@{dir $@@ @}; gcc -shared -o $@{notdir $@@ @} ../*.o -L$@{GLIB@} -lgnat ! cd $@{dir $@@ @}; cp -f ../*.ali . # The dependencies for the modules # Note that we have to force the expansion of *.o, since in some cases --- 19225,19232 ---- # by a new tool, gnatmlib $@{LIB_DIR@}: mkdir -p $@{dir $@@ @} ! cd $@{dir $@@ @} && gcc -shared -o $@{notdir $@@ @} ../*.o -L$@{GLIB@} -lgnat ! cd $@{dir $@@ @} && cp -f ../*.ali . # The dependencies for the modules # Note that we have to force the expansion of *.o, since in some cases *************** In most makefiles, you will have to spec *** 18767,18773 **** store it in a variable. For small projects, it is often easier to specify each of them by hand, since you then have full control over what is the proper order for these directories, which ones should be ! included... However, in larger projects, which might involve hundreds of subdirectories, it might be more convenient to generate this list --- 19255,19261 ---- store it in a variable. For small projects, it is often easier to specify each of them by hand, since you then have full control over what is the proper order for these directories, which ones should be ! included. However, in larger projects, which might involve hundreds of subdirectories, it might be more convenient to generate this list *************** automatically. *** 18775,18787 **** The example below presents two methods. The first one, although less general, gives you more control over the list. It involves wildcard ! characters, that are automatically expanded by @code{make}. Its shortcoming is that you need to explicitly specify some of the organization of your project, such as for instance the directory tree ! depth, whether some directories are found in a separate tree,... The second method is the most general one. It requires an external ! program, called @code{find}, which is standard on all Unix systems. All the directories found under a given root directory will be added to the list. --- 19263,19275 ---- The example below presents two methods. The first one, although less general, gives you more control over the list. It involves wildcard ! characters, that are automatically expanded by @command{make}. Its shortcoming is that you need to explicitly specify some of the organization of your project, such as for instance the directory tree ! depth, whether some directories are found in a separate tree, @enddots{} The second method is the most general one. It requires an external ! program, called @command{find}, which is standard on all Unix systems. All the directories found under a given root directory will be added to the list. *************** It provides three type of information: *** 19169,19175 **** @item General information concerning memory management, such as the total number of allocations and deallocations, the amount of allocated ! memory and the high water mark, i.e. the largest amount of allocated memory in the course of program execution. @item --- 19657,19663 ---- @item General information concerning memory management, such as the total number of allocations and deallocations, the amount of allocated ! memory and the high water mark, i.e.@: the largest amount of allocated memory in the course of program execution. @item *************** Solaris and Windows NT/2000/XP (x86). *** 19202,19208 **** The @code{gnatmem} command has the form @smallexample ! $ gnatmem [switches] user_program @end smallexample @noindent --- 19690,19696 ---- The @code{gnatmem} command has the form @smallexample ! $ gnatmem @ovar{switches} user_program @end smallexample @noindent *************** version of that library that has been co *** 19235,19241 **** Gnatmem must be supplied with the @file{gmem.out} file and the executable to examine. If the location of @file{gmem.out} file was not explicitly supplied by ! @code{-i} switch, gnatmem will assume that this file can be found in the current directory. For example, after you have executed @file{my_program}, @file{gmem.out} can be analyzed by @code{gnatmem} using the command: --- 19723,19729 ---- Gnatmem must be supplied with the @file{gmem.out} file and the executable to examine. If the location of @file{gmem.out} file was not explicitly supplied by ! @option{-i} switch, gnatmem will assume that this file can be found in the current directory. For example, after you have executed @file{my_program}, @file{gmem.out} can be analyzed by @code{gnatmem} using the command: *************** Allocation Root # 3 *** 19436,19442 **** Note that the GNAT run time contains itself a certain number of allocations that have no corresponding deallocation, as shown here for root #2 and root ! #3. This is a normal behavior when the number of non freed allocations is one, it allocates dynamic data structures that the run time needs for the complete lifetime of the program. Note also that there is only one allocation root in the user program with a single line back trace: --- 19924,19930 ---- Note that the GNAT run time contains itself a certain number of allocations that have no corresponding deallocation, as shown here for root #2 and root ! #3. This is a normal behavior when the number of non-freed allocations is one, it allocates dynamic data structures that the run time needs for the complete lifetime of the program. Note also that there is only one allocation root in the user program with a single line back trace: *************** size stack is allocated, but this cannot *** 19564,19570 **** @ifclear vms To ensure that a clean exception is signalled for stack overflow, set the environment variable ! @code{GNAT_STACK_LIMIT} to indicate the maximum stack area that can be used, as in: @cindex GNAT_STACK_LIMIT --- 20052,20058 ---- @ifclear vms To ensure that a clean exception is signalled for stack overflow, set the environment variable ! @env{GNAT_STACK_LIMIT} to indicate the maximum stack area that can be used, as in: @cindex GNAT_STACK_LIMIT *************** With this option, at each task terminati *** 19657,19663 **** It is not always convenient to output the stack usage when the program is still running. Hence, it is possible to delay this output until program termination. for a given number of tasks specified as the argument of the ! @code{-u} option. For instance: @smallexample $ gnatbind -u100 file --- 20145,20151 ---- It is not always convenient to output the stack usage when the program is still running. Hence, it is possible to delay this output until program termination. for a given number of tasks specified as the argument of the ! @option{-u} option. For instance: @smallexample $ gnatbind -u100 file *************** and max values. *** 19693,19699 **** @end table @noindent ! The environment task stack, e.g. the stack that contains the main unit, is only processed when the environment variable GNAT_STACK_LIMIT is set. --- 20181,20187 ---- @end table @noindent ! The environment task stack, e.g., the stack that contains the main unit, is only processed when the environment variable GNAT_STACK_LIMIT is set. *************** driver (see @ref{The GNAT Driver and Pro *** 19730,19770 **** Invoking @command{gnatcheck} on the command line has the form: @smallexample ! $ gnatcheck [@i{switches}] @{@i{filename}@} ! [^-files^/FILES^=@{@i{arg_list_filename}@}] ! [-cargs @i{gcc_switches}] [-rules @i{rule_options}] @end smallexample @noindent where @itemize @bullet @item ! @i{switches} specify the general tool options @item ! Each @i{filename} is the name (including the extension) of a source file to process. ``Wildcards'' are allowed, and the file name may contain path information. @item ! Each @i{arg_list_filename} is the name (including the extension) of a text file containing the names of the source files to process, separated by spaces or line breaks. @item ! @i{gcc_switches} is a list of switches for @command{gcc}. They will be passed on to all compiler invocations made by @command{gnatcheck} to generate the ASIS trees. Here you can provide @option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, and use the @option{-gnatec} switch to set the configuration file. @item ! @i{rule_options} is a list of options for controlling a set of rules to be checked by @command{gnatcheck} (@pxref{gnatcheck Rule Options}). @end itemize @noindent ! Either a @i{filename} or an @i{arg_list_filename} must be supplied. @menu * Format of the Report File:: --- 20218,20258 ---- Invoking @command{gnatcheck} on the command line has the form: @smallexample ! $ gnatcheck @ovar{switches} @{@var{filename}@} ! @r{[}^-files^/FILES^=@{@var{arg_list_filename}@}@r{]} ! @r{[}-cargs @var{gcc_switches}@r{]} @r{[}-rules @var{rule_options}@r{]} @end smallexample @noindent where @itemize @bullet @item ! @var{switches} specify the general tool options @item ! Each @var{filename} is the name (including the extension) of a source file to process. ``Wildcards'' are allowed, and the file name may contain path information. @item ! Each @var{arg_list_filename} is the name (including the extension) of a text file containing the names of the source files to process, separated by spaces or line breaks. @item ! @var{gcc_switches} is a list of switches for @command{gcc}. They will be passed on to all compiler invocations made by @command{gnatcheck} to generate the ASIS trees. Here you can provide @option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, and use the @option{-gnatec} switch to set the configuration file. @item ! @var{rule_options} is a list of options for controlling a set of rules to be checked by @command{gnatcheck} (@pxref{gnatcheck Rule Options}). @end itemize @noindent ! Either a @file{@var{filename}} or an @file{@var{arg_list_filename}} must be supplied. @menu * Format of the Report File:: *************** a generic instantiation a full source lo *** 19833,19838 **** --- 20321,20332 ---- of this construct in the generic unit to the place where this unit is instantiated. + @cindex @option{^-m^/DIAGNOSIS_LIMIT^} (@command{gnatcheck}) + @item ^-m@i{nnn}^/DIAGNOSIS_LIMIT=@i{nnn}^ + Maximum number of diagnoses to be sent to Stdout, @i{nnn} from o@dots{}1000, + the default value is 500. Zero means that there is no limitation on + the number of diagnostic messages to be printed into Stdout. + @cindex @option{^-q^/QUIET^} (@command{gnatcheck}) @item ^-q^/QUIET^ Quiet mode. All the diagnoses about rule violations are placed in the *************** Turn all the rule checks ON. *** 19887,19919 **** Turn all the rule checks OFF. @cindex @option{+R} (@command{gnatcheck}) ! @item +R@i{rule_id[:param]} Turn on the check for a specified rule with the specified parameter, if any. ! @i{rule_id} must be the identifier of one of the currently implemented rules (use @option{^-h^/HELP^} for the list of implemented rules). Rule identifiers ! are not case-sensitive. The @i{param} item must be a string representing a valid parameter(s) for the specified rule. If it contains any space characters then this string must be enclosed in quotation marks. @cindex @option{-R} (@command{gnatcheck}) ! @item -R@i{rule_id[:param]} Turn off the check for a specified rule with the specified parameter, if any. @cindex @option{-from} (@command{gnatcheck}) ! @item -from=@i{rule_option_filename} ! Read the rule options from the text file @i{rule_option_filename}, referred as ``rule file'' below. @end table @noindent ! The default behavior is that all the rule checks are enabled, except for ! the checks performed by the compiler. ! @ignore ! and the checks associated with the ! global rules. ! @end ignore A rule file is a text file containing a set of rule options. @cindex Rule file (for @code{gnatcheck}) --- 20381,20408 ---- Turn all the rule checks OFF. @cindex @option{+R} (@command{gnatcheck}) ! @item +R@var{rule_id}@r{[}:@var{param}@r{]} Turn on the check for a specified rule with the specified parameter, if any. ! @var{rule_id} must be the identifier of one of the currently implemented rules (use @option{^-h^/HELP^} for the list of implemented rules). Rule identifiers ! are not case-sensitive. The @var{param} item must be a string representing a valid parameter(s) for the specified rule. If it contains any space characters then this string must be enclosed in quotation marks. @cindex @option{-R} (@command{gnatcheck}) ! @item -R@var{rule_id}@r{[}:@var{param}@r{]} Turn off the check for a specified rule with the specified parameter, if any. @cindex @option{-from} (@command{gnatcheck}) ! @item -from=@var{rule_option_filename} ! Read the rule options from the text file @var{rule_option_filename}, referred as ``rule file'' below. @end table @noindent ! The default behavior is that all the rule checks are disabled. A rule file is a text file containing a set of rule options. @cindex Rule file (for @code{gnatcheck}) *************** The file may contain empty lines and Ada *** 19921,19933 **** lines and end-of-line comments). The rule file has free format; that is, you do not have to start a new rule option on a new line. ! A rule file may contain other @option{-from=@i{rule_option_filename}} options, each such option being replaced with the content of the corresponding rule file during the rule files processing. In case a ! cycle is detected (that is, @i{rule_file_1} reads rule options from ! @i{rule_file_2}, and @i{rule_file_2} reads (directly or indirectly) ! rule options from @i{rule_file_1}), the processing ! of rule files is interrupted and a part of their content is ignored. @node Adding the Results of Compiler Checks to gnatcheck Output --- 20410,20423 ---- lines and end-of-line comments). The rule file has free format; that is, you do not have to start a new rule option on a new line. ! A rule file may contain other @option{-from=@var{rule_option_filename}} options, each such option being replaced with the content of the corresponding rule file during the rule files processing. In case a ! cycle is detected (that is, @file{@var{rule_file_1}} reads rule options ! from @file{@var{rule_file_2}}, and @file{@var{rule_file_2}} reads ! (directly or indirectly) rule options from @file{@var{rule_file_1}}), ! the processing of rule files is interrupted and a part of their content ! is ignored. @node Adding the Results of Compiler Checks to gnatcheck Output *************** use the rule named *** 19949,19970 **** @code{Restrictions} or @code{Restriction_Warnings}. @item Style_Checks ! To record compiler style checks, use the rule named @code{Style_Checks}. A parameter of this rule can be either @code{All_Checks}, ! which enables all the style checks, or a string that has exactly the same structure and semantics as the @code{string_LITERAL} parameter of GNAT pragma ! @code{Style_Checks} (for further information about this pragma, please ! refer to the @cite{@value{EDITION} Reference Manual}). @item Warnings To record compiler warnings (@pxref{Warning Message Control}), use the rule named @code{Warnings} with a parameter that is a valid @i{static_string_expression} argument of GNAT pragma @code{Warnings} ! (for further information about this pragma, please ! refer to the @cite{@value{EDITION} Reference Manual}). @end table @node Project-Wide Checks @section Project-Wide Checks @cindex Project-wide checks (for @command{gnatcheck}) --- 20439,20470 ---- @code{Restrictions} or @code{Restriction_Warnings}. @item Style_Checks ! To record compiler style checks(@pxref{Style Checking}), use the rule named @code{Style_Checks}. A parameter of this rule can be either @code{All_Checks}, ! which enables all the standard style checks that corresponds to @option{-gnatyy} ! GNAT style check option, or a string that has exactly the same structure and semantics as the @code{string_LITERAL} parameter of GNAT pragma ! @code{Style_Checks} (for further information about this pragma, ! @pxref{Pragma Style_Checks,,, gnat_rm, GNAT Reference Manual}). @item Warnings To record compiler warnings (@pxref{Warning Message Control}), use the rule named @code{Warnings} with a parameter that is a valid @i{static_string_expression} argument of GNAT pragma @code{Warnings} ! (for further information about this pragma, @pxref{Pragma Warnings,,, ! gnat_rm, GNAT Reference Manual}). Note, that in case of gnatcheck ! 's' parameter, that corresponds to the GNAT @option{-gnatws} option, disables ! all the specific warnings, but not suppresses the warning mode, ! and 'e' parameter, corresponding to @option{-gnatwe} that means ! "treat warnings as errors", does not have any effect. @end table + To disable a specific restriction check, use @code{-RStyle_Checks} gnatcheck + option with the corresponding restriction name as a parameter. @code{-R} is + not available for @code{Style_Checks} and @code{Warnings} options, to disable + warnings and style checks, use the corresponding warning and style options. + @node Project-Wide Checks @section Project-Wide Checks @cindex Project-wide checks (for @command{gnatcheck}) *************** used as a parameter of the @option{+R} o *** 20062,20067 **** --- 20562,20568 ---- @ignore * Improperly_Called_Protected_Entries:: @end ignore + * Metrics:: * Misnamed_Identifiers:: * Multiple_Entries_In_Protected_Definitions:: * Name_Clashes:: *************** used as a parameter of the @option{+R} o *** 20086,20091 **** --- 20587,20593 ---- * Predefined_Numeric_Types:: * Raising_External_Exceptions:: * Raising_Predefined_Exceptions:: + * Separate_Numeric_Error_Handlers:: @ignore * Recursion:: * Side_Effect_Functions:: *************** flagged (since @code{1..N} is formally a *** 20141,20147 **** @smallexample @c ada for I in 1 .. N loop ! ... end loop; @end smallexample --- 20643,20649 ---- @smallexample @c ada for I in 1 .. N loop ! @dots{} end loop; @end smallexample *************** Declaring an explicit subtype solves the *** 20150,20158 **** @smallexample @c ada subtype S is Integer range 1..N; ! ... for I in S loop ! ... end loop; @end smallexample --- 20652,20660 ---- @smallexample @c ada subtype S is Integer range 1..N; ! @dots{} for I in S loop ! @dots{} end loop; @end smallexample *************** checked and sets the checks for all the *** 20371,20378 **** ON. @emph{Pragma_Name} is treated as a name of a pragma. If it does not correspond to any pragma name defined in the Ada standard or to the name of a GNAT-specific pragma defined ! in the GNAT Reference Manual, it is treated as the name of ! unknown pragma. @item @code{GNAT} All the GNAT-specific pragmas are detected; this sets --- 20873,20880 ---- ON. @emph{Pragma_Name} is treated as a name of a pragma. If it does not correspond to any pragma name defined in the Ada standard or to the name of a GNAT-specific pragma defined ! in @ref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference ! Manual}, it is treated as the name of unknown pragma. @item @code{GNAT} All the GNAT-specific pragmas are detected; this sets *************** Removes the specified pragma from the se *** 20389,20398 **** checked without affecting checks for other pragmas. @emph{Pragma_Name} is treated as a name of a pragma. If it does not correspond to any pragma ! defined in the Ada standard or to any name defined in the ! GNAT Reference Manual, ! this option is treated as turning OFF detection of all ! unknown pragmas. @item GNAT Turn OFF detection of all GNAT-specific pragmas --- 20891,20899 ---- checked without affecting checks for other pragmas. @emph{Pragma_Name} is treated as a name of a pragma. If it does not correspond to any pragma ! defined in the Ada standard or to any name defined in ! @ref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference Manual}, ! this option is treated as turning OFF detection of all unknown pragmas. @item GNAT Turn OFF detection of all GNAT-specific pragmas *************** This rule has no parameters. *** 20503,20509 **** @cindex @code{Improperly_Located_Instantiations} rule (for @command{gnatcheck}) @noindent ! Flag all generic instantiations in library-level package specifications (including library generic packages) and in all subprogram bodies. Instantiations in task and entry bodies are not flagged. Instantiations in the --- 21004,21010 ---- @cindex @code{Improperly_Located_Instantiations} rule (for @command{gnatcheck}) @noindent ! Flag all generic instantiations in library-level package specs (including library generic packages) and in all subprogram bodies. Instantiations in task and entry bodies are not flagged. Instantiations in the *************** This rule has no parameters. *** 20546,20552 **** @noindent Flag all local packages declared in package and generic package ! specifications. Local packages in bodies are not flagged. This rule has no parameters. --- 21047,21053 ---- @noindent Flag all local packages declared in package and generic package ! specs. Local packages in bodies are not flagged. This rule has no parameters. *************** Flag each protected entry that can be ca *** 20562,20567 **** --- 21063,21118 ---- This rule has no parameters. @end ignore + @node Metrics + @subsection @code{Metrics} + @cindex @code{Metrics} rule (for @command{gnatcheck}) + + @noindent + There is a set of checks based on computing a metric value and comparing the + result with the specified upper (or lower, depending on a specific metric) + value specified for a given metric. A construct is flagged if a given metric + is applicable (can be computed) for it and the computed value is greater + then (lover then) the specified upper (lower) bound. + + The name of any metric-based rule consists of the prefix @code{Metrics_} + followed by the name of the corresponding metric (see the table below). + For @option{+R} option, each metric-based rule has a numeric parameter + specifying the bound (integer or real, depending on a metric), @option{-R} + option for metric rules does not have a parameter. + + The following table shows the metric names for that the corresponding + metrics-based checks are supported by gnatcheck, including the + constraint that must be satisfied by the bound that is specified for the check + and what bound - upper (U) or lower (L) - should be specified. + + @multitable {@code{Cyclomatic_Complexity}}{Cyclomatic complexity}{Positive integer} + @ifnothtml + @headitem Check Name @tab Description @tab Bounds Value + @end ifnothtml + @ifhtml + @item @b{Check Name} @tab @b{Description} @tab @b{Bounds Value} + @end ifhtml + @c Above conditional code is workaround to bug in texi2html (Feb 2008) + @item @code{Essential_Complexity} @tab Essential complexity @tab Positive integer (U) + @item @code{Cyclomatic_Complexity} @tab Cyclomatic complexity @tab Positive integer (U) + @item @code{LSLOC} @tab Logical Source Lines of Code @tab Positive integer (U) + @end multitable + + @noindent + The meaning and the computed values for all these metrics are exactly + the same as for the corresponding metrics in @command{gnatmetric}. + + @emph{Example:} the rule + @smallexample + +RMetrics_Cyclomatic_Complexity : 7 + @end smallexample + @noindent + means that all bodies with cyclomatic complexity exceeding 7 will be flagged. + + To turn OFF the check for cyclomatic complexity metric, use the following option: + @smallexample + -RMetrics_Cyclomatic_Complexity + @end smallexample @node Misnamed_Identifiers @subsection @code{Misnamed_Identifiers} *************** The following declarations are checked: *** 20574,20587 **** @itemize @bullet @item ! type declarations @item ! constant declarations (but not number declarations) @item ! package renaming declarations (but not generic package renaming ! declarations) @end itemize @noindent --- 21125,21138 ---- @itemize @bullet @item ! type declarations @item ! constant declarations (but not number declarations) @item ! package renaming declarations (but not generic package renaming ! declarations) @end itemize @noindent *************** the following checks: *** 20590,20601 **** @itemize @bullet @item ! type-defining names end with @code{_T}, unless the type is an access type, ! in which case the suffix must be @code{_A} @item ! constant names end with @code{_C} @item ! names defining package renamings end with @code{_R} @end itemize @noindent --- 21141,21152 ---- @itemize @bullet @item ! type-defining names end with @code{_T}, unless the type is an access type, ! in which case the suffix must be @code{_A} @item ! constant names end with @code{_C} @item ! names defining package renamings end with @code{_R} @end itemize @noindent *************** made for the defining name suffix: *** 20604,20622 **** @itemize @bullet @item ! For an incomplete type declaration: if the corresponding full type ! declaration is available, the defining identifier from the full type ! declaration is checked, but the defining identifier from the incomplete type ! declaration is not; otherwise the defining identifier from the incomplete ! type declaration is checked against the suffix specified for type ! declarations. @item ! For a private type declaration (including private extensions), the defining ! identifier from the private type declaration is checked against the type ! suffix (even if the corresponding full declaration is an access type ! declaration), and the defining identifier from the corresponding full type ! declaration is not checked. @end itemize @noindent --- 21155,21173 ---- @itemize @bullet @item ! For an incomplete type declaration: if the corresponding full type ! declaration is available, the defining identifier from the full type ! declaration is checked, but the defining identifier from the incomplete type ! declaration is not; otherwise the defining identifier from the incomplete ! type declaration is checked against the suffix specified for type ! declarations. @item ! For a private type declaration (including private extensions), the defining ! identifier from the private type declaration is checked against the type ! suffix (even if the corresponding full declaration is an access type ! declaration), and the defining identifier from the corresponding full type ! declaration is not checked. @end itemize @noindent *************** The control structures checked are the f *** 21010,21016 **** @end itemize @noindent ! The rule may have the following parameter for the @option{+R} option: @table @emph @item N --- 21561,21567 ---- @end itemize @noindent ! The rule has the following parameter for the @option{+R} option: @table @emph @item N *************** level that is not flagged *** 21019,21036 **** @end table @noindent ! If the parameter for the @option{+R} option is not a positive integer, ! the parameter is ignored and the rule is turned ON with the most recently ! specified maximal non-flagged nesting level. If more then one option is specified for the gnatcheck call, the later option and new parameter override the previous one(s). - A @option{+R} option with no parameter turns the rule ON using the maximal - non-flagged nesting level specified by the most recent @option{+R} option with - a parameter, or the value 4 if there is no such previous @option{+R} option. - - @node Parameters_Out_Of_Order @subsection @code{Parameters_Out_Of_Order} --- 21570,21581 ---- @end table @noindent ! If the parameter for the @option{+R} option is not specified or ! if it is not a positive integer, @option{+R} option is ignored. If more then one option is specified for the gnatcheck call, the later option and new parameter override the previous one(s). @node Parameters_Out_Of_Order @subsection @code{Parameters_Out_Of_Order} *************** Flag each @code{raise} statement that ra *** 21199,21204 **** --- 21744,21761 ---- This rule has no parameters. + @node Separate_Numeric_Error_Handlers + @subsection @code{Separate_Numeric_Error_Handlers} + @cindex @code{Separate_Numeric_Error_Handlers} rule (for @command{gnatcheck}) + + @noindent + Flags each exception handler that contains a choice for + the predefined @code{Constraint_Error} exception, but does not contain + the choice for the predefined @code{Numeric_Error} exception, or + that contains the choice for @code{Numeric_Error}, but does not contain the + choice for @code{Constraint_Error}. + + This rule has no parameters. @ignore @node Recursion *************** of @command{gnatstub} switches below. *** 21470,21481 **** @command{gnatstub} has the command-line interface of the form @smallexample ! $ gnatstub [switches] filename [directory] @end smallexample @noindent where ! @table @emph @item filename is the name of the source file that contains a library unit declaration for which a body must be created. The file name may contain the path --- 22027,22038 ---- @command{gnatstub} has the command-line interface of the form @smallexample ! $ gnatstub @ovar{switches} @var{filename} @ovar{directory} @end smallexample @noindent where ! @table @var @item filename is the name of the source file that contains a library unit declaration for which a body must be created. The file name may contain the path *************** into the body stub. *** 21524,21529 **** --- 22081,22090 ---- @cindex @option{^-hg^/HEADER=GENERAL^} (@command{gnatstub}) Put a sample comment header into the body stub. + @item ^--header-file=@var{filename}^/FROM_HEADER_FILE=@var{filename}^ + @cindex @option{^--header-file^/FROM_HEADER_FILE=^} (@command{gnatstub}) + Use the content of the file as the comment header for a generated body stub. + @ifclear vms @item -IDIR @cindex @option{-IDIR} (@command{gnatstub}) *************** be able to click on any identifier and g *** 21741,21747 **** The command line is as follow: @smallexample ! $ perl gnathtml.pl [^switches^options^] ada-files @end smallexample @noindent --- 22302,22308 ---- The command line is as follow: @smallexample ! $ perl gnathtml.pl @ovar{^switches^options^} @var{ada-files} @end smallexample @noindent *************** If you do not specify an extension, it w *** 21781,21787 **** @item -f @cindex @option{-f} (@code{gnathtml}) By default, gnathtml will generate html links only for global entities ! ('with'ed units, global variables and types,...). If you specify @option{-f} on the command line, then links will be generated for local entities too. --- 22342,22348 ---- @item -f @cindex @option{-f} (@code{gnathtml}) By default, gnathtml will generate html links only for global entities ! ('with'ed units, global variables and types,@dots{}). If you specify @option{-f} on the command line, then links will be generated for local entities too. *************** is. The syntax of this line is: *** 21847,21853 **** Alternatively, you may run the script using the following command line: @smallexample ! $ perl gnathtml.pl [switches] files @end smallexample @ifset vms --- 22408,22414 ---- Alternatively, you may run the script using the following command line: @smallexample ! $ perl gnathtml.pl @ovar{switches} @var{files} @end smallexample @ifset vms *************** $ RUN/DEBUG *** 21877,21882 **** --- 22438,22731 ---- @noindent @end ifset + @ifclear vms + @c ****************************** + @node Code Coverage and Profiling + @chapter Code Coverage and Profiling + @cindex Code Coverage + @cindex Profiling + + @noindent + This chapter describes how to use @code{gcov} - coverage testing tool - and + @code{gprof} - profiler tool - on your Ada programs. + + @menu + * Code Coverage of Ada Programs using gcov:: + * Profiling an Ada Program using gprof:: + @end menu + + @node Code Coverage of Ada Programs using gcov + @section Code Coverage of Ada Programs using gcov + @cindex gcov + @cindex -fprofile-arcs + @cindex -ftest-coverage + @cindex -coverage + @cindex Code Coverage + + @noindent + @code{gcov} is a test coverage program: it analyzes the execution of a given + program on selected tests, to help you determine the portions of the program + that are still untested. + + @code{gcov} is part of the GCC suite, and is described in detail in the GCC + User's Guide. You can refer to this documentation for a more complete + description. + + This chapter provides a quick startup guide, and + details some Gnat-specific features. + + @menu + * Quick startup guide:: + * Gnat specifics:: + @end menu + + @node Quick startup guide + @subsection Quick startup guide + + In order to perform coverage analysis of a program using @code{gcov}, 3 + steps are needed: + + @itemize @bullet + @item + Code instrumentation during the compilation process + @item + Execution of the instrumented program + @item + Execution of the @code{gcov} tool to generate the result. + @end itemize + + The code instrumentation needed by gcov is created at the object level: + The source code is not modified in any way, because the instrumentation code is + inserted by gcc during the compilation process. To compile your code with code + coverage activated, you need to recompile your whole project using the + switches + @code{-fprofile-arcs} and @code{-ftest-coverage}, and link it using + @code{-fprofile-arcs}. + + @smallexample + $ gnatmake -P my_project.gpr -f -cargs -fprofile-arcs -ftest-coverage \ + -largs -fprofile-arcs + @end smallexample + + This compilation process will create @file{.gcno} files together with + the usual object files. + + Once the program is compiled with coverage instrumentation, you can + run it as many times as needed - on portions of a test suite for + example. The first execution will produce @file{.gcda} files at the + same location as the @file{.gcno} files. The following executions + will update those files, so that a cumulative result of the covered + portions of the program is generated. + + Finally, you need to call the @code{gcov} tool. The different options of + @code{gcov} are available in the GCC User's Guide, section 'Invoking gcov'. + + This will create annotated source files with a @file{.gcov} extension: + @file{my_main.adb} file will be analysed in @file{my_main.adb.gcov}. + + @node Gnat specifics + @subsection Gnat specifics + + Because Ada semantics, portions of the source code may be shared among + several object files. This is the case for example when generics are + involved, when inlining is active or when declarations generate initialisation + calls. In order to take + into account this shared code, you need to call @code{gcov} on all + source files of the tested program at once. + + The list of source files might exceed the system's maximum command line + length. In order to bypass this limitation, a new mechanism has been + implemented in @code{gcov}: you can now list all your project's files into a + text file, and provide this file to gcov as a parameter, preceded by a @@ + (e.g. @samp{gcov @@mysrclist.txt}). + + Note that on AIX compiling a static library with @code{-fprofile-arcs} is + not supported as there can be unresolved symbols during the final link. + + @node Profiling an Ada Program using gprof + @section Profiling an Ada Program using gprof + @cindex gprof + @cindex -pg + @cindex Profiling + + @noindent + This section is not meant to be an exhaustive documentation of @code{gprof}. + Full documentation for it can be found in the GNU Profiler User's Guide + documentation that is part of this GNAT distribution. + + Profiling a program helps determine the parts of a program that are executed + most often, and are therefore the most time-consuming. + + @code{gprof} is the standard GNU profiling tool; it has been enhanced to + better handle Ada programs and multitasking. + It is currently supported on the following platforms + @itemize @bullet + @item + linux x86/x86_64 + @item + solaris sparc/sparc64/x86 + @item + windows x86 + @end itemize + + @noindent + In order to profile a program using @code{gprof}, 3 steps are needed: + + @itemize @bullet + @item + Code instrumentation, requiring a full recompilation of the project with the + proper switches. + @item + Execution of the program under the analysis conditions, i.e. with the desired + input. + @item + Analysis of the results using the @code{gprof} tool. + @end itemize + + @noindent + The following sections detail the different steps, and indicate how + to interpret the results: + @menu + * Compilation for profiling:: + * Program execution:: + * Running gprof:: + * Interpretation of profiling results:: + @end menu + + @node Compilation for profiling + @subsection Compilation for profiling + @cindex -pg + @cindex Profiling + + In order to profile a program the first step is to tell the compiler + to generate the necessary profiling information. The compiler switch to be used + is @code{-pg}, which must be added to other compilation switches. This + switch needs to be specified both during compilation and link stages, and can + be specified once when using gnatmake: + + @smallexample + gnatmake -f -pg -P my_project + @end smallexample + + @noindent + Note that only the objects that were compiled with the @samp{-pg} switch will be + profiled; if you need to profile your whole project, use the + @samp{-f} gnatmake switch to force full recompilation. + + @node Program execution + @subsection Program execution + + @noindent + Once the program has been compiled for profiling, you can run it as usual. + + The only constraint imposed by profiling is that the program must terminate + normally. An interrupted program (via a Ctrl-C, kill, etc.) will not be + properly analyzed. + + Once the program completes execution, a data file called @file{gmon.out} is + generated in the directory where the program was launched from. If this file + already exists, it will be overwritten. + + @node Running gprof + @subsection Running gprof + + @noindent + The @code{gprof} tool is called as follow: + + @smallexample + gprof my_prog gmon.out + @end smallexample + + @noindent + or simpler: + + @smallexample + gprof my_prog + @end smallexample + + @noindent + The complete form of the gprof command line is the following: + + @smallexample + gprof [^switches^options^] [executable [data-file]] + @end smallexample + + @noindent + @code{gprof} supports numerous ^switch^options^. The order of these + ^switch^options^ does not matter. The full list of options can be found in + the GNU Profiler User's Guide documentation that comes with this documentation. + + The following is the subset of those switches that is most relevant: + + @table @option + + @item --demangle[=@var{style}] + @itemx --no-demangle + @cindex @option{--demangle} (@code{gprof}) + These options control whether symbol names should be demangled when + printing output. The default is to demangle C++ symbols. The + @code{--no-demangle} option may be used to turn off demangling. Different + compilers have different mangling styles. The optional demangling style + argument can be used to choose an appropriate demangling style for your + compiler, in particular Ada symbols generated by GNAT can be demangled using + @code{--demangle=gnat}. + + @item -e @var{function_name} + @cindex @option{-e} (@code{gprof}) + The @samp{-e @var{function}} option tells @code{gprof} not to print + information about the function @var{function_name} (and its + children@dots{}) in the call graph. The function will still be listed + as a child of any functions that call it, but its index number will be + shown as @samp{[not printed]}. More than one @samp{-e} option may be + given; only one @var{function_name} may be indicated with each @samp{-e} + option. + + @item -E @var{function_name} + @cindex @option{-E} (@code{gprof}) + The @code{-E @var{function}} option works like the @code{-e} option, but + execution time spent in the function (and children who were not called from + anywhere else), will not be used to compute the percentages-of-time for + the call graph. More than one @samp{-E} option may be given; only one + @var{function_name} may be indicated with each @samp{-E} option. + + @item -f @var{function_name} + @cindex @option{-f} (@code{gprof}) + The @samp{-f @var{function}} option causes @code{gprof} to limit the + call graph to the function @var{function_name} and its children (and + their children@dots{}). More than one @samp{-f} option may be given; + only one @var{function_name} may be indicated with each @samp{-f} + option. + + @item -F @var{function_name} + @cindex @option{-F} (@code{gprof}) + The @samp{-F @var{function}} option works like the @code{-f} option, but + only time spent in the function and its children (and their + children@dots{}) will be used to determine total-time and + percentages-of-time for the call graph. More than one @samp{-F} option + may be given; only one @var{function_name} may be indicated with each + @samp{-F} option. The @samp{-F} option overrides the @samp{-E} option. + + @end table + + @node Interpretation of profiling results + @subsection Interpretation of profiling results + + @noindent + + The results of the profiling analysis are represented by two arrays: the + 'flat profile' and the 'call graph'. Full documentation of those outputs + can be found in the GNU Profiler User's Guide. + + The flat profile shows the time spent in each function of the program, and how + many time it has been called. This allows you to locate easily the most + time-consuming functions. + + The call graph shows, for each subprogram, the subprograms that call it, + and the subprograms that it calls. It also provides an estimate of the time + spent in each of those callers/called subprograms. + @end ifclear + + @c ****************************** @node Running and Debugging Ada Programs @chapter Running and Debugging Ada Programs @cindex Debugging *************** and in particular is capable of debuggin *** 21938,21948 **** GNAT. The latest versions of @code{GDB} are Ada-aware and can handle complex Ada data structures. ! The manual @cite{Debugging with GDB} @ifset vms ! , located in the GNU:[DOCS] directory, @end ifset ! contains full details on the usage of @code{GDB}, including a section on its usage on programs. This manual should be consulted for full details. The section that follows is a brief introduction to the philosophy and use of @code{GDB}. --- 22787,22797 ---- GNAT. The latest versions of @code{GDB} are Ada-aware and can handle complex Ada data structures. ! @xref{Top,, Debugging with GDB, gdb, Debugging with GDB}, @ifset vms ! located in the GNU:[DOCS] directory, @end ifset ! for full details on the usage of @code{GDB}, including a section on its usage on programs. This manual should be consulted for full details. The section that follows is a brief introduction to the philosophy and use of @code{GDB}. *************** separate from the generated code. It mak *** 21954,21962 **** larger, but it does not add to the size of the actual executable that will be loaded into memory, and has no impact on run-time performance. The generation of debug information is triggered by the use of the ! ^-g^/DEBUG^ switch in the gcc or gnatmake command used to carry out ! the compilations. It is important to emphasize that the use of these ! options does not change the generated code. The debugging information is written in standard system formats that are used by many tools, including debuggers and profilers. The format --- 22803,22811 ---- larger, but it does not add to the size of the actual executable that will be loaded into memory, and has no impact on run-time performance. The generation of debug information is triggered by the use of the ! ^-g^/DEBUG^ switch in the @command{gcc} or @command{gnatmake} command ! used to carry out the compilations. It is important to emphasize that ! the use of these options does not change the generated code. The debugging information is written in standard system formats that are used by many tools, including debuggers and profilers. The format *************** describes some of the additional command *** 22022,22035 **** @section Introduction to GDB Commands @noindent ! @code{GDB} contains a large repertoire of commands. The manual ! @cite{Debugging with GDB} @ifset vms ! (located in the GNU:[DOCS] directory) @end ifset ! includes extensive documentation on the use of these commands, together with examples of their use. Furthermore, ! the command @var{help} invoked from within @code{GDB} activates a simple help facility which summarizes the available commands and their options. In this section we summarize a few of the most commonly used commands to give an idea of what @code{GDB} is about. You should create --- 22871,22884 ---- @section Introduction to GDB Commands @noindent ! @code{GDB} contains a large repertoire of commands. @xref{Top,, ! Debugging with GDB, gdb, Debugging with GDB}, @ifset vms ! located in the GNU:[DOCS] directory, @end ifset ! for extensive documentation on the use of these commands, together with examples of their use. Furthermore, ! the command @command{help} invoked from within GDB activates a simple help facility which summarizes the available commands and their options. In this section we summarize a few of the most commonly used commands to give an idea of what @code{GDB} is about. You should create *************** The above list is a very short introduct *** 22122,22129 **** @code{GDB} provides. Important additional capabilities, including conditional breakpoints, the ability to execute command sequences on a breakpoint, the ability to debug at the machine instruction level and many other ! features are described in detail in @cite{Debugging with GDB}. ! Note that most commands can be abbreviated (for example, c for continue, bt for backtrace). @node Using Ada Expressions --- 22971,22978 ---- @code{GDB} provides. Important additional capabilities, including conditional breakpoints, the ability to execute command sequences on a breakpoint, the ability to debug at the machine instruction level and many other ! features are described in detail in @ref{Top,, Debugging with GDB, gdb, ! Debugging with GDB}. Note that most commands can be abbreviated (for example, c for continue, bt for backtrace). @node Using Ada Expressions *************** packages, thus making it unnecessary to *** 22156,22162 **** their packages, regardless of context. Where this causes ambiguity, @code{GDB} asks the user's intent. ! For details on the supported Ada syntax, see @cite{Debugging with GDB}. @node Calling User-Defined Subprograms @section Calling User-Defined Subprograms --- 23005,23012 ---- their packages, regardless of context. Where this causes ambiguity, @code{GDB} asks the user's intent. ! For details on the supported Ada syntax, see @ref{Top,, Debugging with ! GDB, gdb, Debugging with GDB}. @node Calling User-Defined Subprograms @section Calling User-Defined Subprograms *************** perturbed. *** 22316,22322 **** @noindent For more detailed information on the tasking support, ! see @cite{Debugging with GDB}. @node Debugging Generic Units @section Debugging Generic Units --- 23166,23172 ---- @noindent For more detailed information on the tasking support, ! see @ref{Top,, Debugging with GDB, gdb, Debugging with GDB}. @node Debugging Generic Units @section Debugging Generic Units *************** both language-defined children and GNAT *** 22504,22510 **** @item @findex GNAT Files with prefix @file{^g-^G-^} are children of @code{GNAT}. These are useful ! general-purpose packages, fully documented in their specifications. All the other @file{.c} files are modifications of common @command{gcc} files. @end itemize --- 23354,23360 ---- @item @findex GNAT Files with prefix @file{^g-^G-^} are children of @code{GNAT}. These are useful ! general-purpose packages, fully documented in their specs. All the other @file{.c} files are modifications of common @command{gcc} files. @end itemize *************** $ addr2line --exe=stb 0x401373 0x40138b *** 22639,22646 **** 0040138B at d:/stb/stb.adb:10 0040139C at d:/stb/stb.adb:14 00401335 at d:/stb/b~stb.adb:104 ! 004011C4 at /build/.../crt1.c:200 ! 004011F1 at /build/.../crt1.c:222 77E892A4 in ?? at ??:0 @end smallexample --- 23489,23496 ---- 0040138B at d:/stb/stb.adb:10 0040139C at d:/stb/stb.adb:14 00401335 at d:/stb/b~stb.adb:104 ! 004011C4 at /build/@dots{}/crt1.c:200 ! 004011F1 at /build/@dots{}/crt1.c:222 77E892A4 in ?? at ??:0 @end smallexample *************** $ addr2line --exe=stb --functions --dema *** 22664,22671 **** 0040138B in stb.p2 at d:/stb/stb.adb:10 0040139C in stb at d:/stb/stb.adb:14 00401335 in main at d:/stb/b~stb.adb:104 ! 004011C4 in <__mingw_CRTStartup> at /build/.../crt1.c:200 ! 004011F1 in at /build/.../crt1.c:222 @end smallexample @noindent --- 23514,23521 ---- 0040138B in stb.p2 at d:/stb/stb.adb:10 0040139C in stb at d:/stb/stb.adb:14 00401335 in main at d:/stb/b~stb.adb:104 ! 004011C4 in <__mingw_CRTStartup> at /build/@dots{}/crt1.c:200 ! 004011F1 in at /build/@dots{}/crt1.c:222 @end smallexample @noindent *************** GNAT always follows the Alpha implementa *** 22975,22983 **** For GNAT running on other than VMS systems, all the HP Ada 83 pragmas and attributes are recognized, although only a subset of them can sensibly ! be implemented. The description of pragmas in the ! @cite{GNAT Reference Manual} indicates whether or not they are applicable ! to non-VMS systems. @menu * Ada Language Compatibility:: --- 23825,23833 ---- For GNAT running on other than VMS systems, all the HP Ada 83 pragmas and attributes are recognized, although only a subset of them can sensibly ! be implemented. The description of pragmas in ! @xref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference Manual} ! indicates whether or not they are applicable to non-VMS systems. @menu * Ada Language Compatibility:: *************** package @code{System.Aux_DEC}. *** 23054,23060 **** @cindex @code{Aux_DEC} package (child of @code{System}) These definitions are incorporated directly into package @code{System}, as though they had been declared there. For a ! list of the declarations added, see the specification of this package, which can be found in the file @file{s-auxdec.ads} in the GNAT library. @cindex @file{s-auxdec.ads} file The pragma @code{Extend_System} is a configuration pragma, which means that --- 23904,23910 ---- @cindex @code{Aux_DEC} package (child of @code{System}) These definitions are incorporated directly into package @code{System}, as though they had been declared there. For a ! list of the declarations added, see the spec of this package, which can be found in the file @file{s-auxdec.ads} in the GNAT library. @cindex @file{s-auxdec.ads} file The pragma @code{Extend_System} is a configuration pragma, which means that *************** use System.Aux_DEC; *** 23077,23083 **** The effect is not quite semantically identical to incorporating the declarations directly into package @code{System}, but most programs will not notice a difference ! unless they use prefix notation (e.g. @code{System.Integer_8}) to reference the entities directly in package @code{System}. For units containing such references, the prefixes must either be removed, or the pragma @code{Extend_System} --- 23927,23933 ---- The effect is not quite semantically identical to incorporating the declarations directly into package @code{System}, but most programs will not notice a difference ! unless they use prefix notation (e.g.@: @code{System.Integer_8}) to reference the entities directly in package @code{System}. For units containing such references, the prefixes must either be removed, or the pragma @code{Extend_System} *************** fixed-point types are truncated. *** 23263,23269 **** @subsection Record and Array Component Alignment @noindent ! On HP Ada for OpenVMS Alpha, all non composite components are aligned on natural boundaries. For example, 1-byte components are aligned on byte boundaries, 2-byte components on 2-byte boundaries, 4-byte components on 4-byte --- 24113,24119 ---- @subsection Record and Array Component Alignment @noindent ! On HP Ada for OpenVMS Alpha, all non-composite components are aligned on natural boundaries. For example, 1-byte components are aligned on byte boundaries, 2-byte components on 2-byte boundaries, 4-byte components on 4-byte *************** of declarations: *** 23310,23316 **** @cartouche X, Y : Integer := Init_Func; Q : String (X .. Y) := "abc"; ! ... for Q'Address use Compute_Address; @end cartouche @end smallexample --- 24160,24166 ---- @cartouche X, Y : Integer := Init_Func; Q : String (X .. Y) := "abc"; ! @dots{} for Q'Address use Compute_Address; @end cartouche @end smallexample *************** that @code{Q} is declared. To achieve th *** 23325,23331 **** X, Y : Integer := Init_Func; Q_Address : constant Address := Compute_Address; Q : String (X .. Y) := "abc"; ! ... for Q'Address use Q_Address; @end cartouche @end group --- 24175,24181 ---- X, Y : Integer := Init_Func; Q_Address : constant Address := Compute_Address; Q : String (X .. Y) := "abc"; ! @dots{} for Q'Address use Q_Address; @end cartouche @end group *************** for Q'Address use Q_Address; *** 23334,23340 **** @noindent which will be accepted by GNAT (and other Ada compilers), and is also compatible with Ada 83. A fuller description of the restrictions ! on address specifications is found in the @cite{GNAT Reference Manual}. @node Other Representation Clauses @subsection Other Representation Clauses --- 24184,24191 ---- @noindent which will be accepted by GNAT (and other Ada compilers), and is also compatible with Ada 83. A fuller description of the restrictions ! on address specifications is found in @ref{Top, GNAT Reference Manual, ! About This Guide, gnat_rm, GNAT Reference Manual}. @node Other Representation Clauses @subsection Other Representation Clauses *************** pragmas. See @ref{Floating-Point Types a *** 23369,23375 **** @noindent HP Ada provides a specific version of the package @code{SYSTEM} for each platform on which the language is implemented. ! For the complete specification of the package @code{SYSTEM}, see Appendix F of the @cite{HP Ada Language Reference Manual}. On HP Ada, the package @code{SYSTEM} includes the following conversion --- 24220,24226 ---- @noindent HP Ada provides a specific version of the package @code{SYSTEM} for each platform on which the language is implemented. ! For the complete spec of the package @code{SYSTEM}, see Appendix F of the @cite{HP Ada Language Reference Manual}. On HP Ada, the package @code{SYSTEM} includes the following conversion *************** functions: *** 23386,23392 **** @item @code{TO_UNSIGNED_LONGWORD(ADDRESS)} @item Function @code{IMPORT_VALUE return UNSIGNED_LONGWORD} and the ! functions @code{IMPORT_ADDRESS} and @code{IMPORT_LARGEST_VALUE} @end itemize @noindent --- 24237,24243 ---- @item @code{TO_UNSIGNED_LONGWORD(ADDRESS)} @item Function @code{IMPORT_VALUE return UNSIGNED_LONGWORD} and the ! functions @code{IMPORT_ADDRESS} and @code{IMPORT_LARGEST_VALUE} @end itemize @noindent *************** pragma Extend_System (Aux_DEC); *** 23421,23428 **** @noindent The pragma @code{Extend_System} is a configuration pragma that ! is most conveniently placed in the @file{gnat.adc} file. See the ! @cite{GNAT Reference Manual} for further details. HP Ada does not allow the recompilation of the package @code{SYSTEM}. Instead HP Ada provides several pragmas --- 24272,24279 ---- @noindent The pragma @code{Extend_System} is a configuration pragma that ! is most conveniently placed in the @file{gnat.adc} file. @xref{Pragma ! Extend_System,,, gnat_rm, GNAT Reference Manual} for further details. HP Ada does not allow the recompilation of the package @code{SYSTEM}. Instead HP Ada provides several pragmas *************** are virtually identical to those provide *** 23453,23460 **** @code{TO_ADDRESS} function for type @code{UNSIGNED_LONGWORD} is changed to @code{TO_ADDRESS_LONG}. ! See the @cite{GNAT Reference Manual} for a discussion of why this change was ! necessary. @noindent The version of @code{TO_ADDRESS} taking a @i{universal_integer} argument --- 24304,24311 ---- @code{TO_ADDRESS} function for type @code{UNSIGNED_LONGWORD} is changed to @code{TO_ADDRESS_LONG}. ! @xref{Address Clauses,,, gnat_rm, GNAT Reference Manual} for a ! discussion of why this change was necessary. @noindent The version of @code{TO_ADDRESS} taking a @i{universal_integer} argument *************** GNAT supplies the following task-related *** 23579,23594 **** @itemize @bullet @item @code{TASK_INFO} ! This pragma appears within a task definition and ! applies to the task in which it appears. The argument ! must be of type @code{SYSTEM.TASK_INFO.TASK_INFO_TYPE}. @item @code{TASK_STORAGE} ! GNAT implements pragma @code{TASK_STORAGE} in the same way as ! HP Ada. ! Both HP Ada and GNAT supply the pragmas @code{PASSIVE}, ! @code{SUPPRESS}, and @code{VOLATILE}. @end itemize @node Scheduling and Task Priority @subsection Scheduling and Task Priority --- 24430,24444 ---- @itemize @bullet @item @code{TASK_INFO} ! This pragma appears within a task definition and ! applies to the task in which it appears. The argument ! must be of type @code{SYSTEM.TASK_INFO.TASK_INFO_TYPE}. @item @code{TASK_STORAGE} ! GNAT implements pragma @code{TASK_STORAGE} in the same way as HP Ada. ! Both HP Ada and GNAT supply the pragmas @code{PASSIVE}, ! @code{SUPPRESS}, and @code{VOLATILE}. @end itemize @node Scheduling and Task Priority @subsection Scheduling and Task Priority *************** GNAT also supplies a number of implement *** 23783,23790 **** @end itemize @noindent ! For full details on these GNAT implementation-defined pragmas, see ! the GNAT Reference Manual. @menu * Restrictions on the Pragma INLINE:: --- 24633,24641 ---- @end itemize @noindent ! For full details on these GNAT implementation-defined pragmas, ! see @ref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference ! Manual}. @menu * Restrictions on the Pragma INLINE:: *************** clauses to obey Ada 95 (and thus Ada 200 *** 23913,23919 **** @item Adding the proper notation to generic formal parameters that take unconstrained types in instantiation ! @item Adding pragma @code{ELABORATE_BODY} to package specifications that have package bodies not otherwise allowed @item Replacing occurrences of the identifier ``@code{PROTECTED}'' by --- 24764,24770 ---- @item Adding the proper notation to generic formal parameters that take unconstrained types in instantiation ! @item Adding pragma @code{ELABORATE_BODY} to package specs that have package bodies not otherwise allowed @item Replacing occurrences of the identifier ``@code{PROTECTED}'' by *************** Interfacing to C with GNAT, you can use *** 24026,24033 **** described for HP Ada or the facilities of Annex B of the @cite{Ada Reference Manual} (packages @code{INTERFACES.C}, @code{INTERFACES.C.STRINGS} and @code{INTERFACES.C.POINTERS}). For more ! information, see the section ``Interfacing to C'' in the ! @cite{GNAT Reference Manual}. The @option{-gnatF} qualifier forces default and explicit @code{External_Name} parameters in pragmas @code{Import} and @code{Export} --- 24877,24883 ---- described for HP Ada or the facilities of Annex B of the @cite{Ada Reference Manual} (packages @code{INTERFACES.C}, @code{INTERFACES.C.STRINGS} and @code{INTERFACES.C.POINTERS}). For more ! information, see @ref{Interfacing to C,,, gnat_rm, GNAT Reference Manual}. The @option{-gnatF} qualifier forces default and explicit @code{External_Name} parameters in pragmas @code{Import} and @code{Export} *************** On HP Ada, main programs are defined to *** 24044,24060 **** following conditions: @itemize @bullet @item Procedure with no formal parameters (returns @code{0} upon ! normal completion) @item Procedure with no formal parameters (returns @code{42} when ! an unhandled exception is raised) @item Function with no formal parameters whose returned value ! is of a discrete type @item Procedure with one @code{out} formal of a discrete type for ! which a specification of pragma @code{EXPORT_VALUED_PROCEDURE} ! is given. @end itemize --- 24894,24909 ---- following conditions: @itemize @bullet @item Procedure with no formal parameters (returns @code{0} upon ! normal completion) @item Procedure with no formal parameters (returns @code{42} when ! an unhandled exception is raised) @item Function with no formal parameters whose returned value ! is of a discrete type @item Procedure with one @code{out} formal of a discrete type for ! which a specification of pragma @code{EXPORT_VALUED_PROCEDURE} is given. @end itemize *************** HP Ada provides the following qualifiers *** 24091,24101 **** @item @option{/COMMAND} ! @item @option{/[NO]MAP} ! @item @option{/OUTPUT=@i{file-spec}} ! @item @option{/[NO]DEBUG} and @option{/[NO]TRACEBACK} @end itemize @noindent --- 24940,24950 ---- @item @option{/COMMAND} ! @item @option{/@r{[}NO@r{]}MAP} ! @item @option{/OUTPUT=@var{file-spec}} ! @item @option{/@r{[}NO@r{]}DEBUG} and @option{/@r{[}NO@r{]}TRACEBACK} @end itemize @noindent *************** To pass options to the linker, GNAT prov *** 24103,24113 **** switches: @itemize @bullet ! @item @option{/EXECUTABLE=@i{exec-name}} @item @option{/VERBOSE} ! @item @option{/[NO]DEBUG} and @option{/[NO]TRACEBACK} @end itemize @noindent --- 24952,24962 ---- switches: @itemize @bullet ! @item @option{/EXECUTABLE=@var{exec-name}} @item @option{/VERBOSE} ! @item @option{/@r{[}NO@r{]}DEBUG} and @option{/@r{[}NO@r{]}TRACEBACK} @end itemize @noindent *************** program library. *** 24225,24231 **** @item @command{ACS ENTER FOREIGN} @tab Copy (*)@* Allows the import of a foreign body as an Ada library ! specification and enters a reference to a pointer. @item @command{ACS ENTER UNIT} @tab Copy (*)@* --- 25074,25080 ---- @item @command{ACS ENTER FOREIGN} @tab Copy (*)@* Allows the import of a foreign body as an Ada library ! spec and enters a reference to a pointer. @item @command{ACS ENTER UNIT} @tab Copy (*)@* *************** by the @cite{Ada Reference Manual}. *** 24398,24405 **** For further information on how GNAT interfaces to the file system or how I/O is implemented in programs written in ! mixed languages, see the chapter ``Implementation of the ! Standard I/O'' in the @cite{GNAT Reference Manual}. This chapter covers the following: @itemize @bullet @item Standard I/O packages --- 25247,25254 ---- For further information on how GNAT interfaces to the file system or how I/O is implemented in programs written in ! mixed languages, see @ref{Implementation of the Standard I/O,,, ! gnat_rm, GNAT Reference Manual}. This chapter covers the following: @itemize @bullet @item Standard I/O packages *************** and GNAT systems. *** 24439,24445 **** @sp 1 @item In a subprogram or entry declaration, maximum number of ! formal parameters that are of an unconstrained record type @tab 32 @tab No set limit @sp 1 --- 25288,25294 ---- @sp 1 @item In a subprogram or entry declaration, maximum number of ! formal parameters that are of an unconstrained record type @tab 32 @tab No set limit @sp 1 *************** and GNAT systems. *** 24465,24471 **** @sp 1 @item Maximum number of formal parameters in an entry or ! subprogram declaration @tab 246 @tab No set limit @sp 1 --- 25314,25320 ---- @sp 1 @item Maximum number of formal parameters in an entry or ! subprogram declaration @tab 246 @tab No set limit @sp 1 *************** and GNAT systems. *** 24486,24498 **** @sp 1 @item Maximum number of objects declared with the pragma @code{COMMON_OBJECT} ! or @code{PSECT_OBJECT} @tab 32757 @tab No set limit @sp 1 @item Maximum number of enumeration literals in an enumeration type ! definition @tab 65535 @tab No set limit @sp 1 --- 25335,25347 ---- @sp 1 @item Maximum number of objects declared with the pragma @code{COMMON_OBJECT} ! or @code{PSECT_OBJECT} @tab 32757 @tab No set limit @sp 1 @item Maximum number of enumeration literals in an enumeration type ! definition @tab 65535 @tab No set limit @sp 1 *************** of the DECset package. *** 24591,24625 **** @c @multitable @columnfractions .3 .4 .4 @multitable {Source Code Analyzer /}{Tool with HP Ada}{Tool with GNAT Pro} @item @i{Tool} ! @tab @i{Tool with HP Ada} ! @tab @i{Tool with @value{EDITION}} @item Code Management@*System ! @tab HP CMS ! @tab HP CMS @item Language-Sensitive@*Editor ! @tab HP LSE ! @tab emacs or HP LSE (Alpha) @item ! @tab ! @tab HP LSE (I64) @item Debugger ! @tab OpenVMS Debug ! @tab gdb (Alpha), @item ! @tab ! @tab OpenVMS Debug (I64) @item Source Code Analyzer /@*Cross Referencer ! @tab HP SCA ! @tab GNAT XREF @item Test Manager ! @tab HP Digital Test@*Manager (DTM) ! @tab HP DTM @item Performance and@*Coverage Analyzer ! @tab HP PCA ! @tab HP PCA @item Module Management@*System ! @tab HP MMS ! @tab Not applicable @end multitable @end flushleft @end ifnottex --- 25440,25474 ---- @c @multitable @columnfractions .3 .4 .4 @multitable {Source Code Analyzer /}{Tool with HP Ada}{Tool with GNAT Pro} @item @i{Tool} ! @tab @i{Tool with HP Ada} ! @tab @i{Tool with @value{EDITION}} @item Code Management@*System ! @tab HP CMS ! @tab HP CMS @item Language-Sensitive@*Editor ! @tab HP LSE ! @tab emacs or HP LSE (Alpha) @item ! @tab ! @tab HP LSE (I64) @item Debugger ! @tab OpenVMS Debug ! @tab gdb (Alpha), @item ! @tab ! @tab OpenVMS Debug (I64) @item Source Code Analyzer /@*Cross Referencer ! @tab HP SCA ! @tab GNAT XREF @item Test Manager ! @tab HP Digital Test@*Manager (DTM) ! @tab HP DTM @item Performance and@*Coverage Analyzer ! @tab HP PCA ! @tab HP PCA @item Module Management@*System ! @tab HP MMS ! @tab Not applicable @end multitable @end flushleft @end ifnottex *************** information about several specific platf *** 24681,24686 **** --- 25530,25537 ---- * Solaris-Specific Considerations:: * Linux-Specific Considerations:: * AIX-Specific Considerations:: + * Irix-Specific Considerations:: + * RTX-Specific Considerations:: @end menu @node Summary of Run-Time Configurations *************** information about several specific platf *** 24791,24796 **** --- 25642,25656 ---- @item @code{@ @ @ @ }Tasking @tab native Win32 threads @item @code{@ @ @ @ }Exceptions @tab SJLJ @* + @item @b{x86-windows-rtx} + @item @code{@ @ }@i{rts-rtx-rtss (default)} + @item @code{@ @ @ @ }Tasking @tab RTX real-time subsystem RTSS threads (kernel mode) + @item @code{@ @ @ @ }Exceptions @tab SJLJ + @* + @item @code{@ @ }@i{rts-rtx-w32} + @item @code{@ @ @ @ }Tasking @tab RTX Win32 threads (user mode) + @item @code{@ @ @ @ }Exceptions @tab ZCX + @* @item @b{x86_64-linux} @item @code{@ @ }@i{rts-native (default)} @item @code{@ @ @ @ }Tasking @tab pthread library *************** and can thus execute on multiple process *** 24948,24970 **** The user can alternatively specify a processor on which the program should run to emulate a single-processor system. The multiprocessor / uniprocessor choice is made by ! setting the environment variable @code{GNAT_PROCESSOR} ! @cindex @code{GNAT_PROCESSOR} environment variable (on Sparc Solaris) to one of the following: @table @code @item -2 Use the default configuration (run the program on all ! available processors) - this is the same as having ! @code{GNAT_PROCESSOR} unset @item -1 Let the run-time implementation choose one processor and run the program on ! that processor @item 0 .. Last_Proc Run the program on the specified processor. ! @code{Last_Proc} is equal to @code{_SC_NPROCESSORS_CONF - 1} (where @code{_SC_NPROCESSORS_CONF} is a system variable). @end table --- 25808,25830 ---- The user can alternatively specify a processor on which the program should run to emulate a single-processor system. The multiprocessor / uniprocessor choice is made by ! setting the environment variable @env{GNAT_PROCESSOR} ! @cindex @env{GNAT_PROCESSOR} environment variable (on Sparc Solaris) to one of the following: @table @code @item -2 Use the default configuration (run the program on all ! available processors) - this is the same as having @code{GNAT_PROCESSOR} ! unset @item -1 Let the run-time implementation choose one processor and run the program on ! that processor @item 0 .. Last_Proc Run the program on the specified processor. ! @code{Last_Proc} is equal to @code{_SC_NPROCESSORS_CONF - 1} (where @code{_SC_NPROCESSORS_CONF} is a system variable). @end table *************** Run the program on the specified process *** 24976,24982 **** On GNU/Linux without NPTL support (usually system with GNU C Library older than 2.3), the signal model is not POSIX compliant, which means that to send a signal to the process, you need to send the signal to all ! threads, e.g. by using @code{killpg()}. @node AIX-Specific Considerations @section AIX-Specific Considerations --- 25836,25842 ---- On GNU/Linux without NPTL support (usually system with GNU C Library older than 2.3), the signal model is not POSIX compliant, which means that to send a signal to the process, you need to send the signal to all ! threads, e.g.@: by using @code{killpg()}. @node AIX-Specific Considerations @section AIX-Specific Considerations *************** occurs in the environment task, or use @ *** 24997,25002 **** --- 25857,25900 ---- specify a sufficiently large size for the stack of the task that contains this call. + @node Irix-Specific Considerations + @section Irix-Specific Considerations + @cindex Irix libraries + + @noindent + The GCC support libraries coming with the Irix compiler have moved to + their canonical place with respect to the general Irix ABI related + conventions. Running applications built with the default shared GNAT + run-time now requires the LD_LIBRARY_PATH environment variable to + include this location. A possible way to achieve this is to issue the + following command line on a bash prompt: + + @smallexample + @group + $ LD_LIBRARY_PATH=$LD_LIBRARY_PATH:`dirname \`gcc --print-file-name=libgcc_s.so\`` + @end group + @end smallexample + + @node RTX-Specific Considerations + @section RTX-Specific Considerations + @cindex RTX libraries + + @noindent + The Real-time Extension (RTX) to Windows is based on the Windows Win32 + API. Applications can be built to work in two different modes: + + @itemize @bullet + @item + Windows executables that run in Ring 3 to utilize memory protection + (@emph{rts-rtx-w32}). + + @item + Real-time subsystem (RTSS) executables that run in Ring 0, where + performance can be optimized with RTSS applications taking precedent + over all Windows applications (@emph{rts-rtx-rtss}). + + @end itemize + @c ******************************* @node Example of Binder Output File @appendix Example of Binder Output File *************** package body ada_main is *** 25374,25380 **** -- a-except.ads/adb for full details of how zero cost -- exception handling works. This procedure, the call to -- it, and the two following tables are all omitted if the ! -- build is in longjmp/setjump exception mode. @findex SDP_Table_Build @findex Zero Cost Exceptions --- 26272,26278 ---- -- a-except.ads/adb for full details of how zero cost -- exception handling works. This procedure, the call to -- it, and the two following tables are all omitted if the ! -- build is in longjmp/setjmp exception mode. @findex SDP_Table_Build @findex Zero Cost Exceptions *************** package body ada_main is *** 25449,25455 **** -- Call SDP_Table_Build to build the top level procedure -- table for zero cost exception handling (omitted in ! -- longjmp/setjump mode). SDP_Table_Build (ST'Address, 23, EA'Address, 23); --- 26347,26353 ---- -- Call SDP_Table_Build to build the top level procedure -- table for zero cost exception handling (omitted in ! -- longjmp/setjmp mode). SDP_Table_Build (ST'Address, 23, EA'Address, 23); *************** package body ada_main is *** 25633,25639 **** -- pragma Import because if we try to with the unit and -- call it Ada style, then not only do we waste time -- recompiling it, but also, we don't really know the right ! -- switches (e.g. identifier character set) to be used -- to compile it. procedure Ada_Main_Program; --- 26531,26537 ---- -- pragma Import because if we try to with the unit and -- call it Ada style, then not only do we waste time -- recompiling it, but also, we don't really know the right ! -- switches (e.g.@: identifier character set) to be used -- to compile it. procedure Ada_Main_Program; *************** of that unit before elaborating the unit *** 25803,25809 **** @group @cartouche with Unit_1; ! package Unit_2 is ... @end cartouche @end group @end smallexample --- 26701,26707 ---- @group @cartouche with Unit_1; ! package Unit_2 is @dots{} @end cartouche @end group @end smallexample *************** is impossible to guarantee a safe order *** 25923,25929 **** @noindent In some languages that involve the same kind of elaboration problems, ! e.g. Java and C++, the programmer is expected to worry about these ordering problems himself, and it is common to write a program in which an incorrect elaboration order gives surprising results, because it references variables before they --- 26821,26827 ---- @noindent In some languages that involve the same kind of elaboration problems, ! e.g.@: Java and C++, the programmer is expected to worry about these ordering problems himself, and it is common to write a program in which an incorrect elaboration order gives surprising results, because it references variables before they *************** to use @code{Elaborate_All} on such unit *** 26235,26241 **** @section Controlling Elaboration in GNAT - Internal Calls @noindent ! In the case of internal calls, i.e. calls within a single package, the programmer has full control over the order of elaboration, and it is up to the programmer to elaborate declarations in an appropriate order. For example writing: --- 27133,27139 ---- @section Controlling Elaboration in GNAT - Internal Calls @noindent ! In the case of internal calls, i.e., calls within a single package, the programmer has full control over the order of elaboration, and it is up to the programmer to elaborate declarations in an appropriate order. For example writing: *************** end Math; *** 26462,26468 **** package body Math is function Sqrt (Arg : Float) return Float is begin ! ... end Sqrt; end Math; @end group --- 27360,27366 ---- package body Math is function Sqrt (Arg : Float) return Float is begin ! @dots{} end Sqrt; end Math; @end group *************** end Stuff; *** 26475,26481 **** with Stuff; procedure Main is begin ! ... end Main; @end group @end cartouche --- 27373,27379 ---- with Stuff; procedure Main is begin ! @dots{} end Main; @end group @end cartouche *************** that is not a general rule that can be f *** 26522,26536 **** @smallexample @c ada @group @cartouche ! package X is ... ! package Y is ... with X; ! package body Y is ... with Y; ! package body X is ... @end cartouche @end group @end smallexample --- 27420,27434 ---- @smallexample @c ada @group @cartouche ! package X is @dots{} ! package Y is @dots{} with X; ! package body Y is @dots{} with Y; ! package body X is @dots{} @end cartouche @end group @end smallexample *************** the body of @code{X} @code{with}'s @code *** 26544,26550 **** which means you would have to elaborate the body of @code{Y} first, but that @code{with}'s @code{X}, which means ! you have to elaborate the body of @code{X} first, but ... and we have a loop that cannot be broken. It is true that the binder can in many cases guess an order of elaboration --- 27442,27448 ---- which means you would have to elaborate the body of @code{Y} first, but that @code{with}'s @code{X}, which means ! you have to elaborate the body of @code{X} first, but @dots{} and we have a loop that cannot be broken. It is true that the binder can in many cases guess an order of elaboration *************** Here is the exact chain of events we are *** 26828,26834 **** In the body of @code{Decls} a call is made from within the body of a library task to a subprogram in the package @code{Utils}. Since this call may occur at elaboration time (given that the task is activated at elaboration ! time), we have to assume the worst, i.e. that the call does happen at elaboration time. @item --- 27726,27732 ---- In the body of @code{Decls} a call is made from within the body of a library task to a subprogram in the package @code{Utils}. Since this call may occur at elaboration time (given that the task is activated at elaboration ! time), we have to assume the worst, i.e., that the call does happen at elaboration time. @item *************** Declare separate task types. *** 26960,26966 **** A significant part of the problem arises because of the use of the single task declaration form. This means that the elaboration of ! the task type, and the elaboration of the task itself (i.e. the creation of the task) happen at the same time. A good rule of style in Ada is to always create explicit task types. By following the additional step of placing task objects in separate --- 27858,27864 ---- A significant part of the problem arises because of the use of the single task declaration form. This means that the elaboration of ! the task type, and the elaboration of the task itself (i.e.@: the creation of the task) happen at the same time. A good rule of style in Ada is to always create explicit task types. By following the additional step of placing task objects in separate *************** constants to control which code is execu *** 27656,27664 **** @smallexample @c ada @group FP_Initialize_Required : constant Boolean := True; ! ... if FP_Initialize_Required then ! ... end if; @end group @end smallexample --- 28554,28562 ---- @smallexample @c ada @group FP_Initialize_Required : constant Boolean := True; ! @dots{} if FP_Initialize_Required then ! @dots{} end if; @end group @end smallexample *************** something like: *** 27682,27688 **** package Config is FP_Initialize_Required : constant Boolean := True; Reset_Available : constant Boolean := False; ! ... end Config; @end group @end smallexample --- 28580,28586 ---- package Config is FP_Initialize_Required : constant Boolean := True; Reset_Available : constant Boolean := False; ! @dots{} end Config; @end group @end smallexample *************** a pragma @code{Assert} that can be used *** 27730,27737 **** @cindex pragma @code{Assert} on the @code{Assert} pragma that has always been available in GNAT, so this feature may be used with GNAT even if you are not using Ada 2005 features. ! The use of pragma @code{Assert} is described in the ! @cite{GNAT Reference Manual}, but as an example, the last test could be written: @smallexample @c ada pragma Assert (Temperature <= 999.0, "Temperature Crazy"); --- 28628,28636 ---- @cindex pragma @code{Assert} on the @code{Assert} pragma that has always been available in GNAT, so this feature may be used with GNAT even if you are not using Ada 2005 features. ! The use of pragma @code{Assert} is described in ! @ref{Pragma Assert,,, gnat_rm, GNAT Reference Manual}, but as an ! example, the last test could be written: @smallexample @c ada pragma Assert (Temperature <= 999.0, "Temperature Crazy"); *************** to add a @code{null} statement. *** 27801,27808 **** @smallexample @c ada @group ! if ... then ! ... -- some statements else pragma Assert (Num_Cases < 10); null; --- 28700,28707 ---- @smallexample @c ada @group ! if @dots{} then ! @dots{} -- some statements else pragma Assert (Num_Cases < 10); null; *************** if Small_Machine then *** 27828,27840 **** declare X : Bit_String (1 .. 10); begin ! ... end; else declare X : Large_Bit_String (1 .. 1000); begin ! ... end; end if; @end group --- 28727,28739 ---- declare X : Bit_String (1 .. 10); begin ! @dots{} end; else declare X : Large_Bit_String (1 .. 1000); begin ! @dots{} end; end if; @end group *************** Note that in this approach, both declara *** 27845,27852 **** compiler so this can only be used where both declarations are legal, even though one of them will not be used. ! Another approach is to define integer constants, e.g. @code{Bits_Per_Word}, or ! Boolean constants, e.g. @code{Little_Endian}, and then write declarations that are parameterized by these constants. For example @smallexample @c ada --- 28744,28751 ---- compiler so this can only be used where both declarations are legal, even though one of them will not be used. ! Another approach is to define integer constants, e.g.@: @code{Bits_Per_Word}, or ! Boolean constants, e.g.@: @code{Little_Endian}, and then write declarations that are parameterized by these constants. For example @smallexample @c ada *************** to compile with an Ada 95 compiler. Conc *** 27914,27922 **** @smallexample @c ada @group if Ada_2005 then ! ... neat Ada 2005 code else ! ... not quite as neat Ada 95 code end if; @end group @end smallexample --- 28813,28821 ---- @smallexample @c ada @group if Ada_2005 then ! @dots{} neat Ada 2005 code else ! @dots{} not quite as neat Ada 95 code end if; @end group @end smallexample *************** from which it generates a sequence of as *** 28197,28203 **** The examples in this chapter will illustrate several of the forms for invoking @code{Asm}; a complete specification of the syntax ! is found in the @cite{GNAT Reference Manual}. Under the standard GNAT conventions, the @code{Nothing} procedure should be in a file named @file{nothing.adb}. --- 29096,29103 ---- The examples in this chapter will illustrate several of the forms for invoking @code{Asm}; a complete specification of the syntax ! is found in @ref{Machine Code Insertions,,, gnat_rm, GNAT Reference ! Manual}. Under the standard GNAT conventions, the @code{Nothing} procedure should be in a file named @file{nothing.adb}. *************** most useful (for the Intel x86 processor *** 28395,28401 **** @item = output constraint @item g ! global (i.e. can be stored anywhere) @item m in memory @item I --- 29295,29301 ---- @item = output constraint @item g ! global (i.e.@: can be stored anywhere) @item m in memory @item I *************** end Increment_2; *** 28644,28650 **** @end smallexample Compile the program with both optimization (@option{-O2}) and inlining ! enabled (@option{-gnatpn} instead of @option{-gnatp}). The @code{Incr} function is still compiled as usual, but at the point in @code{Increment} where our function used to be called: --- 29544,29550 ---- @end smallexample Compile the program with both optimization (@option{-O2}) and inlining ! (@option{-gnatn}) enabled. The @code{Incr} function is still compiled as usual, but at the point in @code{Increment} where our function used to be called: *************** following subsections treat the most lik *** 28832,28838 **** @node Legal Ada 83 programs that are illegal in Ada 95 @subsection Legal Ada 83 programs that are illegal in Ada 95 ! Some legal Ada 83 programs are illegal (i.e. they will fail to compile) in Ada 95 and thus also in Ada 2005: @table @emph --- 29732,29738 ---- @node Legal Ada 83 programs that are illegal in Ada 95 @subsection Legal Ada 83 programs that are illegal in Ada 95 ! Some legal Ada 83 programs are illegal (i.e., they will fail to compile) in Ada 95 and thus also in Ada 2005: @table @emph *************** Some uses of character literals are ambi *** 28842,28848 **** character literals that were legal in Ada 83 are illegal in Ada 95. For example: @smallexample @c ada ! for Char in 'A' .. 'Z' loop ... end loop; @end smallexample @noindent --- 29742,29748 ---- character literals that were legal in Ada 83 are illegal in Ada 95. For example: @smallexample @c ada ! for Char in 'A' .. 'Z' loop @dots{} end loop; @end smallexample @noindent *************** The problem is that @code{'A'} and @code *** 28850,28856 **** @code{Character} or @code{Wide_Character}. The simplest correction is to make the type explicit; e.g.: @smallexample @c ada ! for Char in Character range 'A' .. 'Z' loop ... end loop; @end smallexample @item New reserved words --- 29750,29756 ---- @code{Character} or @code{Wide_Character}. The simplest correction is to make the type explicit; e.g.: @smallexample @c ada ! for Char in Character range 'A' .. 'Z' loop @dots{} end loop; @end smallexample @item New reserved words *************** transition from certain Ada 83 compilers *** 29077,29087 **** @noindent Ada compilers are allowed to supplement the language-defined pragmas, and these are a potential source of non-portability. All GNAT-defined pragmas ! are described in the GNAT Reference Manual, and these include several that ! are specifically intended to correspond to other vendors' Ada 83 pragmas. For migrating from VADS, the pragma @code{Use_VADS_Size} may be useful. ! For ! compatibility with HP Ada 83, GNAT supplies the pragmas @code{Extend_System}, @code{Ident}, @code{Inline_Generic}, @code{Interface_Name}, @code{Passive}, @code{Suppress_All}, and @code{Volatile}. --- 29977,29987 ---- @noindent Ada compilers are allowed to supplement the language-defined pragmas, and these are a potential source of non-portability. All GNAT-defined pragmas ! are described in @ref{Implementation Defined Pragmas,,, gnat_rm, GNAT ! Reference Manual}, and these include several that are specifically ! intended to correspond to other vendors' Ada 83 pragmas. For migrating from VADS, the pragma @code{Use_VADS_Size} may be useful. ! For compatibility with HP Ada 83, GNAT supplies the pragmas @code{Extend_System}, @code{Ident}, @code{Inline_Generic}, @code{Interface_Name}, @code{Passive}, @code{Suppress_All}, and @code{Volatile}. *************** relevant in a GNAT context and hence are *** 29096,29104 **** @subsection Implementation-defined attributes Analogous to pragmas, the set of attributes may be extended by an ! implementation. All GNAT-defined attributes are described in the ! @cite{GNAT Reference Manual}, and these include several that are specifically ! intended to correspond to other vendors' Ada 83 attributes. For migrating from VADS, the attribute @code{VADS_Size} may be useful. For compatibility with HP Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and --- 29996,30004 ---- @subsection Implementation-defined attributes Analogous to pragmas, the set of attributes may be extended by an ! implementation. All GNAT-defined attributes are described in ! @ref{Implementation Defined Attributes,,, gnat_rm, GNAT Reference ! Manual}, and these include several that are specifically intended to correspond to other vendors' Ada 83 attributes. For migrating from VADS, the attribute @code{VADS_Size} may be useful. For compatibility with HP Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and *************** code uses vendor-specific libraries then *** 29112,29122 **** this in Ada 95 or Ada 2005: @enumerate @item ! If the source code for the libraries (specifications and bodies) are available, then the libraries can be migrated in the same way as the application. @item ! If the source code for the specifications but not the bodies are available, then you can reimplement the bodies. @item Some features introduced by Ada 95 obviate the need for library support. For --- 30012,30022 ---- this in Ada 95 or Ada 2005: @enumerate @item ! If the source code for the libraries (specs and bodies) are available, then the libraries can be migrated in the same way as the application. @item ! If the source code for the specs but not the bodies are available, then you can reimplement the bodies. @item Some features introduced by Ada 95 obviate the need for library support. For *************** ways to deal with this situation: *** 29145,29151 **** @itemize @bullet @item ! Modify the program to eliminate the circularities, e.g. by moving elaboration-time code into explicitly-invoked procedures @item Constrain the elaboration order by including explicit @code{Elaborate_Body} or --- 30045,30051 ---- @itemize @bullet @item ! Modify the program to eliminate the circularities, e.g.@: by moving elaboration-time code into explicitly-invoked procedures @item Constrain the elaboration order by including explicit @code{Elaborate_Body} or *************** Overview and Comparison on HP Platforms} *** 29374,29381 **** For GNAT running on other than VMS systems, all the HP Ada 83 pragmas and attributes are recognized, although only a subset of them can sensibly ! be implemented. The description of pragmas in the ! @cite{GNAT Reference Manual} indicates whether or not they are applicable to non-VMS systems. @end ifclear --- 30274,30281 ---- For GNAT running on other than VMS systems, all the HP Ada 83 pragmas and attributes are recognized, although only a subset of them can sensibly ! be implemented. The description of pragmas in @ref{Implementation ! Defined Pragmas,,, gnat_rm, GNAT Reference Manual} indicates whether or not they are applicable to non-VMS systems. @end ifclear *************** Using general access types ensures maxim *** 29752,29758 **** All code that comes as part of GNAT is 64-bit clean, but the restrictions given in @ref{Restrictions on use of 64 bit objects}, still apply. Look at the package ! specifications to see in which contexts objects allocated in 64-bit address space are acceptable. @node Technical details --- 30652,30658 ---- All code that comes as part of GNAT is 64-bit clean, but the restrictions given in @ref{Restrictions on use of 64 bit objects}, still apply. Look at the package ! specs to see in which contexts objects allocated in 64-bit address space are acceptable. @node Technical details *************** uninstall or integrate different GNAT pr *** 29891,29897 **** @noindent Make sure the system on which GNAT is installed is accessible from the ! current machine, i.e. the install location is shared over the network. Shared resources are accessed on Windows by means of UNC paths, which have the format @code{\\server\sharename\path} --- 30791,30797 ---- @noindent Make sure the system on which GNAT is installed is accessible from the ! current machine, i.e., the install location is shared over the network. Shared resources are accessed on Windows by means of UNC paths, which have the format @code{\\server\sharename\path} *************** $ gnatmake winprog -largs -mwindows *** 29931,29944 **** @noindent It is possible to control where temporary files gets created by setting ! the TMP environment variable. The file will be created: @itemize ! @item Under the directory pointed to by the TMP environment variable if this directory exists. ! @item Under c:\temp, if the TMP environment variable is not set (or not ! pointing to a directory) and if this directory exists. @item Under the current working directory otherwise. @end itemize --- 30831,30844 ---- @noindent It is possible to control where temporary files gets created by setting ! the @env{TMP} environment variable. The file will be created: @itemize ! @item Under the directory pointed to by the @env{TMP} environment variable if this directory exists. ! @item Under @file{c:\temp}, if the @env{TMP} environment variable is not ! set (or not pointing to a directory) and if this directory exists. @item Under the current working directory otherwise. @end itemize *************** interoperability strategy. *** 29962,29968 **** If you use @command{gcc} to compile the non-Ada part of your application, there are no Windows-specific restrictions that affect the overall interoperability with your Ada code. If you plan to use ! Microsoft tools (e.g. Microsoft Visual C/C++), you should be aware of the following limitations: @itemize @bullet --- 30862,30868 ---- If you use @command{gcc} to compile the non-Ada part of your application, there are no Windows-specific restrictions that affect the overall interoperability with your Ada code. If you plan to use ! Microsoft tools (e.g.@: Microsoft Visual C/C++), you should be aware of the following limitations: @itemize @bullet *************** of the above limitations, you have two c *** 29987,29993 **** @enumerate @item ! Encapsulate your non Ada code in a DLL to be linked with your Ada application. In this case, use the Microsoft or whatever environment to build the DLL and use GNAT to build your executable (@pxref{Using DLLs with GNAT}). --- 30887,30893 ---- @enumerate @item ! Encapsulate your non-Ada code in a DLL to be linked with your Ada application. In this case, use the Microsoft or whatever environment to build the DLL and use GNAT to build your executable (@pxref{Using DLLs with GNAT}). *************** on the stack by the caller from right to *** 30090,30101 **** caller) is in charge of cleaning the stack on routine exit. In addition, the name of a routine with @code{Stdcall} calling convention is mangled by adding a leading underscore (as for the @code{C} calling convention) and a ! trailing @code{@@}@code{@i{nn}}, where @i{nn} is the overall size (in bytes) of the parameters passed to the routine. The name to use on the Ada side when importing a C routine with a @code{Stdcall} calling convention is the name of the C routine. The leading ! underscore and trailing @code{@@}@code{@i{nn}} are added automatically by the compiler. For instance the Win32 function: @smallexample --- 30990,31001 ---- caller) is in charge of cleaning the stack on routine exit. In addition, the name of a routine with @code{Stdcall} calling convention is mangled by adding a leading underscore (as for the @code{C} calling convention) and a ! trailing @code{@@}@code{@var{nn}}, where @var{nn} is the overall size (in bytes) of the parameters passed to the routine. The name to use on the Ada side when importing a C routine with a @code{Stdcall} calling convention is the name of the C routine. The leading ! underscore and trailing @code{@@}@code{@var{nn}} are added automatically by the compiler. For instance the Win32 function: @smallexample *************** pragma Import (Stdcall, Get_Val, Link_Na *** 30140,30150 **** @noindent then the imported routine is @code{retrieve_val}, that is, there is no decoration at all. No leading underscore and no Stdcall suffix ! @code{@@}@code{@i{nn}}. @noindent This is especially important as in some special cases a DLL's entry ! point name lacks a trailing @code{@@}@code{@i{nn}} while the exported name generated for a call has it. @noindent --- 31040,31050 ---- @noindent then the imported routine is @code{retrieve_val}, that is, there is no decoration at all. No leading underscore and no Stdcall suffix ! @code{@@}@code{@var{nn}}. @noindent This is especially important as in some special cases a DLL's entry ! point name lacks a trailing @code{@@}@code{@var{nn}} while the exported name generated for a call has it. @noindent *************** pragma Import (Stdcall, My_Var); *** 30168,30174 **** @noindent Note that to ease building cross-platform bindings this convention ! will be handled as a @code{C} calling convention on non Windows platforms. @node Win32 Calling Convention @subsection @code{Win32} Calling Convention --- 31068,31074 ---- @noindent Note that to ease building cross-platform bindings this convention ! will be handled as a @code{C} calling convention on non-Windows platforms. @node Win32 Calling Convention @subsection @code{Win32} Calling Convention *************** suffix) has the following structure: *** 30406,30426 **** @smallexample @group @cartouche ! [LIBRARY @i{name}] ! [DESCRIPTION @i{string}] EXPORTS ! @i{symbol1} ! @i{symbol2} ! ... @end cartouche @end group @end smallexample @table @code ! @item LIBRARY @i{name} This section, which is optional, gives the name of the DLL. ! @item DESCRIPTION @i{string} This section, which is optional, gives a description string that will be embedded in the import library. --- 31306,31326 ---- @smallexample @group @cartouche ! @r{[}LIBRARY @var{name}@r{]} ! @r{[}DESCRIPTION @var{string}@r{]} EXPORTS ! @var{symbol1} ! @var{symbol2} ! @dots{} @end cartouche @end group @end smallexample @table @code ! @item LIBRARY @var{name} This section, which is optional, gives the name of the DLL. ! @item DESCRIPTION @var{string} This section, which is optional, gives a description string that will be embedded in the import library. *************** EXPORTS *** 30441,30447 **** @end table @noindent ! Note that you must specify the correct suffix (@code{@@}@code{@i{nn}}) (@pxref{Windows Calling Conventions}) for a Stdcall calling convention function in the exported symbols list. --- 31341,31347 ---- @end table @noindent ! Note that you must specify the correct suffix (@code{@@}@code{@var{nn}}) (@pxref{Windows Calling Conventions}) for a Stdcall calling convention function in the exported symbols list. *************** $ dll2def API.dll > API.def *** 30469,30480 **** @code{dll2def} is a very simple tool: it takes as input a DLL and prints to standard output the list of entry points in the DLL. Note that if some routines in the DLL have the @code{Stdcall} convention ! (@pxref{Windows Calling Conventions}) with stripped @code{@@}@i{nn} suffix then you'll have to edit @file{api.def} to add it, and specify ! @code{-k} to @code{gnatdll} when creating the import library. @noindent ! Here are some hints to find the right @code{@@}@i{nn} suffix. @enumerate @item --- 31369,31380 ---- @code{dll2def} is a very simple tool: it takes as input a DLL and prints to standard output the list of entry points in the DLL. Note that if some routines in the DLL have the @code{Stdcall} convention ! (@pxref{Windows Calling Conventions}) with stripped @code{@@}@var{nn} suffix then you'll have to edit @file{api.def} to add it, and specify ! @option{-k} to @command{gnatdll} when creating the import library. @noindent ! Here are some hints to find the right @code{@@}@var{nn} suffix. @enumerate @item *************** $ gnatdll -e API.def -d API.dll *** 30505,30512 **** name of the DLL containing the services listed in the definition file @file{API.dll}. The name of the static import library generated is computed from the name of the definition file as follows: if the ! definition file name is @i{xyz}@code{.def}, the import library name will ! be @code{lib}@i{xyz}@code{.a}. Note that in the previous example option @option{-e} could have been removed because the name of the definition file (before the ``@code{.def}'' suffix) is the same as the name of the DLL (@pxref{Using gnatdll} for more information about @code{gnatdll}). --- 31405,31412 ---- name of the DLL containing the services listed in the definition file @file{API.dll}. The name of the static import library generated is computed from the name of the definition file as follows: if the ! definition file name is @var{xyz}@code{.def}, the import library name will ! be @code{lib}@var{xyz}@code{.a}. Note that in the previous example option @option{-e} could have been removed because the name of the definition file (before the ``@code{.def}'' suffix) is the same as the name of the DLL (@pxref{Using gnatdll} for more information about @code{gnatdll}). *************** into the DLL. This is done by using the *** 30568,30578 **** @item building the DLL ! To build the DLL you must use @command{gcc}'s @code{-shared} option. It is quite simple to use this method: @smallexample ! $ gcc -shared -o api.dll obj1.o obj2.o ... @end smallexample It is important to note that in this case all symbols found in the --- 31468,31478 ---- @item building the DLL ! To build the DLL you must use @command{gcc}'s @option{-shared} option. It is quite simple to use this method: @smallexample ! $ gcc -shared -o api.dll obj1.o obj2.o @dots{} @end smallexample It is important to note that in this case all symbols found in the *************** the set of symbols to export by passing *** 30581,30587 **** file, @pxref{The Definition File}. For example: @smallexample ! $ gcc -shared -o api.dll api.def obj1.o obj2.o ... @end smallexample If you use a definition file you must export the elaboration procedures --- 31481,31487 ---- file, @pxref{The Definition File}. For example: @smallexample ! $ gcc -shared -o api.dll api.def obj1.o obj2.o @dots{} @end smallexample If you use a definition file you must export the elaboration procedures *************** $ attrib +R apilib\*.ali *** 30605,30611 **** At this point it is possible to use the DLL by directly linking against it. Note that you must use the GNAT shared runtime when using ! GNAT shared libraries. This is achieved by using @code{-shared} binder's option. @smallexample --- 31505,31511 ---- At this point it is possible to use the DLL by directly linking against it. Note that you must use the GNAT shared runtime when using ! GNAT shared libraries. This is achieved by using @option{-shared} binder's option. @smallexample *************** one in the main program. *** 30706,30712 **** It is therefore not possible to exchange GNAT run-time objects between the Ada DLL and the main Ada program. Example of GNAT run-time objects are file ! handles (e.g. @code{Text_IO.File_Type}), tasks types, protected objects types, etc. It is completely safe to exchange plain elementary, array or record types, --- 31606,31612 ---- It is therefore not possible to exchange GNAT run-time objects between the Ada DLL and the main Ada program. Example of GNAT run-time objects are file ! handles (e.g.@: @code{Text_IO.File_Type}), tasks types, protected objects types, etc. It is completely safe to exchange plain elementary, array or record types, *************** package body API is *** 30812,30818 **** return Fact; end Factorial; ! ... -- The remainder of this package body is unchanged. end API; @end cartouche --- 31712,31718 ---- return Fact; end Factorial; ! @dots{} -- The remainder of this package body is unchanged. end API; @end cartouche *************** during the DLL build process by the @cod *** 30875,30881 **** @noindent To use the services exported by the Ada DLL from another programming ! language (e.g. C), you have to translate the specs of the exported Ada entities in that language. For instance in the case of @code{API.dll}, the corresponding C header file could look like: --- 31775,31781 ---- @noindent To use the services exported by the Ada DLL from another programming ! language (e.g.@: C), you have to translate the specs of the exported Ada entities in that language. For instance in the case of @code{API.dll}, the corresponding C header file could look like: *************** example consider a DLL comprising the fo *** 30903,30909 **** @cartouche package API is Count : Integer := 0; ! ... -- Remainder of the package omitted. end API; @end cartouche --- 31803,31809 ---- @cartouche package API is Count : Integer := 0; ! @dots{} -- Remainder of the package omitted. end API; @end cartouche *************** static import library for the DLL and th *** 30983,31005 **** @smallexample @cartouche ! $ gnatdll [@var{switches}] @var{list-of-files} [-largs @var{opts}] @end cartouche @end smallexample @noindent ! where @i{list-of-files} is a list of ALI and object files. The object file list must be the exact list of objects corresponding to the non-Ada sources whose services are to be included in the DLL. The ALI file list must be the exact list of ALI files for the corresponding Ada sources ! whose services are to be included in the DLL. If @i{list-of-files} is missing, only the static import library is generated. @noindent You may specify any of the following switches to @code{gnatdll}: @table @code ! @item -a[@var{address}] @cindex @option{-a} (@code{gnatdll}) Build a non-relocatable DLL at @var{address}. If @var{address} is not specified the default address @var{0x11000000} will be used. By default, --- 31883,31905 ---- @smallexample @cartouche ! $ gnatdll @ovar{switches} @var{list-of-files} @r{[}-largs @var{opts}@r{]} @end cartouche @end smallexample @noindent ! where @var{list-of-files} is a list of ALI and object files. The object file list must be the exact list of objects corresponding to the non-Ada sources whose services are to be included in the DLL. The ALI file list must be the exact list of ALI files for the corresponding Ada sources ! whose services are to be included in the DLL. If @var{list-of-files} is missing, only the static import library is generated. @noindent You may specify any of the following switches to @code{gnatdll}: @table @code ! @item -a@ovar{address} @cindex @option{-a} (@code{gnatdll}) Build a non-relocatable DLL at @var{address}. If @var{address} is not specified the default address @var{0x11000000} will be used. By default, *************** advise the reader to build relocatable D *** 31009,31015 **** @item -b @var{address} @cindex @option{-b} (@code{gnatdll}) Set the relocatable DLL base address. By default the address is ! @var{0x11000000}. @item -bargs @var{opts} @cindex @option{-bargs} (@code{gnatdll}) --- 31909,31915 ---- @item -b @var{address} @cindex @option{-b} (@code{gnatdll}) Set the relocatable DLL base address. By default the address is ! @code{0x11000000}. @item -bargs @var{opts} @cindex @option{-bargs} (@code{gnatdll}) *************** object files needed to build the DLL. *** 31051,31060 **** @item -k @cindex @option{-k} (@code{gnatdll}) ! Removes the @code{@@}@i{nn} suffix from the import library's exported names, but keeps them for the link names. You must specify this option if you want to use a @code{Stdcall} function in a DLL for which ! the @code{@@}@i{nn} suffix has been removed. This is the case for most of the Windows NT DLL for example. This option has no effect when @option{-n} option is specified. --- 31951,31960 ---- @item -k @cindex @option{-k} (@code{gnatdll}) ! Removes the @code{@@}@var{nn} suffix from the import library's exported names, but keeps them for the link names. You must specify this option if you want to use a @code{Stdcall} function in a DLL for which ! the @code{@@}@var{nn} suffix has been removed. This is the case for most of the Windows NT DLL for example. This option has no effect when @option{-n} option is specified. *************** common @code{dlltool} switches. The form *** 31202,31208 **** is @smallexample ! $ dlltool [@var{switches}] @end smallexample @noindent --- 32102,32108 ---- is @smallexample ! $ dlltool @ovar{switches} @end smallexample @noindent *************** DLL in the static import library generat *** 31226,31232 **** @item -k @cindex @option{-k} (@command{dlltool}) ! Kill @code{@@}@i{nn} from exported names (@pxref{Windows Calling Conventions} for a discussion about @code{Stdcall}-style symbols. --- 32126,32132 ---- @item -k @cindex @option{-k} (@command{dlltool}) ! Kill @code{@@}@var{nn} from exported names (@pxref{Windows Calling Conventions} for a discussion about @code{Stdcall}-style symbols. *************** Prints the @code{dlltool} switches with *** 31239,31245 **** Generate an export file @var{exportfile}. The export file contains the export table (list of symbols in the DLL) and is used to create the DLL. ! @item --output-lib @i{libfile} @cindex @option{--output-lib} (@command{dlltool}) Generate a static import library @var{libfile}. --- 32139,32145 ---- Generate an export file @var{exportfile}. The export file contains the export table (list of symbols in the DLL) and is used to create the DLL. ! @item --output-lib @var{libfile} @cindex @option{--output-lib} (@command{dlltool}) Generate a static import library @var{libfile}. *************** Generate a static import library @var{li *** 31247,31255 **** @cindex @option{-v} (@command{dlltool}) Verbose mode. ! @item --as @i{assembler-name} @cindex @option{--as} (@command{dlltool}) ! Use @i{assembler-name} as the assembler. The default is @code{as}. @end table @node GNAT and Windows Resources --- 32147,32155 ---- @cindex @option{-v} (@command{dlltool}) Verbose mode. ! @item --as @var{assembler-name} @cindex @option{--as} (@command{dlltool}) ! Use @var{assembler-name} as the assembler. The default is @code{as}. @end table @node GNAT and Windows Resources diff -Nrcpad gcc-4.3.3/gcc/ada/gnatbind.adb gcc-4.4.0/gcc/ada/gnatbind.adb *** gcc-4.3.3/gcc/ada/gnatbind.adb Thu Dec 13 10:23:29 2007 --- gcc-4.4.0/gcc/ada/gnatbind.adb Tue Apr 8 06:51:54 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** procedure Gnatbind is *** 164,211 **** Additional_Restrictions_Listed : Boolean := False; -- Set True if we have listed header for restrictions ! begin ! -- Loop through restrictions ! for R in All_Restrictions loop ! if not No_Restriction_List (R) then ! -- We list a restriction if it is not violated, or if ! -- it is violated but the violation count is exactly known. ! if Cumulative_Restrictions.Violated (R) = False ! or else (R in All_Parameter_Restrictions ! and then ! Cumulative_Restrictions.Unknown (R) = False) ! then ! if not Additional_Restrictions_Listed then ! Write_Eol; ! Write_Line ! ("The following additional restrictions may be" & ! " applied to this partition:"); ! Additional_Restrictions_Listed := True; ! end if; ! Write_Str ("pragma Restrictions ("); ! declare ! S : constant String := Restriction_Id'Image (R); ! begin ! Name_Len := S'Length; ! Name_Buffer (1 .. Name_Len) := S; ! end; ! Set_Casing (Mixed_Case); ! Write_Str (Name_Buffer (1 .. Name_Len)); ! if R in All_Parameter_Restrictions then ! Write_Str (" => "); ! Write_Int (Int (Cumulative_Restrictions.Count (R))); end if; ! Write_Str (");"); Write_Eol; end if; end if; end loop; end List_Applicable_Restrictions; --- 164,259 ---- Additional_Restrictions_Listed : Boolean := False; -- Set True if we have listed header for restrictions ! function Restriction_Could_Be_Set (R : Restriction_Id) return Boolean; ! -- Returns True if the given restriction can be listed as an additional ! -- restriction that could be set. ! ------------------------------ ! -- Restriction_Could_Be_Set -- ! ------------------------------ ! function Restriction_Could_Be_Set (R : Restriction_Id) return Boolean is ! CR : Restrictions_Info renames Cumulative_Restrictions; ! begin ! case R is ! -- Boolean restriction ! when All_Boolean_Restrictions => ! -- The condition for listing a boolean restriction as an ! -- additional restriction that could be set is that it is ! -- not violated by any unit, and not already set. ! return CR.Violated (R) = False and then CR.Set (R) = False; ! ! -- Parameter restriction ! ! when All_Parameter_Restrictions => ! ! -- If the restriction is violated and the level of violation is ! -- unknown, the restriction can definitely not be listed. ! ! if CR.Violated (R) and then CR.Unknown (R) then ! return False; ! ! -- We can list the restriction if it is not set ! ! elsif not CR.Set (R) then ! return True; ! ! -- We can list the restriction if is set to a greater value ! -- than the maximum value known for the violation. ! ! else ! return CR.Value (R) > CR.Count (R); end if; ! -- No other values for R possible ! ! when others => ! raise Program_Error; ! ! end case; ! end Restriction_Could_Be_Set; ! ! -- Start of processing for List_Applicable_Restrictions ! ! begin ! -- Loop through restrictions ! ! for R in All_Restrictions loop ! if not No_Restriction_List (R) ! and then Restriction_Could_Be_Set (R) ! then ! if not Additional_Restrictions_Listed then Write_Eol; + Write_Line + ("The following additional restrictions may be" & + " applied to this partition:"); + Additional_Restrictions_Listed := True; + end if; + + Write_Str ("pragma Restrictions ("); + + declare + S : constant String := Restriction_Id'Image (R); + begin + Name_Len := S'Length; + Name_Buffer (1 .. Name_Len) := S; + end; + + Set_Casing (Mixed_Case); + Write_Str (Name_Buffer (1 .. Name_Len)); + + if R in All_Parameter_Restrictions then + Write_Str (" => "); + Write_Int (Int (Cumulative_Restrictions.Count (R))); end if; + + Write_Str (");"); + Write_Eol; end if; end loop; end List_Applicable_Restrictions; *************** procedure Gnatbind is *** 317,323 **** then null; ! -- Invalid -S switch, let Switch give error, set defalut of IN else Scan_Binder_Switches (Argv); --- 365,371 ---- then null; ! -- Invalid -S switch, let Switch give error, set default of IN else Scan_Binder_Switches (Argv); diff -Nrcpad gcc-4.3.3/gcc/ada/gnatbl.c gcc-4.4.0/gcc/ada/gnatbl.c *** gcc-4.3.3/gcc/ada/gnatbl.c Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/gnatbl.c Thu Jan 1 00:00:00 1970 *************** *** 1,387 **** - /**************************************************************************** - * * - * GNAT COMPILER TOOLS * - * * - * G N A T B L * - * * - * C Implementation File * - * * - * Copyright (C) 1992-2007, 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- * - * ware Foundation; either version 3, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License distributed with GNAT; see file COPYING3. If not, go to * - * http://www.gnu.org/licenses for a complete copy of the license. * - * * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - #ifdef VMS - #define _POSIX_EXIT 1 - #endif - - #include "config.h" - #include "system.h" - - #if defined (__EMX__) || defined (MSDOS) - #include - #endif - #include "adaint.h" - - /* These can be set by command line arguments */ - char *binder_path = 0; - char *linker_path = 0; - char *exec_file_name = 0; - char *ali_file_name = 0; - #define BIND_ARG_MAX 512 - char *bind_args[BIND_ARG_MAX]; - int bind_arg_index = -1; - #ifdef MSDOS - char *coff2exe_path = 0; - char *coff2exe_args[] = {(char *) 0, (char *) 0}; - char *del_command = 0; - #endif - int verbose = 0; - int o_present = 0; - int g_present = 0; - - int link_arg_max = -1; - char **link_args = (char **) 0; - int link_arg_index = -1; - - char *gcc_B_arg = 0; - - #ifndef DIR_SEPARATOR - #if defined (__EMX__) - #define DIR_SEPARATOR '\\' - #else - #define DIR_SEPARATOR '/' - #endif - #endif - - static int linkonly = 0; - - static void addarg (char *); - static void process_args (int *, char *[]); - - static void - addarg (char *str) - { - int i; - - if (++link_arg_index >= link_arg_max) - { - char **new_link_args - = (char **) xcalloc (link_arg_max + 1000, sizeof (char *)); - - for (i = 0; i <= link_arg_max; i++) - new_link_args[i] = link_args[i]; - - if (link_args) - free (link_args); - - link_arg_max += 1000; - link_args = new_link_args; - } - - link_args[link_arg_index] = str; - } - - static void - process_args (int *p_argc, char *argv[]) - { - int i, j; - - for (i = 1; i < *p_argc; i++) - { - /* -I is passed on to gnatbind */ - if (! strncmp( argv[i], "-I", 2)) - { - bind_arg_index += 1; - if (bind_arg_index >= BIND_ARG_MAX) - { - fprintf (stderr, "Too many arguments to gnatbind\n"); - exit (-1); - } - - bind_args[bind_arg_index] = argv[i]; - } - - /* -B is passed on to gcc */ - if (! strncmp (argv[i], "-B", 2)) - gcc_B_arg = argv[i]; - - /* -v turns on verbose option here and is passed on to gcc */ - - if (! strcmp (argv[i], "-v")) - verbose = 1; - - if (! strcmp (argv[i], "-o")) - { - o_present = 1; - exec_file_name = argv[i + 1]; - } - - if (! strcmp (argv[i], "-g")) - g_present = 1; - - if (! strcmp (argv[i], "-gnatbind")) - { - /* Explicit naming of binder. Grab the value then remove the - two arguments from the argument list. */ - if ( i + 1 >= *p_argc ) - { - fprintf (stderr, "Missing argument for -gnatbind\n"); - exit (1); - } - - binder_path = __gnat_locate_exec (argv[i + 1], (char *) "."); - if (!binder_path) - { - fprintf (stderr, "Could not locate binder: %s\n", argv[i + 1]); - exit (1); - } - - for (j = i + 2; j < *p_argc; j++) - argv[j - 2] = argv[j]; - - (*p_argc) -= 2; - i--; - } - - else if (! strcmp (argv[i], "-linkonly")) - { - /* Don't call the binder. Set the flag and then remove the - argument from the argument list. */ - linkonly = 1; - for (j = i + 1; j < *p_argc; j++) - argv[j - 1] = argv[j]; - - *p_argc -= 1; - i--; - } - - else if (! strcmp (argv[i], "-gnatlink")) - { - /* Explicit naming of binder. Grab the value then remove the - two arguments from the argument list. */ - if (i + 1 >= *p_argc) - { - fprintf (stderr, "Missing argument for -gnatlink\n"); - exit (1); - } - - linker_path = __gnat_locate_exec (argv[i + 1], (char *) "."); - if (!linker_path) - { - fprintf (stderr, "Could not locate linker: %s\n", argv[i + 1]); - exit (1); - } - - for (j = i + 2; j < *p_argc; j++) - argv[j - 2] = argv[j]; - *p_argc -= 2; - i--; - } - } - } - extern int main (int, char **); - - int - main (int argc, char **argv) - { - int i, j; - int done_an_ali = 0; - int retcode; - #ifdef VMS - /* Warning: getenv only retrieves the first directory in VAXC$PATH */ - char *pathval = - xstrdup (__gnat_to_canonical_dir_spec (getenv ("VAXC$PATH"), 0)); - #else - char *pathval = getenv ("PATH"); - #endif - char *spawn_args[5]; - int spawn_index = 0; - - #if defined (__EMX__) || defined(MSDOS) - char *tmppathval = malloc (strlen (pathval) + 3); - strcpy (tmppathval, ".;"); - pathval = strcat (tmppathval, pathval); - #endif - - process_args (&argc , argv); - - if (argc == 1) - { - fprintf - (stdout, - "Usage: %s 'name'.ali\n", argv[0]); - fprintf - (stdout, - " [-o exec_name] -- by default it is 'name'\n"); - fprintf - (stdout, - " [-v] -- verbose mode\n"); - fprintf - (stdout, - " [-linkonly] -- doesn't call binder\n"); - fprintf - (stdout, - " [-gnatbind name] -- full name for gnatbind\n"); - fprintf - (stdout, - " [-gnatlink name] -- full name for linker (gcc)\n"); - fprintf - (stdout, - " [list of objects] -- non Ada binaries\n"); - fprintf - (stdout, - " [linker options] -- other options for linker\n"); - exit (1); - } - - if (!binder_path && !linkonly) - binder_path = __gnat_locate_exec ((char *) "gnatbind", pathval); - - if (!binder_path && !linkonly) - { - fprintf (stderr, "Couldn't locate gnatbind\n"); - exit (1); - } - - if (!linker_path) - linker_path = __gnat_locate_exec ((char *) "gnatlink", pathval); - if (!linker_path) - { - fprintf (stderr, "Couldn't locate gnatlink\n"); - exit (1); - } - - #ifdef MSDOS - coff2exe_path = __gnat_locate_regular_file ("coff2exe.bat", pathval); - if (!coff2exe_path) - { - fprintf (stderr, "Couldn't locate %s\n", "coff2exe.bat"); - exit (1); - } - else - coff2exe_args[0] = coff2exe_path; - #endif - - addarg (linker_path); - - for (i = 1; i < argc; i++) - { - int arg_len = strlen (argv[i]); - - if (arg_len > 4 && ! strcmp (&argv[i][arg_len - 4], ".ali")) - { - if (done_an_ali) - { - fprintf (stderr, - "Sorry - cannot handle more than one ALI file\n"); - exit (1); - } - - done_an_ali = 1; - - if (__gnat_is_regular_file (argv[i])) - { - ali_file_name = argv[i]; - if (!linkonly) - { - /* Run gnatbind */ - spawn_index = 0; - spawn_args[spawn_index++] = binder_path; - spawn_args[spawn_index++] = ali_file_name; - for (j = 0 ; j <= bind_arg_index ; j++ ) - spawn_args[spawn_index++] = bind_args[j]; - spawn_args[spawn_index] = 0; - - if (verbose) - { - int i; - for (i = 0; i < 2; i++) - printf ("%s ", spawn_args[i]); - - putchar ('\n'); - } - - retcode = __gnat_portable_spawn (spawn_args); - if (retcode != 0) - exit (retcode); - } - } - else - addarg (argv[i]); - } - #ifdef MSDOS - else if (!strcmp (argv[i], "-o")) - { - addarg (argv[i]); - if (i < argc) - i++; - - { - char *ptr = strstr (argv[i], ".exe"); - - arg_len = strlen (argv[i]); - coff2exe_args[1] = malloc (arg_len + 1); - strcpy (coff2exe_args[1], argv[i]); - if (ptr != NULL && strlen (ptr) == 4) - coff2exe_args[1][arg_len-4] = 0; - - addarg (coff2exe_args[1]); - } - } - #endif - else - addarg (argv[i]); - } - - if (! done_an_ali) - { - fprintf (stderr, "No \".ali\" file specified\n"); - exit (1); - } - - addarg (ali_file_name); - addarg (NULL); - - if (verbose) - { - int i; - - for (i = 0; i < link_arg_index; i++) - printf ("%s ", link_args[i]); - - putchar ('\n'); - } - - retcode = __gnat_portable_spawn (link_args); - if (retcode != 0) - exit (retcode); - - #ifdef MSDOS - retcode = __gnat_portable_spawn (coff2exe_args); - if (retcode != 0) - exit (retcode); - - if (!g_present) - { - del_command = malloc (strlen (coff2exe_args[1]) + 5); - sprintf (del_command, "del %s", coff2exe_args[1]); - retcode = system (del_command); - } - #endif - - exit(0); - } --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/gnatchop.adb gcc-4.4.0/gcc/ada/gnatchop.adb *** gcc-4.3.3/gcc/ada/gnatchop.adb Thu Dec 13 10:23:29 2007 --- gcc-4.4.0/gcc/ada/gnatchop.adb Fri Aug 1 07:38:36 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2008, 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- -- *************** procedure Gnatchop is *** 63,71 **** -- Arguments used in Gnat_Cmd call EOF : constant Character := Character'Val (26); ! -- Special character to signal end of file. Not required in input ! -- files, but properly treated if present. Not generated in output ! -- files except as a result of copying input file. -------------------- -- File arguments -- --- 63,71 ---- -- Arguments used in Gnat_Cmd call EOF : constant Character := Character'Val (26); ! -- Special character to signal end of file. Not required in input files, ! -- but properly treated if present. Not generated in output files except ! -- as a result of copying input file. -------------------- -- File arguments -- *************** procedure Gnatchop is *** 152,159 **** -- Index of unit in sorted unit list Bufferg : String_Access; ! -- Pointer to buffer containing configuration pragmas to be ! -- prepended. Null if no pragmas to be prepended. end record; -- The following table stores the unit offset information --- 152,159 ---- -- Index of unit in sorted unit list Bufferg : String_Access; ! -- Pointer to buffer containing configuration pragmas to be prepended. ! -- Null if no pragmas to be prepended. end record; -- The following table stores the unit offset information *************** procedure Gnatchop is *** 280,286 **** function Report_Duplicate_Units return Boolean; -- Output messages about duplicate units in the input files in Unit.Table ! -- Returns True if any duplicates found, Fals if no duplicates found. function Scan_Arguments return Boolean; -- Scan command line options and set global variables accordingly. --- 280,286 ---- function Report_Duplicate_Units return Boolean; -- Output messages about duplicate units in the input files in Unit.Table ! -- Returns True if any duplicates found, False if no duplicates found. function Scan_Arguments return Boolean; -- Scan command line options and set global variables accordingly. *************** procedure Gnatchop is *** 425,431 **** Info : Unit_Info renames Unit.Table (U); FD : File_Descriptor; Name : aliased constant String := ! File.Table (Input).Name.all & ASCII.Nul; Length : File_Offset; Buffer : String_Access; Result : String_Access; --- 425,431 ---- Info : Unit_Info renames Unit.Table (U); FD : File_Descriptor; Name : aliased constant String := ! File.Table (Input).Name.all & ASCII.NUL; Length : File_Offset; Buffer : String_Access; Result : String_Access; *************** procedure Gnatchop is *** 524,536 **** --- 524,539 ---- (Program_Name : String; Look_For_Prefix : Boolean := True) return String_Access is + Gnatchop_Str : constant String := "gnatchop"; Current_Command : constant String := Normalize_Pathname (Command_Name); End_Of_Prefix : Natural; Start_Of_Prefix : Positive; + Start_Of_Suffix : Positive; Result : String_Access; begin Start_Of_Prefix := Current_Command'First; + Start_Of_Suffix := Current_Command'Last + 1; End_Of_Prefix := Start_Of_Prefix - 1; if Look_For_Prefix then *************** procedure Gnatchop is *** 549,566 **** -- Find End_Of_Prefix ! for J in reverse Start_Of_Prefix .. Current_Command'Last loop ! if Current_Command (J) = '-' then ! End_Of_Prefix := J; exit; end if; end loop; end if; declare Command : constant String := ! Current_Command (Start_Of_Prefix .. End_Of_Prefix) & ! Program_Name; begin Result := Locate_Exec_On_Path (Command); --- 552,579 ---- -- Find End_Of_Prefix ! for J in Start_Of_Prefix .. ! Current_Command'Last - Gnatchop_Str'Length + 1 ! loop ! if Current_Command (J .. J + Gnatchop_Str'Length - 1) = ! Gnatchop_Str ! then ! End_Of_Prefix := J - 1; exit; end if; end loop; end if; + if End_Of_Prefix > Current_Command'First then + Start_Of_Suffix := End_Of_Prefix + Gnatchop_Str'Length + 1; + end if; + declare Command : constant String := ! Current_Command (Start_Of_Prefix .. End_Of_Prefix) ! & Program_Name ! & Current_Command (Start_Of_Suffix .. ! Current_Command'Last); begin Result := Locate_Exec_On_Path (Command); *************** procedure Gnatchop is *** 761,767 **** -- Note that the unit name can be an operator name in quotes. -- This is of course illegal, but both GNAT and gnatchop handle ! -- the case so that this error does not intefere with chopping. -- The SR ir present indicates that a source reference pragma -- was processed as part of this unit (and that therefore no --- 774,780 ---- -- Note that the unit name can be an operator name in quotes. -- This is of course illegal, but both GNAT and gnatchop handle ! -- the case so that this error does not interfere with chopping. -- The SR ir present indicates that a source reference pragma -- was processed as part of this unit (and that therefore no *************** procedure Gnatchop is *** 1005,1013 **** Contents := new String (1 .. Read_Ptr); Contents.all := Buffer (1 .. Read_Ptr); ! -- Things aren't simple on VMS due to the plethora of file types ! -- and organizations. It seems clear that there shouldn't be more ! -- bytes read than are contained in the file though. if Hostparm.OpenVMS then Success := Read_Ptr <= Length + 1; --- 1018,1026 ---- Contents := new String (1 .. Read_Ptr); Contents.all := Buffer (1 .. Read_Ptr); ! -- Things aren't simple on VMS due to the plethora of file types and ! -- organizations. It seems clear that there shouldn't be more bytes ! -- read than are contained in the file though. if Hostparm.OpenVMS then Success := Read_Ptr <= Length + 1; *************** procedure Gnatchop is *** 1236,1242 **** F : constant String := File.Table (File_Num).Name.all; begin - if Is_Directory (F) then Error_Msg (F & " is a directory, cannot be chopped"); return False; --- 1249,1254 ---- *************** procedure Gnatchop is *** 1264,1270 **** end if; return False; - end Scan_Arguments; ---------------- --- 1276,1281 ---- *************** procedure Gnatchop is *** 1413,1419 **** function Write_Chopped_Files (Input : File_Num) return Boolean is Name : aliased constant String := ! File.Table (Input).Name.all & ASCII.Nul; FD : File_Descriptor; Buffer : String_Access; Success : Boolean; --- 1424,1430 ---- function Write_Chopped_Files (Input : File_Num) return Boolean is Name : aliased constant String := ! File.Table (Input).Name.all & ASCII.NUL; FD : File_Descriptor; Buffer : String_Access; Success : Boolean; *************** procedure Gnatchop is *** 1623,1633 **** -- Returns in OS_Name the proper name for the OS when used with the -- returned Encoding value. For example on Windows this will return the -- UTF-8 encoded name into OS_Name and set Encoding to encoding=utf8 ! -- (form parameter Stream_IO). -- Name is the filename and W_Name the same filename in Unicode 16 bits ! -- (this corresponds to Win32 Unicode ISO/IEC 10646). N_Length and ! -- E_Length are the length returned in OS_Name and Encoding ! -- respectively. Info : Unit_Info renames Unit.Table (Num); Name : aliased constant String := Info.File_Name.all & ASCII.NUL; --- 1634,1644 ---- -- Returns in OS_Name the proper name for the OS when used with the -- returned Encoding value. For example on Windows this will return the -- UTF-8 encoded name into OS_Name and set Encoding to encoding=utf8 ! -- (the form parameter for Stream_IO). ! -- -- Name is the filename and W_Name the same filename in Unicode 16 bits ! -- (this corresponds to Win32 Unicode ISO/IEC 10646). N_Length/E_Length ! -- are the length returned in OS_Name/Encoding respectively. Info : Unit_Info renames Unit.Table (Num); Name : aliased constant String := Info.File_Name.all & ASCII.NUL; *************** procedure Gnatchop is *** 1660,1668 **** declare E_Name : constant String := OS_Name (1 .. O_Length); ! C_Name : aliased constant String := E_Name & ASCII.Nul; OS_Encoding : constant String := Encoding (1 .. E_Length); File : Stream_IO.File_Type; begin begin if not Overwrite_Files and then Exists (E_Name) then --- 1671,1680 ---- declare E_Name : constant String := OS_Name (1 .. O_Length); ! C_Name : aliased constant String := E_Name & ASCII.NUL; OS_Encoding : constant String := Encoding (1 .. E_Length); File : Stream_IO.File_Type; + begin begin if not Overwrite_Files and then Exists (E_Name) then *************** procedure Gnatchop is *** 1672,1677 **** --- 1684,1690 ---- (File, Stream_IO.Out_File, E_Name, OS_Encoding); Success := True; end if; + exception when Stream_IO.Name_Error | Stream_IO.Use_Error => Error_Msg ("cannot create " & Info.File_Name.all); *************** procedure Gnatchop is *** 1692,1698 **** if Success and then Info.Bufferg /= null then Write_Source_Reference_Pragma (Info, 1, File, EOL, Success); - String'Write (Stream_IO.Stream (File), Info.Bufferg.all); end if; --- 1705,1710 ---- *************** procedure Gnatchop is *** 1729,1738 **** -- Start of processing for gnatchop begin ! -- Add the directory where gnatchop is invoked in front of the ! -- path, if gnatchop is invoked with directory information. ! -- Only do this if the platform is not VMS, where the notion of path ! -- does not really exist. if not Hostparm.OpenVMS then declare --- 1741,1749 ---- -- Start of processing for gnatchop begin ! -- Add the directory where gnatchop is invoked in front of the path, if ! -- gnatchop is invoked with directory information. Only do this if the ! -- platform is not VMS, where the notion of path does not really exist. if not Hostparm.OpenVMS then declare *************** begin *** 1745,1756 **** Absolute_Dir : constant String := Normalize_Pathname (Command (Command'First .. Index)); - PATH : constant String := ! Absolute_Dir & ! Path_Separator & ! Getenv ("PATH").all; ! begin Setenv ("PATH", PATH); end; --- 1756,1765 ---- Absolute_Dir : constant String := Normalize_Pathname (Command (Command'First .. Index)); PATH : constant String := ! Absolute_Dir ! & Path_Separator ! & Getenv ("PATH").all; begin Setenv ("PATH", PATH); end; *************** begin *** 1800,1825 **** Sort_Units; ! -- Check if any duplicate files would be created. If so, emit ! -- a warning if Overwrite_Files is true, otherwise generate an error. if Report_Duplicate_Units and then not Overwrite_Files then goto No_Files_Written; end if; ! -- Check if any files exist, if so do not write anything ! -- Because all files have been parsed and checked already, ! -- there won't be any duplicates if not Overwrite_Files and then Files_Exist then goto No_Files_Written; end if; ! -- After this point, all source files are read in succession ! -- and chopped into their destination files. ! -- As the Source_File_Name pragmas are handled as logical file 0, ! -- write it first. for F in 1 .. File.Last loop if not Write_Chopped_Files (F) then --- 1809,1832 ---- Sort_Units; ! -- Check if any duplicate files would be created. If so, emit a warning if ! -- Overwrite_Files is true, otherwise generate an error. if Report_Duplicate_Units and then not Overwrite_Files then goto No_Files_Written; end if; ! -- Check if any files exist, if so do not write anything Because all files ! -- have been parsed and checked already, there won't be any duplicates if not Overwrite_Files and then Files_Exist then goto No_Files_Written; end if; ! -- After this point, all source files are read in succession and chopped ! -- into their destination files. ! -- Source_File_Name pragmas are handled as logical file 0 so write it first for F in 1 .. File.Last loop if not Write_Chopped_Files (F) then diff -Nrcpad gcc-4.3.3/gcc/ada/gnatcmd.adb gcc-4.4.0/gcc/ada/gnatcmd.adb *** gcc-4.3.3/gcc/ada/gnatcmd.adb Thu Dec 13 10:27:32 2007 --- gcc-4.4.0/gcc/ada/gnatcmd.adb Thu May 29 08:56:01 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2008, 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- -- *************** with Prj.Util; use Prj.Util; *** 41,46 **** --- 41,47 ---- with Sinput.P; with Snames; use Snames; with Table; + with Targparm; with Tempdir; with Types; use Types; with Hostparm; use Hostparm; *************** procedure GNATCmd is *** 66,72 **** Old_Project_File_Used : Boolean := False; -- This flag indicates a switch -p (for gnatxref and gnatfind) for ! -- an old fashioned project file. -p cannot be used in conjonction -- with -P. Max_Files_On_The_Command_Line : constant := 30; -- Arbitrary --- 67,73 ---- Old_Project_File_Used : Boolean := False; -- This flag indicates a switch -p (for gnatxref and gnatfind) for ! -- an old fashioned project file. -p cannot be used in conjunction -- with -P. Max_Files_On_The_Command_Line : constant := 30; -- Arbitrary *************** procedure GNATCmd is *** 118,136 **** -- tool. We allocate objects because we cannot declare aliased objects -- as we are in a procedure, not a library level package. ! Naming_String : constant String_Access := new String'("naming"); ! Binder_String : constant String_Access := new String'("binder"); ! Compiler_String : constant String_Access := new String'("compiler"); ! Check_String : constant String_Access := new String'("check"); ! Eliminate_String : constant String_Access := new String'("eliminate"); ! Finder_String : constant String_Access := new String'("finder"); ! Linker_String : constant String_Access := new String'("linker"); ! Gnatls_String : constant String_Access := new String'("gnatls"); ! Pretty_String : constant String_Access := new String'("pretty_printer"); ! Stack_String : constant String_Access := new String'("stack"); ! Gnatstub_String : constant String_Access := new String'("gnatstub"); ! Metric_String : constant String_Access := new String'("metrics"); ! Xref_String : constant String_Access := new String'("cross_reference"); Packages_To_Check_By_Binder : constant String_List_Access := new String_List'((Naming_String, Binder_String)); --- 119,140 ---- -- tool. We allocate objects because we cannot declare aliased objects -- as we are in a procedure, not a library level package. ! subtype SA is String_Access; ! ! Naming_String : constant SA := new String'("naming"); ! Binder_String : constant SA := new String'("binder"); ! Compiler_String : constant SA := new String'("compiler"); ! Check_String : constant SA := new String'("check"); ! Synchronize_String : constant SA := new String'("synchronize"); ! Eliminate_String : constant SA := new String'("eliminate"); ! Finder_String : constant SA := new String'("finder"); ! Linker_String : constant SA := new String'("linker"); ! Gnatls_String : constant SA := new String'("gnatls"); ! Pretty_String : constant SA := new String'("pretty_printer"); ! Stack_String : constant SA := new String'("stack"); ! Gnatstub_String : constant SA := new String'("gnatstub"); ! Metric_String : constant SA := new String'("metrics"); ! Xref_String : constant SA := new String'("cross_reference"); Packages_To_Check_By_Binder : constant String_List_Access := new String_List'((Naming_String, Binder_String)); *************** procedure GNATCmd is *** 138,143 **** --- 142,150 ---- Packages_To_Check_By_Check : constant String_List_Access := new String_List'((Naming_String, Check_String, Compiler_String)); + Packages_To_Check_By_Sync : constant String_List_Access := + new String_List'((Naming_String, Synchronize_String, Compiler_String)); + Packages_To_Check_By_Eliminate : constant String_List_Access := new String_List'((Naming_String, Eliminate_String, Compiler_String)); *************** procedure GNATCmd is *** 227,233 **** -- METRIC). procedure Delete_Temp_Config_Files; ! -- Delete all temporary config files procedure Get_Closure; -- Get the sources in the closure of the ASIS_Main and add them to the --- 234,241 ---- -- METRIC). procedure Delete_Temp_Config_Files; ! -- Delete all temporary config files. The caller is responsible for ! -- ensuring that Keep_Temporary_Files is False. procedure Get_Closure; -- Get the sources in the closure of the ASIS_Main and add them to the *************** procedure GNATCmd is *** 320,326 **** declare Current_Last : constant Integer := Last_Switches.Last; begin ! -- Gnatstack needs to add the the .ci file for the binder -- generated files corresponding to all of the library projects -- and main units belonging to the application. --- 328,334 ---- declare Current_Last : constant Integer := Last_Switches.Last; begin ! -- Gnatstack needs to add the .ci file for the binder -- generated files corresponding to all of the library projects -- and main units belonging to the application. *************** procedure GNATCmd is *** 341,349 **** while Main /= Nil_String loop File := new String' ! (Get_Name_String (Data.Object_Directory) & ! Directory_Separator & ! B_Start.all & MLib.Fil.Ext_To (Get_Name_String (Project_Tree.String_Elements.Table --- 349,357 ---- while Main /= Nil_String loop File := new String' ! (Get_Name_String (Data.Object_Directory.Name) & ! Directory_Separator & ! B_Start.all & MLib.Fil.Ext_To (Get_Name_String (Project_Tree.String_Elements.Table *************** procedure GNATCmd is *** 367,376 **** File := new String' ! (Get_Name_String (Data.Object_Directory) & ! Directory_Separator & ! B_Start.all & ! Get_Name_String (Data.Library_Name) & ".ci"); if Is_Regular_File (File.all) then --- 375,384 ---- File := new String' ! (Get_Name_String (Data.Object_Directory.Name) & ! Directory_Separator & ! B_Start.all & ! Get_Name_String (Data.Library_Name) & ".ci"); if Is_Regular_File (File.all) then *************** procedure GNATCmd is *** 395,401 **** if Unit_Data.File_Names (Body_Part).Name /= No_File and then ! Unit_Data.File_Names (Body_Part).Path /= Slash then -- There is a body, check if it is for this project --- 403,409 ---- if Unit_Data.File_Names (Body_Part).Name /= No_File and then ! Unit_Data.File_Names (Body_Part).Path.Name /= Slash then -- There is a body, check if it is for this project *************** procedure GNATCmd is *** 407,413 **** if Unit_Data.File_Names (Specification).Name = No_File or else ! Unit_Data.File_Names (Specification).Path = Slash then -- We have a body with no spec: we need to check if -- this is a subunit, because gnatls will complain --- 415,422 ---- if Unit_Data.File_Names (Specification).Name = No_File or else ! Unit_Data.File_Names ! (Specification).Path.Name = Slash then -- We have a body with no spec: we need to check if -- this is a subunit, because gnatls will complain *************** procedure GNATCmd is *** 420,426 **** Src_Ind := Sinput.P.Load_Project_File (Get_Name_String (Unit_Data.File_Names ! (Body_Part).Path)); Subunit := Sinput.P.Source_File_Is_Subunit --- 429,435 ---- Src_Ind := Sinput.P.Load_Project_File (Get_Name_String (Unit_Data.File_Names ! (Body_Part).Path.Name)); Subunit := Sinput.P.Source_File_Is_Subunit *************** procedure GNATCmd is *** 441,447 **** elsif Unit_Data.File_Names (Specification).Name /= No_File and then ! Unit_Data.File_Names (Specification).Path /= Slash then -- We have a spec with no body; check if it is for this -- project. --- 450,456 ---- elsif Unit_Data.File_Names (Specification).Name /= No_File and then ! Unit_Data.File_Names (Specification).Path.Name /= Slash then -- We have a spec with no body; check if it is for this -- project. *************** procedure GNATCmd is *** 467,473 **** if Unit_Data.File_Names (Body_Part).Name /= No_File and then ! Unit_Data.File_Names (Body_Part).Path /= Slash then -- There is a body. Check if .ci files for this project -- must be added. --- 476,482 ---- if Unit_Data.File_Names (Body_Part).Name /= No_File and then ! Unit_Data.File_Names (Body_Part).Path.Name /= Slash then -- There is a body. Check if .ci files for this project -- must be added. *************** procedure GNATCmd is *** 481,487 **** if Unit_Data.File_Names (Specification).Name = No_File or else ! Unit_Data.File_Names (Specification).Path = Slash then -- We have a body with no spec: we need to check -- if this is a subunit, because .ci files are not --- 490,497 ---- if Unit_Data.File_Names (Specification).Name = No_File or else ! Unit_Data.File_Names ! (Specification).Path.Name = Slash then -- We have a body with no spec: we need to check -- if this is a subunit, because .ci files are not *************** procedure GNATCmd is *** 493,499 **** begin Src_Ind := Sinput.P.Load_Project_File (Get_Name_String ! (Unit_Data.File_Names (Body_Part).Path)); Subunit := Sinput.P.Source_File_Is_Subunit (Src_Ind); --- 503,510 ---- begin Src_Ind := Sinput.P.Load_Project_File (Get_Name_String ! (Unit_Data.File_Names ! (Body_Part).Path.Name)); Subunit := Sinput.P.Source_File_Is_Subunit (Src_Ind); *************** procedure GNATCmd is *** 508,514 **** (Project_Tree.Projects.Table (Unit_Data.File_Names (Body_Part).Project). ! Object_Directory) & Directory_Separator & MLib.Fil.Ext_To (Get_Name_String --- 519,525 ---- (Project_Tree.Projects.Table (Unit_Data.File_Names (Body_Part).Project). ! Object_Directory.Name) & Directory_Separator & MLib.Fil.Ext_To (Get_Name_String *************** procedure GNATCmd is *** 521,527 **** elsif Unit_Data.File_Names (Specification).Name /= No_File and then ! Unit_Data.File_Names (Specification).Path /= Slash then -- We have a spec with no body. Check if it is for this -- project. --- 532,538 ---- elsif Unit_Data.File_Names (Specification).Name /= No_File and then ! Unit_Data.File_Names (Specification).Path.Name /= Slash then -- We have a spec with no body. Check if it is for this -- project. *************** procedure GNATCmd is *** 538,544 **** (Project_Tree.Projects.Table (Unit_Data.File_Names (Specification).Project). ! Object_Directory) & Dir_Separator & MLib.Fil.Ext_To (Get_Name_String --- 549,555 ---- (Project_Tree.Projects.Table (Unit_Data.File_Names (Specification).Project). ! Object_Directory.Name) & Dir_Separator & MLib.Fil.Ext_To (Get_Name_String *************** procedure GNATCmd is *** 549,569 **** end if; else ! -- For gnatcheck, gnatpp and gnatmetric, put all sources ! -- of the project, or of all projects if -U was specified. for Kind in Spec_Or_Body loop if Check_Project (Unit_Data.File_Names (Kind).Project, Project) and then Unit_Data.File_Names (Kind).Name /= No_File ! and then Unit_Data.File_Names (Kind).Path /= Slash then Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String' (Get_Name_String (Unit_Data.File_Names ! (Kind).Display_Path)); end if; end loop; end if; --- 560,581 ---- end if; else ! -- For gnatcheck, gnatsync, gnatpp and gnatmetric, put all ! -- sources of the project, or of all projects if -U was ! -- specified. for Kind in Spec_Or_Body loop if Check_Project (Unit_Data.File_Names (Kind).Project, Project) and then Unit_Data.File_Names (Kind).Name /= No_File ! and then Unit_Data.File_Names (Kind).Path.Name /= Slash then Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String' (Get_Name_String (Unit_Data.File_Names ! (Kind).Path.Display_Name)); end if; end loop; end if; *************** procedure GNATCmd is *** 679,685 **** end loop; Get_Name_String (Project_Tree.Projects.Table ! (Project).Exec_Directory); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; --- 691,697 ---- end loop; Get_Name_String (Project_Tree.Projects.Table ! (Project).Exec_Directory.Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; *************** procedure GNATCmd is *** 714,751 **** pragma Warnings (Off, Success); begin ! if not Keep_Temporary_Files then ! if Project /= No_Project then ! for Prj in Project_Table.First .. ! Project_Table.Last (Project_Tree.Projects) ! loop ! if ! Project_Tree.Projects.Table (Prj).Config_File_Temp ! then ! if Verbose_Mode then ! Output.Write_Str ("Deleting temp configuration file """); ! Output.Write_Str ! (Get_Name_String ! (Project_Tree.Projects.Table ! (Prj).Config_File_Name)); ! Output.Write_Line (""""); ! end if; ! Delete_File ! (Name => Get_Name_String (Project_Tree.Projects.Table ! (Prj).Config_File_Name), ! Success => Success); end if; - end loop; - end if; ! -- If a temporary text file that contains a list of files for a tool ! -- has been created, delete this temporary file. ! if Temp_File_Name /= null then ! Delete_File (Temp_File_Name.all, Success); ! end if; end if; end Delete_Temp_Config_Files; --- 726,765 ---- pragma Warnings (Off, Success); begin ! -- This should only be called if Keep_Temporary_Files is False ! pragma Assert (not Keep_Temporary_Files); ! ! if Project /= No_Project then ! for Prj in Project_Table.First .. ! Project_Table.Last (Project_Tree.Projects) ! loop ! if ! Project_Tree.Projects.Table (Prj).Config_File_Temp ! then ! if Verbose_Mode then ! Output.Write_Str ("Deleting temp configuration file """); ! Output.Write_Str ! (Get_Name_String (Project_Tree.Projects.Table ! (Prj).Config_File_Name)); ! Output.Write_Line (""""); end if; ! Delete_File ! (Name => ! Get_Name_String ! (Project_Tree.Projects.Table (Prj).Config_File_Name), ! Success => Success); ! end if; ! end loop; ! end if; ! -- If a temporary text file that contains a list of files for a tool ! -- has been created, delete this temporary file. ! ! if Temp_File_Name /= null then ! Delete_File (Temp_File_Name.all, Success); end if; end Delete_Temp_Config_Files; *************** procedure GNATCmd is *** 763,769 **** 6 => new String'("-bargs"), 7 => new String'("-R"), 8 => new String'("-Z")); ! -- Arguments of the invocation of gnatmake to get the list of FD : File_Descriptor; -- File descriptor for the temp file that will get the output of the --- 777,784 ---- 6 => new String'("-bargs"), 7 => new String'("-R"), 8 => new String'("-Z")); ! -- Arguments for the invocation of gnatmake which are added to the ! -- Last_Arguments list by this procedure. FD : File_Descriptor; -- File descriptor for the temp file that will get the output of the *************** procedure GNATCmd is *** 772,778 **** Name : Path_Name_Type; -- Path of the file FD ! GN_Name : constant String := Program_Name ("gnatmake").all; -- Name for gnatmake GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name); --- 787,793 ---- Name : Path_Name_Type; -- Path of the file FD ! GN_Name : constant String := Program_Name ("gnatmake", "gnat").all; -- Name for gnatmake GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name); *************** procedure GNATCmd is *** 786,791 **** --- 801,808 ---- File : Ada.Text_IO.File_Type; Line : String (1 .. 250); Last : Natural; + -- Used to read file if there is an error, it is good enough to display + -- just 250 characters if the first line of the file is very long. Udata : Unit_Data; Path : Path_Name_Type; *************** procedure GNATCmd is *** 839,845 **** raise Error_Exit; else ! -- Get each file name in the file, find its path and add it the the -- list of arguments. while not End_Of_File (File) loop --- 856,862 ---- raise Error_Exit; else ! -- Get each file name in the file, find its path and add it the -- list of arguments. while not End_Of_File (File) loop *************** procedure GNATCmd is *** 856,862 **** Get_Name_String (Udata.File_Names (Specification).Name) = Line (1 .. Last) then ! Path := Udata.File_Names (Specification).Path; exit; elsif Udata.File_Names (Body_Part).Name /= No_File --- 873,879 ---- Get_Name_String (Udata.File_Names (Specification).Name) = Line (1 .. Last) then ! Path := Udata.File_Names (Specification).Path.Name; exit; elsif Udata.File_Names (Body_Part).Name /= No_File *************** procedure GNATCmd is *** 864,870 **** Get_Name_String (Udata.File_Names (Body_Part).Name) = Line (1 .. Last) then ! Path := Udata.File_Names (Body_Part).Path; exit; end if; end loop; --- 881,887 ---- Get_Name_String (Udata.File_Names (Body_Part).Name) = Line (1 .. Last) then ! Path := Udata.File_Names (Body_Part).Path.Name; exit; end if; end loop; *************** procedure GNATCmd is *** 883,889 **** if not Keep_Temporary_Files then Delete (File); - else Close (File); end if; --- 900,905 ---- *************** procedure GNATCmd is *** 1090,1096 **** Dir : constant String := Get_Name_String (Project_Tree.Projects.Table ! (Prj).Object_Directory); begin if Is_Regular_File (Dir & --- 1106,1112 ---- Dir : constant String := Get_Name_String (Project_Tree.Projects.Table ! (Prj).Object_Directory.Name); begin if Is_Regular_File (Dir & *************** procedure GNATCmd is *** 1171,1177 **** new String'("-o"); Get_Name_String (Project_Tree.Projects.Table ! (Project).Exec_Directory); Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'(Name_Buffer (1 .. Name_Len) & --- 1187,1193 ---- new String'("-o"); Get_Name_String (Project_Tree.Projects.Table ! (Project).Exec_Directory.Name); Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'(Name_Buffer (1 .. Name_Len) & *************** procedure GNATCmd is *** 1209,1215 **** new String'("-L" & Get_Name_String (Project_Tree.Projects.Table ! (Project).Library_Dir)); -- Add the -l switch --- 1225,1231 ---- new String'("-L" & Get_Name_String (Project_Tree.Projects.Table ! (Project).Library_Dir.Name)); -- Add the -l switch *************** procedure GNATCmd is *** 1231,1237 **** Library_Paths.Table (Library_Paths.Last) := new String'(Get_Name_String (Project_Tree.Projects.Table ! (Project).Library_Dir)); end if; end if; end Set_Library_For; --- 1247,1253 ---- Library_Paths.Table (Library_Paths.Last) := new String'(Get_Name_String (Project_Tree.Projects.Table ! (Project).Library_Dir.Name)); end if; end if; end Set_Library_For; *************** procedure GNATCmd is *** 1315,1323 **** for C in Command_List'Range loop if not Command_List (C).VMS_Only then ! Put ("gnat " & To_Lower (Command_List (C).Cname.all)); Set_Col (25); ! Put (Command_List (C).Unixcmd.all); declare Sws : Argument_List_Access renames Command_List (C).Unixsws; --- 1331,1352 ---- for C in Command_List'Range loop if not Command_List (C).VMS_Only then ! if Targparm.AAMP_On_Target then ! Put ("gnaampcmd "); ! else ! Put ("gnat "); ! end if; ! ! Put (To_Lower (Command_List (C).Cname.all)); Set_Col (25); ! ! -- Never call gnatstack with a prefix ! ! if C = Stack then ! Put (Command_List (C).Unixcmd.all); ! else ! Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all); ! end if; declare Sws : Argument_List_Access renames Command_List (C).Unixsws; *************** begin *** 1368,1373 **** --- 1397,1412 ---- Set_Mode (Ada_Only); + -- Add the default search directories, to be able to find system.ads in the + -- subsequent call to Targparm.Get_Target_Parameters. + + Add_Default_Search_Dirs; + + -- Get target parameters so that AAMP_On_Target will be set, for testing in + -- Osint.Program_Name to handle the mapping of GNAAMP tool names. + + Targparm.Get_Target_Parameters; + -- Add the directory where the GNAT driver is invoked in front of the path, -- if the GNAT driver is invoked with directory information. Do not do this -- for VMS, where the notion of path does not really exist. *************** begin *** 1531,1548 **** end if; declare ! Program : constant String := ! Program_Name (Command_List (The_Command).Unixcmd.all).all; ! Exec_Path : String_Access; begin -- Locate the executable for the command ! Exec_Path := Locate_Exec_On_Path (Program); if Exec_Path = null then ! Put_Line (Standard_Error, "could not locate " & Program); raise Error_Exit; end if; --- 1570,1595 ---- end if; declare ! Program : String_Access; Exec_Path : String_Access; begin + if The_Command = Stack then + -- Never call gnatstack with a prefix + + Program := new String'(Command_List (The_Command).Unixcmd.all); + + else + Program := + Program_Name (Command_List (The_Command).Unixcmd.all, "gnat"); + end if; + -- Locate the executable for the command ! Exec_Path := Locate_Exec_On_Path (Program.all); if Exec_Path = null then ! Put_Line (Standard_Error, "could not locate " & Program.all); raise Error_Exit; end if; *************** begin *** 1561,1566 **** --- 1608,1614 ---- if The_Command = Bind or else The_Command = Check + or else The_Command = Sync or else The_Command = Elim or else The_Command = Find or else The_Command = Link *************** begin *** 1578,1583 **** --- 1626,1634 ---- when Check => Tool_Package_Name := Name_Check; Packages_To_Check := Packages_To_Check_By_Check; + when Sync => + Tool_Package_Name := Name_Synchronize; + Packages_To_Check := Packages_To_Check_By_Sync; when Elim => Tool_Package_Name := Name_Eliminate; Packages_To_Check := Packages_To_Check_By_Eliminate; *************** begin *** 1655,1663 **** end if; end if; -- -aPdir Add dir to the project search path ! if Argv'Length > 3 and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP" then Add_Search_Project_Directory --- 1706,1728 ---- end if; end if; + -- --subdirs=... Specify Subdirs + + if Argv'Length > Subdirs_Option'Length and then + Argv + (Argv'First .. Argv'First + Subdirs_Option'Length - 1) = + Subdirs_Option + then + Subdirs := + new String' + (Argv + (Argv'First + Subdirs_Option'Length .. Argv'Last)); + + Remove_Switch (Arg_Num); + -- -aPdir Add dir to the project search path ! elsif Argv'Length > 3 and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP" then Add_Search_Project_Directory *************** begin *** 1665,1670 **** --- 1730,1742 ---- Remove_Switch (Arg_Num); + -- -eL Follow links for files + + elsif Argv.all = "-eL" then + Follow_Links_For_Files := True; + + Remove_Switch (Arg_Num); + -- -vPx Specify verbosity while parsing project files elsif Argv'Length = 4 *************** begin *** 1761,1766 **** --- 1833,1839 ---- elsif (The_Command = Check or else + The_Command = Sync or else The_Command = Pretty or else The_Command = Metric or else The_Command = Stack or else *************** begin *** 1776,1781 **** --- 1849,1855 ---- end if; elsif ((The_Command = Check and then Argv (Argv'First) /= '+') + or else The_Command = Sync or else The_Command = Metric or else The_Command = Pretty) and then Project_File /= null *************** begin *** 1922,1928 **** Change_Dir (Get_Name_String (Project_Tree.Projects.Table ! (Project).Object_Directory)); end if; -- Set up the env vars for project path files --- 1996,2002 ---- Change_Dir (Get_Name_String (Project_Tree.Projects.Table ! (Project).Object_Directory.Name)); end if; -- Set up the env vars for project path files *************** begin *** 1938,1943 **** --- 2012,2018 ---- or else The_Command = Stub or else The_Command = Elim or else The_Command = Check + or else The_Command = Sync then -- If there are switches in package Compiler, put them in the -- Carg_Switches table. *************** begin *** 2134,2140 **** end loop; Get_Name_String ! (Project_Tree.Projects.Table (Project).Directory); declare Project_Dir : constant String := Name_Buffer (1 .. Name_Len); --- 2209,2215 ---- end loop; Get_Name_String ! (Project_Tree.Projects.Table (Project).Directory.Name); declare Project_Dir : constant String := Name_Buffer (1 .. Name_Len); *************** begin *** 2228,2240 **** -- For gnatmetric, the generated files should be put in the object -- directory. This must be the first switch, because it may be ! -- overriden by a switch in package Metrics in the project file or -- by a command line option. Note that we don't add the -d= switch -- if there is no object directory available. if The_Command = Metric and then ! Project_Tree.Projects.Table (Project).Object_Directory /= No_Path then First_Switches.Increment_Last; First_Switches.Table (2 .. First_Switches.Last) := --- 2303,2316 ---- -- For gnatmetric, the generated files should be put in the object -- directory. This must be the first switch, because it may be ! -- overridden by a switch in package Metrics in the project file or -- by a command line option. Note that we don't add the -d= switch -- if there is no object directory available. if The_Command = Metric and then ! Project_Tree.Projects.Table (Project).Object_Directory /= ! No_Path_Information then First_Switches.Increment_Last; First_Switches.Table (2 .. First_Switches.Last) := *************** begin *** 2243,2249 **** new String'("-d=" & Get_Name_String (Project_Tree.Projects.Table ! (Project).Object_Directory)); end if; -- For gnat check, -rules and the following switches need to be the --- 2319,2325 ---- new String'("-d=" & Get_Name_String (Project_Tree.Projects.Table ! (Project).Object_Directory.Name)); end if; -- For gnat check, -rules and the following switches need to be the *************** begin *** 2295,2302 **** end; end if; ! -- For gnat check, metric or pretty with -U + a main, get the list ! -- of sources from the closure and add them to the arguments. if ASIS_Main /= null then Get_Closure; --- 2371,2378 ---- end; end if; ! -- For gnat check, sync, metric or pretty with -U + a main, get the ! -- list of sources from the closure and add them to the arguments. if ASIS_Main /= null then Get_Closure; *************** begin *** 2315,2325 **** (Project, Project_Tree, Including_Libraries => False); end if; ! -- For gnat check, gnat pretty, gnat metric, gnat list, and gnat ! -- stack, if no file has been put on the command line, call tool ! -- with all the sources of the main project. elsif The_Command = Check or else The_Command = Pretty or else The_Command = Metric or else The_Command = List or else --- 2391,2402 ---- (Project, Project_Tree, Including_Libraries => False); end if; ! -- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list, ! -- and gnat stack, if no file has been put on the command line, call ! -- tool with all the sources of the main project. elsif The_Command = Check or else + The_Command = Sync or else The_Command = Pretty or else The_Command = Metric or else The_Command = List or else diff -Nrcpad gcc-4.3.3/gcc/ada/gnatcmd.ads gcc-4.4.0/gcc/ada/gnatcmd.ads *** gcc-4.3.3/gcc/ada/gnatcmd.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/gnatcmd.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2008, 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- -- *************** *** 29,35 **** -- style switches that are accepted directly. -- The program is typically called GNAT when it is installed and ! -- the two possibile styles of use are: -- To call gcc: --- 29,35 ---- -- style switches that are accepted directly. -- The program is typically called GNAT when it is installed and ! -- the two possible styles of use are: -- To call gcc: diff -Nrcpad gcc-4.3.3/gcc/ada/gnatdll.adb gcc-4.4.0/gcc/ada/gnatdll.adb *** gcc-4.3.3/gcc/ada/gnatdll.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/gnatdll.adb Tue Apr 8 06:44:39 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2008, 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- -- *************** procedure Gnatdll is *** 51,64 **** -- Parse the command line arguments passed to gnatdll procedure Check_Context; ! -- Check the context before runing any commands to build the library Syntax_Error : exception; -- Raised when a syntax error is detected, in this case a usage info will -- be displayed. Context_Error : exception; ! -- Raised when some files (specifed on the command line) are missing to -- build the DLL. Help : Boolean := False; --- 51,64 ---- -- Parse the command line arguments passed to gnatdll procedure Check_Context; ! -- Check the context before running any commands to build the library Syntax_Error : exception; -- Raised when a syntax error is detected, in this case a usage info will -- be displayed. Context_Error : exception; ! -- Raised when some files (specified on the command line) are missing to -- build the DLL. Help : Boolean := False; *************** procedure Gnatdll is *** 89,95 **** -- List of objects to put inside the library Ali_Files : Argument_List_Access := MDLL.Null_Argument_List_Access; ! -- For each Ada file specified, we keep arecord of the corresponding -- ALI file. This list of SLI files is used to build the binder program. Options : Argument_List_Access := MDLL.Null_Argument_List_Access; --- 89,95 ---- -- List of objects to put inside the library Ali_Files : Argument_List_Access := MDLL.Null_Argument_List_Access; ! -- For each Ada file specified, we keep a record of the corresponding -- ALI file. This list of SLI files is used to build the binder program. Options : Argument_List_Access := MDLL.Null_Argument_List_Access; *************** procedure Gnatdll is *** 200,206 **** -- A list of -bargs options (B is next entry to be used) Build_Import : Boolean := True; ! -- Set to Fals if option -n if specified (no-import) -------------- -- Add_File -- --- 200,206 ---- -- A list of -bargs options (B is next entry to be used) Build_Import : Boolean := True; ! -- Set to False if option -n if specified (no-import) -------------- -- Add_File -- *************** procedure Gnatdll is *** 270,276 **** loop case Getopt ("g h v q k a? b: d: e: l: n m I:") is ! when ASCII.Nul => exit; when 'h' => --- 270,276 ---- loop case Getopt ("g h v q k a? b: d: e: l: n m I:") is ! when ASCII.NUL => exit; when 'h' => *************** procedure Gnatdll is *** 381,387 **** loop case Getopt ("*") is ! when ASCII.Nul => exit; when others => --- 381,387 ---- loop case Getopt ("*") is ! when ASCII.NUL => exit; when others => *************** procedure Gnatdll is *** 397,403 **** loop case Getopt ("*") is ! when ASCII.Nul => exit; when others => --- 397,403 ---- loop case Getopt ("*") is ! when ASCII.NUL => exit; when others => diff -Nrcpad gcc-4.3.3/gcc/ada/gnatfind.adb gcc-4.4.0/gcc/ada/gnatfind.adb *** gcc-4.3.3/gcc/ada/gnatfind.adb Thu Dec 13 10:23:29 2007 --- gcc-4.4.0/gcc/ada/gnatfind.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2008, 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- -- *************** procedure Gnatfind is *** 131,137 **** when 'n' => if GNAT.Command_Line.Full_Switch = "nostdinc" then Opt.No_Stdinc := True; ! elsif GNAT.Command_Line.Full_Switch = "nostlib" then Opt.No_Stdlib := True; end if; --- 131,137 ---- when 'n' => if GNAT.Command_Line.Full_Switch = "nostdinc" then Opt.No_Stdinc := True; ! elsif GNAT.Command_Line.Full_Switch = "nostdlib" then Opt.No_Stdlib := True; end if; *************** begin *** 314,321 **** end if; -- Special case to speed things up: if the user has a command line of the ! -- form 'gnatfind entity:file', ie has specified a file and only wants the ! -- bodies and specs, then we can restrict the search to the .ali file -- associated with 'file'. if Has_File_In_Entity --- 314,321 ---- end if; -- Special case to speed things up: if the user has a command line of the ! -- form 'gnatfind entity:file', i.e. has specified a file and only wants ! -- the bodies and specs, then we can restrict the search to the .ali file -- associated with 'file'. if Has_File_In_Entity diff -Nrcpad gcc-4.3.3/gcc/ada/gnathtml.pl gcc-4.4.0/gcc/ada/gnathtml.pl *** gcc-4.3.3/gcc/ada/gnathtml.pl Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/gnathtml.pl Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,1114 ---- + #! /usr/bin/env perl + + #----------------------------------------------------------------------------- + #- -- + #- GNAT COMPILER COMPONENTS -- + #- -- + #- G N A T H T M L -- + #- -- + #- Copyright (C) 1998-2009, 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- -- + #- ware Foundation; either version 3, or (at your option) any later ver- -- + #- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + #- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + #- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + #- for more details. You should have received a copy of the GNU General -- + #- Public License distributed with GNAT; see file COPYING3. If not see -- + #- . -- + #- -- + #- GNAT was originally developed by the GNAT team at New York University. -- + #- Extensive contributions were provided by Ada Core Technologies Inc. -- + #- -- + #----------------------------------------------------------------------------- + + ## This script converts an Ada file (and its dependency files) to Html. + ## Keywords, comments and strings are color-hilighted. If the cross-referencing + ## information provided by Gnat (when not using the -gnatx switch) is found, + ## the html files will also have some cross-referencing features, i.e. if you + ## click on a type, its declaration will be displayed. + ## + ## To find more about the switches provided by this script, please use the + ## following command : + ## perl gnathtml.pl -h + ## You may also change the first line of this script to indicates where Perl is + ## installed on your machine, so that you can just type + ## gnathtml.pl -h + ## + ## Unless you supply another directory with the -odir switch, the html files + ## will be saved saved in a html subdirectory + + use Cwd 'abs_path'; + use File::Basename; + + ### Print help if necessary + sub print_usage + { + print "Usage is:\n"; + print " $0 [switches] main_file[.adb] main_file2[.adb] ...\n"; + print " -83 : Use Ada83 keywords only (default is Ada95)\n"; + print " -cc color : Choose the color for comments\n"; + print " -d : Convert also the files which main_file depends on\n"; + print " -D : same as -d, also looks for files in the standard library\n"; + print " -f : Include cross-references for local entities too\n"; + print " -absolute : Display absolute filenames in the headers\n"; + print " -h : Print this help page\n"; + print " -lnb : Display line numbers every nb lines\n"; + print " -Idir : Specify library/object files search path\n"; + print " -odir : Name of the directory where the html files will be\n"; + print " saved. Default is 'html/'\n"; + print " -pfile : Use file as a project file (.adp file)\n"; + print " -sc color : Choose the color for symbol definitions\n"; + print " -Tfile : Read the name of the files from file rather than the\n"; + print " command line\n"; + print " -ext ext : Choose the generated file names extension (default\n"; + print " is htm)\n"; + print "This program attempts to generate an html file from an Ada file\n"; + exit; + } + + ### Parse the command line + local ($ada83_mode) = 0; + local ($prjfile) = ""; + local (@list_files) = (); + local ($line_numbers) = 0; + local ($dependencies) = 0; + local ($standard_library) = 0; + local ($output_dir) = "html"; + local ($xref_variable) = 0; + local (@search_dir) = ('.'); + local ($tab_size) = 8; + local ($comment_color) = "green"; + local ($symbol_color) = "red"; + local ($absolute) = 0; + local ($fileext) = "htm"; + + while ($_ = shift @ARGV) + { + /^-83$/ && do { $ada83_mode = 1; }; + /^-d$/ && do { $dependencies = 1; }; + /^-D$/ && do { $dependencies = 1; + $standard_library = 1; }; + /^-f$/ && do { $xref_variable = 1; }; + /^-absolute$/ && do {$absolute = 1; }; + /^-h$/ && do { &print_usage; }; + /^[^-]/ && do { $_ .= ".adb" if (! /\.ad[bs]$/); + push (@list_files, $_); }; + + if (/^-o\s*(.*)$/) + { + $output_dir = ($1 eq "") ? shift @ARGV : $1; + chop $output_dir if ($output_dir =~ /\/$/); + &print_usage if ($output_dir =~ /^-/ || $output_dir eq ""); + } + + if (/^-T\s*(.*)$/) + { + my ($source_file) = ($1 eq "") ? shift @ARGV : $1; + local (*SOURCE); + open (SOURCE, "$source_file") || die "file not found: $source_file"; + while () { + @files = split; + foreach (@files) { + $_ .= ".adb" if (! /\.ad[bs]$/); + push (@list_files, $_); + } + } + } + + if (/^-cc\s*(.*)$/) + { + $comment_color = ($1 eq "") ? shift @ARGV : $1; + &print_usage if ($comment_color =~ /^-/ || $comment_color eq ""); + } + + if (/^-sc\s*(.*)$/) + { + $symbol_color = ($1 eq "") ? shift @ARGV : $1; + &print_usage if ($symbol_color =~ /^-/ || $symbol_color eq ""); + } + + if (/^-I\s*(.*)$/) + { + push (@search_dir, ($1 eq "") ? scalar (shift @ARGV) : $1); + } + + if (/^-p\s*(.*)$/) + { + $prjfile = ($1 eq "") ? shift @ARGV : $1; + &print_usage if ($prjfile =~ /^-/ || $prjfile eq ""); + } + + if (/^-l\s*(.*)$/) + { + $line_numbers = ($1 eq "") ? shift @ARGV : $1; + &print_usage if ($line_numbers =~ /^-/ || $line_numbers eq ""); + } + + if (/^-ext\s*(.*)$/) + { + $fileext = ($1 eq "") ? shift @ARGV : $1; + &print_usage if ($fileext =~ /^-/ || $fileext eq ""); + } + } + + &print_usage if ($#list_files == -1); + local (@original_list) = @list_files; + + ## This regexp should match all the files from the standard library (and only them) + ## Note that at this stage the '.' in the file names has been replaced with __ + $standard_file_regexp="^([agis]-|ada__|gnat__|system__|interface__).*\$"; + + local (@src_dir) = (); + local (@obj_dir) = (); + + if ($standard_library) { + open (PIPE, "gnatls -v | "); + local ($mode) = ""; + while (defined ($_ = )) { + chop; + s/^\s+//; + $_ = './' if (//); + next if (/^$/); + + if (/Source Search Path:/) { + $mode = 's'; + } + elsif (/Object Search Path:/) { + $mode = 'o'; + } + elsif ($mode eq 's') { + push (@src_dir, $_); + } + elsif ($mode eq 'o') { + push (@obj_dir, $_); + } + } + close (PIPE); + } + else + { + push (@src_dir, "./"); + push (@obj_dir, "./"); + } + + foreach (@list_files) { + local ($dir) = $_; + $dir =~ s/\/([^\/]+)$//; + push (@src_dir, $dir. '/'); + push (@obj_dir, $dir. '/'); + } + + ### Defines and compiles the Ada key words : + local (@Ada_keywords) = ('abort', 'abs', 'accept', 'access', 'all', 'and', + 'array', 'at', 'begin', 'body', 'case', 'constant', + 'declare', 'delay', 'delta', 'digits', 'do', 'else', + 'elsif', 'end', 'entry', 'exception', 'exit', 'for', + 'function', 'generic', 'goto', 'if', 'in', 'is', + 'limited', 'loop', 'mod', 'new', 'not', 'null', 'of', + 'or', 'others', 'out', 'package', 'pragma', 'private', + 'procedure', 'raise', 'range', 'record', 'rem', + 'renames', 'return', 'reverse', 'select', 'separate', + 'subtype', 'task', 'terminate', 'then', 'type', + 'until', 'use', 'when', 'while', 'with', 'xor'); + local (@Ada95_keywords) = ('abstract', 'aliased', 'protected', 'requeue', + 'tagged'); + + local (%keywords) = (); + grep (++ $keywords{$_}, @Ada_keywords); + grep (++ $keywords{$_}, @Ada95_keywords) unless ($ada83_mode); + + ### Symbols declarations for the current file + ### format is (line_column => 1, ...) + local (%symbols); + + ### Symbols usage for the current file + ### format is ($adafile#$line_$column => $htmlfile#$linedecl_$columndecl, ...) + local (%symbols_used); + + ### the global index of all symbols + ### format is ($name => [[file, line, column], [file, line, column], ...]) + local (%global_index); + + ######### + ## This function create the header of every html file. + ## These header is returned as a string + ## Params: - Name of the Ada file associated with this html file + ######### + sub create_header + { + local ($adafile) = shift; + local ($string) = "$adafile + \n"; + + if ($adafile ne "") + { + $string .= "

File : $adafile " + . "

\n
";
+   }
+   return $string;
+ }
+ 
+ #########
+ ##  Protect a string (or character) from the Html parser
+ ##  Params: - the string to protect
+ ##  Out:    - the protected string
+ #########
+ sub protect_string
+ {
+     local ($string) = shift;
+     $string =~ s/&/&/g;
+     $string =~ s//>/g;
+     return $string;
+ }
+ 
+ #########
+ ##  This function creates the footer of the html file
+ ##  The footer is returned as a string
+ ##  Params :  - Name of the Ada file associated with this html file
+ #########
+ sub create_footer
+ {
+   local ($adafile) = shift;
+   local ($string) = "";
+   $string = "
" if ($adafile ne ""); + return $string . "\n"; + } + + ######### + ## This function creates the string to use for comment output + ## Params : - the comment itself + ######### + sub output_comment + { + local ($comment) = &protect_string (shift); + return "--$comment"; + } + + ######## + ## This function creates the string to use for symbols output + ## Params : - the symbol to output + ## - the current line + ## - the current column + ######## + sub output_symbol + { + local ($symbol) = &protect_string (shift); + local ($lineno) = shift; + local ($column) = shift; + return "$symbol"; + } + + ######## + ## This function creates the string to use for keyword output + ## Params : - the keyword to output + ######## + sub output_keyword + { + local ($keyw) = shift; + return "$keyw"; + } + + ######## + ## This function outputs a line number + ## Params : - the line number to generate + ######## + sub output_line_number + { + local ($no) = shift; + if ($no != -1) + { + return "" . sprintf ("%4d ", $no) . ""; + } + else + { + return " "; + } + } + + ######## + ## Converts a character into the corresponding Ada type + ## This is based on the ali format (see lib-xref.adb) in the GNAT sources + ## Note: 'f' or 'K' should be returned in case a link from the body to the + ## spec needs to be generated. + ## Params : - the character to convert + ######## + sub to_type + { + local ($char) = shift; + $char =~ tr/a-z/A-Z/; + + return 'array' if ($char eq 'A'); + return 'boolean' if ($char eq 'B'); + return 'class' if ($char eq 'C'); + return 'decimal' if ($char eq 'D'); + return 'enumeration' if ($char eq 'E'); + return 'floating point' if ($char eq 'F'); + return 'signed integer' if ($char eq 'I'); + # return 'generic package' if ($char eq 'K'); + return 'block' if ($char eq 'L'); + return 'modular integer' if ($char eq 'M'); + return 'enumeration literal' if ($char eq 'N'); + return 'ordinary fixed point' if ($char eq 'O'); + return 'access' if ($char eq 'P'); + return 'label' if ($char eq 'Q'); + return 'record' if ($char eq 'R'); + return 'string' if ($char eq 'S'); + return 'task' if ($char eq 'T'); + return 'f' if ($char eq 'U'); + return 'f' if ($char eq 'V'); + return 'exception' if ($char eq 'X'); + return 'entry' if ($char eq 'Y'); + return "$char"; + } + + ######## + ## Changes a file name to be http compatible + ######## + sub http_string + { + local ($str) = shift; + $str =~ s/\//__/g; + $str =~ s/\\/__/g; + $str =~ s/:/__/g; + $str =~ s/\./__/g; + return $str; + } + + ######## + ## Creates the complete file-name, with directory + ## use the variables read in the .prj file + ## Params : - file name + ## RETURNS : the relative path_name to the file + ######## + sub get_real_file_name + { + local ($filename) = shift; + local ($path) = $filename; + + foreach (@src_dir) + { + if ( -r "$_$filename") + { + $path = "$_$filename"; + last; + } + } + + $path =~ s/^\.\///; + return $path if (substr ($path, 0, 1) ne '/'); + + ## We want to return relative paths only, so that the name of the HTML files + ## can easily be generated + local ($pwd) = `pwd`; + chop ($pwd); + local (@pwd) = split (/\//, $pwd); + local (@path) = split (/\//, $path); + + while (@pwd) + { + if ($pwd [0] ne $path [0]) + { + return '../' x ($#pwd + 1) . join ("/", @path); + } + shift @pwd; + shift @path; + } + return join ('/', @path); + } + + ######## + ## Reads and parses .adp files + ## Params : - adp file name + ######## + sub parse_prj_file + { + local ($filename) = shift; + local (@src) = (); + local (@obj) = (); + + print "Parsing project file : $filename\n"; + + open (PRJ, $filename) || do { print " ... sorry, file not found\n"; + return; + }; + while () + { + chop; + s/\/$//; + push (@src, $1 . "/") if (/^src_dir=(.*)/); + push (@obj, $1 . "/") if (/^obj_dir=(.*)/); + } + unshift (@src_dir, @src); + unshift (@obj_dir, @obj); + close (PRJ); + } + + ######## + ## Finds a file in the search path + ## Params : - the name of the file + ## RETURNS : - the directory/file_name + ######## + sub find_file + { + local ($filename) = shift; + + foreach (@search_dir) { + if (-f "$_/$filename") { + return "$_/$filename"; + } + } + return $filename; + } + + ######## + ## Inserts a new reference in the list of references + ## Params: - Ref as it appears in the .ali file ($line$type$column) + ## - Current file for the reference + ## - Current offset to be added from the line (handling of + ## pragma Source_Reference) + ## - Current entity reference + ## Modifies: - %symbols_used + ######## + sub create_new_reference + { + local ($ref) = shift; + local ($lastfile) = shift; + local ($offset) = shift; + local ($currentref) = shift; + local ($refline, $type, $refcol); + + ## Do not generate references to the standard library files if we + ## do not generate the corresponding html files + return if (! $standard_library && $lastfile =~ /$standard_file_regexp/); + + ($refline, $type, $extern, $refcol) = /(\d+)(.)(<[^>]+>)?(\d+)/; + $refline += $offset; + + ## If we have a body, then we only generate the cross-reference from + ## the spec to the body if we have a subprogram (or a package) + + + if ($type eq "b") + # && ($symbols {$currentref} eq 'f' || $symbols {$currentref} eq 'K')) + { + local ($cref_file, $cref) = ($currentref =~ /([^\#]+).$fileext\#(.+)/); + + $symbols_used {"$cref_file#$cref"} = "$lastfile.$fileext#$refline\_$refcol"; + $symbols_used {"$lastfile#$refline\_$refcol"} = $currentref; + $symbols {"$lastfile.$fileext#$refline\_$refcol"} = "body"; + } + + ## Do not generate cross-references for "e" and "t", since these point to the + ## semicolon that terminates the block -- irrelevant for gnathtml + ## "p" is also removed, since it is used for primitive subprograms + ## "d" is also removed, since it is used for discriminants + ## "i" is removed since it is used for implicit references + ## "z" is used for generic formals + ## "k" is for references to parent package + ## "=", "<", ">", "^" is for subprogram parameters + + elsif ($type !~ /[eztpid=<>^k]/) + { + $symbols_used {"$lastfile#$refline\_$refcol"} = $currentref; + } + } + + ######## + ## Parses the ali file associated with the current Ada file + ## Params : - the complete ali file name + ######## + sub parse_ali + { + local ($filename) = shift; + local ($currentfile); + local ($currentref); + local ($lastfile); + + # A file | line type column reference + local ($reference) = "(?:(?:\\d+\\|)?\\d+.\\d+|\\w+)"; + + # The following variable is used to represent the possible xref information + # output by GNAT when -gnatdM is used. It includes renaming references, and + # references to the parent type, as well as references to the generic parent + + local ($typeref) = "(?:=$reference|<$reference>|\\{$reference\\}|\\($reference\\)|\\[$reference\\])?"; + + # The beginning of an entity declaration line in the ALI file + local ($decl_line) = "^(\\d+)(.)(\\d+)[ *]([\\w\\d.-]+|\"..?\")$typeref\\s+(\\S.*)?\$"; + + # Contains entries of the form [ filename source_reference_offset] + # Offset needs to be added to the lines read in the cross-references, and are + # used when the source comes from a gnatchop-ed file. See lib-write.ads, lines + # with ^D in the ALI file. + local (@reffiles) = (); + + open (ALI, &find_file ($filename)) || do { + print "no ", &find_file ($filename), " file...\n"; + return; + }; + local (@ali) = ; + close (ALI); + + undef %symbols; + undef %symbols_used; + + foreach (@ali) + { + ## The format of D lines is + ## D source-name time-stamp checksum [subunit-name] line:file-name + + if (/^D\s+([\w\d.-]+)\s+\S+ \S+(\s+\D[^: ]+)?( (\d+):(.*))?/) + { + # The offset will be added to each cross-reference line. If it is + # greater than 1, this means that we have a pragma Source_Reference, + # and this must not be counted in the xref information. + my ($file, $offset) = ($1, (defined $4) ? 2 - $4 : 0); + + if ($dependencies) + { + push (@list_files, $1) unless (grep (/$file/, @list_files)); + } + push (@reffiles, [&http_string (&get_real_file_name ($file)), $offset]); + } + + elsif (/^X\s+(\d+)/) + { + $currentfile = $lastfile = $1 - 1; + } + + elsif (defined $currentfile && /$decl_line/) + { + my ($line) = $1 + $reffiles[$currentfile][1]; + next if (! $standard_library + && $reffiles[$currentfile][0] =~ /$standard_file_regexp/); + if ($xref_variable || $2 eq &uppercases ($2)) + { + $currentref = $reffiles[$currentfile][0] . ".$fileext#$line\_$3"; + $symbols {$currentref} = &to_type ($2); + $lastfile = $currentfile; + + local ($endofline) = $5; + + foreach (split (" ", $endofline)) + { + (s/^(\d+)\|//) && do { $lastfile = $1 - 1; }; + &create_new_reference + ($_, $reffiles[$lastfile][0], + $reffiles[$lastfile][1], $currentref); + } + } + else + { + $currentref = ""; + } + } + elsif (/^\.\s(.*)/ && $reffiles[$currentfile][0] ne "" && $currentref ne "") + { + next if (! $standard_library + && $reffiles[$currentfile][0] =~ /$standard_file_regexp/); + foreach (split (" ", $1)) + { + (s/^(\d+)\|//) && do { $lastfile = $1 - 1; }; + &create_new_reference + ($_, $reffiles[$lastfile][0], $reffiles[$lastfile][1], + $currentref); + } + } + } + } + + ######### + ## Return the name of the ALI file to use for a given source + ## Params: - Name of the source file + ## return: Name and location of the ALI file + ######### + + sub ali_file_name { + local ($source) = shift; + local ($alifilename, $unitname); + local ($in_separate) = 0; + + $source =~ s/\.ad[sb]$//; + $alifilename = $source; + $unitname = $alifilename; + $unitname =~ s/-/./g; + + ## There are two reasons why we might not find the ALI file: either the + ## user did not generate them at all, or we are working on a separate unit. + ## Thus, we search in the parent's ALI file. + + while ($alifilename ne "") { + + ## Search in the object path + foreach (@obj_dir) { + + ## Check if the ALI file does apply to the source file + ## We check the ^D lines, which have the following format: + ## D source-name time-stamp checksum [subunit-name] line:file-name + + if (-r "$_$alifilename.ali") { + if ($in_separate) { + open (FILE, "$_$alifilename.ali"); + + if (grep (/^D \S+\s+\S+\s+\S+ $unitname/, )) { + close FILE; + return "$_$alifilename.ali"; + + } else { + ## If the ALI file doesn't apply to the source file, we can + ## return now, since there won't be a parent ALI file above + ## anyway + close FILE; + return "$source.ali"; + } + } else { + return "$_$alifilename.ali"; + } + } + } + + ## Get the parent's ALI file name + + if (! ($alifilename =~ s/-[^-]+$//)) { + $alifilename = ""; + } + $in_separate = 1; + } + + return "$source.ali"; + } + + ######### + ## Convert a path to an absolute path + ######### + + sub to_absolute + { + local ($path) = shift; + local ($name, $suffix, $separator); + ($name,$path,$suffix) = fileparse ($path, ()); + $path = &abs_path ($path); + $separator = substr ($path, 0, 1); + return $path . $separator . $name; + } + + ######### + ## This function outputs the html version of the file FILE + ## The output is send to FILE.htm. + ## Params : - Name of the file to convert (ends with .ads or .adb) + ######### + sub output_file + { + local ($filename_param) = shift; + local ($lineno) = 1; + local ($column); + local ($found); + + local ($alifilename) = &ali_file_name ($filename_param); + + $filename = &get_real_file_name ($filename_param); + $found = &find_file ($filename); + + ## Read the whole file + open (FILE, $found) || do { + print $found, " not found ... skipping.\n"; + return 0; + }; + local (@file) = ; + close (FILE); + + ## Parse the .ali file to find the cross-references + print "converting ", $filename, "\n"; + &parse_ali ($alifilename); + + ## Create and initialize the html file + open (OUTPUT, ">$output_dir/" . &http_string ($filename) . ".$fileext") + || die "Couldn't write $output_dir/" . &http_string ($filename) + . ".$fileext\n"; + + if ($absolute) { + print OUTPUT &create_header (&to_absolute ($found)), "\n"; + } else { + print OUTPUT &create_header ($filename_param), "\n"; + } + + ## Print the file + $filename = &http_string ($filename); + foreach (@file) + { + local ($index); + local ($line) = $_; + local ($comment); + + $column = 1; + chop ($line); + + ## Print either the line number or a space if required + if ($line_numbers) + { + if ($lineno % $line_numbers == 0) + { + print OUTPUT &output_line_number ($lineno); + } + else + { + print OUTPUT &output_line_number (-1); + } + } + + ## First, isolate any comment on the line + undef $comment; + $index = index ($line, '--'); + if ($index != -1) { + $comment = substr ($line, $index + 2); + if ($index > 1) + { + $line = substr ($line, 0, $index); + } + else + { + undef $line; + } + } + + ## Then print the line + if (defined $line) + { + $index = 0; + while ($index < length ($line)) + { + local ($substring) = substr ($line, $index); + + if ($substring =~ /^\t/) + { + print OUTPUT ' ' x ($tab_size - (($column - 1) % $tab_size)); + $column += $tab_size - (($column - 1) % $tab_size); + $index ++; + } + elsif ($substring =~ /^(\w+)/ + || $substring =~ /^("[^\"]*")/ + || $substring =~ /^(\W)/) + { + local ($word) = $1; + $index += length ($word); + + local ($lowercase) = $word; + $lowercase =~ tr/A-Z/a-z/; + + if ($keywords{$lowercase}) + { + print OUTPUT &output_keyword ($word); + } + elsif ($symbols {"$filename.$fileext#$lineno\_$column"}) + { + ## A symbol can both have a link and be a reference for + ## another link, as is the case for bodies and + ## declarations + + if ($symbols_used{"$filename#$lineno\_$column"}) + { + print OUTPUT "", &protect_string ($word), ""; + print OUTPUT &output_symbol ('', $lineno, $column); + } + else + { + print OUTPUT &output_symbol ($word, $lineno, $column); + } + + ## insert only functions into the global index + + if ($symbols {"$filename.$fileext#$lineno\_$column"} eq 'f') + { + push (@{$global_index {$word}}, + [$filename_param, $filename, $lineno, $column]); + } + } + elsif ($symbols_used{"$filename#$lineno\_$column"}) + { + print OUTPUT "", &protect_string ($word), ""; + } + else + { + print OUTPUT &protect_string ($word); + } + $column += length ($word); + } + else + { + $index ++; + $column ++; + print OUTPUT &protect_string (substr ($substring, 0, 1)); + } + } + } + + ## Then output the comment + print OUTPUT &output_comment ($comment) if (defined $comment); + print OUTPUT "\n"; + + $lineno ++; + } + + print OUTPUT &create_footer ($filename); + close (OUTPUT); + return 1; + } + + ######### + ## This function generates the global index + ######### + sub create_index_file + { + open (INDEX, ">$output_dir/index.$fileext") || die "couldn't write $output_dir/index.$fileext"; + + print INDEX <<"EOF"; + + Source Browser + + + EOF + ; + + local (@files) = &create_file_index; + print INDEX join ("\n", @files), "\n"; + + print INDEX "
\n"; + local (@functions) = &create_function_index; + print INDEX join ("\n", @functions), "\n"; + + print INDEX <<"EOF"; + + + + + + + + + EOF + ; + close (INDEX); + + open (MAIN, ">$output_dir/main.$fileext") || die "couldn't write $output_dir/main.$fileext"; + print MAIN &create_header (""), + "

", + "[No frame version is here]", + "

", + join ("\n", @files), "\n

", + join ("\n", @functions), "\n"; + + if ($dependencies) { + print MAIN "
\n"; + print MAIN "You should start your browsing with one of these files:\n"; + print MAIN "
    \n"; + foreach (@original_list) { + print MAIN "
  • $_\n"; + } + } + print MAIN &create_footer (""); + close (MAIN); + } + + ####### + ## Convert to upper cases (did not exist in Perl 4) + ####### + + sub uppercases { + local ($tmp) = shift; + $tmp =~ tr/a-z/A-Z/; + return $tmp; + } + + ####### + ## This function generates the file_index + ## RETURN : - table with the html lines to be printed + ####### + sub create_file_index + { + local (@output) = ("

    Files

    "); + + + open (FILES, ">$output_dir/files.$fileext") || die "couldn't write $output_dir/files.$fileext"; + print FILES &create_header (""), join ("\n", @output), "\n"; + + + if ($#list_files > 20) + { + local ($last_letter) = ''; + foreach (sort {&uppercases ($a) cmp &uppercases ($b)} @list_files) + { + next if ($_ eq ""); + if (&uppercases (substr ($_, 0, 1)) ne $last_letter) + { + if ($last_letter ne '') + { + print INDEX_FILE "
\n"; + close (INDEX_FILE); + } + $last_letter = &uppercases (substr ($_, 0, 1)); + open (INDEX_FILE, ">$output_dir/files/$last_letter.$fileext") + || die "couldn't write $output_dir/files/$last_letter.$fileext"; + print INDEX_FILE <<"EOF"; + $last_letter + +

Files - $last_letter

+ [index] +
    + EOF + ; + local ($str) = "[$last_letter]"; + push (@output, $str); + print FILES "$str\n"; + } + print INDEX_FILE "
  • $_\n"; ## Problem with TARGET when in no_frame mode! + } + + print INDEX_FILE "
\n"; + close INDEX_FILE; + } + else + { + push (@output, "
    "); + print FILES "
      "; + foreach (sort {&uppercases ($a) cmp &uppercases ($b)} @list_files) + { + next if ($_ eq ""); + local ($ref) = &http_string (&get_real_file_name ($_)); + push (@output, "
    • $_"); + print FILES "
    • $_\n"; + } + } + + print FILES &create_footer (""); + close (FILES); + + push (@output, "
    "); + return @output; + } + + ####### + ## This function generates the function_index + ## RETURN : - table with the html lines to be printed + ####### + sub create_function_index + { + local (@output) = ("

    Functions/Procedures

    "); + local ($initial) = ""; + + open (FUNCS, ">$output_dir/funcs.$fileext") || die "couldn't write $output_dir/funcs.$fileext"; + print FUNCS &create_header (""), join ("\n", @output), "\n"; + + ## If there are more than 20 entries, we just want to create some + ## submenus + if (scalar (keys %global_index) > 20) + { + local ($last_letter) = ''; + foreach (sort {&uppercases ($a) cmp &uppercases ($b)} keys %global_index) + { + if (&uppercases (substr ($_, 0, 1)) ne $last_letter) + { + if ($last_letter ne '') + { + print INDEX_FILE "
\n"; + close (INDEX_FILE); + } + + $last_letter = &uppercases (substr ($_, 0, 1)); + $initial = $last_letter; + if ($initial eq '"') + { + $initial = "operators"; + } + if ($initial ne '.') + { + open (INDEX_FILE, ">$output_dir/funcs/$initial.$fileext") + || die "couldn't write $output_dir/funcs/$initial.$fileext"; + print INDEX_FILE <<"EOF"; + $initial + +

Functions - $initial

+ [index] +
    + EOF + ; + local ($str) = "[$initial]"; + push (@output, $str); + print FUNCS "$str\n"; + } + } + local ($ref); + local ($is_overloaded) = ($#{$global_index {$_}} > 0 ? 1 : 0); + foreach $ref (@{$global_index {$_}}) + { + ($file, $full_file, $lineno, $column) = @{$ref}; + local ($symbol) = ($is_overloaded ? "$_ - $file:$lineno" : $_); + print INDEX_FILE "
  • $symbol"; + } + } + + print INDEX_FILE "
\n"; + close INDEX_FILE; + } + else + { + push (@output, "
    "); + print FUNCS "
      "; + foreach (sort {&uppercases ($a) cmp &uppercases ($b)} keys %global_index) + { + local ($ref); + local ($is_overloaded) = ($#{$global_index {$_}} > 0 ? 1 : 0); + foreach $ref (@{$global_index {$_}}) + { + ($file, $full_file, $lineno, $column) = @{$ref}; + local ($symbol) = ($is_overloaded ? "$_ - $file:$lineno" : $_); + push (@output, "
    • $symbol"); + print FUNCS "
    • $symbol"; + } + } + } + + print FUNCS &create_footer (""); + close (FUNCS); + + push (@output, "
    "); + return (@output); + } + + ###### + ## Main function + ###### + + local ($index_file) = 0; + + mkdir ($output_dir, 0777) if (! -d $output_dir); + mkdir ($output_dir."/files", 0777) if (! -d $output_dir."/files"); + mkdir ($output_dir."/funcs", 0777) if (! -d $output_dir."/funcs"); + + &parse_prj_file ($prjfile) if ($prjfile); + + while ($index_file <= $#list_files) + { + local ($file) = $list_files [$index_file]; + + if (&output_file ($file) == 0) + { + $list_files [$index_file] = ""; + } + $index_file ++; + } + &create_index_file; + + $indexfile = "$output_dir/index.$fileext"; + $indexfile =~ s!//!/!g; + print "You can now download the $indexfile file to see the ", + "created pages\n"; diff -Nrcpad gcc-4.3.3/gcc/ada/gnatlbr.adb gcc-4.4.0/gcc/ada/gnatlbr.adb *** gcc-4.3.3/gcc/ada/gnatlbr.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/gnatlbr.adb Tue Apr 8 06:44:39 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2008, 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- -- *************** begin *** 156,163 **** Create_Block : declare Success : Boolean; Make_Args : Argument_List (1 .. 9); ! C_Lib_Dir : String := Lib_Dir.all & ASCII.Nul; ! C_ADC_File : String := ADC_File.all & ASCII.Nul; F_ADC_File : String (1 .. max_path_len); F_ADC_File_Len : Integer := max_path_len; Include_Dirs : Integer; --- 156,163 ---- Create_Block : declare Success : Boolean; Make_Args : Argument_List (1 .. 9); ! C_Lib_Dir : String := Lib_Dir.all & ASCII.NUL; ! C_ADC_File : String := ADC_File.all & ASCII.NUL; F_ADC_File : String (1 .. max_path_len); F_ADC_File_Len : Integer := max_path_len; Include_Dirs : Integer; *************** begin *** 177,183 **** full_name (C_ADC_File'Address, F_ADC_File'Address); for I in 1 .. max_path_len loop ! if F_ADC_File (I) = ASCII.Nul then F_ADC_File_Len := I - 1; exit; end if; --- 177,183 ---- full_name (C_ADC_File'Address, F_ADC_File'Address); for I in 1 .. max_path_len loop ! if F_ADC_File (I) = ASCII.NUL then F_ADC_File_Len := I - 1; exit; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/gnatlink.adb gcc-4.4.0/gcc/ada/gnatlink.adb *** gcc-4.3.3/gcc/ada/gnatlink.adb Thu Dec 13 10:23:29 2007 --- gcc-4.4.0/gcc/ada/gnatlink.adb Wed Jul 30 15:52:36 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2008, 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- -- *************** procedure Gnatlink is *** 104,110 **** -- important because on the GNU linker command line the -L switch is not -- used to look for objects files but -L switch is used to look for -- objects listed in the response file. This is not a problem with the ! -- applications objects as they are specified with a fullname. package Response_File_Objects is new Table.Table ( Table_Component_Type => String_Access, --- 104,110 ---- -- important because on the GNU linker command line the -L switch is not -- used to look for objects files but -L switch is used to look for -- objects listed in the response file. This is not a problem with the ! -- applications objects as they are specified with a full name. package Response_File_Objects is new Table.Table ( Table_Component_Type => String_Access, *************** procedure Gnatlink is *** 137,145 **** -- This table collects the arguments to be passed to compile the binder -- generated file. ! Gcc : String_Access := Program_Name ("gcc"); ! Read_Mode : constant String := "r" & ASCII.Nul; Begin_Info : String := "-- BEGIN Object file/option list"; End_Info : String := "-- END Object file/option list "; --- 137,145 ---- -- This table collects the arguments to be passed to compile the binder -- generated file. ! Gcc : String_Access := Program_Name ("gcc", "gnatlink"); ! Read_Mode : constant String := "r" & ASCII.NUL; Begin_Info : String := "-- BEGIN Object file/option list"; End_Info : String := "-- END Object file/option list "; *************** procedure Gnatlink is *** 147,153 **** Gcc_Path : String_Access; Linker_Path : String_Access; - Output_File_Name : String_Access; Ali_File_Name : String_Access; Binder_Spec_Src_File : String_Access; --- 147,152 ---- *************** procedure Gnatlink is *** 160,165 **** --- 159,168 ---- -- Temporary file used by linker to pass list of object files on -- certain systems with limitations on size of arguments. + Lname : String_Access := null; + -- File used by linker for CLI target, used to concatenate all .il files + -- when the command line passed to ilasm is too long + Debug_Flag_Present : Boolean := False; Verbose_Mode : Boolean := False; Very_Verbose_Mode : Boolean := False; *************** procedure Gnatlink is *** 167,173 **** Ada_Bind_File : Boolean := True; -- Set to True if bind file is generated in Ada ! Standard_Gcc : Boolean := True; Compile_Bind_File : Boolean := True; -- Set to False if bind file is not to be compiled --- 170,176 ---- Ada_Bind_File : Boolean := True; -- Set to True if bind file is generated in Ada ! Standard_Gcc : Boolean := True; Compile_Bind_File : Boolean := True; -- Set to False if bind file is not to be compiled *************** procedure Gnatlink is *** 518,525 **** (Arg (7 .. Arg'Last)); begin ! Gcc := new String'(Program_Args.all (1).all); ! Standard_Gcc := False; -- Set appropriate flags for switches passed --- 521,530 ---- (Arg (7 .. Arg'Last)); begin ! if Program_Args.all (1).all /= Gcc.all then ! Gcc := new String'(Program_Args.all (1).all); ! Standard_Gcc := False; ! end if; -- Set appropriate flags for switches passed *************** procedure Gnatlink is *** 932,945 **** Objs_End := Linker_Objects.Last; ! -- Let's continue to compute the Link_Bytes, the linker options are ! -- part of command line length. Store_File_Context; while Next_Line (Nfirst .. Nlast) /= End_Info loop Link_Bytes := Link_Bytes + Nlast - Nfirst + 2; - -- See comment above Get_Next_Line; end loop; --- 937,949 ---- Objs_End := Linker_Objects.Last; ! -- Continue to compute the Link_Bytes, the linker options are part of ! -- command line length. Store_File_Context; while Next_Line (Nfirst .. Nlast) /= End_Info loop Link_Bytes := Link_Bytes + Nlast - Nfirst + 2; Get_Next_Line; end loop; *************** procedure Gnatlink is *** 953,959 **** -- to read from a file instead of the command line is only triggered if -- a conservative threshold is passed. ! if Object_List_File_Required or else (Object_List_File_Supported and then Link_Bytes > Link_Max) then --- 957,998 ---- -- to read from a file instead of the command line is only triggered if -- a conservative threshold is passed. ! if VM_Target = CLI_Target ! and then Link_Bytes > Link_Max ! then ! Lname := new String'("l~" & Base_Name (Ali_File_Name.all) & ".il"); ! ! for J in Objs_Begin .. Objs_End loop ! Copy_File (Linker_Objects.Table (J).all, Lname.all, ! Success => Closing_Status, ! Mode => Append); ! end loop; ! ! -- Add the special objects list file option together with the name ! -- of the temporary file to the objects file table. ! ! Linker_Objects.Table (Objs_Begin) := ! new String'(Value (Object_File_Option_Ptr) & Lname.all); ! ! -- The slots containing these object file names are then removed ! -- from the objects table so they do not appear in the link. They ! -- are removed by moving up the linker options and non-Ada object ! -- files appearing after the Ada object list in the table. ! ! declare ! N : Integer; ! ! begin ! N := Objs_End - Objs_Begin + 1; ! ! for J in Objs_End + 1 .. Linker_Objects.Last loop ! Linker_Objects.Table (J - N + 1) := Linker_Objects.Table (J); ! end loop; ! ! Linker_Objects.Set_Last (Linker_Objects.Last - N + 1); ! end; ! ! elsif Object_List_File_Required or else (Object_List_File_Supported and then Link_Bytes > Link_Max) then *************** procedure Gnatlink is *** 1303,1309 **** else -- If gnatlib library not found, then -- add it anyway in case some other ! -- mechanimsm may find it. Linker_Options.Increment_Last; Linker_Options.Table (Linker_Options.Last) := --- 1342,1348 ---- else -- If gnatlib library not found, then -- add it anyway in case some other ! -- mechanism may find it. Linker_Options.Increment_Last; Linker_Options.Table (Linker_Options.Last) := *************** begin *** 1445,1469 **** Exit_Program (E_Fatal); end if; ! -- Get target parameters Namet.Initialize; Csets.Initialize; Snames.Initialize; - Osint.Add_Default_Search_Dirs; - Targparm.Get_Target_Parameters; - - if VM_Target /= No_VM then - case VM_Target is - when JVM_Target => Gcc := new String'("jgnat"); - when CLI_Target => Gcc := new String'("dotnet-gnatcompile"); - when No_VM => raise Program_Error; - end case; - - Ada_Bind_File := True; - Begin_Info := "-- BEGIN Object file/option list"; - End_Info := "-- END Object file/option list "; - end if; -- We always compile with -c --- 1484,1494 ---- Exit_Program (E_Fatal); end if; ! -- Initialize packages to be used Namet.Initialize; Csets.Initialize; Snames.Initialize; -- We always compile with -c *************** begin *** 1471,1520 **** Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := new String'("-c"); - -- If the main program is in Ada it is compiled with the following - -- switches: - - -- -gnatA stops reading gnat.adc, since we don't know what - -- pagmas would work, and we do not need it anyway. - - -- -gnatWb allows brackets coding for wide characters - - -- -gnatiw allows wide characters in identifiers. This is needed - -- because bindgen uses brackets encoding for all upper - -- half and wide characters in identifier names. - - if Ada_Bind_File then - Binder_Options_From_ALI.Increment_Last; - Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := - new String'("-gnatA"); - Binder_Options_From_ALI.Increment_Last; - Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := - new String'("-gnatWb"); - Binder_Options_From_ALI.Increment_Last; - Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := - new String'("-gnatiw"); - end if; - - -- Locate all the necessary programs and verify required files are present - - Gcc_Path := System.OS_Lib.Locate_Exec_On_Path (Gcc.all); - - if Gcc_Path = null then - Exit_With_Error ("Couldn't locate " & Gcc.all); - end if; - - if Linker_Path = null then - if VM_Target = CLI_Target then - Linker_Path := System.OS_Lib.Locate_Exec_On_Path ("ilasm"); - - if Linker_Path = null then - Exit_With_Error ("Couldn't locate ilasm"); - end if; - else - Linker_Path := Gcc_Path; - end if; - end if; - if Ali_File_Name = null then Exit_With_Error ("no ali file given for link"); end if; --- 1496,1501 ---- *************** begin *** 1585,1590 **** --- 1566,1583 ---- := String_Access (Arg); end if; + -- Set the RTS_*_Path_Name variables, so that the + -- correct directories will be set when + -- Osint.Add_Default_Search_Dirs will be called later. + + Opt.RTS_Src_Path_Name := + Get_RTS_Search_Dir + (Arg (Arg'First + 6 .. Arg'Last), Include); + + Opt.RTS_Lib_Path_Name := + Get_RTS_Search_Dir + (Arg (Arg'First + 6 .. Arg'Last), Objects); + -- GNAT doesn't support the GCC multilib mechanism. -- This means that, when a multilib switch is used -- to request a particular compilation mode, the *************** begin *** 1596,1603 **** -- Pass -mrtp to the linker if --RTS=rtp was passed ! if Linker_Path = Gcc_Path ! and then Arg'Length > 8 and then Arg (Arg'First + 6 .. Arg'First + 8) = "rtp" then Linker_Options.Increment_Last; --- 1589,1595 ---- -- Pass -mrtp to the linker if --RTS=rtp was passed ! if Arg'Length > 8 and then Arg (Arg'First + 6 .. Arg'First + 8) = "rtp" then Linker_Options.Increment_Last; *************** begin *** 1606,1613 **** -- Pass -fsjlj to the linker if --RTS=sjlj was passed ! elsif Linker_Path = Gcc_Path ! and then Arg'Length > 9 and then Arg (Arg'First + 6 .. Arg'First + 9) = "sjlj" then Linker_Options.Increment_Last; --- 1598,1604 ---- -- Pass -fsjlj to the linker if --RTS=sjlj was passed ! elsif Arg'Length > 9 and then Arg (Arg'First + 6 .. Arg'First + 9) = "sjlj" then Linker_Options.Increment_Last; *************** begin *** 1621,1626 **** --- 1612,1689 ---- end; end if; + -- Get target parameters + + Osint.Add_Default_Search_Dirs; + Targparm.Get_Target_Parameters; + + if VM_Target /= No_VM then + case VM_Target is + when JVM_Target => Gcc := new String'("jgnat"); + when CLI_Target => Gcc := new String'("dotnet-gnatcompile"); + when No_VM => raise Program_Error; + end case; + + Ada_Bind_File := True; + Begin_Info := "-- BEGIN Object file/option list"; + End_Info := "-- END Object file/option list "; + end if; + + -- If the main program is in Ada it is compiled with the following + -- switches: + + -- -gnatA stops reading gnat.adc, since we don't know what + -- pragmas would work, and we do not need it anyway. + + -- -gnatWb allows brackets coding for wide characters + + -- -gnatiw allows wide characters in identifiers. This is needed + -- because bindgen uses brackets encoding for all upper + -- half and wide characters in identifier names. + + if Ada_Bind_File then + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-gnatA"); + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-gnatWb"); + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-gnatiw"); + end if; + + -- Locate all the necessary programs and verify required files are present + + Gcc_Path := System.OS_Lib.Locate_Exec_On_Path (Gcc.all); + + if Gcc_Path = null then + Exit_With_Error ("Couldn't locate " & Gcc.all); + end if; + + if Linker_Path = null then + if VM_Target = CLI_Target then + Linker_Path := System.OS_Lib.Locate_Exec_On_Path ("ilasm"); + + if Linker_Path = null then + Exit_With_Error ("Couldn't locate ilasm"); + end if; + + elsif RTX_RTSS_Kernel_Module_On_Target then + + -- Use Microsoft linker for RTSS modules + + Linker_Path := System.OS_Lib.Locate_Exec_On_Path ("link"); + + if Linker_Path = null then + Exit_With_Error ("Couldn't locate link"); + end if; + + else + Linker_Path := Gcc_Path; + end if; + end if; + Write_Header; -- If no output name specified, then use the base name of .ali file name *************** begin *** 1641,1646 **** --- 1704,1714 ---- Linker_Options.Table (Linker_Options.Last) := new String'("/OUTPUT=" & Output_File_Name.all); + elsif RTX_RTSS_Kernel_Module_On_Target then + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'("/OUT:" & Output_File_Name.all); + else Linker_Options.Increment_Last; Linker_Options.Table (Linker_Options.Last) := new String'("-o"); *************** begin *** 1830,1835 **** --- 1898,2017 ---- Num_Args := Num_Args - 1; end if; end loop; + + elsif RTX_RTSS_Kernel_Module_On_Target then + + -- Remove flags not relevant for Microsoft linker and adapt some + -- others. + + for J in reverse Linker_Options.First .. Linker_Options.Last loop + + -- Remove flags that are not accepted + if Linker_Options.Table (J)'Length = 0 + or else Linker_Options.Table (J) (1 .. 2) = "-l" + or else Linker_Options.Table (J) (1 .. 3) = "-Wl" + or else Linker_Options.Table (J) (1 .. 3) = "-sh" + or else Linker_Options.Table (J) (1 .. 8) = "-Xlinker" + or else Linker_Options.Table (J) (1 .. 9) = "-mthreads" + then + Linker_Options.Table (J .. Linker_Options.Last - 1) := + Linker_Options.Table (J + 1 .. Linker_Options.Last); + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 1; + + -- Replace "-L" by its counterpart "/LIBPATH:" and UNIX "/" by + -- Windows "\". + elsif Linker_Options.Table (J) (1 .. 2) = "-L" then + declare + Libpath_Option : constant String_Access := new String' + ("/LIBPATH:" & + Linker_Options.Table (J) + (3 .. Linker_Options.Table (J).all'Last)); + begin + for Index in 10 .. Libpath_Option'Last loop + if Libpath_Option (Index) = '/' then + Libpath_Option (Index) := '\'; + end if; + end loop; + + Linker_Options.Table (J) := Libpath_Option; + end; + + -- Replace "-g" by "/DEBUG" + elsif Linker_Options.Table (J) (1 .. 2) = "-g" then + Linker_Options.Table (J) := new String'("/DEBUG"); + + -- Replace "-o" by "/OUT:" + elsif Linker_Options.Table (J) (1 .. 2) = "-o" then + Linker_Options.Table (J + 1) := new String' + ("/OUT:" & Linker_Options.Table (J + 1).all); + + Linker_Options.Table (J .. Linker_Options.Last - 1) := + Linker_Options.Table (J + 1 .. Linker_Options.Last); + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 1; + + -- Replace "--stack=" by "/STACK:" + elsif Linker_Options.Table (J) (1 .. 8) = "--stack=" then + Linker_Options.Table (J) := new String' + ("/STACK:" & + Linker_Options.Table (J) + (9 .. Linker_Options.Table (J).all'Last)); + + -- Replace "-v" by its counterpart "/VERBOSE" + elsif Linker_Options.Table (J) (1 .. 2) = "-v" then + Linker_Options.Table (J) := new String'("/VERBOSE"); + end if; + end loop; + + -- Add some required flags to create RTSS modules + + declare + Flags_For_Linker : constant array (1 .. 17) of String_Access := + (new String'("/NODEFAULTLIB"), + new String'("/INCREMENTAL:NO"), + new String'("/NOLOGO"), + new String'("/DRIVER"), + new String'("/ALIGN:0x20"), + new String'("/SUBSYSTEM:NATIVE"), + new String'("/ENTRY:_RtapiProcessEntryCRT@8"), + new String'("/RELEASE"), + new String'("startupCRT.obj"), + new String'("rtxlibcmt.lib"), + new String'("oldnames.lib"), + new String'("rtapi_rtss.lib"), + new String'("Rtx_Rtss.lib"), + new String'("libkernel32.a"), + new String'("libws2_32.a"), + new String'("libmswsock.a"), + new String'("libadvapi32.a")); + -- These flags need to be passed to Microsoft linker. They + -- come from the RTX documentation. + + Gcc_Lib_Path : constant String_Access := new String' + ("/LIBPATH:" & Include_Dir_Default_Prefix & "\..\"); + -- Place to look for gcc related libraries, such as libgcc + + begin + -- Replace UNIX "/" by Windows "\" in the path + + for Index in 10 .. Gcc_Lib_Path.all'Last loop + if Gcc_Lib_Path (Index) = '/' then + Gcc_Lib_Path (Index) := '\'; + end if; + end loop; + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := Gcc_Lib_Path; + Num_Args := Num_Args + 1; + + for Index in Flags_For_Linker'Range loop + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + Flags_For_Linker (Index); + Num_Args := Num_Args + 1; + end loop; + end; end if; -- Remove duplicate stack size setting from the Linker_Options *************** begin *** 1843,1849 **** -- one. And any subsequent stack setting option will overwrite the -- previous one. This is done especially for GNAT/NT where we set -- the stack size for tasking programs by a pragma in the NT ! -- specific tasking package System.Task_Primitives.Oparations. -- Note: This is not a FOR loop that runs from Linker_Options.First -- to Linker_Options.Last, since operations within the loop can --- 2025,2031 ---- -- one. And any subsequent stack setting option will overwrite the -- previous one. This is done especially for GNAT/NT where we set -- the stack size for tasking programs by a pragma in the NT ! -- specific tasking package System.Task_Primitives.Operations. -- Note: This is not a FOR loop that runs from Linker_Options.First -- to Linker_Options.Last, since operations within the loop can *************** begin *** 1939,1944 **** --- 2121,2135 ---- Linker_Options.Table (Linker_Options.Last) := Static_Libgcc; Num_Args := Num_Args + 1; end if; + + elsif RTX_RTSS_Kernel_Module_On_Target then + + -- Force the use of the static libgcc for RTSS modules + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'("libgcc.a"); + Num_Args := Num_Args + 1; end if; end Clean_Link_Option_Set; *************** begin *** 2008,2020 **** System.OS_Lib.Spawn (Linker_Path.all, Args, Success); ! -- Delete the temporary file used in conjuction with linking if -- one was created. See Process_Bind_File for details. if Tname_FD /= Invalid_FD then Delete (Tname); end if; if not Success then Error_Msg ("error when calling " & Linker_Path.all); Exit_Program (E_Fatal); --- 2199,2215 ---- System.OS_Lib.Spawn (Linker_Path.all, Args, Success); ! -- Delete the temporary file used in conjunction with linking if -- one was created. See Process_Bind_File for details. if Tname_FD /= Invalid_FD then Delete (Tname); end if; + if Lname /= null then + Delete (Lname.all & ASCII.NUL); + end if; + if not Success then Error_Msg ("error when calling " & Linker_Path.all); Exit_Program (E_Fatal); diff -Nrcpad gcc-4.3.3/gcc/ada/gnatmem.adb gcc-4.4.0/gcc/ada/gnatmem.adb *** gcc-4.3.3/gcc/ada/gnatmem.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/gnatmem.adb Tue Apr 8 06:44:39 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2008, AdaCore -- -- -- -- 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- -- *************** *** 27,33 **** -- idea: -- - Read the allocation log generated by the application linked using ! -- instrumented memory allocation and dealocation (see memtrack.adb for -- this circuitry). To get access to this functionality, the application -- must be relinked with library libgmem.a: --- 27,33 ---- -- idea: -- - Read the allocation log generated by the application linked using ! -- instrumented memory allocation and deallocation (see memtrack.adb for -- this circuitry). To get access to this functionality, the application -- must be relinked with library libgmem.a: *************** procedure Gnatmem is *** 307,313 **** loop case Getopt ("b: dd m: i: q s:") is ! when ASCII.Nul => exit; when 'b' => begin --- 307,313 ---- loop case Getopt ("b: dd m: i: q s:") is ! when ASCII.NUL => exit; when 'b' => begin diff -Nrcpad gcc-4.3.3/gcc/ada/gnatname.adb gcc-4.4.0/gcc/ada/gnatname.adb *** gcc-4.3.3/gcc/ada/gnatname.adb Thu Dec 13 10:23:29 2007 --- gcc-4.4.0/gcc/ada/gnatname.adb Mon May 26 09:40:23 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** *** 23,43 **** -- -- ------------------------------------------------------------------------------ with Hostparm; with Opt; with Osint; use Osint; with Output; use Output; with Prj.Makr; with Switch; use Switch; with Table; ! with Ada.Command_Line; use Ada.Command_Line; ! with Ada.Text_IO; use Ada.Text_IO; ! with GNAT.Command_Line; use GNAT.Command_Line; ! with GNAT.OS_Lib; use GNAT.OS_Lib; procedure Gnatname is Usage_Output : Boolean := False; -- Set to True when usage is output, to avoid multiple output --- 23,49 ---- -- -- ------------------------------------------------------------------------------ + with Ada.Command_Line; use Ada.Command_Line; + with Ada.Text_IO; use Ada.Text_IO; + + with GNAT.Dynamic_Tables; + with GNAT.OS_Lib; use GNAT.OS_Lib; + with Hostparm; with Opt; with Osint; use Osint; with Output; use Output; + with Prj; use Prj; with Prj.Makr; with Switch; use Switch; with Table; ! with System.Regexp; use System.Regexp; procedure Gnatname is + Subdirs_Switch : constant String := "--subdirs="; + Usage_Output : Boolean := False; -- Set to True when usage is output, to avoid multiple output *************** procedure Gnatname is *** 60,101 **** -- Set to True by -c or -P switch. -- Used to detect multiple -c/-P switches. ! package Excluded_Patterns is new Table.Table ! (Table_Component_Type => String_Access, ! Table_Index_Type => Natural, ! Table_Low_Bound => 0, ! Table_Initial => 10, ! Table_Increment => 100, ! Table_Name => "Gnatname.Excluded_Patterns"); ! -- Table to accumulate the negative patterns ! ! package Foreign_Patterns is new Table.Table (Table_Component_Type => String_Access, Table_Index_Type => Natural, Table_Low_Bound => 0, Table_Initial => 10, ! Table_Increment => 100, ! Table_Name => "Gnatname.Foreign_Patterns"); ! -- Table to accumulate the foreign patterns ! package Patterns is new Table.Table ! (Table_Component_Type => String_Access, ! Table_Index_Type => Natural, ! Table_Low_Bound => 0, ! Table_Initial => 10, ! Table_Increment => 100, ! Table_Name => "Gnatname.Patterns"); ! -- Table to accumulate the name patterns ! package Source_Directories is new Table.Table ! (Table_Component_Type => String_Access, Table_Index_Type => Natural, Table_Low_Bound => 0, Table_Initial => 10, Table_Increment => 100, ! Table_Name => "Gnatname.Source_Directories"); ! -- Table to accumulate the source directories specified directly with -d ! -- or indirectly with -D. package Preprocessor_Switches is new Table.Table (Table_Component_Type => String_Access, --- 66,94 ---- -- Set to True by -c or -P switch. -- Used to detect multiple -c/-P switches. ! package Patterns is new GNAT.Dynamic_Tables (Table_Component_Type => String_Access, Table_Index_Type => Natural, Table_Low_Bound => 0, Table_Initial => 10, ! Table_Increment => 100); ! -- Table to accumulate the patterns ! type Argument_Data is record ! Directories : Patterns.Instance; ! Name_Patterns : Patterns.Instance; ! Excluded_Patterns : Patterns.Instance; ! Foreign_Patterns : Patterns.Instance; ! end record; ! package Arguments is new Table.Table ! (Table_Component_Type => Argument_Data, Table_Index_Type => Natural, Table_Low_Bound => 0, Table_Initial => 10, Table_Increment => 100, ! Table_Name => "Gnatname.Arguments"); ! -- Table to accumulate the foreign patterns package Preprocessor_Switches is new Table.Table (Table_Component_Type => String_Access, *************** procedure Gnatname is *** 128,135 **** procedure Add_Source_Directory (S : String) is begin ! Source_Directories.Increment_Last; ! Source_Directories.Table (Source_Directories.Last) := new String'(S); end Add_Source_Directory; --------------------- --- 121,128 ---- procedure Add_Source_Directory (S : String) is begin ! Patterns.Append ! (Arguments.Table (Arguments.Last).Directories, new String'(S)); end Add_Source_Directory; --------------------- *************** procedure Gnatname is *** 156,162 **** exception when Name_Error => ! Fail ("cannot open source directory """ & From_File & '"'); end Get_Directories; -------------------- --- 149,155 ---- exception when Name_Error => ! Fail ("cannot open source directory file """ & From_File & '"'); end Get_Directories; -------------------- *************** procedure Gnatname is *** 180,186 **** procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); ! -- Start of processing for Scan_Args begin -- First check for --version or --help --- 173,208 ---- procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); ! Project_File_Name_Expected : Boolean; ! ! Pragmas_File_Expected : Boolean; ! ! Directory_Expected : Boolean; ! ! Dir_File_Name_Expected : Boolean; ! ! Foreign_Pattern_Expected : Boolean; ! ! Excluded_Pattern_Expected : Boolean; ! ! procedure Check_Regular_Expression (S : String); ! -- Compile string S into a Regexp. Fail if any error. ! ! ----------------------------- ! -- Check_Regular_Expression-- ! ----------------------------- ! ! procedure Check_Regular_Expression (S : String) is ! Dummy : Regexp; ! pragma Warnings (Off, Dummy); ! begin ! Dummy := Compile (S, Glob => True); ! exception ! when Error_In_Regexp => ! Fail ("invalid regular expression """, S, """"); ! end Check_Regular_Expression; ! ! -- Start of processing for Scan_Args begin -- First check for --version or --help *************** procedure Gnatname is *** 189,274 **** -- Now scan the other switches ! Initialize_Option_Scan; ! -- Scan options first ! loop ! case Getopt ("c: d: gnatep=! gnatep! gnateD! D: h P: v x: f:") is ! when ASCII.NUL => ! exit; ! when 'c' => ! if File_Set then ! Fail ("only one -P or -c switch may be specified"); ! end if; ! File_Set := True; ! File_Path := new String'(Parameter); ! Create_Project := False; ! when 'd' => ! Add_Source_Directory (Parameter); ! when 'D' => ! Get_Directories (Parameter); ! when 'f' => ! Foreign_Patterns.Increment_Last; ! Foreign_Patterns.Table (Foreign_Patterns.Last) := ! new String'(Parameter); ! when 'g' => ! Preprocessor_Switches.Increment_Last; ! Preprocessor_Switches.Table (Preprocessor_Switches.Last) := ! new String'('-' & Full_Switch & Parameter); ! when 'h' => ! Usage_Needed := True; ! when 'P' => ! if File_Set then ! Fail ("only one -c or -P switch may be specified"); ! end if; ! File_Set := True; ! File_Path := new String'(Parameter); ! Create_Project := True; ! when 'v' => ! if Opt.Verbose_Mode then ! Very_Verbose := True; ! else ! Opt.Verbose_Mode := True; ! end if; ! when 'x' => ! Excluded_Patterns.Increment_Last; ! Excluded_Patterns.Table (Excluded_Patterns.Last) := ! new String'(Parameter); ! when others => ! null; ! end case; ! end loop; ! -- Now, get the name patterns, if any ! loop ! declare ! S : String := Get_Argument (Do_Expansion => False); ! begin ! exit when S = ""; ! Canonical_Case_File_Name (S); ! Patterns.Increment_Last; ! Patterns.Table (Patterns.Last) := new String'(S); end; end loop; - - exception - when Invalid_Switch => - Fail ("invalid switch " & Full_Switch); end Scan_Args; ----------- --- 211,485 ---- -- Now scan the other switches ! Project_File_Name_Expected := False; ! Pragmas_File_Expected := False; ! Directory_Expected := False; ! Dir_File_Name_Expected := False; ! Foreign_Pattern_Expected := False; ! Excluded_Pattern_Expected := False; ! for Next_Arg in 1 .. Argument_Count loop ! declare ! Next_Argv : constant String := Argument (Next_Arg); ! Arg : String (1 .. Next_Argv'Length) := Next_Argv; ! begin ! if Arg'Length > 0 then ! -- -P xxx ! if Project_File_Name_Expected then ! if Arg (1) = '-' then ! Fail ("project file name missing"); ! else ! File_Set := True; ! File_Path := new String'(Arg); ! Project_File_Name_Expected := False; ! end if; ! -- -c file ! elsif Pragmas_File_Expected then ! File_Set := True; ! File_Path := new String'(Arg); ! Create_Project := False; ! Pragmas_File_Expected := False; ! -- -d xxx ! elsif Directory_Expected then ! Add_Source_Directory (Arg); ! Directory_Expected := False; ! -- -D xxx ! elsif Dir_File_Name_Expected then ! Get_Directories (Arg); ! Dir_File_Name_Expected := False; ! -- -f xxx ! elsif Foreign_Pattern_Expected then ! Patterns.Append ! (Arguments.Table (Arguments.Last).Foreign_Patterns, ! new String'(Arg)); ! Check_Regular_Expression (Arg); ! Foreign_Pattern_Expected := False; ! -- -x xxx ! elsif Excluded_Pattern_Expected then ! Patterns.Append ! (Arguments.Table (Arguments.Last).Excluded_Patterns, ! new String'(Arg)); ! Check_Regular_Expression (Arg); ! Excluded_Pattern_Expected := False; ! -- There must be at least one Ada pattern or one foreign ! -- pattern for the previous section. ! -- --and ! ! elsif Arg = "--and" then ! ! if Patterns.Last ! (Arguments.Table (Arguments.Last).Name_Patterns) = 0 ! and then ! Patterns.Last ! (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0 ! then ! Usage; ! return; ! end if; ! ! -- If no directory were specified for the previous section, ! -- then the directory is the project directory. ! ! if Patterns.Last ! (Arguments.Table (Arguments.Last).Directories) = 0 ! then ! Patterns.Append ! (Arguments.Table (Arguments.Last).Directories, ! new String'(".")); ! end if; ! ! -- Add and initialize another component to Arguments table ! ! Arguments.Increment_Last; ! ! Patterns.Init ! (Arguments.Table (Arguments.Last).Directories); ! Patterns.Set_Last ! (Arguments.Table (Arguments.Last).Directories, 0); ! Patterns.Init ! (Arguments.Table (Arguments.Last).Name_Patterns); ! Patterns.Set_Last ! (Arguments.Table (Arguments.Last).Name_Patterns, 0); ! Patterns.Init ! (Arguments.Table (Arguments.Last).Excluded_Patterns); ! Patterns.Set_Last ! (Arguments.Table (Arguments.Last).Excluded_Patterns, 0); ! Patterns.Init ! (Arguments.Table (Arguments.Last).Foreign_Patterns); ! Patterns.Set_Last ! (Arguments.Table (Arguments.Last).Foreign_Patterns, 0); ! ! -- Subdirectory switch ! ! elsif Arg'Length > Subdirs_Switch'Length ! and then Arg (1 .. Subdirs_Switch'Length) = Subdirs_Switch ! then ! Subdirs := ! new String'(Arg (Subdirs_Switch'Length + 1 .. Arg'Last)); ! ! -- -c ! ! elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-c" then ! if File_Set then ! Fail ("only one -P or -c switch may be specified"); ! end if; ! ! if Arg'Length = 2 then ! Pragmas_File_Expected := True; ! ! if Next_Arg = Argument_Count then ! Fail ("configuration pragmas file name missing"); ! end if; ! ! else ! File_Set := True; ! File_Path := new String'(Arg (3 .. Arg'Last)); ! Create_Project := False; ! end if; ! ! -- -d ! ! elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-d" then ! if Arg'Length = 2 then ! Directory_Expected := True; ! ! if Next_Arg = Argument_Count then ! Fail ("directory name missing"); ! end if; ! ! else ! Add_Source_Directory (Arg (3 .. Arg'Last)); ! end if; ! ! -- -D ! ! elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-D" then ! if Arg'Length = 2 then ! Dir_File_Name_Expected := True; ! ! if Next_Arg = Argument_Count then ! Fail ("directory list file name missing"); ! end if; ! ! else ! Get_Directories (Arg (3 .. Arg'Last)); ! end if; ! ! -- -eL ! ! elsif Arg = "-eL" then ! Opt.Follow_Links_For_Files := True; ! ! -- -f ! ! elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-f" then ! if Arg'Length = 2 then ! Foreign_Pattern_Expected := True; ! ! if Next_Arg = Argument_Count then ! Fail ("foreign pattern missing"); ! end if; ! ! else ! Patterns.Append ! (Arguments.Table (Arguments.Last).Foreign_Patterns, ! new String'(Arg (3 .. Arg'Last))); ! Check_Regular_Expression (Arg (3 .. Arg'Last)); ! end if; ! ! -- -gnatep or -gnateD ! ! elsif Arg'Length > 7 and then ! (Arg (1 .. 7) = "-gnatep" or else Arg (1 .. 7) = "-gnateD") ! then ! Preprocessor_Switches.Append (new String'(Arg)); ! ! -- -h ! ! elsif Arg = "-h" then ! Usage_Needed := True; ! ! -- -p ! ! elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-P" then ! if File_Set then ! Fail ("only one -c or -P switch may be specified"); ! end if; ! ! if Arg'Length = 2 then ! if Next_Arg = Argument_Count then ! Fail ("project file name missing"); ! ! else ! Project_File_Name_Expected := True; ! end if; ! ! else ! File_Set := True; ! File_Path := new String'(Arg (3 .. Arg'Last)); ! end if; ! ! Create_Project := True; ! ! -- -v ! ! elsif Arg = "-v" then ! if Opt.Verbose_Mode then ! Very_Verbose := True; ! else ! Opt.Verbose_Mode := True; ! end if; ! ! -- -x ! ! elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-x" then ! if Arg'Length = 2 then ! Excluded_Pattern_Expected := True; ! ! if Next_Arg = Argument_Count then ! Fail ("excluded pattern missing"); ! end if; ! ! else ! Patterns.Append ! (Arguments.Table (Arguments.Last).Excluded_Patterns, ! new String'(Arg (3 .. Arg'Last))); ! Check_Regular_Expression (Arg (3 .. Arg'Last)); ! end if; ! ! -- Junk switch starting with minus ! ! elsif Arg (1) = '-' then ! Fail ("wrong switch: " & Arg); ! ! -- Not a recognized switch, assume file name ! ! else ! Canonical_Case_File_Name (Arg); ! Patterns.Append ! (Arguments.Table (Arguments.Last).Name_Patterns, ! new String'(Arg)); ! Check_Regular_Expression (Arg); ! end if; ! end if; end; end loop; end Scan_Args; ----------- *************** procedure Gnatname is *** 283,295 **** --- 494,515 ---- Write_Str ("Usage: "); Osint.Write_Program_Name; Write_Line (" [switches] naming-pattern [naming-patterns]"); + Write_Line (" {--and [switches] naming-pattern [naming-patterns]}"); Write_Eol; Write_Line ("switches:"); + Write_Line (" --subdirs=dir real obj/lib/exec dirs are subdirs"); + Write_Eol; + + Write_Line (" --and use different patterns"); + Write_Eol; + Write_Line (" -cfile create configuration pragmas file"); Write_Line (" -ddir use dir as one of the source " & "directories"); Write_Line (" -Dfile get source directories from file"); + Write_Line (" -eL follow symbolic links when processing " & + "project files"); Write_Line (" -fpat foreign pattern"); Write_Line (" -gnateDsym=v preprocess with symbol definition"); Write_Line (" -gnatep=data preprocess files with data file"); *************** begin *** 325,332 **** PATH : constant String := Absolute_Dir & ! Path_Separator & ! Getenv ("PATH").all; begin Setenv ("PATH", PATH); --- 545,552 ---- PATH : constant String := Absolute_Dir & ! Path_Separator & ! Getenv ("PATH").all; begin Setenv ("PATH", PATH); *************** begin *** 340,349 **** -- Initialize tables ! Excluded_Patterns.Set_Last (0); ! Foreign_Patterns.Set_Last (0); ! Patterns.Set_Last (0); ! Source_Directories.Set_Last (0); Preprocessor_Switches.Set_Last (0); -- Get the arguments --- 560,576 ---- -- Initialize tables ! Arguments.Set_Last (0); ! Arguments.Increment_Last; ! Patterns.Init (Arguments.Table (1).Directories); ! Patterns.Set_Last (Arguments.Table (1).Directories, 0); ! Patterns.Init (Arguments.Table (1).Name_Patterns); ! Patterns.Set_Last (Arguments.Table (1).Name_Patterns, 0); ! Patterns.Init (Arguments.Table (1).Excluded_Patterns); ! Patterns.Set_Last (Arguments.Table (1).Excluded_Patterns, 0); ! Patterns.Init (Arguments.Table (1).Foreign_Patterns); ! Patterns.Set_Last (Arguments.Table (1).Foreign_Patterns, 0); ! Preprocessor_Switches.Set_Last (0); -- Get the arguments *************** begin *** 358,366 **** Usage; end if; ! -- If no pattern was specified, print the usage and return ! if Patterns.Last = 0 and Foreign_Patterns.Last = 0 then Usage; return; end if; --- 585,596 ---- Usage; end if; ! -- If no Ada or foreign pattern was specified, print the usage and return ! if Patterns.Last (Arguments.Table (Arguments.Last).Name_Patterns) = 0 ! and then ! Patterns.Last (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0 ! then Usage; return; end if; *************** begin *** 370,424 **** -- information, the current directory is the directory of the specified -- file. ! if Source_Directories.Last = 0 then ! Source_Directories.Increment_Last; ! Source_Directories.Table (Source_Directories.Last) := new String'("."); end if; declare - Directories : Argument_List (1 .. Integer (Source_Directories.Last)); - Name_Patterns : Argument_List (1 .. Integer (Patterns.Last)); - Excl_Patterns : Argument_List (1 .. Integer (Excluded_Patterns.Last)); - Frgn_Patterns : Argument_List (1 .. Integer (Foreign_Patterns.Last)); Prep_Switches : Argument_List (1 .. Integer (Preprocessor_Switches.Last)); begin - -- Build the Directories and Name_Patterns arguments - - for Index in Directories'Range loop - Directories (Index) := Source_Directories.Table (Index); - end loop; - - for Index in Name_Patterns'Range loop - Name_Patterns (Index) := Patterns.Table (Index); - end loop; - - for Index in Excl_Patterns'Range loop - Excl_Patterns (Index) := Excluded_Patterns.Table (Index); - end loop; - - for Index in Frgn_Patterns'Range loop - Frgn_Patterns (Index) := Foreign_Patterns.Table (Index); - end loop; - for Index in Prep_Switches'Range loop Prep_Switches (Index) := Preprocessor_Switches.Table (Index); end loop; ! -- Call Prj.Makr.Make where the real work is done ! ! Prj.Makr.Make (File_Path => File_Path.all, Project_File => Create_Project, - Directories => Directories, - Name_Patterns => Name_Patterns, - Excluded_Patterns => Excl_Patterns, - Foreign_Patterns => Frgn_Patterns, Preproc_Switches => Prep_Switches, Very_Verbose => Very_Verbose); end; if Opt.Verbose_Mode then Write_Eol; end if; --- 600,690 ---- -- information, the current directory is the directory of the specified -- file. ! if Patterns.Last ! (Arguments.Table (Arguments.Last).Directories) = 0 ! then ! Patterns.Append ! (Arguments.Table (Arguments.Last).Directories, new String'(".")); end if; + -- Initialize + declare Prep_Switches : Argument_List (1 .. Integer (Preprocessor_Switches.Last)); begin for Index in Prep_Switches'Range loop Prep_Switches (Index) := Preprocessor_Switches.Table (Index); end loop; ! Prj.Makr.Initialize (File_Path => File_Path.all, Project_File => Create_Project, Preproc_Switches => Prep_Switches, Very_Verbose => Very_Verbose); end; + -- Process each section successively + + for J in 1 .. Arguments.Last loop + declare + Directories : Argument_List + (1 .. Integer + (Patterns.Last (Arguments.Table (J).Directories))); + Name_Patterns : Prj.Makr.Regexp_List + (1 .. Integer + (Patterns.Last (Arguments.Table (J).Name_Patterns))); + Excl_Patterns : Prj.Makr.Regexp_List + (1 .. Integer + (Patterns.Last (Arguments.Table (J).Excluded_Patterns))); + Frgn_Patterns : Prj.Makr.Regexp_List + (1 .. Integer + (Patterns.Last (Arguments.Table (J).Foreign_Patterns))); + + begin + -- Build the Directories and Patterns arguments + + for Index in Directories'Range loop + Directories (Index) := + Arguments.Table (J).Directories.Table (Index); + end loop; + + for Index in Name_Patterns'Range loop + Name_Patterns (Index) := + Compile + (Arguments.Table (J).Name_Patterns.Table (Index).all, + Glob => True); + end loop; + + for Index in Excl_Patterns'Range loop + Excl_Patterns (Index) := + Compile + (Arguments.Table (J).Excluded_Patterns.Table (Index).all, + Glob => True); + end loop; + + for Index in Frgn_Patterns'Range loop + Frgn_Patterns (Index) := + Compile + (Arguments.Table (J).Foreign_Patterns.Table (Index).all, + Glob => True); + end loop; + + -- Call Prj.Makr.Process where the real work is done + + Prj.Makr.Process + (Directories => Directories, + Name_Patterns => Name_Patterns, + Excluded_Patterns => Excl_Patterns, + Foreign_Patterns => Frgn_Patterns); + end; + end loop; + + -- Finalize + + Prj.Makr.Finalize; + if Opt.Verbose_Mode then Write_Eol; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/gnatvsn.adb gcc-4.4.0/gcc/ada/gnatvsn.adb *** gcc-4.3.3/gcc/ada/gnatvsn.adb Fri Aug 31 10:19:18 2007 --- gcc-4.4.0/gcc/ada/gnatvsn.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/gnatvsn.ads gcc-4.4.0/gcc/ada/gnatvsn.ads *** gcc-4.3.3/gcc/ada/gnatvsn.ads Wed Sep 26 10:42:09 2007 --- gcc-4.4.0/gcc/ada/gnatvsn.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 36,50 **** package Gnatvsn is function Gnat_Version_String return String; -- Version output when GNAT (compiler), or its related tools, including -- GNATBIND, GNATCHOP, GNATFIND, GNATLINK, GNATMAKE, GNATXREF, are run -- (with appropriate verbose option switch set). - Gnat_Static_Version_String : constant String := "GNU Ada"; - -- Static string identifying this version, that can be used as an argument - -- to e.g. pragma Ident. - type Gnat_Build_Type is (FSF, GPL); -- See Build_Type below for the meaning of these values. --- 34,48 ---- package Gnatvsn is + Gnat_Static_Version_String : constant String := "GNU Ada"; + -- Static string identifying this version, that can be used as an argument + -- to e.g. pragma Ident. + function Gnat_Version_String return String; -- Version output when GNAT (compiler), or its related tools, including -- GNATBIND, GNATCHOP, GNATFIND, GNATLINK, GNATMAKE, GNATXREF, are run -- (with appropriate verbose option switch set). type Gnat_Build_Type is (FSF, GPL); -- See Build_Type below for the meaning of these values. *************** package Gnatvsn is *** 79,85 **** -- value should never be decreased in the future, but it would be -- OK to increase it if absolutely necessary. ! Library_Version : constant String := "4.3"; -- Library version. This value must be updated whenever any change to the -- compiler affects the library formats in such a way as to obsolete -- previously compiled library modules. --- 77,83 ---- -- value should never be decreased in the future, but it would be -- OK to increase it if absolutely necessary. ! Library_Version : constant String := "4.4"; -- Library version. This value must be updated whenever any change to the -- compiler affects the library formats in such a way as to obsolete -- previously compiled library modules. *************** package Gnatvsn is *** 90,96 **** Verbose_Library_Version : constant String := "GNAT Lib v" & Library_Version; -- Version string stored in e.g. ALI files. ! Current_Year : constant String := "2007"; -- Used in printing copyright messages end Gnatvsn; --- 88,94 ---- Verbose_Library_Version : constant String := "GNAT Lib v" & Library_Version; -- Version string stored in e.g. ALI files. ! Current_Year : constant String := "2008"; -- Used in printing copyright messages end Gnatvsn; diff -Nrcpad gcc-4.3.3/gcc/ada/gnatxref.adb gcc-4.4.0/gcc/ada/gnatxref.adb *** gcc-4.3.3/gcc/ada/gnatxref.adb Thu Dec 13 10:23:29 2007 --- gcc-4.4.0/gcc/ada/gnatxref.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2008, 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- -- *************** procedure Gnatxref is *** 114,120 **** when 'n' => if GNAT.Command_Line.Full_Switch = "nostdinc" then Opt.No_Stdinc := True; ! elsif GNAT.Command_Line.Full_Switch = "nostlib" then Opt.No_Stdlib := True; end if; --- 114,120 ---- when 'n' => if GNAT.Command_Line.Full_Switch = "nostdinc" then Opt.No_Stdinc := True; ! elsif GNAT.Command_Line.Full_Switch = "nostdlib" then Opt.No_Stdlib := True; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/gprep.adb gcc-4.4.0/gcc/ada/gprep.adb *** gcc-4.3.3/gcc/ada/gprep.adb Thu Dec 13 10:23:29 2007 --- gcc-4.4.0/gcc/ada/gprep.adb Mon Aug 4 09:17:44 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2008, 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- -- *************** package body GPrep is *** 444,450 **** Symbol := Index_Of (Data.Symbol); ! -- If symbol does not alrady exist, create a new entry in the mapping -- table. if Symbol = No_Symbol then --- 444,450 ---- Symbol := Index_Of (Data.Symbol); ! -- If symbol does not already exist, create a new entry in the mapping -- table. if Symbol = No_Symbol then *************** package body GPrep is *** 475,480 **** --- 475,483 ---- procedure Process_One_File is Infile : Source_File_Index; + Modified : Boolean; + pragma Warnings (Off, Modified); + begin -- Create the output file (fails if this does not work) *************** package body GPrep is *** 515,521 **** -- Preprocess the input file ! Prep.Preprocess; -- In verbose mode, if there is no error, report it --- 518,524 ---- -- Preprocess the input file ! Prep.Preprocess (Modified); -- In verbose mode, if there is no error, report it *************** package body GPrep is *** 778,784 **** elsif Deffile_Name = No_Name then Deffile_Name := Name_Find; else ! Fail ("too many arguments specifed"); end if; end; end loop; --- 781,787 ---- elsif Deffile_Name = No_Name then Deffile_Name := Name_Find; else ! Fail ("too many arguments specified"); end if; end; end loop; diff -Nrcpad gcc-4.3.3/gcc/ada/gprmake.adb gcc-4.4.0/gcc/ada/gprmake.adb *** gcc-4.3.3/gcc/ada/gprmake.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/gprmake.adb Thu Jan 1 00:00:00 1970 *************** *** 1,35 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G P R M A K E -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2004-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- The driver for the gprmake tool - - with Makegpr; - - procedure Gprmake is - begin - -- The code is in Makegpr - - Makegpr.Gprmake; - end Gprmake; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/gsocket.h gcc-4.4.0/gcc/ada/gsocket.h *** gcc-4.3.3/gcc/ada/gsocket.h Wed Feb 13 19:04:53 2008 --- gcc-4.4.0/gcc/ada/gsocket.h Thu Apr 9 23:23:07 2009 *************** *** 6,35 **** * * * C Header File * * * ! * Copyright (C) 2004-2008, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * * * ****************************************************************************/ #ifndef _XOPEN_SOURCE_EXTENDED #define _XOPEN_SOURCE_EXTENDED 1 /* For HP-UX */ --- 6,43 ---- * * * C Header File * * * ! * Copyright (C) 2004-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * * * ****************************************************************************/ + #if defined(__nucleus__) + + #warning Sockets not supported on this platform + #undef HAVE_SOCKETS + + #else + + #define HAVE_SOCKETS + #ifndef _XOPEN_SOURCE_EXTENDED #define _XOPEN_SOURCE_EXTENDED 1 /* For HP-UX */ *************** *** 51,56 **** --- 59,65 ---- #endif #include + #include #if defined(__vxworks) #include *************** *** 69,116 **** #include #include ! #define EACCES WSAEACCES ! #define EADDRINUSE WSAEADDRINUSE ! #define EADDRNOTAVAIL WSAEADDRNOTAVAIL ! #define EAFNOSUPPORT WSAEAFNOSUPPORT ! #define EALREADY WSAEALREADY ! #define EBADF WSAEBADF ! #define ECONNABORTED WSAECONNABORTED ! #define ECONNREFUSED WSAECONNREFUSED ! #define ECONNRESET WSAECONNRESET ! #define EDESTADDRREQ WSAEDESTADDRREQ ! #define EFAULT WSAEFAULT ! #define EHOSTDOWN WSAEHOSTDOWN ! #define EHOSTUNREACH WSAEHOSTUNREACH ! #define EINPROGRESS WSAEINPROGRESS ! #define EINTR WSAEINTR ! #define EINVAL WSAEINVAL ! #define EIO WSAEDISCON ! #define EISCONN WSAEISCONN ! #define ELOOP WSAELOOP ! #define EMFILE WSAEMFILE ! #define EMSGSIZE WSAEMSGSIZE ! #define ENAMETOOLONG WSAENAMETOOLONG ! #define ENETDOWN WSAENETDOWN ! #define ENETRESET WSAENETRESET ! #define ENETUNREACH WSAENETUNREACH ! #define ENOBUFS WSAENOBUFS ! #define ENOPROTOOPT WSAENOPROTOOPT ! #define ENOTCONN WSAENOTCONN ! #define ENOTSOCK WSAENOTSOCK ! #define EOPNOTSUPP WSAEOPNOTSUPP ! #define EPFNOSUPPORT WSAEPFNOSUPPORT ! #define EPROTONOSUPPORT WSAEPROTONOSUPPORT ! #define ENOTSOCK WSAENOTSOCK ! #define EOPNOTSUPP WSAEOPNOTSUPP ! #define EPFNOSUPPORT WSAEPFNOSUPPORT ! #define EPROTONOSUPPORT WSAEPROTONOSUPPORT ! #define EPROTOTYPE WSAEPROTOTYPE ! #define ESHUTDOWN WSAESHUTDOWN ! #define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT ! #define ETIMEDOUT WSAETIMEDOUT ! #define ETOOMANYREFS WSAETOOMANYREFS ! #define EWOULDBLOCK WSAEWOULDBLOCK #define SHUT_RD SD_RECEIVE #define SHUT_WR SD_SEND #define SHUT_RDWR SD_BOTH --- 78,160 ---- #include #include ! #undef EACCES ! #define EACCES WSAEACCES ! #undef EADDRINUSE ! #define EADDRINUSE WSAEADDRINUSE ! #undef EADDRNOTAVAIL ! #define EADDRNOTAVAIL WSAEADDRNOTAVAIL ! #undef EAFNOSUPPORT ! #define EAFNOSUPPORT WSAEAFNOSUPPORT ! #undef EALREADY ! #define EALREADY WSAEALREADY ! #undef EBADF ! #define EBADF WSAEBADF ! #undef ECONNABORTED ! #define ECONNABORTED WSAECONNABORTED ! #undef ECONNREFUSED ! #define ECONNREFUSED WSAECONNREFUSED ! #undef ECONNRESET ! #define ECONNRESET WSAECONNRESET ! #undef EDESTADDRREQ ! #define EDESTADDRREQ WSAEDESTADDRREQ ! #undef EFAULT ! #define EFAULT WSAEFAULT ! #undef EHOSTDOWN ! #define EHOSTDOWN WSAEHOSTDOWN ! #undef EHOSTUNREACH ! #define EHOSTUNREACH WSAEHOSTUNREACH ! #undef EINPROGRESS ! #define EINPROGRESS WSAEINPROGRESS ! #undef EINTR ! #define EINTR WSAEINTR ! #undef EINVAL ! #define EINVAL WSAEINVAL ! #undef EIO ! #define EIO WSAEDISCON ! #undef EISCONN ! #define EISCONN WSAEISCONN ! #undef ELOOP ! #define ELOOP WSAELOOP ! #undef EMFILE ! #define EMFILE WSAEMFILE ! #undef EMSGSIZE ! #define EMSGSIZE WSAEMSGSIZE ! #undef ENAMETOOLONG ! #define ENAMETOOLONG WSAENAMETOOLONG ! #undef ENETDOWN ! #define ENETDOWN WSAENETDOWN ! #undef ENETRESET ! #define ENETRESET WSAENETRESET ! #undef ENETUNREACH ! #define ENETUNREACH WSAENETUNREACH ! #undef ENOBUFS ! #define ENOBUFS WSAENOBUFS ! #undef ENOPROTOOPT ! #define ENOPROTOOPT WSAENOPROTOOPT ! #undef ENOTCONN ! #define ENOTCONN WSAENOTCONN ! #undef ENOTSOCK ! #define ENOTSOCK WSAENOTSOCK ! #undef EOPNOTSUPP ! #define EOPNOTSUPP WSAEOPNOTSUPP ! #undef EPFNOSUPPORT ! #define EPFNOSUPPORT WSAEPFNOSUPPORT ! #undef EPROTONOSUPPORT ! #define EPROTONOSUPPORT WSAEPROTONOSUPPORT ! #undef EPROTOTYPE ! #define EPROTOTYPE WSAEPROTOTYPE ! #undef ESHUTDOWN ! #define ESHUTDOWN WSAESHUTDOWN ! #undef ESOCKTNOSUPPORT ! #define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT ! #undef ETIMEDOUT ! #define ETIMEDOUT WSAETIMEDOUT ! #undef ETOOMANYREFS ! #define ETOOMANYREFS WSAETOOMANYREFS ! #undef EWOULDBLOCK ! #define EWOULDBLOCK WSAEWOULDBLOCK ! #define SHUT_RD SD_RECEIVE #define SHUT_WR SD_SEND #define SHUT_RDWR SD_BOTH *************** *** 129,138 **** #endif - #ifndef __MINGW32__ - #include - #endif - #ifdef __vxworks #include #else --- 173,178 ---- *************** *** 175,181 **** #if defined (_AIX) || defined (__FreeBSD__) || defined (__hpux__) || defined (__osf__) || defined (_WIN32) || defined (__APPLE__) # define HAVE_THREAD_SAFE_GETxxxBYyyy 1 ! #elif defined (sgi) || defined (linux) || (defined (sun) && defined (__SVR4) && !defined (__vxworks)) # define HAVE_GETxxxBYyyy_R 1 #endif --- 215,221 ---- #if defined (_AIX) || defined (__FreeBSD__) || defined (__hpux__) || defined (__osf__) || defined (_WIN32) || defined (__APPLE__) # define HAVE_THREAD_SAFE_GETxxxBYyyy 1 ! #elif defined (sgi) || defined (linux) || defined (__GLIBC__) || (defined (sun) && defined (__SVR4) && !defined (__vxworks)) || defined(__rtems__) # define HAVE_GETxxxBYyyy_R 1 #endif *************** *** 184,186 **** --- 224,234 ---- #else # define Need_Netdb_Buffer 0 #endif + + #if defined (__FreeBSD__) || defined (__vxworks) || defined(__rtems__) + # define Has_Sockaddr_Len 1 + #else + # define Has_Sockaddr_Len 0 + #endif + + #endif /* defined(__nucleus__) */ diff -Nrcpad gcc-4.3.3/gcc/ada/hostparm.ads gcc-4.4.0/gcc/ada/hostparm.ads *** gcc-4.3.3/gcc/ada/hostparm.ads Wed Jun 6 10:31:39 2007 --- gcc-4.4.0/gcc/ada/hostparm.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-c.adb gcc-4.4.0/gcc/ada/i-c.adb *** gcc-4.3.3/gcc/ada/i-c.adb Fri Dec 9 17:22:27 2005 --- gcc-4.4.0/gcc/ada/i-c.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-cexten.ads gcc-4.4.0/gcc/ada/i-cexten.ads *** gcc-4.3.3/gcc/ada/i-cexten.ads Fri Dec 9 17:22:27 2005 --- gcc-4.4.0/gcc/ada/i-cexten.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-cobol.adb gcc-4.4.0/gcc/ada/i-cobol.adb *** gcc-4.3.3/gcc/ada/i-cobol.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/i-cobol.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Interfaces.COBOL is *** 337,343 **** -- Here a swap is needed declare ! Len : constant Natural := B'Length; begin for J in 1 .. Len / 2 loop --- 335,341 ---- -- Here a swap is needed declare ! Len : constant Natural := B'Length; begin for J in 1 .. Len / 2 loop *************** package body Interfaces.COBOL is *** 452,461 **** -- Used for the nonseparate formats to embed the appropriate sign -- at the specified location (i.e. at Result (Loc)) procedure Convert (First, Last : Natural) is ! J : Natural := Last; begin while J >= First loop Result (J) := COBOL_Character'Val --- 450,464 ---- -- Used for the nonseparate formats to embed the appropriate sign -- at the specified location (i.e. at Result (Loc)) + ------------- + -- Convert -- + ------------- + procedure Convert (First, Last : Natural) is ! J : Natural; begin + J := Last; while J >= First loop Result (J) := COBOL_Character'Val *************** package body Interfaces.COBOL is *** 478,483 **** --- 481,490 ---- raise Conversion_Error; end Convert; + ---------------- + -- Embed_Sign -- + ---------------- + procedure Embed_Sign (Loc : Natural) is Digit : Natural range 0 .. 9; *************** package body Interfaces.COBOL is *** 559,564 **** --- 566,575 ---- -- storing the result in Result (First .. Last). Raise Conversion_Error -- if the value is too large to fit. + ------------- + -- Convert -- + ------------- + procedure Convert (First, Last : Natural) is J : Natural := Last; diff -Nrcpad gcc-4.3.3/gcc/ada/i-cobol.ads gcc-4.4.0/gcc/ada/i-cobol.ads *** gcc-4.3.3/gcc/ada/i-cobol.ads Fri Dec 9 17:22:27 2005 --- gcc-4.4.0/gcc/ada/i-cobol.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (ASCII Version) -- -- -- ! -- Copyright (C) 1993-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (ASCII Version) -- -- -- ! -- Copyright (C) 1993-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 42,47 **** --- 40,46 ---- -- type Standard.Character. package Interfaces.COBOL is + pragma Preelaborate (COBOL); ------------------------------------------------------------ -- Types And Operations For Internal Data Representations -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-cpoint.adb gcc-4.4.0/gcc/ada/i-cpoint.adb *** gcc-4.3.3/gcc/ada/i-cpoint.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/i-cpoint.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-cpoint.ads gcc-4.4.0/gcc/ada/i-cpoint.ads *** gcc-4.3.3/gcc/ada/i-cpoint.ads Fri Dec 9 17:22:27 2005 --- gcc-4.4.0/gcc/ada/i-cpoint.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1993-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1993-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-cpp.adb gcc-4.4.0/gcc/ada/i-cpp.adb *** gcc-4.3.3/gcc/ada/i-cpp.adb Fri Dec 9 17:22:27 2005 --- gcc-4.4.0/gcc/ada/i-cpp.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-cpp.ads gcc-4.4.0/gcc/ada/i-cpp.ads *** gcc-4.3.3/gcc/ada/i-cpp.ads Fri Dec 9 17:22:27 2005 --- gcc-4.4.0/gcc/ada/i-cpp.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-cstrea-vms.adb gcc-4.4.0/gcc/ada/i-cstrea-vms.adb *** gcc-4.3.3/gcc/ada/i-cstrea-vms.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/i-cstrea-vms.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Interfaces.C_Streams is *** 229,235 **** -- In order for the above fwrite hack to work, we must always buffer -- stdout and stderr. Is_regular_file on VMS cannot detect when -- these are redirected to a file, so checking for that condition ! -- doesnt help. if mode = IONBF and then (stream = stdout or else stream = stderr) --- 227,233 ---- -- In order for the above fwrite hack to work, we must always buffer -- stdout and stderr. Is_regular_file on VMS cannot detect when -- these are redirected to a file, so checking for that condition ! -- doesn't help. if mode = IONBF and then (stream = stdout or else stream = stderr) diff -Nrcpad gcc-4.3.3/gcc/ada/i-cstrea.adb gcc-4.4.0/gcc/ada/i-cstrea.adb *** gcc-4.3.3/gcc/ada/i-cstrea.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/i-cstrea.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-cstrea.ads gcc-4.4.0/gcc/ada/i-cstrea.ads *** gcc-4.3.3/gcc/ada/i-cstrea.ads Fri Apr 6 09:23:12 2007 --- gcc-4.4.0/gcc/ada/i-cstrea.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-cstrin.adb gcc-4.4.0/gcc/ada/i-cstrin.adb *** gcc-4.3.3/gcc/ada/i-cstrin.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/i-cstrin.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Interfaces.C.Strings is *** 109,115 **** Pointer : chars_ptr; begin ! -- Get index of position of null. If Index > Chars'last, -- nul is absent and must be added explicitly. Index := Position_Of_Nul (Into => Chars); --- 107,113 ---- Pointer : chars_ptr; begin ! -- Get index of position of null. If Index > Chars'Last, -- nul is absent and must be added explicitly. Index := Position_Of_Nul (Into => Chars); *************** package body Interfaces.C.Strings is *** 130,136 **** Offset => 0, Chars => Chars, Check => False); ! Poke (nul, into => Pointer + size_t'(Chars'Length)); end if; return Pointer; --- 128,134 ---- Offset => 0, Chars => Chars, Check => False); ! Poke (nul, Into => Pointer + size_t'(Chars'Length)); end if; return Pointer; diff -Nrcpad gcc-4.3.3/gcc/ada/i-cstrin.ads gcc-4.4.0/gcc/ada/i-cstrin.ads *** gcc-4.3.3/gcc/ada/i-cstrin.ads Wed Nov 14 15:14:45 2007 --- gcc-4.4.0/gcc/ada/i-cstrin.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1993-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1993-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-forbla-darwin.adb gcc-4.4.0/gcc/ada/i-forbla-darwin.adb *** gcc-4.3.3/gcc/ada/i-forbla-darwin.adb Wed Jun 6 10:54:04 2007 --- gcc-4.4.0/gcc/ada/i-forbla-darwin.adb Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- INTERFACES.FORTRAN.BLAS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- I N T E R F A C E S . F O R T R A N . B L A S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-forbla-unimplemented.ads gcc-4.4.0/gcc/ada/i-forbla-unimplemented.ads *** gcc-4.3.3/gcc/ada/i-forbla-unimplemented.ads Thu Dec 13 10:50:30 2007 --- gcc-4.4.0/gcc/ada/i-forbla-unimplemented.ads Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- INTERFACES.FORTRAN.BLAS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- I N T E R F A C E S . F O R T R A N . B L A S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-forbla.adb gcc-4.4.0/gcc/ada/i-forbla.adb *** gcc-4.3.3/gcc/ada/i-forbla.adb Tue Aug 14 08:50:51 2007 --- gcc-4.4.0/gcc/ada/i-forbla.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 32,43 **** ------------------------------------------------------------------------------ -- This Interfaces.Fortran.Blas package body contains the required linker ! -- pragmas for automatically linking with the gnalasup linear algebra support -- library, and the systems math library. Alternative bodies can be supplied -- if different sets of libraries are needed. package body Interfaces.Fortran.BLAS is pragma Linker_Options ("-lgnala"); ! pragma Linker_Options ("-lgnalasup"); pragma Linker_Options ("-lm"); end Interfaces.Fortran.BLAS; --- 30,42 ---- ------------------------------------------------------------------------------ -- This Interfaces.Fortran.Blas package body contains the required linker ! -- pragmas for automatically linking with the LAPACK linear algebra support -- library, and the systems math library. Alternative bodies can be supplied -- if different sets of libraries are needed. package body Interfaces.Fortran.BLAS is pragma Linker_Options ("-lgnala"); ! pragma Linker_Options ("-llapack"); ! pragma Linker_Options ("-lblas"); pragma Linker_Options ("-lm"); end Interfaces.Fortran.BLAS; diff -Nrcpad gcc-4.3.3/gcc/ada/i-forbla.ads gcc-4.4.0/gcc/ada/i-forbla.ads *** gcc-4.3.3/gcc/ada/i-forbla.ads Tue Aug 14 08:50:51 2007 --- gcc-4.4.0/gcc/ada/i-forbla.ads Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- INTERFACES.FORTRAN.BLAS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- I N T E R F A C E S . F O R T R A N . B L A S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-forlap.ads gcc-4.4.0/gcc/ada/i-forlap.ads *** gcc-4.3.3/gcc/ada/i-forlap.ads Tue Aug 14 08:50:51 2007 --- gcc-4.4.0/gcc/ada/i-forlap.ads Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- INTERFACES.FORTRAN.LAPACK -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- I N T E R F A C E S . F O R T R A N . L A P A C K -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-fortra.adb gcc-4.4.0/gcc/ada/i-fortra.adb *** gcc-4.3.3/gcc/ada/i-fortra.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/i-fortra.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-pacdec.adb gcc-4.4.0/gcc/ada/i-pacdec.adb *** gcc-4.3.3/gcc/ada/i-pacdec.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/i-pacdec.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (Version for IBM Mainframe Packed Decimal Format) -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- B o d y -- -- (Version for IBM Mainframe Packed Decimal Format) -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-pacdec.ads gcc-4.4.0/gcc/ada/i-pacdec.ads *** gcc-4.3.3/gcc/ada/i-pacdec.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/i-pacdec.ads Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- S p e c -- -- (Version for IBM Mainframe Packed Decimal Format) -- -- -- ! -- Copyright (C) 1992-2003 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- S p e c -- -- (Version for IBM Mainframe Packed Decimal Format) -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 33,39 **** ------------------------------------------------------------------------------ -- This unit defines the packed decimal format used by GNAT in response to ! -- a specication of Machine_Radix 10 for a decimal fixed-point type. The -- format and operations are completely encapsulated in this unit, so all -- that is necessary to compile using different packed decimal formats is -- to replace this single unit. --- 31,37 ---- ------------------------------------------------------------------------------ -- This unit defines the packed decimal format used by GNAT in response to ! -- a specification of Machine_Radix 10 for a decimal fixed-point type. The -- format and operations are completely encapsulated in this unit, so all -- that is necessary to compile using different packed decimal formats is -- to replace this single unit. diff -Nrcpad gcc-4.3.3/gcc/ada/i-vxwoio.adb gcc-4.4.0/gcc/ada/i-vxwoio.adb *** gcc-4.3.3/gcc/ada/i-vxwoio.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/i-vxwoio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-vxwoio.ads gcc-4.4.0/gcc/ada/i-vxwoio.ads *** gcc-4.3.3/gcc/ada/i-vxwoio.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/i-vxwoio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-vxwork-x86.ads gcc-4.4.0/gcc/ada/i-vxwork-x86.ads *** gcc-4.3.3/gcc/ada/i-vxwork-x86.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/i-vxwork-x86.ads Tue Apr 8 06:44:39 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- GNARL 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- -- *************** package Interfaces.VxWorks is *** 76,82 **** -- procedure Handler (Parameter : System.Address) is -- begin -- Count := Count + 1; ! -- logMsg ("received an interrupt" & ASCII.LF & ASCII.Nul); -- end Handler; -- end P; -- --- 76,82 ---- -- procedure Handler (Parameter : System.Address) is -- begin -- Count := Count + 1; ! -- logMsg ("received an interrupt" & ASCII.LF & ASCII.NUL); -- end Handler; -- end P; -- diff -Nrcpad gcc-4.3.3/gcc/ada/i-vxwork.ads gcc-4.4.0/gcc/ada/i-vxwork.ads *** gcc-4.3.3/gcc/ada/i-vxwork.ads Thu Dec 13 10:46:43 2007 --- gcc-4.4.0/gcc/ada/i-vxwork.ads Tue Apr 8 06:44:39 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- GNARL 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- -- *************** *** 47,53 **** pragma Warnings (Off, "*foreign convention*"); pragma Warnings (Off, "*add Convention pragma*"); ! -- These are temporary pragmas to supress warnings about mismatching -- conventions, which will be a problem when we get rid of trampolines ??? with System.VxWorks; --- 47,53 ---- pragma Warnings (Off, "*foreign convention*"); pragma Warnings (Off, "*add Convention pragma*"); ! -- These are temporary pragmas to suppress warnings about mismatching -- conventions, which will be a problem when we get rid of trampolines ??? with System.VxWorks; *************** package Interfaces.VxWorks is *** 80,86 **** -- S : STATUS; -- begin -- Count := Count + 1; ! -- logMsg ("received an interrupt" & ASCII.LF & ASCII.Nul); -- -- -- Acknowledge VME interrupt -- S := sysBusIntAck (intLevel => Level); --- 80,86 ---- -- S : STATUS; -- begin -- Count := Count + 1; ! -- logMsg ("received an interrupt" & ASCII.LF & ASCII.NUL); -- -- -- Acknowledge VME interrupt -- S := sysBusIntAck (intLevel => Level); *************** package Interfaces.VxWorks is *** 175,181 **** -- Binding to the C routine sysBusIntGen. Note that the T2 -- documentation implies that a vector address is the proper -- argument - it's not. The interrupt number in the range ! -- 0 .. 255 (for 68K and PPC) is the correct agument. procedure logMsg (fmt : String; arg1, arg2, arg3, arg4, arg5, arg6 : int := 0); --- 175,181 ---- -- Binding to the C routine sysBusIntGen. Note that the T2 -- documentation implies that a vector address is the proper -- argument - it's not. The interrupt number in the range ! -- 0 .. 255 (for 68K and PPC) is the correct argument. procedure logMsg (fmt : String; arg1, arg2, arg3, arg4, arg5, arg6 : int := 0); diff -Nrcpad gcc-4.3.3/gcc/ada/impunit.adb gcc-4.4.0/gcc/ada/impunit.adb *** gcc-4.3.3/gcc/ada/impunit.adb Thu Dec 13 10:44:45 2007 --- gcc-4.4.0/gcc/ada/impunit.adb Tue Apr 8 06:57:39 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2008, 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- -- *************** package body Impunit is *** 42,54 **** -- Ada 95 Units -- ------------------ ! -- The following is a giant string list containing the names of all ! -- non-implementation internal files, i.e. the complete list of files for -- internal units which a program may legitimately WITH when operating in -- either Ada 95 or Ada 05 mode. -- Note that this list should match the list of units documented in the ! -- "GNAT Library" section of the GNAT Reference Manual. Non_Imp_File_Names_95 : constant File_List := ( --- 42,55 ---- -- Ada 95 Units -- ------------------ ! -- The following is a giant string list containing the names of all non- ! -- implementation internal files, i.e. the complete list of files for -- internal units which a program may legitimately WITH when operating in -- either Ada 95 or Ada 05 mode. -- Note that this list should match the list of units documented in the ! -- "GNAT Library" section of the GNAT Reference Manual. A unit listed here ! -- must either be documented in that section or described in the Ada RM. Non_Imp_File_Names_95 : constant File_List := ( *************** package body Impunit is *** 146,151 **** --- 147,153 ---- -- GNAT Defined Additions to Ada -- ----------------------------------- + "a-calcon", -- Ada.Calendar.Conversions "a-chlat9", -- Ada.Characters.Latin_9 "a-clrefi", -- Ada.Command_Line.Response_File "a-colien", -- Ada.Command_Line.Environment *************** package body Impunit is *** 160,166 **** "a-ssicst", -- Ada.Streams.Stream_IO.C_Streams "a-suteio", -- Ada.Strings.Unbounded.Text_IO "a-swuwti", -- Ada.Strings.Wide_Unbounded.Wide_Text_IO - "a-taidim", -- Ada.Task_Identification.Image "a-tiocst", -- Ada.Text_IO.C_Streams "a-wtcstr", -- Ada.Wide_Text_IO.C_Streams --- 162,167 ---- *************** package body Impunit is *** 175,188 **** -- GNAT Special IO Units -- --------------------------- ! -- As further explained elsewhere (see Sem_Ch10), the internal ! -- packages of Text_IO and Wide_Text_IO are actually implemented ! -- as separate children, but this fact is intended to be hidden ! -- from the user completely. Any attempt to WITH one of these ! -- units will be diagnosed as an error later on, but for now we ! -- do not consider these internal implementation units (if we did, ! -- then we would get a junk warning which would be confusing and ! -- unecessary, given that we generate a clear error message). "a-tideio", -- Ada.Text_IO.Decimal_IO "a-tienio", -- Ada.Text_IO.Enumeration_IO --- 176,188 ---- -- GNAT Special IO Units -- --------------------------- ! -- As further explained elsewhere (see Sem_Ch10), the internal packages of ! -- Text_IO and Wide_Text_IO are actually implemented as separate children, ! -- but this fact is intended to be hidden from the user completely. Any ! -- attempt to WITH one of these units will be diagnosed as an error later ! -- on, but for now we do not consider these internal implementation units ! -- (if we did, then we would get a junk warning which would be confusing ! -- and unnecessary, given that we generate a clear error message). "a-tideio", -- Ada.Text_IO.Decimal_IO "a-tienio", -- Ada.Text_IO.Enumeration_IO *************** package body Impunit is *** 259,264 **** --- 259,265 ---- "g-regist", -- GNAT.Registry "g-regpat", -- GNAT.Regpat "g-semaph", -- GNAT.Semaphores + "g-sercom", -- GNAT.Serial_Communications "g-sestin", -- GNAT.Secondary_Stack_Info "g-sha1 ", -- GNAT.SHA1 "g-signal", -- GNAT.Signals *************** package body Impunit is *** 276,289 **** "g-table ", -- GNAT.Table "g-tasloc", -- GNAT.Task_Lock "g-thread", -- GNAT.Threads "g-traceb", -- GNAT.Traceback "g-trasym", -- GNAT.Traceback.Symbolic "g-utf_32", -- GNAT.UTF_32 "g-u3spch", -- GNAT.UTF_32_Spelling_Checker "g-wispch", -- GNAT.Wide_Spelling_Checker "g-wistsp", -- GNAT.Wide_String_Split - "g-zspche", -- GNAT.Wide_Wide_Spelling_Checker - "g-zstspl", -- GNAT.Wide_Wide_String_Split ----------------------------------------------------- -- Interface Hierarchy Units from Reference Manual -- --- 277,289 ---- "g-table ", -- GNAT.Table "g-tasloc", -- GNAT.Task_Lock "g-thread", -- GNAT.Threads + "g-timsta", -- GNAT.Time_Stamp "g-traceb", -- GNAT.Traceback "g-trasym", -- GNAT.Traceback.Symbolic "g-utf_32", -- GNAT.UTF_32 "g-u3spch", -- GNAT.UTF_32_Spelling_Checker "g-wispch", -- GNAT.Wide_Spelling_Checker "g-wistsp", -- GNAT.Wide_String_Split ----------------------------------------------------- -- Interface Hierarchy Units from Reference Manual -- *************** package body Impunit is *** 303,308 **** --- 303,309 ---- "i-cpp ", -- Interfaces.CPP "i-cstrea", -- Interfaces.C.Streams "i-java ", -- Interfaces.Java + "i-javjni", -- Interfaces.Java.JNI "i-pacdec", -- Interfaces.Packed_Decimal "i-vxwoio", -- Interfaces.VxWorks.IO "i-vxwork", -- Interfaces.VxWorks *************** package body Impunit is *** 330,335 **** --- 331,337 ---- "s-pooloc", -- System.Pool_Local "s-restri", -- System.Restrictions "s-rident", -- System.Rident + "s-ststop", -- System.Strings.Stream_Ops "s-tasinf", -- System.Task_Info "s-wchcnv", -- System.Wch_Cnv "s-wchcon"); -- System.Wch_Con *************** package body Impunit is *** 369,374 **** --- 371,377 ---- "a-coteio", -- Ada.Complex_Text_IO "a-direct", -- Ada.Directories "a-diroro", -- Ada.Dispatching.Round_Robin + "a-disedf", -- Ada.Dispatching.EDF "a-dispat", -- Ada.Dispatching "a-envvar", -- Ada.Environment_Variables "a-exetim", -- Ada.Execution_Time diff -Nrcpad gcc-4.3.3/gcc/ada/indepsw-aix.adb gcc-4.4.0/gcc/ada/indepsw-aix.adb *** gcc-4.3.3/gcc/ada/indepsw-aix.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/indepsw-aix.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (AIX version) -- -- -- ! -- Copyright (C) 2004 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- B o d y -- -- (AIX version) -- -- -- ! -- Copyright (C) 2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/indepsw-gnu.adb gcc-4.4.0/gcc/ada/indepsw-gnu.adb *** gcc-4.3.3/gcc/ada/indepsw-gnu.adb Fri Dec 9 17:22:27 2005 --- gcc-4.4.0/gcc/ada/indepsw-gnu.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (GNU version) -- -- -- ! -- Copyright (C) 2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- B o d y -- -- (GNU version) -- -- -- ! -- Copyright (C) 2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/indepsw-mingw.adb gcc-4.4.0/gcc/ada/indepsw-mingw.adb *** gcc-4.3.3/gcc/ada/indepsw-mingw.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/indepsw-mingw.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (Windows version) -- -- -- ! -- Copyright (C) 2004 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- B o d y -- -- (Windows version) -- -- -- ! -- Copyright (C) 2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/indepsw.adb gcc-4.4.0/gcc/ada/indepsw.adb *** gcc-4.3.3/gcc/ada/indepsw.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/indepsw.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/indepsw.ads gcc-4.4.0/gcc/ada/indepsw.ads *** gcc-4.3.3/gcc/ada/indepsw.ads Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/indepsw.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/init.c gcc-4.4.0/gcc/ada/init.c *** gcc-4.3.3/gcc/ada/init.c Thu Jan 3 09:35:04 2008 --- gcc-4.4.0/gcc/ada/init.c Thu Apr 9 23:23:07 2009 *************** *** 6,50 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * * * ****************************************************************************/ ! /* This unit contains initialization circuits that are system dependent. A ! major part of the functionality involved involves stack overflow checking. The GCC backend generates probe instructions to test for stack overflow. For details on the exact approach used to generate these probes, see the "Using and Porting GCC" manual, in particular the "Stack Checking" section ! and the subsection "Specifying How Stack Checking is Done". The handlers ! installed by this file are used to handle resulting signals that come ! from these probes failing (i.e. touching protected pages) */ /* This file should be kept synchronized with 2sinit.ads, 2sinit.adb, ! s-init-ae653-cert.adb and s-init-xi-sparc.adb. All these files implement ! the required functionality for different targets. */ /* The following include is here to meet the published VxWorks requirement ! that the __vxworks header appear before any other include. */ #ifdef __vxworks #include "vxWorks.h" #endif --- 6,49 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * * * ****************************************************************************/ ! /* This unit contains initialization circuits that are system dependent. ! A major part of the functionality involves stack overflow checking. The GCC backend generates probe instructions to test for stack overflow. For details on the exact approach used to generate these probes, see the "Using and Porting GCC" manual, in particular the "Stack Checking" section ! and the subsection "Specifying How Stack Checking is Done". The handlers ! installed by this file are used to catch the resulting signals that come ! from these probes failing (i.e. touching protected pages). */ /* This file should be kept synchronized with 2sinit.ads, 2sinit.adb, ! s-init-ae653-cert.adb and s-init-xi-sparc.adb. All these files implement ! the required functionality for different targets. */ /* The following include is here to meet the published VxWorks requirement ! that the __vxworks header appear before any other include. */ #ifdef __vxworks #include "vxWorks.h" #endif *************** *** 66,80 **** extern void __gnat_raise_program_error (const char *, int); ! /* Addresses of exception data blocks for predefined exceptions. Tasking_Error ! is not used in this unit, and the abort signal is only used on IRIX. */ extern struct Exception_Data constraint_error; extern struct Exception_Data numeric_error; extern struct Exception_Data program_error; extern struct Exception_Data storage_error; /* For the Cert run time we use the regular raise exception routine because ! Raise_From_Signal_Handler is not available. */ #ifdef CERT #define Raise_From_Signal_Handler \ __gnat_raise_exception --- 65,79 ---- extern void __gnat_raise_program_error (const char *, int); ! /* Addresses of exception data blocks for predefined exceptions. Tasking_Error ! is not used in this unit, and the abort signal is only used on IRIX. */ extern struct Exception_Data constraint_error; extern struct Exception_Data numeric_error; extern struct Exception_Data program_error; extern struct Exception_Data storage_error; /* For the Cert run time we use the regular raise exception routine because ! Raise_From_Signal_Handler is not available. */ #ifdef CERT #define Raise_From_Signal_Handler \ __gnat_raise_exception *************** extern void Raise_From_Signal_Handler (s *** 85,91 **** extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *); #endif ! /* Global values computed by the binder */ int __gl_main_priority = -1; int __gl_time_slice_val = -1; char __gl_wc_encoding = 'n'; --- 84,90 ---- extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *); #endif ! /* Global values computed by the binder. */ int __gl_main_priority = -1; int __gl_time_slice_val = -1; char __gl_wc_encoding = 'n'; *************** int __gl_zero_cost_exceptions *** 102,121 **** int __gl_detect_blocking = 0; int __gl_default_stack_size = -1; int __gl_leap_seconds_support = 0; /* Indication of whether synchronous signal handler has already been ! installed by a previous call to adainit */ int __gnat_handler_installed = 0; #ifndef IN_RTS int __gnat_inside_elab_final_code = 0; /* ??? This variable is obsolete since 2001-08-29 but is kept to allow ! bootstrap from old GNAT versions (< 3.15). */ #endif /* HAVE_GNAT_INIT_FLOAT must be set on every targets where a __gnat_init_float ! is defined. If this is not set them a void implementation will be defined ! at the end of this unit. */ #undef HAVE_GNAT_INIT_FLOAT /******************************/ --- 101,121 ---- int __gl_detect_blocking = 0; int __gl_default_stack_size = -1; int __gl_leap_seconds_support = 0; + int __gl_canonical_streams = 0; /* Indication of whether synchronous signal handler has already been ! installed by a previous call to adainit. */ int __gnat_handler_installed = 0; #ifndef IN_RTS int __gnat_inside_elab_final_code = 0; /* ??? This variable is obsolete since 2001-08-29 but is kept to allow ! bootstrap from old GNAT versions (< 3.15). */ #endif /* HAVE_GNAT_INIT_FLOAT must be set on every targets where a __gnat_init_float ! is defined. If this is not set then a void implementation will be defined ! at the end of this unit. */ #undef HAVE_GNAT_INIT_FLOAT /******************************/ *************** char __gnat_get_interrupt_state (int); *** 126,138 **** /* This routine is called from the runtime as needed to determine the state of an interrupt, as set by an Interrupt_State pragma appearing anywhere ! in the current partition. The input argument is the interrupt number, and the result is one of the following: 'n' this interrupt not set by any Interrupt_State pragma 'u' Interrupt_State pragma set state to User 'r' Interrupt_State pragma set state to Runtime ! 's' Interrupt_State pragma set state to System */ char __gnat_get_interrupt_state (int intrup) --- 126,138 ---- /* This routine is called from the runtime as needed to determine the state of an interrupt, as set by an Interrupt_State pragma appearing anywhere ! in the current partition. The input argument is the interrupt number, and the result is one of the following: 'n' this interrupt not set by any Interrupt_State pragma 'u' Interrupt_State pragma set state to User 'r' Interrupt_State pragma set state to Runtime ! 's' Interrupt_State pragma set state to System */ char __gnat_get_interrupt_state (int intrup) *************** __gnat_get_interrupt_state (int intrup) *** 149,161 **** char __gnat_get_specific_dispatching (int); ! /* This routine is called from the run time as needed to determine the priority specific dispatching policy, as set by a Priority_Specific_Dispatching pragma appearing anywhere in the current ! partition. The input argument is the priority number, and the result is ! the upper case first character of the policy name, e.g. 'F' for FIFO_Within_Priorities. A space ' ' is returned if no ! Priority_Specific_Dispatching pragma is used in the partition. */ char __gnat_get_specific_dispatching (int priority) --- 149,161 ---- char __gnat_get_specific_dispatching (int); ! /* This routine is called from the runtime as needed to determine the priority specific dispatching policy, as set by a Priority_Specific_Dispatching pragma appearing anywhere in the current ! partition. The input argument is the priority number, and the result ! is the upper case first character of the policy name, e.g. 'F' for FIFO_Within_Priorities. A space ' ' is returned if no ! Priority_Specific_Dispatching pragma is used in the partition. */ char __gnat_get_specific_dispatching (int priority) *************** __gnat_get_specific_dispatching (int pri *** 174,181 **** /* __gnat_set_globals */ /**********************/ ! /* This routine is kept for boostrapping purposes, since the binder generated ! file now sets the __gl_* variables directly. */ void __gnat_set_globals () --- 174,181 ---- /* __gnat_set_globals */ /**********************/ ! /* This routine is kept for bootstrapping purposes, since the binder generated ! file now sets the __gl_* variables directly. */ void __gnat_set_globals () *************** __gnat_set_globals () *** 193,206 **** #include #include ! /* Some versions of AIX don't define SA_NODEFER. */ #ifndef SA_NODEFER #define SA_NODEFER 0 #endif /* SA_NODEFER */ /* Versions of AIX before 4.3 don't have nanosleep but provide ! nsleep instead. */ #ifndef _AIXVERSION_430 --- 193,206 ---- #include #include ! /* Some versions of AIX don't define SA_NODEFER. */ #ifndef SA_NODEFER #define SA_NODEFER 0 #endif /* SA_NODEFER */ /* Versions of AIX before 4.3 don't have nanosleep but provide ! nsleep instead. */ #ifndef _AIXVERSION_430 *************** nanosleep (struct timestruc_t *Rqtp, str *** 216,237 **** static void __gnat_error_handler (int sig, siginfo_t * si, void * uc); - /* __gnat_adjust_context_for_raise - see comments along with the default - version later in this file. */ - - void - __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) - { - /* We need to adjust the "Instruction Address Register" value, part of a - 'struct mstsave' wrapped as a jumpbuf in the mcontext field designated by - the signal data pointer we get. See sys/context.h + sys/mstsave.h */ - - mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; - mcontext->jmp_context.iar++; - } - - #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE - static void __gnat_error_handler (int sig, siginfo_t * si, void * uc) { --- 216,221 ---- *************** __gnat_error_handler (int sig, siginfo_t *** 241,247 **** switch (sig) { case SIGSEGV: ! /* FIXME: we need to detect the case of a *real* SIGSEGV */ exception = &storage_error; msg = "stack overflow or erroneous memory access"; break; --- 225,231 ---- switch (sig) { case SIGSEGV: ! /* FIXME: we need to detect the case of a *real* SIGSEGV. */ exception = &storage_error; msg = "stack overflow or erroneous memory access"; break; *************** __gnat_error_handler (int sig, siginfo_t *** 261,267 **** msg = "unhandled signal"; } - __gnat_adjust_context_for_raise (sig, uc); Raise_From_Signal_Handler (exception, msg); } --- 245,250 ---- *************** __gnat_install_handler (void) *** 272,284 **** /* Set up signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! */ act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; act.sa_sigaction = __gnat_error_handler; sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System" */ if (__gnat_get_interrupt_state (SIGABRT) != 's') sigaction (SIGABRT, &act, NULL); if (__gnat_get_interrupt_state (SIGFPE) != 's') --- 255,267 ---- /* Set up signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! */ act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; act.sa_sigaction = __gnat_error_handler; sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System". */ if (__gnat_get_interrupt_state (SIGABRT) != 's') sigaction (SIGABRT, &act, NULL); if (__gnat_get_interrupt_state (SIGFPE) != 's') *************** __gnat_install_handler (void) *** 408,420 **** /* Setup signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! */ act.sa_handler = (void (*) (int)) __gnat_error_handler; act.sa_flags = SA_RESTART | SA_NODEFER | SA_SIGINFO; sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System" */ if (__gnat_get_interrupt_state (SIGABRT) != 's') sigaction (SIGABRT, &act, NULL); if (__gnat_get_interrupt_state (SIGFPE) != 's') --- 391,403 ---- /* Setup signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! */ act.sa_handler = (void (*) (int)) __gnat_error_handler; act.sa_flags = SA_RESTART | SA_NODEFER | SA_SIGINFO; sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System". */ if (__gnat_get_interrupt_state (SIGABRT) != 's') sigaction (SIGABRT, &act, NULL); if (__gnat_get_interrupt_state (SIGFPE) != 's') *************** __gnat_machine_state_length (void) *** 463,488 **** static void __gnat_error_handler (int sig, siginfo_t *siginfo, void *ucontext); - #if defined (__hppa__) - - /* __gnat_adjust_context_for_raise - see comments along with the default - version later in this file. */ - - #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE - - void - __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) - { - mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; - - if (UseWideRegs (mcontext)) - mcontext->ss_wide.ss_32.ss_pcoq_head_lo ++; - else - mcontext->ss_narrow.ss_pcoq_head ++; - } - - #endif - static void __gnat_error_handler (int sig, siginfo_t *siginfo ATTRIBUTE_UNUSED, void *ucontext) --- 446,451 ---- *************** __gnat_error_handler *** 493,499 **** switch (sig) { case SIGSEGV: ! /* FIXME: we need to detect the case of a *real* SIGSEGV */ exception = &storage_error; msg = "stack overflow or erroneous memory access"; break; --- 456,462 ---- switch (sig) { case SIGSEGV: ! /* FIXME: we need to detect the case of a *real* SIGSEGV. */ exception = &storage_error; msg = "stack overflow or erroneous memory access"; break; *************** __gnat_error_handler *** 513,523 **** msg = "unhandled signal"; } - __gnat_adjust_context_for_raise (sig, ucontext); - Raise_From_Signal_Handler (exception, msg); } void __gnat_install_handler (void) { --- 476,491 ---- msg = "unhandled signal"; } Raise_From_Signal_Handler (exception, msg); } + /* This must be in keeping with System.OS_Interface.Alternate_Stack_Size. */ + #if defined (__hppa__) + char __gnat_alternate_stack[16 * 1024]; /* 2 * SIGSTKSZ */ + #else + char __gnat_alternate_stack[128 * 1024]; /* MINSIGSTKSZ */ + #endif + void __gnat_install_handler (void) { *************** __gnat_install_handler (void) *** 525,562 **** /* Set up signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! Also setup an alternate stack region for the handler execution so that stack overflows can be handled properly, avoiding a SEGV generation from stack usage by the ! handler itself. */ ! ! static char handler_stack[SIGSTKSZ*2]; ! /* SIGSTKSZ appeared to be "short" for the needs in some contexts ! (e.g. experiments with GCC ZCX exceptions). */ stack_t stack; ! ! stack.ss_sp = handler_stack; ! stack.ss_size = sizeof (handler_stack); stack.ss_flags = 0; - sigaltstack (&stack, NULL); act.sa_sigaction = __gnat_error_handler; ! act.sa_flags = SA_NODEFER | SA_RESTART | SA_ONSTACK | SA_SIGINFO; sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System" */ if (__gnat_get_interrupt_state (SIGABRT) != 's') sigaction (SIGABRT, &act, NULL); if (__gnat_get_interrupt_state (SIGFPE) != 's') sigaction (SIGFPE, &act, NULL); if (__gnat_get_interrupt_state (SIGILL) != 's') sigaction (SIGILL, &act, NULL); - if (__gnat_get_interrupt_state (SIGSEGV) != 's') - sigaction (SIGSEGV, &act, NULL); if (__gnat_get_interrupt_state (SIGBUS) != 's') sigaction (SIGBUS, &act, NULL); __gnat_handler_installed = 1; } --- 493,525 ---- /* Set up signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! Also setup an alternate stack region for the handler execution so that stack overflows can be handled properly, avoiding a SEGV generation from stack usage by the ! handler itself. */ stack_t stack; ! stack.ss_sp = __gnat_alternate_stack; ! stack.ss_size = sizeof (__gnat_alternate_stack); stack.ss_flags = 0; sigaltstack (&stack, NULL); act.sa_sigaction = __gnat_error_handler; ! act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System". */ if (__gnat_get_interrupt_state (SIGABRT) != 's') sigaction (SIGABRT, &act, NULL); if (__gnat_get_interrupt_state (SIGFPE) != 's') sigaction (SIGFPE, &act, NULL); if (__gnat_get_interrupt_state (SIGILL) != 's') sigaction (SIGILL, &act, NULL); if (__gnat_get_interrupt_state (SIGBUS) != 's') sigaction (SIGBUS, &act, NULL); + act.sa_flags |= SA_ONSTACK; + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + sigaction (SIGSEGV, &act, NULL); __gnat_handler_installed = 1; } *************** __gnat_install_handler (void) *** 566,572 **** /*********************/ #elif defined (linux) && (defined (i386) || defined (__x86_64__) \ ! || defined (__ia64__)) #include --- 529,535 ---- /*********************/ #elif defined (linux) && (defined (i386) || defined (__x86_64__) \ ! || defined (__ia64__) || defined (__powerpc__)) #include *************** __gnat_install_handler (void) *** 574,580 **** #include /* GNU/Linux, which uses glibc, does not define NULL in included ! header files */ #if !defined (NULL) #define NULL ((void *) 0) --- 537,543 ---- #include /* GNU/Linux, which uses glibc, does not define NULL in included ! header files. */ #if !defined (NULL) #define NULL ((void *) 0) *************** __gnat_install_handler (void) *** 583,595 **** #if defined (MaRTE) /* MaRTE OS provides its own version of sigaction, sigfillset, and ! sigemptyset (overriding these symbol names). We want to make sure that the versions provided by the underlying C library are used here (these versions are renamed by MaRTE to linux_sigaction, fake_linux_sigfillset, ! and fake_linux_sigemptyset, respectively). The MaRTE library will not always be present (it will not be linked if no tasking constructs are used), so we use the weak symbol mechanism to point always to the symbols ! defined within the C library. */ #pragma weak linux_sigaction int linux_sigaction (int signum, const struct sigaction *act, --- 546,558 ---- #if defined (MaRTE) /* MaRTE OS provides its own version of sigaction, sigfillset, and ! sigemptyset (overriding these symbol names). We want to make sure that the versions provided by the underlying C library are used here (these versions are renamed by MaRTE to linux_sigaction, fake_linux_sigfillset, ! and fake_linux_sigemptyset, respectively). The MaRTE library will not always be present (it will not be linked if no tasking constructs are used), so we use the weak symbol mechanism to point always to the symbols ! defined within the C library. */ #pragma weak linux_sigaction int linux_sigaction (int signum, const struct sigaction *act, *************** void fake_linux_sigemptyset (sigset_t *s *** 614,621 **** static void __gnat_error_handler (int, siginfo_t *siginfo, void *ucontext); ! /* __gnat_adjust_context_for_raise - see comments along with the default ! version later in this file. */ #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE --- 577,583 ---- static void __gnat_error_handler (int, siginfo_t *siginfo, void *ucontext); ! #if defined (i386) || defined (__x86_64__) || defined (__ia64__) #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE *************** __gnat_adjust_context_for_raise (int sig *** 624,638 **** { mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; #if defined (i386) ! mcontext->gregs[REG_EIP]++; #elif defined (__x86_64__) ! mcontext->gregs[REG_RIP]++; #elif defined (__ia64__) mcontext->sc_ip++; #endif } static void __gnat_error_handler (int sig, siginfo_t *siginfo ATTRIBUTE_UNUSED, --- 586,626 ---- { mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; + /* On the i386 and x86-64 architectures, stack checking is performed by + means of probes with moving stack pointer, that is to say the probed + address is always the value of the stack pointer. Upon hitting the + guard page, the stack pointer therefore points to an inaccessible + address and an alternate signal stack is needed to run the handler. + But there is an additional twist: on these architectures, the EH + return code writes the address of the handler at the target CFA's + value on the stack before doing the jump. As a consequence, if + there is an active handler in the frame whose stack has overflowed, + the stack pointer must nevertheless point to an accessible address + by the time the EH return is executed. + + We therefore adjust the saved value of the stack pointer by the size + of one page, in order to make sure that it points to an accessible + address in case it's used as the target CFA. The stack checking code + guarantees that this page is unused by the time this happens. */ + #if defined (i386) ! unsigned long pattern = *(unsigned long *)mcontext->gregs[REG_EIP]; ! /* The pattern is "orl $0x0,(%esp)" for a probe in 32-bit mode. */ ! if (signo == SIGSEGV && pattern == 0x00240c83) ! mcontext->gregs[REG_ESP] += 4096; #elif defined (__x86_64__) ! unsigned long pattern = *(unsigned long *)mcontext->gregs[REG_RIP]; ! /* The pattern is "orq $0x0,(%rsp)" for a probe in 64-bit mode. */ ! if (signo == SIGSEGV && (pattern & 0xffffffffff) == 0x00240c8348) ! mcontext->gregs[REG_RSP] += 4096; #elif defined (__ia64__) + /* ??? The IA-64 unwinder doesn't compensate for signals. */ mcontext->sc_ip++; #endif } + #endif + static void __gnat_error_handler (int sig, siginfo_t *siginfo ATTRIBUTE_UNUSED, *************** __gnat_error_handler (int sig, *** 676,682 **** For now we simply do not attempt any discrimination at all. Note that this is quite acceptable, since a "real" SIGSEGV can only ! occur as the result of an erroneous program */ msg = "stack overflow (or erroneous memory access)"; exception = &storage_error; --- 664,670 ---- For now we simply do not attempt any discrimination at all. Note that this is quite acceptable, since a "real" SIGSEGV can only ! occur as the result of an erroneous program. */ msg = "stack overflow (or erroneous memory access)"; exception = &storage_error; *************** __gnat_error_handler (int sig, *** 699,738 **** } recurse = 0; ! /* We adjust the interrupted context here (and not in the ! MD_FALLBACK_FRAME_STATE_FOR macro) because recent versions of the Native ! POSIX Thread Library (NPTL) are compiled with DWARF 2 unwind information, ! and hence the later macro is never executed for signal frames. */ ! __gnat_adjust_context_for_raise (sig, ucontext); Raise_From_Signal_Handler (exception, msg); } void __gnat_install_handler (void) { struct sigaction act; /* Set up signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! */ act.sa_sigaction = __gnat_error_handler; act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System" */ if (__gnat_get_interrupt_state (SIGABRT) != 's') sigaction (SIGABRT, &act, NULL); if (__gnat_get_interrupt_state (SIGFPE) != 's') sigaction (SIGFPE, &act, NULL); if (__gnat_get_interrupt_state (SIGILL) != 's') sigaction (SIGILL, &act, NULL); - if (__gnat_get_interrupt_state (SIGSEGV) != 's') - sigaction (SIGSEGV, &act, NULL); if (__gnat_get_interrupt_state (SIGBUS) != 's') sigaction (SIGBUS, &act, NULL); __gnat_handler_installed = 1; } --- 687,768 ---- } recurse = 0; ! /* We adjust the interrupted context here (and not in the fallback ! unwinding routine) because recent versions of the Native POSIX ! Thread Library (NPTL) are compiled with unwind information, so ! the fallback routine is never executed for signal frames. */ __gnat_adjust_context_for_raise (sig, ucontext); Raise_From_Signal_Handler (exception, msg); } + #if defined (i386) || defined (__x86_64__) + /* This must be in keeping with System.OS_Interface.Alternate_Stack_Size. */ + char __gnat_alternate_stack[16 * 1024]; /* 2 * SIGSTKSZ */ + #endif + + #ifdef __XENO__ + #include + #include + + RT_TASK main_task; + #endif + void __gnat_install_handler (void) { struct sigaction act; + #ifdef __XENO__ + int prio; + + if (__gl_main_priority == -1) + prio = 49; + else + prio = __gl_main_priority; + + /* Avoid memory swapping for this program */ + + mlockall (MCL_CURRENT|MCL_FUTURE); + + /* Turn the current Linux task into a native Xenomai task */ + + rt_task_shadow(&main_task, "environment_task", prio, T_FPU); + #endif + /* Set up signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! Also setup an alternate ! stack region for the handler execution so that stack overflows can be ! handled properly, avoiding a SEGV generation from stack usage by the ! handler itself. */ ! ! #if defined (i386) || defined (__x86_64__) ! stack_t stack; ! stack.ss_sp = __gnat_alternate_stack; ! stack.ss_size = sizeof (__gnat_alternate_stack); ! stack.ss_flags = 0; ! sigaltstack (&stack, NULL); ! #endif act.sa_sigaction = __gnat_error_handler; act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System". */ if (__gnat_get_interrupt_state (SIGABRT) != 's') sigaction (SIGABRT, &act, NULL); if (__gnat_get_interrupt_state (SIGFPE) != 's') sigaction (SIGFPE, &act, NULL); if (__gnat_get_interrupt_state (SIGILL) != 's') sigaction (SIGILL, &act, NULL); if (__gnat_get_interrupt_state (SIGBUS) != 's') sigaction (SIGBUS, &act, NULL); + #if defined (i386) || defined (__x86_64__) + act.sa_flags |= SA_ONSTACK; + #endif + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + sigaction (SIGSEGV, &act, NULL); __gnat_handler_installed = 1; } *************** static void __gnat_error_handler (int, i *** 771,778 **** also the signal number but the second argument is the signal code identifying the cause of the signal. The third argument points to a sigcontext_t structure containing the receiving ! process's context when the signal was delivered. ! */ static void __gnat_error_handler (int sig, int code, sigcontext_t *sc ATTRIBUTE_UNUSED) --- 801,807 ---- also the signal number but the second argument is the signal code identifying the cause of the signal. The third argument points to a sigcontext_t structure containing the receiving ! process's context when the signal was delivered. */ static void __gnat_error_handler (int sig, int code, sigcontext_t *sc ATTRIBUTE_UNUSED) *************** __gnat_error_handler (int sig, int code, *** 807,813 **** /* ??? Re-add smarts to further verify that we launched the stack into a guard page, not an attempt to ! write to .text or something */ exception = &storage_error; msg = "SIGSEGV: (stack overflow or erroneous memory access)"; } --- 836,842 ---- /* ??? Re-add smarts to further verify that we launched the stack into a guard page, not an attempt to ! write to .text or something. */ exception = &storage_error; msg = "SIGSEGV: (stack overflow or erroneous memory access)"; } *************** __gnat_error_handler (int sig, int code, *** 816,822 **** /* Just in case the OS guys did it to us again. Sometimes they fail to document all of the valid codes that are passed to signal handlers, just in case someone depends ! on knowing all the codes */ exception = &program_error; msg = "SIGSEGV: (Undocumented reason)"; } --- 845,851 ---- /* Just in case the OS guys did it to us again. Sometimes they fail to document all of the valid codes that are passed to signal handlers, just in case someone depends ! on knowing all the codes. */ exception = &program_error; msg = "SIGSEGV: (Undocumented reason)"; } *************** __gnat_error_handler (int sig, int code, *** 846,852 **** break; default: ! /* Everything else is a Program_Error. */ exception = &program_error; msg = "unhandled signal"; } --- 875,881 ---- break; default: ! /* Everything else is a Program_Error. */ exception = &program_error; msg = "unhandled signal"; } *************** __gnat_install_handler (void) *** 861,874 **** /* Setup signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! */ act.sa_handler = __gnat_error_handler; act.sa_flags = SA_NODEFER + SA_RESTART; sigfillset (&act.sa_mask); sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System" */ if (__gnat_get_interrupt_state (SIGABRT) != 's') sigaction (SIGABRT, &act, NULL); if (__gnat_get_interrupt_state (SIGFPE) != 's') --- 890,903 ---- /* Setup signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! */ act.sa_handler = __gnat_error_handler; act.sa_flags = SA_NODEFER + SA_RESTART; sigfillset (&act.sa_mask); sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System". */ if (__gnat_get_interrupt_state (SIGABRT) != 's') sigaction (SIGABRT, &act, NULL); if (__gnat_get_interrupt_state (SIGFPE) != 's') *************** __gnat_install_handler (void) *** 886,891 **** --- 915,983 ---- } /*******************/ + /* LynxOS Section */ + /*******************/ + + #elif defined (__Lynx__) + + #include + #include + + static void + __gnat_error_handler (int sig) + { + struct Exception_Data *exception; + const char *msg; + + switch(sig) + { + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + case SIGILL: + exception = &constraint_error; + msg = "SIGILL"; + break; + case SIGSEGV: + exception = &storage_error; + msg = "stack overflow or erroneous memory access"; + break; + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler(exception, msg); + } + + void + __gnat_install_handler(void) + { + struct sigaction act; + + act.sa_handler = __gnat_error_handler; + act.sa_flags = 0x0; + sigemptyset (&act.sa_mask); + + /* Do not install handlers if interrupt state is "System". */ + if (__gnat_get_interrupt_state (SIGFPE) != 's') + sigaction (SIGFPE, &act, NULL); + if (__gnat_get_interrupt_state (SIGILL) != 's') + sigaction (SIGILL, &act, NULL); + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + sigaction (SIGSEGV, &act, NULL); + if (__gnat_get_interrupt_state (SIGBUS) != 's') + sigaction (SIGBUS, &act, NULL); + + __gnat_handler_installed = 1; + } + + /*******************/ /* Solaris Section */ /*******************/ *************** __gnat_install_handler (void) *** 896,902 **** #include #include ! /* The code below is common to sparc and x86. Beware of the delay slot differences for signal context adjustments. */ #if defined (__sparc) --- 988,994 ---- #include #include ! /* The code below is common to SPARC and x86. Beware of the delay slot differences for signal context adjustments. */ #if defined (__sparc) *************** __gnat_install_handler (void) *** 907,913 **** /* Likewise regarding how the "instruction pointer" register slot can be identified in signal machine contexts. We have either "REG_PC" ! or "PC" at hand, depending on the target CPU and solaris version. */ #if !defined (REG_PC) #define REG_PC PC --- 999,1005 ---- /* Likewise regarding how the "instruction pointer" register slot can be identified in signal machine contexts. We have either "REG_PC" ! or "PC" at hand, depending on the target CPU and Solaris version. */ #if !defined (REG_PC) #define REG_PC PC *************** __gnat_install_handler (void) *** 915,933 **** static void __gnat_error_handler (int, siginfo_t *, ucontext_t *); - /* __gnat_adjust_context_for_raise - see comments along with the default - version later in this file. */ - - #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE - - void - __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, - void * ucontext) - { - mcontext_t *mcontext = & ((ucontext_t *)ucontext)->uc_mcontext; - mcontext->gregs[REG_PC] += (1 - RETURN_ADDR_OFFSET); - } - static void __gnat_error_handler (int sig, siginfo_t *sip, ucontext_t *uctx) { --- 1007,1012 ---- *************** __gnat_error_handler (int sig, siginfo_t *** 935,944 **** static int recurse = 0; const char *msg; - /* Adjusting is required for every fault context, so adjust for this one - now, before we possibly trigger a recursive fault below. */ - __gnat_adjust_context_for_raise (sig, (void *)uctx); - /* If this was an explicit signal from a "kill", just resignal it. */ if (SI_FROMUSER (sip)) { --- 1014,1019 ---- *************** __gnat_install_handler (void) *** 1005,1017 **** /* Set up signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! */ act.sa_handler = __gnat_error_handler; act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System" */ if (__gnat_get_interrupt_state (SIGABRT) != 's') sigaction (SIGABRT, &act, NULL); if (__gnat_get_interrupt_state (SIGFPE) != 's') --- 1080,1092 ---- /* Set up signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! */ act.sa_handler = __gnat_error_handler; act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System". */ if (__gnat_get_interrupt_state (SIGABRT) != 's') sigaction (SIGABRT, &act, NULL); if (__gnat_get_interrupt_state (SIGFPE) != 's') *************** __gnat_install_handler (void) *** 1030,1035 **** --- 1105,1114 ---- #elif defined (VMS) + /* Routine called from binder to override default feature values. */ + void __gnat_set_features (); + int __gnat_features_set = 0; + long __gnat_error_handler (int *, void *); #ifdef __IA64 *************** long __gnat_error_handler (int *, void * *** 1044,1051 **** #if defined (IN_RTS) && !defined (__IA64) ! /* The prehandler actually gets control first on a condition. It swaps the ! stack pointer and calls the handler (__gnat_error_handler). */ extern long __gnat_error_prehandler (void); extern char *__gnat_error_prehandler_stack; /* Alternate signal stack */ --- 1123,1130 ---- #if defined (IN_RTS) && !defined (__IA64) ! /* The prehandler actually gets control first on a condition. It swaps the ! stack pointer and calls the handler (__gnat_error_handler). */ extern long __gnat_error_prehandler (void); extern char *__gnat_error_prehandler_stack; /* Alternate signal stack */ *************** extern char *__gnat_error_prehandler_sta *** 1053,1068 **** /* Define macro symbols for the VMS conditions that become Ada exceptions. Most of these are also defined in the header file ssdef.h which has not ! yet been converted to be recognized by Gnu C. */ /* Defining these as macros, as opposed to external addresses, allows ! them to be used in a case statement (below */ #define SS$_ACCVIO 12 #define SS$_HPARITH 1284 #define SS$_STKOVF 1364 #define SS$_RESIGNAL 2328 ! /* These codes are in standard message libraries */ extern int CMA$_EXIT_THREAD; extern int SS$_DEBUG; extern int SS$_INTDIV; --- 1132,1147 ---- /* Define macro symbols for the VMS conditions that become Ada exceptions. Most of these are also defined in the header file ssdef.h which has not ! yet been converted to be recognized by GNU C. */ /* Defining these as macros, as opposed to external addresses, allows ! them to be used in a case statement below. */ #define SS$_ACCVIO 12 #define SS$_HPARITH 1284 #define SS$_STKOVF 1364 #define SS$_RESIGNAL 2328 ! /* These codes are in standard message libraries. */ extern int CMA$_EXIT_THREAD; extern int SS$_DEBUG; extern int SS$_INTDIV; *************** extern int MTH$_FLOOVEMAT; /* Some *** 1072,1078 **** /* These codes are non standard, which is to say the author is not sure if they are defined in the standard message libraries ! so keep them as macros for now. */ #define RDB$_STREAM_EOF 20480426 #define FDL$_UNPRIKW 11829410 --- 1151,1157 ---- /* These codes are non standard, which is to say the author is not sure if they are defined in the standard message libraries ! so keep them as macros for now. */ #define RDB$_STREAM_EOF 20480426 #define FDL$_UNPRIKW 11829410 *************** struct descriptor_s {unsigned short len, *** 1085,1092 **** /* Conditions that don't have an Ada exception counterpart must raise Non_Ada_Error. Since this is defined in s-auxdec, it should only be ! referenced by user programs, not the compiler or tools. Hence the ! #ifdef IN_RTS. */ #ifdef IN_RTS --- 1164,1171 ---- /* Conditions that don't have an Ada exception counterpart must raise Non_Ada_Error. Since this is defined in s-auxdec, it should only be ! referenced by user programs, not the compiler or tools. Hence the ! #ifdef IN_RTS. */ #ifdef IN_RTS *************** extern struct Exception_Data *Coded_Exce *** 1124,1130 **** extern Exception_Code Base_Code_In (Exception_Code); /* DEC Ada exceptions are not defined in a header file, so they ! must be declared as external addresses */ extern int ADA$_PROGRAM_ERROR; extern int ADA$_LOCK_ERROR; --- 1203,1209 ---- extern Exception_Code Base_Code_In (Exception_Code); /* DEC Ada exceptions are not defined in a header file, so they ! must be declared as external addresses. */ extern int ADA$_PROGRAM_ERROR; extern int ADA$_LOCK_ERROR; *************** extern int ADA$_KEY_MISMATCH; *** 1156,1162 **** extern int ADA$_MAXLINEXC; extern int ADA$_LINEXCMRS; ! /* DEC Ada specific conditions */ static const struct cond_except dec_ada_cond_except_table [] = { {&ADA$_PROGRAM_ERROR, &program_error}, {&ADA$_USE_ERROR, &Use_Error}, --- 1235,1241 ---- extern int ADA$_MAXLINEXC; extern int ADA$_LINEXCMRS; ! /* DEC Ada specific conditions. */ static const struct cond_except dec_ada_cond_except_table [] = { {&ADA$_PROGRAM_ERROR, &program_error}, {&ADA$_USE_ERROR, &Use_Error}, *************** static const struct cond_except dec_ada_ *** 1198,1205 **** #endif /* IN_RTS */ ! /* Non DEC Ada specific conditions. We could probably also put ! SS$_HPARITH here and possibly SS$_ACCVIO, SS$_STKOVF. */ static const struct cond_except cond_except_table [] = { {&MTH$_FLOOVEMAT, &constraint_error}, {&SS$_INTDIV, &constraint_error}, --- 1277,1284 ---- #endif /* IN_RTS */ ! /* Non-DEC Ada specific conditions. We could probably also put ! SS$_HPARITH here and possibly SS$_ACCVIO, SS$_STKOVF. */ static const struct cond_except cond_except_table [] = { {&MTH$_FLOOVEMAT, &constraint_error}, {&SS$_INTDIV, &constraint_error}, *************** static const struct cond_except cond_exc *** 1212,1218 **** still need to be handled by such handlers, however, in which case __gnat_error_handler needs to return SS$_RESIGNAL. Consider for instance the use of a third party library compiled with DECAda and ! performing it's own exception handling internally. To allow some user-level flexibility, which conditions should be resignaled is controlled by a predicate function, provided with the --- 1291,1297 ---- still need to be handled by such handlers, however, in which case __gnat_error_handler needs to return SS$_RESIGNAL. Consider for instance the use of a third party library compiled with DECAda and ! performing its own exception handling internally. To allow some user-level flexibility, which conditions should be resignaled is controlled by a predicate function, provided with the *************** __gnat_set_resignal_predicate (resignal_ *** 1290,1301 **** __gnat_resignal_p = predicate; } ! /* Should match System.Parameters.Default_Exception_Msg_Max_Length */ #define Default_Exception_Msg_Max_Length 512 ! /* Action routine for SYS$PUTMSG. There may be ! multiple conditions, each with text to be appended to ! MESSAGE and separated by line termination. */ static int copy_msg (msgdesc, message) --- 1369,1380 ---- __gnat_resignal_p = predicate; } ! /* Should match System.Parameters.Default_Exception_Msg_Max_Length. */ #define Default_Exception_Msg_Max_Length 512 ! /* Action routine for SYS$PUTMSG. There may be multiple ! conditions, each with text to be appended to MESSAGE ! and separated by line termination. */ static int copy_msg (msgdesc, message) *************** copy_msg (msgdesc, message) *** 1305,1318 **** int len = strlen (message); int copy_len; ! /* Check for buffer overflow and skip */ if (len > 0 && len <= Default_Exception_Msg_Max_Length - 3) { strcat (message, "\r\n"); len += 2; } ! /* Check for buffer overflow and truncate if necessary */ copy_len = (len + msgdesc->len <= Default_Exception_Msg_Max_Length - 1 ? msgdesc->len : Default_Exception_Msg_Max_Length - 1 - len); --- 1384,1397 ---- int len = strlen (message); int copy_len; ! /* Check for buffer overflow and skip. */ if (len > 0 && len <= Default_Exception_Msg_Max_Length - 3) { strcat (message, "\r\n"); len += 2; } ! /* Check for buffer overflow and truncate if necessary. */ copy_len = (len + msgdesc->len <= Default_Exception_Msg_Max_Length - 1 ? msgdesc->len : Default_Exception_Msg_Max_Length - 1 - len); *************** __gnat_handle_vms_condition (int *sigarg *** 1338,1344 **** return SS$_RESIGNAL; #ifdef IN_RTS ! /* See if it's an imported exception. Beware that registered exceptions are bound to their base code, with the severity bits masked off. */ base_code = Base_Code_In ((Exception_Code) sigargs [1]); exception = Coded_Exception (base_code); --- 1417,1423 ---- return SS$_RESIGNAL; #ifdef IN_RTS ! /* See if it's an imported exception. Beware that registered exceptions are bound to their base code, with the severity bits masked off. */ base_code = Base_Code_In ((Exception_Code) sigargs [1]); exception = Coded_Exception (base_code); *************** __gnat_handle_vms_condition (int *sigarg *** 1347,1360 **** { message [0] = 0; ! /* Subtract PC & PSL fields which messes with PUTMSG */ sigargs [0] -= 2; SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message); sigargs [0] += 2; msg = message; exception->Name_Length = 19; ! /* The full name really should be get sys$getmsg returns. ??? */ exception->Full_Name = "IMPORTED_EXCEPTION"; exception->Import_Code = base_code; --- 1426,1439 ---- { message [0] = 0; ! /* Subtract PC & PSL fields which messes with PUTMSG. */ sigargs [0] -= 2; SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message); sigargs [0] += 2; msg = message; exception->Name_Length = 19; ! /* ??? The full name really should be get sys$getmsg returns. */ exception->Full_Name = "IMPORTED_EXCEPTION"; exception->Import_Code = base_code; *************** __gnat_handle_vms_condition (int *sigarg *** 1395,1402 **** --- 1474,1485 ---- #else exception = &constraint_error; msg = "arithmetic error"; + #ifndef __alpha__ + /* No need to adjust pc on Alpha: the pc is already on the instruction + after the trapping one. */ __gnat_adjust_context_for_raise (0, (void *)mechargs); #endif + #endif break; default: *************** __gnat_handle_vms_condition (int *sigarg *** 1405,1411 **** int i; /* Scan the DEC Ada exception condition table for a match and fetch ! the associated GNAT exception pointer */ for (i = 0; dec_ada_cond_except_table [i].cond && !LIB$MATCH_COND (&sigargs [1], --- 1488,1494 ---- int i; /* Scan the DEC Ada exception condition table for a match and fetch ! the associated GNAT exception pointer. */ for (i = 0; dec_ada_cond_except_table [i].cond && !LIB$MATCH_COND (&sigargs [1], *************** __gnat_handle_vms_condition (int *sigarg *** 1417,1423 **** if (!exception) { /* Scan the VMS standard condition table for a match and fetch ! the associated GNAT exception pointer */ for (i = 0; cond_except_table [i].cond && !LIB$MATCH_COND (&sigargs [1], &cond_except_table [i].cond); --- 1500,1506 ---- if (!exception) { /* Scan the VMS standard condition table for a match and fetch ! the associated GNAT exception pointer. */ for (i = 0; cond_except_table [i].cond && !LIB$MATCH_COND (&sigargs [1], &cond_except_table [i].cond); *************** __gnat_handle_vms_condition (int *sigarg *** 1427,1433 **** if (!exception) /* User programs expect Non_Ada_Error to be raised, reference ! DEC Ada test CXCONDHAN. */ exception = &Non_Ada_Error; } } --- 1510,1516 ---- if (!exception) /* User programs expect Non_Ada_Error to be raised, reference ! DEC Ada test CXCONDHAN. */ exception = &Non_Ada_Error; } } *************** __gnat_handle_vms_condition (int *sigarg *** 1435,1441 **** exception = &program_error; #endif message [0] = 0; ! /* Subtract PC & PSL fields which messes with PUTMSG */ sigargs [0] -= 2; SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message); sigargs [0] += 2; --- 1518,1524 ---- exception = &program_error; #endif message [0] = 0; ! /* Subtract PC & PSL fields which messes with PUTMSG. */ sigargs [0] -= 2; SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message); sigargs [0] += 2; *************** __gnat_install_handler (void) *** 1479,1485 **** __gnat_handler_installed = 1; } ! /* __gnat_adjust_context_for_raise for alpha - see comments along with the default version later in this file. */ #if defined (IN_RTS) && defined (__alpha__) --- 1562,1568 ---- __gnat_handler_installed = 1; } ! /* __gnat_adjust_context_for_raise for Alpha - see comments along with the default version later in this file. */ #if defined (IN_RTS) && defined (__alpha__) *************** __gnat_adjust_context_for_raise (int sig *** 1539,1544 **** --- 1622,1675 ---- #endif + /* Feature logical name and global variable address pair */ + struct feature {char *name; int* gl_addr;}; + + /* Default values for GNAT features set by environment. */ + int __gl_no_malloc_64 = 0; + + /* Array feature logical names and global variable addresses */ + static struct feature features[] = { + {"GNAT$NO_MALLOC_64", &__gl_no_malloc_64}, + {0, 0} + }; + + void __gnat_set_features () + { + struct descriptor_s name_desc, result_desc; + int i, status; + unsigned short rlen; + + #define MAXEQUIV 10 + char buff [MAXEQUIV]; + + /* Loop through features array and test name for enable/disable */ + for (i=0; features [i].name; i++) + { + name_desc.len = strlen (features [i].name); + name_desc.mbz = 0; + name_desc.adr = features [i].name; + + result_desc.len = MAXEQUIV - 1; + result_desc.mbz = 0; + result_desc.adr = buff; + + status = LIB$GET_LOGICAL (&name_desc, &result_desc, &rlen); + + if (((status & 1) == 1) && (rlen < MAXEQUIV)) + buff [rlen] = 0; + else + strcpy (buff, ""); + + if (strcmp (buff, "ENABLE") == 0) + *features [i].gl_addr = 1; + else if (strcmp (buff, "DISABLE") == 0) + *features [i].gl_addr = 0; + } + + __gnat_features_set = 1; + } + /*******************/ /* FreeBSD Section */ /*******************/ *************** __gnat_adjust_context_for_raise (int sig *** 1550,1568 **** #include static void __gnat_error_handler (int, siginfo_t *, ucontext_t *); - void __gnat_adjust_context_for_raise (int, void*); - - /* __gnat_adjust_context_for_raise - see comments along with the default - version later in this file. */ - - #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE - - void - __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) - { - mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; - mcontext->mc_eip++; - } static void __gnat_error_handler (int sig, siginfo_t *info __attribute__ ((unused)), --- 1681,1686 ---- *************** __gnat_error_handler (int sig, siginfo_t *** 1598,1604 **** msg = "unhandled signal"; } - __gnat_adjust_context_for_raise (sig, ucontext); Raise_From_Signal_Handler (exception, msg); } --- 1716,1721 ---- *************** __gnat_install_handler () *** 1609,1615 **** /* Set up signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! */ act.sa_sigaction = (void (*)(int, struct __siginfo *, void*)) __gnat_error_handler; --- 1726,1732 ---- /* Set up signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! */ act.sa_sigaction = (void (*)(int, struct __siginfo *, void*)) __gnat_error_handler; *************** __gnat_install_handler () *** 1642,1657 **** #include "private/vThreadsP.h" #endif ! static void __gnat_error_handler (int, int, struct sigcontext *); ! void __gnat_map_signal (int); #ifndef __RTP__ ! /* Directly vectored Interrupt routines are not supported when using RTPs */ extern int __gnat_inum_to_ivec (int); ! /* This is needed by the GNAT run time to handle Vxworks interrupts */ int __gnat_inum_to_ivec (int num) { --- 1759,1773 ---- #include "private/vThreadsP.h" #endif ! void __gnat_error_handler (int, void *, struct sigcontext *); #ifndef __RTP__ ! /* Directly vectored Interrupt routines are not supported when using RTPs. */ extern int __gnat_inum_to_ivec (int); ! /* This is needed by the GNAT run time to handle Vxworks interrupts. */ int __gnat_inum_to_ivec (int num) { *************** __gnat_inum_to_ivec (int num) *** 1662,1668 **** #if !defined(__alpha_vxworks) && (_WRS_VXWORKS_MAJOR != 6) && !defined(__RTP__) /* getpid is used by s-parint.adb, but is not defined by VxWorks, except ! on Alpha VxWorks and VxWorks 6.x (including RTPs). */ extern long getpid (void); --- 1778,1784 ---- #if !defined(__alpha_vxworks) && (_WRS_VXWORKS_MAJOR != 6) && !defined(__RTP__) /* getpid is used by s-parint.adb, but is not defined by VxWorks, except ! on Alpha VxWorks and VxWorks 6.x (including RTPs). */ extern long getpid (void); *************** getpid (void) *** 1674,1680 **** #endif /* VxWorks expects the field excCnt to be zeroed when a signal is handled. ! The VxWorks version of longjmp does this; gcc's builtin_longjmp does not */ void __gnat_clear_exception_count (void) { --- 1790,1796 ---- #endif /* VxWorks expects the field excCnt to be zeroed when a signal is handled. ! The VxWorks version of longjmp does this; GCC's builtin_longjmp doesn't. */ void __gnat_clear_exception_count (void) { *************** __gnat_clear_exception_count (void) *** 1685,1693 **** #endif } ! /* Exported to s-intman-vxworks.adb in order to handle different signal ! to exception mappings in different VxWorks versions */ ! void __gnat_map_signal (int sig) { struct Exception_Data *exception; --- 1801,1809 ---- #endif } ! /* Handle different SIGnal to exception mappings in different VxWorks ! versions. */ ! static void __gnat_map_signal (int sig) { struct Exception_Data *exception; *************** __gnat_map_signal (int sig) *** 1750,1771 **** Raise_From_Signal_Handler (exception, msg); } ! static void ! __gnat_error_handler (int sig, int code, struct sigcontext *sc) { sigset_t mask; - int result; /* VxWorks will always mask out the signal during the signal handler and will reenable it on a longjmp. GNAT does not generate a longjmp to return from a signal handler so the signal will still be masked unless ! we unmask it. */ sigprocmask (SIG_SETMASK, NULL, &mask); sigdelset (&mask, sig); sigprocmask (SIG_SETMASK, &mask, NULL); __gnat_map_signal (sig); - } void --- 1866,1889 ---- Raise_From_Signal_Handler (exception, msg); } ! /* Tasking and Non-tasking signal handler. Map SIGnal to Ada exception ! propagation after the required low level adjustments. */ ! ! void ! __gnat_error_handler (int sig, void * si ATTRIBUTE_UNUSED, ! struct sigcontext * sc) { sigset_t mask; /* VxWorks will always mask out the signal during the signal handler and will reenable it on a longjmp. GNAT does not generate a longjmp to return from a signal handler so the signal will still be masked unless ! we unmask it. */ sigprocmask (SIG_SETMASK, NULL, &mask); sigdelset (&mask, sig); sigprocmask (SIG_SETMASK, &mask, NULL); __gnat_map_signal (sig); } void *************** __gnat_install_handler (void) *** 1775,1788 **** /* Setup signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! */ act.sa_handler = __gnat_error_handler; act.sa_flags = SA_SIGINFO | SA_ONSTACK; sigemptyset (&act.sa_mask); /* For VxWorks, install all signal handlers, since pragma Interrupt_State ! applies to vectored hardware interrupts, not signals */ sigaction (SIGFPE, &act, NULL); sigaction (SIGILL, &act, NULL); sigaction (SIGSEGV, &act, NULL); --- 1893,1906 ---- /* Setup signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another ! signal that might cause a scheduling event! */ act.sa_handler = __gnat_error_handler; act.sa_flags = SA_SIGINFO | SA_ONSTACK; sigemptyset (&act.sa_mask); /* For VxWorks, install all signal handlers, since pragma Interrupt_State ! applies to vectored hardware interrupts, not signals. */ sigaction (SIGFPE, &act, NULL); sigaction (SIGILL, &act, NULL); sigaction (SIGSEGV, &act, NULL); *************** __gnat_install_handler (void) *** 1796,1805 **** void __gnat_init_float (void) { ! /* Disable overflow/underflow exceptions on the PPC processor, this is needed to get correct Ada semantics. Note that for AE653 vThreads, the HW overflow settings are an OS configuration issue. The instructions ! below have no effect */ #if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && !defined (VTHREADS) asm ("mtfsb0 25"); asm ("mtfsb0 26"); --- 1914,1923 ---- void __gnat_init_float (void) { ! /* Disable overflow/underflow exceptions on the PPC processor, needed to get correct Ada semantics. Note that for AE653 vThreads, the HW overflow settings are an OS configuration issue. The instructions ! below have no effect. */ #if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && !defined (VTHREADS) asm ("mtfsb0 25"); asm ("mtfsb0 26"); *************** __gnat_init_float (void) *** 1807,1817 **** #if (defined (__i386__) || defined (i386)) && !defined (VTHREADS) /* This is used to properly initialize the FPU on an x86 for each ! process thread. */ asm ("finit"); #endif ! /* Similarly for sparc64. Achieved by masking bits in the Trap Enable Mask field of the Floating-point Status Register (see the SPARC Architecture Manual Version 9, p 48). */ #if defined (sparc64) --- 1925,1935 ---- #if (defined (__i386__) || defined (i386)) && !defined (VTHREADS) /* This is used to properly initialize the FPU on an x86 for each ! process thread. */ asm ("finit"); #endif ! /* Similarly for SPARC64. Achieved by masking bits in the Trap Enable Mask field of the Floating-point Status Register (see the SPARC Architecture Manual Version 9, p 48). */ #if defined (sparc64) *************** __gnat_install_handler(void) *** 1889,1895 **** act.sa_flags = SA_NODEFER | SA_RESTART; sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System" */ if (__gnat_get_interrupt_state (SIGFPE) != 's') sigaction (SIGFPE, &act, NULL); if (__gnat_get_interrupt_state (SIGILL) != 's') --- 2007,2013 ---- act.sa_flags = SA_NODEFER | SA_RESTART; sigemptyset (&act.sa_mask); ! /* Do not install handlers if interrupt state is "System". */ if (__gnat_get_interrupt_state (SIGFPE) != 's') sigaction (SIGFPE, &act, NULL); if (__gnat_get_interrupt_state (SIGILL) != 's') *************** __gnat_install_handler(void) *** 1967,1973 **** #else ! /* For all other versions of GNAT, the handler does nothing */ /*******************/ /* Default Section */ --- 2085,2091 ---- #else ! /* For all other versions of GNAT, the handler does nothing. */ /*******************/ /* Default Section */ *************** __gnat_install_handler (void) *** 1986,1993 **** /*********************/ /* This routine is called as each process thread is created, for possible ! initialization of the FP processor. This version is used under INTERIX, ! WIN32 and could be used under OS/2 */ #if defined (_WIN32) || defined (__INTERIX) || defined (__EMX__) \ || defined (__Lynx__) || defined(__NetBSD__) || defined(__FreeBSD__) \ --- 2104,2111 ---- /*********************/ /* This routine is called as each process thread is created, for possible ! initialization of the FP processor. This version is used under INTERIX, ! WIN32 and could be used under OS/2. */ #if defined (_WIN32) || defined (__INTERIX) || defined (__EMX__) \ || defined (__Lynx__) || defined(__NetBSD__) || defined(__FreeBSD__) \ *************** __gnat_init_float (void) *** 2001,2007 **** #if defined (__i386__) || defined (i386) /* This is used to properly initialize the FPU on an x86 for each ! process thread. */ asm ("finit"); --- 2119,2125 ---- #if defined (__i386__) || defined (i386) /* This is used to properly initialize the FPU on an x86 for each ! process thread. */ asm ("finit"); *************** __gnat_init_float (void) *** 2011,2017 **** #ifndef HAVE_GNAT_INIT_FLOAT ! /* All targets without a specific __gnat_init_float will use an empty one */ void __gnat_init_float (void) { --- 2129,2135 ---- #ifndef HAVE_GNAT_INIT_FLOAT ! /* All targets without a specific __gnat_init_float will use an empty one. */ void __gnat_init_float (void) { *************** __gnat_init_float (void) *** 2024,2030 **** #ifndef HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE ! /* All targets without a specific version will use an empty one */ /* Given UCONTEXT a pointer to a context structure received by a signal handler for SIGNO, perform the necessary adjustments to let the handler --- 2142,2148 ---- #ifndef HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE ! /* All targets without a specific version will use an empty one. */ /* Given UCONTEXT a pointer to a context structure received by a signal handler for SIGNO, perform the necessary adjustments to let the handler *************** void *** 2035,2046 **** __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext ATTRIBUTE_UNUSED) { ! /* Adjustments are currently required for the GCC ZCX propagation scheme ! only. These adjustments (described below) are harmless for the other ! schemes, so may be applied unconditionally. */ ! /* Adjustments required for a GCC ZCX propagation scheme: ! ------------------------------------------------------ The GCC unwinder expects to be dealing with call return addresses, since this is the "nominal" case of what we retrieve while unwinding a regular --- 2153,2163 ---- __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext ATTRIBUTE_UNUSED) { ! /* We used to compensate here for the raised from call vs raised from signal ! exception discrepancy with the GCC ZCX scheme, but this is now dealt with ! generically (except for the Alpha and IA-64), see GCC PR other/26208. ! *** Call vs signal exception discrepancy with GCC ZCX scheme *** The GCC unwinder expects to be dealing with call return addresses, since this is the "nominal" case of what we retrieve while unwinding a regular *************** __gnat_adjust_context_for_raise (int sig *** 2068,2082 **** signo is passed because on some targets for some signals the PC in context points to the instruction after the faulting one, in which case ! the unwinder adjustment is still desired. ! ! We used to perform the compensation in the GCC unwinding fallback macro. ! The thread at http://gcc.gnu.org/ml/gcc-patches/2004-05/msg00343.html ! describes a couple of issues with this approach. First, on some targets ! the adjustment to apply depends on the triggering signal, which is not ! easily accessible from the macro. Besides, other languages, e.g. Java, ! deal with this by performing the adjustment in the signal handler before ! the raise, so fallback adjustments just break those front-ends. */ } #endif --- 2185,2191 ---- signo is passed because on some targets for some signals the PC in context points to the instruction after the faulting one, in which case ! the unwinder adjustment is still desired. */ } #endif diff -Nrcpad gcc-4.3.3/gcc/ada/initialize.c gcc-4.4.0/gcc/ada/initialize.c *** gcc-4.3.3/gcc/ada/initialize.c Thu Jan 3 09:35:04 2008 --- gcc-4.4.0/gcc/ada/initialize.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** __gnat_initialize (void *eh) *** 76,87 **** given that we have set Max_Digits etc with this in mind */ __gnat_init_float (); - #ifndef RTX - /* Initialize a lock for a process handle list - see adaint.c for the - implementation of __gnat_portable_no_block_spawn, __gnat_portable_wait */ - __gnat_plist_init(); - #endif - /* Note that we do not activate this for the compiler itself to avoid a bootstrap path problem. Older version of gnatbind will generate a call to __gnat_initialize() without argument. Therefore we cannot use eh in --- 75,80 ---- *************** __gnat_initialize (void *eh) *** 135,141 **** dynamic unloader. Note that since the tables shall be registered against a common ! datastructure, libgcc should be one of the modules (vs being partially linked against all the others at build time) and shall be loaded first. For applications linked with the kernel, the scheme above would lead to --- 128,134 ---- dynamic unloader. Note that since the tables shall be registered against a common ! data structure, libgcc should be one of the modules (vs being partially linked against all the others at build time) and shall be loaded first. For applications linked with the kernel, the scheme above would lead to diff -Nrcpad gcc-4.3.3/gcc/ada/inline.adb gcc-4.4.0/gcc/ada/inline.adb *** gcc-4.3.3/gcc/ada/inline.adb Thu Dec 13 10:28:24 2007 --- gcc-4.4.0/gcc/ada/inline.adb Mon May 26 09:40:31 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Inline is *** 329,335 **** if Pack = Standard_Standard then ! -- Library-level inlined function. Add function iself to -- list of needed units. Inlined_Bodies.Increment_Last; --- 329,335 ---- if Pack = Standard_Standard then ! -- Library-level inlined function. Add function itself to -- list of needed units. Inlined_Bodies.Increment_Last; *************** package body Inline is *** 368,374 **** -- mode it will lead to undefined symbols at link time. -- -- b) If a body contains inlined function instances, it cannot be ! -- inlined under ZCX because the numerix suffix generated by gigi -- will be different in the body and the place of the inlined call. -- -- This procedure must be carefully coordinated with the back end --- 368,374 ---- -- mode it will lead to undefined symbols at link time. -- -- b) If a body contains inlined function instances, it cannot be ! -- inlined under ZCX because the numeric suffix generated by gigi -- will be different in the body and the place of the inlined call. -- -- This procedure must be carefully coordinated with the back end *************** package body Inline is *** 847,857 **** -- cleanup operations have been delayed, and the subprogram -- has been rewritten in the expansion of the enclosing -- protected body. It is the corresponding subprogram that ! -- may require the cleanup operations. Set_Uses_Sec_Stack (Protected_Body_Subprogram (Scop), Uses_Sec_Stack (Scop)); Scop := Protected_Body_Subprogram (Scop); end if; --- 847,861 ---- -- cleanup operations have been delayed, and the subprogram -- has been rewritten in the expansion of the enclosing -- protected body. It is the corresponding subprogram that ! -- may require the cleanup operations, so propagate the ! -- information that triggers cleanup activity. Set_Uses_Sec_Stack (Protected_Body_Subprogram (Scop), Uses_Sec_Stack (Scop)); + Set_Finalization_Chain_Entity + (Protected_Body_Subprogram (Scop), + Finalization_Chain_Entity (Scop)); Scop := Protected_Body_Subprogram (Scop); end if; diff -Nrcpad gcc-4.3.3/gcc/ada/interfac.ads gcc-4.4.0/gcc/ada/interfac.ads *** gcc-4.3.3/gcc/ada/interfac.ads Fri Dec 9 17:22:27 2005 --- gcc-4.4.0/gcc/ada/interfac.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/ioexcept.ads gcc-4.4.0/gcc/ada/ioexcept.ads *** gcc-4.3.3/gcc/ada/ioexcept.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/ioexcept.ads Fri Aug 1 10:33:45 2008 *************** *** 15,23 **** pragma Ada_2005; -- Explicit setting of Ada 2005 mode is required here, since we want to with a ! -- child unit (not possible in Ada 83 mode), and Text_IO is not considered to ! -- be an internal unit that is automatically compiled in Ada 2005 mode (since ! -- a user is allowed to redeclare IO_Exceptions). with Ada.IO_Exceptions; --- 15,23 ---- pragma Ada_2005; -- Explicit setting of Ada 2005 mode is required here, since we want to with a ! -- child unit (not possible in Ada 83 mode), and IO_Exceptions is not ! -- considered to be an internal unit that is automatically compiled in Ada ! -- 2005 mode (since a user is allowed to redeclare IO_Exceptions). with Ada.IO_Exceptions; diff -Nrcpad gcc-4.3.3/gcc/ada/itypes.adb gcc-4.4.0/gcc/ada/itypes.adb *** gcc-4.3.3/gcc/ada/itypes.adb Thu Dec 13 10:45:14 2007 --- gcc-4.4.0/gcc/ada/itypes.adb Tue Apr 8 06:52:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Sem; use Sem; *** 29,34 **** --- 29,35 ---- with Sinfo; use Sinfo; with Stand; use Stand; with Targparm; use Targparm; + with Uintp; use Uintp; package body Itypes is *************** package body Itypes is *** 47,63 **** Typ : Entity_Id; begin if Related_Id = Empty then Typ := New_Internal_Entity (Ekind, Scope_Id, Sloc (Related_Nod), 'T'); Set_Public_Status (Typ); else ! Typ := New_External_Entity ! (Ekind, Scope_Id, Sloc (Related_Nod), Related_Id, Suffix, ! Suffix_Index, 'T'); end if; ! Init_Size_Align (Typ); Set_Etype (Typ, Any_Type); Set_Is_Itype (Typ); Set_Associated_Node_For_Itype (Typ, Related_Nod); --- 48,71 ---- Typ : Entity_Id; begin + -- Should comment setting of Public_Status here ??? + if Related_Id = Empty then Typ := New_Internal_Entity (Ekind, Scope_Id, Sloc (Related_Nod), 'T'); Set_Public_Status (Typ); else ! Typ := ! New_External_Entity ! (Ekind, Scope_Id, Sloc (Related_Nod), Related_Id, Suffix, ! Suffix_Index, 'T'); end if; ! -- Make sure Esize (Typ) was properly initialized, it should be since ! -- New_Internal_Entity/New_External_Entity call Init_Size_Align. ! ! pragma Assert (Esize (Typ) = Uint_0); ! Set_Etype (Typ, Any_Type); Set_Is_Itype (Typ); Set_Associated_Node_For_Itype (Typ, Related_Nod); *************** package body Itypes is *** 68,74 **** Set_Is_Frozen (Typ); end if; ! if Ekind in Access_Subprogram_Type_Kind then Set_Can_Use_Internal_Rep (Typ, not Always_Compatible_Rep_On_Target); end if; --- 76,82 ---- Set_Is_Frozen (Typ); end if; ! if Ekind in Access_Subprogram_Kind then Set_Can_Use_Internal_Rep (Typ, not Always_Compatible_Rep_On_Target); end if; *************** package body Itypes is *** 95,101 **** Set_Directly_Designated_Type (I_Typ, Directly_Designated_Type (T)); Set_Etype (I_Typ, T); - Init_Size_Align (I_Typ); Set_Depends_On_Private (I_Typ, Depends_On_Private (T)); Set_Is_Public (I_Typ, Is_Public (T)); Set_From_With_Type (I_Typ, From_With_Type (T)); --- 103,108 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/itypes.ads gcc-4.4.0/gcc/ada/itypes.ads *** gcc-4.3.3/gcc/ada/itypes.ads Thu Dec 13 10:45:14 2007 --- gcc-4.4.0/gcc/ada/itypes.ads Tue Apr 8 07:04:25 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Itypes is *** 38,44 **** -- Implicit types (Itypes) are types and subtypes created by the semantic -- phase or the expander to reflect the underlying semantics. These could -- be generated by building trees for corresponding declarations and then ! -- analyzing these trees, but there are three reasons for not doing this: -- 1. The declarations would require more tree nodes --- 38,45 ---- -- Implicit types (Itypes) are types and subtypes created by the semantic -- phase or the expander to reflect the underlying semantics. These could -- be generated by building trees for corresponding declarations and then ! -- analyzing these trees, but there are three reasons for not doing this ! -- in some cases: -- 1. The declarations would require more tree nodes *************** package Itypes is *** 81,86 **** --- 82,106 ---- -- and for the array subtype. The associated node of each index subtype -- is the corresponding range expression. + -- Notes on the use of the Parent field of an Itype + + -- In some cases, we do create a declaration node for an itype, and in + -- such cases, the Parent field of the Itype points to this declaration + -- in the normal manner. This case can be detected by checking for a + -- non-empty Parent field referencing a declaration whose Defining_Entity + -- is the Itype in question. + + -- In some other cases, where we don't generate such a declaration, as + -- described above, the Itype is attached to the tree implicitly by being + -- referenced elsewhere, e.g. as the Etype of some object. In this case + -- the Parent field may be Empty. + + -- In other cases where we don't generate a declaration for the Itype, + -- the Itype may be attached to an arbitrary node in the tree, using + -- the Parent field. This Parent field may even reference a declaration + -- for a related different entity (hence the description of the tests + -- needed for the case where a declaration for the Itype is created). + ------------------ -- Create_Itype -- ------------------ *************** package Itypes is *** 115,122 **** -- The Scope_Id parameter specifies the scope of the created type, and -- is normally the Current_Scope as shown, but can be set otherwise. -- ! -- If Ekind is in Access_Subprogram_Type_Kind, Can_Use_Internal_Rep is set ! -- True, unless Always_Compatible_Rep_On_Target is True. --------------------------------- -- Create_Null_Excluding_Itype -- --- 135,144 ---- -- The Scope_Id parameter specifies the scope of the created type, and -- is normally the Current_Scope as shown, but can be set otherwise. -- ! -- The size/align fields are initialized to unknown (Uint_0). ! -- ! -- If Ekind is in Access_Subprogram_Kind, Can_Use_Internal_Rep is set True, ! -- unless Always_Compatible_Rep_On_Target is True. --------------------------------- -- Create_Null_Excluding_Itype -- diff -Nrcpad gcc-4.3.3/gcc/ada/krunch.adb gcc-4.4.0/gcc/ada/krunch.adb *** gcc-4.3.3/gcc/ada/krunch.adb Wed Jun 6 10:52:32 2007 --- gcc-4.4.0/gcc/ada/krunch.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/krunch.ads gcc-4.4.0/gcc/ada/krunch.ads *** gcc-4.3.3/gcc/ada/krunch.ads Tue Oct 31 17:57:54 2006 --- gcc-4.4.0/gcc/ada/krunch.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/lang-specs.h gcc-4.4.0/gcc/ada/lang-specs.h *** gcc-4.3.3/gcc/ada/lang-specs.h Sat Nov 15 16:15:00 2008 --- gcc-4.4.0/gcc/ada/lang-specs.h Thu Jan 1 00:00:00 1970 *************** *** 1,49 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * L A N G - S P E C S * - * * - * C Header File * - * * - * Copyright (C) 1992-2007, 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- * - * ware Foundation; either version 3, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License along with GCC; see the file COPYING3. If not see * - * . * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - /* This is the contribution to the `default_compilers' array in gcc.c for - GNAT. */ - - {".ads", "@ada", 0, 0, 0}, - {".adb", "@ada", 0, 0, 0}, - {"@ada", - "\ - %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ - %{!S:%{!c:%e-c or -S required for Ada}}\ - gnat1 %{I*} %{k8:-gnatk8} %{w:-gnatws} %{!Q:-quiet} %{nostdinc*}\ - %{nostdlib*}\ - -dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\ - %{O*} %{W*} %{w} %{p} %{pg:-p} %{a} %{f*} %{d*}\ - %{gnatea:-gnatez} %{g*&m*} " - #if defined(TARGET_VXWORKS_RTP) - "%{fRTS=rtp:-mrtp} " - #endif - #if CONFIG_DUAL_EXCEPTIONS - "%{fRTS=sjlj:-fsjlj} " - #endif - "%1 %{!S:%{o*:%w%*-gnatO}} \ - %i %{S:%W{o*}%{!o*:-o %b.s}} \ - %{gnatc*|gnats*: -o %j} %{-param*} \ - %{!gnatc*:%{!gnats*:%(invoke_as)}}", 0, 0, 0}, --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/lang.opt gcc-4.4.0/gcc/ada/lang.opt *** gcc-4.3.3/gcc/ada/lang.opt Mon Sep 3 10:06:52 2007 --- gcc-4.4.0/gcc/ada/lang.opt Thu Jan 1 00:00:00 1970 *************** *** 1,98 **** - ; Options for the Ada front end. - ; Copyright (C) 2003, 2007 Free Software Foundation, Inc. - ; - ; This file is part of GCC. - ; - ; GCC is free software; you can redistribute it and/or modify it under - ; the terms of the GNU General Public License as published by the Free - ; Software Foundation; either version 3, or (at your option) any later - ; version. - ; - ; GCC is distributed in the hope that it will be useful, but WITHOUT ANY - ; WARRANTY; without even the implied warranty of MERCHANTABILITY or - ; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License - ; for more details. - ; - ; You should have received a copy of the GNU General Public License - ; along with GCC; see the file COPYING3. If not see - ; . - - - ; See the GCC internals manual for a description of this file's format. - - ; Please try to keep this file in ASCII collating order. - - Language - Ada - - I - Ada Joined Separate - ; Documented for C - - Wall - Ada - ; Documented for C - - Wmissing-prototypes - Ada - ; Documented for C - - Wstrict-prototypes - Ada - ; Documented for C - - Wwrite-strings - Ada - ; Documented for C - - Wlong-long - Ada - ; Documented for C - - Wvariadic-macros - Ada - ; Documented for C - - Wold-style-definition - Ada - ; Documented for C - - Wmissing-format-attribute - Ada - ; Documented for C - - Woverlength-strings - Ada - ; Documented for C - - nostdinc - Ada RejectNegative - ; Don't look for source files - - feliminate-unused-debug-types - Ada - ; Effect documented for C - intercepted for Ada to force the associated flag - ; not to be set by default, as it currently eliminates unreferenced parallel - ; types we need for encoding descriptions to the debugger. - - nostdlib - Ada - ; Don't look for object files - - fRTS= - Ada Joined RejectNegative - ; Selects the runtime - - gant - Ada Joined Undocumented - ; Catches typos - - gnatO - Ada Separate - ; Sets name of output ALI file (internal switch) - - gnat - Ada Joined - -gnat Specify options to GNAT - - ; This comment is to ensure we retain the blank line above. --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/layout.adb gcc-4.4.0/gcc/ada/layout.adb *** gcc-4.3.3/gcc/ada/layout.adb Thu Dec 13 10:27:21 2007 --- gcc-4.4.0/gcc/ada/layout.adb Mon Aug 4 09:40:33 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package body Layout is *** 83,98 **** Left_Opnd : Node_Id; Right_Opnd : Node_Id) return Node_Id; -- This is like Make_Op_Multiply except that it optimizes some cases ! -- knowing that associative rearrangement is allowed for constant ! -- folding if one of the operands is a compile time known value function Assoc_Subtract (Loc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id) return Node_Id; -- This is like Make_Op_Subtract except that it optimizes some cases ! -- knowing that associative rearrangement is allowed for constant ! -- folding if one of the operands is a compile time known value function Bits_To_SU (N : Node_Id) return Node_Id; -- This is used when we cross the boundary from static sizes in bits to --- 83,98 ---- Left_Opnd : Node_Id; Right_Opnd : Node_Id) return Node_Id; -- This is like Make_Op_Multiply except that it optimizes some cases ! -- knowing that associative rearrangement is allowed for constant folding ! -- if one of the operands is a compile time known value function Assoc_Subtract (Loc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id) return Node_Id; -- This is like Make_Op_Subtract except that it optimizes some cases ! -- knowing that associative rearrangement is allowed for constant folding ! -- if one of the operands is a compile time known value function Bits_To_SU (N : Node_Id) return Node_Id; -- This is used when we cross the boundary from static sizes in bits to *************** package body Layout is *** 159,179 **** -- Front-end layout of record type procedure Rewrite_Integer (N : Node_Id; V : Uint); ! -- Rewrite node N with an integer literal whose value is V. The Sloc ! -- for the new node is taken from N, and the type of the literal is ! -- set to a copy of the type of N on entry. procedure Set_And_Check_Static_Size (E : Entity_Id; Esiz : SO_Ref; RM_Siz : SO_Ref); ! -- This procedure is called to check explicit given sizes (possibly ! -- stored in the Esize and RM_Size fields of E) against computed ! -- Object_Size (Esiz) and Value_Size (RM_Siz) values. Appropriate ! -- errors and warnings are posted if specified sizes are inconsistent ! -- with specified sizes. On return, the Esize and RM_Size fields of ! -- E are set (either from previously given values, or from the newly ! -- computed values, as appropriate). procedure Set_Composite_Alignment (E : Entity_Id); -- This procedure is called for record types and subtypes, and also for --- 159,178 ---- -- Front-end layout of record type procedure Rewrite_Integer (N : Node_Id; V : Uint); ! -- Rewrite node N with an integer literal whose value is V. The Sloc for ! -- the new node is taken from N, and the type of the literal is set to a ! -- copy of the type of N on entry. procedure Set_And_Check_Static_Size (E : Entity_Id; Esiz : SO_Ref; RM_Siz : SO_Ref); ! -- This procedure is called to check explicit given sizes (possibly stored ! -- in the Esize and RM_Size fields of E) against computed Object_Size ! -- (Esiz) and Value_Size (RM_Siz) values. Appropriate errors and warnings ! -- are posted if specified sizes are inconsistent with specified sizes. On ! -- return, Esize and RM_Size fields of E are set (either from previously ! -- given values, or from the newly computed values, as appropriate). procedure Set_Composite_Alignment (E : Entity_Id); -- This procedure is called for record types and subtypes, and also for *************** package body Layout is *** 200,207 **** -- which must be obeyed. If so, we cannot increase the size in this -- routine. ! -- For a type, the issue is whether an object size clause has been ! -- set. A normal size clause constrains only the value size (RM_Size) if Is_Type (E) then Esize_Set := Has_Object_Size_Clause (E); --- 199,206 ---- -- which must be obeyed. If so, we cannot increase the size in this -- routine. ! -- For a type, the issue is whether an object size clause has been set. ! -- A normal size clause constrains only the value size (RM_Size) if Is_Type (E) then Esize_Set := Has_Object_Size_Clause (E); *************** package body Layout is *** 247,260 **** return; end if; ! -- Here we have a situation where the Esize is not a multiple of ! -- the alignment. We must either increase Esize or reduce the ! -- alignment to correct this situation. -- The case in which we can decrease the alignment is where the -- alignment was not set by an alignment clause, and the type in ! -- question is a discrete type, where it is definitely safe to ! -- reduce the alignment. For example: -- t : integer range 1 .. 2; -- for t'size use 8; --- 246,259 ---- return; end if; ! -- Here we have a situation where the Esize is not a multiple of the ! -- alignment. We must either increase Esize or reduce the alignment to ! -- correct this situation. -- The case in which we can decrease the alignment is where the -- alignment was not set by an alignment clause, and the type in ! -- question is a discrete type, where it is definitely safe to reduce ! -- the alignment. For example: -- t : integer range 1 .. 2; -- for t'size use 8; *************** package body Layout is *** 275,282 **** return; end if; ! -- Now the only possible approach left is to increase the Esize ! -- but we can't do that if the size was set by a specific clause. if Esize_Set then Error_Msg_NE --- 274,281 ---- return; end if; ! -- Now the only possible approach left is to increase the Esize but we ! -- can't do that if the size was set by a specific clause. if Esize_Set then Error_Msg_NE *************** package body Layout is *** 606,614 **** Ent := Get_Dynamic_SO_Entity (D); if Is_Discrim_SO_Function (Ent) then ! -- If a component is passed in whose type matches the type ! -- of the function formal, then select that component from ! -- the "V" parameter rather than passing "V" directly. if Present (Comp) and then Base_Type (Etype (Comp)) --- 605,614 ---- Ent := Get_Dynamic_SO_Entity (D); if Is_Discrim_SO_Function (Ent) then ! ! -- If a component is passed in whose type matches the type of ! -- the function formal, then select that component from the "V" ! -- parameter rather than passing "V" directly. if Present (Comp) and then Base_Type (Etype (Comp)) *************** package body Layout is *** 661,678 **** when Dynamic => Nod : Node_Id; end case; end record; ! -- Shows the status of the value so far. Const means that the value ! -- is constant, and Val is the current constant value. Dynamic means ! -- that the value is dynamic, and in this case Nod is the Node_Id of ! -- the expression to compute the value. Size : Val_Type; -- Calculated value so far if Size.Status = Const, -- or expression value so far if Size.Status = Dynamic. SU_Convert_Required : Boolean := False; ! -- This is set to True if the final result must be converted from ! -- bits to storage units (rounding up to a storage unit boundary). ----------------------- -- Local Subprograms -- --- 661,678 ---- when Dynamic => Nod : Node_Id; end case; end record; ! -- Shows the status of the value so far. Const means that the value is ! -- constant, and Val is the current constant value. Dynamic means that ! -- the value is dynamic, and in this case Nod is the Node_Id of the ! -- expression to compute the value. Size : Val_Type; -- Calculated value so far if Size.Status = Const, -- or expression value so far if Size.Status = Dynamic. SU_Convert_Required : Boolean := False; ! -- This is set to True if the final result must be converted from bits ! -- to storage units (rounding up to a storage unit boundary). ----------------------- -- Local Subprograms -- *************** package body Layout is *** 799,807 **** (Dynamic, Make_Integer_Literal (Loc, Size.Val / SSU)); SU_Convert_Required := False; ! -- Otherwise, we go ahead and convert the value in bits, ! -- and set SU_Convert_Required to True to ensure that the ! -- final value is indeed properly converted. else Size := (Dynamic, Make_Integer_Literal (Loc, Size.Val)); --- 799,807 ---- (Dynamic, Make_Integer_Literal (Loc, Size.Val / SSU)); SU_Convert_Required := False; ! -- Otherwise, we go ahead and convert the value in bits, and ! -- set SU_Convert_Required to True to ensure that the final ! -- value is indeed properly converted. else Size := (Dynamic, Make_Integer_Literal (Loc, Size.Val)); *************** package body Layout is *** 827,834 **** Len := Convert_To (Standard_Unsigned, Len); ! -- If we cannot verify that range cannot be super-flat, ! -- we need a max with zero, since length must be non-neg. if not OK or else LLo < 0 then Len := --- 827,834 ---- Len := Convert_To (Standard_Unsigned, Len); ! -- If we cannot verify that range cannot be super-flat, we need ! -- a max with zero, since length must be non-negative. if not OK or else LLo < 0 then Len := *************** package body Layout is *** 846,853 **** Next_Index (Indx); end loop; ! -- Here after processing all bounds to set sizes. If the value is ! -- a constant, then it is bits, so we convert to storage units. if Size.Status = Const then return Bits_To_SU (Make_Integer_Literal (Loc, Size.Val)); --- 846,853 ---- Next_Index (Indx); end loop; ! -- Here after processing all bounds to set sizes. If the value is a ! -- constant, then it is bits, so we convert to storage units. if Size.Status = Const then return Bits_To_SU (Make_Integer_Literal (Loc, Size.Val)); *************** package body Layout is *** 900,909 **** -- How An Array Type is Laid Out -- ------------------------------------ ! -- Here is what goes on. We need to multiply the component size of ! -- the array (which has already been set) by the length of each of ! -- the indexes. If all these values are known at compile time, then ! -- the resulting size of the array is the appropriate constant value. -- If the component size or at least one bound is dynamic (but no -- discriminants are present), then the size will be computed as an --- 900,909 ---- -- How An Array Type is Laid Out -- ------------------------------------ ! -- Here is what goes on. We need to multiply the component size of the ! -- array (which has already been set) by the length of each of the ! -- indexes. If all these values are known at compile time, then the ! -- resulting size of the array is the appropriate constant value. -- If the component size or at least one bound is dynamic (but no -- discriminants are present), then the size will be computed as an *************** package body Layout is *** 941,948 **** -- Value of size computed so far. See comments above Vtyp : Entity_Id := Empty; ! -- Variant record type for the formal parameter of the ! -- discriminant function V if Status = Discrim. SU_Convert_Required : Boolean := False; -- This is set to True if the final result must be converted from --- 941,948 ---- -- Value of size computed so far. See comments above Vtyp : Entity_Id := Empty; ! -- Variant record type for the formal parameter of the discriminant ! -- function V if Status = Discrim. SU_Convert_Required : Boolean := False; -- This is set to True if the final result must be converted from *************** package body Layout is *** 956,962 **** Make_Size_Function : Boolean := False; -- Indicates whether to request that SO_Ref_From_Expr should ! -- encapsulate the array size expresion in a function. procedure Discrimify (N : in out Node_Id); -- If N represents a discriminant, then the Size.Status is set to --- 956,962 ---- Make_Size_Function : Boolean := False; -- Indicates whether to request that SO_Ref_From_Expr should ! -- encapsulate the array size expression in a function. procedure Discrimify (N : in out Node_Id); -- If N represents a discriminant, then the Size.Status is set to *************** package body Layout is *** 1064,1070 **** while Present (Indx) loop Ityp := Etype (Indx); ! -- If an index of the array is a generic formal type then there's -- no point in determining a size for the array type. if Is_Generic_Type (Ityp) then --- 1064,1070 ---- while Present (Indx) loop Ityp := Etype (Indx); ! -- If an index of the array is a generic formal type then there is -- no point in determining a size for the array type. if Is_Generic_Type (Ityp) then *************** package body Layout is *** 1139,1156 **** (Dynamic, Make_Integer_Literal (Loc, Size.Val / SSU)); SU_Convert_Required := False; ! -- If the current value is a factor of the storage unit, ! -- then we can use a value of one for the size and reduce ! -- the strength of the later division. elsif SSU mod Size.Val = 0 then Storage_Divisor := SSU / Size.Val; Size := (Dynamic, Make_Integer_Literal (Loc, Uint_1)); SU_Convert_Required := True; ! -- Otherwise, we go ahead and convert the value in bits, ! -- and set SU_Convert_Required to True to ensure that the ! -- final value is indeed properly converted. else Size := (Dynamic, Make_Integer_Literal (Loc, Size.Val)); --- 1139,1156 ---- (Dynamic, Make_Integer_Literal (Loc, Size.Val / SSU)); SU_Convert_Required := False; ! -- If the current value is a factor of the storage unit, then ! -- we can use a value of one for the size and reduce the ! -- strength of the later division. elsif SSU mod Size.Val = 0 then Storage_Divisor := SSU / Size.Val; Size := (Dynamic, Make_Integer_Literal (Loc, Uint_1)); SU_Convert_Required := True; ! -- Otherwise, we go ahead and convert the value in bits, and ! -- set SU_Convert_Required to True to ensure that the final ! -- value is indeed properly converted. else Size := (Dynamic, Make_Integer_Literal (Loc, Size.Val)); *************** package body Layout is *** 1165,1172 **** Len := Compute_Length (Lo, Hi); ! -- If Len isn't a Length attribute, then its range needs to ! -- be checked a possible Max with zero needs to be computed. if Nkind (Len) /= N_Attribute_Reference or else Attribute_Name (Len) /= Name_Length --- 1165,1172 ---- Len := Compute_Length (Lo, Hi); ! -- If Len isn't a Length attribute, then its range needs to be ! -- checked a possible Max with zero needs to be computed. if Nkind (Len) /= N_Attribute_Reference or else Attribute_Name (Len) /= Name_Length *************** package body Layout is *** 1193,1201 **** return; end if; ! -- If we cannot verify that range cannot be super-flat, ! -- we need a maximum with zero, since length cannot be ! -- negative. if not OK or else LLo < 0 then Len := --- 1193,1200 ---- return; end if; ! -- If we cannot verify that range cannot be super-flat, we ! -- need a max with zero, since length cannot be negative. if not OK or else LLo < 0 then Len := *************** package body Layout is *** 1221,1229 **** Next_Index (Indx); end loop; ! -- Here after processing all bounds to set sizes. If the value is ! -- a constant, then it is bits, and the only thing we need to do ! -- is to check against explicit given size and do alignment adjust. if Size.Status = Const then Set_And_Check_Static_Size (E, Size.Val, Size.Val); --- 1220,1228 ---- Next_Index (Indx); end loop; ! -- Here after processing all bounds to set sizes. If the value is a ! -- constant, then it is bits, and the only thing we need to do is to ! -- check against explicit given size and do alignment adjust. if Size.Status = Const then Set_And_Check_Static_Size (E, Size.Val, Size.Val); *************** package body Layout is *** 1303,1310 **** return; end if; ! -- Set size if not set for object and known for type. Use the ! -- RM_Size if that is known for the type and Esize is not. if Unknown_Esize (E) then if Known_Esize (T) then --- 1302,1309 ---- return; end if; ! -- Set size if not set for object and known for type. Use the RM_Size if ! -- that is known for the type and Esize is not. if Unknown_Esize (E) then if Known_Esize (T) then *************** package body Layout is *** 1325,1333 **** Adjust_Esize_Alignment (E); ! -- Final adjustment, if we don't know the alignment, and the Esize ! -- was not set by an explicit Object_Size attribute clause, then ! -- we reset the Esize to unknown, since we really don't know it. if Unknown_Alignment (E) and then not Has_Size_Clause (E) --- 1324,1332 ---- Adjust_Esize_Alignment (E); ! -- Final adjustment, if we don't know the alignment, and the Esize was ! -- not set by an explicit Object_Size attribute clause, then we reset ! -- the Esize to unknown, since we really don't know it. if Unknown_Alignment (E) and then not Has_Size_Clause (E) *************** package body Layout is *** 1505,1512 **** New_Fbit := (New_Fbit + SSU - 1) / SSU * SSU; end if; ! -- If old normalized position is static, we can go ahead ! -- and compute the new normalized position directly. if Known_Static_Normalized_Position (Prev_Comp) then New_Npos := Old_Npos; --- 1504,1511 ---- New_Fbit := (New_Fbit + SSU - 1) / SSU * SSU; end if; ! -- If old normalized position is static, we can go ahead and ! -- compute the new normalized position directly. if Known_Static_Normalized_Position (Prev_Comp) then New_Npos := Old_Npos; *************** package body Layout is *** 1619,1629 **** return; end if; ! -- Check case of type of component has a scope of the record we ! -- are laying out. When this happens, the type in question is an ! -- Itype that has not yet been laid out (that's because such ! -- types do not get frozen in the normal manner, because there ! -- is no place for the freeze nodes). if Scope (Ctyp) = E then Layout_Type (Ctyp); --- 1618,1628 ---- return; end if; ! -- Check case of type of component has a scope of the record we are ! -- laying out. When this happens, the type in question is an Itype ! -- that has not yet been laid out (that's because such types do not ! -- get frozen in the normal manner, because there is no place for ! -- the freeze nodes). if Scope (Ctyp) = E then Layout_Type (Ctyp); *************** package body Layout is *** 1636,1644 **** end if; -- Set size of component from type. We use the Esize except in a ! -- packed record, where we use the RM_Size (since that is exactly ! -- what the RM_Size value, as distinct from the Object_Size is ! -- useful for!) if Is_Packed (E) then Set_Esize (Comp, RM_Size (Ctyp)); --- 1635,1642 ---- end if; -- Set size of component from type. We use the Esize except in a ! -- packed record, where we use the RM_Size (since that is what the ! -- RM_Size value, as distinct from the Object_Size is useful for!) if Is_Packed (E) then Set_Esize (Comp, RM_Size (Ctyp)); *************** package body Layout is *** 1915,1924 **** RM_Siz_Expr : Node_Id := Empty; -- Expression for the evolving RM_Siz value. This is typically a ! -- conditional expression which involves tests of discriminant ! -- values that are formed as references to the entity V. At ! -- the end of scanning all the components, a suitable function ! -- is constructed in which V is the parameter. ----------------------- -- Local Subprograms -- --- 1913,1922 ---- RM_Siz_Expr : Node_Id := Empty; -- Expression for the evolving RM_Siz value. This is typically a ! -- conditional expression which involves tests of discriminant values ! -- that are formed as references to the entity V. At the end of ! -- scanning all the components, a suitable function is constructed ! -- in which V is the parameter. ----------------------- -- Local Subprograms -- *************** package body Layout is *** 1928,1941 **** (Clist : Node_Id; Esiz : out SO_Ref; RM_Siz_Expr : out Node_Id); ! -- Recursive procedure, called to lay out one component list ! -- Esiz and RM_Siz_Expr are set to the Object_Size and Value_Size ! -- values respectively representing the record size up to and ! -- including the last component in the component list (including ! -- any variants in this component list). RM_Siz_Expr is returned ! -- as an expression which may in the general case involve some ! -- references to the discriminants of the current record value, ! -- referenced by selecting from the entity V. --------------------------- -- Layout_Component_List -- --- 1926,1939 ---- (Clist : Node_Id; Esiz : out SO_Ref; RM_Siz_Expr : out Node_Id); ! -- Recursive procedure, called to lay out one component list Esiz ! -- and RM_Siz_Expr are set to the Object_Size and Value_Size values ! -- respectively representing the record size up to and including the ! -- last component in the component list (including any variants in ! -- this component list). RM_Siz_Expr is returned as an expression ! -- which may in the general case involve some references to the ! -- discriminants of the current record value, referenced by selecting ! -- from the entity V. --------------------------- -- Layout_Component_List -- *************** package body Layout is *** 1982,1990 **** else RMS_Ent := Get_Dynamic_SO_Entity (RM_Siz); ! -- If the size is represented by a function, then we ! -- create an appropriate function call using V as ! -- the parameter to the call. if Is_Discrim_SO_Function (RMS_Ent) then RM_Siz_Expr := --- 1980,1988 ---- else RMS_Ent := Get_Dynamic_SO_Entity (RM_Siz); ! -- If the size is represented by a function, then we create ! -- an appropriate function call using V as the parameter to ! -- the call. if Is_Discrim_SO_Function (RMS_Ent) then RM_Siz_Expr := *************** package body Layout is *** 2080,2088 **** -- individual variants, and xxDx are the discriminant -- checking functions generated for the variant type. ! -- If this is the first variant, we simply set the ! -- result as the expression. Note that this takes ! -- care of the others case. if No (RM_Siz_Expr) then RM_Siz_Expr := Bits_To_SU (RM_SizV); --- 2078,2086 ---- -- individual variants, and xxDx are the discriminant -- checking functions generated for the variant type. ! -- If this is the first variant, we simply set the result ! -- as the expression. Note that this takes care of the ! -- others case. if No (RM_Siz_Expr) then RM_Siz_Expr := Bits_To_SU (RM_SizV); *************** package body Layout is *** 2236,2252 **** -- All other cases else ! -- Initialize alignment conservatively to 1. This value will ! -- be increased as necessary during processing of the record. if Unknown_Alignment (E) then Set_Alignment (E, Uint_1); end if; ! -- Initialize previous component. This is Empty unless there ! -- are components which have already been laid out by component ! -- clauses. If there are such components, we start our lay out of ! -- the remaining components following the last such component. Prev_Comp := Empty; --- 2234,2250 ---- -- All other cases else ! -- Initialize alignment conservatively to 1. This value will be ! -- increased as necessary during processing of the record. if Unknown_Alignment (E) then Set_Alignment (E, Uint_1); end if; ! -- Initialize previous component. This is Empty unless there are ! -- components which have already been laid out by component clauses. ! -- If there are such components, we start our lay out of the ! -- remaining components following the last such component. Prev_Comp := Empty; *************** package body Layout is *** 2303,2310 **** Desig_Type : Entity_Id; begin ! -- For string literal types, for now, kill the size always, this ! -- is because gigi does not like or need the size to be set ??? if Ekind (E) = E_String_Literal_Subtype then Set_Esize (E, Uint_0); --- 2301,2308 ---- Desig_Type : Entity_Id; begin ! -- For string literal types, for now, kill the size always, this is ! -- because gigi does not like or need the size to be set ??? if Ekind (E) = E_String_Literal_Subtype then Set_Esize (E, Uint_0); *************** package body Layout is *** 2312,2325 **** return; end if; ! -- For access types, set size/alignment. This is system address ! -- size, except for fat pointers (unconstrained array access types), ! -- where the size is two times the address size, to accommodate the ! -- two pointers that are required for a fat pointer (data and ! -- template). Note that E_Access_Protected_Subprogram_Type is not ! -- an access type for this purpose since it is not a pointer but is ! -- equivalent to a record. For access subtypes, copy the size from ! -- the base type since Gigi represents them the same way. if Is_Access_Type (E) then --- 2310,2323 ---- return; end if; ! -- For access types, set size/alignment. This is system address size, ! -- except for fat pointers (unconstrained array access types), where the ! -- size is two times the address size, to accommodate the two pointers ! -- that are required for a fat pointer (data and template). Note that ! -- E_Access_Protected_Subprogram_Type is not an access type for this ! -- purpose since it is not a pointer but is equivalent to a record. For ! -- access subtypes, copy the size from the base type since Gigi ! -- represents them the same way. if Is_Access_Type (E) then *************** package body Layout is *** 2335,2349 **** Desig_Type := Non_Limited_View (Designated_Type (E)); end if; ! -- If Esize already set (e.g. by a size clause), then nothing ! -- further to be done here. if Known_Esize (E) then null; ! -- Access to subprogram is a strange beast, and we let the ! -- backend figure out what is needed (it may be some kind ! -- of fat pointer, including the static link for example. elsif Is_Access_Protected_Subprogram_Type (E) then null; --- 2333,2347 ---- Desig_Type := Non_Limited_View (Designated_Type (E)); end if; ! -- If Esize already set (e.g. by a size clause), then nothing further ! -- to be done here. if Known_Esize (E) then null; ! -- Access to subprogram is a strange beast, and we let the backend ! -- figure out what is needed (it may be some kind of fat pointer, ! -- including the static link for example. elsif Is_Access_Protected_Subprogram_Type (E) then null; *************** package body Layout is *** 2354,2362 **** Set_Size_Info (E, Base_Type (E)); Set_RM_Size (E, RM_Size (Base_Type (E))); ! -- For other access types, we use either address size, or, if ! -- a fat pointer is used (pointer-to-unconstrained array case), ! -- twice the address size to accommodate a fat pointer. elsif Present (Desig_Type) and then Is_Array_Type (Desig_Type) --- 2352,2360 ---- Set_Size_Info (E, Base_Type (E)); Set_RM_Size (E, RM_Size (Base_Type (E))); ! -- For other access types, we use either address size, or, if a fat ! -- pointer is used (pointer-to-unconstrained array case), twice the ! -- address size to accommodate a fat pointer. elsif Present (Desig_Type) and then Is_Array_Type (Desig_Type) *************** package body Layout is *** 2378,2386 **** ("?this access type does not correspond to C pointer", E); end if; ! -- If the designated type is a limited view it is unanalyzed. We ! -- can examine the declaration itself to determine whether it will ! -- need a fat pointer. elsif Present (Desig_Type) and then Present (Parent (Desig_Type)) --- 2376,2384 ---- ("?this access type does not correspond to C pointer", E); end if; ! -- If the designated type is a limited view it is unanalyzed. We can ! -- examine the declaration itself to determine whether it will need a ! -- fat pointer. elsif Present (Desig_Type) and then Present (Parent (Desig_Type)) *************** package body Layout is *** 2392,2400 **** Init_Size (E, 2 * System_Address_Size); -- When the target is AAMP, access-to-subprogram types are fat ! -- pointers consisting of the subprogram address and a static ! -- link (with the exception of library-level access types, ! -- where a simple subprogram address is used). elsif AAMP_On_Target and then --- 2390,2398 ---- Init_Size (E, 2 * System_Address_Size); -- When the target is AAMP, access-to-subprogram types are fat ! -- pointers consisting of the subprogram address and a static link ! -- (with the exception of library-level access types, where a simple ! -- subprogram address is used). elsif AAMP_On_Target and then *************** package body Layout is *** 2411,2425 **** -- On VMS, reset size to 32 for convention C access type if no -- explicit size clause is given and the default size is 64. Really -- we do not know the size, since depending on options for the VMS ! -- compiler, the size of a pointer type can be 32 or 64, but ! -- choosing 32 as the default improves compatibility with legacy ! -- VMS code. -- Note: we do not use Has_Size_Clause in the test below, because we ! -- want to catch the case of a derived type inheriting a size ! -- clause. We want to consider this to be an explicit size clause ! -- for this purpose, since it would be weird not to inherit the size ! -- in this case. -- We do NOT do this if we are in -gnatdm mode on a non-VMS target -- since in that case we want the normal pointer representation. --- 2409,2422 ---- -- On VMS, reset size to 32 for convention C access type if no -- explicit size clause is given and the default size is 64. Really -- we do not know the size, since depending on options for the VMS ! -- compiler, the size of a pointer type can be 32 or 64, but choosing ! -- 32 as the default improves compatibility with legacy VMS code. -- Note: we do not use Has_Size_Clause in the test below, because we ! -- want to catch the case of a derived type inheriting a size clause. ! -- We want to consider this to be an explicit size clause for this ! -- purpose, since it would be weird not to inherit the size in this ! -- case. -- We do NOT do this if we are in -gnatdm mode on a non-VMS target -- since in that case we want the normal pointer representation. *************** package body Layout is *** 2440,2451 **** elsif Is_Scalar_Type (E) then ! -- For discrete types, the RM_Size and Esize must be set ! -- already, since this is part of the earlier processing ! -- and the front end is always required to lay out the ! -- sizes of such types (since they are available as static ! -- attributes). All we do is to check that this rule is ! -- indeed obeyed! if Is_Discrete_Type (E) then --- 2437,2447 ---- elsif Is_Scalar_Type (E) then ! -- For discrete types, the RM_Size and Esize must be set already, ! -- since this is part of the earlier processing and the front end is ! -- always required to lay out the sizes of such types (since they are ! -- available as static attributes). All we do is to check that this ! -- rule is indeed obeyed! if Is_Discrete_Type (E) then *************** package body Layout is *** 2472,2481 **** Init_Esize (E, S); exit; ! -- If the RM_Size is greater than 64 (happens only ! -- when strange values are specified by the user, ! -- then Esize is simply a copy of RM_Size, it will ! -- be further refined later on) elsif S = 64 then Set_Esize (E, RM_Size (E)); --- 2468,2477 ---- Init_Esize (E, S); exit; ! -- If the RM_Size is greater than 64 (happens only when ! -- strange values are specified by the user, then Esize ! -- is simply a copy of RM_Size, it will be further ! -- refined later on) elsif S = 64 then Set_Esize (E, RM_Size (E)); *************** package body Layout is *** 2490,2497 **** end; end if; ! -- For non-discrete sclar types, if the RM_Size is not set, ! -- then set it now to a copy of the Esize if the Esize is set. else if Known_Esize (E) and then Unknown_RM_Size (E) then --- 2486,2493 ---- end; end if; ! -- For non-discrete scalar types, if the RM_Size is not set, then set ! -- it now to a copy of the Esize if the Esize is set. else if Known_Esize (E) and then Unknown_RM_Size (E) then *************** package body Layout is *** 2508,2515 **** if Known_RM_Size (E) and then Unknown_Esize (E) then ! -- If the alignment is known, we bump the Esize up to the ! -- next alignment boundary if it is not already on one. if Known_Alignment (E) then declare --- 2504,2511 ---- if Known_RM_Size (E) and then Unknown_Esize (E) then ! -- If the alignment is known, we bump the Esize up to the next ! -- alignment boundary if it is not already on one. if Known_Alignment (E) then declare *************** package body Layout is *** 2520,2537 **** end; end if; ! -- If Esize is set, and RM_Size is not, RM_Size is copied from ! -- Esize at least for now this seems reasonable, and is in any ! -- case needed for compatibility with old versions of gigi. ! -- look to be unknown. elsif Known_Esize (E) and then Unknown_RM_Size (E) then Set_RM_Size (E, Esize (E)); end if; ! -- For array base types, set component size if object size of ! -- the component type is known and is a small power of 2 (8, ! -- 16, 32, 64), since this is what will always be used. if Ekind (E) = E_Array_Type and then Unknown_Component_Size (E) --- 2516,2532 ---- end; end if; ! -- If Esize is set, and RM_Size is not, RM_Size is copied from Esize. ! -- At least for now this seems reasonable, and is in any case needed ! -- for compatibility with old versions of gigi. elsif Known_Esize (E) and then Unknown_RM_Size (E) then Set_RM_Size (E, Esize (E)); end if; ! -- For array base types, set component size if object size of the ! -- component type is known and is a small power of 2 (8, 16, 32, 64), ! -- since this is what will always be used. if Ekind (E) = E_Array_Type and then Unknown_Component_Size (E) *************** package body Layout is *** 2540,2547 **** CT : constant Entity_Id := Component_Type (E); begin ! -- For some reasons, access types can cause trouble, ! -- So let's just do this for discrete types ??? if Present (CT) and then Is_Discrete_Type (CT) --- 2535,2542 ---- CT : constant Entity_Id := Component_Type (E); begin ! -- For some reasons, access types can cause trouble, So let's ! -- just do this for discrete types ??? if Present (CT) and then Is_Discrete_Type (CT) *************** package body Layout is *** 2591,2597 **** Set_Composite_Alignment (E); end if; ! -- Procressing for array types elsif Is_Array_Type (E) then --- 2586,2592 ---- Set_Composite_Alignment (E); end if; ! -- Processing for array types elsif Is_Array_Type (E) then *************** package body Layout is *** 2646,2654 **** begin Set_Esize (E, RM_Size (E)); ! -- For scalar types, increase Object_Size to power of 2, ! -- but not less than a storage unit in any case (i.e., ! -- normally this means it will be storage-unit addressable). if Is_Scalar_Type (E) then if Size <= System_Storage_Unit then --- 2641,2649 ---- begin Set_Esize (E, RM_Size (E)); ! -- For scalar types, increase Object_Size to power of 2, but ! -- not less than a storage unit in any case (i.e., normally ! -- this means it will be storage-unit addressable). if Is_Scalar_Type (E) then if Size <= System_Storage_Unit then *************** package body Layout is *** 2700,2715 **** SC : Node_Id; procedure Check_Size_Too_Small (Spec : Uint; Min : Uint); ! -- Spec is the number of bit specified in the size clause, and ! -- Min is the minimum computed size. An error is given that the ! -- specified size is too small if Spec < Min, and in this case ! -- both Esize and RM_Size are set to unknown in E. The error ! -- message is posted on node SC. procedure Check_Unused_Bits (Spec : Uint; Max : Uint); ! -- Spec is the number of bits specified in the size clause, and ! -- Max is the maximum computed size. A warning is given about ! -- unused bits if Spec > Max. This warning is posted on node SC. -------------------------- -- Check_Size_Too_Small -- --- 2695,2709 ---- SC : Node_Id; procedure Check_Size_Too_Small (Spec : Uint; Min : Uint); ! -- Spec is the number of bit specified in the size clause, and Min is ! -- the minimum computed size. An error is given that the specified size ! -- is too small if Spec < Min, and in this case both Esize and RM_Size ! -- are set to unknown in E. The error message is posted on node SC. procedure Check_Unused_Bits (Spec : Uint; Max : Uint); ! -- Spec is the number of bits specified in the size clause, and Max is ! -- the maximum computed size. A warning is given about unused bits if ! -- Spec > Max. This warning is posted on node SC. -------------------------- -- Check_Size_Too_Small -- *************** package body Layout is *** 2758,2767 **** end if; end if; ! -- Case where Value_Size (RM_Size) is set by specific Value_Size ! -- clause (we do not need to worry about Value_Size being set by ! -- a Size clause, since that will have set Esize as well, and we ! -- already took care of that case). if Known_Static_RM_Size (E) then SC := Get_Attribute_Definition_Clause (E, Attribute_Value_Size); --- 2752,2761 ---- end if; end if; ! -- Case where Value_Size (RM_Size) is set by specific Value_Size clause ! -- (we do not need to worry about Value_Size being set by a Size clause, ! -- since that will have set Esize as well, and we already took care of ! -- that case). if Known_Static_RM_Size (E) then SC := Get_Attribute_Definition_Clause (E, Attribute_Value_Size); *************** package body Layout is *** 2794,2800 **** Align : Nat; begin ! if Unknown_Alignment (E) then if Known_Static_Esize (E) then Siz := Esize (E); --- 2788,2819 ---- Align : Nat; begin ! -- If alignment is already set, then nothing to do ! ! if Known_Alignment (E) then ! return; ! end if; ! ! -- Alignment is not known, see if we can set it, taking into account ! -- the setting of the Optimize_Alignment mode. ! ! -- If Optimize_Alignment is set to Space, then packed records always ! -- have an alignment of 1. But don't do anything for atomic records ! -- since we may need higher alignment for indivisible access. ! ! if Optimize_Alignment_Space (E) ! and then Is_Record_Type (E) ! and then Is_Packed (E) ! and then not Is_Atomic (E) ! then ! Align := 1; ! ! -- Not a record, or not packed ! ! else ! -- The only other cases we worry about here are where the size is ! -- statically known at compile time. ! if Known_Static_Esize (E) then Siz := Esize (E); *************** package body Layout is *** 2809,2816 **** -- Size is known, alignment is not set ! -- Reset alignment to match size if size is exactly 2, 4, or 8 ! -- storage units. if Siz = 2 * System_Storage_Unit then Align := 2; --- 2828,2835 ---- -- Size is known, alignment is not set ! -- Reset alignment to match size if the known size is exactly 2, 4, ! -- or 8 storage units. if Siz = 2 * System_Storage_Unit then Align := 2; *************** package body Layout is *** 2819,2872 **** elsif Siz = 8 * System_Storage_Unit then Align := 8; ! -- On VMS, also reset for odd "in between" sizes, e.g. a 17-bit ! -- record is given an alignment of 4. This is more consistent with ! -- what DEC Ada does (-gnatd.a turns this off which can be used to ! -- examine the value of this special transformation). ! elsif OpenVMS_On_Target ! and then not Debug_Flag_Dot_A and then Siz > System_Storage_Unit then if Siz <= 2 * System_Storage_Unit then Align := 2; elsif Siz <= 4 * System_Storage_Unit then Align := 4; ! elsif Siz <= 8 * System_Storage_Unit then Align := 8; - else - return; end if; ! -- No special alignment fiddling needed else return; end if; ! -- Here Align is set to the proposed improved alignment ! if Align > Maximum_Alignment then ! Align := Maximum_Alignment; ! end if; ! -- Further processing for record types only to reduce the alignment ! -- set by the above processing in some specific cases. We do not ! -- do this for atomic records, since we need max alignment there. ! if Is_Record_Type (E) then ! -- For records, there is generally no point in setting alignment ! -- higher than word size since we cannot do better than move by ! -- words in any case ! if Align > System_Word_Size / System_Storage_Unit then ! Align := System_Word_Size / System_Storage_Unit; ! end if; ! -- Check components. If any component requires a higher ! -- alignment, then we set that higher alignment in any case. declare Comp : Entity_Id; --- 2838,2912 ---- elsif Siz = 8 * System_Storage_Unit then Align := 8; ! -- If Optimize_Alignment is set to Space, then make sure the ! -- alignment matches the size, for example, if the size is 17 ! -- bytes then we want an alignment of 1 for the type. ! elsif Optimize_Alignment_Space (E) then ! if Siz mod (8 * System_Storage_Unit) = 0 then ! Align := 8; ! elsif Siz mod (4 * System_Storage_Unit) = 0 then ! Align := 4; ! elsif Siz mod (2 * System_Storage_Unit) = 0 then ! Align := 2; ! else ! Align := 1; ! end if; ! ! -- If Optimize_Alignment is set to Time, then we reset for odd ! -- "in between sizes", for example a 17 bit record is given an ! -- alignment of 4. Note that this matches the old VMS behavior ! -- in versions of GNAT prior to 6.1.1. ! ! elsif Optimize_Alignment_Time (E) and then Siz > System_Storage_Unit + and then Siz <= 8 * System_Storage_Unit then if Siz <= 2 * System_Storage_Unit then Align := 2; elsif Siz <= 4 * System_Storage_Unit then Align := 4; ! else -- Siz <= 8 * System_Storage_Unit then Align := 8; end if; ! -- No special alignment fiddling needed else return; end if; + end if; ! -- Here we have Set Align to the proposed improved value. Make sure the ! -- value set does not exceed Maximum_Alignment for the target. ! if Align > Maximum_Alignment then ! Align := Maximum_Alignment; ! end if; ! -- Further processing for record types only to reduce the alignment ! -- set by the above processing in some specific cases. We do not ! -- do this for atomic records, since we need max alignment there, ! if Is_Record_Type (E) and then not Is_Atomic (E) then ! -- For records, there is generally no point in setting alignment ! -- higher than word size since we cannot do better than move by ! -- words in any case. Omit this if we are optimizing for time, ! -- since conceivably we may be able to do better. ! if Align > System_Word_Size / System_Storage_Unit ! and then not Optimize_Alignment_Time (E) ! then ! Align := System_Word_Size / System_Storage_Unit; ! end if; ! -- Check components. If any component requires a higher alignment, ! -- then we set that higher alignment in any case. Don't do this if ! -- we have Optimize_Alignment set to Space. Note that that covers ! -- the case of packed records, where we already set alignment to 1. + if not Optimize_Alignment_Space (E) then declare Comp : Entity_Id; *************** package body Layout is *** 2878,2896 **** Calign : constant Uint := Alignment (Etype (Comp)); begin ! -- The cases to worry about are when the alignment ! -- of the component type is larger than the alignment ! -- we have so far, and either there is no component ! -- clause for the alignment, or the length set by ! -- the component clause matches the alignment set. if Calign > Align and then (Unknown_Esize (Comp) ! or else (Known_Static_Esize (Comp) ! and then ! Esize (Comp) = ! Calign * System_Storage_Unit)) then Align := UI_To_Int (Calign); end if; --- 2918,2936 ---- Calign : constant Uint := Alignment (Etype (Comp)); begin ! -- The cases to process are when the alignment of the ! -- component type is larger than the alignment we have ! -- so far, and either there is no component clause for ! -- the component, or the length set by the component ! -- clause matches the length of the component type. if Calign > Align and then (Unknown_Esize (Comp) ! or else (Known_Static_Esize (Comp) ! and then ! Esize (Comp) = ! Calign * System_Storage_Unit)) then Align := UI_To_Int (Calign); end if; *************** package body Layout is *** 2901,2916 **** end loop; end; end if; ! -- Set chosen alignment ! Set_Alignment (E, UI_From_Int (Align)); ! if Known_Static_Esize (E) ! and then Esize (E) < Align * System_Storage_Unit ! then ! Set_Esize (E, UI_From_Int (Align * System_Storage_Unit)); ! end if; end if; end Set_Composite_Alignment; --- 2941,2957 ---- end loop; end; end if; + end if; ! -- Set chosen alignment, and increase Esize if necessary to match the ! -- chosen alignment. ! Set_Alignment (E, UI_From_Int (Align)); ! if Known_Static_Esize (E) ! and then Esize (E) < Align * System_Storage_Unit ! then ! Set_Esize (E, UI_From_Int (Align * System_Storage_Unit)); end if; end Set_Composite_Alignment; *************** package body Layout is *** 2922,2942 **** FST : constant Entity_Id := First_Subtype (Def_Id); begin ! -- All discrete types except for the base types in standard ! -- are constrained, so indicate this by setting Is_Constrained. Set_Is_Constrained (Def_Id); ! -- We set generic types to have an unknown size, since the ! -- representation of a generic type is irrelevant, in view ! -- of the fact that they have nothing to do with code. if Is_Generic_Type (Root_Type (FST)) then Set_RM_Size (Def_Id, Uint_0); ! -- If the subtype statically matches the first subtype, then ! -- it is required to have exactly the same layout. This is ! -- required by aliasing considerations. elsif Def_Id /= FST and then Subtypes_Statically_Match (Def_Id, FST) --- 2963,2983 ---- FST : constant Entity_Id := First_Subtype (Def_Id); begin ! -- All discrete types except for the base types in standard are ! -- constrained, so indicate this by setting Is_Constrained. Set_Is_Constrained (Def_Id); ! -- Set generic types to have an unknown size, since the representation ! -- of a generic type is irrelevant, in view of the fact that they have ! -- nothing to do with code. if Is_Generic_Type (Root_Type (FST)) then Set_RM_Size (Def_Id, Uint_0); ! -- If the subtype statically matches the first subtype, then it is ! -- required to have exactly the same layout. This is required by ! -- aliasing considerations. elsif Def_Id /= FST and then Subtypes_Statically_Match (Def_Id, FST) *************** package body Layout is *** 2944,2952 **** Set_RM_Size (Def_Id, RM_Size (FST)); Set_Size_Info (Def_Id, FST); ! -- In all other cases the RM_Size is set to the minimum size. ! -- Note that this routine is never called for subtypes for which ! -- the RM_Size is set explicitly by an attribute clause. else Set_RM_Size (Def_Id, UI_From_Int (Minimum_Size (Def_Id))); --- 2985,2993 ---- Set_RM_Size (Def_Id, RM_Size (FST)); Set_Size_Info (Def_Id, FST); ! -- In all other cases the RM_Size is set to the minimum size. Note that ! -- this routine is never called for subtypes for which the RM_Size is ! -- set explicitly by an attribute clause. else Set_RM_Size (Def_Id, UI_From_Int (Minimum_Size (Def_Id))); *************** package body Layout is *** 2986,2994 **** return; end if; ! -- Here we calculate the alignment as the largest power of two ! -- multiple of System.Storage_Unit that does not exceed either ! -- the actual size of the type, or the maximum allowed alignment. declare S : constant Int := --- 3027,3035 ---- return; end if; ! -- Here we calculate the alignment as the largest power of two multiple ! -- of System.Storage_Unit that does not exceed either the actual size of ! -- the type, or the maximum allowed alignment. declare S : constant Int := *************** package body Layout is *** 3003,3020 **** A := 2 * A; end loop; ! -- Now we think we should set the alignment to A, but we ! -- skip this if an alignment is already set to a value ! -- greater than A (happens for derived types). ! -- However, if the alignment is known and too small it ! -- must be increased, this happens in a case like: -- type R is new Character; -- for R'Size use 16; ! -- Here the alignment inherited from Character is 1, but ! -- it must be increased to 2 to reflect the increased size. if Unknown_Alignment (E) or else Alignment (E) < A then Init_Alignment (E, A); --- 3044,3061 ---- A := 2 * A; end loop; ! -- Now we think we should set the alignment to A, but we skip this if ! -- an alignment is already set to a value greater than A (happens for ! -- derived types). ! -- However, if the alignment is known and too small it must be ! -- increased, this happens in a case like: -- type R is new Character; -- for R'Size use 16; ! -- Here the alignment inherited from Character is 1, but it must be ! -- increased to 2 to reflect the increased size. if Unknown_Alignment (E) or else Alignment (E) < A then Init_Alignment (E, A); *************** package body Layout is *** 3123,3130 **** Make_Simple_Return_Statement (Loc, Expression => Expr)))); ! -- The caller requests that the expression be encapsulated in ! -- a parameterless function. elsif Make_Func then Decl := --- 3164,3171 ---- Make_Simple_Return_Statement (Loc, Expression => Expr)))); ! -- The caller requests that the expression be encapsulated in a ! -- parameterless function. elsif Make_Func then Decl := diff -Nrcpad gcc-4.3.3/gcc/ada/lib-list.adb gcc-4.4.0/gcc/ada/lib-list.adb *** gcc-4.3.3/gcc/ada/lib-list.adb Fri Dec 9 17:22:27 2005 --- gcc-4.4.0/gcc/ada/lib-list.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/lib-load.adb gcc-4.4.0/gcc/ada/lib-load.adb *** gcc-4.3.3/gcc/ada/lib-load.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/lib-load.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Lib.Load is *** 224,230 **** Source_Index => No_Source_File, Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False), Unit_Name => Spec_Name, ! Version => 0); Set_Comes_From_Source_Default (Save_CS); Set_Error_Posted (Cunit_Entity); --- 224,231 ---- Source_Index => No_Source_File, Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False), Unit_Name => Spec_Name, ! Version => 0, ! OA_Setting => 'O'); Set_Comes_From_Source_Default (Save_CS); Set_Error_Posted (Cunit_Entity); *************** package body Lib.Load is *** 327,333 **** Source_Index => Main_Source_File, Unit_File_Name => Fname, Unit_Name => No_Unit_Name, ! Version => Version); end if; end Load_Main_Source; --- 328,335 ---- Source_Index => Main_Source_File, Unit_File_Name => Fname, Unit_Name => No_Unit_Name, ! Version => Version, ! OA_Setting => 'O'); end if; end Load_Main_Source; *************** package body Lib.Load is *** 647,653 **** Source_Index => Src_Ind, Unit_File_Name => Fname, Unit_Name => Uname_Actual, ! Version => Source_Checksum (Src_Ind)); -- Parse the new unit --- 649,656 ---- Source_Index => Src_Ind, Unit_File_Name => Fname, Unit_Name => Uname_Actual, ! Version => Source_Checksum (Src_Ind), ! OA_Setting => 'O'); -- Parse the new unit *************** package body Lib.Load is *** 708,714 **** -- it may very likely be the case that there is also pragma -- Restriction forbidding its usage. This is typically the -- case when building a configurable run time, where the ! -- usage of certain run-time units units is restricted by -- means of both the corresponding pragma Restriction (such -- as No_Calendar), and by not including the unit. Hence, -- we check whether this predefined unit is forbidden, so --- 711,717 ---- -- it may very likely be the case that there is also pragma -- Restriction forbidding its usage. This is typically the -- case when building a configurable run time, where the ! -- usage of certain run-time units is restricted by -- means of both the corresponding pragma Restriction (such -- as No_Calendar), and by not including the unit. Hence, -- we check whether this predefined unit is forbidden, so diff -Nrcpad gcc-4.3.3/gcc/ada/lib-sort.adb gcc-4.4.0/gcc/ada/lib-sort.adb *** gcc-4.3.3/gcc/ada/lib-sort.adb Mon Oct 15 13:55:27 2007 --- gcc-4.4.0/gcc/ada/lib-sort.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/lib-writ.adb gcc-4.4.0/gcc/ada/lib-writ.adb *** gcc-4.3.3/gcc/ada/lib-writ.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/lib-writ.adb Tue Apr 8 06:45:42 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Lib.Writ is *** 87,93 **** Munit_Index => 0, Serial_Number => 0, Version => 0, ! Error_Location => No_Location); end Add_Preprocessing_Dependency; ------------------------------ --- 87,94 ---- Munit_Index => 0, Serial_Number => 0, Version => 0, ! Error_Location => No_Location, ! OA_Setting => 'O'); end Add_Preprocessing_Dependency; ------------------------------ *************** package body Lib.Writ is *** 141,147 **** Munit_Index => 0, Serial_Number => 0, Version => 0, ! Error_Location => No_Location); -- Parse system.ads so that the checksum is set right -- Style checks are not applied. --- 142,149 ---- Munit_Index => 0, Serial_Number => 0, Version => 0, ! Error_Location => No_Location, ! OA_Setting => 'O'); -- Parse system.ads so that the checksum is set right -- Style checks are not applied. *************** package body Lib.Writ is *** 236,263 **** -- Process with clause -- Ada 2005 (AI-50217): limited with_clauses do not create ! -- dependencies ! if Nkind (Item) = N_With_Clause ! and then not (Limited_Present (Item)) ! then Unum := Get_Cunit_Unit_Number (Library_Unit (Item)); With_Flags (Unum) := True; ! if Elaborate_Present (Item) then ! Elab_Flags (Unum) := True; ! end if; ! if Elaborate_All_Present (Item) then ! Elab_All_Flags (Unum) := True; ! end if; ! if Elaborate_All_Desirable (Item) then ! Elab_All_Des_Flags (Unum) := True; ! end if; ! if Elaborate_Desirable (Item) then ! Elab_Des_Flags (Unum) := True; end if; end if; --- 238,270 ---- -- Process with clause -- Ada 2005 (AI-50217): limited with_clauses do not create ! -- dependencies, but must be recorded as components of the ! -- partition, in case there is no regular with_clause for ! -- the unit anywhere else. ! if Nkind (Item) = N_With_Clause then Unum := Get_Cunit_Unit_Number (Library_Unit (Item)); With_Flags (Unum) := True; ! if not Limited_Present (Item) then ! if Elaborate_Present (Item) then ! Elab_Flags (Unum) := True; ! end if; ! if Elaborate_All_Present (Item) then ! Elab_All_Flags (Unum) := True; ! end if; ! if Elaborate_All_Desirable (Item) then ! Elab_All_Des_Flags (Unum) := True; ! end if; ! if Elaborate_Desirable (Item) then ! Elab_Des_Flags (Unum) := True; ! end if; ! ! else ! Set_From_With_Type (Cunit_Entity (Unum)); end if; end if; *************** package body Lib.Writ is *** 441,446 **** --- 448,456 ---- Write_Info_Str (" NE"); end if; + Write_Info_Str (" O"); + Write_Info_Char (OA_Setting (Unit_Num)); + if Is_Preelaborated (Uent) then Write_Info_Str (" PR"); end if; *************** package body Lib.Writ is *** 512,518 **** end case; end if; ! if Initialize_Scalars then Write_Info_Str (" IS"); end if; --- 522,528 ---- end case; end if; ! if Initialize_Scalars or else Invalid_Value_Used then Write_Info_Str (" IS"); end if; *************** package body Lib.Writ is *** 667,673 **** -- Loop to build the with table. A with on the main unit itself -- is ignored (AARM 10.2(14a)). Such a with-clause can occur if -- the main unit is a subprogram with no spec, and a subunit of ! -- it unecessarily withs the parent. for J in Units.First + 1 .. Last_Unit loop --- 677,683 ---- -- Loop to build the with table. A with on the main unit itself -- is ignored (AARM 10.2(14a)). Such a with-clause can occur if -- the main unit is a subprogram with no spec, and a subunit of ! -- it unnecessarily withs the parent. for J in Units.First + 1 .. Last_Unit loop *************** package body Lib.Writ is *** 696,702 **** Uname := Units.Table (Unum).Unit_Name; Fname := Units.Table (Unum).Unit_File_Name; ! Write_Info_Initiate ('W'); Write_Info_Char (' '); Write_Info_Name (Uname); --- 706,719 ---- Uname := Units.Table (Unum).Unit_Name; Fname := Units.Table (Unum).Unit_File_Name; ! if Ekind (Cunit_Entity (Unum)) = E_Package ! and then From_With_Type (Cunit_Entity (Unum)) ! then ! Write_Info_Initiate ('Y'); ! else ! Write_Info_Initiate ('W'); ! end if; ! Write_Info_Char (' '); Write_Info_Name (Uname); *************** package body Lib.Writ is *** 750,769 **** Write_With_File_Names (Fname, Munit_Index (Unum)); end if; ! if Elab_Flags (Unum) then ! Write_Info_Str (" E"); ! end if; ! if Elab_All_Flags (Unum) then ! Write_Info_Str (" EA"); ! end if; ! if Elab_Des_Flags (Unum) then ! Write_Info_Str (" ED"); ! end if; ! if Elab_All_Des_Flags (Unum) then ! Write_Info_Str (" AD"); end if; end if; --- 767,792 ---- Write_With_File_Names (Fname, Munit_Index (Unum)); end if; ! if Ekind (Cunit_Entity (Unum)) = E_Package ! and then From_With_Type (Cunit_Entity (Unum)) ! then ! null; ! else ! if Elab_Flags (Unum) then ! Write_Info_Str (" E"); ! end if; ! if Elab_All_Flags (Unum) then ! Write_Info_Str (" EA"); ! end if; ! if Elab_Des_Flags (Unum) then ! Write_Info_Str (" ED"); ! end if; ! if Elab_All_Des_Flags (Unum) then ! Write_Info_Str (" AD"); ! end if; end if; end if; *************** package body Lib.Writ is *** 904,910 **** end if; end Output_Main_Program_Line; ! -- Write command argmument ('A') lines for A in 1 .. Compilation_Switches.Last loop Write_Info_Initiate ('A'); --- 927,933 ---- end if; end Output_Main_Program_Line; ! -- Write command argument ('A') lines for A in 1 .. Compilation_Switches.Last loop Write_Info_Initiate ('A'); diff -Nrcpad gcc-4.3.3/gcc/ada/lib-writ.ads gcc-4.4.0/gcc/ada/lib-writ.ads *** gcc-4.3.3/gcc/ada/lib-writ.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/lib-writ.ads Mon Apr 14 21:07:59 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Lib.Writ is *** 77,83 **** -- Adding entirely new lines (with a new key letter) to the ali -- file is always safe, at any point (other than before the V ! -- line), since suchy lines will be ignored. -- Following the guidelines in this section should ensure that this -- problem is minimized and that old tools will be able to deal --- 77,83 ---- -- Adding entirely new lines (with a new key letter) to the ali -- file is always safe, at any point (other than before the V ! -- line), since such lines will be ignored. -- Following the guidelines in this section should ensure that this -- problem is minimized and that old tools will be able to deal *************** package Lib.Writ is *** 167,173 **** -- P <> -- Indicates various information that applies to the compilation ! -- of the corresponding source unit. Parameters is a sequence of -- zero or more two letter codes that indicate configuration -- pragmas and other parameters that apply: -- --- 167,173 ---- -- P <> -- Indicates various information that applies to the compilation ! -- of the corresponding source file. Parameters is a sequence of -- zero or more two letter codes that indicate configuration -- pragmas and other parameters that apply: -- *************** package Lib.Writ is *** 209,215 **** -- to all units in the file. -- -- NS Normalize_Scalars pragma in effect for all units in ! -- this file -- -- Qx A valid Queueing_Policy pragma applies to all the units -- in this file, where x is the first character (upper case) --- 209,215 ---- -- to all units in the file. -- -- NS Normalize_Scalars pragma in effect for all units in ! -- this file. -- -- Qx A valid Queueing_Policy pragma applies to all the units -- in this file, where x is the first character (upper case) *************** package Lib.Writ is *** 395,401 **** -- each compilation unit that appears in the corresponding object file. -- In particular, when a package body or subprogram body is compiled, -- there will be two sets of information, one for the spec and one for ! -- the body. with the entry for the body appearing first. This is the -- only case in which a single ALI file contains more than one unit (in -- particular note that subunits do *not* count as compilation units for -- this purpose, and generate no library information, since they are --- 395,401 ---- -- each compilation unit that appears in the corresponding object file. -- In particular, when a package body or subprogram body is compiled, -- there will be two sets of information, one for the spec and one for ! -- the body, with the entry for the body appearing first. This is the -- only case in which a single ALI file contains more than one unit (in -- particular note that subunits do *not* count as compilation units for -- this purpose, and generate no library information, since they are *************** package Lib.Writ is *** 458,464 **** -- case usage is detected, or the compiler cannot determine -- the style, then no I parameter will appear. -- ! -- IS Initialize_Scalars pragma applies to this unit -- -- KM Unit source uses a style with keywords in mixed case -- KU (KM) or all upper case (KU). If the standard lower-case --- 458,465 ---- -- case usage is detected, or the compiler cannot determine -- the style, then no I parameter will appear. -- ! -- IS Initialize_Scalars pragma applies to this unit, or else there ! -- is at least one use of the Invalid_Value attribute. -- -- KM Unit source uses a style with keywords in mixed case -- KU (KM) or all upper case (KU). If the standard lower-case *************** package Lib.Writ is *** 471,476 **** --- 472,494 ---- -- elaboration code is required. Set if N_Compilation_Unit -- node has flag Has_No_Elaboration_Code set. -- + -- OL The units in this file are compiled with a local pragma + -- Optimize_Alignment, so no consistency requirement applies + -- to these units. All internal units have this status since + -- they have an automatic default of Optimize_Alignment (Off). + -- + -- OO Optimize_Alignment (Off) is the default setting for all + -- units in this file. All files in the partition that specify + -- a default must specify the same default. + -- + -- OS Optimize_Alignment (Space) is the default setting for all + -- units in this file. All files in the partition that specify + -- a default must specify the same default. + -- + -- OT Optimize_Alignment (Time) is the default setting for all + -- units in this file. All files in the partition that specify + -- a default must specify the same default. + -- -- PK Unit is package, rather than a subprogram -- -- PU Unit has pragma Pure *************** package Lib.Writ is *** 498,512 **** -- W unit-name [source-name lib-name] [E] [EA] [ED] [AD] -- -- One of these lines is present for each unit that is mentioned in ! -- an explicit with clause by the current unit. The first parameter ! -- is the unit name in internal format. The second parameter is the ! -- file name of the file that must be compiled to compile this unit. ! -- It is usually the file for the body, except for packages ! -- which have no body; for units that need a body, if the source file ! -- for the body cannot be found, the file name of the spec is used ! -- instead. The third parameter is the file name of the library ! -- information file that contains the results of compiling this unit. ! -- The optional modifiers are used as follows: -- -- E pragma Elaborate applies to this unit -- --- 516,530 ---- -- W unit-name [source-name lib-name] [E] [EA] [ED] [AD] -- -- One of these lines is present for each unit that is mentioned in ! -- an explicit with clause by the current unit. The first parameter is ! -- the unit name in internal format. The second parameter is the file ! -- name of the file that must be compiled to compile this unit. It is ! -- usually the file for the body, except for packages which have no ! -- body. For units that need a body, if the source file for the body ! -- cannot be found, the file name of the spec is used instead. The ! -- third parameter is the file name of the library information file ! -- that contains the results of compiling this unit. The optional ! -- modifiers are used as follows: -- -- E pragma Elaborate applies to this unit -- *************** package Lib.Writ is *** 528,540 **** -- of a generic unit compiled with earlier versions of GNAT which -- did not generate object or ali files for generics. -- ----------------------- -- -- L Linker_Options -- -- ----------------------- -- Following the W lines (if any, or the U line if not), are an -- optional series of lines that indicates the usage of the pragma ! -- Linker_Options in the associated unit. For each appearence of a -- pragma Linker_Options (or Link_With) in the unit, a line is -- present with the form: --- 546,560 ---- -- of a generic unit compiled with earlier versions of GNAT which -- did not generate object or ali files for generics. + -- In fact W lines include implicit withs ??? + -- ----------------------- -- -- L Linker_Options -- -- ----------------------- -- Following the W lines (if any, or the U line if not), are an -- optional series of lines that indicates the usage of the pragma ! -- Linker_Options in the associated unit. For each appearance of a -- pragma Linker_Options (or Link_With) in the unit, a line is -- present with the form: diff -Nrcpad gcc-4.3.3/gcc/ada/lib-xref.adb gcc-4.4.0/gcc/ada/lib-xref.adb *** gcc-4.3.3/gcc/ada/lib-xref.adb Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/lib-xref.adb Fri Aug 1 10:33:29 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2008, 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- -- *************** package body Lib.Xref is *** 235,240 **** --- 235,245 ---- -- -- Out param Same as above cases, but OUT parameter + function OK_To_Set_Referenced return Boolean; + -- Returns True if the Referenced flag can be set. There are a few + -- exceptions where we do not want to set this flag, see body for + -- details of these exceptional cases. + --------------- -- Is_On_LHS -- --------------- *************** package body Lib.Xref is *** 304,314 **** return False; end if; end loop; ! -- Parent (N) is assignment statement, check whether N is its name ! return Name (Parent (N)) = N; ! end Is_On_LHS; -- Start of processing for Generate_Reference --- 309,350 ---- return False; end if; end loop; + end Is_On_LHS; ! --------------------------- ! -- OK_To_Set_Referenced -- ! --------------------------- ! function OK_To_Set_Referenced return Boolean is ! P : Node_Id; ! ! begin ! -- A reference from a pragma Unreferenced or pragma Unmodified or ! -- pragma Warnings does not cause the Referenced flag to be set. ! -- This avoids silly warnings about things being referenced and ! -- not assigned when the only reference is from the pragma. ! ! if Nkind (N) = N_Identifier then ! P := Parent (N); ! ! if Nkind (P) = N_Pragma_Argument_Association then ! P := Parent (P); ! ! if Nkind (P) = N_Pragma then ! if Pragma_Name (P) = Name_Warnings ! or else ! Pragma_Name (P) = Name_Unmodified ! or else ! Pragma_Name (P) = Name_Unreferenced ! then ! return False; ! end if; ! end if; ! end if; ! end if; ! ! return True; ! end OK_To_Set_Referenced; -- Start of processing for Generate_Reference *************** package body Lib.Xref is *** 527,535 **** Set_Referenced_As_LHS (E, False); end if; ! -- Any other occurrence counts as referencing the entity ! else Set_Referenced (E); -- If variable, this is an OK reference after an assignment --- 563,571 ---- Set_Referenced_As_LHS (E, False); end if; ! -- Any other occurrence counts as referencing the entity ! elsif OK_To_Set_Referenced then Set_Referenced (E); -- If variable, this is an OK reference after an assignment *************** package body Lib.Xref is *** 824,830 **** -- set to Empty, and Left/Right are set to space. procedure Output_Import_Export_Info (Ent : Entity_Id); ! -- Ouput language and external name information for an interfaced -- entity, using the format , ------------------------ --- 860,866 ---- -- set to Empty, and Left/Right are set to space. procedure Output_Import_Export_Info (Ent : Entity_Id); ! -- Output language and external name information for an interfaced -- entity, using the format , ------------------------ *************** package body Lib.Xref is *** 1114,1129 **** New_Entry (Tref); if Is_Record_Type (Ent) ! and then Present (Abstract_Interfaces (Ent)) then -- Add an entry for each one of the given interfaces -- implemented by type Ent. declare ! Elmt : Elmt_Id; ! begin - Elmt := First_Elmt (Abstract_Interfaces (Ent)); while Present (Elmt) loop New_Entry (Node (Elmt)); Next_Elmt (Elmt); --- 1150,1163 ---- New_Entry (Tref); if Is_Record_Type (Ent) ! and then Present (Interfaces (Ent)) then -- Add an entry for each one of the given interfaces -- implemented by type Ent. declare ! Elmt : Elmt_Id := First_Elmt (Interfaces (Ent)); begin while Present (Elmt) loop New_Entry (Node (Elmt)); Next_Elmt (Elmt); *************** package body Lib.Xref is *** 1539,1552 **** -------------------------- procedure Output_Overridden_Op (Old_E : Entity_Id) is begin ! if Present (Old_E) ! and then Sloc (Old_E) /= Standard_Location then declare ! Loc : constant Source_Ptr := Sloc (Old_E); Par_Unit : constant Unit_Number_Type := Get_Source_Unit (Loc); begin Write_Info_Char ('<'); --- 1573,1606 ---- -------------------------- procedure Output_Overridden_Op (Old_E : Entity_Id) is + Op : Entity_Id; + begin ! -- The overridden operation has an implicit declaration ! -- at the point of derivation. What we want to display ! -- is the original operation, which has the actual body ! -- (or abstract declaration) that is being overridden. ! -- The overridden operation is not always set, e.g. when ! -- it is a predefined operator. ! ! if No (Old_E) then ! return; ! ! elsif Present (Alias (Old_E)) then ! Op := Alias (Old_E); ! ! else ! Op := Old_E; ! end if; ! ! if Present (Op) ! and then Sloc (Op) /= Standard_Location then declare ! Loc : constant Source_Ptr := Sloc (Op); Par_Unit : constant Unit_Number_Type := Get_Source_Unit (Loc); + begin Write_Info_Char ('<'); *************** package body Lib.Xref is *** 1780,1786 **** Par : Node_Id; begin ! if Ekind (Scope (E)) /= E_Generic_Package then return False; end if; --- 1834,1844 ---- Par : Node_Id; begin ! -- The Present check here is an error defense ! ! if Present (Scope (E)) ! and then Ekind (Scope (E)) /= E_Generic_Package ! then return False; end if; *************** package body Lib.Xref is *** 1976,1988 **** -- Additional information for types with progenitors if Is_Record_Type (XE.Ent) ! and then Present (Abstract_Interfaces (XE.Ent)) then declare ! Elmt : Elmt_Id; ! begin - Elmt := First_Elmt (Abstract_Interfaces (XE.Ent)); while Present (Elmt) loop Check_Type_Reference (Node (Elmt), True); Next_Elmt (Elmt); --- 2034,2044 ---- -- Additional information for types with progenitors if Is_Record_Type (XE.Ent) ! and then Present (Interfaces (XE.Ent)) then declare ! Elmt : Elmt_Id := First_Elmt (Interfaces (XE.Ent)); begin while Present (Elmt) loop Check_Type_Reference (Node (Elmt), True); Next_Elmt (Elmt); diff -Nrcpad gcc-4.3.3/gcc/ada/lib-xref.ads gcc-4.4.0/gcc/ada/lib-xref.ads *** gcc-4.3.3/gcc/ada/lib-xref.ads Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/lib-xref.ads Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2008, 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- -- *************** package Lib.Xref is *** 73,79 **** -- in the visible part of a generic package, and space otherwise. -- entity is the name of the referenced entity, with casing in ! -- the canical casing for the source file where it is defined. -- renameref provides information on renaming. If the entity is -- a package, object or overloadable entity which is declared by --- 73,79 ---- -- in the visible part of a generic package, and space otherwise. -- entity is the name of the referenced entity, with casing in ! -- the canonical casing for the source file where it is defined. -- renameref provides information on renaming. If the entity is -- a package, object or overloadable entity which is declared by *************** package Lib.Xref is *** 188,194 **** -- > = subprogram IN parameter -- = = subprogram IN OUT parameter -- < = subprogram OUT parameter ! -- > = subprogram ACCESS parameter -- b is used for spec entities that are repeated in a body, -- including the unit (subprogram, package, task, protected --- 188,194 ---- -- > = subprogram IN parameter -- = = subprogram IN OUT parameter -- < = subprogram OUT parameter ! -- ^ = subprogram ACCESS parameter -- b is used for spec entities that are repeated in a body, -- including the unit (subprogram, package, task, protected *************** package Lib.Xref is *** 276,282 **** -- Pq of this type, then an entry in the list of references to -- Tx will point to the declaration of Pq. Note that this entry -- type is unusual because it an implicit rather than explicit, ! -- and the name of the refrerence does not match the name of the -- entity for which a reference is generated. These entries are -- generated only for entities declared in the extended main -- source unit (main unit itself, its separate spec (if any). --- 276,282 ---- -- Pq of this type, then an entry in the list of references to -- Tx will point to the declaration of Pq. Note that this entry -- type is unusual because it an implicit rather than explicit, ! -- and the name of the reference does not match the name of the -- entity for which a reference is generated. These entries are -- generated only for entities declared in the extended main -- source unit (main unit itself, its separate spec (if any). *************** package Lib.Xref is *** 324,330 **** -- instantiations, this can be nested [...[...[...]]] etc. -- The reference is of the form [file|line] no column is -- present since it is assumed that only one instantiation ! -- appears on a single source line. Note that the appearence -- of file numbers in such references follows the normal -- rules (present only if needed, and resets the current -- file for subsequent references). --- 324,330 ---- -- instantiations, this can be nested [...[...[...]]] etc. -- The reference is of the form [file|line] no column is -- present since it is assumed that only one instantiation ! -- appears on a single source line. Note that the appearance -- of file numbers in such references follows the normal -- rules (present only if needed, and resets the current -- file for subsequent references). *************** package Lib.Xref is *** 358,364 **** -- a reference (e.g. a call) at line 8 column 4 of the -- of the current file. ! -- the END line of the body has an explict reference to -- the name of the procedure at line 12, column 13. -- the body ends at line 12, column 15, just past this label --- 358,364 ---- -- a reference (e.g. a call) at line 8 column 4 of the -- of the current file. ! -- the END line of the body has an explicit reference to -- the name of the procedure at line 12, column 13. -- the body ends at line 12, column 15, just past this label *************** package Lib.Xref is *** 587,593 **** -- Node N is an operator node, whose entity has been set. If this entity -- is a user defined operator (i.e. an operator not defined in package -- Standard), then a reference to the operator is recorded at node N. ! -- T is the operand type of of the operator. A reference to the operator -- is an implicit reference to the type, and that needs to be recorded -- to avoid spurious warnings on unused entities, when the operator is -- a renaming of a predefined operator. --- 587,593 ---- -- Node N is an operator node, whose entity has been set. If this entity -- is a user defined operator (i.e. an operator not defined in package -- Standard), then a reference to the operator is recorded at node N. ! -- T is the operand type of the operator. A reference to the operator -- is an implicit reference to the type, and that needs to be recorded -- to avoid spurious warnings on unused entities, when the operator is -- a renaming of a predefined operator. diff -Nrcpad gcc-4.3.3/gcc/ada/lib.adb gcc-4.4.0/gcc/ada/lib.adb *** gcc-4.3.3/gcc/ada/lib.adb Sat Nov 15 16:15:00 2008 --- gcc-4.4.0/gcc/ada/lib.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Lib is *** 145,150 **** --- 143,153 ---- return Units.Table (U).Munit_Index; end Munit_Index; + function OA_Setting (U : Unit_Number_Type) return Character is + begin + return Units.Table (U).OA_Setting; + end OA_Setting; + function Source_Index (U : Unit_Number_Type) return Source_File_Index is begin return Units.Table (U).Source_Index; *************** package body Lib is *** 223,228 **** --- 226,236 ---- Units.Table (U).Main_Priority := P; end Set_Main_Priority; + procedure Set_OA_Setting (U : Unit_Number_Type; C : Character) is + begin + Units.Table (U).OA_Setting := C; + end Set_OA_Setting; + procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is begin Units.Table (U).Unit_Name := N; *************** package body Lib is *** 334,340 **** end if; -- At this stage we know that neither is a subunit, so we deal ! -- with instantiations, since we culd have a common ancestor Inst1 := Instantiation (Sind1); Inst2 := Instantiation (Sind2); --- 342,348 ---- end if; -- At this stage we know that neither is a subunit, so we deal ! -- with instantiations, since we could have a common ancestor Inst1 := Instantiation (Sind1); Inst2 := Instantiation (Sind2); diff -Nrcpad gcc-4.3.3/gcc/ada/lib.ads gcc-4.4.0/gcc/ada/lib.ads *** gcc-4.3.3/gcc/ada/lib.ads Sat Nov 15 16:15:00 2008 --- gcc-4.4.0/gcc/ada/lib.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Lib is *** 344,349 **** --- 342,351 ---- -- that the default priority is to be used (and is also used for -- entries that do not correspond to possible main programs). + -- OA_Setting + -- This is a character field containing L if Optimize_Alignment mode + -- was set locally, and O/T/S for Off/Time/Space default if not. + -- Serial_Number -- This field holds a serial number used by New_Internal_Name to -- generate unique temporary numbers on a unit by unit basis. The *************** package Lib is *** 385,390 **** --- 387,393 ---- function Loading (U : Unit_Number_Type) return Boolean; function Main_Priority (U : Unit_Number_Type) return Int; function Munit_Index (U : Unit_Number_Type) return Nat; + function OA_Setting (U : Unit_Number_Type) return Character; function Source_Index (U : Unit_Number_Type) return Source_File_Index; function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type; function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type; *************** package Lib is *** 401,406 **** --- 404,410 ---- procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id); procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True); procedure Set_Main_Priority (U : Unit_Number_Type; P : Int); + procedure Set_OA_Setting (U : Unit_Number_Type; C : Character); procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type); -- Set value of named field for given units table entry. Note that we -- do not have an entry for each possible field, since some of the fields *************** private *** 636,641 **** --- 640,646 ---- pragma Inline (Loading); pragma Inline (Main_Priority); pragma Inline (Munit_Index); + pragma Inline (OA_Setting); pragma Inline (Set_Cunit); pragma Inline (Set_Cunit_Entity); pragma Inline (Set_Fatal_Error); *************** private *** 643,648 **** --- 648,654 ---- pragma Inline (Set_Has_RACW); pragma Inline (Set_Loading); pragma Inline (Set_Main_Priority); + pragma Inline (Set_OA_Setting); pragma Inline (Set_Unit_Name); pragma Inline (Source_Index); pragma Inline (Unit_File_Name); *************** private *** 668,673 **** --- 674,680 ---- Is_Compiler_Unit : Boolean; Dynamic_Elab : Boolean; Loading : Boolean; + OA_Setting : Character; end record; -- The following representation clause ensures that the above record *************** private *** 692,702 **** Generate_Code at 53 range 0 .. 7; Has_RACW at 54 range 0 .. 7; Dynamic_Elab at 55 range 0 .. 7; ! Is_Compiler_Unit at 56 range 0 .. 31; ! Loading at 60 range 0 .. 31; end record; ! for Unit_Record'Size use 64 * 8; -- This ensures that we did not leave out any fields package Units is new Table.Table ( --- 699,710 ---- Generate_Code at 53 range 0 .. 7; Has_RACW at 54 range 0 .. 7; Dynamic_Elab at 55 range 0 .. 7; ! Is_Compiler_Unit at 56 range 0 .. 7; ! OA_Setting at 57 range 0 .. 7; ! Loading at 58 range 0 .. 15; end record; ! for Unit_Record'Size use 60 * 8; -- This ensures that we did not leave out any fields package Units is new Table.Table ( diff -Nrcpad gcc-4.3.3/gcc/ada/link.c gcc-4.4.0/gcc/ada/link.c *** gcc-4.3.3/gcc/ada/link.c Wed Nov 14 12:26:05 2007 --- gcc-4.4.0/gcc/ada/link.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** *** 50,63 **** /* link_max is a conservative system specific threshold (in bytes) of the */ /* argument length passed to the linker which will trigger a file being */ /* used instead of the command line directly. If the argument length is */ ! /* greater than this threshhold, then an objlist_file will be generated */ /* and object_file_option and objlist_file_supported must be set. If */ /* objlist_file_supported is set to 0 (unsupported), then link_max is */ /* set to 2**31-1 so that the limit will never be exceeded. */ /* run_path_option is the system dependent linker option which specifies */ /* the run time path to use when loading dynamic libraries. This should */ ! /* be set to the null string if the system does not support dynmamic */ /* loading of libraries. */ /* shared_libgnat_default gives the system dependent link method that */ --- 49,62 ---- /* link_max is a conservative system specific threshold (in bytes) of the */ /* argument length passed to the linker which will trigger a file being */ /* used instead of the command line directly. If the argument length is */ ! /* greater than this threshold, then an objlist_file will be generated */ /* and object_file_option and objlist_file_supported must be set. If */ /* objlist_file_supported is set to 0 (unsupported), then link_max is */ /* set to 2**31-1 so that the limit will never be exceeded. */ /* run_path_option is the system dependent linker option which specifies */ /* the run time path to use when loading dynamic libraries. This should */ ! /* be set to the null string if the system does not support dynamic */ /* loading of libraries. */ /* shared_libgnat_default gives the system dependent link method that */ *************** unsigned char __gnat_objlist_file_suppor *** 153,159 **** unsigned char __gnat_using_gnu_linker = 1; const char *__gnat_object_library_extension = ".a"; ! #elif defined (linux) const char *__gnat_object_file_option = ""; const char *__gnat_run_path_option = "-Wl,-rpath,"; char __gnat_shared_libgnat_default = STATIC; --- 152,158 ---- unsigned char __gnat_using_gnu_linker = 1; const char *__gnat_object_library_extension = ".a"; ! #elif defined (linux) || defined(__GLIBC__) const char *__gnat_object_file_option = ""; const char *__gnat_run_path_option = "-Wl,-rpath,"; char __gnat_shared_libgnat_default = STATIC; diff -Nrcpad gcc-4.3.3/gcc/ada/live.ads gcc-4.4.0/gcc/ada/live.ads *** gcc-4.3.3/gcc/ada/live.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/live.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2008, 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- -- *************** package Live is *** 31,36 **** procedure Collect_Garbage_Entities; -- Eliminate unreachable entities using a mark-and-sweep from ! -- the set of root entities, ie. those having Is_Public set. end Live; --- 31,36 ---- procedure Collect_Garbage_Entities; -- Eliminate unreachable entities using a mark-and-sweep from ! -- the set of root entities, i.e. those having Is_Public set. end Live; diff -Nrcpad gcc-4.3.3/gcc/ada/make.adb gcc-4.4.0/gcc/ada/make.adb *** gcc-4.3.3/gcc/ada/make.adb Sat Nov 15 16:15:00 2008 --- gcc-4.4.0/gcc/ada/make.adb Fri Nov 7 10:46:18 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with ALI; use ALI; *** 27,32 **** --- 27,33 ---- with ALI.Util; use ALI.Util; with Csets; with Debug; + with Errutil; with Fmap; with Fname; use Fname; with Fname.SF; use Fname.SF; *************** package body Make is *** 319,324 **** --- 320,334 ---- Saved_Maximum_Processes : Natural := 0; + Gnatmake_Switch_Found : Boolean; + -- Set by Scan_Make_Arg. True when the switch is a gnatmake switch. + -- Tested by Add_Switches when switches in package Builder must all be + -- gnatmake switches. + + Switch_May_Be_Passed_To_The_Compiler : Boolean; + -- Set by Add_Switches and Switches_Of. True when unrecognized switches + -- are passed to the Ada compiler. + type Arg_List_Ref is access Argument_List; The_Saved_Gcc_Switches : Arg_List_Ref; *************** package body Make is *** 415,421 **** Do_Link_Step : Boolean := True; -- Flags to indicate what step should be executed. Can be set to False -- with the switches -c, -b and -l. These flags are reset to True for ! -- each invokation of procedure Gnatmake. Shared_String : aliased String := "-shared"; Force_Elab_Flags_String : aliased String := "-F"; --- 425,431 ---- Do_Link_Step : Boolean := True; -- Flags to indicate what step should be executed. Can be set to False -- with the switches -c, -b and -l. These flags are reset to True for ! -- each invocation of procedure Gnatmake. Shared_String : aliased String := "-shared"; Force_Elab_Flags_String : aliased String := "-F"; *************** package body Make is *** 589,599 **** -- Gnatmake Routines -- ----------------------- - Gnatmake_Called : Boolean := False; - -- Set to True when procedure Gnatmake is called. - -- Attempt to delete temporary files is made only when Gnatmake_Called - -- is True. - subtype Lib_Mark_Type is Byte; -- Used in Mark_Directory --- 599,604 ---- *************** package body Make is *** 650,657 **** -- project file. If the Source_File ends with a standard GNAT extension -- (".ads" or ".adb"), try first the full name, then the name without the -- extension, then, if Allow_ALI is True, the name with the extension ! -- ".ali". If there is no switches for either names, try the default ! -- switches for Ada. If all failed, return No_Variable_Value. function Is_In_Object_Directory (Source_File : File_Name_Type; --- 655,663 ---- -- project file. If the Source_File ends with a standard GNAT extension -- (".ads" or ".adb"), try first the full name, then the name without the -- extension, then, if Allow_ALI is True, the name with the extension ! -- ".ali". If there is no switches for either names, try first Switches ! -- (others) then the default switches for Ada. If all failed, return ! -- No_Variable_Value. function Is_In_Object_Directory (Source_File : File_Name_Type; *************** package body Make is *** 664,684 **** -- Compiler, Binder & Linker Data and Subprograms -- ---------------------------------------------------- ! Gcc : String_Access := Program_Name ("gcc"); ! Gnatbind : String_Access := Program_Name ("gnatbind"); ! Gnatlink : String_Access := Program_Name ("gnatlink"); -- Default compiler, binder, linker programs ! Saved_Gcc : String_Access := null; ! Saved_Gnatbind : String_Access := null; ! Saved_Gnatlink : String_Access := null; -- Given by the command line. Will be used, if non null ! Gcc_Path : String_Access := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all); ! Gnatbind_Path : String_Access := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all); ! Gnatlink_Path : String_Access := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all); -- Path for compiler, binder, linker programs, defaulted now for gnatdist. -- Changed later if overridden on command line. --- 670,690 ---- -- Compiler, Binder & Linker Data and Subprograms -- ---------------------------------------------------- ! Gcc : String_Access := Program_Name ("gcc", "gnatmake"); ! Gnatbind : String_Access := Program_Name ("gnatbind", "gnatmake"); ! Gnatlink : String_Access := Program_Name ("gnatlink", "gnatmake"); -- Default compiler, binder, linker programs ! Saved_Gcc : String_Access := null; ! Saved_Gnatbind : String_Access := null; ! Saved_Gnatlink : String_Access := null; -- Given by the command line. Will be used, if non null ! Gcc_Path : String_Access := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all); ! Gnatbind_Path : String_Access := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all); ! Gnatlink_Path : String_Access := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all); -- Path for compiler, binder, linker programs, defaulted now for gnatdist. -- Changed later if overridden on command line. *************** package body Make is *** 698,704 **** Display_Executed_Programs : Boolean := True; -- Set to True if name of commands should be output on stderr (or on stdout ! -- if the Commands_To_Stdout flag was set by use of the -S switch). Output_File_Name_Seen : Boolean := False; -- Set to True after having scanned the file_name for --- 704,710 ---- Display_Executed_Programs : Boolean := True; -- Set to True if name of commands should be output on stderr (or on stdout ! -- if the Commands_To_Stdout flag was set by use of the -eS switch). Output_File_Name_Seen : Boolean := False; -- Set to True after having scanned the file_name for *************** package body Make is *** 723,732 **** -- file, to avoid displaying the -gnatec switch for a temporary file. procedure Add_Switches ! (The_Package : Package_Id; ! File_Name : String; ! Index : Int; ! Program : Make_Program_Type); procedure Add_Switch (S : String_Access; Program : Make_Program_Type; --- 729,739 ---- -- file, to avoid displaying the -gnatec switch for a temporary file. procedure Add_Switches ! (The_Package : Package_Id; ! File_Name : String; ! Index : Int; ! Program : Make_Program_Type; ! Unknown_Switches_To_The_Compiler : Boolean := True); procedure Add_Switch (S : String_Access; Program : Make_Program_Type; *************** package body Make is *** 739,746 **** And_Save : Boolean := True); -- Make invokes one of three programs (the compiler, the binder or the -- linker). For the sake of convenience, some program specific switches ! -- can be passed directly on the gnatmake commande line. This procedure ! -- records these switches so that gnamake can pass them to the right -- program. S is the switch to be added at the end of the command line -- for Program if Append_Switch is True. If Append_Switch is False S is -- added at the beginning of the command line. --- 746,753 ---- And_Save : Boolean := True); -- Make invokes one of three programs (the compiler, the binder or the -- linker). For the sake of convenience, some program specific switches ! -- can be passed directly on the gnatmake command line. This procedure ! -- records these switches so that gnatmake can pass them to the right -- program. S is the switch to be added at the end of the command line -- for Program if Append_Switch is True. If Append_Switch is False S is -- added at the beginning of the command line. *************** package body Make is *** 824,830 **** -- The path name of a mapping file specified by switch -C= procedure Delete_Mapping_Files; ! -- Delete all temporary mapping files procedure Init_Mapping_File (Project : Project_Id; --- 831,838 ---- -- The path name of a mapping file specified by switch -C= procedure Delete_Mapping_Files; ! -- Delete all temporary mapping files. Called only in Delete_All_Temp_Files ! -- which ensures that Debug_Flag_N is False. procedure Init_Mapping_File (Project : Project_Id; *************** package body Make is *** 834,843 **** -- the index to the name of the file in the array The_Mapping_File_Names. procedure Delete_Temp_Config_Files; ! -- Delete all temporary config files procedure Delete_All_Temp_Files; ! -- Delete all temp files (config files, mapping files, path files) ------------------------------------------------- -- Subprogram declarations moved from the spec -- --- 842,854 ---- -- the index to the name of the file in the array The_Mapping_File_Names. procedure Delete_Temp_Config_Files; ! -- Delete all temporary config files. Must not be called if Debug_Flag_N ! -- is False. procedure Delete_All_Temp_Files; ! -- Delete all temp files (config files, mapping files, path files), unless ! -- Debug_Flag_N is True (in which case all temp files are left for user ! -- examination). ------------------------------------------------- -- Subprogram declarations moved from the spec -- *************** package body Make is *** 1069,1075 **** else Get_Name_String ! (Project_Tree.Projects.Table (Main_Project).Display_Directory); Add_Lib_Search_Dir (Normalize_Pathname (Path, Name_Buffer (1 .. Name_Len))); end if; --- 1080,1086 ---- else Get_Name_String ! (Project_Tree.Projects.Table (Main_Project).Directory.Display_Name); Add_Lib_Search_Dir (Normalize_Pathname (Path, Name_Buffer (1 .. Name_Len))); end if; *************** package body Make is *** 1121,1127 **** else Get_Name_String ! (Project_Tree.Projects.Table (Main_Project).Display_Directory); Add_Src_Search_Dir (Normalize_Pathname (Path, Name_Buffer (1 .. Name_Len))); end if; --- 1132,1138 ---- else Get_Name_String ! (Project_Tree.Projects.Table (Main_Project).Directory.Display_Name); Add_Src_Search_Dir (Normalize_Pathname (Path, Name_Buffer (1 .. Name_Len))); end if; *************** package body Make is *** 1237,1300 **** ------------------ procedure Add_Switches ! (The_Package : Package_Id; ! File_Name : String; ! Index : Int; ! Program : Make_Program_Type) is Switches : Variable_Value; Switch_List : String_List_Id; Element : String_Element; begin if File_Name'Length > 0 then Name_Len := File_Name'Length; Name_Buffer (1 .. Name_Len) := File_Name; Switches := Switches_Of ! (Source_File => Name_Find, ! Source_File_Name => File_Name, ! Source_Index => Index, ! Naming => Project_Tree.Projects.Table ! (Main_Project).Naming, ! In_Package => The_Package, ! Allow_ALI => ! Program = Binder or else Program = Linker); ! ! case Switches.Kind is ! when Undefined => ! null; ! ! when List => ! Program_Args := Program; ! ! Switch_List := Switches.Values; ! ! while Switch_List /= Nil_String loop ! Element := Project_Tree.String_Elements.Table (Switch_List); ! Get_Name_String (Element.Value); ! ! if Name_Len > 0 then ! declare ! Argv : constant String := Name_Buffer (1 .. Name_Len); ! -- We need a copy, because Name_Buffer may be modified ! ! begin ! if Verbose_Mode then ! Write_Str (" Adding "); ! Write_Line (Argv); ! end if; ! ! Scan_Make_Arg (Argv, And_Save => False); ! end; ! end if; ! Switch_List := Element.Next; ! end loop; ! when Single => ! Program_Args := Program; ! Get_Name_String (Switches.Value); if Name_Len > 0 then declare --- 1248,1287 ---- ------------------ procedure Add_Switches ! (The_Package : Package_Id; ! File_Name : String; ! Index : Int; ! Program : Make_Program_Type; ! Unknown_Switches_To_The_Compiler : Boolean := True) is Switches : Variable_Value; Switch_List : String_List_Id; Element : String_Element; begin + Switch_May_Be_Passed_To_The_Compiler := + Unknown_Switches_To_The_Compiler; + if File_Name'Length > 0 then Name_Len := File_Name'Length; Name_Buffer (1 .. Name_Len) := File_Name; Switches := Switches_Of ! (Source_File => Name_Find, ! Source_File_Name => File_Name, ! Source_Index => Index, ! Naming => Project_Tree.Projects.Table ! (Main_Project).Naming, ! In_Package => The_Package, ! Allow_ALI => Program = Binder or else Program = Linker); ! if Switches.Kind = List then ! Program_Args := Program; ! Switch_List := Switches.Values; ! while Switch_List /= Nil_String loop ! Element := Project_Tree.String_Elements.Table (Switch_List); ! Get_Name_String (Element.Value); if Name_Len > 0 then declare *************** package body Make is *** 1308,1316 **** end if; Scan_Make_Arg (Argv, And_Save => False); end; end if; ! end case; end if; end Add_Switches; --- 1295,1319 ---- end if; Scan_Make_Arg (Argv, And_Save => False); + + if not Gnatmake_Switch_Found + and then not Switch_May_Be_Passed_To_The_Compiler + then + Errutil.Error_Msg + ('"' & Argv & + """ is not a gnatmake switch. Consider moving " & + "it to Global_Compilation_Switches.", + Element.Location); + Errutil.Finalize; + Make_Failed + ("*** illegal switch """, Argv, """"); + end if; end; end if; ! ! Switch_List := Element.Next; ! end loop; ! end if; end if; end Add_Switches; *************** package body Make is *** 1392,1398 **** if Project_Of_Current_Object_Directory /= Actual_Project then Project_Of_Current_Object_Directory := Actual_Project; Object_Directory := ! Project_Tree.Projects.Table (Actual_Project).Object_Directory; -- Set the working directory to the object directory of the actual -- project. --- 1395,1401 ---- if Project_Of_Current_Object_Directory /= Actual_Project then Project_Of_Current_Object_Directory := Actual_Project; Object_Directory := ! Project_Tree.Projects.Table (Actual_Project).Object_Directory.Name; -- Set the working directory to the object directory of the actual -- project. *************** package body Make is *** 1414,1422 **** when Directory_Error => Make_Failed ("unable to change to object directory """ & ! Get_Name_String (Project_Tree.Projects.Table ! (Actual_Project).Object_Directory) & """ of project " & Get_Name_String (Project_Tree.Projects.Table (Actual_Project).Display_Name)); --- 1417,1425 ---- when Directory_Error => Make_Failed ("unable to change to object directory """ & ! Path_Or_File_Name (Project_Tree.Projects.Table ! (Actual_Project).Object_Directory.Name) & """ of project " & Get_Name_String (Project_Tree.Projects.Table (Actual_Project).Display_Name)); *************** package body Make is *** 1437,1442 **** --- 1440,1449 ---- O_File : out File_Name_Type; O_Stamp : out Time_Stamp_Type) is + function File_Not_A_Source_Of + (Uname : Name_Id; + Sfile : File_Name_Type) return Boolean; + function First_New_Spec (A : ALI_Id) return File_Name_Type; -- Looks in the with table entries of A and returns the spec file name -- of the first withed unit (subprogram) for which no spec existed when *************** package body Make is *** 1451,1456 **** --- 1458,1491 ---- -- services, but this causes the whole compiler to be dragged along -- for gnatbind and gnatmake. + -------------------------- + -- File_Not_A_Source_Of -- + -------------------------- + + function File_Not_A_Source_Of + (Uname : Name_Id; + Sfile : File_Name_Type) return Boolean + is + UID : Prj.Unit_Index; + U_Data : Unit_Data; + + begin + UID := Units_Htable.Get (Project_Tree.Units_HT, Uname); + + if UID /= Prj.No_Unit_Index then + U_Data := Project_Tree.Units.Table (UID); + + if U_Data.File_Names (Body_Part).Name /= Sfile + and then U_Data.File_Names (Specification).Name /= Sfile + then + Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile)); + return True; + end if; + end if; + + return False; + end File_Not_A_Source_Of; + -------------------- -- First_New_Spec -- -------------------- *************** package body Make is *** 1473,1479 **** File_Name : File_Name_Type; begin ! -- Test whether Uname is the name of a body unit (ie ends with %b) Get_Name_String (Uname); pragma --- 1508,1515 ---- File_Name : File_Name_Type; begin ! -- Test whether Uname is the name of a body unit (i.e. ends ! -- with %b) Get_Name_String (Uname); pragma *************** package body Make is *** 1823,1844 **** end if; end if; ! elsif Main_Project /= No_Project then -- Check if a file name does not correspond to the mapping of -- units to file names. declare WR : With_Record; Unit_Name : Name_Id; - UID : Prj.Unit_Index; - U_Data : Unit_Data; begin U_Chk : for U in ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit loop W_Check : for W in Units.Table (U).First_With .. --- 1859,1895 ---- end if; end if; ! elsif not Read_Only and then Main_Project /= No_Project then -- Check if a file name does not correspond to the mapping of -- units to file names. declare + SD : Sdep_Record; WR : With_Record; Unit_Name : Name_Id; begin U_Chk : for U in ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit loop + -- Check if the file name is one of the source of the + -- unit. + + Get_Name_String (Units.Table (U).Uname); + Name_Len := Name_Len - 2; + Unit_Name := Name_Find; + + if File_Not_A_Source_Of + (Unit_Name, Units.Table (U).Sfile) + then + ALI := No_ALI_Id; + return; + end if; + + -- Do the same check for each of the withed units. + W_Check : for W in Units.Table (U).First_With .. *************** package body Make is *** 1851,1879 **** Name_Len := Name_Len - 2; Unit_Name := Name_Find; ! UID := Units_Htable.Get ! (Project_Tree.Units_HT, Unit_Name); ! ! if UID /= Prj.No_Unit_Index then ! U_Data := Project_Tree.Units.Table (UID); ! ! if U_Data.File_Names (Body_Part).Name /= WR.Sfile ! and then ! U_Data.File_Names (Specification).Name /= ! WR.Sfile ! then ! ALI := No_ALI_Id; ! ! Verbose_Msg ! (Unit_Name, " sources does not include ", ! Name_Id (WR.Sfile)); ! ! return; ! end if; end if; end if; end loop W_Check; end loop U_Chk; end; -- Check that the ALI file is in the correct object directory. --- 1902,1931 ---- Name_Len := Name_Len - 2; Unit_Name := Name_Find; ! if File_Not_A_Source_Of (Unit_Name, WR.Sfile) then ! ALI := No_ALI_Id; ! return; end if; end if; end loop W_Check; end loop U_Chk; + + -- Check also the subunits + + D_Check : + for D in ALIs.Table (ALI).First_Sdep .. + ALIs.Table (ALI).Last_Sdep + loop + SD := Sdep.Table (D); + Unit_Name := SD.Subunit_Name; + + if Unit_Name /= No_Name then + if File_Not_A_Source_Of (Unit_Name, SD.Sfile) then + ALI := No_ALI_Id; + return; + end if; + end if; + end loop D_Check; end; -- Check that the ALI file is in the correct object directory. *************** package body Make is *** 1927,1934 **** Add_Str_To_Name_Buffer (Res_Obj_Dir); if Name_Len > 1 and then ! (Name_Buffer (Name_Len) = '/' or else ! Name_Buffer (Name_Len) = Directory_Separator) then Name_Len := Name_Len - 1; end if; --- 1979,1987 ---- Add_Str_To_Name_Buffer (Res_Obj_Dir); if Name_Len > 1 and then ! (Name_Buffer (Name_Len) = '/' ! or else ! Name_Buffer (Name_Len) = Directory_Separator) then Name_Len := Name_Len - 1; end if; *************** package body Make is *** 1938,1944 **** while ALI_Project /= No_Project and then Obj_Dir /= Project_Tree.Projects.Table ! (ALI_Project).Object_Directory loop ALI_Project := Project_Tree.Projects.Table (ALI_Project).Extended_By; --- 1991,1997 ---- while ALI_Project /= No_Project and then Obj_Dir /= Project_Tree.Projects.Table ! (ALI_Project).Object_Directory.Name loop ALI_Project := Project_Tree.Projects.Table (ALI_Project).Extended_By; *************** package body Make is *** 2330,2336 **** if Data.Dir_Path = null then Data.Dir_Path := ! new String'(Get_Name_String (Data.Display_Directory)); Project_Tree.Projects.Table (Arguments_Project) := Data; end if; --- 2383,2389 ---- if Data.Dir_Path = null then Data.Dir_Path := ! new String'(Get_Name_String (Data.Directory.Display_Name)); Project_Tree.Projects.Table (Arguments_Project) := Data; end if; *************** package body Make is *** 2837,2842 **** --- 2890,2896 ---- end loop; if The_Data.Library + and then not The_Data.Externally_Built and then not The_Data.Need_To_Build_Lib then -- Add to the Q all sources of the project that *************** package body Make is *** 2981,2987 **** -- Set -gnatpg for predefined files (for this purpose the renamings -- such as Text_IO do not count as predefined). Note that we strip ! -- the directory name from the source file name becase the call to -- Fname.Is_Predefined_File_Name cannot deal with directory prefixes. declare --- 3035,3041 ---- -- Set -gnatpg for predefined files (for this purpose the renamings -- such as Text_IO do not count as predefined). Note that we strip ! -- the directory name from the source file name because the call to -- Fname.Is_Predefined_File_Name cannot deal with directory prefixes. declare *************** package body Make is *** 3228,3234 **** exit Make_Loop; end if; ! -- PHASE 1: Check if there is more work that we can do (ie the Q -- is non empty). If there is, do it only if we have not yet used -- up all the available processes. --- 3282,3288 ---- exit Make_Loop; end if; ! -- PHASE 1: Check if there is more work that we can do (i.e. the Q -- is non empty). If there is, do it only if we have not yet used -- up all the available processes. *************** package body Make is *** 3465,3470 **** --- 3519,3525 ---- -- If an ALI file was generated by this compilation, scan -- the ALI file and record it. + -- If the scan fails, a previous ali file is inconsistent with -- the unit just compiled. *************** package body Make is *** 3489,3499 **** -- If we could not read the ALI file that was just generated -- then there could be a problem reading either the ALI or the ! -- corresponding object file (if Check_Object_Consistency ! -- is set Read_Library_Info checks that the time stamp of the ! -- object file is more recent than that of the ALI). For an ! -- example of problems caught by this test see [6625-009]. ! -- However, we record a failure only if not already done. else if Compilation_OK and not Syntax_Only then --- 3544,3553 ---- -- If we could not read the ALI file that was just generated -- then there could be a problem reading either the ALI or the ! -- corresponding object file (if Check_Object_Consistency is ! -- set Read_Library_Info checks that the time stamp of the ! -- object file is more recent than that of the ALI). However, ! -- we record a failure only if not already done. else if Compilation_OK and not Syntax_Only then *************** package body Make is *** 3583,3589 **** Udata.File_Names (Body_Part).Name /= No_File and then ! Udata.File_Names (Body_Part).Path /= Slash then Sfile := Udata.File_Names (Body_Part).Name; Source_Index := --- 3637,3644 ---- Udata.File_Names (Body_Part).Name /= No_File and then ! Udata.File_Names (Body_Part).Path.Name /= ! Slash then Sfile := Udata.File_Names (Body_Part).Name; Source_Index := *************** package body Make is *** 3593,3600 **** Udata.File_Names (Specification).Name /= No_File and then ! Udata.File_Names (Specification).Path /= ! Slash then Sfile := Udata.File_Names (Specification).Name; --- 3648,3655 ---- Udata.File_Names (Specification).Name /= No_File and then ! Udata.File_Names ! (Specification).Path.Name /= Slash then Sfile := Udata.File_Names (Specification).Name; *************** package body Make is *** 3657,3664 **** -- Delete any temporary configuration pragma file ! Delete_Temp_Config_Files; ! end Compile_Sources; ----------------------------------- --- 3712,3720 ---- -- Delete any temporary configuration pragma file ! if not Debug.Debug_Flag_N then ! Delete_Temp_Config_Files; ! end if; end Compile_Sources; ----------------------------------- *************** package body Make is *** 3798,3804 **** Parent_Directory : constant String := Get_Name_String (Project_Tree.Projects.Table ! (Project).Display_Directory); begin if Parent_Directory (Parent_Directory'Last) = --- 3854,3860 ---- Parent_Directory : constant String := Get_Name_String (Project_Tree.Projects.Table ! (Project).Directory.Display_Name); begin if Parent_Directory (Parent_Directory'Last) = *************** package body Make is *** 3865,3872 **** Global_Attribute.Project); begin if not Is_Regular_File (Path) then ! Make_Failed ! ("cannot find configuration pragmas file ", Path); end if; Last := Last + 1; --- 3921,3935 ---- Global_Attribute.Project); begin if not Is_Regular_File (Path) then ! if Debug.Debug_Flag_F then ! Make_Failed ! ("cannot find configuration pragmas file ", ! File_Name (Path)); ! else ! Make_Failed ! ("cannot find configuration pragmas file ", ! Path); ! end if; end if; Last := Last + 1; *************** package body Make is *** 3903,3910 **** Local_Attribute.Project); begin if not Is_Regular_File (Path) then ! Make_Failed ! ("cannot find configuration pragmas file ", Path); end if; Last := Last + 1; --- 3966,3980 ---- Local_Attribute.Project); begin if not Is_Regular_File (Path) then ! if Debug.Debug_Flag_F then ! Make_Failed ! ("cannot find configuration pragmas file ", ! File_Name (Path)); ! ! else ! Make_Failed ! ("cannot find configuration pragmas file ", Path); ! end if; end if; Last := Last + 1; *************** package body Make is *** 3947,3953 **** procedure Delete_All_Temp_Files is begin ! if Gnatmake_Called and not Debug.Debug_Flag_N then Delete_Mapping_Files; Delete_Temp_Config_Files; Prj.Env.Delete_All_Path_Files (Project_Tree); --- 4017,4023 ---- procedure Delete_All_Temp_Files is begin ! if not Debug.Debug_Flag_N then Delete_Mapping_Files; Delete_Temp_Config_Files; Prj.Env.Delete_All_Path_Files (Project_Tree); *************** package body Make is *** 3961,3978 **** procedure Delete_Mapping_Files is Success : Boolean; pragma Warnings (Off, Success); begin ! if not Debug.Debug_Flag_N then ! if The_Mapping_File_Names /= null then ! for Project in The_Mapping_File_Names'Range (1) loop ! for Index in 1 .. Last_Mapping_File_Names (Project) loop ! Delete_File ! (Name => Get_Name_String ! (The_Mapping_File_Names (Project, Index)), ! Success => Success); ! end loop; end loop; ! end if; end if; end Delete_Mapping_Files; --- 4031,4051 ---- procedure Delete_Mapping_Files is Success : Boolean; pragma Warnings (Off, Success); + begin ! -- The caller is responsible for ensuring that Debug_Flag_N is False ! ! pragma Assert (not Debug.Debug_Flag_N); ! ! if The_Mapping_File_Names /= null then ! for Project in The_Mapping_File_Names'Range (1) loop ! for Index in 1 .. Last_Mapping_File_Names (Project) loop ! Delete_File ! (Name => Get_Name_String ! (The_Mapping_File_Names (Project, Index)), ! Success => Success); end loop; ! end loop; end if; end Delete_Mapping_Files; *************** package body Make is *** 3985,3991 **** pragma Warnings (Off, Success); begin ! if (not Debug.Debug_Flag_N) and Main_Project /= No_Project then for Project in Project_Table.First .. Project_Table.Last (Project_Tree.Projects) loop --- 4058,4068 ---- pragma Warnings (Off, Success); begin ! -- The caller is responsible for ensuring that Debug_Flag_N is False ! ! pragma Assert (not Debug.Debug_Flag_N); ! ! if Main_Project /= No_Project then for Project in Project_Table.First .. Project_Table.Last (Project_Tree.Projects) loop *************** package body Make is *** 4006,4015 **** (Project).Config_File_Name), Success => Success); ! -- Make sure that we don't have a config file for this ! -- project, in case when there are several mains. ! -- In this case, we will recreate another config file: ! -- we cannot reuse the one that we just deleted! Project_Tree.Projects.Table (Project). Config_Checked := False; --- 4083,4092 ---- (Project).Config_File_Name), Success => Success); ! -- Make sure that we don't have a config file for this project, ! -- in case there are several mains. In this case, we will ! -- recreate another config file: we cannot reuse the one that ! -- we just deleted! Project_Tree.Projects.Table (Project). Config_Checked := False; *************** package body Make is *** 4073,4079 **** Args (J) (Args (J)'First .. Args (J)'First + 2) /= "-F=" then Write_Str (" "); ! Write_Str (Args (J).all); end if; end if; end if; --- 4150,4189 ---- Args (J) (Args (J)'First .. Args (J)'First + 2) /= "-F=" then Write_Str (" "); ! ! -- If -df is used, only display file names, not path ! -- names. ! ! if Debug.Debug_Flag_F then ! declare ! Equal_Pos : Natural; ! begin ! Equal_Pos := Args (J)'First - 1; ! for K in Args (J)'Range loop ! if Args (J) (K) = '=' then ! Equal_Pos := K; ! exit; ! end if; ! end loop; ! ! if Is_Absolute_Path ! (Args (J) (Equal_Pos + 1 .. Args (J)'Last)) ! then ! Write_Str ! (Args (J) (Args (J)'First .. Equal_Pos)); ! Write_Str ! (File_Name ! (Args (J) ! (Equal_Pos + 1 .. Args (J)'Last))); ! ! else ! Write_Str (Args (J).all); ! end if; ! end; ! ! else ! Write_Str (Args (J).all); ! end if; end if; end if; end if; *************** package body Make is *** 4258,4264 **** -- directory information. File_Name : constant String := Base_Name (Main); ! -- The simple file name of the current main main begin exit when Main = ""; --- 4368,4374 ---- -- directory information. File_Name : constant String := Base_Name (Main); ! -- The simple file name of the current main begin exit when Main = ""; *************** package body Make is *** 4488,4496 **** -- for other projects, use the object directory. if PD.Library then ! Get_Name_String (PD.Library_Dir); else ! Get_Name_String (PD.Object_Directory); end if; if Name_Buffer (Name_Len) /= --- 4598,4606 ---- -- for other projects, use the object directory. if PD.Library then ! Get_Name_String (PD.Library_Dir.Name); else ! Get_Name_String (PD.Object_Directory.Name); end if; if Name_Buffer (Name_Len) /= *************** package body Make is *** 4587,4594 **** -- This body is very long, should be broken down ??? begin - Gnatmake_Called := True; - Install_Int_Handler (Sigint_Intercepted'Access); Do_Compile_Step := True; --- 4697,4702 ---- *************** package body Make is *** 4720,4735 **** -- If no sources to compile, then there is nothing to do if Osint.Number_Of_Files = 0 then - if not Debug.Debug_Flag_N then - Delete_Mapping_Files; - Prj.Env.Delete_All_Path_Files (Project_Tree); - end if; - if not Quiet_Output then Osint.Write_Program_Name; Write_Line (": no sources to compile"); end if; Exit_Program (E_Success); end if; end if; --- 4828,4839 ---- -- If no sources to compile, then there is nothing to do if Osint.Number_Of_Files = 0 then if not Quiet_Output then Osint.Write_Program_Name; Write_Line (": no sources to compile"); end if; + Delete_All_Temp_Files; Exit_Program (E_Success); end if; end if; *************** package body Make is *** 4831,4837 **** if Verbose_Mode then Write_Eol; ! Display_Version ("GNATMAKE ", "1995"); end if; if Main_Project /= No_Project --- 4935,4941 ---- if Verbose_Mode then Write_Eol; ! Display_Version ("GNATMAKE", "1995"); end if; if Main_Project /= No_Project *************** package body Make is *** 4879,4884 **** --- 4983,4990 ---- Gcc_Path => Gcc_Path, Bind => Bind_Only, Link => Link_Only); + + Delete_All_Temp_Files; Exit_Program (E_Success); else *************** package body Make is *** 4941,4947 **** if Main_Project /= No_Project then if Project_Tree.Projects.Table ! (Main_Project).Object_Directory /= No_Path then -- Change current directory to object directory of main project --- 5047,5053 ---- if Main_Project /= No_Project then if Project_Tree.Projects.Table ! (Main_Project).Object_Directory /= No_Path_Information then -- Change current directory to object directory of main project *************** package body Make is *** 4989,4994 **** --- 5095,5106 ---- In_Packages => The_Packages, In_Tree => Project_Tree); + Default_Switches_Array : Array_Id; + + Global_Compilation_Array : Array_Element_Id; + Global_Compilation_Elem : Array_Element; + Global_Compilation_Switches : Variable_Value; + begin -- We fail if we cannot find the main source file *************** package body Make is *** 5034,5039 **** --- 5146,5182 ---- if Builder_Package /= No_Package then + Global_Compilation_Array := Prj.Util.Value_Of + (Name => Name_Global_Compilation_Switches, + In_Arrays => Project_Tree.Packages.Table + (Builder_Package).Decl.Arrays, + In_Tree => Project_Tree); + + Default_Switches_Array := + Project_Tree.Packages.Table + (Builder_Package).Decl.Arrays; + + while Default_Switches_Array /= No_Array and then + Project_Tree.Arrays.Table (Default_Switches_Array).Name /= + Name_Default_Switches + loop + Default_Switches_Array := + Project_Tree.Arrays.Table (Default_Switches_Array).Next; + end loop; + + if Global_Compilation_Array /= No_Array_Element and then + Default_Switches_Array /= No_Array + then + Errutil.Error_Msg + ("Default_Switches forbidden in presence of " & + "Global_Compilation_Switches. Use Switches instead.", + Project_Tree.Arrays.Table + (Default_Switches_Array).Location); + Errutil.Finalize; + Make_Failed + ("*** illegal combination of Builder attributes"); + end if; + -- If there is only one main, we attempt to get the gnatmake -- switches for this main (if any). If there are no specific -- switch for this particular main, get the general gnatmake *************** package body Make is *** 5047,5093 **** end if; Add_Switches ! (File_Name => Main_Unit_File_Name, ! Index => Main_Index, ! The_Package => Builder_Package, ! Program => None); else -- If there are several mains, we always get the general -- gnatmake switches (if any). ! -- Warn the user, if necessary, so that he is not surprized -- that specific switches are not taken into account. declare Defaults : constant Variable_Value := ! Prj.Util.Value_Of ! (Name => Name_Ada, ! Index => 0, ! Attribute_Or_Array_Name => Name_Default_Switches, ! In_Package => Builder_Package, ! In_Tree => Project_Tree); Switches : constant Array_Element_Id := ! Prj.Util.Value_Of ! (Name => Name_Switches, ! In_Arrays => ! Project_Tree.Packages.Table ! (Builder_Package).Decl.Arrays, ! In_Tree => Project_Tree); begin ! if Defaults /= Nil_Variable_Value then ! if (not Quiet_Output) and then Switches /= No_Array_Element then Write_Line ! ("Warning: using Builder'Default_Switches" & ! "(""Ada""), as there are several mains"); end if; ! -- As there is never a source with name " ", we are ! -- guaranteed to always get the general switches. Add_Switches (File_Name => " ", --- 5190,5264 ---- end if; Add_Switches ! (File_Name => Main_Unit_File_Name, ! Index => Main_Index, ! The_Package => Builder_Package, ! Program => None, ! Unknown_Switches_To_The_Compiler => ! Global_Compilation_Array = No_Array_Element); else -- If there are several mains, we always get the general -- gnatmake switches (if any). ! -- Warn the user, if necessary, so that he is not surprised -- that specific switches are not taken into account. declare Defaults : constant Variable_Value := ! Prj.Util.Value_Of ! (Name => Name_Ada, ! Index => 0, ! Attribute_Or_Array_Name => ! Name_Default_Switches, ! In_Package => ! Builder_Package, ! In_Tree => Project_Tree); Switches : constant Array_Element_Id := ! Prj.Util.Value_Of ! (Name => Name_Switches, ! In_Arrays => ! Project_Tree.Packages.Table ! (Builder_Package).Decl.Arrays, ! In_Tree => Project_Tree); ! ! Other_Switches : constant Variable_Value := ! Prj.Util.Value_Of ! (Name => All_Other_Names, ! Index => 0, ! Attribute_Or_Array_Name ! => Name_Switches, ! In_Package => Builder_Package, ! In_Tree => Project_Tree); begin ! if Other_Switches /= Nil_Variable_Value then ! if not Quiet_Output and then Switches /= No_Array_Element + and then Project_Tree.Array_Elements.Table + (Switches).Next /= No_Array_Element then Write_Line ! ("Warning: using Builder'Switches(others), " ! & "as there are several mains"); end if; ! Add_Switches ! (File_Name => " ", ! Index => 0, ! The_Package => Builder_Package, ! Program => None, ! Unknown_Switches_To_The_Compiler => False); ! ! elsif Defaults /= Nil_Variable_Value then ! if not Quiet_Output ! and then Switches /= No_Array_Element ! then ! Write_Line ! ("Warning: using Builder'Default_Switches" ! & "(""Ada""), as there are several mains"); ! end if; Add_Switches (File_Name => " ", *************** package body Make is *** 5095,5116 **** The_Package => Builder_Package, Program => None); ! elsif (not Quiet_Output) and then Switches /= No_Array_Element then Write_Line ! ("Warning: using no switches from package Builder," & ! " as there are several mains"); end if; end; end if; end if; Osint.Add_Default_Search_Dirs; -- Record the current last switch index for table Binder_Switches -- and Linker_Switches, so that these tables may be reset before ! -- for each main, before adding swiches from the project file -- and from the command line. Last_Binder_Switch := Binder_Switches.Last; --- 5266,5340 ---- The_Package => Builder_Package, Program => None); ! elsif not Quiet_Output and then Switches /= No_Array_Element then Write_Line ! ("Warning: using no switches from package " ! & "Builder, as there are several mains"); end if; end; end if; + + -- Take into account attribute Global_Compilation_Switches + -- ("Ada"). + + declare + Index : Name_Id; + List : String_List_Id; + Elem : String_Element; + + begin + while Global_Compilation_Array /= No_Array_Element loop + Global_Compilation_Elem := + Project_Tree.Array_Elements.Table + (Global_Compilation_Array); + + Get_Name_String (Global_Compilation_Elem.Index); + To_Lower (Name_Buffer (1 .. Name_Len)); + Index := Name_Find; + + if Index = Name_Ada then + Global_Compilation_Switches := + Global_Compilation_Elem.Value; + + if Global_Compilation_Switches /= Nil_Variable_Value + and then not Global_Compilation_Switches.Default + then + -- We have found attribute + -- Global_Compilation_Switches ("Ada"): put the + -- switches in the appropriate table. + + List := Global_Compilation_Switches.Values; + + while List /= Nil_String loop + Elem := + Project_Tree.String_Elements.Table (List); + + if Elem.Value /= No_Name then + Add_Switch + (Get_Name_String (Elem.Value), + Compiler, + And_Save => False); + end if; + + List := Elem.Next; + end loop; + + exit; + end if; + end if; + + Global_Compilation_Array := Global_Compilation_Elem.Next; + end loop; + end; end if; Osint.Add_Default_Search_Dirs; -- Record the current last switch index for table Binder_Switches -- and Linker_Switches, so that these tables may be reset before ! -- for each main, before adding switches from the project file -- and from the command line. Last_Binder_Switch := Binder_Switches.Last; *************** package body Make is *** 5218,5224 **** -- impossible to build the library. So fail immediately. if Project_Tree.Projects.Table (Proj).Object_Directory = ! No_Path then Make_Failed ("no object files to build library for project """, --- 5442,5448 ---- -- impossible to build the library. So fail immediately. if Project_Tree.Projects.Table (Proj).Object_Directory = ! No_Path_Information then Make_Failed ("no object files to build library for project """, *************** package body Make is *** 5262,5268 **** if not Is_Absolute_Path (Exec_File_Name) then Get_Name_String (Project_Tree.Projects.Table ! (Main_Project).Exec_Directory); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; --- 5486,5492 ---- if not Is_Absolute_Path (Exec_File_Name) then Get_Name_String (Project_Tree.Projects.Table ! (Main_Project).Exec_Directory.Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; *************** package body Make is *** 5291,5297 **** Dir_Path : constant String_Access := new String'(Get_Name_String (Project_Tree.Projects.Table ! (Main_Project).Directory)); begin for J in 1 .. Binder_Switches.Last loop Test_If_Relative_Path --- 5515,5521 ---- Dir_Path : constant String_Access := new String'(Get_Name_String (Project_Tree.Projects.Table ! (Main_Project).Directory.Name)); begin for J in 1 .. Binder_Switches.Last loop Test_If_Relative_Path *************** package body Make is *** 5491,5497 **** else -- If we are using a project file, we attempt to remove the -- body (or spec) termination of the main subprogram. We find ! -- it the the naming scheme of the project file. This avoids -- generating an executable "main.2" for a main subprogram -- "main.2.ada", when the body termination is ".2.ada". --- 5715,5721 ---- else -- If we are using a project file, we attempt to remove the -- body (or spec) termination of the main subprogram. We find ! -- it the naming scheme of the project file. This avoids -- generating an executable "main.2" for a main subprogram -- "main.2.ada", when the body termination is ".2.ada". *************** package body Make is *** 5508,5515 **** begin if not Is_Absolute_Path (Exec_File_Name) then ! Get_Name_String (Project_Tree.Projects.Table ! (Main_Project).Display_Exec_Dir); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; --- 5732,5740 ---- begin if not Is_Absolute_Path (Exec_File_Name) then ! Get_Name_String ! (Project_Tree.Projects.Table ! (Main_Project).Exec_Directory.Display_Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; *************** package body Make is *** 6095,6101 **** new String' (Get_Name_String (Project_Tree.Projects.Table ! (Proj1).Display_Library_Dir)); end if; end if; end loop; --- 6320,6326 ---- new String' (Get_Name_String (Project_Tree.Projects.Table ! (Proj1).Library_Dir.Display_Name)); end if; end if; end loop; *************** package body Make is *** 6110,6116 **** Get_Name_String (Project_Tree.Projects.Table (Library_Projs.Table (Index)). ! Display_Library_Dir)); -- Add the -l switch --- 6335,6341 ---- Get_Name_String (Project_Tree.Projects.Table (Library_Projs.Table (Index)). ! Library_Dir.Display_Name)); -- Add the -l switch *************** package body Make is *** 6416,6422 **** Dir_Path : constant String_Access := new String'(Get_Name_String (Project_Tree.Projects.Table ! (Main_Project).Directory)); begin for J in Last_Binder_Switch + 1 .. Binder_Switches.Last --- 6641,6647 ---- Dir_Path : constant String_Access := new String'(Get_Name_String (Project_Tree.Projects.Table ! (Main_Project).Directory.Name)); begin for J in Last_Binder_Switch + 1 .. Binder_Switches.Last *************** package body Make is *** 6494,6503 **** -- Delete the temporary mapping file that was created if we are -- using project files. ! if not Debug.Debug_Flag_N then ! Delete_Mapping_Files; ! Prj.Env.Delete_All_Path_Files (Project_Tree); ! end if; exception when X : others => --- 6719,6725 ---- -- Delete the temporary mapping file that was created if we are -- using project files. ! Delete_All_Temp_Files; exception when X : others => *************** package body Make is *** 6721,6727 **** -- Test for simultaneity of -i and -D if Object_Directory_Path /= null and then In_Place_Mode then ! Make_Failed ("-i and -D cannot be used simutaneously"); end if; -- Deal with -C= switch --- 6943,6949 ---- -- Test for simultaneity of -i and -D if Object_Directory_Path /= null and then In_Place_Mode then ! Make_Failed ("-i and -D cannot be used simultaneously"); end if; -- Deal with -C= switch *************** package body Make is *** 6774,6779 **** --- 6996,7009 ---- Project_File_Name => Project_File_Name.all, Packages_To_Check => Packages_To_Check_By_Gnatmake); + -- The parsing of project files may have changed the current output + + if Commands_To_Stdout then + Set_Standard_Output; + else + Set_Standard_Error; + end if; + if Main_Project = No_Project then Make_Failed ("""", Project_File_Name.all, """ processing failed"); end if; *************** package body Make is *** 6856,6861 **** --- 7086,7092 ---- Put_In_Q : Boolean := Into_Q; Unit : Unit_Data; Sfile : File_Name_Type; + Index : Int; Extending : constant Boolean := Project_Tree.Projects.Table *************** package body Make is *** 6903,6914 **** loop Unit := Project_Tree.Units.Table (Id); Sfile := No_File; -- If there is a source for the body, and the body has not been -- locally removed, if Unit.File_Names (Body_Part).Name /= No_File ! and then Unit.File_Names (Body_Part).Path /= Slash then -- And it is a source for the specified project --- 7134,7146 ---- loop Unit := Project_Tree.Units.Table (Id); Sfile := No_File; + Index := 0; -- If there is a source for the body, and the body has not been -- locally removed, if Unit.File_Names (Body_Part).Name /= No_File ! and then Unit.File_Names (Body_Part).Path.Name /= Slash then -- And it is a source for the specified project *************** package body Make is *** 6935,6958 **** begin Src_Ind := Sinput.P.Load_Project_File (Get_Name_String ! (Unit.File_Names (Body_Part).Path)); -- If it is a subunit, discard it if Sinput.P.Source_File_Is_Subunit (Src_Ind) then Sfile := No_File; else Sfile := Unit.File_Names (Body_Part).Display_Name; end if; end; else Sfile := Unit.File_Names (Body_Part).Display_Name; end if; end if; elsif Unit.File_Names (Specification).Name /= No_File ! and then Unit.File_Names (Specification).Path /= Slash and then Check_Project (Unit.File_Names (Specification).Project) then -- If there is no source for the body, but there is a source --- 7167,7193 ---- begin Src_Ind := Sinput.P.Load_Project_File (Get_Name_String ! (Unit.File_Names (Body_Part).Path.Name)); -- If it is a subunit, discard it if Sinput.P.Source_File_Is_Subunit (Src_Ind) then Sfile := No_File; + Index := 0; else Sfile := Unit.File_Names (Body_Part).Display_Name; + Index := Unit.File_Names (Body_Part).Index; end if; end; else Sfile := Unit.File_Names (Body_Part).Display_Name; + Index := Unit.File_Names (Body_Part).Index; end if; end if; elsif Unit.File_Names (Specification).Name /= No_File ! and then Unit.File_Names (Specification).Path.Name /= Slash and then Check_Project (Unit.File_Names (Specification).Project) then -- If there is no source for the body, but there is a source *************** package body Make is *** 6960,6965 **** --- 7195,7201 ---- -- this one. Sfile := Unit.File_Names (Specification).Display_Name; + Index := Unit.File_Names (Specification).Index; end if; -- If Put_In_Q is True, we insert into the Q *************** package body Make is *** 6976,6995 **** -- And of course, we only insert in the Q if the source is not -- marked. ! if Sfile /= No_File and then not Is_Marked (Sfile) then if Verbose_Mode then Write_Str ("Adding """); Write_Str (Get_Name_String (Sfile)); Write_Line (""" to the queue"); end if; ! Insert_Q (Sfile); ! Mark (Sfile); end if; elsif Sfile /= No_File then ! -- If Put_In_Q is False, we add the source as it it were specified -- on the command line, and we set Put_In_Q to True, so that the -- following sources will be put directly in the queue. This will -- allow parallel compilation processes if -jx switch is used. --- 7212,7231 ---- -- And of course, we only insert in the Q if the source is not -- marked. ! if Sfile /= No_File and then not Is_Marked (Sfile, Index) then if Verbose_Mode then Write_Str ("Adding """); Write_Str (Get_Name_String (Sfile)); Write_Line (""" to the queue"); end if; ! Insert_Q (Sfile, Index => Index); ! Mark (Sfile, Index); end if; elsif Sfile /= No_File then ! -- If Put_In_Q is False, we add the source as if it were specified -- on the command line, and we set Put_In_Q to True, so that the -- following sources will be put directly in the queue. This will -- allow parallel compilation processes if -jx switch is used. *************** package body Make is *** 7000,7006 **** Write_Line (""" as if on the command line"); end if; ! Osint.Add_File (Get_Name_String (Sfile)); Put_In_Q := True; -- As we may look into the Q later, ensure the Q has been --- 7236,7242 ---- Write_Line (""" as if on the command line"); end if; ! Osint.Add_File (Get_Name_String (Sfile), Index); Put_In_Q := True; -- As we may look into the Q later, ensure the Q has been *************** package body Make is *** 7127,7134 **** declare Object_Directory : constant String := Normalize_Pathname ! (Get_Name_String ! (Data.Display_Object_Dir)); Olast : Natural := Object_Directory'Last; --- 7363,7370 ---- declare Object_Directory : constant String := Normalize_Pathname ! (Get_Name_String ! (Data.Object_Directory.Display_Name)); Olast : Natural := Object_Directory'Last; *************** package body Make is *** 7141,7147 **** begin -- For directories, Normalize_Pathname may or may not put -- a directory separator at the end, depending on its input. ! -- Remove any last directory separator before comparaison. -- Returns True only if the two directories are the same. if Object_Directory (Olast) = Directory_Separator then --- 7377,7383 ---- begin -- For directories, Normalize_Pathname may or may not put -- a directory separator at the end, depending on its input. ! -- Remove any last directory separator before comparison. -- Returns True only if the two directories are the same. if Object_Directory (Olast) = Directory_Separator then *************** package body Make is *** 7323,7329 **** (Dir, Get_Name_String (Project_Tree.Projects.Table ! (Main_Project).Display_Directory)); begin if Real_Path'Length = 0 then --- 7559,7565 ---- (Dir, Get_Name_String (Project_Tree.Projects.Table ! (Main_Project).Directory.Display_Name)); begin if Real_Path'Length = 0 then *************** package body Make is *** 7408,7418 **** procedure Report_Compilation_Failed is begin ! if not Debug.Debug_Flag_N then ! Delete_Mapping_Files; ! Prj.Env.Delete_All_Path_Files (Project_Tree); ! end if; ! Exit_Program (E_Fatal); end Report_Compilation_Failed; --- 7644,7650 ---- procedure Report_Compilation_Failed is begin ! Delete_All_Temp_Files; Exit_Program (E_Fatal); end Report_Compilation_Failed; *************** package body Make is *** 7425,7439 **** begin Set_Standard_Error; Write_Line ("*** Interrupted ***"); - Delete_All_Temp_Files; ! -- Send SIGINT to all oustanding compilation processes spawned for J in 1 .. Outstanding_Compiles loop Kill (Running_Compile (J).Pid, SIGINT, 1); end loop; OS_Exit (1); end Sigint_Intercepted; ------------------- --- 7657,7673 ---- begin Set_Standard_Error; Write_Line ("*** Interrupted ***"); ! -- Send SIGINT to all outstanding compilation processes spawned for J in 1 .. Outstanding_Compiles loop Kill (Running_Compile (J).Pid, SIGINT, 1); end loop; + Delete_All_Temp_Files; OS_Exit (1); + -- ??? OS_Exit (1) is equivalent to Exit_Program (E_No_Compile), + -- shouldn't that be Exit_Program (E_Abort) instead? end Sigint_Intercepted; ------------------- *************** package body Make is *** 7444,7449 **** --- 7678,7685 ---- Success : Boolean; begin + Gnatmake_Switch_Found := True; + pragma Assert (Argv'First = 1); if Argv'Length = 0 then *************** package body Make is *** 7984,7997 **** Add_Switch (Argv, Compiler, And_Save => And_Save); Add_Switch (Argv, Binder, And_Save => And_Save); ! -- All other switches are processed by Scan_Make_Switches. ! -- If the call returns with Success = False, then the switch is ! -- passed to the compiler. else ! Scan_Make_Switches (Argv, Success); ! if not Success then Add_Switch (Argv, Compiler, And_Save => And_Save); end if; end if; --- 8220,8233 ---- Add_Switch (Argv, Compiler, And_Save => And_Save); Add_Switch (Argv, Binder, And_Save => And_Save); ! -- All other switches are processed by Scan_Make_Switches. If the ! -- call returns with Gnatmake_Switch_Found = False, then the switch ! -- is passed to the compiler. else ! Scan_Make_Switches (Argv, Gnatmake_Switch_Found); ! if not Gnatmake_Switch_Found then Add_Switch (Argv, Compiler, And_Save => And_Save); end if; end if; *************** package body Make is *** 8035,8040 **** --- 8271,8278 ---- In_Tree => Project_Tree); begin + -- First, try Switches () + Switches := Prj.Util.Value_Of (Index => Name_Id (Source_File), *************** package body Make is *** 8042,8047 **** --- 8280,8287 ---- In_Array => Switches_Array, In_Tree => Project_Tree); + -- Check also without the suffix + if Switches = Nil_Variable_Value then declare Name : String (1 .. Source_File_Name'Length + 3); *************** package body Make is *** 8105,8110 **** --- 8345,8383 ---- end; end if; + -- Next, try Switches ("Ada") + + if Switches = Nil_Variable_Value then + Switches := + Prj.Util.Value_Of + (Index => Name_Ada, + Src_Index => 0, + In_Array => Switches_Array, + In_Tree => Project_Tree, + Force_Lower_Case_Index => True); + + if Switches /= Nil_Variable_Value then + Switch_May_Be_Passed_To_The_Compiler := False; + end if; + end if; + + -- Next, try Switches (others) + + if Switches = Nil_Variable_Value then + Switches := + Prj.Util.Value_Of + (Index => All_Other_Names, + Src_Index => 0, + In_Array => Switches_Array, + In_Tree => Project_Tree); + + if Switches /= Nil_Variable_Value then + Switch_May_Be_Passed_To_The_Compiler := False; + end if; + end if; + + -- And finally, Default_Switches ("Ada") + if Switches = Nil_Variable_Value then Switches := Prj.Util.Value_Of diff -Nrcpad gcc-4.3.3/gcc/ada/makegpr.adb gcc-4.4.0/gcc/ada/makegpr.adb *** gcc-4.3.3/gcc/ada/makegpr.adb Wed Dec 19 16:26:08 2007 --- gcc-4.4.0/gcc/ada/makegpr.adb Thu Jan 1 00:00:00 1970 *************** *** 1,4452 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M A K E G P R -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2004-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - with Csets; - with Gnatvsn; - with Hostparm; use Hostparm; - with Makeutl; use Makeutl; - with MLib.Tgt; use MLib.Tgt; - with Namet; use Namet; - with Output; use Output; - with Opt; use Opt; - with Osint; use Osint; - with Prj; use Prj; - with Prj.Ext; use Prj.Ext; - with Prj.Pars; - with Prj.Util; use Prj.Util; - with Snames; use Snames; - with Table; - with Types; use Types; - - with Ada.Command_Line; use Ada.Command_Line; - with Ada.Strings.Fixed; use Ada.Strings.Fixed; - with Ada.Text_IO; use Ada.Text_IO; - with Ada.Unchecked_Deallocation; - - with GNAT.Directory_Operations; use GNAT.Directory_Operations; - with GNAT.Dynamic_Tables; - with GNAT.Expect; use GNAT.Expect; - with GNAT.HTable; - with GNAT.OS_Lib; use GNAT.OS_Lib; - with GNAT.Regpat; use GNAT.Regpat; - - with System; - with System.Case_Util; use System.Case_Util; - - package body Makegpr is - - On_Windows : constant Boolean := Directory_Separator = '\'; - -- True when on Windows. Used in Check_Compilation_Needed when processing - -- C/C++ dependency files for backslash handling. - - Max_In_Archives : constant := 50; - -- The maximum number of arguments for a single invocation of the - -- Archive Indexer (ar). - - No_Argument : aliased Argument_List := (1 .. 0 => null); - -- Null argument list representing case of no arguments - - FD : Process_Descriptor; - -- The process descriptor used when invoking a non GNU compiler with -M - -- and getting the output with GNAT.Expect. - - Line_Matcher : constant Pattern_Matcher := Compile ("^.*?\n", Single_Line); - -- Pattern for GNAT.Expect for the invocation of a non GNU compiler with -M - - Name_Ide : Name_Id; - Name_Compiler_Command : Name_Id; - -- Names of package IDE and its attribute Compiler_Command. - -- Set up by Initialize. - - Unique_Compile : Boolean := False; - -- True when switch -u is used on the command line - - type Source_Index_Rec is record - Project : Project_Id; - Id : Other_Source_Id; - Found : Boolean := False; - end record; - -- Used as Source_Indexes component to check if archive needs to be rebuilt - - type Source_Index_Array is array (Positive range <>) of Source_Index_Rec; - type Source_Indexes_Ref is access Source_Index_Array; - - procedure Free is new Ada.Unchecked_Deallocation - (Source_Index_Array, Source_Indexes_Ref); - - Initial_Source_Index_Count : constant Positive := 20; - Source_Indexes : Source_Indexes_Ref := - new Source_Index_Array (1 .. Initial_Source_Index_Count); - -- A list of the Other_Source_Ids of a project file, with an indication - -- that they have been found in the archive dependency file. - - Last_Source : Natural := 0; - -- The index of the last valid component of Source_Indexes - - Compiler_Names : array (First_Language_Indexes) of String_Access; - -- The names of the compilers to be used. Set up by Get_Compiler. - -- Used to display the commands spawned. - - Gnatmake_String : constant String_Access := new String'("gnatmake"); - GCC_String : constant String_Access := new String'("gcc"); - G_Plus_Plus_String : constant String_Access := new String'("g++"); - - Default_Compiler_Names : constant array - (First_Language_Indexes range - Ada_Language_Index .. C_Plus_Plus_Language_Index) - of String_Access := - (Ada_Language_Index => Gnatmake_String, - C_Language_Index => GCC_String, - C_Plus_Plus_Language_Index => G_Plus_Plus_String); - - Compiler_Paths : array (First_Language_Indexes) of String_Access; - -- The path names of the compiler to be used. Set up by Get_Compiler. - -- Used to spawn compiling/linking processes. - - Compiler_Is_Gcc : array (First_Language_Indexes) of Boolean; - -- An indication that a compiler is a GCC compiler, to be able to use - -- specific GCC switches. - - Archive_Builder_Path : String_Access := null; - -- The path name of the archive builder (ar). To be used when spawning - -- ar commands. - - Archive_Indexer_Path : String_Access := null; - -- The path name of the archive indexer (ranlib), if it exists - - Copyright_Output : Boolean := False; - Usage_Output : Boolean := False; - -- Flags to avoid multiple displays of Copyright notice and of Usage - - Output_File_Name : String_Access := null; - -- The name given after a switch -o - - Output_File_Name_Expected : Boolean := False; - -- True when last switch was -o - - Project_File_Name : String_Access := null; - -- The name of the project file specified with switch -P - - Project_File_Name_Expected : Boolean := False; - -- True when last switch was -P - - Naming_String : aliased String := "naming"; - Builder_String : aliased String := "builder"; - Compiler_String : aliased String := "compiler"; - Binder_String : aliased String := "binder"; - Linker_String : aliased String := "linker"; - -- Name of packages to be checked when parsing/processing project files - - List_Of_Packages : aliased String_List := - (Naming_String 'Access, - Builder_String 'Access, - Compiler_String 'Access, - Binder_String 'Access, - Linker_String 'Access); - Packages_To_Check : constant String_List_Access := List_Of_Packages'Access; - -- List of the packages to be checked when parsing/processing project files - - Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data; - - Main_Project : Project_Id; - -- The project id of the main project - - type Processor is (None, Linker, Compiler); - Current_Processor : Processor := None; - -- This variable changes when switches -*args are used - - Current_Language : Language_Index := Ada_Language_Index; - -- The compiler language to consider when Processor is Compiler - - package Comp_Opts is new GNAT.Dynamic_Tables - (Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100); - Options : array (First_Language_Indexes) of Comp_Opts.Instance; - -- Tables to store compiling options for the different compilers - - package Linker_Options is new Table.Table - (Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Makegpr.Linker_Options"); - -- Table to store the linking options - - package Library_Opts is new Table.Table - (Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Makegpr.Library_Opts"); - -- Table to store the linking options - - package Ada_Mains is new Table.Table - (Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Makegpr.Ada_Mains"); - -- Table to store the Ada mains, either specified on the command line - -- or found in attribute Main of the main project file. - - package Other_Mains is new Table.Table - (Table_Component_Type => Other_Source, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Makegpr.Other_Mains"); - -- Table to store the mains of languages other than Ada, either specified - -- on the command line or found in attribute Main of the main project file. - - package Sources_Compiled is new GNAT.HTable.Simple_HTable - (Header_Num => Header_Num, - Element => Boolean, - No_Element => False, - Key => File_Name_Type, - Hash => Hash, - Equal => "="); - - package Saved_Switches is new Table.Table - (Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 10, - Table_Increment => 100, - Table_Name => "Makegpr.Saved_Switches"); - -- Table to store the switches to be passed to gnatmake - - Initial_Argument_Count : constant Positive := 20; - type Boolean_Array is array (Positive range <>) of Boolean; - type Booleans is access Boolean_Array; - - procedure Free is new Ada.Unchecked_Deallocation (Boolean_Array, Booleans); - - Arguments : Argument_List_Access := - new Argument_List (1 .. Initial_Argument_Count); - -- Used to store lists of arguments to be used when spawning a process - - Arguments_Displayed : Booleans := - new Boolean_Array (1 .. Initial_Argument_Count); - -- For each argument in Arguments, indicate if the argument should be - -- displayed when procedure Display_Command is called. - - Last_Argument : Natural := 0; - -- Index of the last valid argument in Arguments - - package Cache_Args is new Table.Table - (Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 200, - Table_Increment => 100, - Table_Name => "Makegpr.Cache_Args"); - -- A table to cache arguments, to avoid multiple allocation of the same - -- strings. It is not possible to use a hash table, because String is - -- an unconstrained type. - - -- Various switches used when spawning processes: - - Dash_B_String : aliased String := "-B"; - Dash_B : constant String_Access := Dash_B_String'Access; - Dash_c_String : aliased String := "-c"; - Dash_c : constant String_Access := Dash_c_String'Access; - Dash_cargs_String : aliased String := "-cargs"; - Dash_cargs : constant String_Access := Dash_cargs_String'Access; - Dash_d_String : aliased String := "-d"; - Dash_d : constant String_Access := Dash_d_String'Access; - Dash_f_String : aliased String := "-f"; - Dash_f : constant String_Access := Dash_f_String'Access; - Dash_k_String : aliased String := "-k"; - Dash_k : constant String_Access := Dash_k_String'Access; - Dash_largs_String : aliased String := "-largs"; - Dash_largs : constant String_Access := Dash_largs_String'Access; - Dash_M_String : aliased String := "-M"; - Dash_M : constant String_Access := Dash_M_String'Access; - Dash_margs_String : aliased String := "-margs"; - Dash_margs : constant String_Access := Dash_margs_String'Access; - Dash_o_String : aliased String := "-o"; - Dash_o : constant String_Access := Dash_o_String'Access; - Dash_P_String : aliased String := "-P"; - Dash_P : constant String_Access := Dash_P_String'Access; - Dash_q_String : aliased String := "-q"; - Dash_q : constant String_Access := Dash_q_String'Access; - Dash_u_String : aliased String := "-u"; - Dash_u : constant String_Access := Dash_u_String'Access; - Dash_v_String : aliased String := "-v"; - Dash_v : constant String_Access := Dash_v_String'Access; - Dash_vP1_String : aliased String := "-vP1"; - Dash_vP1 : constant String_Access := Dash_vP1_String'Access; - Dash_vP2_String : aliased String := "-vP2"; - Dash_vP2 : constant String_Access := Dash_vP2_String'Access; - Dash_x_String : aliased String := "-x"; - Dash_x : constant String_Access := Dash_x_String'Access; - r_String : aliased String := "r"; - r : constant String_Access := r_String'Access; - - CPATH : constant String := "CPATH"; - -- The environment variable to set when compiler is a GCC compiler - -- to indicate the include directory path. - - Current_Include_Paths : array (First_Language_Indexes) of String_Access; - -- A cache for the paths of included directories, to avoid setting - -- env var CPATH unnecessarily. - - C_Plus_Plus_Is_Used : Boolean := False; - -- True when there are sources in C++ - - Link_Options_Switches : Argument_List_Access := null; - -- The link options coming from the attributes Linker'Linker_Options in - -- project files imported, directly or indirectly, by the main project. - - Total_Number_Of_Errors : Natural := 0; - -- Used when Keep_Going is True (switch -k) to keep the total number - -- of compilation/linking errors, to report at the end of execution. - - Need_To_Rebuild_Global_Archive : Boolean := False; - - Error_Header : constant String := "*** ERROR: "; - -- The beginning of error message, when Keep_Going is True - - Need_To_Relink : Boolean := False; - -- True when an executable of a language other than Ada need to be linked - - Global_Archive_Exists : Boolean := False; - -- True if there is a non empty global archive, to prevent creation - -- of such archives. - - Path_Option : String_Access; - -- The path option switch, when supported - - Project_Of_Current_Object_Directory : Project_Id := No_Project; - -- The object directory of the project for the last compilation. Avoid - -- calling Change_Dir if the current working directory is already this - -- directory. - - package Lib_Path is new Table.Table - (Table_Component_Type => Character, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 200, - Table_Increment => 100, - Table_Name => "Makegpr.Lib_Path"); - -- A table to compute the path to put in the path option switch, when it - -- is supported. - - procedure Add_Archives (For_Gnatmake : Boolean); - -- Add to Arguments the list of archives for linking an executable - - procedure Add_Argument (Arg : String_Access; Display : Boolean); - procedure Add_Argument (Arg : String; Display : Boolean); - -- Add an argument to Arguments. Reallocate if necessary - - procedure Add_Arguments (Args : Argument_List; Display : Boolean); - -- Add a list of arguments to Arguments. Reallocate if necessary - - procedure Add_Option (Arg : String); - -- Add a switch for the Ada, C or C++ compiler, or for the linker. - -- The table where this option is stored depends on the values of - -- Current_Processor and Current_Language. - - procedure Add_Search_Directories - (Data : Project_Data; - Language : First_Language_Indexes); - -- Either add to the Arguments the necessary -I switches needed to - -- compile, or, when compiler is gcc/g++, set up the C*INCLUDE_PATH - -- environment variable, if necessary. - - procedure Add_Source_Id (Project : Project_Id; Id : Other_Source_Id); - -- Add a source id to Source_Indexes, with Found set to False - - procedure Add_Switches - (Data : Project_Data; - Proc : Processor; - Language : Language_Index; - File_Name : File_Name_Type); - -- Add to Arguments the switches, if any, for a source (attribute Switches) - -- or language (attribute Default_Switches), coming from package Compiler - -- or Linker (depending on Proc) of a specified project file. - - procedure Build_Global_Archive; - -- Build the archive for the main project - - procedure Build_Library (Project : Project_Id; Unconditionally : Boolean); - -- Build the library for a library project. If Unconditionally is - -- False, first check if the library is up to date, and build it only - -- if it is not. - - procedure Check (Option : String); - -- Check that a switch coming from a project file is not the concatenation - -- of several valid switch, for example "-g -v". If it is, issue a warning. - - procedure Check_Archive_Builder; - -- Check if the archive builder (ar) is there - - procedure Check_Compilation_Needed - (Source : Other_Source; - Need_To_Compile : out Boolean); - -- Check if a source of a language other than Ada needs to be compiled or - -- recompiled. - - procedure Check_For_C_Plus_Plus; - -- Check if C++ is used in at least one project - - procedure Compile - (Source_Id : Other_Source_Id; - Data : Project_Data; - Local_Errors : in out Boolean); - -- Compile one non-Ada source - - procedure Compile_Individual_Sources; - -- Compile the sources specified on the command line, when in - -- Unique_Compile mode. - - procedure Compile_Link_With_Gnatmake (Mains_Specified : Boolean); - -- Compile/Link with gnatmake when there are Ada sources in the main - -- project. Arguments may already contain options to be used by - -- gnatmake. Used for both Ada mains and mains of other languages. - -- When Compile_Only is True, do not use the linking options - - procedure Compile_Sources; - -- Compile the sources of languages other than Ada, if necessary - - procedure Copyright; - -- Output the Copyright notice - - procedure Create_Archive_Dependency_File - (Name : String; - First_Source : Other_Source_Id); - -- Create the archive dependency file for a library project - - procedure Create_Global_Archive_Dependency_File (Name : String); - -- Create the archive depenency file for the main project - - procedure Display_Command - (Name : String; - Path : String_Access; - CPATH : String_Access := null; - Ellipse : Boolean := False); - -- Display the command for a spawned process, if in Verbose_Mode or not in - -- Quiet_Output. In non verbose mode, when Ellipse is True, display "..." - -- in place of the first argument that has Display set to False. - - procedure Get_Compiler (For_Language : First_Language_Indexes); - -- Find the compiler name and path name for a specified programming - -- language, if not already done. Results are in the corresponding elements - -- of arrays Compiler_Names and Compiler_Paths. Name of compiler is found - -- in package IDE of the main project, or defaulted. Fail if compiler - -- cannot be found on the path. For the Ada language, gnatmake, rather than - -- the Ada compiler is returned. - - procedure Get_Imported_Directories - (Project : Project_Id; - Data : in out Project_Data); - -- Find the necessary switches -I to be used when compiling sources of - -- languages other than Ada, in a specified project file. Cache the result - -- in component Imported_Directories_Switches of the project data. For - -- gcc/g++ compilers, get the value of the C*_INCLUDE_PATH, instead. - - procedure Initialize; - -- Do the necessary package initialization and process the command line - -- arguments. - - function Is_Included_In_Global_Archive - (Object_Name : File_Name_Type; - Project : Project_Id) return Boolean; - -- Return True if the object Object_Name is not overridden by a source - -- in a project extending project Project. - - procedure Link_Executables; - -- Link executables - - procedure Report_Error (S1 : String; S2 : String := ""; S3 : String := ""); - -- Report an error. If Keep_Going is False, just call Osint.Fail. If - -- Keep_Going is True, display the error and increase the total number of - -- errors. - - procedure Report_Total_Errors (Kind : String); - -- If Total_Number_Of_Errors is not zero, report it, and fail - - procedure Scan_Arg (Arg : String); - -- Process one command line argument - - function Strip_CR_LF (Text : String) return String; - -- Remove characters ASCII.CR and ASCII.LF from a String - - procedure Usage; - -- Display the usage - - ------------------ - -- Add_Archives -- - ------------------ - - procedure Add_Archives (For_Gnatmake : Boolean) is - Last_Arg : constant Natural := Last_Argument; - -- The position of the last argument before adding the archives. Used to - -- reverse the order of the arguments added when processing the - -- archives. - - procedure Recursive_Add_Archives (Project : Project_Id); - -- Recursive procedure to add the archive of a project file, if any, - -- then call itself for the project imported. - - ---------------------------- - -- Recursive_Add_Archives -- - ---------------------------- - - procedure Recursive_Add_Archives (Project : Project_Id) is - Data : Project_Data; - Imported : Project_List; - Prj : Project_Id; - - procedure Add_Archive_Path; - -- For a library project or the main project, add the archive - -- path to the arguments. - - ---------------------- - -- Add_Archive_Path -- - ---------------------- - - procedure Add_Archive_Path is - Increment : Positive; - Prev_Last : Positive; - - begin - if Data.Library then - - -- If it is a library project file, nothing to do if gnatmake - -- will be invoked, because gnatmake will take care of it, even - -- if the library is not an Ada library. - - if not For_Gnatmake then - if Data.Library_Kind = Static then - Add_Argument - (Get_Name_String (Data.Display_Library_Dir) & - Directory_Separator & - "lib" & Get_Name_String (Data.Library_Name) & - '.' & Archive_Ext, - Verbose_Mode); - - else - -- As we first insert in the reverse order, - -- -L is put after -l - - Add_Argument - ("-l" & Get_Name_String (Data.Library_Name), - Verbose_Mode); - - Get_Name_String (Data.Display_Library_Dir); - - Add_Argument - ("-L" & Name_Buffer (1 .. Name_Len), - Verbose_Mode); - - -- If there is a run path option, prepend this directory - -- to the library path. It is probable that the order of - -- the directories in the path option is not important, - -- but just in case put the directories in the same order - -- as the libraries. - - if Path_Option /= null then - - -- If it is not the first directory, make room at the - -- beginning of the table, including for a path - -- separator. - - if Lib_Path.Last > 0 then - Increment := Name_Len + 1; - Prev_Last := Lib_Path.Last; - Lib_Path.Set_Last (Prev_Last + Increment); - - for Index in reverse 1 .. Prev_Last loop - Lib_Path.Table (Index + Increment) := - Lib_Path.Table (Index); - end loop; - - Lib_Path.Table (Increment) := Path_Separator; - - else - -- If it is the first directory, just set - -- Last to the length of the directory. - - Lib_Path.Set_Last (Name_Len); - end if; - - -- Put the directory at the beginning of the - -- table. - - for Index in 1 .. Name_Len loop - Lib_Path.Table (Index) := Name_Buffer (Index); - end loop; - end if; - end if; - end if; - - -- For a non-library project, the only archive needed is the one - -- for the main project, if there is one. - - elsif Project = Main_Project and then Global_Archive_Exists then - Add_Argument - (Get_Name_String (Data.Display_Object_Dir) & - Directory_Separator & - "lib" & Get_Name_String (Data.Display_Name) - & '.' & Archive_Ext, - Verbose_Mode); - end if; - end Add_Archive_Path; - - begin - -- Nothing to do when there is no project specified - - if Project /= No_Project then - Data := Project_Tree.Projects.Table (Project); - - -- Nothing to do if the project has already been processed - - if not Data.Seen then - - -- Mark the project as processed, to avoid processing it again - - Project_Tree.Projects.Table (Project).Seen := True; - - Recursive_Add_Archives (Data.Extends); - - Imported := Data.Imported_Projects; - - -- Call itself recursively for all imported projects - - while Imported /= Empty_Project_List loop - Prj := Project_Tree.Project_Lists.Table - (Imported).Project; - - if Prj /= No_Project then - while Project_Tree.Projects.Table - (Prj).Extended_By /= No_Project - loop - Prj := Project_Tree.Projects.Table - (Prj).Extended_By; - end loop; - - Recursive_Add_Archives (Prj); - end if; - - Imported := Project_Tree.Project_Lists.Table - (Imported).Next; - end loop; - - -- If there is sources of language other than Ada in this - -- project, add the path of the archive to Arguments. - - if Project = Main_Project - or else Data.Other_Sources_Present - then - Add_Archive_Path; - end if; - end if; - end if; - end Recursive_Add_Archives; - - -- Start of processing for Add_Archives - - begin - -- First, mark all projects as not processed - - for Project in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Project_Tree.Projects.Table (Project).Seen := False; - end loop; - - -- Take care of the run path option - - if Path_Option = null then - Path_Option := MLib.Linker_Library_Path_Option; - end if; - - Lib_Path.Set_Last (0); - - -- Add archives in the reverse order - - Recursive_Add_Archives (Main_Project); - - -- And reverse the order - - declare - First : Positive; - Last : Natural; - Temp : String_Access; - - begin - First := Last_Arg + 1; - Last := Last_Argument; - while First < Last loop - Temp := Arguments (First); - Arguments (First) := Arguments (Last); - Arguments (Last) := Temp; - First := First + 1; - Last := Last - 1; - end loop; - end; - end Add_Archives; - - ------------------ - -- Add_Argument -- - ------------------ - - procedure Add_Argument (Arg : String_Access; Display : Boolean) is - begin - -- Nothing to do if no argument is specified or if argument is empty - - if Arg /= null or else Arg'Length = 0 then - - -- Reallocate arrays if necessary - - if Last_Argument = Arguments'Last then - declare - New_Arguments : constant Argument_List_Access := - new Argument_List - (1 .. Last_Argument + - Initial_Argument_Count); - - New_Arguments_Displayed : constant Booleans := - new Boolean_Array - (1 .. Last_Argument + - Initial_Argument_Count); - - begin - New_Arguments (Arguments'Range) := Arguments.all; - - -- To avoid deallocating the strings, nullify all components - -- of Arguments before calling Free. - - Arguments.all := (others => null); - - Free (Arguments); - Arguments := New_Arguments; - - New_Arguments_Displayed (Arguments_Displayed'Range) := - Arguments_Displayed.all; - Free (Arguments_Displayed); - Arguments_Displayed := New_Arguments_Displayed; - end; - end if; - - -- Add the argument and its display indication - - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := Arg; - Arguments_Displayed (Last_Argument) := Display; - end if; - end Add_Argument; - - procedure Add_Argument (Arg : String; Display : Boolean) is - Argument : String_Access := null; - - begin - -- Nothing to do if argument is empty - - if Arg'Length > 0 then - - -- Check if the argument is already in the Cache_Args table. - -- If it is already there, reuse the allocated value. - - for Index in 1 .. Cache_Args.Last loop - if Cache_Args.Table (Index).all = Arg then - Argument := Cache_Args.Table (Index); - exit; - end if; - end loop; - - -- If the argument is not in the cache, create a new entry in the - -- cache. - - if Argument = null then - Argument := new String'(Arg); - Cache_Args.Increment_Last; - Cache_Args.Table (Cache_Args.Last) := Argument; - end if; - - -- And add the argument - - Add_Argument (Argument, Display); - end if; - end Add_Argument; - - ------------------- - -- Add_Arguments -- - ------------------- - - procedure Add_Arguments (Args : Argument_List; Display : Boolean) is - begin - -- Reallocate the arrays, if necessary - - if Last_Argument + Args'Length > Arguments'Last then - declare - New_Arguments : constant Argument_List_Access := - new Argument_List - (1 .. Last_Argument + Args'Length + - Initial_Argument_Count); - - New_Arguments_Displayed : constant Booleans := - new Boolean_Array - (1 .. Last_Argument + - Args'Length + - Initial_Argument_Count); - - begin - New_Arguments (1 .. Last_Argument) := - Arguments (1 .. Last_Argument); - - -- To avoid deallocating the strings, nullify all components - -- of Arguments before calling Free. - - Arguments.all := (others => null); - Free (Arguments); - - Arguments := New_Arguments; - New_Arguments_Displayed (1 .. Last_Argument) := - Arguments_Displayed (1 .. Last_Argument); - Free (Arguments_Displayed); - Arguments_Displayed := New_Arguments_Displayed; - end; - end if; - - -- Add the new arguments and the display indications - - Arguments (Last_Argument + 1 .. Last_Argument + Args'Length) := Args; - Arguments_Displayed (Last_Argument + 1 .. Last_Argument + Args'Length) := - (others => Display); - Last_Argument := Last_Argument + Args'Length; - end Add_Arguments; - - ---------------- - -- Add_Option -- - ---------------- - - procedure Add_Option (Arg : String) is - Option : constant String_Access := new String'(Arg); - - begin - case Current_Processor is - when None => - null; - - when Linker => - - -- Add option to the linker table - - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := Option; - - when Compiler => - - -- Add option to the compiler option table, depending on the - -- value of Current_Language. - - Comp_Opts.Increment_Last (Options (Current_Language)); - Options (Current_Language).Table - (Comp_Opts.Last (Options (Current_Language))) := Option; - - end case; - end Add_Option; - - ------------------- - -- Add_Source_Id -- - ------------------- - - procedure Add_Source_Id (Project : Project_Id; Id : Other_Source_Id) is - begin - -- Reallocate the array, if necessary - - if Last_Source = Source_Indexes'Last then - declare - New_Indexes : constant Source_Indexes_Ref := - new Source_Index_Array - (1 .. Source_Indexes'Last + - Initial_Source_Index_Count); - begin - New_Indexes (Source_Indexes'Range) := Source_Indexes.all; - Free (Source_Indexes); - Source_Indexes := New_Indexes; - end; - end if; - - Last_Source := Last_Source + 1; - Source_Indexes (Last_Source) := (Project, Id, False); - end Add_Source_Id; - - ---------------------------- - -- Add_Search_Directories -- - ---------------------------- - - procedure Add_Search_Directories - (Data : Project_Data; - Language : First_Language_Indexes) - is - begin - -- If a GNU compiler is used, set the CPATH environment variable, - -- if it does not already has the correct value. - - if Compiler_Is_Gcc (Language) then - if Current_Include_Paths (Language) /= Data.Include_Path then - Current_Include_Paths (Language) := Data.Include_Path; - Setenv (CPATH, Data.Include_Path.all); - end if; - - else - Add_Arguments (Data.Imported_Directories_Switches.all, Verbose_Mode); - end if; - end Add_Search_Directories; - - ------------------ - -- Add_Switches -- - ------------------ - - procedure Add_Switches - (Data : Project_Data; - Proc : Processor; - Language : Language_Index; - File_Name : File_Name_Type) - is - Switches : Variable_Value; - -- The switches, if any, for the file/language - - Pkg : Package_Id; - -- The id of the package where to look for the switches - - Defaults : Array_Element_Id; - -- The Default_Switches associative array - - Switches_Array : Array_Element_Id; - -- The Switches associative array - - Element_Id : String_List_Id; - Element : String_Element; - - begin - -- First, choose the proper package - - case Proc is - when None => - raise Program_Error; - - when Linker => - Pkg := Value_Of (Name_Linker, Data.Decl.Packages, Project_Tree); - - when Compiler => - Pkg := Value_Of (Name_Compiler, Data.Decl.Packages, Project_Tree); - end case; - - if Pkg /= No_Package then - - -- Get the Switches ("file name"), if they exist - - Switches_Array := Prj.Util.Value_Of - (Name => Name_Switches, - In_Arrays => Project_Tree.Packages.Table - (Pkg).Decl.Arrays, - In_Tree => Project_Tree); - - Switches := - Prj.Util.Value_Of - (Index => Name_Id (File_Name), - Src_Index => 0, - In_Array => Switches_Array, - In_Tree => Project_Tree); - - -- Otherwise, get the Default_Switches ("language"), if they exist - - if Switches = Nil_Variable_Value then - Defaults := Prj.Util.Value_Of - (Name => Name_Default_Switches, - In_Arrays => Project_Tree.Packages.Table - (Pkg).Decl.Arrays, - In_Tree => Project_Tree); - Switches := Prj.Util.Value_Of - (Index => Language_Names.Table (Language), - Src_Index => 0, - In_Array => Defaults, - In_Tree => Project_Tree); - end if; - - -- If there are switches, add them to Arguments - - if Switches /= Nil_Variable_Value then - Element_Id := Switches.Values; - while Element_Id /= Nil_String loop - Element := Project_Tree.String_Elements.Table - (Element_Id); - - if Element.Value /= No_Name then - Get_Name_String (Element.Value); - - if not Quiet_Output then - - -- When not in quiet output (no -q), check that the - -- switch is not the concatenation of several valid - -- switches, such as "-g -v". If it is, issue a warning. - - Check (Option => Name_Buffer (1 .. Name_Len)); - end if; - - Add_Argument (Name_Buffer (1 .. Name_Len), True); - end if; - - Element_Id := Element.Next; - end loop; - end if; - end if; - end Add_Switches; - - -------------------------- - -- Build_Global_Archive -- - -------------------------- - - procedure Build_Global_Archive is - Data : Project_Data := Project_Tree.Projects.Table (Main_Project); - Source_Id : Other_Source_Id; - S_Id : Other_Source_Id; - Source : Other_Source; - Success : Boolean; - - Archive_Name : constant String := - "lib" - & Get_Name_String (Data.Display_Name) - & '.' - & Archive_Ext; - -- The name of the archive file for this project - - Archive_Dep_Name : constant String := - "lib" - & Get_Name_String (Data.Display_Name) - & ".deps"; - -- The name of the archive dependency file for this project - - Need_To_Rebuild : Boolean := Need_To_Rebuild_Global_Archive; - -- When True, archive will be rebuilt - - File : Prj.Util.Text_File; - Object_Path : Path_Name_Type; - Time_Stamp : Time_Stamp_Type; - Saved_Last_Argument : Natural; - First_Object : Natural; - - Discard : Boolean; - pragma Warnings (Off, Discard); - - begin - Check_Archive_Builder; - - if Project_Of_Current_Object_Directory /= Main_Project then - Project_Of_Current_Object_Directory := Main_Project; - Change_Dir (Get_Name_String (Data.Object_Directory)); - - if Verbose_Mode then - Write_Str ("Changing to object directory of """); - Write_Name (Data.Display_Name); - Write_Str (""": """); - Write_Name (Data.Display_Object_Dir); - Write_Line (""""); - end if; - end if; - - if not Need_To_Rebuild then - if Verbose_Mode then - Write_Str (" Checking "); - Write_Line (Archive_Name); - end if; - - -- If the archive does not exist, of course it needs to be built - - if not Is_Regular_File (Archive_Name) then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Line (" -> archive does not exist"); - end if; - - -- Archive does exist - - else - -- Check the archive dependency file - - Open (File, Archive_Dep_Name); - - -- If the archive dependency file does not exist, we need to - -- rebuild the archive and to create its dependency file. - - if not Is_Valid (File) then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> archive dependency file "); - Write_Str (Archive_Dep_Name); - Write_Line (" does not exist"); - end if; - - else - -- Put all sources of language other than Ada in Source_Indexes - - declare - Local_Data : Project_Data; - - begin - Last_Source := 0; - - for Proj in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Local_Data := Project_Tree.Projects.Table (Proj); - - if not Local_Data.Library then - Source_Id := Local_Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Add_Source_Id (Proj, Source_Id); - Source_Id := Project_Tree.Other_Sources.Table - (Source_Id).Next; - end loop; - end if; - end loop; - end; - - -- Read the dependency file, line by line - - while not End_Of_File (File) loop - Get_Line (File, Name_Buffer, Name_Len); - - -- First line is the path of the object file - - Object_Path := Name_Find; - Source_Id := No_Other_Source; - - -- Check if this object file is for a source of this project - - for S in 1 .. Last_Source loop - S_Id := Source_Indexes (S).Id; - Source := Project_Tree.Other_Sources.Table (S_Id); - - if (not Source_Indexes (S).Found) - and then Source.Object_Path = Object_Path - then - -- We have found the object file: get the source data, - -- and mark it as found. - - Source_Id := S_Id; - Source_Indexes (S).Found := True; - exit; - end if; - end loop; - - -- If it is not for a source of this project, then the - -- archive needs to be rebuilt. - - if Source_Id = No_Other_Source then - Need_To_Rebuild := True; - if Verbose_Mode then - Write_Str (" -> "); - Write_Str (Get_Name_String (Object_Path)); - Write_Line (" is not an object of any project"); - end if; - - exit; - end if; - - -- The second line is the time stamp of the object file. If - -- there is no next line, then the dependency file is - -- truncated, and the archive need to be rebuilt. - - if End_Of_File (File) then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> archive dependency file "); - Write_Line (" is truncated"); - end if; - - exit; - end if; - - Get_Line (File, Name_Buffer, Name_Len); - - -- If the line has the wrong number of characters, then - -- the dependency file is incorrectly formatted, and the - -- archive needs to be rebuilt. - - if Name_Len /= Time_Stamp_Length then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> archive dependency file "); - Write_Line (" is incorrectly formatted (time stamp)"); - end if; - - exit; - end if; - - Time_Stamp := Time_Stamp_Type (Name_Buffer (1 .. Name_Len)); - - -- If the time stamp in the dependency file is different - -- from the time stamp of the object file, then the archive - -- needs to be rebuilt. - - if Time_Stamp /= Source.Object_TS then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> time stamp of "); - Write_Str (Get_Name_String (Object_Path)); - Write_Str (" is incorrect in the archive"); - Write_Line (" dependency file"); - end if; - - exit; - end if; - end loop; - - Close (File); - end if; - end if; - end if; - - if not Need_To_Rebuild then - if Verbose_Mode then - Write_Line (" -> up to date"); - end if; - - -- No need to create a global archive, if there is no object - -- file to put into. - - Global_Archive_Exists := Last_Source /= 0; - - -- Archive needs to be rebuilt - - else - -- If archive already exists, first delete it - - -- Comment needed on why we discard result??? - - if Is_Regular_File (Archive_Name) then - Delete_File (Archive_Name, Discard); - end if; - - Last_Argument := 0; - - -- Start with the options found in MLib.Tgt (usually just "rc") - - Add_Arguments (Archive_Builder_Options.all, True); - - -- Followed by the archive name - - Add_Argument (Archive_Name, True); - - First_Object := Last_Argument; - - -- Followed by all the object files of the non library projects - - for Proj in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Data := Project_Tree.Projects.Table (Proj); - - if not Data.Library then - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := - Project_Tree.Other_Sources.Table (Source_Id); - - -- Only include object file name that have not been - -- overriden in extending projects. - - if Is_Included_In_Global_Archive - (Source.Object_Name, Proj) - then - Add_Argument - (Get_Name_String (Source.Object_Path), - Verbose_Mode or (First_Object = Last_Argument)); - end if; - - Source_Id := Source.Next; - end loop; - end if; - end loop; - - -- No need to create a global archive, if there is no object - -- file to put into. - - Global_Archive_Exists := Last_Argument > First_Object; - - if Global_Archive_Exists then - - -- If the archive is built, then linking will need to occur - -- unconditionally. - - Need_To_Relink := True; - - -- Spawn the archive builder (ar) - - Saved_Last_Argument := Last_Argument; - Last_Argument := First_Object + Max_In_Archives; - loop - if Last_Argument > Saved_Last_Argument then - Last_Argument := Saved_Last_Argument; - end if; - - Display_Command - (Archive_Builder, - Archive_Builder_Path, - Ellipse => True); - - Spawn - (Archive_Builder_Path.all, - Arguments (1 .. Last_Argument), - Success); - - exit when not Success - or else Last_Argument = Saved_Last_Argument; - - Arguments (1) := r; - Arguments (3 .. Saved_Last_Argument - Last_Argument + 2) := - Arguments (Last_Argument + 1 .. Saved_Last_Argument); - Saved_Last_Argument := Saved_Last_Argument - Last_Argument + 2; - end loop; - - -- If the archive was built, run the archive indexer (ranlib) - -- if there is one. - - if Success then - - if Archive_Indexer_Path /= null then - Last_Argument := 0; - Add_Argument (Archive_Name, True); - - Display_Command (Archive_Indexer, Archive_Indexer_Path); - - Spawn - (Archive_Indexer_Path.all, Arguments (1 .. 1), Success); - - if not Success then - - -- Running ranlib failed, delete the dependency file, - -- if it exists. - - if Is_Regular_File (Archive_Dep_Name) then - Delete_File (Archive_Dep_Name, Success); - end if; - - -- And report the error - - Report_Error - ("running" & Archive_Indexer & " for project """, - Get_Name_String (Data.Display_Name), - """ failed"); - return; - end if; - end if; - - -- The archive was correctly built, create its dependency file - - Create_Global_Archive_Dependency_File (Archive_Dep_Name); - - -- Building the archive failed, delete dependency file if one - -- exists. - - else - if Is_Regular_File (Archive_Dep_Name) then - Delete_File (Archive_Dep_Name, Success); - end if; - - -- And report the error - - Report_Error - ("building archive for project """, - Get_Name_String (Data.Display_Name), - """ failed"); - end if; - end if; - end if; - end Build_Global_Archive; - - ------------------- - -- Build_Library -- - ------------------- - - procedure Build_Library (Project : Project_Id; Unconditionally : Boolean) is - Data : constant Project_Data := - Project_Tree.Projects.Table (Project); - Source_Id : Other_Source_Id; - Source : Other_Source; - - Archive_Name : constant String := - "lib" & Get_Name_String (Data.Library_Name) - & '.' & Archive_Ext; - -- The name of the archive file for this project - - Archive_Dep_Name : constant String := - "lib" & Get_Name_String (Data.Library_Name) - & ".deps"; - -- The name of the archive dependency file for this project - - Need_To_Rebuild : Boolean := Unconditionally; - -- When True, archive will be rebuilt - - File : Prj.Util.Text_File; - - Object_Name : File_Name_Type; - Time_Stamp : Time_Stamp_Type; - Driver_Name : Name_Id := No_Name; - - Lib_Opts : Argument_List_Access := No_Argument'Access; - - begin - -- Nothing to do if the project is externally built - - if Data.Externally_Built then - return; - end if; - - Check_Archive_Builder; - - -- If Unconditionally is False, check if the archive need to be built - - if not Need_To_Rebuild then - if Verbose_Mode then - Write_Str (" Checking "); - Write_Line (Archive_Name); - end if; - - -- If the archive does not exist, of course it needs to be built - - if not Is_Regular_File (Archive_Name) then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Line (" -> archive does not exist"); - end if; - - -- Archive does exist - - else - -- Check the archive dependency file - - Open (File, Archive_Dep_Name); - - -- If the archive dependency file does not exist, we need to - -- rebuild the archive and to create its dependency file. - - if not Is_Valid (File) then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> archive dependency file "); - Write_Str (Archive_Dep_Name); - Write_Line (" does not exist"); - end if; - - else - -- Put all sources of language other than Ada in Source_Indexes - - Last_Source := 0; - - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Add_Source_Id (Project, Source_Id); - Source_Id := - Project_Tree.Other_Sources.Table (Source_Id).Next; - end loop; - - -- Read the dependency file, line by line - - while not End_Of_File (File) loop - Get_Line (File, Name_Buffer, Name_Len); - - -- First line is the name of an object file - - Object_Name := Name_Find; - Source_Id := No_Other_Source; - - -- Check if this object file is for a source of this project - - for S in 1 .. Last_Source loop - if (not Source_Indexes (S).Found) - and then - Project_Tree.Other_Sources.Table - (Source_Indexes (S).Id).Object_Name = Object_Name - then - -- We have found the object file: get the source - -- data, and mark it as found. - - Source_Id := Source_Indexes (S).Id; - Source := Project_Tree.Other_Sources.Table - (Source_Id); - Source_Indexes (S).Found := True; - exit; - end if; - end loop; - - -- If it is not for a source of this project, then the - -- archive needs to be rebuilt. - - if Source_Id = No_Other_Source then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> "); - Write_Str (Get_Name_String (Object_Name)); - Write_Line (" is not an object of the project"); - end if; - - exit; - end if; - - -- The second line is the time stamp of the object file. - -- If there is no next line, then the dependency file is - -- truncated, and the archive need to be rebuilt. - - if End_Of_File (File) then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> archive dependency file "); - Write_Line (" is truncated"); - end if; - - exit; - end if; - - Get_Line (File, Name_Buffer, Name_Len); - - -- If the line has the wrong number of character, then - -- the dependency file is incorrectly formatted, and the - -- archive needs to be rebuilt. - - if Name_Len /= Time_Stamp_Length then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> archive dependency file "); - Write_Line (" is incorrectly formatted (time stamp)"); - end if; - - exit; - end if; - - Time_Stamp := Time_Stamp_Type (Name_Buffer (1 .. Name_Len)); - - -- If the time stamp in the dependency file is different - -- from the time stamp of the object file, then the archive - -- needs to be rebuilt. - - if Time_Stamp /= Source.Object_TS then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> time stamp of "); - Write_Str (Get_Name_String (Object_Name)); - Write_Str (" is incorrect in the archive"); - Write_Line (" dependency file"); - end if; - - exit; - end if; - end loop; - - Close (File); - - if not Need_To_Rebuild then - - -- Now, check if all object files of the project have been - -- accounted for. If any of them is not in the dependency - -- file, the archive needs to be rebuilt. - - for Index in 1 .. Last_Source loop - if not Source_Indexes (Index).Found then - Need_To_Rebuild := True; - - if Verbose_Mode then - Source_Id := Source_Indexes (Index).Id; - Source := Project_Tree.Other_Sources.Table - (Source_Id); - Write_Str (" -> "); - Write_Str (Get_Name_String (Source.Object_Name)); - Write_Str (" is not in the archive "); - Write_Line ("dependency file"); - end if; - - exit; - end if; - end loop; - end if; - - if (not Need_To_Rebuild) and Verbose_Mode then - Write_Line (" -> up to date"); - end if; - end if; - end if; - end if; - - -- Build the library if necessary - - if Need_To_Rebuild then - - -- If a library is built, then linking will need to occur - -- unconditionally. - - Need_To_Relink := True; - - Last_Argument := 0; - - -- If there are sources in Ada, then gnatmake will build the library, - -- so nothing to do. - - if not Data.Langs (Ada_Language_Index) then - - -- Get all the object files of the project - - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := Project_Tree.Other_Sources.Table (Source_Id); - Add_Argument - (Get_Name_String (Source.Object_Name), Verbose_Mode); - Source_Id := Source.Next; - end loop; - - -- If it is a library, it need to be built it the same way Ada - -- libraries are built. - - if Data.Library_Kind = Static then - MLib.Build_Library - (Ofiles => Arguments (1 .. Last_Argument), - Output_File => Get_Name_String (Data.Library_Name), - Output_Dir => Get_Name_String (Data.Display_Library_Dir)); - - else - -- Link with g++ if C++ is one of the languages, otherwise - -- building the library may fail with unresolved symbols. - - if C_Plus_Plus_Is_Used then - if Compiler_Names (C_Plus_Plus_Language_Index) = null then - Get_Compiler (C_Plus_Plus_Language_Index); - end if; - - if Compiler_Is_Gcc (C_Plus_Plus_Language_Index) then - Name_Len := 0; - Add_Str_To_Name_Buffer - (Compiler_Names (C_Plus_Plus_Language_Index).all); - Driver_Name := Name_Find; - end if; - end if; - - -- If Library_Options is specified, add these options - - declare - Library_Options : constant Variable_Value := - Value_Of - (Name_Library_Options, - Data.Decl.Attributes, - Project_Tree); - - begin - if not Library_Options.Default then - declare - Current : String_List_Id; - Element : String_Element; - - begin - Current := Library_Options.Values; - while Current /= Nil_String loop - Element := - Project_Tree.String_Elements.Table (Current); - Get_Name_String (Element.Value); - - if Name_Len /= 0 then - Library_Opts.Increment_Last; - Library_Opts.Table (Library_Opts.Last) := - new String'(Name_Buffer (1 .. Name_Len)); - end if; - - Current := Element.Next; - end loop; - end; - end if; - - Lib_Opts := - new Argument_List'(Argument_List - (Library_Opts.Table (1 .. Library_Opts.Last))); - end; - - MLib.Tgt.Build_Dynamic_Library - (Ofiles => Arguments (1 .. Last_Argument), - Options => Lib_Opts.all, - Interfaces => No_Argument, - Lib_Filename => Get_Name_String (Data.Library_Name), - Lib_Dir => Get_Name_String (Data.Library_Dir), - Symbol_Data => No_Symbols, - Driver_Name => Driver_Name, - Lib_Version => "", - Auto_Init => False); - end if; - end if; - - -- Create fake empty archive, so we can check its time stamp later - - declare - Archive : Ada.Text_IO.File_Type; - begin - Create (Archive, Out_File, Archive_Name); - Close (Archive); - end; - - Create_Archive_Dependency_File - (Archive_Dep_Name, Data.First_Other_Source); - end if; - end Build_Library; - - ----------- - -- Check -- - ----------- - - procedure Check (Option : String) is - First : Positive := Option'First; - Last : Natural; - - begin - for Index in Option'First + 1 .. Option'Last - 1 loop - if Option (Index) = ' ' and then Option (Index + 1) = '-' then - Write_Str ("warning: switch """); - Write_Str (Option); - Write_Str (""" is suspicious; consider using "); - - Last := First; - while Last <= Option'Last loop - if Option (Last) = ' ' then - if First /= Option'First then - Write_Str (", "); - end if; - - Write_Char ('"'); - Write_Str (Option (First .. Last - 1)); - Write_Char ('"'); - - while Last <= Option'Last and then Option (Last) = ' ' loop - Last := Last + 1; - end loop; - - First := Last; - - else - if Last = Option'Last then - if First /= Option'First then - Write_Str (", "); - end if; - - Write_Char ('"'); - Write_Str (Option (First .. Last)); - Write_Char ('"'); - end if; - - Last := Last + 1; - end if; - end loop; - - Write_Line (" instead"); - exit; - end if; - end loop; - end Check; - - --------------------------- - -- Check_Archive_Builder -- - --------------------------- - - procedure Check_Archive_Builder is - begin - -- First, make sure that the archive builder (ar) is on the path - - if Archive_Builder_Path = null then - Archive_Builder_Path := Locate_Exec_On_Path (Archive_Builder); - - if Archive_Builder_Path = null then - Osint.Fail - ("unable to locate archive builder """, - Archive_Builder, - """"); - end if; - - -- If there is an archive indexer (ranlib), try to locate it on the - -- path. Don't fail if it is not found. - - if Archive_Indexer /= "" then - Archive_Indexer_Path := Locate_Exec_On_Path (Archive_Indexer); - end if; - end if; - end Check_Archive_Builder; - - ------------------------------ - -- Check_Compilation_Needed -- - ------------------------------ - - procedure Check_Compilation_Needed - (Source : Other_Source; - Need_To_Compile : out Boolean) - is - Source_Name : constant String := Get_Name_String (Source.File_Name); - Source_Path : constant String := Get_Name_String (Source.Path_Name); - Object_Name : constant String := Get_Name_String (Source.Object_Name); - C_Object_Name : String := Object_Name; - Dep_Name : constant String := Get_Name_String (Source.Dep_Name); - C_Source_Path : constant String := - Normalize_Pathname - (Name => Source_Path, - Resolve_Links => False, - Case_Sensitive => False); - - Source_In_Dependencies : Boolean := False; - -- Set True if source was found in dependency file of its object file - - Dep_File : Prj.Util.Text_File; - Start : Natural; - Finish : Natural; - - Looping : Boolean := False; - -- Set to True at the end of the first Big_Loop - - begin - Canonical_Case_File_Name (C_Object_Name); - - -- Assume the worst, so that statement "return;" may be used if there - -- is any problem. - - Need_To_Compile := True; - - if Verbose_Mode then - Write_Str (" Checking "); - Write_Str (Source_Name); - Write_Line (" ... "); - end if; - - -- If object file does not exist, of course source need to be compiled - - if Source.Object_TS = Empty_Time_Stamp then - if Verbose_Mode then - Write_Str (" -> object file "); - Write_Str (Object_Name); - Write_Line (" does not exist"); - end if; - - return; - end if; - - -- If the object file has been created before the last modification - -- of the source, the source need to be recompiled. - - if Source.Object_TS < Source.Source_TS then - if Verbose_Mode then - Write_Str (" -> object file "); - Write_Str (Object_Name); - Write_Line (" has time stamp earlier than source"); - end if; - - return; - end if; - - -- If there is no dependency file, then the source needs to be - -- recompiled and the dependency file need to be created. - - if Source.Dep_TS = Empty_Time_Stamp then - if Verbose_Mode then - Write_Str (" -> dependency file "); - Write_Str (Dep_Name); - Write_Line (" does not exist"); - end if; - - return; - end if; - - -- The source needs to be recompiled if the source has been modified - -- after the dependency file has been created. - - if Source.Dep_TS < Source.Source_TS then - if Verbose_Mode then - Write_Str (" -> dependency file "); - Write_Str (Dep_Name); - Write_Line (" has time stamp earlier than source"); - end if; - - return; - end if; - - -- Look for all dependencies - - Open (Dep_File, Dep_Name); - - -- If dependency file cannot be open, we need to recompile the source - - if not Is_Valid (Dep_File) then - if Verbose_Mode then - Write_Str (" -> could not open dependency file "); - Write_Line (Dep_Name); - end if; - - return; - end if; - - -- Loop Big_Loop is executed several times only when the dependency file - -- contains several times - -- : ... - -- When there is only one of such occurence, Big_Loop is exited - -- successfully at the beginning of the second loop. - - Big_Loop : - loop - declare - End_Of_File_Reached : Boolean := False; - - begin - loop - if End_Of_File (Dep_File) then - End_Of_File_Reached := True; - exit; - end if; - - Get_Line (Dep_File, Name_Buffer, Name_Len); - - exit when Name_Len > 0 and then Name_Buffer (1) /= '#'; - end loop; - - -- If dependency file contains only empty lines or comments, then - -- dependencies are unknown, and the source needs to be - -- recompiled. - - if End_Of_File_Reached then - -- If we have reached the end of file after the first loop, - -- there is nothing else to do. - - exit Big_Loop when Looping; - - if Verbose_Mode then - Write_Str (" -> dependency file "); - Write_Str (Dep_Name); - Write_Line (" is empty"); - end if; - - Close (Dep_File); - return; - end if; - end; - - Start := 1; - Finish := Index (Name_Buffer (1 .. Name_Len), ": "); - - if Finish /= 0 then - Canonical_Case_File_Name (Name_Buffer (1 .. Finish - 1)); - end if; - - -- First line must start with name of object file, followed by colon - - if Finish = 0 or else - Name_Buffer (1 .. Finish - 1) /= C_Object_Name - then - if Verbose_Mode then - Write_Str (" -> dependency file "); - Write_Str (Dep_Name); - Write_Line (" has wrong format"); - end if; - - Close (Dep_File); - return; - - else - Start := Finish + 2; - - -- Process each line - - Line_Loop : loop - declare - Line : String := Name_Buffer (1 .. Name_Len); - Last : Natural := Name_Len; - - begin - Name_Loop : loop - - -- Find the beginning of the next source path name - - while Start < Last and then Line (Start) = ' ' loop - Start := Start + 1; - end loop; - - -- Go to next line when there is a continuation character - -- \ at the end of the line. - - exit Name_Loop when Start = Last - and then Line (Start) = '\'; - - -- We should not be at the end of the line, without - -- a continuation character \. - - if Start = Last then - if Verbose_Mode then - Write_Str (" -> dependency file "); - Write_Str (Dep_Name); - Write_Line (" has wrong format"); - end if; - - Close (Dep_File); - return; - end if; - - -- Look for the end of the source path name - - Finish := Start; - while Finish < Last loop - if Line (Finish) = '\' then - - -- On Windows, a '\' is part of the path name, - -- except when it is followed by another '\' or by - -- a space. On other platforms, when we are getting - -- a '\' that is not the last character of the - -- line, the next character is part of the path - -- name, even if it is a space. - - if On_Windows - and then Line (Finish + 1) /= '\' - and then Line (Finish + 1) /= ' ' - then - Finish := Finish + 1; - - else - Line (Finish .. Last - 1) := - Line (Finish + 1 .. Last); - Last := Last - 1; - end if; - - else - -- A space that is not preceded by '\' indicates - -- the end of the path name. - - exit when Line (Finish + 1) = ' '; - - Finish := Finish + 1; - end if; - end loop; - - -- Check this source - - declare - Src_Name : constant String := - Normalize_Pathname - (Name => - Line (Start .. Finish), - Resolve_Links => False, - Case_Sensitive => False); - Src_TS : Time_Stamp_Type; - - begin - -- If it is original source, set - -- Source_In_Dependencies. - - if Src_Name = C_Source_Path then - Source_In_Dependencies := True; - end if; - - Name_Len := 0; - Add_Str_To_Name_Buffer (Src_Name); - Src_TS := File_Stamp (File_Name_Type'(Name_Find)); - - -- If the source does not exist, we need to recompile - - if Src_TS = Empty_Time_Stamp then - if Verbose_Mode then - Write_Str (" -> source "); - Write_Str (Src_Name); - Write_Line (" does not exist"); - end if; - - Close (Dep_File); - return; - - -- If the source has been modified after the object - -- file, we need to recompile. - - elsif Src_TS > Source.Object_TS then - if Verbose_Mode then - Write_Str (" -> source "); - Write_Str (Src_Name); - Write_Line - (" has time stamp later than object file"); - end if; - - Close (Dep_File); - return; - end if; - end; - - -- If the source path name ends the line, we are done - - exit Line_Loop when Finish = Last; - - -- Go get the next source on the line - - Start := Finish + 1; - end loop Name_Loop; - end; - - -- If we are here, we had a continuation character \ at the end - -- of the line, so we continue with the next line. - - Get_Line (Dep_File, Name_Buffer, Name_Len); - Start := 1; - end loop Line_Loop; - end if; - - -- Set Looping at the end of the first loop - Looping := True; - end loop Big_Loop; - - Close (Dep_File); - - -- If the original sources were not in the dependency file, then we - -- need to recompile. It may mean that we are using a different source - -- (different variant) for this object file. - - if not Source_In_Dependencies then - if Verbose_Mode then - Write_Str (" -> source "); - Write_Str (Source_Path); - Write_Line (" is not in the dependencies"); - end if; - - return; - end if; - - -- If we are here, then everything is OK, no need to recompile - - if Verbose_Mode then - Write_Line (" -> up to date"); - end if; - - Need_To_Compile := False; - end Check_Compilation_Needed; - - --------------------------- - -- Check_For_C_Plus_Plus -- - --------------------------- - - procedure Check_For_C_Plus_Plus is - begin - C_Plus_Plus_Is_Used := False; - - for Project in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - if - Project_Tree.Projects.Table (Project).Langs - (C_Plus_Plus_Language_Index) - then - C_Plus_Plus_Is_Used := True; - exit; - end if; - end loop; - end Check_For_C_Plus_Plus; - - ------------- - -- Compile -- - ------------- - - procedure Compile - (Source_Id : Other_Source_Id; - Data : Project_Data; - Local_Errors : in out Boolean) - is - Source : Other_Source := - Project_Tree.Other_Sources.Table (Source_Id); - Success : Boolean; - CPATH : String_Access := null; - - begin - -- If the compiler is not known yet, get its path name - - if Compiler_Names (Source.Language) = null then - Get_Compiler (Source.Language); - end if; - - -- For non GCC compilers, get the dependency file, first calling the - -- compiler with the switch -M. - - if not Compiler_Is_Gcc (Source.Language) then - Last_Argument := 0; - - -- Add the source name, preceded by -M - - Add_Argument (Dash_M, True); - Add_Argument (Get_Name_String (Source.Path_Name), True); - - -- Add the compiling switches for this source found in - -- package Compiler of the project file, if they exist. - - Add_Switches - (Data, Compiler, Source.Language, Source.File_Name); - - -- Add the compiling switches for the language specified - -- on the command line, if any. - - for - J in 1 .. Comp_Opts.Last (Options (Source.Language)) - loop - Add_Argument (Options (Source.Language).Table (J), True); - end loop; - - -- Finally, add imported directory switches for this project file - - Add_Search_Directories (Data, Source.Language); - - -- And invoke the compiler using GNAT.Expect - - Display_Command - (Compiler_Names (Source.Language).all, - Compiler_Paths (Source.Language)); - - begin - Non_Blocking_Spawn - (FD, - Compiler_Paths (Source.Language).all, - Arguments (1 .. Last_Argument), - Buffer_Size => 0, - Err_To_Out => True); - - declare - Dep_File : Ada.Text_IO.File_Type; - Result : Expect_Match; - - Status : Integer; - pragma Warnings (Off, Status); - - begin - -- Create the dependency file - - Create (Dep_File, Out_File, Get_Name_String (Source.Dep_Name)); - - loop - Expect (FD, Result, Line_Matcher); - - exit when Result = Expect_Timeout; - - declare - S : constant String := Strip_CR_LF (Expect_Out (FD)); - - begin - -- Each line of the output is put in the dependency - -- file, including errors. If there are errors, the - -- syntax of the dependency file will be incorrect and - -- recompilation will occur automatically the next time - -- the dependencies are checked. - - Put_Line (Dep_File, S); - end; - end loop; - - -- If we are here, it means we had a timeout, so the - -- dependency file may be incomplete. It is safer to - -- delete it, otherwise the dependencies may be wrong. - - Close (FD, Status); - Close (Dep_File); - Delete_File (Get_Name_String (Source.Dep_Name), Success); - - exception - when Process_Died => - - -- This is the normal outcome. Just close the file - - Close (FD, Status); - Close (Dep_File); - - when others => - - -- Something wrong happened. It is safer to delete the - -- dependency file, otherwise the dependencies may be wrong. - - Close (FD, Status); - - if Is_Open (Dep_File) then - Close (Dep_File); - end if; - - Delete_File (Get_Name_String (Source.Dep_Name), Success); - end; - - exception - -- If we cannot spawn the compiler, then the dependencies are - -- not updated. It is safer then to delete the dependency file, - -- otherwise the dependencies may be wrong. - - when Invalid_Process => - Delete_File (Get_Name_String (Source.Dep_Name), Success); - end; - end if; - - Last_Argument := 0; - - -- For GCC compilers, make sure the language is always specified to - -- to the GCC driver, in case the extension is not recognized by the - -- GCC driver as a source of the language. - - if Compiler_Is_Gcc (Source.Language) then - Add_Argument (Dash_x, Verbose_Mode); - Add_Argument - (Get_Name_String (Language_Names.Table (Source.Language)), - Verbose_Mode); - end if; - - Add_Argument (Dash_c, True); - - -- Add the compiling switches for this source found in package Compiler - -- of the project file, if they exist. - - Add_Switches - (Data, Compiler, Source.Language, Source.File_Name); - - -- Specify the source to be compiled - - Add_Argument (Get_Name_String (Source.Path_Name), True); - - -- If non static library project, compile with the PIC option if there - -- is one (when there is no PIC option, MLib.Tgt.PIC_Option returns an - -- empty string, and Add_Argument with an empty string has no effect). - - if Data.Library and then Data.Library_Kind /= Static then - Add_Argument (PIC_Option, True); - end if; - - -- Indicate the name of the object - - Add_Argument (Dash_o, True); - Add_Argument (Get_Name_String (Source.Object_Name), True); - - -- When compiler is GCC, use the magic switch that creates the - -- dependency file in the correct format. - - if Compiler_Is_Gcc (Source.Language) then - Add_Argument - ("-Wp,-MD," & Get_Name_String (Source.Dep_Name), - Verbose_Mode); - end if; - - -- Add the compiling switches for the language specified on the command - -- line, if any. - - for J in 1 .. Comp_Opts.Last (Options (Source.Language)) loop - Add_Argument (Options (Source.Language).Table (J), True); - end loop; - - -- Finally, add the imported directory switches for this project file - -- (or, for gcc compilers, set up the CPATH env var if needed). - - Add_Search_Directories (Data, Source.Language); - - -- Set CPATH, if compiler is GCC - - if Compiler_Is_Gcc (Source.Language) then - CPATH := Current_Include_Paths (Source.Language); - end if; - - -- And invoke the compiler - - Display_Command - (Name => Compiler_Names (Source.Language).all, - Path => Compiler_Paths (Source.Language), - CPATH => CPATH); - - Spawn - (Compiler_Paths (Source.Language).all, - Arguments (1 .. Last_Argument), - Success); - - -- Case of successful compilation - - if Success then - - -- Update the time stamp of the object file - - Source.Object_TS := File_Stamp (Source.Object_Name); - - -- Do some sanity checks - - if Source.Object_TS = Empty_Time_Stamp then - Local_Errors := True; - Report_Error - ("object file ", - Get_Name_String (Source.Object_Name), - " has not been created"); - - elsif Source.Object_TS < Source.Source_TS then - Local_Errors := True; - Report_Error - ("object file ", - Get_Name_String (Source.Object_Name), - " has not been modified"); - - else - -- Everything looks fine, update the Other_Sources table - - Project_Tree.Other_Sources.Table (Source_Id) := Source; - end if; - - -- Compilation failed - - else - Local_Errors := True; - Report_Error - ("compilation of ", - Get_Name_String (Source.Path_Name), - " failed"); - end if; - end Compile; - - -------------------------------- - -- Compile_Individual_Sources -- - -------------------------------- - - procedure Compile_Individual_Sources is - Data : Project_Data := - Project_Tree.Projects.Table (Main_Project); - Source_Id : Other_Source_Id; - Source : Other_Source; - Source_Name : File_Name_Type; - Project_Name : String := Get_Name_String (Data.Name); - Dummy : Boolean := False; - - Ada_Is_A_Language : constant Boolean := - Data.Langs (Ada_Language_Index); - - begin - Ada_Mains.Init; - To_Mixed (Project_Name); - Compile_Only := True; - - Get_Imported_Directories (Main_Project, Data); - Project_Tree.Projects.Table (Main_Project) := Data; - - -- Compilation will occur in the object directory - - if Project_Of_Current_Object_Directory /= Main_Project then - Project_Of_Current_Object_Directory := Main_Project; - Change_Dir (Get_Name_String (Data.Object_Directory)); - - if Verbose_Mode then - Write_Str ("Changing to object directory of """); - Write_Name (Data.Name); - Write_Str (""": """); - Write_Name (Data.Display_Object_Dir); - Write_Line (""""); - end if; - end if; - - if not Data.Other_Sources_Present then - if Ada_Is_A_Language then - Mains.Reset; - - loop - declare - Main : constant String := Mains.Next_Main; - begin - exit when Main'Length = 0; - Ada_Mains.Increment_Last; - Ada_Mains.Table (Ada_Mains.Last) := new String'(Main); - end; - end loop; - - else - Osint.Fail ("project ", Project_Name, " contains no source"); - end if; - - else - Mains.Reset; - - loop - declare - Main : constant String := Mains.Next_Main; - begin - Name_Len := Main'Length; - exit when Name_Len = 0; - Name_Buffer (1 .. Name_Len) := Main; - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Source_Name := Name_Find; - - if not Sources_Compiled.Get (Source_Name) then - Sources_Compiled.Set (Source_Name, True); - - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := Project_Tree.Other_Sources.Table (Source_Id); - exit when Source.File_Name = Source_Name; - Source_Id := Source.Next; - end loop; - - if Source_Id = No_Other_Source then - if Ada_Is_A_Language then - Ada_Mains.Increment_Last; - Ada_Mains.Table (Ada_Mains.Last) := new String'(Main); - - else - Report_Error - (Main, - " is not a valid source of project ", - Project_Name); - end if; - - else - Compile (Source_Id, Data, Dummy); - end if; - end if; - end; - end loop; - end if; - - if Ada_Mains.Last > 0 then - - -- Invoke gnatmake for all Ada sources - - Last_Argument := 0; - Add_Argument (Dash_u, True); - - for Index in 1 .. Ada_Mains.Last loop - Add_Argument (Ada_Mains.Table (Index), True); - end loop; - - Compile_Link_With_Gnatmake (Mains_Specified => False); - end if; - end Compile_Individual_Sources; - - -------------------------------- - -- Compile_Link_With_Gnatmake -- - -------------------------------- - - procedure Compile_Link_With_Gnatmake (Mains_Specified : Boolean) is - Data : constant Project_Data := - Project_Tree.Projects.Table (Main_Project); - Success : Boolean; - - begin - -- Array Arguments may already contain some arguments, so we don't - -- set Last_Argument to 0. - - -- Get the gnatmake to invoke - - Get_Compiler (Ada_Language_Index); - - -- Specify the project file - - Add_Argument (Dash_P, True); - Add_Argument (Get_Name_String (Data.Display_Path_Name), True); - - -- Add the saved switches, if any - - for Index in 1 .. Saved_Switches.Last loop - Add_Argument (Saved_Switches.Table (Index), True); - end loop; - - -- If Mains_Specified is True, find the mains in package Mains - - if Mains_Specified then - Mains.Reset; - - loop - declare - Main : constant String := Mains.Next_Main; - begin - exit when Main'Length = 0; - Add_Argument (Main, True); - end; - end loop; - end if; - - -- Specify output file name, if any was specified on the command line - - if Output_File_Name /= null then - Add_Argument (Dash_o, True); - Add_Argument (Output_File_Name, True); - end if; - - -- Transmit some switches to gnatmake - - -- -c - - if Compile_Only then - Add_Argument (Dash_c, True); - end if; - - -- -d - - if Display_Compilation_Progress then - Add_Argument (Dash_d, True); - end if; - - -- -k - - if Keep_Going then - Add_Argument (Dash_k, True); - end if; - - -- -f - - if Force_Compilations then - Add_Argument (Dash_f, True); - end if; - - -- -v - - if Verbose_Mode then - Add_Argument (Dash_v, True); - end if; - - -- -q - - if Quiet_Output then - Add_Argument (Dash_q, True); - end if; - - -- -vP1 and -vP2 - - case Current_Verbosity is - when Default => - null; - - when Medium => - Add_Argument (Dash_vP1, True); - - when High => - Add_Argument (Dash_vP2, True); - end case; - - -- If there are compiling options for Ada, transmit them to gnatmake - - if Comp_Opts.Last (Options (Ada_Language_Index)) /= 0 then - Add_Argument (Dash_cargs, True); - - for Arg in 1 .. Comp_Opts.Last (Options (Ada_Language_Index)) loop - Add_Argument (Options (Ada_Language_Index).Table (Arg), True); - end loop; - end if; - - if not Compile_Only then - - -- Linking options - - if Linker_Options.Last /= 0 then - Add_Argument (Dash_largs, True); - else - Add_Argument (Dash_largs, Verbose_Mode); - end if; - - -- Add the archives - - Add_Archives (For_Gnatmake => True); - - -- If there are linking options from the command line, - -- transmit them to gnatmake. - - for Arg in 1 .. Linker_Options.Last loop - Add_Argument (Linker_Options.Table (Arg), True); - end loop; - end if; - - -- And invoke gnatmake - - Display_Command - (Compiler_Names (Ada_Language_Index).all, - Compiler_Paths (Ada_Language_Index)); - - Spawn - (Compiler_Paths (Ada_Language_Index).all, - Arguments (1 .. Last_Argument), - Success); - - -- Report an error if call to gnatmake failed - - if not Success then - Report_Error - ("invocation of ", - Compiler_Names (Ada_Language_Index).all, - " failed"); - end if; - end Compile_Link_With_Gnatmake; - - --------------------- - -- Compile_Sources -- - --------------------- - - procedure Compile_Sources is - Data : Project_Data; - Source_Id : Other_Source_Id; - Source : Other_Source; - - Local_Errors : Boolean := False; - -- Set to True when there is a compilation error. Used only when - -- Keep_Going is True, to inhibit the building of the archive. - - Need_To_Compile : Boolean; - -- Set to True when a source needs to be compiled/recompiled - - Need_To_Rebuild_Archive : Boolean := Force_Compilations; - -- True when the archive needs to be built/rebuilt unconditionally - - Total_Number_Of_Sources : Int := 0; - - Current_Source_Number : Int := 0; - - begin - -- First, get the number of sources - - for Project in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Data := Project_Tree.Projects.Table (Project); - - if not Data.Virtual and then Data.Other_Sources_Present then - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := Project_Tree.Other_Sources.Table (Source_Id); - Total_Number_Of_Sources := Total_Number_Of_Sources + 1; - Source_Id := Source.Next; - end loop; - end if; - end loop; - - -- Loop through project files - - for Project in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Local_Errors := False; - Data := Project_Tree.Projects.Table (Project); - - -- Nothing to do when no sources of language other than Ada - - if (not Data.Virtual) and then Data.Other_Sources_Present then - - -- If the imported directory switches are unknown, compute them - - if not Data.Include_Data_Set then - Get_Imported_Directories (Project, Data); - Data.Include_Data_Set := True; - Project_Tree.Projects.Table (Project) := Data; - end if; - - Need_To_Rebuild_Archive := Force_Compilations; - - -- Compilation will occur in the object directory - - if Project_Of_Current_Object_Directory /= Project then - Project_Of_Current_Object_Directory := Project; - Change_Dir (Get_Name_String (Data.Object_Directory)); - - if Verbose_Mode then - Write_Str ("Changing to object directory of """); - Write_Name (Data.Display_Name); - Write_Str (""": """); - Write_Name (Data.Display_Object_Dir); - Write_Line (""""); - end if; - end if; - - -- Process each source one by one - - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := Project_Tree.Other_Sources.Table (Source_Id); - Current_Source_Number := Current_Source_Number + 1; - Need_To_Compile := Force_Compilations; - - -- Check if compilation is needed - - if not Need_To_Compile then - Check_Compilation_Needed (Source, Need_To_Compile); - end if; - - -- Proceed, if compilation is needed - - if Need_To_Compile then - - -- If a source is compiled/recompiled, of course the - -- archive will need to be built/rebuilt. - - Need_To_Rebuild_Archive := True; - Compile (Source_Id, Data, Local_Errors); - end if; - - if Display_Compilation_Progress then - Write_Str ("completed "); - Write_Int (Current_Source_Number); - Write_Str (" out of "); - Write_Int (Total_Number_Of_Sources); - Write_Str (" ("); - Write_Int - ((Current_Source_Number * 100) / Total_Number_Of_Sources); - Write_Str ("%)..."); - Write_Eol; - end if; - - -- Next source, if any - - Source_Id := Source.Next; - end loop; - - if Need_To_Rebuild_Archive and then (not Data.Library) then - Need_To_Rebuild_Global_Archive := True; - end if; - - -- If there was no compilation error and -c was not used, - -- build / rebuild the archive if necessary. - - if not Local_Errors - and then Data.Library - and then not Data.Langs (Ada_Language_Index) - and then not Compile_Only - then - Build_Library (Project, Need_To_Rebuild_Archive); - end if; - end if; - end loop; - end Compile_Sources; - - --------------- - -- Copyright -- - --------------- - - procedure Copyright is - begin - -- Only output the Copyright notice once - - if not Copyright_Output then - Copyright_Output := True; - Write_Eol; - Write_Str ("GPRMAKE "); - Write_Str (Gnatvsn.Gnat_Version_String); - Write_Str (" Copyright 2004-"); - Write_Str (Gnatvsn.Current_Year); - Write_Str (" Free Software Foundation, Inc."); - Write_Eol; - end if; - end Copyright; - - ------------------------------------ - -- Create_Archive_Dependency_File -- - ------------------------------------ - - procedure Create_Archive_Dependency_File - (Name : String; - First_Source : Other_Source_Id) - is - Source_Id : Other_Source_Id; - Source : Other_Source; - Dep_File : Ada.Text_IO.File_Type; - - begin - -- Create the file in Append mode, to avoid automatic insertion of - -- an end of line if file is empty. - - Create (Dep_File, Append_File, Name); - - Source_Id := First_Source; - while Source_Id /= No_Other_Source loop - Source := Project_Tree.Other_Sources.Table (Source_Id); - Put_Line (Dep_File, Get_Name_String (Source.Object_Name)); - Put_Line (Dep_File, String (Source.Object_TS)); - Source_Id := Source.Next; - end loop; - - Close (Dep_File); - - exception - when others => - if Is_Open (Dep_File) then - Close (Dep_File); - end if; - end Create_Archive_Dependency_File; - - ------------------------------------------- - -- Create_Global_Archive_Dependency_File -- - ------------------------------------------- - - procedure Create_Global_Archive_Dependency_File (Name : String) is - Source_Id : Other_Source_Id; - Source : Other_Source; - Dep_File : Ada.Text_IO.File_Type; - - begin - -- Create the file in Append mode, to avoid automatic insertion of - -- an end of line if file is empty. - - Create (Dep_File, Append_File, Name); - - -- Get all the object files of non-Ada sources in non-library projects - - for Project in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - if not Project_Tree.Projects.Table (Project).Library then - Source_Id := - Project_Tree.Projects.Table (Project).First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := Project_Tree.Other_Sources.Table (Source_Id); - - -- Put only those object files that are in the global archive - - if Is_Included_In_Global_Archive - (Source.Object_Name, Project) - then - Put_Line (Dep_File, Get_Name_String (Source.Object_Path)); - Put_Line (Dep_File, String (Source.Object_TS)); - end if; - - Source_Id := Source.Next; - end loop; - end if; - end loop; - - Close (Dep_File); - - exception - when others => - if Is_Open (Dep_File) then - Close (Dep_File); - end if; - end Create_Global_Archive_Dependency_File; - - --------------------- - -- Display_Command -- - --------------------- - - procedure Display_Command - (Name : String; - Path : String_Access; - CPATH : String_Access := null; - Ellipse : Boolean := False) - is - Display_Ellipse : Boolean := Ellipse; - - begin - -- Only display the command in Verbose Mode (-v) or when - -- not in Quiet Output (no -q). - - if Verbose_Mode or (not Quiet_Output) then - - -- In Verbose Mode output the full path of the spawned process - - if Verbose_Mode then - if CPATH /= null then - Write_Str ("CPATH = "); - Write_Line (CPATH.all); - end if; - - Write_Str (Path.all); - - else - Write_Str (Name); - end if; - - -- Display only the arguments for which the display flag is set - -- (in Verbose Mode, the display flag is set for all arguments) - - for Arg in 1 .. Last_Argument loop - if Arguments_Displayed (Arg) then - Write_Char (' '); - Write_Str (Arguments (Arg).all); - - elsif Display_Ellipse then - Write_Str (" ..."); - Display_Ellipse := False; - end if; - end loop; - - Write_Eol; - end if; - end Display_Command; - - ------------------ - -- Get_Compiler -- - ------------------ - - procedure Get_Compiler (For_Language : First_Language_Indexes) is - Data : constant Project_Data := - Project_Tree.Projects.Table (Main_Project); - - Ide : constant Package_Id := - Value_Of - (Name_Ide, - In_Packages => Data.Decl.Packages, - In_Tree => Project_Tree); - -- The id of the package IDE in the project file - - Compiler : constant Variable_Value := - Value_Of - (Name => Language_Names.Table (For_Language), - Index => 0, - Attribute_Or_Array_Name => Name_Compiler_Command, - In_Package => Ide, - In_Tree => Project_Tree); - -- The value of Compiler_Command ("language") in package IDE, if defined - - begin - -- No need to do it again if the compiler is known for this language - - if Compiler_Names (For_Language) = null then - - -- If compiler command is not defined for this language in package - -- IDE, use the default compiler for this language. - - if Compiler = Nil_Variable_Value then - if For_Language in Default_Compiler_Names'Range then - Compiler_Names (For_Language) := - Default_Compiler_Names (For_Language); - - else - Osint.Fail - ("unknow compiler name for language """, - Get_Name_String (Language_Names.Table (For_Language)), - """"); - end if; - - else - Compiler_Names (For_Language) := - new String'(Get_Name_String (Compiler.Value)); - end if; - - -- Check we have a GCC compiler (name ends with "gcc" or "g++") - - declare - Comp_Name : constant String := Compiler_Names (For_Language).all; - Last3 : String (1 .. 3); - begin - if Comp_Name'Length >= 3 then - Last3 := Comp_Name (Comp_Name'Last - 2 .. Comp_Name'Last); - Compiler_Is_Gcc (For_Language) := - (Last3 = "gcc") or (Last3 = "g++"); - else - Compiler_Is_Gcc (For_Language) := False; - end if; - end; - - -- Locate the compiler on the path - - Compiler_Paths (For_Language) := - Locate_Exec_On_Path (Compiler_Names (For_Language).all); - - -- Fail if compiler cannot be found - - if Compiler_Paths (For_Language) = null then - if For_Language = Ada_Language_Index then - Osint.Fail - ("unable to locate """, - Compiler_Names (For_Language).all, - """"); - - else - Osint.Fail - ("unable to locate " & - Get_Name_String (Language_Names.Table (For_Language)), - " compiler """, Compiler_Names (For_Language).all & '"'); - end if; - end if; - end if; - end Get_Compiler; - - ------------------------------ - -- Get_Imported_Directories -- - ------------------------------ - - procedure Get_Imported_Directories - (Project : Project_Id; - Data : in out Project_Data) - is - Imported_Projects : Project_List := Data.Imported_Projects; - - Path_Length : Natural := 0; - Position : Natural := 0; - - procedure Add (Source_Dirs : String_List_Id); - -- Add a list of source directories - - procedure Recursive_Get_Dirs (Prj : Project_Id); - -- Recursive procedure to get the source directories of this project - -- file and of the project files it imports, in the correct order. - - --------- - -- Add -- - --------- - - procedure Add (Source_Dirs : String_List_Id) is - Element_Id : String_List_Id; - Element : String_Element; - Add_Arg : Boolean := True; - - begin - -- Add each source directory path name, preceded by "-I" to Arguments - - Element_Id := Source_Dirs; - while Element_Id /= Nil_String loop - Element := Project_Tree.String_Elements.Table (Element_Id); - - if Element.Value /= No_Name then - Get_Name_String (Element.Display_Value); - - if Name_Len > 0 then - - -- Remove a trailing directory separator: this may cause - -- problems on Windows. - - if Name_Len > 1 - and then Name_Buffer (Name_Len) = Directory_Separator - then - Name_Len := Name_Len - 1; - end if; - - declare - Arg : constant String := - "-I" & Name_Buffer (1 .. Name_Len); - begin - -- Check if directory is already in the list. If it is, - -- no need to put it there again. - - Add_Arg := True; - - for Index in 1 .. Last_Argument loop - if Arguments (Index).all = Arg then - Add_Arg := False; - exit; - end if; - end loop; - - if Add_Arg then - if Path_Length /= 0 then - Path_Length := Path_Length + 1; - end if; - - Path_Length := Path_Length + Name_Len; - - Add_Argument (Arg, True); - end if; - end; - end if; - end if; - - Element_Id := Element.Next; - end loop; - end Add; - - ------------------------ - -- Recursive_Get_Dirs -- - ------------------------ - - procedure Recursive_Get_Dirs (Prj : Project_Id) is - Data : Project_Data; - Imported : Project_List; - - begin - -- Nothing to do if project is undefined - - if Prj /= No_Project then - Data := Project_Tree.Projects.Table (Prj); - - -- Nothing to do if project has already been processed - - if not Data.Seen then - - -- Mark the project as processed, to avoid multiple processing - -- of the same project. - - Project_Tree.Projects.Table (Prj).Seen := True; - - -- Add the source directories of this project - - if not Data.Virtual then - Add (Data.Source_Dirs); - end if; - - Recursive_Get_Dirs (Data.Extends); - - -- Call itself for all imported projects, if any - - Imported := Data.Imported_Projects; - while Imported /= Empty_Project_List loop - Recursive_Get_Dirs - (Project_Tree.Project_Lists.Table (Imported).Project); - Imported := - Project_Tree.Project_Lists.Table (Imported).Next; - end loop; - end if; - end if; - end Recursive_Get_Dirs; - - -- Start of processing for Get_Imported_Directories - - begin - -- First, mark all project as not processed - - for J in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Project_Tree.Projects.Table (J).Seen := False; - end loop; - - -- Empty Arguments - - Last_Argument := 0; - - -- Process this project individually, project data are already known - - Project_Tree.Projects.Table (Project).Seen := True; - - Add (Data.Source_Dirs); - - Recursive_Get_Dirs (Data.Extends); - - while Imported_Projects /= Empty_Project_List loop - Recursive_Get_Dirs - (Project_Tree.Project_Lists.Table - (Imported_Projects).Project); - Imported_Projects := Project_Tree.Project_Lists.Table - (Imported_Projects).Next; - end loop; - - Data.Imported_Directories_Switches := - new Argument_List'(Arguments (1 .. Last_Argument)); - - -- Create the Include_Path, from the Arguments - - Data.Include_Path := new String (1 .. Path_Length); - Data.Include_Path (1 .. Arguments (1)'Length - 2) := - Arguments (1)(Arguments (1)'First + 2 .. Arguments (1)'Last); - Position := Arguments (1)'Length - 2; - - for Arg in 2 .. Last_Argument loop - Position := Position + 1; - Data.Include_Path (Position) := Path_Separator; - Data.Include_Path - (Position + 1 .. Position + Arguments (Arg)'Length - 2) := - Arguments (Arg)(Arguments (Arg)'First + 2 .. Arguments (Arg)'Last); - Position := Position + Arguments (Arg)'Length - 2; - end loop; - - Last_Argument := 0; - end Get_Imported_Directories; - - ------------- - -- Gprmake -- - ------------- - - procedure Gprmake is - begin - Makegpr.Initialize; - - if Verbose_Mode then - Write_Eol; - Write_Str ("Parsing project file """); - Write_Str (Project_File_Name.all); - Write_Str ("""."); - Write_Eol; - end if; - - -- Parse and process project files for other languages (not for Ada) - - Prj.Pars.Parse - (Project => Main_Project, - In_Tree => Project_Tree, - Project_File_Name => Project_File_Name.all, - Packages_To_Check => Packages_To_Check); - - -- Fail if parsing/processing was unsuccessful - - if Main_Project = No_Project then - Osint.Fail ("""", Project_File_Name.all, """ processing failed"); - end if; - - if Verbose_Mode then - Write_Eol; - Write_Str ("Parsing of project file """); - Write_Str (Project_File_Name.all); - Write_Str (""" is finished."); - Write_Eol; - end if; - - -- If -f was specified, we will certainly need to link (except when - -- -u or -c were specified, of course). - - Need_To_Relink := Force_Compilations; - - if Unique_Compile then - if Mains.Number_Of_Mains = 0 then - Osint.Fail - ("No source specified to compile in 'unique compile' mode"); - else - Compile_Individual_Sources; - Report_Total_Errors ("compilation"); - end if; - - else - declare - Data : constant Prj.Project_Data := - Project_Tree.Projects.Table (Main_Project); - begin - if Data.Library and then Mains.Number_Of_Mains /= 0 then - Osint.Fail - ("Cannot specify mains on the command line " & - "for a Library Project"); - end if; - - -- First check for C++, to link libraries with g++, - -- rather than gcc. - - Check_For_C_Plus_Plus; - - -- Compile sources and build archives for library project, - -- if necessary. - - Compile_Sources; - - -- When Keep_Going is True, if we had some errors, fail now, - -- reporting the number of compilation errors. - -- Do not attempt to link. - - Report_Total_Errors ("compilation"); - - -- If -c was not specified, link the executables, - -- if there are any. - - if not Compile_Only - and then not Data.Library - and then Data.Object_Directory /= No_Path - then - Build_Global_Archive; - Link_Executables; - end if; - - -- When Keep_Going is True, if we had some errors, fail, reporting - -- the number of linking errors. - - Report_Total_Errors ("linking"); - end; - end if; - end Gprmake; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - Set_Mode (Ada_Only); - - -- Do some necessary package initializations - - Csets.Initialize; - Namet.Initialize; - Snames.Initialize; - Prj.Initialize (Project_Tree); - Mains.Delete; - - -- Add the directory where gprmake is invoked in front of the path, - -- if gprmake is invoked from a bin directory or with directory - -- information. information. Only do this if the platform is not VMS, - -- where the notion of path does not really exist. - - -- Below code shares nasty code duplication with make.adb code??? - - if not OpenVMS then - declare - Prefix : constant String := Executable_Prefix_Path; - Command : constant String := Command_Name; - - begin - if Prefix'Length > 0 then - declare - PATH : constant String := - Prefix & Directory_Separator & "bin" & - Path_Separator & - Getenv ("PATH").all; - begin - Setenv ("PATH", PATH); - end; - - else - for Index in reverse Command'Range loop - if Command (Index) = Directory_Separator then - declare - Absolute_Dir : constant String := - Normalize_Pathname - (Command (Command'First .. Index)); - PATH : constant String := - Absolute_Dir & - Path_Separator & - Getenv ("PATH").all; - begin - Setenv ("PATH", PATH); - end; - - exit; - end if; - end loop; - end if; - end; - end if; - - -- Set Name_Ide and Name_Compiler_Command - - Name_Len := 0; - Add_Str_To_Name_Buffer ("ide"); - Name_Ide := Name_Find; - - Name_Len := 0; - Add_Str_To_Name_Buffer ("compiler_command"); - Name_Compiler_Command := Name_Find; - - -- Make sure the Saved_Switches table is empty - - Saved_Switches.Set_Last (0); - - -- Get the command line arguments - - Scan_Args : for Next_Arg in 1 .. Argument_Count loop - Scan_Arg (Argument (Next_Arg)); - end loop Scan_Args; - - -- Fail if command line ended with "-P" - - if Project_File_Name_Expected then - Osint.Fail ("project file name missing after -P"); - - -- Or if it ended with "-o" - - elsif Output_File_Name_Expected then - Osint.Fail ("output file name missing after -o"); - end if; - - -- If no project file was specified, display the usage and fail - - if Project_File_Name = null then - Usage; - Exit_Program (E_Success); - end if; - - -- To be able of finding libgnat.a in MLib.Tgt, we need to have the - -- default search dirs established in Osint. - - Osint.Add_Default_Search_Dirs; - end Initialize; - - ----------------------------------- - -- Is_Included_In_Global_Archive -- - ----------------------------------- - - function Is_Included_In_Global_Archive - (Object_Name : File_Name_Type; - Project : Project_Id) return Boolean - is - Data : Project_Data := Project_Tree.Projects.Table (Project); - Source : Other_Source_Id; - - begin - while Data.Extended_By /= No_Project loop - Data := Project_Tree.Projects.Table (Data.Extended_By); - - Source := Data.First_Other_Source; - while Source /= No_Other_Source loop - if Project_Tree.Other_Sources.Table (Source).Object_Name = - Object_Name - then - return False; - else - Source := - Project_Tree.Other_Sources.Table (Source).Next; - end if; - end loop; - end loop; - - return True; - end Is_Included_In_Global_Archive; - - ---------------------- - -- Link_Executables -- - ---------------------- - - procedure Link_Executables is - Data : constant Project_Data := - Project_Tree.Projects.Table (Main_Project); - - Mains_Specified : constant Boolean := Mains.Number_Of_Mains /= 0; - -- True if main sources were specified on the command line - - Object_Dir : constant String := - Get_Name_String (Data.Display_Object_Dir); - -- Path of the object directory of the main project - - Source_Id : Other_Source_Id; - Source : Other_Source; - Success : Boolean; - - Linker_Name : String_Access; - Linker_Path : String_Access; - -- The linker name and path, when linking is not done by gnatlink - - Link_Done : Boolean := False; - -- Set to True when the linker is invoked directly (not through - -- gnatmake) to be able to report if mains were up to date at the end - -- of execution. - - procedure Add_C_Plus_Plus_Link_For_Gnatmake; - -- Add the --LINK= switch for gnatlink, depending on the C++ compiler - - procedure Check_Time_Stamps (Exec_Time_Stamp : Time_Stamp_Type); - -- Check if there is an archive that is more recent than the executable - -- to decide if we need to relink. - - procedure Choose_C_Plus_Plus_Link_Process; - -- If the C++ compiler is not g++, create the correct script to link - - procedure Link_Foreign - (Main : String; - Main_Id : File_Name_Type; - Source : Other_Source); - -- Link a non-Ada main, when there is no Ada code - - --------------------------------------- - -- Add_C_Plus_Plus_Link_For_Gnatmake -- - --------------------------------------- - - procedure Add_C_Plus_Plus_Link_For_Gnatmake is - begin - Add_Argument - ("--LINK=" & Compiler_Names (C_Plus_Plus_Language_Index).all, - Verbose_Mode); - end Add_C_Plus_Plus_Link_For_Gnatmake; - - ----------------------- - -- Check_Time_Stamps -- - ----------------------- - - procedure Check_Time_Stamps (Exec_Time_Stamp : Time_Stamp_Type) is - Prj_Data : Project_Data; - - begin - for Prj in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Prj_Data := Project_Tree.Projects.Table (Prj); - - -- There is an archive only in project - -- files with sources other than Ada - -- sources. - - if Data.Other_Sources_Present then - declare - Archive_Path : constant String := Get_Name_String - (Prj_Data.Display_Object_Dir) & Directory_Separator - & "lib" & Get_Name_String (Prj_Data.Display_Name) - & '.' & Archive_Ext; - Archive_TS : Time_Stamp_Type; - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Archive_Path); - Archive_TS := File_Stamp (File_Name_Type'(Name_Find)); - - -- If the archive is later than the - -- executable, we need to relink. - - if Archive_TS /= Empty_Time_Stamp - and then - Exec_Time_Stamp < Archive_TS - then - Need_To_Relink := True; - - if Verbose_Mode then - Write_Str (" -> "); - Write_Str (Archive_Path); - Write_Str (" has time stamp "); - Write_Str ("later than "); - Write_Line ("executable"); - end if; - - exit; - end if; - end; - end if; - end loop; - end Check_Time_Stamps; - - ------------------------------------- - -- Choose_C_Plus_Plus_Link_Process -- - ------------------------------------- - - procedure Choose_C_Plus_Plus_Link_Process is - begin - if Compiler_Names (C_Plus_Plus_Language_Index) = null then - Get_Compiler (C_Plus_Plus_Language_Index); - end if; - end Choose_C_Plus_Plus_Link_Process; - - ------------------ - -- Link_Foreign -- - ------------------ - - procedure Link_Foreign - (Main : String; - Main_Id : File_Name_Type; - Source : Other_Source) - is - Executable_Name : constant String := - Get_Name_String - (Executable_Of - (Project => Main_Project, - In_Tree => Project_Tree, - Main => Main_Id, - Index => 0, - Ada_Main => False)); - -- File name of the executable - - Executable_Path : constant String := - Get_Name_String - (Data.Display_Exec_Dir) & - Directory_Separator & Executable_Name; - -- Path name of the executable - - Exec_Time_Stamp : Time_Stamp_Type; - - begin - -- Now, check if the executable is up to date. It is considered - -- up to date if its time stamp is not earlier that the time stamp - -- of any archive. Only do that if we don't know if we need to link. - - if not Need_To_Relink then - - -- Get the time stamp of the executable - - Name_Len := 0; - Add_Str_To_Name_Buffer (Executable_Path); - Exec_Time_Stamp := File_Stamp (File_Name_Type'(Name_Find)); - - if Verbose_Mode then - Write_Str (" Checking executable "); - Write_Line (Executable_Name); - end if; - - -- If executable does not exist, we need to link - - if Exec_Time_Stamp = Empty_Time_Stamp then - Need_To_Relink := True; - - if Verbose_Mode then - Write_Line (" -> not found"); - end if; - - -- Otherwise, get the time stamps of each archive. If one of - -- them is found later than the executable, we need to relink. - - else - Check_Time_Stamps (Exec_Time_Stamp); - end if; - - -- If Need_To_Relink is False, we are done - - if Verbose_Mode and (not Need_To_Relink) then - Write_Line (" -> up to date"); - end if; - end if; - - -- Prepare to link - - if Need_To_Relink then - Link_Done := True; - - Last_Argument := 0; - - -- Specify the executable path name - - Add_Argument (Dash_o, True); - Add_Argument - (Get_Name_String (Data.Display_Exec_Dir) & - Directory_Separator & - Get_Name_String - (Executable_Of - (Project => Main_Project, - In_Tree => Project_Tree, - Main => Main_Id, - Index => 0, - Ada_Main => False)), - True); - - -- Specify the object file of the main source - - Add_Argument - (Object_Dir & Directory_Separator & - Get_Name_String (Source.Object_Name), - True); - - -- Add all the archives, in a correct order - - Add_Archives (For_Gnatmake => False); - - -- Add the switches specified in package Linker of - -- the main project. - - Add_Switches - (Data => Data, - Proc => Linker, - Language => Source.Language, - File_Name => Main_Id); - - -- Add the switches specified in attribute - -- Linker_Options of packages Linker. - - if Link_Options_Switches = null then - Link_Options_Switches := - new Argument_List' - (Linker_Options_Switches (Main_Project, Project_Tree)); - end if; - - Add_Arguments (Link_Options_Switches.all, True); - - -- Add the linking options specified on the - -- command line. - - for Arg in 1 .. Linker_Options.Last loop - Add_Argument (Linker_Options.Table (Arg), True); - end loop; - - -- If there are shared libraries and the run path - -- option is supported, add the run path switch. - - if Lib_Path.Last > 0 then - Add_Argument - (Path_Option.all & - String (Lib_Path.Table (1 .. Lib_Path.Last)), - Verbose_Mode); - end if; - - -- And invoke the linker - - Display_Command (Linker_Name.all, Linker_Path); - Spawn - (Linker_Path.all, - Arguments (1 .. Last_Argument), - Success); - - if not Success then - Report_Error ("could not link ", Main); - end if; - end if; - end Link_Foreign; - - -- Start of processing of Link_Executables - - begin - -- If no mains specified, get mains from attribute Main, if it exists - - if not Mains_Specified then - declare - Element_Id : String_List_Id; - Element : String_Element; - - begin - Element_Id := Data.Mains; - while Element_Id /= Nil_String loop - Element := Project_Tree.String_Elements.Table (Element_Id); - - if Element.Value /= No_Name then - Mains.Add_Main (Get_Name_String (Element.Value)); - end if; - - Element_Id := Element.Next; - end loop; - end; - end if; - - if Mains.Number_Of_Mains = 0 then - - -- If the attribute Main is an empty list or not specified, - -- there is nothing to do. - - if Verbose_Mode then - Write_Line ("No main to link"); - end if; - return; - end if; - - -- Check if -o was used for several mains - - if Output_File_Name /= null and then Mains.Number_Of_Mains > 1 then - Osint.Fail ("cannot specify an executable name for several mains"); - end if; - - -- Check how we are going to do the link - - if not Data.Other_Sources_Present then - - -- Only Ada sources in the main project, and even maybe not - - if Data.Extends = No_Project and then - not Data.Langs (Ada_Language_Index) - then - -- Fail if the main project has no source of any language - - Osint.Fail - ("project """, - Get_Name_String (Data.Name), - """ has no sources, so no main can be linked"); - - else - -- Only Ada sources in the main project, call gnatmake directly - - Last_Argument := 0; - - -- Choose correct linker if there is C++ code in other projects - - if C_Plus_Plus_Is_Used then - Choose_C_Plus_Plus_Link_Process; - Add_Argument (Dash_largs, Verbose_Mode); - Add_C_Plus_Plus_Link_For_Gnatmake; - Add_Argument (Dash_margs, Verbose_Mode); - end if; - - Compile_Link_With_Gnatmake (Mains_Specified); - end if; - - else - -- There are other language sources. First check if there are also - -- sources in Ada. - - if Data.Langs (Ada_Language_Index) then - - -- There is a mix of Ada and other language sources in the main - -- project. Any main that is not a source of the other languages - -- will be deemed to be an Ada main. - - -- Find the mains of the other languages and the Ada mains - - Mains.Reset; - Ada_Mains.Set_Last (0); - Other_Mains.Set_Last (0); - - -- For each main - - loop - declare - Main : constant String := Mains.Next_Main; - Main_Id : File_Name_Type; - - begin - exit when Main'Length = 0; - - -- Get the main file name - - Name_Len := 0; - Add_Str_To_Name_Buffer (Main); - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Main_Id := Name_Find; - - -- Check if it is a source of a language other than Ada - - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := - Project_Tree.Other_Sources.Table (Source_Id); - exit when Source.File_Name = Main_Id; - Source_Id := Source.Next; - end loop; - - -- If it is not, put it in the list of Ada mains - - if Source_Id = No_Other_Source then - Ada_Mains.Increment_Last; - Ada_Mains.Table (Ada_Mains.Last) := new String'(Main); - - -- Otherwise, put it in the list of other mains - - else - Other_Mains.Increment_Last; - Other_Mains.Table (Other_Mains.Last) := Source; - end if; - end; - end loop; - - -- If C++ is one of the other language, create the shell script - -- to do the link. - - if C_Plus_Plus_Is_Used then - Choose_C_Plus_Plus_Link_Process; - end if; - - -- Call gnatmake with the necessary switches for each non-Ada - -- main, if there are some. - - for Main in 1 .. Other_Mains.Last loop - declare - Source : constant Other_Source := Other_Mains.Table (Main); - - begin - Last_Argument := 0; - - -- Add -o if -o was specified - - if Output_File_Name = null then - Add_Argument (Dash_o, True); - Add_Argument - (Get_Name_String - (Executable_Of - (Project => Main_Project, - In_Tree => Project_Tree, - Main => Other_Mains.Table (Main).File_Name, - Index => 0, - Ada_Main => False)), - True); - end if; - - -- Call gnatmake with the -B switch - - Add_Argument (Dash_B, True); - - -- Add to the linking options the object file of the source - - Add_Argument (Dash_largs, Verbose_Mode); - Add_Argument - (Get_Name_String (Source.Object_Name), Verbose_Mode); - - -- If C++ is one of the language, add the --LINK switch - -- to the linking switches. - - if C_Plus_Plus_Is_Used then - Add_C_Plus_Plus_Link_For_Gnatmake; - end if; - - -- Add -margs so that the following switches are for - -- gnatmake - - Add_Argument (Dash_margs, Verbose_Mode); - - -- And link with gnatmake - - Compile_Link_With_Gnatmake (Mains_Specified => False); - end; - end loop; - - -- If there are also Ada mains, call gnatmake for all these mains - - if Ada_Mains.Last /= 0 then - Last_Argument := 0; - - -- Put all the Ada mains as the first arguments - - for Main in 1 .. Ada_Mains.Last loop - Add_Argument (Ada_Mains.Table (Main).all, True); - end loop; - - -- If C++ is one of the languages, add the --LINK switch to - -- the linking switches. - - if Data.Langs (C_Plus_Plus_Language_Index) then - Add_Argument (Dash_largs, Verbose_Mode); - Add_C_Plus_Plus_Link_For_Gnatmake; - Add_Argument (Dash_margs, Verbose_Mode); - end if; - - -- And link with gnatmake - - Compile_Link_With_Gnatmake (Mains_Specified => False); - end if; - - else - -- No Ada source in main project - - -- First, get the linker to invoke - - if Data.Langs (C_Plus_Plus_Language_Index) then - Get_Compiler (C_Plus_Plus_Language_Index); - Linker_Name := Compiler_Names (C_Plus_Plus_Language_Index); - Linker_Path := Compiler_Paths (C_Plus_Plus_Language_Index); - - else - Get_Compiler (C_Language_Index); - Linker_Name := Compiler_Names (C_Language_Index); - Linker_Path := Compiler_Paths (C_Language_Index); - end if; - - Link_Done := False; - - Mains.Reset; - - -- Get each main, check if it is a source of the main project, - -- and if it is, invoke the linker. - - loop - declare - Main : constant String := Mains.Next_Main; - Main_Id : File_Name_Type; - - begin - exit when Main'Length = 0; - - -- Get the file name of the main - - Name_Len := 0; - Add_Str_To_Name_Buffer (Main); - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Main_Id := Name_Find; - - -- Check if it is a source of the main project file - - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := - Project_Tree.Other_Sources.Table (Source_Id); - exit when Source.File_Name = Main_Id; - Source_Id := Source.Next; - end loop; - - -- Report an error if it is not - - if Source_Id = No_Other_Source then - Report_Error - (Main, "is not a source of project ", - Get_Name_String (Data.Name)); - - else - Link_Foreign (Main, Main_Id, Source); - end if; - end; - end loop; - - -- If no linking was done, report it, except in Quiet Output - - if (Verbose_Mode or (not Quiet_Output)) and (not Link_Done) then - Osint.Write_Program_Name; - - if Mains.Number_Of_Mains = 1 then - - -- If there is only one executable, report its name too - - Write_Str (": """); - Mains.Reset; - - declare - Main : constant String := Mains.Next_Main; - Main_Id : File_Name_Type; - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Main); - Main_Id := Name_Find; - Write_Str - (Get_Name_String - (Executable_Of - (Project => Main_Project, - In_Tree => Project_Tree, - Main => Main_Id, - Index => 0, - Ada_Main => False))); - Write_Line (""" up to date"); - end; - - else - Write_Line (": all executables up to date"); - end if; - end if; - end if; - end if; - end Link_Executables; - - ------------------ - -- Report_Error -- - ------------------ - - procedure Report_Error - (S1 : String; - S2 : String := ""; - S3 : String := "") - is - begin - -- If Keep_Going is True, output error message preceded by error header - - if Keep_Going then - Total_Number_Of_Errors := Total_Number_Of_Errors + 1; - Write_Str (Error_Header); - Write_Str (S1); - Write_Str (S2); - Write_Str (S3); - Write_Eol; - - -- Otherwise just fail - - else - Osint.Fail (S1, S2, S3); - end if; - end Report_Error; - - ------------------------- - -- Report_Total_Errors -- - ------------------------- - - procedure Report_Total_Errors (Kind : String) is - begin - if Total_Number_Of_Errors /= 0 then - if Total_Number_Of_Errors = 1 then - Osint.Fail - ("One ", Kind, " error"); - - else - Osint.Fail - ("Total of" & Total_Number_Of_Errors'Img, - ' ' & Kind & " errors"); - end if; - end if; - end Report_Total_Errors; - - -------------- - -- Scan_Arg -- - -------------- - - procedure Scan_Arg (Arg : String) is - begin - pragma Assert (Arg'First = 1); - - if Arg'Length = 0 then - return; - end if; - - -- If preceding switch was -P, a project file name need to be - -- specified, not a switch. - - if Project_File_Name_Expected then - if Arg (1) = '-' then - Osint.Fail ("project file name missing after -P"); - else - Project_File_Name_Expected := False; - Project_File_Name := new String'(Arg); - end if; - - -- If preceding switch was -o, an executable name need to be - -- specified, not a switch. - - elsif Output_File_Name_Expected then - if Arg (1) = '-' then - Osint.Fail ("output file name missing after -o"); - else - Output_File_Name_Expected := False; - Output_File_Name := new String'(Arg); - end if; - - -- Set the processor/language for the following switches - - -- -cargs: Ada compiler arguments - - elsif Arg = "-cargs" then - Current_Language := Ada_Language_Index; - Current_Processor := Compiler; - - elsif Arg'Length > 7 and then Arg (1 .. 7) = "-cargs:" then - Name_Len := 0; - Add_Str_To_Name_Buffer (Arg (8 .. Arg'Last)); - To_Lower (Name_Buffer (1 .. Name_Len)); - - declare - Lang : constant Name_Id := Name_Find; - begin - Current_Language := Language_Indexes.Get (Lang); - - if Current_Language = No_Language_Index then - Add_Language_Name (Lang); - Current_Language := Last_Language_Index; - end if; - - Current_Processor := Compiler; - end; - - elsif Arg = "-largs" then - Current_Processor := Linker; - - -- -gargs: gprmake - - elsif Arg = "-gargs" then - Current_Processor := None; - - -- A special test is needed for the -o switch within a -largs since - -- that is another way to specify the name of the final executable. - - elsif Current_Processor = Linker and then Arg = "-o" then - Osint.Fail - ("switch -o not allowed within a -largs. Use -o directly."); - - -- If current processor is not gprmake directly, store the option in - -- the appropriate table. - - elsif Current_Processor /= None then - Add_Option (Arg); - - -- Switches start with '-' - - elsif Arg (1) = '-' then - if Arg'Length > 3 and then Arg (1 .. 3) = "-aP" then - Add_Search_Project_Directory (Arg (4 .. Arg'Last)); - - -- Record the switch, so that it is passed to gnatmake, if - -- gnatmake is called. - - Saved_Switches.Append (new String'(Arg)); - - elsif Arg = "-c" then - Compile_Only := True; - - -- Make sure that when a main is specified and switch -c is used, - -- only the main(s) is/are compiled. - - if Mains.Number_Of_Mains > 0 then - Unique_Compile := True; - end if; - - elsif Arg = "-d" then - Display_Compilation_Progress := True; - - elsif Arg = "-f" then - Force_Compilations := True; - - elsif Arg = "-h" then - Usage; - - elsif Arg = "-k" then - Keep_Going := True; - - elsif Arg = "-o" then - if Output_File_Name /= null then - Osint.Fail ("cannot specify several -o switches"); - - else - Output_File_Name_Expected := True; - end if; - - elsif Arg'Length >= 2 and then Arg (2) = 'P' then - if Project_File_Name /= null then - Osint.Fail ("cannot have several project files specified"); - - elsif Arg'Length = 2 then - Project_File_Name_Expected := True; - - else - Project_File_Name := new String'(Arg (3 .. Arg'Last)); - end if; - - elsif Arg = "-p" or else Arg = "--create-missing-dirs" then - Setup_Projects := True; - - elsif Arg = "-q" then - Quiet_Output := True; - - elsif Arg = "-u" then - Unique_Compile := True; - Compile_Only := True; - - elsif Arg = "-v" then - Verbose_Mode := True; - Copyright; - - elsif Arg'Length = 4 and then Arg (1 .. 3) = "-vP" - and then Arg (4) in '0' .. '2' - then - case Arg (4) is - when '0' => - Current_Verbosity := Prj.Default; - when '1' => - Current_Verbosity := Prj.Medium; - when '2' => - Current_Verbosity := Prj.High; - when others => - null; - end case; - - elsif Arg'Length >= 3 and then Arg (2) = 'X' - and then Is_External_Assignment (Arg) - then - -- Is_External_Assignment has side effects when it returns True - - -- Record the -X switch, so that it will be passed to gnatmake, - -- if gnatmake is called. - - Saved_Switches.Append (new String'(Arg)); - - else - Osint.Fail ("illegal option """, Arg, """"); - end if; - - else - -- Not a switch: must be a main - - Mains.Add_Main (Arg); - - -- Make sure that when a main is specified and switch -c is used, - -- only the main(s) is/are compiled. - - if Compile_Only then - Unique_Compile := True; - end if; - end if; - end Scan_Arg; - - ----------------- - -- Strip_CR_LF -- - ----------------- - - function Strip_CR_LF (Text : String) return String is - To : String (1 .. Text'Length); - Index_To : Natural := 0; - - begin - for Index in Text'Range loop - if (Text (Index) /= ASCII.CR) and then (Text (Index) /= ASCII.LF) then - Index_To := Index_To + 1; - To (Index_To) := Text (Index); - end if; - end loop; - - return To (1 .. Index_To); - end Strip_CR_LF; - - ----------- - -- Usage -- - ----------- - - procedure Usage is - begin - if not Usage_Output then - Usage_Output := True; - Copyright; - - Write_Str ("Usage: "); - Osint.Write_Program_Name; - Write_Str (" -P [opts] [name] {"); - Write_Str ("[-cargs:lang opts] "); - Write_Str ("[-largs opts] [-gargs opts]}"); - Write_Eol; - Write_Eol; - Write_Str (" name is zero or more file names"); - Write_Eol; - Write_Eol; - - -- GPRMAKE switches - - Write_Str ("gprmake switches:"); - Write_Eol; - - -- Line for -aP - - Write_Str (" -aPdir Add directory dir to project search path"); - Write_Eol; - - -- Line for -c - - Write_Str (" -c Compile only"); - Write_Eol; - - -- Line for -f - - Write_Str (" -f Force recompilations"); - Write_Eol; - - -- Line for -k - - Write_Str (" -k Keep going after compilation errors"); - Write_Eol; - - -- Line for -o - - Write_Str (" -o name Choose an alternate executable name"); - Write_Eol; - - -- Line for -p - - Write_Str (" -p Create missing obj, lib and exec dirs"); - Write_Eol; - - -- Line for -P - - Write_Str (" -Pproj Use GNAT Project File proj"); - Write_Eol; - - -- Line for -q - - Write_Str (" -q Be quiet/terse"); - Write_Eol; - - -- Line for -u - - Write_Str - (" -u Unique compilation. Only compile the given files"); - Write_Eol; - - -- Line for -v - - Write_Str (" -v Verbose output"); - Write_Eol; - - -- Line for -vPx - - Write_Str (" -vPx Specify verbosity when parsing Project Files"); - Write_Eol; - - -- Line for -X - - Write_Str (" -Xnm=val Specify an external reference for " & - "Project Files"); - Write_Eol; - Write_Eol; - - -- Line for -cargs - - Write_Line (" -cargs opts opts are passed to the Ada compiler"); - - -- Line for -cargs:lang - - Write_Line (" -cargs: opts"); - Write_Line (" opts are passed to the compiler " & - "for language < lang > "); - - -- Line for -largs - - Write_Str (" -largs opts opts are passed to the linker"); - Write_Eol; - - -- Line for -gargs - - Write_Str (" -gargs opts opts directly interpreted by gprmake"); - Write_Eol; - Write_Eol; - - end if; - end Usage; - - begin - Makeutl.Do_Fail := Report_Error'Access; - end Makegpr; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/makegpr.ads gcc-4.4.0/gcc/ada/makegpr.ads *** gcc-4.3.3/gcc/ada/makegpr.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/makegpr.ads Thu Jan 1 00:00:00 1970 *************** *** 1,34 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M A K E G P R -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2004-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- The following package implements the facilities to compile, bind and/or - -- link a set of Ada and non Ada sources, specified in Project Files. - - package Makegpr is - - procedure Gprmake; - -- The driver of gprmake - - end Makegpr; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/makeusg.adb gcc-4.4.0/gcc/ada/makeusg.adb *** gcc-4.3.3/gcc/ada/makeusg.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/makeusg.adb Tue Apr 8 06:48:54 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** begin *** 306,311 **** --- 306,316 ---- Write_Str (" --RTS=dir specify the default source and object search" & " path"); Write_Eol; + + -- Line for --subdirs= + + Write_Str (" --subdirs=dir real obj/lib/exec dirs are subdirs"); + Write_Eol; Write_Eol; -- General Compiler, Binder, Linker switches diff -Nrcpad gcc-4.3.3/gcc/ada/makeutl.adb gcc-4.4.0/gcc/ada/makeutl.adb *** gcc-4.3.3/gcc/ada/makeutl.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/makeutl.adb Thu Jul 31 14:41:22 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2008, 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- -- *************** *** 23,29 **** -- -- ------------------------------------------------------------------------------ ! with Ada.Command_Line; use Ada.Command_Line; with Osint; use Osint; with Output; use Output; with Prj.Ext; --- 23,29 ---- -- -- ------------------------------------------------------------------------------ ! with Debug; with Osint; use Osint; with Output; use Output; with Prj.Ext; *************** with Prj.Util; *** 31,36 **** --- 31,40 ---- with Snames; use Snames; with Table; + with Ada.Command_Line; use Ada.Command_Line; + + with GNAT.Directory_Operations; use GNAT.Directory_Operations; + with System.Case_Util; use System.Case_Util; with System.HTable; *************** package body Makeutl is *** 41,47 **** Index : Int; end record; -- Identify either a mono-unit source (when Index = 0) or a specific unit ! -- in a multi-unit source. -- There follow many global undocumented declarations, comments needed ??? --- 45,51 ---- Index : Int; end record; -- Identify either a mono-unit source (when Index = 0) or a specific unit ! -- (index = 1's origin index of unit) in a multi-unit source. -- There follow many global undocumented declarations, comments needed ??? *************** package body Makeutl is *** 191,197 **** Exec_Name : constant String := Command_Name; function Get_Install_Dir (S : String) return String; ! -- S is the executable name preceeded by the absolute or relative -- path, e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory -- where "bin" lies (in the example "C:\usr"). -- If the executable is not in a "bin" directory, return "". --- 195,201 ---- Exec_Name : constant String := Command_Name; function Get_Install_Dir (S : String) return String; ! -- S is the executable name preceded by the absolute or relative -- path, e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory -- where "bin" lies (in the example "C:\usr"). -- If the executable is not in a "bin" directory, return "". *************** package body Makeutl is *** 242,248 **** -- If we get here, the user has typed the executable name with no -- directory prefix. ! return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name).all); end Executable_Prefix_Path; ---------- --- 246,260 ---- -- If we get here, the user has typed the executable name with no -- directory prefix. ! declare ! Path : constant String_Access := Locate_Exec_On_Path (Exec_Name); ! begin ! if Path = null then ! return ""; ! else ! return Get_Install_Dir (Path.all); ! end if; ! end; end Executable_Prefix_Path; ---------- *************** package body Makeutl is *** 271,277 **** if N /= No_Name then Write_Str (""""); ! Write_Name (N); Write_Str (""" "); end if; --- 283,299 ---- if N /= No_Name then Write_Str (""""); ! ! declare ! Name : constant String := Get_Name_String (N); ! begin ! if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then ! Write_Str (File_Name (Name)); ! else ! Write_Str (Name); ! end if; ! end; ! Write_Str (""" "); end if; *************** package body Makeutl is *** 428,434 **** new String' (Get_Name_String (In_Tree.Projects.Table ! (Proj). Directory)); end if; while Options /= Nil_String loop --- 450,456 ---- new String' (Get_Name_String (In_Tree.Projects.Table ! (Proj).Directory.Name)); end if; while Options /= Nil_String loop *************** package body Makeutl is *** 467,474 **** package body Mains is package Names is new Table.Table ! (Table_Component_Type => File_Name_Type, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 10, --- 489,501 ---- package body Mains is + type File_And_Loc is record + File_Name : File_Name_Type; + Location : Source_Ptr := No_Location; + end record; + package Names is new Table.Table ! (Table_Component_Type => File_And_Loc, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 10, *************** package body Makeutl is *** 488,494 **** Name_Len := 0; Add_Str_To_Name_Buffer (Name); Names.Increment_Last; ! Names.Table (Names.Last) := Name_Find; end Add_Main; ------------ --- 515,521 ---- Name_Len := 0; Add_Str_To_Name_Buffer (Name); Names.Increment_Last; ! Names.Table (Names.Last) := (Name_Find, No_Location); end Add_Main; ------------ *************** package body Makeutl is *** 501,506 **** --- 528,546 ---- Mains.Reset; end Delete; + ------------------ + -- Get_Location -- + ------------------ + + function Get_Location return Source_Ptr is + begin + if Current in Names.First .. Names.Last then + return Names.Table (Current).Location; + else + return No_Location; + end if; + end Get_Location; + --------------- -- Next_Main -- --------------- *************** package body Makeutl is *** 509,518 **** begin if Current >= Names.Last then return ""; - else Current := Current + 1; ! return Get_Name_String (Names.Table (Current)); end if; end Next_Main; --- 549,557 ---- begin if Current >= Names.Last then return ""; else Current := Current + 1; ! return Get_Name_String (Names.Table (Current).File_Name); end if; end Next_Main; *************** package body Makeutl is *** 534,539 **** --- 573,601 ---- Current := 0; end Reset; + ------------------ + -- Set_Location -- + ------------------ + + procedure Set_Location (Location : Source_Ptr) is + begin + if Names.Last > 0 then + Names.Table (Names.Last).Location := Location; + end if; + end Set_Location; + + ----------------- + -- Update_Main -- + ----------------- + + procedure Update_Main (Name : String) is + begin + if Current in Names.First .. Names.Last then + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + Names.Table (Current).File_Name := Name_Find; + end if; + end Update_Main; end Mains; ---------- *************** package body Makeutl is *** 545,550 **** --- 607,626 ---- Marks.Set (K => (File => Source_File, Index => Index), E => True); end Mark; + ----------------------- + -- Path_Or_File_Name -- + ----------------------- + + function Path_Or_File_Name (Path : Path_Name_Type) return String is + Path_Name : constant String := Get_Name_String (Path); + begin + if Debug.Debug_Flag_F then + return File_Name (Path_Name); + else + return Path_Name; + end if; + end Path_Or_File_Name; + --------------------------- -- Test_If_Relative_Path -- --------------------------- *************** package body Makeutl is *** 657,663 **** Start := Start - 1; end loop; ! -- If there is no difits, or if the digits are not preceded by -- the character that precedes a unit index, this is not the ALI file -- of a unit in a multi-unit source. --- 733,739 ---- Start := Start - 1; end loop; ! -- If there are no digits, or if the digits are not preceded by -- the character that precedes a unit index, this is not the ALI file -- of a unit in a multi-unit source. diff -Nrcpad gcc-4.3.3/gcc/ada/makeutl.ads gcc-4.4.0/gcc/ada/makeutl.ads *** gcc-4.3.3/gcc/ada/makeutl.ads Wed Sep 26 10:45:15 2007 --- gcc-4.4.0/gcc/ada/makeutl.ads Tue May 27 09:20:48 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2008, 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- -- *************** package Makeutl is *** 103,108 **** --- 103,112 ---- procedure Add_Main (Name : String); -- Add one main to the table + procedure Set_Location (Location : Source_Ptr); + -- Set the location of the last main added. By default, the location is + -- No_Location. + procedure Delete; -- Empty the table *************** package Makeutl is *** 113,118 **** --- 117,128 ---- -- Increase the index and return the next main. -- If table is exhausted, return an empty string. + function Get_Location return Source_Ptr; + -- Get the location of the current main + + procedure Update_Main (Name : String); + -- Update the file name of the current main + function Number_Of_Mains return Natural; -- Returns the number of mains added with Add_Main since the last call -- to Delete. *************** package Makeutl is *** 130,135 **** --- 140,148 ---- -- For gnatbind switches, Including_L_Switch is False, because the -- argument of the -L switch is not a path. + function Path_Or_File_Name (Path : Path_Name_Type) return String; + -- Returns a file name if -df is used, otherwise return a path name + ---------------------- -- Marking Routines -- ---------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/math_lib.adb gcc-4.4.0/gcc/ada/math_lib.adb *** gcc-4.3.3/gcc/ada/math_lib.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/math_lib.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Math_Lib is *** 93,99 **** (Y : Real; A : Real := 1.0) return Real; ! -- Common code for arc tangent after cyele reduction function Log_Inverse_Epsilon return Real; -- Function to provide constant: Log (1.0 / Epsilon) --- 91,97 ---- (Y : Real; A : Real := 1.0) return Real; ! -- Common code for arc tangent after cycle reduction function Log_Inverse_Epsilon return Real; -- Function to provide constant: Log (1.0 / Epsilon) diff -Nrcpad gcc-4.3.3/gcc/ada/mdll-utl.adb gcc-4.4.0/gcc/ada/mdll-utl.adb *** gcc-4.3.3/gcc/ada/mdll-utl.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mdll-utl.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body MDLL.Utl is *** 51,57 **** procedure Print_Command (Tool_Name : String; Arguments : OS_Lib.Argument_List); ! -- display the command runned when in Verbose mode ------------------- -- Print_Command -- --- 51,57 ---- procedure Print_Command (Tool_Name : String; Arguments : OS_Lib.Argument_List); ! -- display the command run when in Verbose mode ------------------- -- Print_Command -- diff -Nrcpad gcc-4.3.3/gcc/ada/mdll.ads gcc-4.4.0/gcc/ada/mdll.ads *** gcc-4.3.3/gcc/ada/mdll.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mdll.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package MDLL is *** 40,46 **** new Argument_List (1 .. 0); Tools_Error : exception; ! -- Commment required Verbose : Boolean := False; Quiet : Boolean := False; --- 40,46 ---- new Argument_List (1 .. 0); Tools_Error : exception; ! -- Comment required Verbose : Boolean := False; Quiet : Boolean := False; diff -Nrcpad gcc-4.3.3/gcc/ada/memroot.adb gcc-4.4.0/gcc/ada/memroot.adb *** gcc-4.3.3/gcc/ada/memroot.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/memroot.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2008, AdaCore -- -- -- -- 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- -- *************** package body Memroot is *** 86,92 **** -- Returns an image for F containing the file name, the Line number, -- and if 'Short' is not true, the subprogram name. When possible, spaces -- are inserted between the line number and the subprogram name in order ! -- to align images of the same frame. Alignement is cimputed with Max_Fil -- & Max_Lin representing the max number of character in a filename or -- length in a given frame. --- 86,92 ---- -- Returns an image for F containing the file name, the Line number, -- and if 'Short' is not true, the subprogram name. When possible, spaces -- are inserted between the line number and the subprogram name in order ! -- to align images of the same frame. Alignment is computed with Max_Fil -- & Max_Lin representing the max number of character in a filename or -- length in a given frame. diff -Nrcpad gcc-4.3.3/gcc/ada/memroot.ads gcc-4.4.0/gcc/ada/memroot.ads *** gcc-4.3.3/gcc/ada/memroot.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/memroot.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2008, AdaCore -- -- -- -- 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- -- *************** package Memroot is *** 77,83 **** -- Create an allocation root from the frames that compose it function Frames_Of (B : Root_Id) return Frame_Array; ! -- Retreives the Frames of the root's backtrace procedure Print_BT (B : Root_Id; Short : Boolean := False); -- Prints on standard out the backtrace associated with the root B --- 77,83 ---- -- Create an allocation root from the frames that compose it function Frames_Of (B : Root_Id) return Frame_Array; ! -- Retrieves the Frames of the root's backtrace procedure Print_BT (B : Root_Id; Short : Boolean := False); -- Prints on standard out the backtrace associated with the root B diff -Nrcpad gcc-4.3.3/gcc/ada/memtrack.adb gcc-4.4.0/gcc/ada/memtrack.adb *** gcc-4.3.3/gcc/ada/memtrack.adb Wed Jun 6 10:30:04 2007 --- gcc-4.4.0/gcc/ada/memtrack.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/mingw32.h gcc-4.4.0/gcc/ada/mingw32.h *** gcc-4.3.3/gcc/ada/mingw32.h Thu Dec 13 10:19:55 2007 --- gcc-4.4.0/gcc/ada/mingw32.h Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Header File * * * ! * Copyright (C) 2002-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Header File * * * ! * Copyright (C) 2002-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** *** 93,102 **** version instead of the previous enhanced version to ease building GNAT on Windows platforms. By using STD_MINGW or OLD_MINGW it is possible to build GNAT using both MingW include files (Old MingW + ACT changes and standard ! MingW starting with version 1.3. */ #define STD_MINGW ((__MINGW32_MAJOR_VERSION == 1 \ && __MINGW32_MINOR_VERSION >= 3) \ || (__MINGW32_MAJOR_VERSION >= 2)) #define OLD_MINGW (!(STD_MINGW)) --- 92,107 ---- version instead of the previous enhanced version to ease building GNAT on Windows platforms. By using STD_MINGW or OLD_MINGW it is possible to build GNAT using both MingW include files (Old MingW + ACT changes and standard ! MingW starting with version 1.3. ! For w64 Mingw the define STD_MINGW is always set to value 1, because ! there is no old header set present. */ ! #ifdef _WIN64 ! #define STD_MINGW 1 ! #else #define STD_MINGW ((__MINGW32_MAJOR_VERSION == 1 \ && __MINGW32_MINOR_VERSION >= 3) \ || (__MINGW32_MAJOR_VERSION >= 2)) + #endif #define OLD_MINGW (!(STD_MINGW)) diff -Nrcpad gcc-4.3.3/gcc/ada/misc.c gcc-4.4.0/gcc/ada/misc.c *** gcc-4.3.3/gcc/ada/misc.c Mon Nov 19 17:49:11 2007 --- gcc-4.4.0/gcc/ada/misc.c Thu Jan 1 00:00:00 1970 *************** *** 1,898 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * M I S C * - * * - * C Implementation File * - * * - * Copyright (C) 1992-2007, 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- * - * ware Foundation; either version 2, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License distributed with GNAT; see file COPYING. If not, write * - * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * - * Boston, MA 02110-1301, USA. * - * * - * As a special exception, if you link this file with other files to * - * produce an executable, this file does not by itself cause the resulting * - * executable to be covered by the GNU General Public License. This except- * - * ion does not however invalidate any other reasons why the executable * - * file might be covered by the GNU Public License. * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - /* This file contains parts of the compiler that are required for interfacing - with GCC but otherwise do nothing and parts of Gigi that need to know - about RTL. */ - - #include "config.h" - #include "system.h" - #include "coretypes.h" - #include "tm.h" - #include "tree.h" - #include "real.h" - #include "rtl.h" - #include "diagnostic.h" - #include "expr.h" - #include "libfuncs.h" - #include "ggc.h" - #include "flags.h" - #include "debug.h" - #include "cgraph.h" - #include "tree-inline.h" - #include "insn-codes.h" - #include "insn-flags.h" - #include "insn-config.h" - #include "optabs.h" - #include "recog.h" - #include "toplev.h" - #include "output.h" - #include "except.h" - #include "tm_p.h" - #include "langhooks.h" - #include "langhooks-def.h" - #include "target.h" - - #include "ada.h" - #include "types.h" - #include "atree.h" - #include "elists.h" - #include "namet.h" - #include "nlists.h" - #include "stringt.h" - #include "uintp.h" - #include "fe.h" - #include "sinfo.h" - #include "einfo.h" - #include "ada-tree.h" - #include "gigi.h" - #include "adadecode.h" - #include "opts.h" - #include "options.h" - - extern FILE *asm_out_file; - - /* The largest alignment, in bits, that is needed for using the widest - move instruction. */ - unsigned int largest_move_alignment; - - static bool gnat_init (void); - static void gnat_finish_incomplete_decl (tree); - static unsigned int gnat_init_options (unsigned int, const char **); - static int gnat_handle_option (size_t, const char *, int); - static bool gnat_post_options (const char **); - static alias_set_type gnat_get_alias_set (tree); - static void gnat_print_decl (FILE *, tree, int); - static void gnat_print_type (FILE *, tree, int); - static const char *gnat_printable_name (tree, int); - static const char *gnat_dwarf_name (tree, int); - static tree gnat_return_tree (tree); - static int gnat_eh_type_covers (tree, tree); - static void gnat_parse_file (int); - static rtx gnat_expand_expr (tree, rtx, enum machine_mode, int, - rtx *); - static void internal_error_function (const char *, va_list *); - static tree gnat_type_max_size (const_tree); - - /* Definitions for our language-specific hooks. */ - - #undef LANG_HOOKS_NAME - #define LANG_HOOKS_NAME "GNU Ada" - #undef LANG_HOOKS_IDENTIFIER_SIZE - #define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier) - #undef LANG_HOOKS_INIT - #define LANG_HOOKS_INIT gnat_init - #undef LANG_HOOKS_INIT_OPTIONS - #define LANG_HOOKS_INIT_OPTIONS gnat_init_options - #undef LANG_HOOKS_HANDLE_OPTION - #define LANG_HOOKS_HANDLE_OPTION gnat_handle_option - #undef LANG_HOOKS_POST_OPTIONS - #define LANG_HOOKS_POST_OPTIONS gnat_post_options - #undef LANG_HOOKS_PARSE_FILE - #define LANG_HOOKS_PARSE_FILE gnat_parse_file - #undef LANG_HOOKS_HASH_TYPES - #define LANG_HOOKS_HASH_TYPES false - #undef LANG_HOOKS_GETDECLS - #define LANG_HOOKS_GETDECLS lhd_return_null_tree_v - #undef LANG_HOOKS_PUSHDECL - #define LANG_HOOKS_PUSHDECL gnat_return_tree - #undef LANG_HOOKS_WRITE_GLOBALS - #define LANG_HOOKS_WRITE_GLOBALS gnat_write_global_declarations - #undef LANG_HOOKS_FINISH_INCOMPLETE_DECL - #define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl - #undef LANG_HOOKS_REDUCE_BIT_FIELD_OPERATIONS - #define LANG_HOOKS_REDUCE_BIT_FIELD_OPERATIONS true - #undef LANG_HOOKS_GET_ALIAS_SET - #define LANG_HOOKS_GET_ALIAS_SET gnat_get_alias_set - #undef LANG_HOOKS_EXPAND_EXPR - #define LANG_HOOKS_EXPAND_EXPR gnat_expand_expr - #undef LANG_HOOKS_MARK_ADDRESSABLE - #define LANG_HOOKS_MARK_ADDRESSABLE gnat_mark_addressable - #undef LANG_HOOKS_PRINT_DECL - #define LANG_HOOKS_PRINT_DECL gnat_print_decl - #undef LANG_HOOKS_PRINT_TYPE - #define LANG_HOOKS_PRINT_TYPE gnat_print_type - #undef LANG_HOOKS_TYPE_MAX_SIZE - #define LANG_HOOKS_TYPE_MAX_SIZE gnat_type_max_size - #undef LANG_HOOKS_DECL_PRINTABLE_NAME - #define LANG_HOOKS_DECL_PRINTABLE_NAME gnat_printable_name - #undef LANG_HOOKS_DWARF_NAME - #define LANG_HOOKS_DWARF_NAME gnat_dwarf_name - #undef LANG_HOOKS_GIMPLIFY_EXPR - #define LANG_HOOKS_GIMPLIFY_EXPR gnat_gimplify_expr - #undef LANG_HOOKS_TYPE_FOR_MODE - #define LANG_HOOKS_TYPE_FOR_MODE gnat_type_for_mode - #undef LANG_HOOKS_TYPE_FOR_SIZE - #define LANG_HOOKS_TYPE_FOR_SIZE gnat_type_for_size - #undef LANG_HOOKS_ATTRIBUTE_TABLE - #define LANG_HOOKS_ATTRIBUTE_TABLE gnat_internal_attribute_table - #undef LANG_HOOKS_BUILTIN_FUNCTION - #define LANG_HOOKS_BUILTIN_FUNCTION gnat_builtin_function - - const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; - - /* Tables describing GCC tree codes used only by GNAT. - - Table indexed by tree code giving a string containing a character - classifying the tree code. Possibilities are - t, d, s, c, r, <, 1 and 2. See cp-tree.def for details. */ - - #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE, - - const enum tree_code_class tree_code_type[] = { - #include "tree.def" - tcc_exceptional, - #include "ada-tree.def" - }; - #undef DEFTREECODE - - /* Table indexed by tree code giving number of expression - operands beyond the fixed part of the node structure. - Not used for types or decls. */ - - #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH, - - const unsigned char tree_code_length[] = { - #include "tree.def" - 0, - #include "ada-tree.def" - }; - #undef DEFTREECODE - - /* Names of tree components. - Used for printing out the tree and error messages. */ - #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME, - - const char *const tree_code_name[] = { - #include "tree.def" - "@@dummy", - #include "ada-tree.def" - }; - #undef DEFTREECODE - - /* Command-line argc and argv. - These variables are global, since they are imported and used in - back_end.adb */ - - unsigned int save_argc; - const char **save_argv; - - /* gnat standard argc argv */ - - extern int gnat_argc; - extern char **gnat_argv; - - - /* Declare functions we use as part of startup. */ - extern void __gnat_initialize (void *); - extern void __gnat_install_SEH_handler (void *); - extern void adainit (void); - extern void _ada_gnat1drv (void); - - /* The parser for the language. For us, we process the GNAT tree. */ - - static void - gnat_parse_file (int set_yydebug ATTRIBUTE_UNUSED) - { - int seh[2]; - - /* Call the target specific initializations. */ - __gnat_initialize (NULL); - - /* ??? Call the SEH initialization routine. This is to workaround - a bootstrap path problem. The call below should be removed at some - point and the SEH pointer passed to __gnat_initialize() above. */ - __gnat_install_SEH_handler((void *)seh); - - /* Call the front-end elaboration procedures. */ - adainit (); - - /* Call the front end. */ - _ada_gnat1drv (); - - /* We always have a single compilation unit in Ada. */ - cgraph_finalize_compilation_unit (); - } - - /* Decode all the language specific options that cannot be decoded by GCC. - The option decoding phase of GCC calls this routine on the flags that - it cannot decode. This routine returns the number of consecutive arguments - from ARGV that it successfully decoded; 0 indicates failure. */ - - static int - gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED) - { - const struct cl_option *option = &cl_options[scode]; - enum opt_code code = (enum opt_code) scode; - char *q; - - if (arg == NULL && (option->flags & (CL_JOINED | CL_SEPARATE))) - { - error ("missing argument to \"-%s\"", option->opt_text); - return 1; - } - - switch (code) - { - case OPT_I: - q = xmalloc (sizeof("-I") + strlen (arg)); - strcpy (q, "-I"); - strcat (q, arg); - gnat_argv[gnat_argc] = q; - gnat_argc++; - break; - - /* All front ends are expected to accept this. */ - case OPT_Wall: - /* These are used in the GCC Makefile. */ - case OPT_Wmissing_prototypes: - case OPT_Wstrict_prototypes: - case OPT_Wwrite_strings: - case OPT_Wlong_long: - case OPT_Wvariadic_macros: - case OPT_Wold_style_definition: - case OPT_Wmissing_format_attribute: - case OPT_Woverlength_strings: - break; - - /* This is handled by the front-end. */ - case OPT_nostdinc: - break; - - case OPT_nostdlib: - gnat_argv[gnat_argc] = xstrdup ("-nostdlib"); - gnat_argc++; - break; - - case OPT_feliminate_unused_debug_types: - /* We arrange for post_option to be able to only set the corresponding - flag to 1 when explicitely requested by the user. We expect the - default flag value to be either 0 or positive, and expose a positive - -f as a negative value to post_option. */ - flag_eliminate_unused_debug_types = -value; - break; - - case OPT_fRTS_: - gnat_argv[gnat_argc] = xstrdup ("-fRTS"); - gnat_argc++; - break; - - case OPT_gant: - warning (0, "%<-gnat%> misspelled as %<-gant%>"); - - /* ... fall through ... */ - - case OPT_gnat: - /* Recopy the switches without the 'gnat' prefix. */ - gnat_argv[gnat_argc] = xmalloc (strlen (arg) + 2); - gnat_argv[gnat_argc][0] = '-'; - strcpy (gnat_argv[gnat_argc] + 1, arg); - gnat_argc++; - break; - - case OPT_gnatO: - gnat_argv[gnat_argc] = xstrdup ("-O"); - gnat_argc++; - gnat_argv[gnat_argc] = xstrdup (arg); - gnat_argc++; - break; - - default: - gcc_unreachable (); - } - - return 1; - } - - /* Initialize for option processing. */ - - static unsigned int - gnat_init_options (unsigned int argc, const char **argv) - { - /* Initialize gnat_argv with save_argv size. */ - gnat_argv = (char **) xmalloc ((argc + 1) * sizeof (argv[0])); - gnat_argv[0] = xstrdup (argv[0]); /* name of the command */ - gnat_argc = 1; - - save_argc = argc; - save_argv = argv; - - /* Uninitialized really means uninitialized in Ada. */ - flag_zero_initialized_in_bss = 0; - - return CL_Ada; - } - - /* Post-switch processing. */ - - bool - gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED) - { - flag_inline_trees = 1; - - if (!flag_no_inline) - flag_no_inline = 1; - if (flag_inline_functions) - flag_inline_trees = 2; - - /* Force eliminate_unused_debug_types to 0 unless an explicit positive - -f has been passed. This forces the default to 0 for Ada, which might - differ from the common default. */ - if (flag_eliminate_unused_debug_types < 0) - flag_eliminate_unused_debug_types = 1; - else - flag_eliminate_unused_debug_types = 0; - - return false; - } - - /* Here is the function to handle the compiler error processing in GCC. */ - - static void - internal_error_function (const char *msgid, va_list *ap) - { - text_info tinfo; - char *buffer, *p, *loc; - String_Template temp, temp_loc; - Fat_Pointer fp, fp_loc; - expanded_location s; - - /* Reset the pretty-printer. */ - pp_clear_output_area (global_dc->printer); - - /* Format the message into the pretty-printer. */ - tinfo.format_spec = msgid; - tinfo.args_ptr = ap; - tinfo.err_no = errno; - pp_format_verbatim (global_dc->printer, &tinfo); - - /* Extract a (writable) pointer to the formatted text. */ - buffer = (char*) pp_formatted_text (global_dc->printer); - - /* Go up to the first newline. */ - for (p = buffer; *p; p++) - if (*p == '\n') - { - *p = '\0'; - break; - } - - temp.Low_Bound = 1; - temp.High_Bound = p - buffer; - fp.Bounds = &temp; - fp.Array = buffer; - - s = expand_location (input_location); - #ifdef USE_MAPPED_LOCATION - if (flag_show_column && s.column != 0) - asprintf (&loc, "%s:%d:%d", s.file, s.line, s.column); - else - #endif - asprintf (&loc, "%s:%d", s.file, s.line); - temp_loc.Low_Bound = 1; - temp_loc.High_Bound = strlen (loc); - fp_loc.Bounds = &temp_loc; - fp_loc.Array = loc; - - Current_Error_Node = error_gnat_node; - Compiler_Abort (fp, -1, fp_loc); - } - - /* Perform all the initialization steps that are language-specific. */ - - static bool - gnat_init (void) - { - /* Performs whatever initialization steps needed by the language-dependent - lexical analyzer. */ - gnat_init_decl_processing (); - - /* Add the input filename as the last argument. */ - gnat_argv[gnat_argc] = (char *) main_input_filename; - gnat_argc++; - gnat_argv[gnat_argc] = 0; - - global_dc->internal_error = &internal_error_function; - - /* Show that REFERENCE_TYPEs are internal and should be Pmode. */ - internal_reference_types (); - - return true; - } - - /* This function is called indirectly from toplev.c to handle incomplete - declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise, - compile_file in toplev.c makes an indirect call through the function pointer - incomplete_decl_finalize_hook which is initialized to this routine in - init_decl_processing. */ - - static void - gnat_finish_incomplete_decl (tree dont_care ATTRIBUTE_UNUSED) - { - gcc_unreachable (); - } - - /* Compute the alignment of the largest mode that can be used for copying - objects. */ - - void - gnat_compute_largest_alignment (void) - { - enum machine_mode mode; - - for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); mode != VOIDmode; - mode = GET_MODE_WIDER_MODE (mode)) - if (optab_handler (mov_optab, mode)->insn_code != CODE_FOR_nothing) - largest_move_alignment = MIN (BIGGEST_ALIGNMENT, - MAX (largest_move_alignment, - GET_MODE_ALIGNMENT (mode))); - } - - /* If we are using the GCC mechanism to process exception handling, we - have to register the personality routine for Ada and to initialize - various language dependent hooks. */ - - void - gnat_init_gcc_eh (void) - { - #ifdef DWARF2_UNWIND_INFO - /* lang_dependent_init already called dwarf2out_frame_init if true. */ - int dwarf2out_frame_initialized = dwarf2out_do_frame (); - #endif - - /* We shouldn't do anything if the No_Exceptions_Handler pragma is set, - though. This could for instance lead to the emission of tables with - references to symbols (such as the Ada eh personality routine) within - libraries we won't link against. */ - if (No_Exception_Handlers_Set ()) - return; - - /* Tell GCC we are handling cleanup actions through exception propagation. - This opens possibilities that we don't take advantage of yet, but is - nonetheless necessary to ensure that fixup code gets assigned to the - right exception regions. */ - using_eh_for_cleanups (); - - eh_personality_libfunc = init_one_libfunc (USING_SJLJ_EXCEPTIONS - ? "__gnat_eh_personality_sj" - : "__gnat_eh_personality"); - lang_eh_type_covers = gnat_eh_type_covers; - lang_eh_runtime_type = gnat_return_tree; - default_init_unwind_resume_libfunc (); - - /* Turn on -fexceptions and -fnon-call-exceptions. The first one triggers - the generation of the necessary exception runtime tables. The second one - is useful for two reasons: 1/ we map some asynchronous signals like SEGV - to exceptions, so we need to ensure that the insns which can lead to such - signals are correctly attached to the exception region they pertain to, - 2/ Some calls to pure subprograms are handled as libcall blocks and then - marked as "cannot trap" if the flag is not set (see emit_libcall_block). - We should not let this be since it is possible for such calls to actually - raise in Ada. */ - - flag_exceptions = 1; - flag_non_call_exceptions = 1; - - init_eh (); - #ifdef DWARF2_UNWIND_INFO - if (!dwarf2out_frame_initialized && dwarf2out_do_frame ()) - dwarf2out_frame_init (); - #endif - } - - /* Language hooks, first one to print language-specific items in a DECL. */ - - static void - gnat_print_decl (FILE *file, tree node, int indent) - { - switch (TREE_CODE (node)) - { - case CONST_DECL: - print_node (file, "const_corresponding_var", - DECL_CONST_CORRESPONDING_VAR (node), indent + 4); - break; - - case FIELD_DECL: - print_node (file, "original_field", DECL_ORIGINAL_FIELD (node), - indent + 4); - break; - - case VAR_DECL: - print_node (file, "renamed_object", DECL_RENAMED_OBJECT (node), - indent + 4); - break; - - default: - break; - } - } - - static void - gnat_print_type (FILE *file, tree node, int indent) - { - switch (TREE_CODE (node)) - { - case FUNCTION_TYPE: - print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4); - break; - - case ENUMERAL_TYPE: - print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4); - break; - - case INTEGER_TYPE: - if (TYPE_MODULAR_P (node)) - print_node (file, "modulus", TYPE_MODULUS (node), indent + 4); - else if (TYPE_HAS_ACTUAL_BOUNDS_P (node)) - print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node), - indent + 4); - else if (TYPE_VAX_FLOATING_POINT_P (node)) - ; - else - print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4); - - print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4); - break; - - case ARRAY_TYPE: - print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4); - break; - - case RECORD_TYPE: - if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node)) - print_node (file, "unconstrained array", - TYPE_UNCONSTRAINED_ARRAY (node), indent + 4); - else - print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4); - break; - - case UNION_TYPE: - case QUAL_UNION_TYPE: - print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4); - break; - - default: - break; - } - } - - static const char * - gnat_printable_name (tree decl, int verbosity) - { - const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl)); - char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60); - - __gnat_decode (coded_name, ada_name, 0); - - if (verbosity == 2) - { - Set_Identifier_Casing (ada_name, (char *) DECL_SOURCE_FILE (decl)); - ada_name = Name_Buffer; - } - - return (const char *) ada_name; - } - - static const char * - gnat_dwarf_name (tree t, int verbosity ATTRIBUTE_UNUSED) - { - gcc_assert (DECL_P (t)); - - return (const char *) IDENTIFIER_POINTER (DECL_NAME (t)); - } - - /* Expands GNAT-specific GCC tree nodes. The only ones we support - here are and NULL_EXPR. */ - - static rtx - gnat_expand_expr (tree exp, rtx target, enum machine_mode tmode, - int modifier, rtx *alt_rtl) - { - tree type = TREE_TYPE (exp); - tree new; - - /* Update EXP to be the new expression to expand. */ - switch (TREE_CODE (exp)) - { - #if 0 - case ALLOCATE_EXPR: - return - allocate_dynamic_stack_space - (expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, TYPE_MODE (sizetype), - EXPAND_NORMAL), - NULL_RTX, tree_low_cst (TREE_OPERAND (exp, 1), 1)); - #endif - - case UNCONSTRAINED_ARRAY_REF: - /* If we are evaluating just for side-effects, just evaluate our - operand. Otherwise, abort since this code should never appear - in a tree to be evaluated (objects aren't unconstrained). */ - if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE) - return expand_expr (TREE_OPERAND (exp, 0), const0_rtx, - VOIDmode, modifier); - - /* ... fall through ... */ - - default: - gcc_unreachable (); - } - - return expand_expr_real (new, target, tmode, modifier, alt_rtl); - } - - /* Do nothing (return the tree node passed). */ - - static tree - gnat_return_tree (tree t) - { - return t; - } - - /* Return true if type A catches type B. Callback for flow analysis from - the exception handling part of the back-end. */ - - static int - gnat_eh_type_covers (tree a, tree b) - { - /* a catches b if they represent the same exception id or if a - is an "others". - - ??? integer_zero_node for "others" is hardwired in too many places - currently. */ - return (a == b || a == integer_zero_node); - } - - /* Get the alias set corresponding to a type or expression. */ - - static alias_set_type - gnat_get_alias_set (tree type) - { - /* If this is a padding type, use the type of the first field. */ - if (TREE_CODE (type) == RECORD_TYPE - && TYPE_IS_PADDING_P (type)) - return get_alias_set (TREE_TYPE (TYPE_FIELDS (type))); - - /* If the type is an unconstrained array, use the type of the - self-referential array we make. */ - else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) - return - get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))))); - - /* If the type can alias any other types, return the alias set 0. */ - else if (TYPE_P (type) - && TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (type))) - return 0; - - return -1; - } - - /* GNU_TYPE is a type. Return its maximum size in bytes, if known, - as a constant when possible. */ - - static tree - gnat_type_max_size (const_tree gnu_type) - { - /* First see what we can get from TYPE_SIZE_UNIT, which might not - be constant even for simple expressions if it has already been - elaborated and possibly replaced by a VAR_DECL. */ - tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true); - - /* If we don't have a constant, see what we can get from TYPE_ADA_SIZE, - which should stay untouched. */ - if (!host_integerp (max_unitsize, 1) - && (TREE_CODE (gnu_type) == RECORD_TYPE - || TREE_CODE (gnu_type) == UNION_TYPE - || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) - && TYPE_ADA_SIZE (gnu_type)) - { - tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true); - - /* If we have succeeded in finding a constant, round it up to the - type's alignment and return the result in units. */ - if (host_integerp (max_adasize, 1)) - max_unitsize - = size_binop (CEIL_DIV_EXPR, - round_up (max_adasize, TYPE_ALIGN (gnu_type)), - bitsize_unit_node); - } - - return max_unitsize; - } - - /* GNU_TYPE is a type. Determine if it should be passed by reference by - default. */ - - bool - default_pass_by_ref (tree gnu_type) - { - /* We pass aggregates by reference if they are sufficiently large. The - choice of constant here is somewhat arbitrary. We also pass by - reference if the target machine would either pass or return by - reference. Strictly speaking, we need only check the return if this - is an In Out parameter, but it's probably best to err on the side of - passing more things by reference. */ - - if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, 1)) - return true; - - if (targetm.calls.return_in_memory (gnu_type, NULL_TREE)) - return true; - - if (AGGREGATE_TYPE_P (gnu_type) - && (!host_integerp (TYPE_SIZE (gnu_type), 1) - || 0 < compare_tree_int (TYPE_SIZE (gnu_type), - 8 * TYPE_ALIGN (gnu_type)))) - return true; - - return false; - } - - /* GNU_TYPE is the type of a subprogram parameter. Determine from the type if - it should be passed by reference. */ - - bool - must_pass_by_ref (tree gnu_type) - { - /* We pass only unconstrained objects, those required by the language - to be passed by reference, and objects of variable size. The latter - is more efficient, avoids problems with variable size temporaries, - and does not produce compatibility problems with C, since C does - not have such objects. */ - return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE - || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type)) - || (TYPE_SIZE (gnu_type) - && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST)); - } - - /* This function is called by the front end to enumerate all the supported - modes for the machine. We pass a function which is called back with - the following integer parameters: - - FLOAT_P nonzero if this represents a floating-point mode - COMPLEX_P nonzero is this represents a complex mode - COUNT count of number of items, nonzero for vector mode - PRECISION number of bits in data representation - MANTISSA number of bits in mantissa, if FP and known, else zero. - SIZE number of bits used to store data - ALIGN number of bits to which mode is aligned. */ - - void - enumerate_modes (void (*f) (int, int, int, int, int, int, unsigned int)) - { - enum machine_mode i; - - for (i = 0; i < NUM_MACHINE_MODES; i++) - { - enum machine_mode j; - bool float_p = 0; - bool complex_p = 0; - bool vector_p = 0; - bool skip_p = 0; - int mantissa = 0; - enum machine_mode inner_mode = i; - - switch (GET_MODE_CLASS (i)) - { - case MODE_INT: - break; - case MODE_FLOAT: - float_p = 1; - break; - case MODE_COMPLEX_INT: - complex_p = 1; - inner_mode = GET_MODE_INNER (i); - break; - case MODE_COMPLEX_FLOAT: - float_p = 1; - complex_p = 1; - inner_mode = GET_MODE_INNER (i); - break; - case MODE_VECTOR_INT: - vector_p = 1; - inner_mode = GET_MODE_INNER (i); - break; - case MODE_VECTOR_FLOAT: - float_p = 1; - vector_p = 1; - inner_mode = GET_MODE_INNER (i); - break; - default: - skip_p = 1; - } - - /* Skip this mode if it's one the front end doesn't need to know about - (e.g., the CC modes) or if there is no add insn for that mode (or - any wider mode), meaning it is not supported by the hardware. If - this a complex or vector mode, we care about the inner mode. */ - for (j = inner_mode; j != VOIDmode; j = GET_MODE_WIDER_MODE (j)) - if (optab_handler (add_optab, j)->insn_code != CODE_FOR_nothing) - break; - - if (float_p) - { - const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode); - - mantissa = fmt->p; - } - - if (!skip_p && j != VOIDmode) - (*f) (float_p, complex_p, vector_p ? GET_MODE_NUNITS (i) : 0, - GET_MODE_BITSIZE (i), mantissa, - GET_MODE_SIZE (i) * BITS_PER_UNIT, GET_MODE_ALIGNMENT (i)); - } - } - - int - fp_prec_to_size (int prec) - { - enum machine_mode mode; - - for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode; - mode = GET_MODE_WIDER_MODE (mode)) - if (GET_MODE_PRECISION (mode) == prec) - return GET_MODE_BITSIZE (mode); - - gcc_unreachable (); - } - - int - fp_size_to_prec (int size) - { - enum machine_mode mode; - - for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode; - mode = GET_MODE_WIDER_MODE (mode)) - if (GET_MODE_BITSIZE (mode) == size) - return GET_MODE_PRECISION (mode); - - gcc_unreachable (); - } --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mkdir.c gcc-4.4.0/gcc/ada/mkdir.c *** gcc-4.3.3/gcc/ada/mkdir.c Wed Jun 6 10:38:07 2007 --- gcc-4.4.0/gcc/ada/mkdir.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 2002-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 2002-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-prj.adb gcc-4.4.0/gcc/ada/mlib-prj.adb *** gcc-4.3.3/gcc/ada/mlib-prj.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/mlib-prj.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** package body MLib.Prj is *** 322,328 **** -- g-trasym.obj. Object_Directory_Path : constant String := ! Get_Name_String (Data.Display_Object_Dir); Standalone : constant Boolean := Data.Standalone_Library; --- 322,329 ---- -- g-trasym.obj. Object_Directory_Path : constant String := ! Get_Name_String ! (Data.Object_Directory.Display_Name); Standalone : constant Boolean := Data.Standalone_Library; *************** package body MLib.Prj is *** 446,452 **** -- Start of processing for Add_Rpath begin ! -- If firt path, allocate initial Rpath if Rpath = null then Rpath := new String (1 .. Initial_Rpath_Length); --- 447,453 ---- -- Start of processing for Add_Rpath begin ! -- If first path, allocate initial Rpath if Rpath = null then Rpath := new String (1 .. Initial_Rpath_Length); *************** package body MLib.Prj is *** 713,726 **** if Libgnarl_Needed = Unknown then if Data.Libgnarl_Needed = Unknown ! and then Data.Object_Directory /= No_Path then -- Check if libgnarl is needed for this library declare Object_Dir_Path : constant String := Get_Name_String ! (Data.Display_Object_Dir); Object_Dir : Dir_Type; Filename : String (1 .. 255); Last : Natural; --- 714,728 ---- if Libgnarl_Needed = Unknown then if Data.Libgnarl_Needed = Unknown ! and then Data.Object_Directory /= No_Path_Information then -- Check if libgnarl is needed for this library declare Object_Dir_Path : constant String := Get_Name_String ! (Data.Object_Directory. ! Display_Name); Object_Dir : Dir_Type; Filename : String (1 .. 255); Last : Natural; *************** package body MLib.Prj is *** 799,805 **** Current := Library_Projs.Table (Index); Get_Name_String ! (In_Tree.Projects.Table (Current).Display_Library_Dir); Opts.Increment_Last; Opts.Table (Opts.Last) := new String'("-L" & Name_Buffer (1 .. Name_Len)); --- 801,807 ---- Current := Library_Projs.Table (Index); Get_Name_String ! (In_Tree.Projects.Table (Current).Library_Dir.Display_Name); Opts.Increment_Last; Opts.Table (Opts.Last) := new String'("-L" & Name_Buffer (1 .. Name_Len)); *************** package body MLib.Prj is *** 829,834 **** --- 831,842 ---- Com.Fail ("project """, Project_Name, """ has no library"); end if; + -- Do not attempt to build the library if it is externally built + + if Data.Externally_Built then + return; + end if; + -- If this is the first time Build_Library is called, get the Name_Id -- of "s-osinte.ads". *************** package body MLib.Prj is *** 960,966 **** Unit := In_Tree.Units.Table (Source); if Unit.File_Names (Body_Part).Name /= No_File ! and then Unit.File_Names (Body_Part).Path /= Slash then if Check_Project (Unit.File_Names (Body_Part).Project) --- 968,974 ---- Unit := In_Tree.Units.Table (Source); if Unit.File_Names (Body_Part).Name /= No_File ! and then Unit.File_Names (Body_Part).Path.Name /= Slash then if Check_Project (Unit.File_Names (Body_Part).Project) *************** package body MLib.Prj is *** 973,979 **** Src_Ind := Sinput.P.Load_Project_File (Get_Name_String (Unit.File_Names ! (Body_Part).Path)); -- Add the ALI file only if it is not a subunit --- 981,987 ---- Src_Ind := Sinput.P.Load_Project_File (Get_Name_String (Unit.File_Names ! (Body_Part).Path.Name)); -- Add the ALI file only if it is not a subunit *************** package body MLib.Prj is *** 993,999 **** end if; elsif Unit.File_Names (Specification).Name /= No_File ! and then Unit.File_Names (Specification).Path /= Slash and then Check_Project (Unit.File_Names (Specification).Project) then --- 1001,1007 ---- end if; elsif Unit.File_Names (Specification).Name /= No_File ! and then Unit.File_Names (Specification).Path.Name /= Slash and then Check_Project (Unit.File_Names (Specification).Project) then *************** package body MLib.Prj is *** 1155,1161 **** Close (FD); ! -- And invoke gnatbind with this this response file Spawn (Gnatbind_Path.all, Args, Success); --- 1163,1169 ---- Close (FD); ! -- And invoke gnatbind with this response file Spawn (Gnatbind_Path.all, Args, Success); *************** package body MLib.Prj is *** 1312,1318 **** end if; Lib_Dirpath := ! new String'(Get_Name_String (Data.Display_Library_Dir)); Lib_Filename := new String'(Get_Name_String (Data.Library_Name)); case Data.Library_Kind is --- 1320,1326 ---- end if; Lib_Dirpath := ! new String'(Get_Name_String (Data.Library_Dir.Display_Name)); Lib_Filename := new String'(Get_Name_String (Data.Library_Name)); case Data.Library_Kind is *************** package body MLib.Prj is *** 1349,1523 **** There_Are_Foreign_Sources := Data.Other_Sources_Present; loop ! declare ! Object_Dir_Path : constant String := ! Get_Name_String (Data.Display_Object_Dir); ! Object_Dir : Dir_Type; ! Filename : String (1 .. 255); ! Last : Natural; ! Id : Name_Id; ! ! begin ! Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path); ! -- For all entries in the object directory ! loop ! Read (Object_Dir, Filename, Last); ! exit when Last = 0; ! -- Check if it is an object file ! if Is_Obj (Filename (1 .. Last)) then ! declare ! Object_Path : constant String := ! Normalize_Pathname ! (Object_Dir_Path & Directory_Separator & ! Filename (1 .. Last)); ! C_Object_Path : String := Object_Path; ! C_Filename : String := Filename (1 .. Last); ! begin ! Canonical_Case_File_Name (C_Object_Path); ! Canonical_Case_File_Name (C_Filename); ! -- If in the object directory of an extended project, ! -- do not consider generated object files. ! if In_Main_Object_Directory ! or else Last < 5 ! or else C_Filename (1 .. B_Start'Length) /= ! B_Start.all ! then ! Name_Len := Last; ! Name_Buffer (1 .. Name_Len) := ! C_Filename (1 .. Last); ! Id := Name_Find; ! if not Objects_Htable.Get (Id) then ! declare ! ALI_File : constant String := ! Ext_To ! (Filename (1 .. Last), "ali"); ! ALI_Path : constant String := ! Ext_To (Object_Path, "ali"); ! Add_It : Boolean := ! There_Are_Foreign_Sources ! or else ! (Last > 5 ! and then ! C_Filename ! (1 .. B_Start'Length) = ! B_Start.all); ! Fname : File_Name_Type; ! Proj : Project_Id; ! begin ! if Is_Regular_File (ALI_Path) then ! -- If there is an ALI file, check if the ! -- object file should be added to the ! -- library. If there are foreign sources ! -- we put all object files in the library. ! if not Add_It then ! for Index in ! 1 .. Unit_Table.Last (In_Tree.Units) ! loop ! if In_Tree.Units.Table ! (Index).File_Names ! (Body_Part).Name /= No_File ! then ! Proj := ! In_Tree.Units.Table (Index). ! File_Names ! (Body_Part).Project; ! Fname := ! In_Tree.Units.Table (Index). ! File_Names (Body_Part).Name; ! elsif ! In_Tree.Units.Table ! (Index).File_Names ! (Specification).Name /= No_File ! then ! Proj := ! In_Tree.Units.Table (Index).File_Names ! (Specification).Project; ! Fname := In_Tree.Units.Table (Index).File_Names ! (Specification).Name; ! else ! Proj := No_Project; ! end if; ! Add_It := Proj /= No_Project; ! -- If the source is in the project ! -- or a project it extends, we may ! -- put it in the library. ! if Add_It then ! Add_It := Check_Project (Proj); ! end if; ! -- But we don't, if the ALI file ! -- does not correspond to the unit. ! if Add_It then ! declare ! F : constant String := ! Ext_To ! (Get_Name_String ! (Fname), "ali"); ! begin ! Add_It := F = ALI_File; ! end; ! end if; ! exit when Add_It; ! end loop; ! end if; ! if Add_It then ! Objects_Htable.Set (Id, True); ! Objects.Append ! (new String'(Object_Path)); ! -- Record the ALI file ! ALIs.Append (new String'(ALI_Path)); ! -- Find out if for this ALI file, ! -- libgnarl or libdecgnat or ! -- g-trasym.obj (on OpenVMS) is ! -- necessary. ! Check_Libs (ALI_Path, True); ! end if; ! elsif There_Are_Foreign_Sources then ! Objects.Append (new String'(Object_Path)); ! end if; ! end; end if; ! end if; ! end; ! end if; ! end loop; ! Close (Dir => Object_Dir); ! exception ! when Directory_Error => ! Com.Fail ("cannot find object directory """, ! Get_Name_String (Data.Object_Directory), ! """"); ! end; exit when Data.Extends = No_Project; --- 1357,1543 ---- There_Are_Foreign_Sources := Data.Other_Sources_Present; loop ! if Data.Object_Directory /= No_Path_Information then ! declare ! Object_Dir_Path : constant String := ! Get_Name_String ! (Data.Object_Directory.Display_Name); ! Object_Dir : Dir_Type; ! Filename : String (1 .. 255); ! Last : Natural; ! Id : Name_Id; ! begin ! Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path); ! -- For all entries in the object directory ! loop ! Read (Object_Dir, Filename, Last); ! exit when Last = 0; ! -- Check if it is an object file ! if Is_Obj (Filename (1 .. Last)) then ! declare ! Object_Path : constant String := ! Normalize_Pathname ! (Object_Dir_Path & ! Directory_Separator & ! Filename (1 .. Last)); ! C_Object_Path : String := Object_Path; ! C_Filename : String := Filename (1 .. Last); ! begin ! Canonical_Case_File_Name (C_Object_Path); ! Canonical_Case_File_Name (C_Filename); ! -- If in the object directory of an extended ! -- project, do not consider generated object files. ! if In_Main_Object_Directory ! or else Last < 5 ! or else ! C_Filename (1 .. B_Start'Length) /= B_Start.all ! then ! Name_Len := Last; ! Name_Buffer (1 .. Name_Len) := ! C_Filename (1 .. Last); ! Id := Name_Find; ! if not Objects_Htable.Get (Id) then ! declare ! ALI_File : constant String := ! Ext_To ! (C_Filename ! (1 .. Last), "ali"); ! ALI_Path : constant String := ! Ext_To (C_Object_Path, "ali"); ! Add_It : Boolean := ! There_Are_Foreign_Sources ! or else ! (Last > 5 ! and then ! C_Filename ! (1 .. B_Start'Length) = ! B_Start.all); ! Fname : File_Name_Type; ! Proj : Project_Id; ! begin ! if Is_Regular_File (ALI_Path) then ! -- If there is an ALI file, check if ! -- the object file should be added to ! -- the library. If there are foreign ! -- sources we put all object files in ! -- the library. ! if not Add_It then ! for Index in ! 1 .. Unit_Table.Last ! (In_Tree.Units) ! loop ! if In_Tree.Units.Table (Index).File_Names ! (Body_Part).Name /= No_File ! then ! Proj := ! In_Tree.Units.Table (Index). ! File_Names ! (Body_Part).Project; ! Fname := ! In_Tree.Units.Table (Index). ! File_Names (Body_Part).Name; ! ! elsif In_Tree.Units.Table (Index).File_Names ! (Specification).Name /= ! No_File ! then ! Proj := ! In_Tree.Units.Table ! (Index).File_Names ! (Specification).Project; ! Fname := ! In_Tree.Units.Table ! (Index).File_Names ! (Specification).Name; ! else ! Proj := No_Project; ! end if; ! Add_It := Proj /= No_Project; ! -- If the source is in the ! -- project or a project it ! -- extends, we may put it in ! -- the library. ! if Add_It then ! Add_It := Check_Project (Proj); ! end if; ! -- But we don't, if the ALI file ! -- does not correspond to the ! -- unit. ! if Add_It then ! declare ! F : constant String := ! Ext_To ! (Get_Name_String ! (Fname), "ali"); ! begin ! Add_It := F = ALI_File; ! end; ! end if; ! exit when Add_It; ! end loop; ! end if; ! if Add_It then ! Objects_Htable.Set (Id, True); ! Objects.Append ! (new String'(Object_Path)); ! -- Record the ALI file ! ALIs.Append (new String'(ALI_Path)); ! -- Find out if for this ALI file, ! -- libgnarl or libdecgnat or ! -- g-trasym.obj (on OpenVMS) is ! -- necessary. ! Check_Libs (ALI_Path, True); ! end if; ! elsif There_Are_Foreign_Sources then ! Objects.Append ! (new String'(Object_Path)); ! end if; ! end; ! end if; end if; ! end; ! end if; ! end loop; ! Close (Dir => Object_Dir); ! exception ! when Directory_Error => ! Com.Fail ("cannot find object directory """, ! Get_Name_String ! (Data.Object_Directory.Display_Name), ! """"); ! end; ! end if; exit when Data.Extends = No_Project; *************** package body MLib.Prj is *** 1791,1797 **** begin Get_Name_String ! (In_Tree.Projects.Table (For_Project).Library_Dir); Change_Dir (Name_Buffer (1 .. Name_Len)); exception --- 1811,1817 ---- begin Get_Name_String ! (In_Tree.Projects.Table (For_Project).Library_Dir.Name); Change_Dir (Name_Buffer (1 .. Name_Len)); exception *************** package body MLib.Prj is *** 1931,1951 **** Copy_ALI_Files (Files => Ali_Files.all, ! To => In_Tree.Projects.Table (For_Project).Library_ALI_Dir, Interfaces => Arguments (1 .. Argument_Number)); -- Copy interface sources if Library_Src_Dir specified if Standalone and then In_Tree.Projects.Table ! (For_Project).Library_Src_Dir /= No_Path then -- Clean the interface copy directory: remove any source that -- could be a source of the project. begin Get_Name_String ! (In_Tree.Projects.Table (For_Project).Library_Src_Dir); Change_Dir (Name_Buffer (1 .. Name_Len)); exception --- 1951,1972 ---- Copy_ALI_Files (Files => Ali_Files.all, ! To => In_Tree.Projects.Table ! (For_Project).Library_ALI_Dir.Name, Interfaces => Arguments (1 .. Argument_Number)); -- Copy interface sources if Library_Src_Dir specified if Standalone and then In_Tree.Projects.Table ! (For_Project).Library_Src_Dir /= No_Path_Information then -- Clean the interface copy directory: remove any source that -- could be a source of the project. begin Get_Name_String ! (In_Tree.Projects.Table (For_Project).Library_Src_Dir.Name); Change_Dir (Name_Buffer (1 .. Name_Len)); exception *************** package body MLib.Prj is *** 2023,2029 **** In_Tree => In_Tree, Interfaces => Arguments (1 .. Argument_Number), To_Dir => In_Tree.Projects.Table ! (For_Project).Display_Library_Src_Dir); end if; end if; --- 2044,2050 ---- In_Tree => In_Tree, Interfaces => Arguments (1 .. Argument_Number), To_Dir => In_Tree.Projects.Table ! (For_Project).Library_Src_Dir.Display_Name); end if; end if; *************** package body MLib.Prj is *** 2077,2090 **** Lib_Name : constant File_Name_Type := Library_File_Name_For (For_Project, In_Tree); begin ! Change_Dir (Get_Name_String (Data.Library_Dir)); Lib_TS := File_Stamp (Lib_Name); In_Tree.Projects.Table (For_Project).Library_TS := Lib_TS; end; if not Data.Externally_Built and then not Data.Need_To_Build_Lib ! and then Data.Object_Directory /= No_Path then declare Obj_TS : Time_Stamp_Type; --- 2098,2111 ---- Lib_Name : constant File_Name_Type := Library_File_Name_For (For_Project, In_Tree); begin ! Change_Dir (Get_Name_String (Data.Library_Dir.Name)); Lib_TS := File_Stamp (Lib_Name); In_Tree.Projects.Table (For_Project).Library_TS := Lib_TS; end; if not Data.Externally_Built and then not Data.Need_To_Build_Lib ! and then Data.Object_Directory /= No_Path_Information then declare Obj_TS : Time_Stamp_Type; *************** package body MLib.Prj is *** 2098,2104 **** -- If the library file does not exist, then the time stamp will -- be Empty_Time_Stamp, earlier than any other time stamp. ! Change_Dir (Get_Name_String (Data.Object_Directory)); Open (Dir => Object_Dir, Dir_Name => "."); -- For all entries in the object directory --- 2119,2125 ---- -- If the library file does not exist, then the time stamp will -- be Empty_Time_Stamp, earlier than any other time stamp. ! Change_Dir (Get_Name_String (Data.Object_Directory.Name)); Open (Dir => Object_Dir, Dir_Name => "."); -- For all entries in the object directory *************** package body MLib.Prj is *** 2118,2126 **** Obj_TS := File_Stamp (File_Name_Type'(Name_Find)); -- If library file time stamp is earlier, set ! -- Need_To_Build_Lib and return. String comparaison is -- used, otherwise time stamps may be too close and the ! -- comparaison would return True, which would trigger -- an unnecessary rebuild of the library. if String (Lib_TS) < String (Obj_TS) then --- 2139,2147 ---- Obj_TS := File_Stamp (File_Name_Type'(Name_Find)); -- If library file time stamp is earlier, set ! -- Need_To_Build_Lib and return. String comparison is -- used, otherwise time stamps may be too close and the ! -- comparison would return True, which would trigger -- an unnecessary rebuild of the library. if String (Lib_TS) < String (Obj_TS) then *************** package body MLib.Prj is *** 2202,2208 **** and then Data.File_Names (J).Name = File_Name then Copy_File ! (Get_Name_String (Data.File_Names (J).Path), Target, Success, Mode => Overwrite, --- 2223,2229 ---- and then Data.File_Names (J).Name = File_Name then Copy_File ! (Get_Name_String (Data.File_Names (J).Path.Name), Target, Success, Mode => Overwrite, *************** package body MLib.Prj is *** 2243,2250 **** Change_Dir (Get_Name_String ! (In_Tree.Projects.Table ! (For_Project).Object_Directory)); for Index in Interfaces'Range loop --- 2264,2270 ---- Change_Dir (Get_Name_String ! (In_Tree.Projects.Table (For_Project).Object_Directory.Name)); for Index in Interfaces'Range loop *************** package body MLib.Prj is *** 2348,2354 **** Fd : FILEs; -- Binder file's descriptor ! Read_Mode : constant String := "r" & ASCII.Nul; -- For fopen Status : Interfaces.C_Streams.int; --- 2368,2374 ---- Fd : FILEs; -- Binder file's descriptor ! Read_Mode : constant String := "r" & ASCII.NUL; -- For fopen Status : Interfaces.C_Streams.int; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-aix.adb gcc-4.4.0/gcc/ada/mlib-tgt-aix.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-aix.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-aix.adb Thu Jan 1 00:00:00 1970 *************** *** 1,211 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . S P E C I F I C -- - -- (AIX Version) -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2003-2007, AdaCore -- - -- -- - -- 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the AIX version of the body - - with Ada.Strings.Fixed; use Ada.Strings.Fixed; - - with MLib.Fil; - with MLib.Utl; - with Opt; - with Output; use Output; - with Prj.Com; - with Prj.Util; use Prj.Util; - - package body MLib.Tgt.Specific is - - -- Non default subprograms - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - function DLL_Ext return String; - - function Library_Major_Minor_Id_Supported return Boolean; - - function Support_For_Libraries return Library_Support; - - -- Local variables - - No_Arguments : aliased Argument_List := (1 .. 0 => null); - Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; - - Bexpall : aliased String := "-Wl,-bexpall"; - Bexpall_Option : constant String_Access := Bexpall'Access; - -- The switch to export all symbols - - Lpthreads : aliased String := "-lpthreads"; - Native_Thread_Options : aliased Argument_List := (1 => Lpthreads'Access); - -- The switch to use when linking a library against libgnarl when using - -- Native threads. - - Lgthreads : aliased String := "-lgthreads"; - Lmalloc : aliased String := "-lmalloc"; - FSU_Thread_Options : aliased Argument_List := - (1 => Lgthreads'Access, 2 => Lmalloc'Access); - -- The switches to use when linking a library against libgnarl when using - -- FSU threads. - - Thread_Options : Argument_List_Access := Empty_Argument_List; - -- Designate the thread switches to used when linking a library against - -- libgnarl. Depends on the thread library (Native or FSU). Resolved for - -- the first library linked against libgnarl. - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Lib_Version); - pragma Unreferenced (Auto_Init); - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - MLib.Fil.Append_To (Lib_Filename, DLL_Ext); - -- The file name of the library - - Thread_Opts : Argument_List_Access := Empty_Argument_List; - -- Set to Thread_Options if -lgnarl is found in the Options - - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_File); - end if; - - -- Look for -lgnarl in Options. If found, set the thread options - - for J in Options'Range loop - if Options (J).all = "-lgnarl" then - - -- If Thread_Options is null, read s-osinte.ads to discover the - -- thread library and set Thread_Options accordingly. - - if Thread_Options = null then - declare - File : Text_File; - Line : String (1 .. 100); - Last : Natural; - - begin - Open - (File, Include_Dir_Default_Prefix & "/s-osinte.ads"); - - while not End_Of_File (File) loop - Get_Line (File, Line, Last); - - if Index (Line (1 .. Last), "-lpthreads") /= 0 then - Thread_Options := Native_Thread_Options'Access; - exit; - - elsif Index (Line (1 .. Last), "-lgthreads") /= 0 then - Thread_Options := FSU_Thread_Options'Access; - exit; - end if; - end loop; - - Close (File); - - if Thread_Options = null then - Prj.Com.Fail ("cannot find the thread library in use"); - end if; - - exception - when others => - Prj.Com.Fail ("cannot open s-osinte.ads"); - end; - end if; - - Thread_Opts := Thread_Options; - exit; - end if; - end loop; - - -- Finally, call GCC (or the driver specified) to build the library - - MLib.Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles, - Options => Options & Bexpall_Option, - Driver_Name => Driver_Name, - Options_2 => Thread_Opts.all); - end Build_Dynamic_Library; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "a"; - end DLL_Ext; - - -------------------------------------- - -- Library_Major_Minor_Id_Supported -- - -------------------------------------- - - function Library_Major_Minor_Id_Supported return Boolean is - begin - return False; - end Library_Major_Minor_Id_Supported; - - --------------------------- - -- Support_For_Libraries -- - --------------------------- - - function Support_For_Libraries return Library_Support is - begin - return Static_Only; - end Support_For_Libraries; - - begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; - DLL_Ext_Ptr := DLL_Ext'Access; - Library_Major_Minor_Id_Supported_Ptr := - Library_Major_Minor_Id_Supported'Access; - Support_For_Libraries_Ptr := Support_For_Libraries'Access; - - end MLib.Tgt.Specific; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-darwin.adb gcc-4.4.0/gcc/ada/mlib-tgt-darwin.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-darwin.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-darwin.adb Thu Jan 1 00:00:00 1970 *************** *** 1,188 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . S P E C I F I C -- - -- (Darwin Version) -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2001-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the Darwin version of the body - - with MLib; use MLib; - with MLib.Fil; - with MLib.Utl; - with Opt; use Opt; - with Output; use Output; - - package body MLib.Tgt.Specific is - - -- Non default subprograms - - function Archive_Indexer_Options return String_List_Access; - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - function DLL_Ext return String; - - function Dynamic_Option return String; - - function Is_Archive_Ext (Ext : String) return Boolean; - - -- Local objects - - Flat_Namespace : aliased String := "-Wl,-flat_namespace"; - -- Instruct the linker to build the shared library as a flat - -- namespace image. The default is a two-level namespace image. - - Shared_Libgcc : aliased String := "-shared-libgcc"; - - Shared_Options : constant Argument_List := - (1 => Flat_Namespace'Access, - 2 => Shared_Libgcc'Access); - - ----------------------------- - -- Archive_Indexer_Options -- - ----------------------------- - - function Archive_Indexer_Options return String_List_Access is - begin - return new String_List'(1 => new String'("-c")); - end Archive_Indexer_Options; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Auto_Init); - - Lib_File : constant String := - "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); - - Lib_Path : constant String := - Lib_Dir & Directory_Separator & Lib_File; - - Symbolic_Link_Needed : Boolean := False; - - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_File); - end if; - - -- If specified, add automatic elaboration/finalization - - if Lib_Version = "" then - Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles, - Options => Options & Shared_Options, - Driver_Name => Driver_Name, - Options_2 => No_Argument_List); - - else - declare - Maj_Version : constant String := - Major_Id_Name (Lib_File, Lib_Version); - begin - if Is_Absolute_Path (Lib_Version) then - Utl.Gcc - (Output_File => Lib_Version, - Objects => Ofiles, - Options => Options & Shared_Options, - Driver_Name => Driver_Name, - Options_2 => No_Argument_List); - Symbolic_Link_Needed := Lib_Version /= Lib_File; - - else - Utl.Gcc - (Output_File => Lib_Dir & Directory_Separator & Lib_Version, - Objects => Ofiles, - Options => Options & Shared_Options, - Driver_Name => Driver_Name, - Options_2 => No_Argument_List); - Symbolic_Link_Needed := - Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; - end if; - - if Symbolic_Link_Needed then - Create_Sym_Links - (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); - end if; - end; - end if; - end Build_Dynamic_Library; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "dylib"; - end DLL_Ext; - - -------------------- - -- Dynamic_Option -- - -------------------- - - function Dynamic_Option return String is - begin - return "-dynamiclib"; - end Dynamic_Option; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".dylib" or else Ext = ".a"; - end Is_Archive_Ext; - - begin - Archive_Indexer_Options_Ptr := Archive_Indexer_Options'Access; - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; - DLL_Ext_Ptr := DLL_Ext'Access; - Dynamic_Option_Ptr := Dynamic_Option'Access; - Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; - end MLib.Tgt.Specific; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-hpux.adb gcc-4.4.0/gcc/ada/mlib-tgt-hpux.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-hpux.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-hpux.adb Thu Jan 1 00:00:00 1970 *************** *** 1,164 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . S P E C I F I C -- - -- (HP-UX Version) -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2003-2007, AdaCore -- - -- -- - -- 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the HP-UX version of the body - - with MLib.Fil; - with MLib.Utl; - with Opt; - with Output; use Output; - - package body MLib.Tgt.Specific is - - -- Non default subprograms - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - function DLL_Ext return String; - - function Is_Archive_Ext (Ext : String) return Boolean; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Auto_Init); - - Lib_File : constant String := - "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); - - Lib_Path : constant String := - Lib_Dir & Directory_Separator & Lib_File; - - Version_Arg : String_Access; - Symbolic_Link_Needed : Boolean := False; - - Common_Options : constant Argument_List := - Options & new String'(PIC_Option); - -- Common set of options to the gcc command performing the link. - -- On HPUX, this command eventually resorts to collect2, which may - -- generate a C file and compile it on the fly. This compilation shall - -- also generate position independant code for the final link to - -- succeed. - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_Path); - end if; - - if Lib_Version = "" then - MLib.Utl.Gcc - (Output_File => Lib_Path, - Objects => Ofiles, - Options => Common_Options, - Options_2 => No_Argument_List, - Driver_Name => Driver_Name); - - else - declare - Maj_Version : constant String := - Major_Id_Name (Lib_File, Lib_Version); - begin - if Maj_Version'Length /= 0 then - Version_Arg := new String'("-Wl,+h," & Maj_Version); - - else - Version_Arg := new String'("-Wl,+h," & Lib_Version); - end if; - - if Is_Absolute_Path (Lib_Version) then - MLib.Utl.Gcc - (Output_File => Lib_Version, - Objects => Ofiles, - Options => Common_Options & Version_Arg, - Options_2 => No_Argument_List, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := Lib_Version /= Lib_Path; - - else - MLib.Utl.Gcc - (Output_File => Lib_Dir & Directory_Separator & Lib_Version, - Objects => Ofiles, - Options => Common_Options & Version_Arg, - Options_2 => No_Argument_List, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := - Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; - end if; - - if Symbolic_Link_Needed then - Create_Sym_Links - (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); - end if; - end; - end if; - end Build_Dynamic_Library; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "sl"; - end DLL_Ext; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a" or else Ext = ".so"; - end Is_Archive_Ext; - - begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; - DLL_Ext_Ptr := DLL_Ext'Access; - Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; - end MLib.Tgt.Specific; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-irix.adb gcc-4.4.0/gcc/ada/mlib-tgt-irix.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-irix.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-irix.adb Thu Jan 1 00:00:00 1970 *************** *** 1,182 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . S P E C I F I C -- - -- (IRIX Version) -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2003-2007, AdaCore -- - -- -- - -- 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the IRIX version of the body - - with MLib.Fil; - with MLib.Utl; - with Opt; - with Output; use Output; - - package body MLib.Tgt.Specific is - - -- Non default subprogram - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - function Is_Archive_Ext (Ext : String) return Boolean; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Auto_Init); - - Lib_File : constant String := - "lib" & MLib.Fil.Append_To (Lib_Filename, DLL_Ext); - - Lib_Path : constant String := - Lib_Dir & Directory_Separator & Lib_File; - - Version_Arg : String_Access; - Symbolic_Link_Needed : Boolean := False; - - N_Options : Argument_List := Options; - Options_Last : Natural := N_Options'Last; - -- After moving -lxxx to Options_2, N_Options up to index Options_Last - -- will contain the Options to pass to MLib.Utl.Gcc. - - Real_Options_2 : Argument_List (1 .. Options'Length); - Real_Options_2_Last : Natural := 0; - -- Real_Options_2 up to index Real_Options_2_Last will contain the - -- Options_2 to pass to MLib.Utl.Gcc. - - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_Path); - end if; - - -- Move all -lxxx to Options_2 - - declare - Index : Natural := N_Options'First; - Arg : String_Access; - - begin - while Index <= Options_Last loop - Arg := N_Options (Index); - - if Arg'Length > 2 - and then Arg (Arg'First .. Arg'First + 1) = "-l" - then - Real_Options_2_Last := Real_Options_2_Last + 1; - Real_Options_2 (Real_Options_2_Last) := Arg; - N_Options (Index .. Options_Last - 1) := - N_Options (Index + 1 .. Options_Last); - Options_Last := Options_Last - 1; - - else - Index := Index + 1; - end if; - end loop; - end; - - if Lib_Version = "" then - MLib.Utl.Gcc - (Output_File => Lib_Path, - Objects => Ofiles, - Options => N_Options (N_Options'First .. Options_Last), - Driver_Name => Driver_Name, - Options_2 => Real_Options_2 (1 .. Real_Options_2_Last)); - - else - declare - Maj_Version : constant String := - Major_Id_Name (Lib_File, Lib_Version); - begin - if Maj_Version'Length /= 0 then - Version_Arg := new String'("-Wl,-soname," & Maj_Version); - - else - Version_Arg := new String'("-Wl,-soname," & Lib_Version); - end if; - - if Is_Absolute_Path (Lib_Version) then - MLib.Utl.Gcc - (Output_File => Lib_Version, - Objects => Ofiles, - Options => N_Options (N_Options'First .. Options_Last) & - Version_Arg, - Driver_Name => Driver_Name, - Options_2 => Real_Options_2 (1 .. Real_Options_2_Last)); - Symbolic_Link_Needed := Lib_Version /= Lib_Path; - - else - MLib.Utl.Gcc - (Output_File => Lib_Dir & Directory_Separator & Lib_Version, - Objects => Ofiles, - Options => N_Options (N_Options'First .. Options_Last) & - Version_Arg, - Driver_Name => Driver_Name, - Options_2 => Real_Options_2 (1 .. Real_Options_2_Last)); - Symbolic_Link_Needed := - Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; - end if; - - if Symbolic_Link_Needed then - Create_Sym_Links - (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); - end if; - end; - end if; - end Build_Dynamic_Library; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a" or else Ext = ".so"; - end Is_Archive_Ext; - - begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; - Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; - end MLib.Tgt.Specific; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-linux.adb gcc-4.4.0/gcc/ada/mlib-tgt-linux.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-linux.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-linux.adb Thu Jan 1 00:00:00 1970 *************** *** 1,148 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . S P E C I F I C -- - -- (GNU/Linux Version) -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2001-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the GNU/Linux version of the body - - with MLib.Fil; - with MLib.Utl; - with Opt; - with Output; use Output; - - package body MLib.Tgt.Specific is - - use MLib; - - -- Non default subprograms - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - function Is_Archive_Ext (Ext : String) return Boolean; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Auto_Init); - -- Initialization is done through the contructor mechanism - - Lib_File : constant String := - "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); - - Lib_Path : constant String := - Lib_Dir & Directory_Separator & Lib_File; - - Version_Arg : String_Access; - Symbolic_Link_Needed : Boolean := False; - - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_Path); - end if; - - if Lib_Version = "" then - Utl.Gcc - (Output_File => Lib_Path, - Objects => Ofiles, - Options => Options, - Driver_Name => Driver_Name, - Options_2 => No_Argument_List); - - else - declare - Maj_Version : constant String := - Major_Id_Name (Lib_File, Lib_Version); - begin - if Maj_Version'Length /= 0 then - Version_Arg := new String'("-Wl,-soname," & Maj_Version); - - else - Version_Arg := new String'("-Wl,-soname," & Lib_Version); - end if; - - if Is_Absolute_Path (Lib_Version) then - Utl.Gcc - (Output_File => Lib_Version, - Objects => Ofiles, - Options => Options & Version_Arg, - Driver_Name => Driver_Name, - Options_2 => No_Argument_List); - Symbolic_Link_Needed := Lib_Version /= Lib_Path; - - else - Utl.Gcc - (Output_File => Lib_Dir & Directory_Separator & Lib_Version, - Objects => Ofiles, - Options => Options & Version_Arg, - Driver_Name => Driver_Name, - Options_2 => No_Argument_List); - Symbolic_Link_Needed := - Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; - end if; - - if Symbolic_Link_Needed then - Create_Sym_Links - (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); - end if; - end; - end if; - end Build_Dynamic_Library; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a" or else Ext = ".so"; - end Is_Archive_Ext; - - begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; - Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; - end MLib.Tgt.Specific; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-lynxos.adb gcc-4.4.0/gcc/ada/mlib-tgt-lynxos.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-lynxos.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-lynxos.adb Thu Jan 1 00:00:00 1970 *************** *** 1,149 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . S P E C I F I C -- - -- (LynxOS Version) -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2003-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the LynxOS version of the body - - package body MLib.Tgt.Specific is - - -- Non default subprograms - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - function DLL_Ext return String; - - function Dynamic_Option return String; - - function PIC_Option return String; - - function Library_Major_Minor_Id_Supported return Boolean; - - function Standalone_Library_Auto_Init_Is_Supported return Boolean; - - function Support_For_Libraries return Library_Support; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Ofiles); - pragma Unreferenced (Options); - pragma Unreferenced (Interfaces); - pragma Unreferenced (Lib_Filename); - pragma Unreferenced (Lib_Dir); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Driver_Name); - pragma Unreferenced (Lib_Version); - pragma Unreferenced (Auto_Init); - - begin - null; - end Build_Dynamic_Library; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return ""; - end DLL_Ext; - - -------------------- - -- Dynamic_Option -- - -------------------- - - function Dynamic_Option return String is - begin - return ""; - end Dynamic_Option; - - -------------------------------------- - -- Library_Major_Minor_Id_Supported -- - -------------------------------------- - - function Library_Major_Minor_Id_Supported return Boolean is - begin - return False; - end Library_Major_Minor_Id_Supported; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return ""; - end PIC_Option; - - ----------------------------------------------- - -- Standalone_Library_Auto_Init_Is_Supported -- - ----------------------------------------------- - - function Standalone_Library_Auto_Init_Is_Supported return Boolean is - begin - return False; - end Standalone_Library_Auto_Init_Is_Supported; - - --------------------------- - -- Support_For_Libraries -- - --------------------------- - - function Support_For_Libraries return Library_Support is - begin - return Static_Only; - end Support_For_Libraries; - - begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; - DLL_Ext_Ptr := DLL_Ext'Access; - Dynamic_Option_Ptr := Dynamic_Option'Access; - Library_Major_Minor_Id_Supported_Ptr := - Library_Major_Minor_Id_Supported'Access; - PIC_Option_Ptr := PIC_Option'Access; - Standalone_Library_Auto_Init_Is_Supported_Ptr := - Standalone_Library_Auto_Init_Is_Supported'Access; - Support_For_Libraries_Ptr := Support_For_Libraries'Access; - end MLib.Tgt.Specific; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-mingw.adb gcc-4.4.0/gcc/ada/mlib-tgt-mingw.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-mingw.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-mingw.adb Thu Jan 1 00:00:00 1970 *************** *** 1,160 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . S P E C I F I C -- - -- (Windows Version) -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2002-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the Windows version of the body. Works only with GCC versions - -- supporting the "-shared" option. - - with Opt; - with Output; use Output; - - with MLib.Fil; - with MLib.Utl; - - package body MLib.Tgt.Specific is - - package Files renames MLib.Fil; - package Tools renames MLib.Utl; - - -- Non default subprograms - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - function DLL_Ext return String; - - function DLL_Prefix return String; - - function Is_Archive_Ext (Ext : String) return Boolean; - - function Library_Major_Minor_Id_Supported return Boolean; - - function PIC_Option return String; - - No_Argument_List : constant String_List := (1 .. 0 => null); - -- Used as value of parameter Options or Options2 in calls to Gcc - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Interfaces); - pragma Unreferenced (Lib_Version); - pragma Unreferenced (Auto_Init); - - Lib_File : constant String := - Lib_Dir & Directory_Separator & - DLL_Prefix & Files.Append_To (Lib_Filename, DLL_Ext); - - -- Start of processing for Build_Dynamic_Library - - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_File); - end if; - - Tools.Gcc - (Output_File => Lib_File, - Objects => Ofiles, - Options => No_Argument_List, - Options_2 => Options, - Driver_Name => Driver_Name); - end Build_Dynamic_Library; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "dll"; - end DLL_Ext; - - ---------------- - -- DLL_Prefix -- - ---------------- - - function DLL_Prefix return String is - begin - return "lib"; - end DLL_Prefix; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a" or else Ext = ".dll"; - end Is_Archive_Ext; - - -------------------------------------- - -- Library_Major_Minor_Id_Supported -- - -------------------------------------- - - function Library_Major_Minor_Id_Supported return Boolean is - begin - return False; - end Library_Major_Minor_Id_Supported; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return ""; - end PIC_Option; - - begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; - DLL_Ext_Ptr := DLL_Ext'Access; - DLL_Prefix_Ptr := DLL_Prefix'Access; - Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; - PIC_Option_Ptr := PIC_Option'Access; - Library_Major_Minor_Id_Supported_Ptr := - Library_Major_Minor_Id_Supported'Access; - end MLib.Tgt.Specific; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-solaris.adb gcc-4.4.0/gcc/ada/mlib-tgt-solaris.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-solaris.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-solaris.adb Thu Jan 1 00:00:00 1970 *************** *** 1,145 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . S P E C I F I C -- - -- (Solaris Version) -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2002-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the Solaris version of the body - - with MLib.Fil; - with MLib.Utl; - with Opt; - with Output; use Output; - - package body MLib.Tgt.Specific is - - -- Non default subprograms - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - function Is_Archive_Ext (Ext : String) return Boolean; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Auto_Init); - - Lib_File : constant String := - "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); - - Lib_Path : constant String := - Lib_Dir & Directory_Separator & Lib_File; - - Version_Arg : String_Access; - Symbolic_Link_Needed : Boolean := False; - - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_Path); - end if; - - if Lib_Version = "" then - Utl.Gcc - (Output_File => Lib_Path, - Objects => Ofiles, - Options => Options, - Options_2 => No_Argument_List, - Driver_Name => Driver_Name); - - else - declare - Maj_Version : constant String := - Major_Id_Name (Lib_File, Lib_Version); - begin - if Maj_Version'Length /= 0 then - Version_Arg := new String'("-Wl,-h," & Maj_Version); - - else - Version_Arg := new String'("-Wl,-h," & Lib_Version); - end if; - - if Is_Absolute_Path (Lib_Version) then - Utl.Gcc - (Output_File => Lib_Version, - Objects => Ofiles, - Options => Options & Version_Arg, - Options_2 => No_Argument_List, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := Lib_Version /= Lib_Path; - - else - Utl.Gcc - (Output_File => Lib_Dir & Directory_Separator & Lib_Version, - Objects => Ofiles, - Options => Options & Version_Arg, - Options_2 => No_Argument_List, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := - Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; - end if; - - if Symbolic_Link_Needed then - Create_Sym_Links - (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); - end if; - end; - end if; - end Build_Dynamic_Library; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a" or else Ext = ".so"; - end Is_Archive_Ext; - - begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; - Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; - end MLib.Tgt.Specific; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-specific-aix.adb gcc-4.4.0/gcc/ada/mlib-tgt-specific-aix.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-specific-aix.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-specific-aix.adb Tue Apr 8 06:44:24 2008 *************** *** 0 **** --- 1,225 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . S P E C I F I C -- + -- (AIX Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003-2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the AIX version of the body + + with Ada.Strings.Fixed; use Ada.Strings.Fixed; + + with MLib.Fil; + with MLib.Utl; + with Opt; + with Output; use Output; + with Prj.Com; + with Prj.Util; use Prj.Util; + + package body MLib.Tgt.Specific is + + -- Local subprograms + -- These *ALL* require comments ??? + + function Archive_Indexer return String; + -- What is this??? + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function Library_Major_Minor_Id_Supported return Boolean; + + function Support_For_Libraries return Library_Support; + + -- Local variables + + No_Arguments : aliased Argument_List := (1 .. 0 => null); + Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; + + Bexpall : aliased String := "-Wl,-bexpall"; + Bexpall_Option : constant String_Access := Bexpall'Access; + -- The switch to export all symbols + + Lpthreads : aliased String := "-lpthreads"; + Native_Thread_Options : aliased Argument_List := (1 => Lpthreads'Access); + -- The switch to use when linking a library against libgnarl when using + -- Native threads. + + Lgthreads : aliased String := "-lgthreads"; + Lmalloc : aliased String := "-lmalloc"; + FSU_Thread_Options : aliased Argument_List := + (1 => Lgthreads'Access, 2 => Lmalloc'Access); + -- The switches to use when linking a library against libgnarl when using + -- FSU threads. + + Thread_Options : Argument_List_Access := Empty_Argument_List; + -- Designate the thread switches to used when linking a library against + -- libgnarl. Depends on the thread library (Native or FSU). Resolved for + -- the first library linked against libgnarl. + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return ""; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Auto_Init); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + MLib.Fil.Append_To (Lib_Filename, DLL_Ext); + -- The file name of the library + + Thread_Opts : Argument_List_Access := Empty_Argument_List; + -- Set to Thread_Options if -lgnarl is found in the Options + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- Look for -lgnarl in Options. If found, set the thread options + + for J in Options'Range loop + if Options (J).all = "-lgnarl" then + + -- If Thread_Options is null, read s-osinte.ads to discover the + -- thread library and set Thread_Options accordingly. + + if Thread_Options = null then + declare + File : Text_File; + Line : String (1 .. 100); + Last : Natural; + + begin + Open + (File, Include_Dir_Default_Prefix & "/s-osinte.ads"); + + while not End_Of_File (File) loop + Get_Line (File, Line, Last); + + if Index (Line (1 .. Last), "-lpthreads") /= 0 then + Thread_Options := Native_Thread_Options'Access; + exit; + + elsif Index (Line (1 .. Last), "-lgthreads") /= 0 then + Thread_Options := FSU_Thread_Options'Access; + exit; + end if; + end loop; + + Close (File); + + if Thread_Options = null then + Prj.Com.Fail ("cannot find the thread library in use"); + end if; + + exception + when others => + Prj.Com.Fail ("cannot open s-osinte.ads"); + end; + end if; + + Thread_Opts := Thread_Options; + exit; + end if; + end loop; + + -- Finally, call GCC (or the driver specified) to build the library + + MLib.Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => Options & Bexpall_Option, + Driver_Name => Driver_Name, + Options_2 => Thread_Opts.all); + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "a"; + end DLL_Ext; + + -------------------------------------- + -- Library_Major_Minor_Id_Supported -- + -------------------------------------- + + function Library_Major_Minor_Id_Supported return Boolean is + begin + return False; + end Library_Major_Minor_Id_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Static_Only; + end Support_For_Libraries; + + begin + Archive_Indexer_Ptr := Archive_Indexer'Access; + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Library_Major_Minor_Id_Supported_Ptr := + Library_Major_Minor_Id_Supported'Access; + Support_For_Libraries_Ptr := Support_For_Libraries'Access; + + end MLib.Tgt.Specific; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-specific-darwin.adb gcc-4.4.0/gcc/ada/mlib-tgt-specific-darwin.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-specific-darwin.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-specific-darwin.adb Tue Apr 8 06:44:24 2008 *************** *** 0 **** --- 1,188 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . S P E C I F I C -- + -- (Darwin Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2001-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the Darwin version of the body + + with MLib; use MLib; + with MLib.Fil; + with MLib.Utl; + with Opt; use Opt; + with Output; use Output; + + package body MLib.Tgt.Specific is + + -- Non default subprograms + + function Archive_Indexer_Options return String_List_Access; + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function Dynamic_Option return String; + + function Is_Archive_Ext (Ext : String) return Boolean; + + -- Local objects + + Flat_Namespace : aliased String := "-Wl,-flat_namespace"; + -- Instruct the linker to build the shared library as a flat + -- namespace image. The default is a two-level namespace image. + + Shared_Libgcc : aliased String := "-shared-libgcc"; + + Shared_Options : constant Argument_List := + (1 => Flat_Namespace'Access, + 2 => Shared_Libgcc'Access); + + ----------------------------- + -- Archive_Indexer_Options -- + ----------------------------- + + function Archive_Indexer_Options return String_List_Access is + begin + return new String_List'(1 => new String'("-c")); + end Archive_Indexer_Options; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Auto_Init); + + Lib_File : constant String := + "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); + + Lib_Path : constant String := + Lib_Dir & Directory_Separator & Lib_File; + + Symbolic_Link_Needed : Boolean := False; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- If specified, add automatic elaboration/finalization + + if Lib_Version = "" then + Utl.Gcc + (Output_File => Lib_Path, + Objects => Ofiles, + Options => Options & Shared_Options, + Driver_Name => Driver_Name, + Options_2 => No_Argument_List); + + else + declare + Maj_Version : constant String := + Major_Id_Name (Lib_File, Lib_Version); + begin + if Is_Absolute_Path (Lib_Version) then + Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Options & Shared_Options, + Driver_Name => Driver_Name, + Options_2 => No_Argument_List); + Symbolic_Link_Needed := Lib_Version /= Lib_Path; + + else + Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Options & Shared_Options, + Driver_Name => Driver_Name, + Options_2 => No_Argument_List); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; + end if; + + if Symbolic_Link_Needed then + Create_Sym_Links + (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); + end if; + end; + end if; + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "dylib"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-dynamiclib"; + end Dynamic_Option; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".dylib" or else Ext = ".a"; + end Is_Archive_Ext; + + begin + Archive_Indexer_Options_Ptr := Archive_Indexer_Options'Access; + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Dynamic_Option_Ptr := Dynamic_Option'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; + end MLib.Tgt.Specific; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-specific-hpux.adb gcc-4.4.0/gcc/ada/mlib-tgt-specific-hpux.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-specific-hpux.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-specific-hpux.adb Tue Apr 8 06:44:24 2008 *************** *** 0 **** --- 1,164 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . S P E C I F I C -- + -- (HP-UX Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003-2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the HP-UX version of the body + + with MLib.Fil; + with MLib.Utl; + with Opt; + with Output; use Output; + + package body MLib.Tgt.Specific is + + -- Non default subprograms + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function Is_Archive_Ext (Ext : String) return Boolean; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Auto_Init); + + Lib_File : constant String := + "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); + + Lib_Path : constant String := + Lib_Dir & Directory_Separator & Lib_File; + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + Common_Options : constant Argument_List := + Options & new String'(PIC_Option); + -- Common set of options to the gcc command performing the link. + -- On HPUX, this command eventually resorts to collect2, which may + -- generate a C file and compile it on the fly. This compilation shall + -- also generate position independent code for the final link to + -- succeed. + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_Path); + end if; + + if Lib_Version = "" then + MLib.Utl.Gcc + (Output_File => Lib_Path, + Objects => Ofiles, + Options => Common_Options, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + + else + declare + Maj_Version : constant String := + Major_Id_Name (Lib_File, Lib_Version); + begin + if Maj_Version'Length /= 0 then + Version_Arg := new String'("-Wl,+h," & Maj_Version); + + else + Version_Arg := new String'("-Wl,+h," & Lib_Version); + end if; + + if Is_Absolute_Path (Lib_Version) then + MLib.Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Common_Options & Version_Arg, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_Path; + + else + MLib.Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Common_Options & Version_Arg, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; + end if; + + if Symbolic_Link_Needed then + Create_Sym_Links + (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); + end if; + end; + end if; + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "sl"; + end DLL_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; + end MLib.Tgt.Specific; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-specific-irix.adb gcc-4.4.0/gcc/ada/mlib-tgt-specific-irix.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-specific-irix.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-specific-irix.adb Fri Feb 20 15:20:38 2009 *************** *** 0 **** --- 1,182 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . S P E C I F I C -- + -- (IRIX Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003-2008, AdaCore -- + -- -- + -- 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the IRIX version of the body + + with MLib.Fil; + with MLib.Utl; + with Opt; + with Output; use Output; + + package body MLib.Tgt.Specific is + + -- Non default subprogram + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function Is_Archive_Ext (Ext : String) return Boolean; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Auto_Init); + + Lib_File : constant String := + "lib" & MLib.Fil.Append_To (Lib_Filename, DLL_Ext); + + Lib_Path : constant String := + Lib_Dir & Directory_Separator & Lib_File; + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + N_Options : Argument_List := Options; + Options_Last : Natural := N_Options'Last; + -- After moving -lxxx to Options_2, N_Options up to index Options_Last + -- will contain the Options to pass to MLib.Utl.Gcc. + + Real_Options_2 : Argument_List (1 .. Options'Length); + Real_Options_2_Last : Natural := 0; + -- Real_Options_2 up to index Real_Options_2_Last will contain the + -- Options_2 to pass to MLib.Utl.Gcc. + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_Path); + end if; + + -- Move all -lxxx to Options_2 + + declare + Index : Natural := N_Options'First; + Arg : String_Access; + + begin + while Index <= Options_Last loop + Arg := N_Options (Index); + + if Arg'Length > 2 + and then Arg (Arg'First .. Arg'First + 1) = "-l" + then + Real_Options_2_Last := Real_Options_2_Last + 1; + Real_Options_2 (Real_Options_2_Last) := Arg; + N_Options (Index .. Options_Last - 1) := + N_Options (Index + 1 .. Options_Last); + Options_Last := Options_Last - 1; + + else + Index := Index + 1; + end if; + end loop; + end; + + if Lib_Version = "" then + MLib.Utl.Gcc + (Output_File => Lib_Path, + Objects => Ofiles, + Options => N_Options (N_Options'First .. Options_Last), + Driver_Name => Driver_Name, + Options_2 => Real_Options_2 (1 .. Real_Options_2_Last)); + + else + declare + Maj_Version : constant String := + Major_Id_Name (Lib_File, Lib_Version); + begin + if Maj_Version'Length /= 0 then + Version_Arg := new String'("-Wl,-soname," & Maj_Version); + + else + Version_Arg := new String'("-Wl,-soname," & Lib_Version); + end if; + + if Is_Absolute_Path (Lib_Version) then + MLib.Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => N_Options (N_Options'First .. Options_Last) & + Version_Arg, + Driver_Name => Driver_Name, + Options_2 => Real_Options_2 (1 .. Real_Options_2_Last)); + Symbolic_Link_Needed := Lib_Version /= Lib_Path; + + else + MLib.Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => N_Options (N_Options'First .. Options_Last) & + Version_Arg, + Driver_Name => Driver_Name, + Options_2 => Real_Options_2 (1 .. Real_Options_2_Last)); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; + end if; + + if Symbolic_Link_Needed then + Create_Sym_Links + (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); + end if; + end; + end if; + end Build_Dynamic_Library; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; + end MLib.Tgt.Specific; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-specific-linux.adb gcc-4.4.0/gcc/ada/mlib-tgt-specific-linux.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-specific-linux.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-specific-linux.adb Mon Apr 14 21:07:59 2008 *************** *** 0 **** --- 1,148 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . S P E C I F I C -- + -- (GNU/Linux Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2001-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the GNU/Linux version of the body + + with MLib.Fil; + with MLib.Utl; + with Opt; + with Output; use Output; + + package body MLib.Tgt.Specific is + + use MLib; + + -- Non default subprograms + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function Is_Archive_Ext (Ext : String) return Boolean; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Auto_Init); + -- Initialization is done through the constructor mechanism + + Lib_File : constant String := + "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); + + Lib_Path : constant String := + Lib_Dir & Directory_Separator & Lib_File; + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_Path); + end if; + + if Lib_Version = "" then + Utl.Gcc + (Output_File => Lib_Path, + Objects => Ofiles, + Options => Options, + Driver_Name => Driver_Name, + Options_2 => No_Argument_List); + + else + declare + Maj_Version : constant String := + Major_Id_Name (Lib_File, Lib_Version); + begin + if Maj_Version'Length /= 0 then + Version_Arg := new String'("-Wl,-soname," & Maj_Version); + + else + Version_Arg := new String'("-Wl,-soname," & Lib_Version); + end if; + + if Is_Absolute_Path (Lib_Version) then + Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg, + Driver_Name => Driver_Name, + Options_2 => No_Argument_List); + Symbolic_Link_Needed := Lib_Version /= Lib_Path; + + else + Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg, + Driver_Name => Driver_Name, + Options_2 => No_Argument_List); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; + end if; + + if Symbolic_Link_Needed then + Create_Sym_Links + (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); + end if; + end; + end if; + end Build_Dynamic_Library; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; + end MLib.Tgt.Specific; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-specific-lynxos.adb gcc-4.4.0/gcc/ada/mlib-tgt-specific-lynxos.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-specific-lynxos.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-specific-lynxos.adb Fri Feb 20 15:20:38 2009 *************** *** 0 **** --- 1,149 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . S P E C I F I C -- + -- (LynxOS Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the LynxOS version of the body + + package body MLib.Tgt.Specific is + + -- Non default subprograms + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function Dynamic_Option return String; + + function PIC_Option return String; + + function Library_Major_Minor_Id_Supported return Boolean; + + function Standalone_Library_Auto_Init_Is_Supported return Boolean; + + function Support_For_Libraries return Library_Support; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Ofiles); + pragma Unreferenced (Options); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Lib_Filename); + pragma Unreferenced (Lib_Dir); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Driver_Name); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Auto_Init); + + begin + null; + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return ""; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return ""; + end Dynamic_Option; + + -------------------------------------- + -- Library_Major_Minor_Id_Supported -- + -------------------------------------- + + function Library_Major_Minor_Id_Supported return Boolean is + begin + return False; + end Library_Major_Minor_Id_Supported; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return False; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Static_Only; + end Support_For_Libraries; + + begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Dynamic_Option_Ptr := Dynamic_Option'Access; + Library_Major_Minor_Id_Supported_Ptr := + Library_Major_Minor_Id_Supported'Access; + PIC_Option_Ptr := PIC_Option'Access; + Standalone_Library_Auto_Init_Is_Supported_Ptr := + Standalone_Library_Auto_Init_Is_Supported'Access; + Support_For_Libraries_Ptr := Support_For_Libraries'Access; + end MLib.Tgt.Specific; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-specific-mingw.adb gcc-4.4.0/gcc/ada/mlib-tgt-specific-mingw.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-specific-mingw.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-specific-mingw.adb Fri Feb 20 15:20:38 2009 *************** *** 0 **** --- 1,160 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . S P E C I F I C -- + -- (Windows Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2002-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the Windows version of the body. Works only with GCC versions + -- supporting the "-shared" option. + + with Opt; + with Output; use Output; + + with MLib.Fil; + with MLib.Utl; + + package body MLib.Tgt.Specific is + + package Files renames MLib.Fil; + package Tools renames MLib.Utl; + + -- Non default subprograms + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function DLL_Prefix return String; + + function Is_Archive_Ext (Ext : String) return Boolean; + + function Library_Major_Minor_Id_Supported return Boolean; + + function PIC_Option return String; + + No_Argument_List : constant String_List := (1 .. 0 => null); + -- Used as value of parameter Options or Options2 in calls to Gcc + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Auto_Init); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & + DLL_Prefix & Files.Append_To (Lib_Filename, DLL_Ext); + + -- Start of processing for Build_Dynamic_Library + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + Tools.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => No_Argument_List, + Options_2 => Options, + Driver_Name => Driver_Name); + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "dll"; + end DLL_Ext; + + ---------------- + -- DLL_Prefix -- + ---------------- + + function DLL_Prefix return String is + begin + return "lib"; + end DLL_Prefix; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".dll"; + end Is_Archive_Ext; + + -------------------------------------- + -- Library_Major_Minor_Id_Supported -- + -------------------------------------- + + function Library_Major_Minor_Id_Supported return Boolean is + begin + return False; + end Library_Major_Minor_Id_Supported; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + DLL_Prefix_Ptr := DLL_Prefix'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; + PIC_Option_Ptr := PIC_Option'Access; + Library_Major_Minor_Id_Supported_Ptr := + Library_Major_Minor_Id_Supported'Access; + end MLib.Tgt.Specific; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-specific-solaris.adb gcc-4.4.0/gcc/ada/mlib-tgt-specific-solaris.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-specific-solaris.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-specific-solaris.adb Fri Feb 20 15:20:38 2009 *************** *** 0 **** --- 1,145 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . S P E C I F I C -- + -- (Solaris Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2002-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the Solaris version of the body + + with MLib.Fil; + with MLib.Utl; + with Opt; + with Output; use Output; + + package body MLib.Tgt.Specific is + + -- Non default subprograms + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function Is_Archive_Ext (Ext : String) return Boolean; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Auto_Init); + + Lib_File : constant String := + "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); + + Lib_Path : constant String := + Lib_Dir & Directory_Separator & Lib_File; + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_Path); + end if; + + if Lib_Version = "" then + Utl.Gcc + (Output_File => Lib_Path, + Objects => Ofiles, + Options => Options, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + + else + declare + Maj_Version : constant String := + Major_Id_Name (Lib_File, Lib_Version); + begin + if Maj_Version'Length /= 0 then + Version_Arg := new String'("-Wl,-h," & Maj_Version); + + else + Version_Arg := new String'("-Wl,-h," & Lib_Version); + end if; + + if Is_Absolute_Path (Lib_Version) then + Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_Path; + + else + Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; + end if; + + if Symbolic_Link_Needed then + Create_Sym_Links + (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); + end if; + end; + end if; + end Build_Dynamic_Library; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; + end MLib.Tgt.Specific; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-specific-tru64.adb gcc-4.4.0/gcc/ada/mlib-tgt-specific-tru64.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-specific-tru64.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-specific-tru64.adb Mon Apr 14 21:07:59 2008 *************** *** 0 **** --- 1,168 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . S P E C I F I C -- + -- (Tru64 Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2002-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the Tru64 version of the body + + with MLib.Fil; + with MLib.Utl; + with Opt; + with Output; use Output; + + package body MLib.Tgt.Specific is + + use MLib; + + -- Non default subprogram + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function Is_Archive_Ext (Ext : String) return Boolean; + + function PIC_Option return String; + + -- Local variables + + Expect_Unresolved : aliased String := "-Wl,-expect_unresolved,*"; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Auto_Init); + -- Initialization is done through the constructor mechanism + + Lib_File : constant String := + "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); + + Lib_Path : constant String := + Lib_Dir & Directory_Separator & Lib_File; + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_Path); + end if; + + -- If specified, add automatic elaboration/finalization + + if Lib_Version = "" then + Utl.Gcc + (Output_File => Lib_Path, + Objects => Ofiles, + Options => Options & Expect_Unresolved'Access, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + + else + declare + Maj_Version : constant String := + Major_Id_Name (Lib_File, Lib_Version); + begin + if Maj_Version'Length /= 0 then + Version_Arg := new String'("-Wl,-soname," & Maj_Version); + + else + Version_Arg := new String'("-Wl,-soname," & Lib_Version); + end if; + + if Is_Absolute_Path (Lib_Version) then + Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => + Options & Version_Arg & Expect_Unresolved'Access, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_Path; + + else + Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => + Options & Version_Arg & Expect_Unresolved'Access, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; + end if; + + if Symbolic_Link_Needed then + Create_Sym_Links + (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); + end if; + end; + end if; + end Build_Dynamic_Library; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; + PIC_Option_Ptr := PIC_Option'Access; + end MLib.Tgt.Specific; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-specific-vms-alpha.adb gcc-4.4.0/gcc/ada/mlib-tgt-specific-vms-alpha.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-specific-vms-alpha.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-specific-vms-alpha.adb Fri Aug 1 07:38:54 2008 *************** *** 0 **** --- 1,508 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . S P E C I F I C -- + -- (Alpha VMS Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the Alpha VMS version of the body + + with Ada.Characters.Handling; use Ada.Characters.Handling; + + with MLib.Fil; + with MLib.Utl; + + with MLib.Tgt.VMS_Common; + pragma Warnings (Off, MLib.Tgt.VMS_Common); + -- MLib.Tgt.VMS_Common is with'ed only for elaboration purposes + + with Opt; use Opt; + with Output; use Output; + + with GNAT.Directory_Operations; use GNAT.Directory_Operations; + + with System; use System; + with System.Case_Util; use System.Case_Util; + with System.CRTL; use System.CRTL; + + package body MLib.Tgt.Specific is + + -- Non default subprogram. See comment in mlib-tgt.ads. + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + -- Local variables + + Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); + Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; + -- Used to add the generated auto-init object files for auto-initializing + -- stand-alone libraries. + + Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; + -- The name of the command to invoke the macro-assembler + + VMS_Options : Argument_List := (1 .. 1 => null); + + Gnatsym_Name : constant String := "gnatsym"; + + Gnatsym_Path : String_Access; + + Arguments : Argument_List_Access := null; + Last_Argument : Natural := 0; + + Success : Boolean := False; + + Shared_Libgcc : aliased String := "-shared-libgcc"; + + Shared_Libgcc_Switch : constant Argument_List := + (1 => Shared_Libgcc'Access); + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Filename, DLL_Ext); + + Opts : Argument_List := Options; + Last_Opt : Natural := Opts'Last; + Opts2 : Argument_List (Options'Range); + Last_Opt2 : Natural := Opts2'First - 1; + + Inter : constant Argument_List := Interfaces; + + function Is_Interface (Obj_File : String) return Boolean; + -- For a Stand-Alone Library, returns True if Obj_File is the object + -- file name of an interface of the SAL. For other libraries, always + -- return True. + + function Option_File_Name return String; + -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" + + function Version_String return String; + -- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is + -- not Autonomous, otherwise returns "". When Symbol_Data.Symbol_Policy + -- is Autonomous, fails gnatmake if Lib_Version is not the image of a + -- positive number. + + ------------------ + -- Is_Interface -- + ------------------ + + function Is_Interface (Obj_File : String) return Boolean is + ALI : constant String := + Fil.Ext_To + (Filename => To_Lower (Base_Name (Obj_File)), + New_Ext => "ali"); + + begin + if Inter'Length = 0 then + return True; + + elsif ALI'Length > 2 and then + ALI (ALI'First .. ALI'First + 2) = "b__" + then + return True; + + else + for J in Inter'Range loop + if Inter (J).all = ALI then + return True; + end if; + end loop; + + return False; + end if; + end Is_Interface; + + ---------------------- + -- Option_File_Name -- + ---------------------- + + function Option_File_Name return String is + begin + if Symbol_Data.Symbol_File = No_Path then + return "symvec.opt"; + else + Get_Name_String (Symbol_Data.Symbol_File); + To_Lower (Name_Buffer (1 .. Name_Len)); + return Name_Buffer (1 .. Name_Len); + end if; + end Option_File_Name; + + -------------------- + -- Version_String -- + -------------------- + + function Version_String return String is + Version : Integer := 0; + + begin + if Lib_Version = "" + or else Symbol_Data.Symbol_Policy /= Autonomous + then + return ""; + + else + begin + Version := Integer'Value (Lib_Version); + + if Version <= 0 then + raise Constraint_Error; + end if; + + return Lib_Version; + + exception + when Constraint_Error => + Fail ("illegal version """, Lib_Version, + """ (on VMS version must be a positive number)"); + return ""; + end; + end if; + end Version_String; + + --------------------- + -- Local Variables -- + --------------------- + + Opt_File_Name : constant String := Option_File_Name; + Version : constant String := Version_String; + For_Linker_Opt : String_Access; + + -- Start of processing for Build_Dynamic_Library + + begin + -- If option file name does not ends with ".opt", append "/OPTIONS" + -- to its specification for the VMS linker. + + if Opt_File_Name'Length > 4 + and then + Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt" + then + For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name); + else + For_Linker_Opt := + new String'("--for-linker=" & Opt_File_Name & "/OPTIONS"); + end if; + + VMS_Options (VMS_Options'First) := For_Linker_Opt; + + for J in Inter'Range loop + To_Lower (Inter (J).all); + end loop; + + -- "gnatsym" is necessary for building the option file + + if Gnatsym_Path = null then + Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name); + + if Gnatsym_Path = null then + Fail (Gnatsym_Name, " not found in path"); + end if; + end if; + + -- For auto-initialization of a stand-alone library, we create + -- a macro-assembly file and we invoke the macro-assembler. + + if Auto_Init then + declare + Macro_File_Name : constant String := Lib_Filename & "__init.asm"; + Macro_File : File_Descriptor; + Init_Proc : String := Lib_Filename & "INIT"; + Popen_Result : System.Address; + Pclose_Result : Integer; + Len : Natural; + OK : Boolean := True; + + command : constant String := + Macro_Name & " " & Macro_File_Name & ASCII.NUL; + -- The command to invoke the assembler on the generated auto-init + -- assembly file. + + mode : constant String := "r" & ASCII.NUL; + -- The mode for the invocation of Popen + + begin + To_Upper (Init_Proc); + + if Verbose_Mode then + Write_Str ("Creating auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + -- Create and write the auto-init assembly file + + declare + use ASCII; + + -- Output a dummy transfer address for debugging + -- followed by the LIB$INITIALIZE section. + + Lines : constant String := + HT & ".text" & LF & + HT & ".align 4" & LF & + HT & ".globl __main" & LF & + HT & ".ent __main" & LF & + "__main..en:" & LF & + HT & ".base $27" & LF & + HT & ".frame $29,0,$26,8" & LF & + HT & "ret $31,($26),1" & LF & + HT & ".link" & LF & + "__main:" & LF & + HT & ".pdesc __main..en,null" & LF & + HT & ".end __main" & LF & LF & + HT & ".section LIB$INITIALIZE,GBL,NOWRT" & LF & + HT & ".long " & Init_Proc & LF; + + begin + Macro_File := Create_File (Macro_File_Name, Text); + OK := Macro_File /= Invalid_FD; + + if OK then + Len := Write + (Macro_File, Lines (Lines'First)'Address, + Lines'Length); + OK := Len = Lines'Length; + end if; + + if OK then + Close (Macro_File, OK); + end if; + + if not OK then + Fail ("creation of auto-init assembly file """, + Macro_File_Name, """ failed"); + end if; + end; + + -- Invoke the macro-assembler + + if Verbose_Mode then + Write_Str ("Assembling auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + Popen_Result := popen (command (command'First)'Address, + mode (mode'First)'Address); + + if Popen_Result = Null_Address then + Fail ("assembly of auto-init assembly file """, + Macro_File_Name, """ failed"); + end if; + + -- Wait for the end of execution of the macro-assembler + + Pclose_Result := pclose (Popen_Result); + + if Pclose_Result < 0 then + Fail ("assembly of auto init assembly file """, + Macro_File_Name, """ failed"); + end if; + + -- Add the generated object file to the list of objects to be + -- included in the library. + + Additional_Objects := + new Argument_List' + (1 => new String'(Lib_Filename & "__init.obj")); + end; + end if; + + -- Allocate the argument list and put the symbol file name, the + -- reference (if any) and the policy (if not autonomous). + + Arguments := new Argument_List (1 .. Ofiles'Length + 8); + + Last_Argument := 0; + + -- Verbosity + + if Verbose_Mode then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-v"); + end if; + + -- Version number (major ID) + + if Lib_Version /= "" then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-V"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Version); + end if; + + -- Symbol file + + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-s"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Opt_File_Name); + + -- Reference Symbol File + + if Symbol_Data.Reference /= No_Path then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-r"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := + new String'(Get_Name_String (Symbol_Data.Reference)); + end if; + + -- Policy + + case Symbol_Data.Symbol_Policy is + when Autonomous => + null; + + when Compliant => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-c"); + + when Controlled => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-C"); + + when Restricted => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-R"); + + when Direct => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-D"); + + end case; + + -- Add each relevant object file + + for Index in Ofiles'Range loop + if Is_Interface (Ofiles (Index).all) then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Ofiles (Index).all); + end if; + end loop; + + -- Spawn gnatsym + + Spawn (Program_Name => Gnatsym_Path.all, + Args => Arguments (1 .. Last_Argument), + Success => Success); + + if not Success then + Fail ("unable to create symbol file for library """, + Lib_Filename, """"); + end if; + + Free (Arguments); + + -- Move all the -l switches from Opts to Opts2 + + declare + Index : Natural := Opts'First; + Opt : String_Access; + + begin + while Index <= Last_Opt loop + Opt := Opts (Index); + + if Opt'Length > 2 and then + Opt (Opt'First .. Opt'First + 1) = "-l" + then + if Index < Last_Opt then + Opts (Index .. Last_Opt - 1) := + Opts (Index + 1 .. Last_Opt); + end if; + + Last_Opt := Last_Opt - 1; + + Last_Opt2 := Last_Opt2 + 1; + Opts2 (Last_Opt2) := Opt; + + else + Index := Index + 1; + end if; + end loop; + end; + + -- Invoke gcc to build the library + + Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles & Additional_Objects.all, + Options => VMS_Options, + Options_2 => Shared_Libgcc_Switch & + Opts (Opts'First .. Last_Opt) & + Opts2 (Opts2'First .. Last_Opt2), + Driver_Name => Driver_Name); + + -- The auto-init object file need to be deleted, so that it will not + -- be included in the library as a regular object file, otherwise + -- it will be included twice when the library will be built next + -- time, which may lead to errors. + + if Auto_Init then + declare + Auto_Init_Object_File_Name : constant String := + Lib_Filename & "__init.obj"; + Disregard : Boolean; + + begin + if Verbose_Mode then + Write_Str ("deleting auto-init object file """); + Write_Str (Auto_Init_Object_File_Name); + Write_Line (""""); + end if; + + Delete_File (Auto_Init_Object_File_Name, Success => Disregard); + end; + end if; + end Build_Dynamic_Library; + + -- Package initialization + + begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + end MLib.Tgt.Specific; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-specific-vms-ia64.adb gcc-4.4.0/gcc/ada/mlib-tgt-specific-vms-ia64.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-specific-vms-ia64.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-specific-vms-ia64.adb Fri Aug 1 07:38:54 2008 *************** *** 0 **** --- 1,512 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . S P E C I F I C -- + -- (Integrity VMS Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2004-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the Integrity VMS version of the body + + with Ada.Characters.Handling; use Ada.Characters.Handling; + + with MLib.Fil; + with MLib.Utl; + + with MLib.Tgt.VMS_Common; + pragma Warnings (Off, MLib.Tgt.VMS_Common); + -- MLib.Tgt.VMS_Common is with'ed only for elaboration purposes + + with Opt; use Opt; + with Output; use Output; + + with GNAT.Directory_Operations; use GNAT.Directory_Operations; + + with System; use System; + with System.Case_Util; use System.Case_Util; + with System.CRTL; use System.CRTL; + + package body MLib.Tgt.Specific is + + -- Non default subprogram. See comment in mlib-tgt.ads. + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + -- Local variables + + Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); + Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; + -- Used to add the generated auto-init object files for auto-initializing + -- stand-alone libraries. + + Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; + -- The name of the command to invoke the macro-assembler + + VMS_Options : Argument_List := (1 .. 1 => null); + + Gnatsym_Name : constant String := "gnatsym"; + + Gnatsym_Path : String_Access; + + Arguments : Argument_List_Access := null; + Last_Argument : Natural := 0; + + Success : Boolean := False; + + Shared_Libgcc : aliased String := "-shared-libgcc"; + + Shared_Libgcc_Switch : constant Argument_List := + (1 => Shared_Libgcc'Access); + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Filename, DLL_Ext); + + Opts : Argument_List := Options; + Last_Opt : Natural := Opts'Last; + Opts2 : Argument_List (Options'Range); + Last_Opt2 : Natural := Opts2'First - 1; + + Inter : constant Argument_List := Interfaces; + + function Is_Interface (Obj_File : String) return Boolean; + -- For a Stand-Alone Library, returns True if Obj_File is the object + -- file name of an interface of the SAL. For other libraries, always + -- return True. + + function Option_File_Name return String; + -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" + + function Version_String return String; + -- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is + -- not Autonomous, otherwise returns "". When Symbol_Data.Symbol_Policy + -- is Autonomous, fails gnatmake if Lib_Version is not the image of a + -- positive number. + + ------------------ + -- Is_Interface -- + ------------------ + + function Is_Interface (Obj_File : String) return Boolean is + ALI : constant String := + Fil.Ext_To + (Filename => To_Lower (Base_Name (Obj_File)), + New_Ext => "ali"); + + begin + if Inter'Length = 0 then + return True; + + elsif ALI'Length > 2 and then + ALI (ALI'First .. ALI'First + 2) = "b__" + then + return True; + + else + for J in Inter'Range loop + if Inter (J).all = ALI then + return True; + end if; + end loop; + + return False; + end if; + end Is_Interface; + + ---------------------- + -- Option_File_Name -- + ---------------------- + + function Option_File_Name return String is + begin + if Symbol_Data.Symbol_File = No_Path then + return "symvec.opt"; + else + Get_Name_String (Symbol_Data.Symbol_File); + To_Lower (Name_Buffer (1 .. Name_Len)); + return Name_Buffer (1 .. Name_Len); + end if; + end Option_File_Name; + + -------------------- + -- Version_String -- + -------------------- + + function Version_String return String is + Version : Integer := 0; + begin + if Lib_Version = "" + or else Symbol_Data.Symbol_Policy /= Autonomous + then + return ""; + + else + begin + Version := Integer'Value (Lib_Version); + + if Version <= 0 then + raise Constraint_Error; + end if; + + return Lib_Version; + + exception + when Constraint_Error => + Fail ("illegal version """, Lib_Version, + """ (on VMS version must be a positive number)"); + return ""; + end; + end if; + end Version_String; + + --------------------- + -- Local Variables -- + --------------------- + + Opt_File_Name : constant String := Option_File_Name; + Version : constant String := Version_String; + For_Linker_Opt : String_Access; + + -- Start of processing for Build_Dynamic_Library + + begin + -- Option file must end with ".opt" + + if Opt_File_Name'Length > 4 + and then + Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt" + then + For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name); + else + Fail ("Options File """, Opt_File_Name, """ must end with .opt"); + end if; + + VMS_Options (VMS_Options'First) := For_Linker_Opt; + + for J in Inter'Range loop + To_Lower (Inter (J).all); + end loop; + + -- "gnatsym" is necessary for building the option file + + if Gnatsym_Path = null then + Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name); + + if Gnatsym_Path = null then + Fail (Gnatsym_Name, " not found in path"); + end if; + end if; + + -- For auto-initialization of a stand-alone library, we create + -- a macro-assembly file and we invoke the macro-assembler. + + if Auto_Init then + declare + Macro_File_Name : constant String := Lib_Filename & "__init.asm"; + Macro_File : File_Descriptor; + Init_Proc : String := Lib_Filename & "INIT"; + Popen_Result : System.Address; + Pclose_Result : Integer; + Len : Natural; + OK : Boolean := True; + + command : constant String := + Macro_Name & " " & Macro_File_Name & ASCII.NUL; + -- The command to invoke the assembler on the generated auto-init + -- assembly file. + -- Why odd lower case name ??? + + mode : constant String := "r" & ASCII.NUL; + -- The mode for the invocation of Popen + -- Why odd lower case name ??? + + begin + To_Upper (Init_Proc); + + if Verbose_Mode then + Write_Str ("Creating auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + -- Create and write the auto-init assembly file + + declare + use ASCII; + + -- Output a dummy transfer address for debugging + -- followed by the LIB$INITIALIZE section. + + Lines : constant String := + HT & ".pred.safe_across_calls p1-p5,p16-p63" & LF & + HT & ".text" & LF & + HT & ".align 16" & LF & + HT & ".global __main#" & LF & + HT & ".proc __main#" & LF & + "__main:" & LF & + HT & ".prologue" & LF & + HT & ".body" & LF & + HT & ".mib" & LF & + HT & "nop 0" & LF & + HT & "nop 0" & LF & + HT & "br.ret.sptk.many b0" & LF & + HT & ".endp __main#" & LF & LF & + HT & ".type " & Init_Proc & "#, @function" & LF & + HT & ".global " & Init_Proc & "#" & LF & + HT & ".global LIB$INITIALIZE#" & LF & + HT & ".section LIB$INITIALIZE#,""a"",@progbits" & LF & + HT & "data4 @fptr(" & Init_Proc & "#)" & LF; + + begin + Macro_File := Create_File (Macro_File_Name, Text); + OK := Macro_File /= Invalid_FD; + + if OK then + Len := Write + (Macro_File, Lines (Lines'First)'Address, + Lines'Length); + OK := Len = Lines'Length; + end if; + + if OK then + Close (Macro_File, OK); + end if; + + if not OK then + Fail ("creation of auto-init assembly file """, + Macro_File_Name, """ failed"); + end if; + end; + + -- Invoke the macro-assembler + + if Verbose_Mode then + Write_Str ("Assembling auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + Popen_Result := popen (command (command'First)'Address, + mode (mode'First)'Address); + + if Popen_Result = Null_Address then + Fail ("assembly of auto-init assembly file """, + Macro_File_Name, """ failed"); + end if; + + -- Wait for the end of execution of the macro-assembler + + Pclose_Result := pclose (Popen_Result); + + if Pclose_Result < 0 then + Fail ("assembly of auto init assembly file """, + Macro_File_Name, """ failed"); + end if; + + -- Add the generated object file to the list of objects to be + -- included in the library. + + Additional_Objects := + new Argument_List' + (1 => new String'(Lib_Filename & "__init.obj")); + end; + end if; + + -- Allocate the argument list and put the symbol file name, the + -- reference (if any) and the policy (if not autonomous). + + Arguments := new Argument_List (1 .. Ofiles'Length + 8); + + Last_Argument := 0; + + -- Verbosity + + if Verbose_Mode then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-v"); + end if; + + -- Version number (major ID) + + if Lib_Version /= "" then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-V"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Version); + end if; + + -- Symbol file + + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-s"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Opt_File_Name); + + -- Reference Symbol File + + if Symbol_Data.Reference /= No_Path then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-r"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := + new String'(Get_Name_String (Symbol_Data.Reference)); + end if; + + -- Policy + + case Symbol_Data.Symbol_Policy is + when Autonomous => + null; + + when Compliant => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-c"); + + when Controlled => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-C"); + + when Restricted => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-R"); + + when Direct => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-D"); + end case; + + -- Add each relevant object file + + for Index in Ofiles'Range loop + if Is_Interface (Ofiles (Index).all) then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Ofiles (Index).all); + end if; + end loop; + + -- Spawn gnatsym + + Spawn (Program_Name => Gnatsym_Path.all, + Args => Arguments (1 .. Last_Argument), + Success => Success); + + if not Success then + Fail ("unable to create symbol file for library """, + Lib_Filename, """"); + end if; + + Free (Arguments); + + -- Move all the -l switches from Opts to Opts2 + + declare + Index : Natural := Opts'First; + Opt : String_Access; + + begin + while Index <= Last_Opt loop + Opt := Opts (Index); + + if Opt'Length > 2 and then + Opt (Opt'First .. Opt'First + 1) = "-l" + then + if Index < Last_Opt then + Opts (Index .. Last_Opt - 1) := + Opts (Index + 1 .. Last_Opt); + end if; + + Last_Opt := Last_Opt - 1; + + Last_Opt2 := Last_Opt2 + 1; + Opts2 (Last_Opt2) := Opt; + + else + Index := Index + 1; + end if; + end loop; + end; + + -- Invoke gcc to build the library + + Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles & Additional_Objects.all, + Options => VMS_Options, + Options_2 => Shared_Libgcc_Switch & + Opts (Opts'First .. Last_Opt) & + Opts2 (Opts2'First .. Last_Opt2), + Driver_Name => Driver_Name); + + -- The auto-init object file need to be deleted, so that it will not + -- be included in the library as a regular object file, otherwise + -- it will be included twice when the library will be built next + -- time, which may lead to errors. + + if Auto_Init then + declare + Auto_Init_Object_File_Name : constant String := + Lib_Filename & "__init.obj"; + + Disregard : Boolean; + pragma Warnings (Off, Disregard); + + begin + if Verbose_Mode then + Write_Str ("deleting auto-init object file """); + Write_Str (Auto_Init_Object_File_Name); + Write_Line (""""); + end if; + + Delete_File (Auto_Init_Object_File_Name, Success => Disregard); + end; + end if; + end Build_Dynamic_Library; + + -- Package initialization + + begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + end MLib.Tgt.Specific; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-specific-vxworks.adb gcc-4.4.0/gcc/ada/mlib-tgt-specific-vxworks.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-specific-vxworks.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-specific-vxworks.adb Fri Feb 20 15:20:38 2009 *************** *** 0 **** --- 1,217 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . S P E C I F I C -- + -- (VxWorks Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the VxWorks version of the body + + with Sdefault; + + package body MLib.Tgt.Specific is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Get_Target_Suffix return String; + -- Returns the required suffix for some utilities + -- (such as ar and ranlib) that depend on the real target. + + -- Non default subprograms + + function Archive_Builder return String; + + function Archive_Indexer return String; + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function Dynamic_Option return String; + + function Library_Major_Minor_Id_Supported return Boolean; + + function PIC_Option return String; + + function Standalone_Library_Auto_Init_Is_Supported return Boolean; + + function Support_For_Libraries return Library_Support; + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar" & Get_Target_Suffix; + end Archive_Builder; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib" & Get_Target_Suffix; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Ofiles); + pragma Unreferenced (Options); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Lib_Filename); + pragma Unreferenced (Lib_Dir); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Driver_Name); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Auto_Init); + + begin + null; + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return ""; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return ""; + end Dynamic_Option; + + ----------------------------- + -- Get_Target_Suffix -- + ----------------------------- + + function Get_Target_Suffix return String is + Target_Name : constant String := Sdefault.Target_Name.all; + Index : Positive := Target_Name'First; + + begin + while Index < Target_Name'Last + and then Target_Name (Index + 1) /= '-' + loop + Index := Index + 1; + end loop; + + if Target_Name (Target_Name'First .. Index) = "m68k" then + return "68k"; + elsif Target_Name (Target_Name'First .. Index) = "mips" then + return "mips"; + elsif Target_Name (Target_Name'First .. Index) = "powerpc" then + return "ppc"; + elsif Target_Name (Target_Name'First .. Index) = "sparc" then + return "sparc"; + elsif Target_Name (Target_Name'First .. Index) = "sparc64" then + return "sparc64"; + elsif Target_Name (Target_Name'First .. Index) = "xscale" then + return "arm"; + elsif Target_Name (Target_Name'First .. Index) = "i586" then + return "pentium"; + else + return ""; + end if; + end Get_Target_Suffix; + + -------------------------------------- + -- Library_Major_Minor_Id_Supported -- + -------------------------------------- + + function Library_Major_Minor_Id_Supported return Boolean is + begin + return False; + end Library_Major_Minor_Id_Supported; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return False; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Static_Only; + end Support_For_Libraries; + + begin + Archive_Builder_Ptr := Archive_Builder'Access; + Archive_Indexer_Ptr := Archive_Indexer'Access; + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Dynamic_Option_Ptr := Dynamic_Option'Access; + PIC_Option_Ptr := PIC_Option'Access; + Library_Major_Minor_Id_Supported_Ptr := + Library_Major_Minor_Id_Supported'Access; + Standalone_Library_Auto_Init_Is_Supported_Ptr := + Standalone_Library_Auto_Init_Is_Supported'Access; + Support_For_Libraries_Ptr := Support_For_Libraries'Access; + end MLib.Tgt.Specific; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-specific-xi.adb gcc-4.4.0/gcc/ada/mlib-tgt-specific-xi.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-specific-xi.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-specific-xi.adb Fri Feb 20 15:20:38 2009 *************** *** 0 **** --- 1,210 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T. S P E C I F I C -- + -- (Bare Board Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the bare board version of the body + + with Sdefault; + with Types; use Types; + + package body MLib.Tgt.Specific is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Get_Target_Prefix return String; + -- Returns the required prefix for some utilities + -- (such as ar and ranlib) that depend on the real target. + + -- Non default subprograms + + function Archive_Builder return String; + + function Archive_Indexer return String; + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function Dynamic_Option return String; + + function Library_Major_Minor_Id_Supported return Boolean; + + function PIC_Option return String; + + function Standalone_Library_Auto_Init_Is_Supported return Boolean; + + function Support_For_Libraries return Library_Support; + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return Get_Target_Prefix & "ar"; + end Archive_Builder; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return Get_Target_Prefix & "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Ofiles); + pragma Unreferenced (Options); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Lib_Filename); + pragma Unreferenced (Lib_Dir); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Driver_Name); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Auto_Init); + + begin + null; + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return ""; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return ""; + end Dynamic_Option; + + ----------------------- + -- Get_Target_Prefix -- + ----------------------- + + function Get_Target_Prefix return String is + Target_Name : constant String_Ptr := Sdefault.Target_Name; + Index : Positive := Target_Name'First; + + begin + while Index < Target_Name'Last + and then Target_Name (Index + 1) /= '-' + loop + Index := Index + 1; + end loop; + + if Target_Name (Target_Name'First .. Index) = "erc32" then + return "erc32-elf-"; + elsif Target_Name (Target_Name'First .. Index) = "leon" then + return "leon-elf-"; + elsif Target_Name (Target_Name'First .. Index) = "powerpc" then + return "powerpc-elf-"; + else + return ""; + end if; + end Get_Target_Prefix; + + -------------------------------------- + -- Library_Major_Minor_Id_Supported -- + -------------------------------------- + + function Library_Major_Minor_Id_Supported return Boolean is + begin + return False; + end Library_Major_Minor_Id_Supported; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return False; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Static_Only; + end Support_For_Libraries; + + begin + Archive_Builder_Ptr := Archive_Builder'Access; + Archive_Indexer_Ptr := Archive_Indexer'Access; + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Dynamic_Option_Ptr := Dynamic_Option'Access; + Library_Major_Minor_Id_Supported_Ptr := + Library_Major_Minor_Id_Supported'Access; + PIC_Option_Ptr := PIC_Option'Access; + Standalone_Library_Auto_Init_Is_Supported_Ptr := + Standalone_Library_Auto_Init_Is_Supported'Access; + Support_For_Libraries_Ptr := Support_For_Libraries'Access; + end MLib.Tgt.Specific; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-tru64.adb gcc-4.4.0/gcc/ada/mlib-tgt-tru64.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-tru64.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-tru64.adb Thu Jan 1 00:00:00 1970 *************** *** 1,168 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . S P E C I F I C -- - -- (True64 Version) -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2002-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the True64 version of the body - - with MLib.Fil; - with MLib.Utl; - with Opt; - with Output; use Output; - - package body MLib.Tgt.Specific is - - use MLib; - - -- Non default subprogram - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - function Is_Archive_Ext (Ext : String) return Boolean; - - function PIC_Option return String; - - -- Local variables - - Expect_Unresolved : aliased String := "-Wl,-expect_unresolved,*"; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Auto_Init); - -- Initialization is done through the contructor mechanism - - Lib_File : constant String := - "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); - - Lib_Path : constant String := - Lib_Dir & Directory_Separator & Lib_File; - - Version_Arg : String_Access; - Symbolic_Link_Needed : Boolean := False; - - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_Path); - end if; - - -- If specified, add automatic elaboration/finalization - - if Lib_Version = "" then - Utl.Gcc - (Output_File => Lib_Path, - Objects => Ofiles, - Options => Options & Expect_Unresolved'Access, - Options_2 => No_Argument_List, - Driver_Name => Driver_Name); - - else - declare - Maj_Version : constant String := - Major_Id_Name (Lib_File, Lib_Version); - begin - if Maj_Version'Length /= 0 then - Version_Arg := new String'("-Wl,-soname," & Maj_Version); - - else - Version_Arg := new String'("-Wl,-soname," & Lib_Version); - end if; - - if Is_Absolute_Path (Lib_Version) then - Utl.Gcc - (Output_File => Lib_Version, - Objects => Ofiles, - Options => - Options & Version_Arg & Expect_Unresolved'Access, - Options_2 => No_Argument_List, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := Lib_Version /= Lib_Path; - - else - Utl.Gcc - (Output_File => Lib_Dir & Directory_Separator & Lib_Version, - Objects => Ofiles, - Options => - Options & Version_Arg & Expect_Unresolved'Access, - Options_2 => No_Argument_List, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := - Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; - end if; - - if Symbolic_Link_Needed then - Create_Sym_Links - (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); - end if; - end; - end if; - end Build_Dynamic_Library; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a" or else Ext = ".so"; - end Is_Archive_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return ""; - end PIC_Option; - - begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; - Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; - PIC_Option_Ptr := PIC_Option'Access; - end MLib.Tgt.Specific; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-vms-alpha.adb gcc-4.4.0/gcc/ada/mlib-tgt-vms-alpha.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-vms-alpha.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-vms-alpha.adb Thu Jan 1 00:00:00 1970 *************** *** 1,501 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . S P E C I F I C -- - -- (Alpha VMS Version) -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2003-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the Alpha VMS version of the body - - with Ada.Characters.Handling; use Ada.Characters.Handling; - - with MLib.Fil; - with MLib.Utl; - - with MLib.Tgt.VMS; - pragma Warnings (Off, MLib.Tgt.VMS); - -- MLib.Tgt.VMS is with'ed only for elaboration purposes - - with Opt; use Opt; - with Output; use Output; - - with GNAT.Directory_Operations; use GNAT.Directory_Operations; - - with System; use System; - with System.Case_Util; use System.Case_Util; - with System.CRTL; use System.CRTL; - - package body MLib.Tgt.Specific is - - -- Non default subprogram. See comment in mlib-tgt.ads. - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - -- Local variables - - Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); - Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; - -- Used to add the generated auto-init object files for auto-initializing - -- stand-alone libraries. - - Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; - -- The name of the command to invoke the macro-assembler - - VMS_Options : Argument_List := (1 .. 1 => null); - - Gnatsym_Name : constant String := "gnatsym"; - - Gnatsym_Path : String_Access; - - Arguments : Argument_List_Access := null; - Last_Argument : Natural := 0; - - Success : Boolean := False; - - Shared_Libgcc : aliased String := "-shared-libgcc"; - - Shared_Libgcc_Switch : constant Argument_List := - (1 => Shared_Libgcc'Access); - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Filename, DLL_Ext); - - Opts : Argument_List := Options; - Last_Opt : Natural := Opts'Last; - Opts2 : Argument_List (Options'Range); - Last_Opt2 : Natural := Opts2'First - 1; - - Inter : constant Argument_List := Interfaces; - - function Is_Interface (Obj_File : String) return Boolean; - -- For a Stand-Alone Library, returns True if Obj_File is the object - -- file name of an interface of the SAL. For other libraries, always - -- return True. - - function Option_File_Name return String; - -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" - - function Version_String return String; - -- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is - -- not Autonomous, otherwise returns "". When Symbol_Data.Symbol_Policy - -- is Autonomous, fails gnatmake if Lib_Version is not the image of a - -- positive number. - - ------------------ - -- Is_Interface -- - ------------------ - - function Is_Interface (Obj_File : String) return Boolean is - ALI : constant String := - Fil.Ext_To - (Filename => To_Lower (Base_Name (Obj_File)), - New_Ext => "ali"); - - begin - if Inter'Length = 0 then - return True; - - elsif ALI'Length > 2 and then - ALI (ALI'First .. ALI'First + 2) = "b__" - then - return True; - - else - for J in Inter'Range loop - if Inter (J).all = ALI then - return True; - end if; - end loop; - - return False; - end if; - end Is_Interface; - - ---------------------- - -- Option_File_Name -- - ---------------------- - - function Option_File_Name return String is - begin - if Symbol_Data.Symbol_File = No_Path then - return "symvec.opt"; - else - Get_Name_String (Symbol_Data.Symbol_File); - To_Lower (Name_Buffer (1 .. Name_Len)); - return Name_Buffer (1 .. Name_Len); - end if; - end Option_File_Name; - - -------------------- - -- Version_String -- - -------------------- - - function Version_String return String is - Version : Integer := 0; - - begin - if Lib_Version = "" - or else Symbol_Data.Symbol_Policy /= Autonomous - then - return ""; - - else - begin - Version := Integer'Value (Lib_Version); - - if Version <= 0 then - raise Constraint_Error; - end if; - - return Lib_Version; - - exception - when Constraint_Error => - Fail ("illegal version """, Lib_Version, - """ (on VMS version must be a positive number)"); - return ""; - end; - end if; - end Version_String; - - --------------------- - -- Local Variables -- - --------------------- - - Opt_File_Name : constant String := Option_File_Name; - Version : constant String := Version_String; - For_Linker_Opt : String_Access; - - -- Start of processing for Build_Dynamic_Library - - begin - -- If option file name does not ends with ".opt", append "/OPTIONS" - -- to its specification for the VMS linker. - - if Opt_File_Name'Length > 4 - and then - Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt" - then - For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name); - else - For_Linker_Opt := - new String'("--for-linker=" & Opt_File_Name & "/OPTIONS"); - end if; - - VMS_Options (VMS_Options'First) := For_Linker_Opt; - - for J in Inter'Range loop - To_Lower (Inter (J).all); - end loop; - - -- "gnatsym" is necessary for building the option file - - if Gnatsym_Path = null then - Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name); - - if Gnatsym_Path = null then - Fail (Gnatsym_Name, " not found in path"); - end if; - end if; - - -- For auto-initialization of a stand-alone library, we create - -- a macro-assembly file and we invoke the macro-assembler. - - if Auto_Init then - declare - Macro_File_Name : constant String := Lib_Filename & "__init.asm"; - Macro_File : File_Descriptor; - Init_Proc : String := Lib_Filename & "INIT"; - Popen_Result : System.Address; - Pclose_Result : Integer; - Len : Natural; - OK : Boolean := True; - - command : constant String := - Macro_Name & " " & Macro_File_Name & ASCII.NUL; - -- The command to invoke the assembler on the generated auto-init - -- assembly file. - - mode : constant String := "r" & ASCII.NUL; - -- The mode for the invocation of Popen - - begin - To_Upper (Init_Proc); - - if Verbose_Mode then - Write_Str ("Creating auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - -- Create and write the auto-init assembly file - - declare - First_Line : constant String := - ASCII.HT & ".section LIB$INITIALIZE,GBL,NOWRT" & - ASCII.LF; - Second_Line : constant String := - ASCII.HT & ".long " & Init_Proc & ASCII.LF; - -- First and second lines of the auto-init assembly file - - begin - Macro_File := Create_File (Macro_File_Name, Text); - OK := Macro_File /= Invalid_FD; - - if OK then - Len := Write - (Macro_File, First_Line (First_Line'First)'Address, - First_Line'Length); - OK := Len = First_Line'Length; - end if; - - if OK then - Len := Write - (Macro_File, Second_Line (Second_Line'First)'Address, - Second_Line'Length); - OK := Len = Second_Line'Length; - end if; - - if OK then - Close (Macro_File, OK); - end if; - - if not OK then - Fail ("creation of auto-init assembly file """, - Macro_File_Name, """ failed"); - end if; - end; - - -- Invoke the macro-assembler - - if Verbose_Mode then - Write_Str ("Assembling auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - Popen_Result := popen (command (command'First)'Address, - mode (mode'First)'Address); - - if Popen_Result = Null_Address then - Fail ("assembly of auto-init assembly file """, - Macro_File_Name, """ failed"); - end if; - - -- Wait for the end of execution of the macro-assembler - - Pclose_Result := pclose (Popen_Result); - - if Pclose_Result < 0 then - Fail ("assembly of auto init assembly file """, - Macro_File_Name, """ failed"); - end if; - - -- Add the generated object file to the list of objects to be - -- included in the library. - - Additional_Objects := - new Argument_List' - (1 => new String'(Lib_Filename & "__init.obj")); - end; - end if; - - -- Allocate the argument list and put the symbol file name, the - -- reference (if any) and the policy (if not autonomous). - - Arguments := new Argument_List (1 .. Ofiles'Length + 8); - - Last_Argument := 0; - - -- Verbosity - - if Verbose_Mode then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-v"); - end if; - - -- Version number (major ID) - - if Lib_Version /= "" then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-V"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Version); - end if; - - -- Symbol file - - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-s"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Opt_File_Name); - - -- Reference Symbol File - - if Symbol_Data.Reference /= No_Path then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-r"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := - new String'(Get_Name_String (Symbol_Data.Reference)); - end if; - - -- Policy - - case Symbol_Data.Symbol_Policy is - when Autonomous => - null; - - when Compliant => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-c"); - - when Controlled => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-C"); - - when Restricted => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-R"); - - when Direct => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-D"); - - end case; - - -- Add each relevant object file - - for Index in Ofiles'Range loop - if Is_Interface (Ofiles (Index).all) then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Ofiles (Index).all); - end if; - end loop; - - -- Spawn gnatsym - - Spawn (Program_Name => Gnatsym_Path.all, - Args => Arguments (1 .. Last_Argument), - Success => Success); - - if not Success then - Fail ("unable to create symbol file for library """, - Lib_Filename, """"); - end if; - - Free (Arguments); - - -- Move all the -l switches from Opts to Opts2 - - declare - Index : Natural := Opts'First; - Opt : String_Access; - - begin - while Index <= Last_Opt loop - Opt := Opts (Index); - - if Opt'Length > 2 and then - Opt (Opt'First .. Opt'First + 1) = "-l" - then - if Index < Last_Opt then - Opts (Index .. Last_Opt - 1) := - Opts (Index + 1 .. Last_Opt); - end if; - - Last_Opt := Last_Opt - 1; - - Last_Opt2 := Last_Opt2 + 1; - Opts2 (Last_Opt2) := Opt; - - else - Index := Index + 1; - end if; - end loop; - end; - - -- Invoke gcc to build the library - - Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles & Additional_Objects.all, - Options => VMS_Options, - Options_2 => Shared_Libgcc_Switch & - Opts (Opts'First .. Last_Opt) & - Opts2 (Opts2'First .. Last_Opt2), - Driver_Name => Driver_Name); - - -- The auto-init object file need to be deleted, so that it will not - -- be included in the library as a regular object file, otherwise - -- it will be included twice when the library will be built next - -- time, which may lead to errors. - - if Auto_Init then - declare - Auto_Init_Object_File_Name : constant String := - Lib_Filename & "__init.obj"; - Disregard : Boolean; - - begin - if Verbose_Mode then - Write_Str ("deleting auto-init object file """); - Write_Str (Auto_Init_Object_File_Name); - Write_Line (""""); - end if; - - Delete_File (Auto_Init_Object_File_Name, Success => Disregard); - end; - end if; - end Build_Dynamic_Library; - - -- Package initialization - - begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; - end MLib.Tgt.Specific; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-vms-ia64.adb gcc-4.4.0/gcc/ada/mlib-tgt-vms-ia64.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-vms-ia64.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-vms-ia64.adb Thu Jan 1 00:00:00 1970 *************** *** 1,536 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . S P E C I F I C -- - -- (Integrity VMS Version) -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2004-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the Integrity VMS version of the body - - with Ada.Characters.Handling; use Ada.Characters.Handling; - - with MLib.Fil; - with MLib.Utl; - - with MLib.Tgt.VMS; - pragma Warnings (Off, MLib.Tgt.VMS); - -- MLib.Tgt.VMS is with'ed only for elaboration purposes - - with Opt; use Opt; - with Output; use Output; - - with GNAT.Directory_Operations; use GNAT.Directory_Operations; - - with System; use System; - with System.Case_Util; use System.Case_Util; - with System.CRTL; use System.CRTL; - - package body MLib.Tgt.Specific is - - -- Non default subprogram. See comment in mlib-tgt.ads. - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - -- Local variables - - Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); - Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; - -- Used to add the generated auto-init object files for auto-initializing - -- stand-alone libraries. - - Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; - -- The name of the command to invoke the macro-assembler - - VMS_Options : Argument_List := (1 .. 1 => null); - - Gnatsym_Name : constant String := "gnatsym"; - - Gnatsym_Path : String_Access; - - Arguments : Argument_List_Access := null; - Last_Argument : Natural := 0; - - Success : Boolean := False; - - Shared_Libgcc : aliased String := "-shared-libgcc"; - - Shared_Libgcc_Switch : constant Argument_List := - (1 => Shared_Libgcc'Access); - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Filename, DLL_Ext); - - Opts : Argument_List := Options; - Last_Opt : Natural := Opts'Last; - Opts2 : Argument_List (Options'Range); - Last_Opt2 : Natural := Opts2'First - 1; - - Inter : constant Argument_List := Interfaces; - - function Is_Interface (Obj_File : String) return Boolean; - -- For a Stand-Alone Library, returns True if Obj_File is the object - -- file name of an interface of the SAL. For other libraries, always - -- return True. - - function Option_File_Name return String; - -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" - - function Version_String return String; - -- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is - -- not Autonomous, otherwise returns "". When Symbol_Data.Symbol_Policy - -- is Autonomous, fails gnatmake if Lib_Version is not the image of a - -- positive number. - - ------------------ - -- Is_Interface -- - ------------------ - - function Is_Interface (Obj_File : String) return Boolean is - ALI : constant String := - Fil.Ext_To - (Filename => To_Lower (Base_Name (Obj_File)), - New_Ext => "ali"); - - begin - if Inter'Length = 0 then - return True; - - elsif ALI'Length > 2 and then - ALI (ALI'First .. ALI'First + 2) = "b__" - then - return True; - - else - for J in Inter'Range loop - if Inter (J).all = ALI then - return True; - end if; - end loop; - - return False; - end if; - end Is_Interface; - - ---------------------- - -- Option_File_Name -- - ---------------------- - - function Option_File_Name return String is - begin - if Symbol_Data.Symbol_File = No_Path then - return "symvec.opt"; - else - Get_Name_String (Symbol_Data.Symbol_File); - To_Lower (Name_Buffer (1 .. Name_Len)); - return Name_Buffer (1 .. Name_Len); - end if; - end Option_File_Name; - - -------------------- - -- Version_String -- - -------------------- - - function Version_String return String is - Version : Integer := 0; - begin - if Lib_Version = "" - or else Symbol_Data.Symbol_Policy /= Autonomous - then - return ""; - - else - begin - Version := Integer'Value (Lib_Version); - - if Version <= 0 then - raise Constraint_Error; - end if; - - return Lib_Version; - - exception - when Constraint_Error => - Fail ("illegal version """, Lib_Version, - """ (on VMS version must be a positive number)"); - return ""; - end; - end if; - end Version_String; - - --------------------- - -- Local Variables -- - --------------------- - - Opt_File_Name : constant String := Option_File_Name; - Version : constant String := Version_String; - For_Linker_Opt : String_Access; - - -- Start of processing for Build_Dynamic_Library - - begin - -- Option file must end with ".opt" - - if Opt_File_Name'Length > 4 - and then - Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt" - then - For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name); - else - Fail ("Options File """, Opt_File_Name, """ must end with .opt"); - end if; - - VMS_Options (VMS_Options'First) := For_Linker_Opt; - - for J in Inter'Range loop - To_Lower (Inter (J).all); - end loop; - - -- "gnatsym" is necessary for building the option file - - if Gnatsym_Path = null then - Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name); - - if Gnatsym_Path = null then - Fail (Gnatsym_Name, " not found in path"); - end if; - end if; - - -- For auto-initialization of a stand-alone library, we create - -- a macro-assembly file and we invoke the macro-assembler. - - if Auto_Init then - declare - Macro_File_Name : constant String := Lib_Filename & "__init.asm"; - Macro_File : File_Descriptor; - Init_Proc : String := Lib_Filename & "INIT"; - Popen_Result : System.Address; - Pclose_Result : Integer; - Len : Natural; - OK : Boolean := True; - - command : constant String := - Macro_Name & " " & Macro_File_Name & ASCII.NUL; - -- The command to invoke the assembler on the generated auto-init - -- assembly file. - -- Why odd lower case name ??? - - mode : constant String := "r" & ASCII.NUL; - -- The mode for the invocation of Popen - -- Why odd lower case name ??? - - begin - To_Upper (Init_Proc); - - if Verbose_Mode then - Write_Str ("Creating auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - -- Create and write the auto-init assembly file - - declare - First_Line : constant String := - ASCII.HT - & ".type " & Init_Proc & "#, @function" - & ASCII.LF; - Second_Line : constant String := - ASCII.HT - & ".global " & Init_Proc & "#" - & ASCII.LF; - Third_Line : constant String := - ASCII.HT - & ".global LIB$INITIALIZE#" - & ASCII.LF; - Fourth_Line : constant String := - ASCII.HT - & ".section LIB$INITIALIZE#,""a"",@progbits" - & ASCII.LF; - Fifth_Line : constant String := - ASCII.HT - & "data4 @fptr(" & Init_Proc & "#)" - & ASCII.LF; - - begin - Macro_File := Create_File (Macro_File_Name, Text); - OK := Macro_File /= Invalid_FD; - - if OK then - Len := Write - (Macro_File, First_Line (First_Line'First)'Address, - First_Line'Length); - OK := Len = First_Line'Length; - end if; - - if OK then - Len := Write - (Macro_File, Second_Line (Second_Line'First)'Address, - Second_Line'Length); - OK := Len = Second_Line'Length; - end if; - - if OK then - Len := Write - (Macro_File, Third_Line (Third_Line'First)'Address, - Third_Line'Length); - OK := Len = Third_Line'Length; - end if; - - if OK then - Len := Write - (Macro_File, Fourth_Line (Fourth_Line'First)'Address, - Fourth_Line'Length); - OK := Len = Fourth_Line'Length; - end if; - - if OK then - Len := Write - (Macro_File, Fifth_Line (Fifth_Line'First)'Address, - Fifth_Line'Length); - OK := Len = Fifth_Line'Length; - end if; - - if OK then - Close (Macro_File, OK); - end if; - - if not OK then - Fail ("creation of auto-init assembly file """, - Macro_File_Name, """ failed"); - end if; - end; - - -- Invoke the macro-assembler - - if Verbose_Mode then - Write_Str ("Assembling auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - Popen_Result := popen (command (command'First)'Address, - mode (mode'First)'Address); - - if Popen_Result = Null_Address then - Fail ("assembly of auto-init assembly file """, - Macro_File_Name, """ failed"); - end if; - - -- Wait for the end of execution of the macro-assembler - - Pclose_Result := pclose (Popen_Result); - - if Pclose_Result < 0 then - Fail ("assembly of auto init assembly file """, - Macro_File_Name, """ failed"); - end if; - - -- Add the generated object file to the list of objects to be - -- included in the library. - - Additional_Objects := - new Argument_List' - (1 => new String'(Lib_Filename & "__init.obj")); - end; - end if; - - -- Allocate the argument list and put the symbol file name, the - -- reference (if any) and the policy (if not autonomous). - - Arguments := new Argument_List (1 .. Ofiles'Length + 8); - - Last_Argument := 0; - - -- Verbosity - - if Verbose_Mode then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-v"); - end if; - - -- Version number (major ID) - - if Lib_Version /= "" then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-V"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Version); - end if; - - -- Symbol file - - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-s"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Opt_File_Name); - - -- Reference Symbol File - - if Symbol_Data.Reference /= No_Path then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-r"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := - new String'(Get_Name_String (Symbol_Data.Reference)); - end if; - - -- Policy - - case Symbol_Data.Symbol_Policy is - when Autonomous => - null; - - when Compliant => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-c"); - - when Controlled => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-C"); - - when Restricted => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-R"); - - when Direct => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-D"); - end case; - - -- Add each relevant object file - - for Index in Ofiles'Range loop - if Is_Interface (Ofiles (Index).all) then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Ofiles (Index).all); - end if; - end loop; - - -- Spawn gnatsym - - Spawn (Program_Name => Gnatsym_Path.all, - Args => Arguments (1 .. Last_Argument), - Success => Success); - - if not Success then - Fail ("unable to create symbol file for library """, - Lib_Filename, """"); - end if; - - Free (Arguments); - - -- Move all the -l switches from Opts to Opts2 - - declare - Index : Natural := Opts'First; - Opt : String_Access; - - begin - while Index <= Last_Opt loop - Opt := Opts (Index); - - if Opt'Length > 2 and then - Opt (Opt'First .. Opt'First + 1) = "-l" - then - if Index < Last_Opt then - Opts (Index .. Last_Opt - 1) := - Opts (Index + 1 .. Last_Opt); - end if; - - Last_Opt := Last_Opt - 1; - - Last_Opt2 := Last_Opt2 + 1; - Opts2 (Last_Opt2) := Opt; - - else - Index := Index + 1; - end if; - end loop; - end; - - -- Invoke gcc to build the library - - Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles & Additional_Objects.all, - Options => VMS_Options, - Options_2 => Shared_Libgcc_Switch & - Opts (Opts'First .. Last_Opt) & - Opts2 (Opts2'First .. Last_Opt2), - Driver_Name => Driver_Name); - - -- The auto-init object file need to be deleted, so that it will not - -- be included in the library as a regular object file, otherwise - -- it will be included twice when the library will be built next - -- time, which may lead to errors. - - if Auto_Init then - declare - Auto_Init_Object_File_Name : constant String := - Lib_Filename & "__init.obj"; - - Disregard : Boolean; - pragma Warnings (Off, Disregard); - - begin - if Verbose_Mode then - Write_Str ("deleting auto-init object file """); - Write_Str (Auto_Init_Object_File_Name); - Write_Line (""""); - end if; - - Delete_File (Auto_Init_Object_File_Name, Success => Disregard); - end; - end if; - end Build_Dynamic_Library; - - -- Package initialization - - begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; - end MLib.Tgt.Specific; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-vms.adb gcc-4.4.0/gcc/ada/mlib-tgt-vms.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-vms.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-vms.adb Thu Jan 1 00:00:00 1970 *************** *** 1,155 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . V M S -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2003-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the part of MLib.Tgt.Specific common to both VMS versions - - package body MLib.Tgt.VMS is - - -- Non default subprograms. See comments in mlib-tgt.ads - - function Archive_Ext return String; - - function Default_Symbol_File_Name return String; - - function DLL_Ext return String; - - function Is_Object_Ext (Ext : String) return Boolean; - - function Is_Archive_Ext (Ext : String) return Boolean; - - function Libgnat return String; - - function Object_Ext return String; - - function Library_Major_Minor_Id_Supported return Boolean; - - function PIC_Option return String; - - ----------------- - -- Archive_Ext -- - ----------------- - - function Archive_Ext return String is - begin - return "olb"; - end Archive_Ext; - - ------------------------------ - -- Default_Symbol_File_Name -- - ------------------------------ - - function Default_Symbol_File_Name return String is - begin - return "symvec.opt"; - end Default_Symbol_File_Name; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "exe"; - end DLL_Ext; - - ------------------- - -- Is_Object_Ext -- - ------------------- - - function Is_Object_Ext (Ext : String) return Boolean is - begin - return Ext = ".obj"; - end Is_Object_Ext; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".olb" or else Ext = ".exe"; - end Is_Archive_Ext; - - ------------- - -- Libgnat -- - ------------- - - function Libgnat return String is - Libgnat_A : constant String := "libgnat.a"; - Libgnat_Olb : constant String := "libgnat.olb"; - - begin - Name_Len := Libgnat_A'Length; - Name_Buffer (1 .. Name_Len) := Libgnat_A; - - if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then - return Libgnat_A; - else - return Libgnat_Olb; - end if; - end Libgnat; - - -------------------------------------- - -- Library_Major_Minor_Id_Supported -- - -------------------------------------- - - function Library_Major_Minor_Id_Supported return Boolean is - begin - return False; - end Library_Major_Minor_Id_Supported; - - ---------------- - -- Object_Ext -- - ---------------- - - function Object_Ext return String is - begin - return "obj"; - end Object_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return ""; - end PIC_Option; - - -- Package initialization - - begin - Archive_Ext_Ptr := Archive_Ext'Access; - Default_Symbol_File_Name_Ptr := Default_Symbol_File_Name'Access; - DLL_Ext_Ptr := DLL_Ext'Access; - Is_Object_Ext_Ptr := Is_Object_Ext'Access; - Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; - Libgnat_Ptr := Libgnat'Access; - Object_Ext_Ptr := Object_Ext'Access; - PIC_Option_Ptr := PIC_Option'Access; - Library_Major_Minor_Id_Supported_Ptr := - Library_Major_Minor_Id_Supported'Access; - - end MLib.Tgt.VMS; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-vms.ads gcc-4.4.0/gcc/ada/mlib-tgt-vms.ads *** gcc-4.3.3/gcc/ada/mlib-tgt-vms.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-vms.ads Thu Jan 1 00:00:00 1970 *************** *** 1,30 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . V M S -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the part of MLib.Tgt.Specific common to both VMS versions - - package MLib.Tgt.VMS is - pragma Elaborate_Body; - end MLib.Tgt.VMS; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-vms_common.adb gcc-4.4.0/gcc/ada/mlib-tgt-vms_common.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-vms_common.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-vms_common.adb Tue Apr 8 06:44:24 2008 *************** *** 0 **** --- 1,155 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . V M S _ C O M M O N -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the part of MLib.Tgt.Specific common to both VMS versions + + package body MLib.Tgt.VMS_Common is + + -- Non default subprograms. See comments in mlib-tgt.ads + + function Archive_Ext return String; + + function Default_Symbol_File_Name return String; + + function DLL_Ext return String; + + function Is_Object_Ext (Ext : String) return Boolean; + + function Is_Archive_Ext (Ext : String) return Boolean; + + function Libgnat return String; + + function Object_Ext return String; + + function Library_Major_Minor_Id_Supported return Boolean; + + function PIC_Option return String; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "olb"; + end Archive_Ext; + + ------------------------------ + -- Default_Symbol_File_Name -- + ------------------------------ + + function Default_Symbol_File_Name return String is + begin + return "symvec.opt"; + end Default_Symbol_File_Name; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "exe"; + end DLL_Ext; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".obj"; + end Is_Object_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".olb" or else Ext = ".exe"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + Libgnat_A : constant String := "libgnat.a"; + Libgnat_Olb : constant String := "libgnat.olb"; + + begin + Name_Len := Libgnat_A'Length; + Name_Buffer (1 .. Name_Len) := Libgnat_A; + + if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then + return Libgnat_A; + else + return Libgnat_Olb; + end if; + end Libgnat; + + -------------------------------------- + -- Library_Major_Minor_Id_Supported -- + -------------------------------------- + + function Library_Major_Minor_Id_Supported return Boolean is + begin + return False; + end Library_Major_Minor_Id_Supported; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "obj"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + -- Package initialization + + begin + Archive_Ext_Ptr := Archive_Ext'Access; + Default_Symbol_File_Name_Ptr := Default_Symbol_File_Name'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Is_Object_Ext_Ptr := Is_Object_Ext'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; + Libgnat_Ptr := Libgnat'Access; + Object_Ext_Ptr := Object_Ext'Access; + PIC_Option_Ptr := PIC_Option'Access; + Library_Major_Minor_Id_Supported_Ptr := + Library_Major_Minor_Id_Supported'Access; + + end MLib.Tgt.VMS_Common; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-vms_common.ads gcc-4.4.0/gcc/ada/mlib-tgt-vms_common.ads *** gcc-4.3.3/gcc/ada/mlib-tgt-vms_common.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/mlib-tgt-vms_common.ads Tue Apr 8 06:44:24 2008 *************** *** 0 **** --- 1,30 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T . V M S _ C O M M O N -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2007-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the part of MLib.Tgt.Specific common to both VMS versions + + package MLib.Tgt.VMS_Common is + pragma Elaborate_Body; + end MLib.Tgt.VMS_Common; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt-vxworks.adb gcc-4.4.0/gcc/ada/mlib-tgt-vxworks.adb *** gcc-4.3.3/gcc/ada/mlib-tgt-vxworks.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt-vxworks.adb Thu Jan 1 00:00:00 1970 *************** *** 1,217 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- M L I B . T G T . S P E C I F I C -- - -- (VxWorks Version) -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 2003-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the VxWorks version of the body - - with Sdefault; - - package body MLib.Tgt.Specific is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Get_Target_Suffix return String; - -- Returns the required suffix for some utilities - -- (such as ar and ranlib) that depend on the real target. - - -- Non default subprograms - - function Archive_Builder return String; - - function Archive_Indexer return String; - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - function DLL_Ext return String; - - function Dynamic_Option return String; - - function Library_Major_Minor_Id_Supported return Boolean; - - function PIC_Option return String; - - function Standalone_Library_Auto_Init_Is_Supported return Boolean; - - function Support_For_Libraries return Library_Support; - - --------------------- - -- Archive_Builder -- - --------------------- - - function Archive_Builder return String is - begin - return "ar" & Get_Target_Suffix; - end Archive_Builder; - - --------------------- - -- Archive_Indexer -- - --------------------- - - function Archive_Indexer return String is - begin - return "ranlib" & Get_Target_Suffix; - end Archive_Indexer; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Ofiles); - pragma Unreferenced (Options); - pragma Unreferenced (Interfaces); - pragma Unreferenced (Lib_Filename); - pragma Unreferenced (Lib_Dir); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Driver_Name); - pragma Unreferenced (Lib_Version); - pragma Unreferenced (Auto_Init); - - begin - null; - end Build_Dynamic_Library; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return ""; - end DLL_Ext; - - -------------------- - -- Dynamic_Option -- - -------------------- - - function Dynamic_Option return String is - begin - return ""; - end Dynamic_Option; - - ----------------------------- - -- Get_Target_Suffix -- - ----------------------------- - - function Get_Target_Suffix return String is - Target_Name : constant String := Sdefault.Target_Name.all; - Index : Positive := Target_Name'First; - - begin - while Index < Target_Name'Last - and then Target_Name (Index + 1) /= '-' - loop - Index := Index + 1; - end loop; - - if Target_Name (Target_Name'First .. Index) = "m68k" then - return "68k"; - elsif Target_Name (Target_Name'First .. Index) = "mips" then - return "mips"; - elsif Target_Name (Target_Name'First .. Index) = "powerpc" then - return "ppc"; - elsif Target_Name (Target_Name'First .. Index) = "sparc" then - return "sparc"; - elsif Target_Name (Target_Name'First .. Index) = "sparc64" then - return "sparc64"; - elsif Target_Name (Target_Name'First .. Index) = "xscale" then - return "arm"; - elsif Target_Name (Target_Name'First .. Index) = "i586" then - return "pentium"; - else - return ""; - end if; - end Get_Target_Suffix; - - -------------------------------------- - -- Library_Major_Minor_Id_Supported -- - -------------------------------------- - - function Library_Major_Minor_Id_Supported return Boolean is - begin - return False; - end Library_Major_Minor_Id_Supported; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return ""; - end PIC_Option; - - ----------------------------------------------- - -- Standalone_Library_Auto_Init_Is_Supported -- - ----------------------------------------------- - - function Standalone_Library_Auto_Init_Is_Supported return Boolean is - begin - return False; - end Standalone_Library_Auto_Init_Is_Supported; - - --------------------------- - -- Support_For_Libraries -- - --------------------------- - - function Support_For_Libraries return Library_Support is - begin - return Static_Only; - end Support_For_Libraries; - - begin - Archive_Builder_Ptr := Archive_Builder'Access; - Archive_Indexer_Ptr := Archive_Indexer'Access; - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; - DLL_Ext_Ptr := DLL_Ext'Access; - Dynamic_Option_Ptr := Dynamic_Option'Access; - PIC_Option_Ptr := PIC_Option'Access; - Library_Major_Minor_Id_Supported_Ptr := - Library_Major_Minor_Id_Supported'Access; - Standalone_Library_Auto_Init_Is_Supported_Ptr := - Standalone_Library_Auto_Init_Is_Supported'Access; - Support_For_Libraries_Ptr := Support_For_Libraries'Access; - end MLib.Tgt.Specific; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt.adb gcc-4.4.0/gcc/ada/mlib-tgt.adb *** gcc-4.3.3/gcc/ada/mlib-tgt.adb Thu Dec 13 10:59:30 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt.adb Tue May 27 11:00:07 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** package body MLib.Tgt is *** 340,346 **** declare Lib_Dir : constant String := Get_Name_String ! (In_Tree.Projects.Table (Project).Library_Dir); Lib_Name : constant String := Get_Name_String (In_Tree.Projects.Table (Project).Library_Name); --- 340,346 ---- declare Lib_Dir : constant String := Get_Name_String ! (In_Tree.Projects.Table (Project).Library_Dir.Name); Lib_Name : constant String := Get_Name_String (In_Tree.Projects.Table (Project).Library_Name); diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-tgt.ads gcc-4.4.0/gcc/ada/mlib-tgt.ads *** gcc-4.3.3/gcc/ada/mlib-tgt.ads Fri Dec 7 22:19:22 2007 --- gcc-4.4.0/gcc/ada/mlib-tgt.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** *** 23,33 **** -- -- ------------------------------------------------------------------------------ ! -- This package provides a set of target dependent routines to build ! -- static, dynamic and shared libraries. There are several packages ! -- providing the actual routines; this package calls them indirectly ! -- by means of access-to-subprogram values; each target-dependent ! -- package initializes these values in its elaboration block. with Prj; use Prj; --- 23,33 ---- -- -- ------------------------------------------------------------------------------ ! -- This package provides a set of target dependent routines to build static, ! -- dynamic and shared libraries. There are several packages providing ! -- the actual routines. This package calls them indirectly by means of ! -- access-to-subprogram values. Each target-dependent package initializes ! -- these values in its elaboration block. with Prj; use Prj; *************** package MLib.Tgt is *** 132,138 **** -- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which -- will be the actual library file. -- ! -- Symbol_Data is used for some patforms, including VMS, to generate -- the symbols to be exported by the library. -- -- Note: Depending on the OS, some of the parameters may not be taken into --- 132,138 ---- -- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which -- will be the actual library file. -- ! -- Symbol_Data is used for some platforms, including VMS, to generate -- the symbols to be exported by the library. -- -- Note: Depending on the OS, some of the parameters may not be taken into *************** package MLib.Tgt is *** 153,159 **** function Library_Major_Minor_Id_Supported return Boolean; -- Indicates if major and minor ids are supported for libraries. -- If they are supported, then a Library_Version such as libtoto.so.1.2 ! -- will have a major id of 1 and a minor id of 2. Then litoto.so, -- libtoto.so.1 and libtoto.so.1.2 will be created, all three designating -- the same file. --- 153,159 ---- function Library_Major_Minor_Id_Supported return Boolean; -- Indicates if major and minor ids are supported for libraries. -- If they are supported, then a Library_Version such as libtoto.so.1.2 ! -- will have a major id of 1 and a minor id of 2. Then libtoto.so, -- libtoto.so.1 and libtoto.so.1.2 will be created, all three designating -- the same file. diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-utl.adb gcc-4.4.0/gcc/ada/mlib-utl.adb *** gcc-4.3.3/gcc/ada/mlib-utl.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-utl.adb Fri Aug 1 09:03:11 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2008, AdaCore -- -- -- -- 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- -- *************** with System; *** 35,40 **** --- 35,44 ---- package body MLib.Utl is + Adalib_Path : String_Access := null; + -- Path of the GNAT adalib directory, specified in procedure + -- Specify_Adalib_Dir. Used in function Lib_Directory. + Gcc_Name : String_Access; -- Default value of the "gcc" executable used in procedure Gcc *************** package body MLib.Utl is *** 136,142 **** begin if Ar_Exec = null then ! Ar_Name := Osint.Program_Name (Archive_Builder); Ar_Exec := Locate_Exec_On_Path (Ar_Name.all); if Ar_Exec = null then --- 140,146 ---- begin if Ar_Exec = null then ! Ar_Name := Osint.Program_Name (Archive_Builder, "gnatmake"); Ar_Exec := Locate_Exec_On_Path (Ar_Name.all); if Ar_Exec = null then *************** package body MLib.Utl is *** 177,183 **** -- ranlib ! Ranlib_Name := Osint.Program_Name (Archive_Indexer); if Ranlib_Name'Length > 0 then Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all); --- 181,187 ---- -- ranlib ! Ranlib_Name := Osint.Program_Name (Archive_Indexer, "gnatmake"); if Ranlib_Name'Length > 0 then Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all); *************** package body MLib.Utl is *** 299,305 **** ----------------- procedure Delete_File (Filename : String) is ! File : constant String := Filename & ASCII.Nul; Success : Boolean; begin --- 303,309 ---- ----------------- procedure Delete_File (Filename : String) is ! File : constant String := Filename & ASCII.NUL; Success : Boolean; begin *************** package body MLib.Utl is *** 408,414 **** if Driver_Name = No_Name then if Gcc_Exec = null then if Gcc_Name = null then ! Gcc_Name := Osint.Program_Name ("gcc"); end if; Gcc_Exec := Locate_Exec_On_Path (Gcc_Name.all); --- 412,418 ---- if Driver_Name = No_Name then if Gcc_Exec = null then if Gcc_Name = null then ! Gcc_Name := Osint.Program_Name ("gcc", "gnatmake"); end if; Gcc_Exec := Locate_Exec_On_Path (Gcc_Name.all); *************** package body MLib.Utl is *** 597,602 **** --- 601,613 ---- Libgnat : constant String := Tgt.Libgnat; begin + -- If procedure Specify_Adalib_Dir has been called, used the specified + -- value. + + if Adalib_Path /= null then + return Adalib_Path.all; + end if; + Name_Len := Libgnat'Length; Name_Buffer (1 .. Name_Len) := Libgnat; Get_Name_String (Osint.Find_File (Name_Enter, Osint.Library)); *************** package body MLib.Utl is *** 606,609 **** --- 617,633 ---- return Name_Buffer (1 .. Name_Len - Libgnat'Length); end Lib_Directory; + ------------------------ + -- Specify_Adalib_Dir -- + ------------------------ + + procedure Specify_Adalib_Dir (Path : String) is + begin + if Path'Length = 0 then + Adalib_Path := null; + else + Adalib_Path := new String'(Path); + end if; + end Specify_Adalib_Dir; + end MLib.Utl; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib-utl.ads gcc-4.4.0/gcc/ada/mlib-utl.ads *** gcc-4.3.3/gcc/ada/mlib-utl.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/mlib-utl.ads Fri Aug 1 09:03:11 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, AdaCore -- -- -- -- 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- -- *************** package MLib.Utl is *** 47,58 **** procedure Ar (Output_File : String; Objects : Argument_List); ! -- Run ar to move all the binaries inside the archive. If ranlib is on the ! -- path, run it also. Output_File is the path name of the archive to -- create. Objects is the list of the path names of the object files to be ! -- put in the archive. function Lib_Directory return String; -- Return the directory containing libgnat end MLib.Utl; --- 47,67 ---- procedure Ar (Output_File : String; Objects : Argument_List); ! -- Run ar to move all the binaries inside the archive. If ranlib is on ! -- the path, run it also. Output_File is the path name of the archive to -- create. Objects is the list of the path names of the object files to be ! -- put in the archive. This procedure currently assumes that it is always ! -- called in the context of gnatmake. If other executables start using this ! -- procedure, an additional parameter would need to be added, and calls to ! -- Osint.Program_Name updated accordingly in the body. function Lib_Directory return String; -- Return the directory containing libgnat + procedure Specify_Adalib_Dir (Path : String); + -- Specify the path of the GNAT adalib directory, to be returned by + -- function Lib_Directory without looking for it. This is used only in + -- gprlib, because we cannot rely on the search in Lib_Directory, as the + -- GNAT version may be different for gprbuild/gprlib and the compiler. + end MLib.Utl; diff -Nrcpad gcc-4.3.3/gcc/ada/mlib.adb gcc-4.4.0/gcc/ada/mlib.adb *** gcc-4.3.3/gcc/ada/mlib.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/mlib.adb Tue Aug 5 09:28:55 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- 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- -- *************** package body MLib is *** 263,273 **** -- Set Success to True only if the newly -- created file has been correctly written. ! Success := Status and Actual_Len = Len + 3; if Success then ! Set_Read_Only ( ! Name_Buffer (1 .. Name_Len - 1)); end if; end if; end if; --- 263,278 ---- -- Set Success to True only if the newly -- created file has been correctly written. ! Success := Status and then Actual_Len = Len + 3; if Success then ! ! -- Set_Read_Only is used here, rather than ! -- Set_Non_Writable, so that gprbuild can ! -- he compiled with older compilers. ! ! Set_Read_Only ! (Name_Buffer (1 .. Name_Len - 1)); end if; end if; end if; *************** package body MLib is *** 310,327 **** pragma Unreferenced (Success, Result); begin ! if Is_Absolute_Path (Lib_Version) then ! Version_Path := new String (1 .. Lib_Version'Length + 1); ! Version_Path (1 .. Lib_Version'Length) := Lib_Version; ! ! else ! Version_Path := ! new String (1 .. Lib_Dir'Length + 1 + Lib_Version'Length + 1); ! Version_Path (1 .. Version_Path'Last - 1) := ! Lib_Dir & Directory_Separator & Lib_Version; ! end if; ! ! Version_Path (Version_Path'Last) := ASCII.NUL; if Maj_Version'Length = 0 then declare --- 315,323 ---- pragma Unreferenced (Success, Result); begin ! Version_Path := new String (1 .. Lib_Version'Length + 1); ! Version_Path (1 .. Lib_Version'Length) := Lib_Version; ! Version_Path (Version_Path'Last) := ASCII.NUL; if Maj_Version'Length = 0 then declare *************** package body MLib is *** 339,344 **** --- 335,341 ---- Maj_Path : constant String := Lib_Dir & Directory_Separator & Maj_Version; Newpath2 : String (1 .. Maj_Path'Length + 1); + Maj_Ver : String (1 .. Maj_Version'Length + 1); begin Newpath1 (1 .. Lib_Path'Length) := Lib_Path; *************** package body MLib is *** 347,359 **** Newpath2 (1 .. Maj_Path'Length) := Maj_Path; Newpath2 (Newpath2'Last) := ASCII.NUL; Delete_File (Maj_Path, Success); Result := Symlink (Version_Path (1)'Address, Newpath2'Address); Delete_File (Lib_Path, Success); ! Result := Symlink (Newpath2'Address, Newpath1'Address); end; end if; end Create_Sym_Links; --- 344,359 ---- Newpath2 (1 .. Maj_Path'Length) := Maj_Path; Newpath2 (Newpath2'Last) := ASCII.NUL; + Maj_Ver (1 .. Maj_Version'Length) := Maj_Version; + Maj_Ver (Maj_Ver'Last) := ASCII.NUL; + Delete_File (Maj_Path, Success); Result := Symlink (Version_Path (1)'Address, Newpath2'Address); Delete_File (Lib_Path, Success); ! Result := Symlink (Maj_Ver'Address, Newpath1'Address); end; end if; end Create_Sym_Links; diff -Nrcpad gcc-4.3.3/gcc/ada/namet-sp.adb gcc-4.4.0/gcc/ada/namet-sp.adb *** gcc-4.3.3/gcc/ada/namet-sp.adb Thu Dec 13 10:27:58 2007 --- gcc-4.4.0/gcc/ada/namet-sp.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/namet-sp.ads gcc-4.4.0/gcc/ada/namet-sp.ads *** gcc-4.3.3/gcc/ada/namet-sp.ads Thu Dec 13 10:27:58 2007 --- gcc-4.4.0/gcc/ada/namet-sp.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/namet.adb gcc-4.4.0/gcc/ada/namet.adb *** gcc-4.3.3/gcc/ada/namet.adb Thu Dec 13 10:27:58 2007 --- gcc-4.4.0/gcc/ada/namet.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Namet is *** 55,61 **** Hash_Num : constant Int := 2**12; -- Number of headers in the hash table. Current hash algorithm is closely -- tailored to this choice, so it can only be changed if a corresponding ! -- change is made to the hash alogorithm. Hash_Max : constant Int := Hash_Num - 1; -- Indexes in the hash header table run from 0 to Hash_Num - 1 --- 53,59 ---- Hash_Num : constant Int := 2**12; -- Number of headers in the hash table. Current hash algorithm is closely -- tailored to this choice, so it can only be changed if a corresponding ! -- change is made to the hash algorithm. Hash_Max : constant Int := Hash_Num - 1; -- Indexes in the hash header table run from 0 to Hash_Num - 1 diff -Nrcpad gcc-4.3.3/gcc/ada/namet.ads gcc-4.4.0/gcc/ada/namet.ads *** gcc-4.3.3/gcc/ada/namet.ads Wed Jun 6 10:23:26 2007 --- gcc-4.4.0/gcc/ada/namet.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/namet.h gcc-4.4.0/gcc/ada/namet.h *** gcc-4.3.3/gcc/ada/namet.h Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/namet.h Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** * * * C Header File * * * ! * Copyright (C) 1992-2007, 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- * --- 6,12 ---- * * * C Header File * * * ! * Copyright (C) 1992-2008, 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- * *************** Get_Decoded_Name_String (Name_Id Id) *** 85,91 **** /* Like Get_Decoded_Name_String, but the result has all qualification and package body entity suffixes stripped, and also all letters are upper ! cased. This is used fo rbuilding the enumeration literal table. */ extern void casing__set_all_upper_case (void); --- 85,91 ---- /* Like Get_Decoded_Name_String, but the result has all qualification and package body entity suffixes stripped, and also all letters are upper ! cased. This is used for building the enumeration literal table. */ extern void casing__set_all_upper_case (void); diff -Nrcpad gcc-4.3.3/gcc/ada/nlists.adb gcc-4.4.0/gcc/ada/nlists.adb *** gcc-4.3.3/gcc/ada/nlists.adb Thu Dec 13 10:22:06 2007 --- gcc-4.4.0/gcc/ada/nlists.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Nlists is *** 139,145 **** Prev_Node.Set_Last (N); -- Make sure we have no uninitialized junk in any new entires added. ! -- This ensures that Tree_Gen will not write out any unitialized junk. for J in Old_Last + 1 .. N loop Next_Node.Table (J) := Empty; --- 137,143 ---- Prev_Node.Set_Last (N); -- Make sure we have no uninitialized junk in any new entires added. ! -- This ensures that Tree_Gen will not write out any uninitialized junk. for J in Old_Last + 1 .. N loop Next_Node.Table (J) := Empty; *************** package body Nlists is *** 538,544 **** end if; end Insert_List_Before_Debug; ! -- Start of prodcessing for Insert_List_Before begin pragma Assert (Is_List_Member (Before)); --- 536,542 ---- end if; end Insert_List_Before_Debug; ! -- Start of processing for Insert_List_Before begin pragma Assert (Is_List_Member (Before)); *************** package body Nlists is *** 604,610 **** function Is_Non_Empty_List (List : List_Id) return Boolean is begin ! return List /= No_List and then First (List) /= Empty; end Is_Non_Empty_List; ---------- --- 602,608 ---- function Is_Non_Empty_List (List : List_Id) return Boolean is begin ! return First (List) /= Empty; end Is_Non_Empty_List; ---------- diff -Nrcpad gcc-4.3.3/gcc/ada/nlists.ads gcc-4.4.0/gcc/ada/nlists.ads *** gcc-4.3.3/gcc/ada/nlists.ads Thu Dec 13 10:22:06 2007 --- gcc-4.4.0/gcc/ada/nlists.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Nlists is *** 129,135 **** -- returned. It is an error to call First_Non_Pragma with a Node_Id value -- or No_List (No_List is not considered to be the same as an empty list). -- This function also skips N_Null nodes which can result from rewriting ! -- unrecognized or incorrrect pragmas. function Last (List : List_Id) return Node_Id; pragma Inline (Last); --- 127,133 ---- -- returned. It is an error to call First_Non_Pragma with a Node_Id value -- or No_List (No_List is not considered to be the same as an empty list). -- This function also skips N_Null nodes which can result from rewriting ! -- unrecognized or incorrect pragmas. function Last (List : List_Id) return Node_Id; pragma Inline (Last); *************** package Nlists is *** 172,178 **** function Prev (Node : Node_Id) return Node_Id; pragma Inline (Prev); ! -- This function returns the previous node on a node list list, or Empty -- if Node is the first element of the node list. The argument must be -- a member of a node list. Note: the implementation does maintain back -- pointers, so this function executes quickly in constant time. --- 170,176 ---- function Prev (Node : Node_Id) return Node_Id; pragma Inline (Prev); ! -- This function returns the previous node on a node list, or Empty -- if Node is the first element of the node list. The argument must be -- a member of a node list. Note: the implementation does maintain back -- pointers, so this function executes quickly in constant time. *************** package Nlists is *** 201,207 **** function Is_Empty_List (List : List_Id) return Boolean; pragma Inline (Is_Empty_List); -- This function determines if a given list id references a node list that ! -- contains no items. No_List is a not a legitimate argument. function Is_Non_Empty_List (List : List_Id) return Boolean; pragma Inline (Is_Non_Empty_List); --- 199,205 ---- function Is_Empty_List (List : List_Id) return Boolean; pragma Inline (Is_Empty_List); -- This function determines if a given list id references a node list that ! -- contains no items. No_List as an argument returns True. function Is_Non_Empty_List (List : List_Id) return Boolean; pragma Inline (Is_Non_Empty_List); diff -Nrcpad gcc-4.3.3/gcc/ada/nlists.h gcc-4.4.0/gcc/ada/nlists.h *** gcc-4.3.3/gcc/ada/nlists.h Wed Sep 12 13:12:49 2007 --- gcc-4.4.0/gcc/ada/nlists.h Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** * * * C Header File * * * ! * Copyright (C) 1992-2007, 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- * --- 6,12 ---- * * * C Header File * * * ! * Copyright (C) 1992-2008, 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- * *************** *** 24,30 **** ****************************************************************************/ /* This is the C header corresponding to the Ada package specification for ! Nlists. It also contains the implementations of inlined functions from the the package body for Nlists. It was generated manually from nlists.ads and nlists.adb and must be kept synchronized with changes in these files. --- 24,30 ---- ****************************************************************************/ /* This is the C header corresponding to the Ada package specification for ! Nlists. It also contains the implementations of inlined functions from the package body for Nlists. It was generated manually from nlists.ads and nlists.adb and must be kept synchronized with changes in these files. diff -Nrcpad gcc-4.3.3/gcc/ada/opt.adb gcc-4.4.0/gcc/ada/opt.adb *** gcc-4.3.3/gcc/ada/opt.adb Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/opt.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Opt is *** 49,54 **** --- 47,54 ---- Ada_Version_Config := Ada_Version; Ada_Version_Explicit_Config := Ada_Version_Explicit; Assertions_Enabled_Config := Assertions_Enabled; + Assume_No_Invalid_Values_Config := Assume_No_Invalid_Values; + Check_Policy_List_Config := Check_Policy_List; Debug_Pragmas_Enabled_Config := Debug_Pragmas_Enabled; Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks; Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed; *************** package body Opt is *** 56,64 **** --- 56,71 ---- External_Name_Exp_Casing_Config := External_Name_Exp_Casing; External_Name_Imp_Casing_Config := External_Name_Imp_Casing; Fast_Math_Config := Fast_Math; + Optimize_Alignment_Config := Optimize_Alignment; Persistent_BSS_Mode_Config := Persistent_BSS_Mode; Polling_Required_Config := Polling_Required; Use_VADS_Size_Config := Use_VADS_Size; + + -- Reset the indication that Optimize_Alignment was set locally, since + -- if we had a pragma in the config file, it would set this flag True, + -- but that's not a local setting. + + Optimize_Alignment_Local := False; end Register_Opt_Config_Switches; --------------------------------- *************** package body Opt is *** 70,75 **** --- 77,84 ---- Ada_Version := Save.Ada_Version; Ada_Version_Explicit := Save.Ada_Version_Explicit; Assertions_Enabled := Save.Assertions_Enabled; + Assume_No_Invalid_Values := Save.Assume_No_Invalid_Values; + Check_Policy_List := Save.Check_Policy_List; Debug_Pragmas_Enabled := Save.Debug_Pragmas_Enabled; Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks; Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed; *************** package body Opt is *** 77,82 **** --- 86,93 ---- External_Name_Exp_Casing := Save.External_Name_Exp_Casing; External_Name_Imp_Casing := Save.External_Name_Imp_Casing; Fast_Math := Save.Fast_Math; + Optimize_Alignment := Save.Optimize_Alignment; + Optimize_Alignment_Local := Save.Optimize_Alignment_Local; Persistent_BSS_Mode := Save.Persistent_BSS_Mode; Polling_Required := Save.Polling_Required; Use_VADS_Size := Save.Use_VADS_Size; *************** package body Opt is *** 91,96 **** --- 102,109 ---- Save.Ada_Version := Ada_Version; Save.Ada_Version_Explicit := Ada_Version_Explicit; Save.Assertions_Enabled := Assertions_Enabled; + Save.Assume_No_Invalid_Values := Assume_No_Invalid_Values; + Save.Check_Policy_List := Check_Policy_List; Save.Debug_Pragmas_Enabled := Debug_Pragmas_Enabled; Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks; Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed; *************** package body Opt is *** 98,103 **** --- 111,118 ---- Save.External_Name_Exp_Casing := External_Name_Exp_Casing; Save.External_Name_Imp_Casing := External_Name_Imp_Casing; Save.Fast_Math := Fast_Math; + Save.Optimize_Alignment := Optimize_Alignment; + Save.Optimize_Alignment_Local := Optimize_Alignment_Local; Save.Persistent_BSS_Mode := Persistent_BSS_Mode; Save.Polling_Required := Polling_Required; Save.Use_VADS_Size := Use_VADS_Size; *************** package body Opt is *** 120,162 **** -- since the whole point of this is that it still properly indicates -- the configuration setting even in a run time unit. ! Ada_Version := Ada_Version_Runtime; ! Dynamic_Elaboration_Checks := False; ! Extensions_Allowed := True; ! External_Name_Exp_Casing := As_Is; ! External_Name_Imp_Casing := Lowercase; ! Persistent_BSS_Mode := False; ! Use_VADS_Size := False; -- For an internal unit, assertions/debug pragmas are off unless this ! -- is the main unit and they were explicitly enabled. if Main_Unit then ! Assertions_Enabled := Assertions_Enabled_Config; ! Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; else ! Assertions_Enabled := False; ! Debug_Pragmas_Enabled := False; end if; -- Case of non-internal unit else ! Ada_Version := Ada_Version_Config; ! Ada_Version_Explicit := Ada_Version_Explicit_Config; ! Assertions_Enabled := Assertions_Enabled_Config; ! Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; ! Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config; ! Extensions_Allowed := Extensions_Allowed_Config; ! External_Name_Exp_Casing := External_Name_Exp_Casing_Config; ! External_Name_Imp_Casing := External_Name_Imp_Casing_Config; ! Fast_Math := Fast_Math_Config; ! Persistent_BSS_Mode := Persistent_BSS_Mode_Config; ! Use_VADS_Size := Use_VADS_Size_Config; end if; Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config; Fast_Math := Fast_Math_Config; Polling_Required := Polling_Required_Config; end Set_Opt_Config_Switches; --- 135,189 ---- -- since the whole point of this is that it still properly indicates -- the configuration setting even in a run time unit. ! Ada_Version := Ada_Version_Runtime; ! Dynamic_Elaboration_Checks := False; ! Extensions_Allowed := True; ! External_Name_Exp_Casing := As_Is; ! External_Name_Imp_Casing := Lowercase; ! Optimize_Alignment := 'O'; ! Persistent_BSS_Mode := False; ! Use_VADS_Size := False; ! Optimize_Alignment_Local := True; -- For an internal unit, assertions/debug pragmas are off unless this ! -- is the main unit and they were explicitly enabled. We also make ! -- sure we do not assume that values are necessarily valid. if Main_Unit then ! Assertions_Enabled := Assertions_Enabled_Config; ! Assume_No_Invalid_Values := Assume_No_Invalid_Values_Config; ! Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; ! Check_Policy_List := Check_Policy_List_Config; else ! Assertions_Enabled := False; ! Assume_No_Invalid_Values := False; ! Debug_Pragmas_Enabled := False; ! Check_Policy_List := Empty; end if; -- Case of non-internal unit else ! Ada_Version := Ada_Version_Config; ! Ada_Version_Explicit := Ada_Version_Explicit_Config; ! Assertions_Enabled := Assertions_Enabled_Config; ! Assume_No_Invalid_Values := Assume_No_Invalid_Values_Config; ! Check_Policy_List := Check_Policy_List_Config; ! Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; ! Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config; ! Extensions_Allowed := Extensions_Allowed_Config; ! External_Name_Exp_Casing := External_Name_Exp_Casing_Config; ! External_Name_Imp_Casing := External_Name_Imp_Casing_Config; ! Fast_Math := Fast_Math_Config; ! Optimize_Alignment := Optimize_Alignment_Config; ! Optimize_Alignment_Local := False; ! Persistent_BSS_Mode := Persistent_BSS_Mode_Config; ! Use_VADS_Size := Use_VADS_Size_Config; end if; Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config; Fast_Math := Fast_Math_Config; + Optimize_Alignment := Optimize_Alignment_Config; Polling_Required := Polling_Required_Config; end Set_Opt_Config_Switches; *************** package body Opt is *** 186,191 **** --- 213,219 ---- Tree_Read_Int (Assertions_Enabled_Config_Val); Tree_Read_Bool (All_Errors_Mode); Tree_Read_Bool (Assertions_Enabled); + Tree_Read_Int (Int (Check_Policy_List)); Tree_Read_Bool (Debug_Pragmas_Enabled); Tree_Read_Bool (Enable_Overflow_Checks); Tree_Read_Bool (Full_List); *************** package body Opt is *** 250,255 **** --- 278,284 ---- Tree_Write_Int (Boolean'Pos (Assertions_Enabled_Config)); Tree_Write_Bool (All_Errors_Mode); Tree_Write_Bool (Assertions_Enabled); + Tree_Write_Int (Int (Check_Policy_List)); Tree_Write_Bool (Debug_Pragmas_Enabled); Tree_Write_Bool (Enable_Overflow_Checks); Tree_Write_Bool (Full_List); diff -Nrcpad gcc-4.3.3/gcc/ada/opt.ads gcc-4.4.0/gcc/ada/opt.ads *** gcc-4.3.3/gcc/ada/opt.ads Thu Dec 13 10:22:25 2007 --- gcc-4.4.0/gcc/ada/opt.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Opt is *** 55,61 **** -- The following mode values represent the current state of processing. -- The values set here are the default values. Unless otherwise noted, ! -- the value may be reset in Switch-? with an appropropiate switch. In -- some cases, the values can also be modified by pragmas, and in the -- case of some binder variables, Gnatbind.Scan_Bind_Arg may modify -- the default values. --- 53,59 ---- -- The following mode values represent the current state of processing. -- The values set here are the default values. Unless otherwise noted, ! -- the value may be reset in Switch-? with an appropriate switch. In -- some cases, the values can also be modified by pragmas, and in the -- case of some binder variables, Gnatbind.Scan_Bind_Arg may modify -- the default values. *************** package Opt is *** 144,153 **** -- Set to non null when Bind_Alternate_Main_Name is True. This value -- is modified as needed by Gnatbind.Scan_Bind_Arg. - Assertions_Enabled : Boolean := False; - -- GNAT - -- Enable assertions made using pragma Assert - ASIS_Mode : Boolean := False; -- GNAT -- Enable semantic checks and tree transformations that are important --- 142,147 ---- *************** package Opt is *** 158,163 **** --- 152,170 ---- -- Back_Annotate_Rep_Info flag in this case. At the moment this does not -- make very much sense, because GNSA cannot do back annotation). + Assertions_Enabled : Boolean := False; + -- GNAT + -- Enable assertions made using pragma Assert + + Assume_No_Invalid_Values : Boolean := True; + -- ??? true for now, enable by setting to false later + -- GNAT + -- Normally, in accordance with (RM 13.9.1 (9-11)) the front end assumes + -- that values could have invalid representations, unless it can clearly + -- prove that the values are valid. If this switch is set (by -gnatB or by + -- pragma Assume_No_Invalid_Values (Off)), then the compiler assumes values + -- are valid and in range of their representations. + Back_Annotate_Rep_Info : Boolean := False; -- GNAT -- If set True, enables back annotation of representation information *************** package Opt is *** 214,219 **** --- 221,232 ---- -- GNATBIND -- Set to True to do checks only, no output of binder file + Check_Policy_List : Node_Id := Empty; + -- GNAT + -- This points to the list of N_Pragma nodes for Check_Policy pragmas + -- that are linked through the Next_Pragma fields, with the list being + -- terminated by Empty. The order is most recently processed first. + Check_Readonly_Files : Boolean := False; -- GNATMAKE -- Set to True to check readonly files during the make process *************** package Opt is *** 400,406 **** -- message routines generates one line of output as a separate message. -- If it is set to a non-zero value, then continuation lines are folded -- to make a single long message, and then this message is split up into ! -- multiple lines not exceeding the specified length. Set by -gnatLnnn. Exception_Locations_Suppressed : Boolean := False; -- GNAT --- 413,419 ---- -- message routines generates one line of output as a separate message. -- If it is set to a non-zero value, then continuation lines are folded -- to make a single long message, and then this message is split up into ! -- multiple lines not exceeding the specified length. Set by -gnatj=nn. Exception_Locations_Suppressed : Boolean := False; -- GNAT *************** package Opt is *** 522,531 **** -- the name is of the form .xxx, then to name.xxx where name is the source -- file name with extension stripped. Generating_Code : Boolean := False; -- GNAT -- True if the frontend finished its work and has called the backend to ! -- processs the tree and generate the object file. Global_Discard_Names : Boolean := False; -- GNAT, GNATBIND --- 535,549 ---- -- the name is of the form .xxx, then to name.xxx where name is the source -- file name with extension stripped. + Generate_Processed_File : Boolean := False; + -- GNAT + -- True when switch -gnateG is used. When True, create in a file + -- .prep, if the source is preprocessed. + Generating_Code : Boolean := False; -- GNAT -- True if the frontend finished its work and has called the backend to ! -- process the tree and generate the object file. Global_Discard_Names : Boolean := False; -- GNAT, GNATBIND *************** package Opt is *** 620,625 **** --- 638,647 ---- -- generate code even in case of unsupported construct, so that the byte -- code can be used by static analysis tools. + Invalid_Value_Used : Boolean := False; + -- GNAT + -- Set True if a valid Invalid_Value attribute is encountered + Follow_Links_For_Files : Boolean := False; -- PROJECT MANAGER -- Set to True (-eL) to process the project files in trusted mode *************** package Opt is *** 646,652 **** In_Place_Mode : Boolean := False; -- GNATMAKE ! -- Set True to store ALI and object files in place ie in the object -- directory if these files already exist or in the source directory -- if not. --- 668,674 ---- In_Place_Mode : Boolean := False; -- GNATMAKE ! -- Set True to store ALI and object files in place i.e. in the object -- directory if these files already exist or in the source directory -- if not. *************** package Opt is *** 858,863 **** --- 880,897 ---- -- error is detected then this flag is reset from Generate_Code to -- Check_Semantics after generating an error message. + Optimize_Alignment : Character := 'O'; + -- Setting of Optimize_Alignment, set to T/S/O for time/space/off. Can + -- be modified by use of pragma Optimize_Alignment. + + Optimize_Alignment_Local : Boolean := False; + -- Set True if Optimize_Alignment mode is set by a local configuration + -- pragma that overrides the gnat.adc (or other configuration file) default + -- so that the unit is not dependent on the default setting. Also always + -- set True for internal units, since these always have a default setting + -- of Optimize_Alignment (Off) that is enforced (essentially equivalent to + -- them all having such an explicit pragma in each unit). + Original_Operating_Mode : Operating_Mode_Type := Generate_Code; -- GNAT -- Indicates the original operating mode of the compiler as set by *************** package Opt is *** 866,872 **** Optimization_Level : Int; pragma Import (C, Optimization_Level, "optimize"); ! -- This constant reflects the optimization level (0,1,2 for -O0,-O1,-O2) Output_File_Name_Present : Boolean := False; -- GNATBIND, GNAT, GNATMAKE, GPRMAKE --- 900,906 ---- Optimization_Level : Int; pragma Import (C, Optimization_Level, "optimize"); ! -- Constant reflecting the optimization level (0,1,2,3 for -O0,-O1,-O2,-O3) Output_File_Name_Present : Boolean := False; -- GNATBIND, GNAT, GNATMAKE, GPRMAKE *************** package Opt is *** 904,910 **** Preprocessing_Data_File : String_Ptr := null; -- GNAT ! -- Set by switch -gnatep=. The file name of the prepocessing data file. Print_Generated_Code : Boolean := False; -- GNAT --- 938,944 ---- Preprocessing_Data_File : String_Ptr := null; -- GNAT ! -- Set by switch -gnatep=. The file name of the preprocessing data file. Print_Generated_Code : Boolean := False; -- GNAT *************** package Opt is *** 1086,1091 **** --- 1120,1130 ---- -- Tolerate time stamp and other consistency errors. If this flag is set to -- True (-t), then inconsistencies result in warnings rather than errors. + Treat_Restrictions_As_Warnings : Boolean := False; + -- GNAT + -- Set True to treat pragma Restrictions as Restriction_Warnings. Set by + -- -gnatr switch. + Tree_Output : Boolean := False; -- GNAT -- Set to True (-gnatt) to generate output tree file *************** package Opt is *** 1129,1135 **** Upper_Half_Encoding : Boolean := False; -- GNAT, GNATBIND ! -- Normally set False, indicating that upper half ASCII characters are -- used in the normal way to represent themselves. If the wide character -- encoding method uses the upper bit for this encoding, then this flag is -- set True, and upper half characters in the source indicate the start of --- 1168,1174 ---- Upper_Half_Encoding : Boolean := False; -- GNAT, GNATBIND ! -- Normally set False, indicating that upper half ISO 8859-1 characters are -- used in the normal way to represent themselves. If the wide character -- encoding method uses the upper bit for this encoding, then this flag is -- set True, and upper half characters in the source indicate the start of *************** package Opt is *** 1186,1191 **** --- 1225,1236 ---- -- including warnings on Ada 2005 obsolescent features used in Ada 2005 -- mode. Set False by -gnatwY. + Warn_On_Parameter_Order : Boolean := False; + -- GNAT + -- Set to True to generate warnings for cases where the argument list for + -- a call is a sequence of identifiers that match the formal identifiers, + -- but are in the wrong order. + Warn_On_Assertion_Failure : Boolean := True; -- GNAT -- Set to True to activate warnings on assertions that can be determined *************** package Opt is *** 1202,1207 **** --- 1247,1258 ---- -- Set to True to generate warnings for static fixed-point expression -- values that are not an exact multiple of the small value of the type. + Warn_On_Biased_Representation : Boolean := True; + -- GNAT + -- Set to True to generate warnings for size clauses, component clauses + -- and component_size clauses that force biased representation. Set False + -- by -gnatw.B. + Warn_On_Constant : Boolean := False; -- GNAT -- Set to True to generate warnings for variables that could be declared *************** package Opt is *** 1262,1268 **** Warn_On_Questionable_Missing_Parens : Boolean := True; -- GNAT ! -- Set to True to generate warnings for cases where parenthese are missing -- and the usage is questionable, because the intent is unclear. Warn_On_Redundant_Constructs : Boolean := False; --- 1313,1319 ---- Warn_On_Questionable_Missing_Parens : Boolean := True; -- GNAT ! -- Set to True to generate warnings for cases where parentheses are missing -- and the usage is questionable, because the intent is unclear. Warn_On_Redundant_Constructs : Boolean := False; *************** package Opt is *** 1298,1303 **** --- 1349,1360 ---- -- which have a record representation clause but this component does not -- have a component clause. The default is that this warning is disabled. + Warn_On_Warnings_Off : Boolean := False; + -- GNAT + -- Set to True to generate warnings for use of Pragma Warnings (Off, ent), + -- where either the pragma is never used, or it could be replaced by a + -- pragma Unmodified or Unreferenced. + type Warning_Mode_Type is (Suppress, Normal, Treat_As_Error); Warning_Mode : Warning_Mode_Type := Normal; -- GNAT, GNATBIND *************** package Opt is *** 1338,1345 **** -- These are settings that are used to establish the mode at the start of -- each unit. The values defined below can be affected either by command ! -- line switches, or by the use of appropriate configuration pragmas in the ! -- gnat.adc file. Ada_Version_Config : Ada_Version_Type; -- GNAT --- 1395,1402 ---- -- These are settings that are used to establish the mode at the start of -- each unit. The values defined below can be affected either by command ! -- line switches, or by the use of appropriate configuration pragmas in a ! -- configuration pragma file. Ada_Version_Config : Ada_Version_Type; -- GNAT *************** package Opt is *** 1356,1362 **** -- This is set in the same manner as Ada_Version_Config. The difference is -- that the setting of this flag is not ignored for internal and predefined -- units, which for some purposes do indeed access this value, regardless ! -- of the fact that they are compiled the the most up to date ada version). Assertions_Enabled_Config : Boolean; -- GNAT --- 1413,1419 ---- -- This is set in the same manner as Ada_Version_Config. The difference is -- that the setting of this flag is not ignored for internal and predefined -- units, which for some purposes do indeed access this value, regardless ! -- of the fact that they are compiled the most up to date ada version). Assertions_Enabled_Config : Boolean; -- GNAT *************** package Opt is *** 1364,1369 **** --- 1421,1440 ---- -- mode, as possibly set by the command line switch -gnata, and possibly -- modified by the use of the configuration pragma Assertion_Policy. + Assume_No_Invalid_Values_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch for assuming no invalid + -- values enabled mode mode, as possibly set by the command line switch + -- -gnatB, and possibly modified by the use of the configuration pragma + -- Assume_No_Invalid_Values. + + Check_Policy_List_Config : Node_Id; + -- GNAT + -- This points to the list of N_Pragma nodes for Check_Policy pragmas + -- that are linked through the Next_Pragma fields, with the list being + -- terminated by Empty. The order is most recently processed first. This + -- list includes only those pragmas in configuration pragma files. + Debug_Pragmas_Enabled_Config : Boolean; -- GNAT -- This is the value of the configuration switch for debug pragmas enabled *************** package Opt is *** 1416,1421 **** --- 1487,1500 ---- -- used to set the initial value of Fast_Math at the start of each new -- compilation unit. + Optimize_Alignment_Config : Character; + -- GNAT + -- This is the value of the configuration switch that controls the + -- alignment optimization mode, as set by an Optimize_Alignment pragma. + -- It is used to set the initial value of Optimize_Alignment at the start + -- of each new compilation unit, except that it is always set to 'O' (off) + -- for internal units. + Persistent_BSS_Mode_Config : Boolean; -- GNAT -- This is the value of the configuration switch that controls whether *************** package Opt is *** 1436,1442 **** Use_VADS_Size_Config : Boolean; -- GNAT -- This is the value of the configuration switch that controls the use of ! -- VADS_Size instead of Size whereever the attribute Size is used. It can -- be set True by the use of the pragma Use_VADS_Size in the gnat.adc file. -- This flag is used to set the initial value for Use_VADS_Size at the -- start of analyzing each unit. Note however that the setting of this flag --- 1515,1521 ---- Use_VADS_Size_Config : Boolean; -- GNAT -- This is the value of the configuration switch that controls the use of ! -- VADS_Size instead of Size wherever the attribute Size is used. It can -- be set True by the use of the pragma Use_VADS_Size in the gnat.adc file. -- This flag is used to set the initial value for Use_VADS_Size at the -- start of analyzing each unit. Note however that the setting of this flag *************** package Opt is *** 1467,1475 **** -- call to Save_Opt_Switches. procedure Register_Opt_Config_Switches; ! -- This procedure is called after processing the gnat.adc file to record ! -- the values of the Config switches, as possibly modified by the use of ! -- command line switches and configuration pragmas. ------------------------ -- Other Global Flags -- --- 1546,1555 ---- -- call to Save_Opt_Switches. procedure Register_Opt_Config_Switches; ! -- This procedure is called after processing the gnat.adc file and other ! -- configuration pragma files to record the values of the Config switches, ! -- as possibly modified by the use of command line switches and pragmas ! -- appearing in these files. ------------------------ -- Other Global Flags -- *************** private *** 1546,1551 **** --- 1626,1633 ---- Ada_Version : Ada_Version_Type; Ada_Version_Explicit : Ada_Version_Type; Assertions_Enabled : Boolean; + Assume_No_Invalid_Values : Boolean; + Check_Policy_List : Node_Id; Debug_Pragmas_Enabled : Boolean; Dynamic_Elaboration_Checks : Boolean; Exception_Locations_Suppressed : Boolean; *************** private *** 1553,1558 **** --- 1635,1642 ---- External_Name_Exp_Casing : External_Casing_Type; External_Name_Imp_Casing : External_Casing_Type; Fast_Math : Boolean; + Optimize_Alignment : Character; + Optimize_Alignment_Local : Boolean; Persistent_BSS_Mode : Boolean; Polling_Required : Boolean; Use_VADS_Size : Boolean; diff -Nrcpad gcc-4.3.3/gcc/ada/osint-b.ads gcc-4.4.0/gcc/ada/osint-b.ads *** gcc-4.3.3/gcc/ada/osint-b.ads Mon Oct 15 13:58:20 2007 --- gcc-4.4.0/gcc/ada/osint-b.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package Osint.B is *** 76,82 **** procedure Close_Binder_Output; -- Closes the file created by Create_Binder_Output, flushing any ! -- buffers etc from writes by Write_Binder_Info. procedure Set_Current_File_Name_Index (To : Int); -- Set value of Current_File_Name_Index (in private part of Osint) to To --- 76,82 ---- procedure Close_Binder_Output; -- Closes the file created by Create_Binder_Output, flushing any ! -- buffers etc. from writes by Write_Binder_Info. procedure Set_Current_File_Name_Index (To : Int); -- Set value of Current_File_Name_Index (in private part of Osint) to To diff -Nrcpad gcc-4.3.3/gcc/ada/osint-c.adb gcc-4.4.0/gcc/ada/osint-c.adb *** gcc-4.3.3/gcc/ada/osint-c.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/osint-c.adb Mon Mar 31 19:28:19 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package body Osint.C is *** 43,49 **** Suffix : String) return File_Name_Type; -- Common processing for Create_List_File, Create_Repinfo_File and -- Create_Debug_File. Src is the file name used to create the required ! -- output file and Suffix is the desired suffic (dg/rep/xxx for debug/ -- repinfo/list file where xxx is specified extension. procedure Set_Library_Info_Name; --- 43,49 ---- Suffix : String) return File_Name_Type; -- Common processing for Create_List_File, Create_Repinfo_File and -- Create_Debug_File. Src is the file name used to create the required ! -- output file and Suffix is the desired suffix (dg/rep/xxx for debug/ -- repinfo/list file where xxx is specified extension. procedure Set_Library_Info_Name; *************** package body Osint.C is *** 315,328 **** -- Remove extension preparing to replace it declare ! Name : constant String := Name_Buffer (1 .. Dot_Index); First : Positive; begin Name_Buffer (1 .. Output_Object_File_Name'Length) := Output_Object_File_Name.all; - Dot_Index := 0; for J in reverse Output_Object_File_Name'Range loop if Name_Buffer (J) = '.' then Dot_Index := J; --- 315,335 ---- -- Remove extension preparing to replace it declare ! Name : String := Name_Buffer (1 .. Dot_Index); First : Positive; begin Name_Buffer (1 .. Output_Object_File_Name'Length) := Output_Object_File_Name.all; + -- Put two names in canonical case, to allow object file names + -- with upper-case letters on Windows. + + Canonical_Case_File_Name (Name); + Canonical_Case_File_Name + (Name_Buffer (1 .. Output_Object_File_Name'Length)); + + Dot_Index := 0; for J in reverse Output_Object_File_Name'Range loop if Name_Buffer (J) = '.' then Dot_Index := J; *************** package body Osint.C is *** 432,438 **** pragma Assert (Dot_Index /= 0); ! -- Change exctension to adt Name_Buffer (Dot_Index) := '.'; Name_Buffer (Dot_Index + 1) := 'a'; --- 439,445 ---- pragma Assert (Dot_Index /= 0); ! -- Change extension to adt Name_Buffer (Dot_Index) := '.'; Name_Buffer (Dot_Index + 1) := 'a'; diff -Nrcpad gcc-4.3.3/gcc/ada/osint-c.ads gcc-4.4.0/gcc/ada/osint-c.ads *** gcc-4.3.3/gcc/ada/osint-c.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/osint-c.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package Osint.C is *** 128,134 **** procedure Close_Output_Library_Info; -- Closes the file created by Create_Output_Library_Info, flushing any ! -- buffers etc from writes by Write_Library_Info. procedure Read_Library_Info (Name : out File_Name_Type; --- 128,134 ---- procedure Close_Output_Library_Info; -- Closes the file created by Create_Output_Library_Info, flushing any ! -- buffers etc. from writes by Write_Library_Info. procedure Read_Library_Info (Name : out File_Name_Type; diff -Nrcpad gcc-4.3.3/gcc/ada/osint.adb gcc-4.4.0/gcc/ada/osint.adb *** gcc-4.3.3/gcc/ada/osint.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/osint.adb Thu May 29 08:56:01 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Osint is *** 63,72 **** -- that are used to locate the actual file and for the purpose of message -- construction. These names need not be accessible by Name_Find, and can -- be therefore created by using routine Name_Enter. The files in question ! -- are file names with a prefix directory (ie the files not in the current ! -- directory). File names without a prefix directory are entered with ! -- Name_Find because special values might be attached to the various Info ! -- fields of the corresponding name table entry. ----------------------- -- Local Subprograms -- --- 63,72 ---- -- that are used to locate the actual file and for the purpose of message -- construction. These names need not be accessible by Name_Find, and can -- be therefore created by using routine Name_Enter. The files in question ! -- are file names with a prefix directory (i.e., the files not in the ! -- current directory). File names without a prefix directory are entered ! -- with Name_Find because special values might be attached to the various ! -- Info fields of the corresponding name table entry. ----------------------- -- Local Subprograms -- *************** package body Osint is *** 124,130 **** Look_In_Primary_Directory_For_Current_Main : Boolean := False; -- When this variable is True, Find_File only looks in Primary_Directory -- for the Current_Main file. This variable is always set to True for the ! -- compiler. It is also True for gnatmake, when the soucr name given on -- the command line has directory information. Current_Full_Source_Name : File_Name_Type := No_File; --- 124,130 ---- Look_In_Primary_Directory_For_Current_Main : Boolean := False; -- When this variable is True, Find_File only looks in Primary_Directory -- for the Current_Main file. This variable is always set to True for the ! -- compiler. It is also True for gnatmake, when the source name given on -- the command line has directory information. Current_Full_Source_Name : File_Name_Type := No_File; *************** package body Osint is *** 177,183 **** -- The file hash table is provided to free the programmer from any -- efficiency concern when retrieving full file names or time stamps of -- source files. If the programmer calls Source_File_Data (Cache => True) ! -- he is guaranteed that the price to retrieve the full name (ie with -- directory info) or time stamp of the file will be payed only once, the -- first time the full name is actually searched (or the first time the -- time stamp is actually retrieved). This is achieved by employing a hash --- 177,183 ---- -- The file hash table is provided to free the programmer from any -- efficiency concern when retrieving full file names or time stamps of -- source files. If the programmer calls Source_File_Data (Cache => True) ! -- he is guaranteed that the price to retrieve the full name (i.e. with -- directory info) or time stamp of the file will be payed only once, the -- first time the full name is actually searched (or the first time the -- time stamp is actually retrieved). This is achieved by employing a hash *************** package body Osint is *** 250,256 **** -- -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\ -- GNAT\Standard Libraries ! -- Return an empty string on other systems -------------------- -- Add_Search_Dir -- --- 250,260 ---- -- -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\ -- GNAT\Standard Libraries ! -- Return an empty string on other systems. ! -- ! -- Note that this is an undocumented legacy feature, and that it ! -- works only when using the default runtime library (i.e. no --RTS= ! -- command line switch). -------------------- -- Add_Search_Dir -- *************** package body Osint is *** 803,809 **** function Executable_Prefix return String_Ptr is function Get_Install_Dir (Exec : String) return String_Ptr; ! -- S is the executable name preceeded by the absolute or relative -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc". --------------------- --- 807,813 ---- function Executable_Prefix return String_Ptr is function Get_Install_Dir (Exec : String) return String_Ptr; ! -- S is the executable name preceded by the absolute or relative -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc". --------------------- *************** package body Osint is *** 1870,1911 **** -- Program_Name -- ------------------ ! function Program_Name (Nam : String) return String_Access is ! Res : String_Access; begin -- Get the name of the current program being executed Find_Program_Name; ! -- Find the target prefix if any, for the cross compilation case. ! -- For instance in "alpha-dec-vxworks-gcc" the target prefix is ! -- "alpha-dec-vxworks-" ! ! while Name_Len > 0 loop ! -- All done if we find the last hyphen ! if Name_Buffer (Name_Len) = '-' then exit; ! -- If directory separator found, we don't want to look further ! -- since in this case, no prefix has been found. ! elsif Is_Directory_Separator (Name_Buffer (Name_Len)) then ! Name_Len := 0; exit; end if; - - Name_Len := Name_Len - 1; end loop; -- Create the new program name ! Res := new String (1 .. Name_Len + Nam'Length); ! Res.all (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); ! Res.all (Name_Len + 1 .. Name_Len + Nam'Length) := Nam; ! return Res; end Program_Name; ------------------------------ --- 1874,1950 ---- -- Program_Name -- ------------------ ! function Program_Name (Nam : String; Prog : String) return String_Access is ! End_Of_Prefix : Natural := 0; ! Start_Of_Prefix : Positive := 1; ! Start_Of_Suffix : Positive; begin + -- GNAAMP tool names require special treatment + + if AAMP_On_Target then + + -- The name "gcc" is mapped to "gnaamp" (the compiler driver) + + if Nam = "gcc" then + return new String'("gnaamp"); + + -- Tool names starting with "gnat" are mapped by substituting the + -- string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp"). + + elsif Nam'Length >= 4 + and then Nam (Nam'First .. Nam'First + 3) = "gnat" + then + return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last)); + + -- No other mapping rules, so we continue and handle any other forms + -- of tool names the same as on other targets. + + else + null; + end if; + end if; + -- Get the name of the current program being executed Find_Program_Name; ! Start_Of_Suffix := Name_Len + 1; ! -- Find the target prefix if any, for the cross compilation case. ! -- For instance in "powerpc-elf-gcc" the target prefix is ! -- "powerpc-elf-" ! -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1" ! for J in reverse 1 .. Name_Len loop ! if Name_Buffer (J) = '/' ! or else Name_Buffer (J) = Directory_Separator ! or else Name_Buffer (J) = ':' ! then ! Start_Of_Prefix := J + 1; exit; + end if; + end loop; ! -- Find End_Of_Prefix ! for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop ! if Name_Buffer (J .. J + Prog'Length - 1) = Prog then ! End_Of_Prefix := J - 1; exit; end if; end loop; + if End_Of_Prefix > 1 then + Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1; + end if; + -- Create the new program name ! return new String' ! (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix) ! & Nam ! & Name_Buffer (Start_Of_Suffix .. Name_Len)); end Program_Name; ------------------------------ *************** package body Osint is *** 1976,1994 **** Curr := Curr + Actual_Len; end loop; ! -- Process the file, translating line and file ending ! -- control characters to a path separator character. Prev_Was_Separator := True; Nb_Relative_Dir := 0; for J in 1 .. Len loop ! if S (J) in ASCII.NUL .. ASCII.US or else S (J) = ' ' then S (J) := Path_Separator; end if; if S (J) = Path_Separator then Prev_Was_Separator := True; else if Prev_Was_Separator and then Is_Relative (S.all, J) then Nb_Relative_Dir := Nb_Relative_Dir + 1; --- 2015,2044 ---- Curr := Curr + Actual_Len; end loop; ! -- Process the file, dealing with path separators Prev_Was_Separator := True; Nb_Relative_Dir := 0; for J in 1 .. Len loop ! ! -- Treat any control character as a path separator. Note that we do ! -- not treat space as a path separator (we used to treat space as a ! -- path separator in an earlier version). That way space can appear ! -- as a legitimate character in a path name. ! ! -- Why do we treat all control characters as path separators??? ! ! if S (J) in ASCII.NUL .. ASCII.US then S (J) := Path_Separator; end if; + -- Test for explicit path separator (or control char as above) + if S (J) = Path_Separator then Prev_Was_Separator := True; + -- If not path separator, register use of relative directory + else if Prev_Was_Separator and then Is_Relative (S.all, J) then Nb_Relative_Dir := Nb_Relative_Dir + 1; *************** package body Osint is *** 2556,2562 **** Canonical_File_Len : Integer; begin ! -- Retrieve the expanded directoy names and build the list for J in 1 .. Num_Files loop Canonical_File_Addr := To_Canonical_File_List_Next; --- 2606,2612 ---- Canonical_File_Len : Integer; begin ! -- Retrieve the expanded directory names and build the list for J in 1 .. Num_Files loop Canonical_File_Addr := To_Canonical_File_List_Next; diff -Nrcpad gcc-4.3.3/gcc/ada/osint.ads gcc-4.4.0/gcc/ada/osint.ads *** gcc-4.3.3/gcc/ada/osint.ads Wed Sep 26 10:45:36 2007 --- gcc-4.4.0/gcc/ada/osint.ads Wed Jul 30 13:02:39 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Osint is *** 62,68 **** T : File_Type) return File_Name_Type; -- Finds a source, library or config file depending on the value of T -- following the directory search order rules unless N is the name of the ! -- file just read with Next_Main_File and already contains directiory -- information, in which case just look in the Primary_Directory. Returns -- File_Name_Type of the full file name if found, No_File if file not -- found. Note that for the special case of gnat.adc, only the compilation --- 62,68 ---- T : File_Type) return File_Name_Type; -- Finds a source, library or config file depending on the value of T -- following the directory search order rules unless N is the name of the ! -- file just read with Next_Main_File and already contains directory -- information, in which case just look in the Primary_Directory. Returns -- File_Name_Type of the full file name if found, No_File if file not -- found. Note that for the special case of gnat.adc, only the compilation *************** package Osint is *** 105,120 **** -- Put simple name of current program being run (excluding the directory -- path) in Name_Buffer, with the length in Name_Len. ! function Program_Name (Nam : String) return String_Access; -- In the native compilation case, Create a string containing Nam. In the -- cross compilation case, looks at the prefix of the current program being -- run and prepend it to Nam. For instance if the program being run is -- -gnatmake and Nam is "gcc", the returned value will be a pointer ! -- to "-gcc". This function clobbers Name_Buffer and Name_Len. procedure Write_Program_Name; ! -- Writes name of program as invoked to the current output ! -- (normally standard output). procedure Fail (S1 : String; S2 : String := ""; S3 : String := ""); pragma No_Return (Fail); --- 105,125 ---- -- Put simple name of current program being run (excluding the directory -- path) in Name_Buffer, with the length in Name_Len. ! function Program_Name (Nam : String; Prog : String) return String_Access; -- In the native compilation case, Create a string containing Nam. In the -- cross compilation case, looks at the prefix of the current program being -- run and prepend it to Nam. For instance if the program being run is -- -gnatmake and Nam is "gcc", the returned value will be a pointer ! -- to "-gcc". In the specific case where AAMP_On_Target is set, the ! -- name "gcc" is mapped to "gnaamp", and names of the form "gnat*" are ! -- mapped to "gnaamp*". This function clobbers Name_Buffer and Name_Len. ! -- Also look at any suffix, e.g. gnatmake-4.1 -> "gcc-4.1". Prog is the ! -- default name of the current program being executed, e.g. "gnatmake", ! -- "gnatlink". procedure Write_Program_Name; ! -- Writes name of program as invoked to the current output (normally ! -- standard output). procedure Fail (S1 : String; S2 : String := ""; S3 : String := ""); pragma No_Return (Fail); *************** package Osint is *** 160,166 **** -- Same as above for a path name type String_Access_List is array (Positive range <>) of String_Access; ! -- Deferenced type used to return a list of file specs in -- To_Canonical_File_List. type String_Access_List_Access is access all String_Access_List; --- 165,171 ---- -- Same as above for a path name type String_Access_List is array (Positive range <>) of String_Access; ! -- Dereferenced type used to return a list of file specs in -- To_Canonical_File_List. type String_Access_List_Access is access all String_Access_List; *************** package Osint is *** 171,179 **** (Wildcard_Host_File : String; Only_Dirs : Boolean) return String_Access_List_Access; -- Expand a wildcard host syntax file or directory specification (e.g. on ! -- a VMS host, any file or directory spec that contains: ! -- "*", or "%", or "...") ! -- and return a list of valid Unix syntax file or directory specs. -- If Only_Dirs is True, then only return directories. function To_Canonical_Dir_Spec --- 176,183 ---- (Wildcard_Host_File : String; Only_Dirs : Boolean) return String_Access_List_Access; -- Expand a wildcard host syntax file or directory specification (e.g. on ! -- a VMS host, any file or directory spec that contains: "*", or "%", or ! -- "...") and return a list of valid Unix syntax file or directory specs. -- If Only_Dirs is True, then only return directories. function To_Canonical_Dir_Spec *************** package Osint is *** 239,246 **** -- modified by update_path. procedure Add_Default_Search_Dirs; ! -- This routine adds the default search dirs indicated by the ! -- environment variables and sdefault package. procedure Add_Lib_Search_Dir (Dir : String); -- Add Dir at the end of the library file search path --- 243,250 ---- -- modified by update_path. procedure Add_Default_Search_Dirs; ! -- This routine adds the default search dirs indicated by the environment ! -- variables and sdefault package. procedure Add_Lib_Search_Dir (Dir : String); -- Add Dir at the end of the library file search path *************** package Osint is *** 252,262 **** (Search_Path : String_Access); function Get_Next_Dir_In_Path (Search_Path : String_Access) return String_Access; ! -- These subprograms are used to parse out the directory names in a ! -- search path specified by a Search_Path argument. The procedure ! -- initializes an internal pointer to point to the initial directory ! -- name, and calls to the function return successive directory names, ! -- with a null pointer marking the end of the list. type Search_File_Type is (Include, Objects); --- 256,266 ---- (Search_Path : String_Access); function Get_Next_Dir_In_Path (Search_Path : String_Access) return String_Access; ! -- These subprograms are used to parse out the directory names in a search ! -- path specified by a Search_Path argument. The procedure initializes an ! -- internal pointer to point to the initial directory name, and calls to ! -- the function return successive directory names, with a null pointer ! -- marking the end of the list. type Search_File_Type is (Include, Objects); *************** package Osint is *** 282,288 **** new String'("ada_source_path"); Objects_Search_File : constant String_Access := new String'("ada_object_path"); ! -- Names of the files containg the default include or objects search -- directories. These files, located in Sdefault.Search_Dir_Prefix, do -- not necessarily exist. --- 286,292 ---- new String'("ada_source_path"); Objects_Search_File : constant String_Access := new String'("ada_object_path"); ! -- Names of the files containing the default include or objects search -- directories. These files, located in Sdefault.Search_Dir_Prefix, do -- not necessarily exist. *************** package Osint is *** 343,352 **** -- LF/CR -- LF ! -- The source is terminated by an EOF (16#1A#) character, which is ! -- the last charcater of the returned source bufer (note that any ! -- EOF characters in positions other than the last source character ! -- are treated as representing blanks). -- -- The logical lower bound of the source buffer is the input value of Lo, -- and on exit Hi is set to the logical upper bound of the source buffer. --- 347,355 ---- -- LF/CR -- LF ! -- The source is terminated by an EOF (16#1A#) character, which is the last ! -- character of the returned source buffer (note that any EOF characters in ! -- positions other than the last source character are treated as blanks). -- -- The logical lower bound of the source buffer is the input value of Lo, -- and on exit Hi is set to the logical upper bound of the source buffer. *************** package Osint is *** 367,376 **** -- without any directory information. The implementation is responsible -- for searching for the file in the appropriate directories. -- ! -- Note the special case that if the file name is gnat.adc, then the ! -- search for the file is done ONLY in the directory corresponding to ! -- the current compilation environment, i.e. in the same directory ! -- where the ali and object files will be written. function Full_Source_Name return File_Name_Type; function Current_Source_File_Stamp return Time_Stamp_Type; --- 370,379 ---- -- without any directory information. The implementation is responsible -- for searching for the file in the appropriate directories. -- ! -- Note the special case that if the file name is gnat.adc, then the search ! -- for the file is done ONLY in the directory corresponding to the current ! -- compilation environment, i.e. in the same directory where the ali and ! -- object files will be written. function Full_Source_Name return File_Name_Type; function Current_Source_File_Stamp return Time_Stamp_Type; *************** package Osint is *** 405,411 **** -- Source_File_Stamp (N) is made. This may be undesirable in certain -- applications as this is uselessly slow if source file data does not -- change during program execution. When this procedure is called with ! -- Cache => True access to source file data does not encurr a penalty if -- this data was previously retrieved. ------------------------------------------- --- 408,414 ---- -- Source_File_Stamp (N) is made. This may be undesirable in certain -- applications as this is uselessly slow if source file data does not -- change during program execution. When this procedure is called with ! -- Cache => True access to source file data does not incur a penalty if -- this data was previously retrieved. ------------------------------------------- *************** package Osint is *** 458,464 **** -- whose name is given by the parameter Name. -- -- See description of Read_Source_File for details on the format of the ! -- returned text buffer (the format is identical). THe lower bound of -- the Text_Buffer is always zero -- -- If the specified file cannot be opened, then the action depends on --- 461,467 ---- -- whose name is given by the parameter Name. -- -- See description of Read_Source_File for details on the format of the ! -- returned text buffer (the format is identical). The lower bound of -- the Text_Buffer is always zero -- -- If the specified file cannot be opened, then the action depends on *************** package Osint is *** 484,490 **** -- using Read_Library_Info, including appropriate directory information. -- Calling this routine entails no library file directory lookup -- penalty. Note that the object file corresponding to a library file ! -- is not actually read. Its time stamp is fected when the flag -- Opt.Check_Object_Consistency is set. function Current_Library_File_Stamp return Time_Stamp_Type; --- 487,493 ---- -- using Read_Library_Info, including appropriate directory information. -- Calling this routine entails no library file directory lookup -- penalty. Note that the object file corresponding to a library file ! -- is not actually read. Its time stamp is affected when the flag -- Opt.Check_Object_Consistency is set. function Current_Library_File_Stamp return Time_Stamp_Type; *************** package Osint is *** 506,519 **** (Source_File : File_Name_Type; Munit_Index : Nat := 0) return File_Name_Type; -- Given the name of a source file, returns the name of the corresponding ! -- library information file. This may be the name of the object file, or ! -- of a separate file used to store the library information. In either case ! -- the returned result is suitable for use in a call to Read_Library_Info. ! -- The Munit_Index is the unit index in multiple unit per file mode, or ! -- zero in normal single unit per file mode (used to add ~nnn suffix). ! -- Note: this subprogram is in this section because it is used by the ! -- compiler to determine the proper library information names to be placed ! -- in the generated library information file. ----------------- -- Termination -- --- 509,523 ---- (Source_File : File_Name_Type; Munit_Index : Nat := 0) return File_Name_Type; -- Given the name of a source file, returns the name of the corresponding ! -- library information file. This may be the name of the object file or of ! -- a separate file used to store the library information. In the current ! -- implementation, a separate file (the ALI file) is always used. In either ! -- case the returned result is suitable for calling Read_Library_Info. The ! -- Munit_Index is the unit index in multiple unit per file mode, or zero in ! -- normal single unit per file mode (used to add ~nnn suffix). Note: this ! -- subprogram is in this section because it is used by the compiler to ! -- determine the proper library information names to be placed in the ! -- generated library information file. ----------------- -- Termination -- diff -Nrcpad gcc-4.3.3/gcc/ada/output.adb gcc-4.4.0/gcc/ada/output.adb *** gcc-4.3.3/gcc/ada/output.adb Tue Aug 14 08:48:45 2007 --- gcc-4.4.0/gcc/ada/output.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/output.ads gcc-4.4.0/gcc/ada/output.ads *** gcc-4.3.3/gcc/ada/output.ads Tue Aug 14 08:48:45 2007 --- gcc-4.4.0/gcc/ada/output.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Output is *** 139,145 **** procedure Restore_Output_Buffer (S : Saved_Output_Buffer); -- Restore previously saved output buffer. The value in S is not affected ! -- so it is legtimate to restore a buffer more than once. -------------------------- -- Debugging Procedures -- --- 137,143 ---- procedure Restore_Output_Buffer (S : Saved_Output_Buffer); -- Restore previously saved output buffer. The value in S is not affected ! -- so it is legitimate to restore a buffer more than once. -------------------------- -- Debugging Procedures -- diff -Nrcpad gcc-4.3.3/gcc/ada/par-ch10.adb gcc-4.4.0/gcc/ada/par-ch10.adb *** gcc-4.3.3/gcc/ada/par-ch10.adb Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/par-ch10.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Ch10 is *** 47,53 **** (Cunit : Node_Id; Loc : Source_Ptr; SR_Present : Boolean); ! -- This procedure is used to generate a line of output for the a unit in -- the source program. Cunit is the node for the compilation unit, and -- Loc is the source location for the start of the unit in the source -- file (which is not necessarily the Sloc of the Cunit node). This --- 47,53 ---- (Cunit : Node_Id; Loc : Source_Ptr; SR_Present : Boolean); ! -- This procedure is used to generate a line of output for a unit in -- the source program. Cunit is the node for the compilation unit, and -- Loc is the source location for the start of the unit in the source -- file (which is not necessarily the Sloc of the Cunit node). This *************** package body Ch10 is *** 115,124 **** P : Node_Id; SR_Present : Boolean; ! Cunit_Error_Flag : Boolean := False; -- This flag is set True if we have to scan for a compilation unit -- token. It is used to ensure clean termination in such cases by ! -- not insisting on being at the end of file, and, in the sytax only -- case by not scanning for additional compilation units. Cunit_Location : Source_Ptr; --- 115,124 ---- P : Node_Id; SR_Present : Boolean; ! Cunit_Error_Flag : Boolean := False; -- This flag is set True if we have to scan for a compilation unit -- token. It is used to ensure clean termination in such cases by ! -- not insisting on being at the end of file, and, in the syntax only -- case by not scanning for additional compilation units. Cunit_Location : Source_Ptr; *************** package body Ch10 is *** 140,147 **** Config_Pragmas := No_List; ! -- If we have an initial Source_Reference pragma, then remember ! -- the fact to generate an NR parameter in the output line. SR_Present := False; --- 140,147 ---- Config_Pragmas := No_List; ! -- If we have an initial Source_Reference pragma, then remember the fact ! -- to generate an NR parameter in the output line. SR_Present := False; *************** package body Ch10 is *** 150,156 **** Item := P_Pragma; if Item = Error ! or else Chars (Item) /= Name_Source_Reference then Restore_Scan_State (Scan_State); --- 150,156 ---- Item := P_Pragma; if Item = Error ! or else Pragma_Name (Item) /= Name_Source_Reference then Restore_Scan_State (Scan_State); *************** package body Ch10 is *** 180,186 **** Item := P_Pragma; if Item = Error ! or else not Is_Configuration_Pragma_Name (Chars (Item)) then Restore_Scan_State (Scan_State); exit; --- 180,186 ---- Item := P_Pragma; if Item = Error ! or else not Is_Configuration_Pragma_Name (Pragma_Name (Item)) then Restore_Scan_State (Scan_State); exit; *************** package body Ch10 is *** 331,337 **** -- A common error is to omit the body keyword after package. We can -- often diagnose this early on (before getting loads of errors from ! -- contained subprogram bodies), by knowing that that the file we -- are compiling has a name that requires a body to be found. Save_Scan_State (Scan_State); --- 331,337 ---- -- A common error is to omit the body keyword after package. We can -- often diagnose this early on (before getting loads of errors from ! -- contained subprogram bodies), by knowing that the file we -- are compiling has a name that requires a body to be found. Save_Scan_State (Scan_State); *************** package body Ch10 is *** 664,670 **** if Token /= Tok_EOF then -- If we already had to scan for a compilation unit, then don't ! -- give any further error message, since it just sems to make -- things worse, and we already gave a serious error message. if Cunit_Error_Flag then --- 664,670 ---- if Token /= Tok_EOF then -- If we already had to scan for a compilation unit, then don't ! -- give any further error message, since it just seems to make -- things worse, and we already gave a serious error message. if Cunit_Error_Flag then *************** package body Ch10 is *** 898,904 **** First_Flag := True; -- Loop through names in one with clause, generating a separate ! -- N_With_Clause node for each nam encountered. loop With_Node := New_Node (N_With_Clause, Token_Ptr); --- 898,904 ---- First_Flag := True; -- Loop through names in one with clause, generating a separate ! -- N_With_Clause node for each name encountered. loop With_Node := New_Node (N_With_Clause, Token_Ptr); *************** package body Ch10 is *** 1024,1033 **** Set_Name (Subunit_Node, P_Qualified_Simple_Name); U_Right_Paren; ! if Token = Tok_Semicolon then ! Error_Msg_SC ("unexpected semicolon ignored"); ! Scan; ! end if; if Token = Tok_Function or else Token = Tok_Procedure then Body_Node := P_Subprogram (Pf_Pbod); --- 1024,1030 ---- Set_Name (Subunit_Node, P_Qualified_Simple_Name); U_Right_Paren; ! Ignore (Tok_Semicolon); if Token = Tok_Function or else Token = Tok_Procedure then Body_Node := P_Subprogram (Pf_Pbod); diff -Nrcpad gcc-4.3.3/gcc/ada/par-ch11.adb gcc-4.4.0/gcc/ada/par-ch11.adb *** gcc-4.3.3/gcc/ada/par-ch11.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/par-ch11.adb Tue Apr 8 06:54:03 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Ch11 is *** 94,99 **** --- 94,104 ---- begin Handler_Node := New_Node (N_Exception_Handler, Token_Ptr); Set_Local_Raise_Statements (Handler_Node, No_Elist); + + if Style_Check then + Style.Check_Indentation; + end if; + T_When; -- Test for possible choice parameter present diff -Nrcpad gcc-4.3.3/gcc/ada/par-ch12.adb gcc-4.4.0/gcc/ada/par-ch12.adb *** gcc-4.3.3/gcc/ada/par-ch12.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/par-ch12.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Ch12 is *** 830,836 **** -- [abstract] [limited | synchronized] -- new SUBTYPE_MARK [[and INTERFACE_LIST] with private] ! -- The caller has checked the initial token(s) is/are NEW, ASTRACT NEW, -- or LIMITED NEW, ABSTRACT LIMITED NEW, SYNCHRONIZED NEW or ABSTRACT -- SYNCHRONIZED NEW. --- 830,836 ---- -- [abstract] [limited | synchronized] -- new SUBTYPE_MARK [[and INTERFACE_LIST] with private] ! -- The caller has checked the initial token(s) is/are NEW, ABSTRACT NEW, -- or LIMITED NEW, ABSTRACT LIMITED NEW, SYNCHRONIZED NEW or ABSTRACT -- SYNCHRONIZED NEW. diff -Nrcpad gcc-4.3.3/gcc/ada/par-ch2.adb gcc-4.4.0/gcc/ada/par-ch2.adb *** gcc-4.3.3/gcc/ada/par-ch2.adb Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/par-ch2.adb Mon Mar 31 19:28:19 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Ch2 is *** 118,124 **** -- DECIMAL_LITERAL ::= NUMERAL [.NUMERAL] [EXPONENT] ! -- Handled by scanner as part of numeric lIteral handing (see 2.4) -------------------- -- 2.4.1 Numeral -- --- 118,124 ---- -- DECIMAL_LITERAL ::= NUMERAL [.NUMERAL] [EXPONENT] ! -- Handled by scanner as part of numeric literal handing (see 2.4) -------------------- -- 2.4.1 Numeral -- *************** package body Ch2 is *** 241,248 **** -- Set True if an identifier is encountered for a pragma argument. Used -- to check that there are no more arguments without identifiers. ! Pragma_Node : Node_Id; ! Pragma_Name : Name_Id; Semicolon_Loc : Source_Ptr; Ident_Node : Node_Id; Assoc_Node : Node_Id; --- 241,248 ---- -- Set True if an identifier is encountered for a pragma argument. Used -- to check that there are no more arguments without identifiers. ! Prag_Node : Node_Id; ! Prag_Name : Name_Id; Semicolon_Loc : Source_Ptr; Ident_Node : Node_Id; Assoc_Node : Node_Id; *************** package body Ch2 is *** 280,288 **** -- Start of processing for P_Pragma begin ! Pragma_Node := New_Node (N_Pragma, Token_Ptr); Scan; -- past PRAGMA ! Pragma_Name := Token_Name; if Style_Check then Style.Check_Pragma_Name; --- 280,288 ---- -- Start of processing for P_Pragma begin ! Prag_Node := New_Node (N_Pragma, Token_Ptr); Scan; -- past PRAGMA ! Prag_Name := Token_Name; if Style_Check then Style.Check_Pragma_Name; *************** package body Ch2 is *** 294,314 **** if Ada_Version >= Ada_05 and then Token = Tok_Interface then ! Pragma_Name := Name_Interface; Ident_Node := Make_Identifier (Token_Ptr, Name_Interface); Scan; -- past INTERFACE else Ident_Node := P_Identifier; end if; ! Set_Chars (Pragma_Node, Pragma_Name); ! Set_Pragma_Identifier (Pragma_Node, Ident_Node); -- See if special INTERFACE/IMPORT check is required if SIS_Entry_Active then ! Interface_Check_Required := (Pragma_Name = Name_Interface); ! Import_Check_Required := (Pragma_Name = Name_Import); else Interface_Check_Required := False; Import_Check_Required := False; --- 294,313 ---- if Ada_Version >= Ada_05 and then Token = Tok_Interface then ! Prag_Name := Name_Interface; Ident_Node := Make_Identifier (Token_Ptr, Name_Interface); Scan; -- past INTERFACE else Ident_Node := P_Identifier; end if; ! Set_Pragma_Identifier (Prag_Node, Ident_Node); -- See if special INTERFACE/IMPORT check is required if SIS_Entry_Active then ! Interface_Check_Required := (Prag_Name = Name_Interface); ! Import_Check_Required := (Prag_Name = Name_Import); else Interface_Check_Required := False; Import_Check_Required := False; *************** package body Ch2 is *** 322,328 **** or else (Token /= Tok_Semicolon and then not Token_Is_At_Start_Of_Line) then ! Set_Pragma_Argument_Associations (Pragma_Node, New_List); T_Left_Paren; loop --- 321,327 ---- or else (Token /= Tok_Semicolon and then not Token_Is_At_Start_Of_Line) then ! Set_Pragma_Argument_Associations (Prag_Node, New_List); T_Left_Paren; loop *************** package body Ch2 is *** 342,348 **** end if; end if; ! Append (Assoc_Node, Pragma_Argument_Associations (Pragma_Node)); exit when Token /= Tok_Comma; Scan; -- past comma end loop; --- 341,347 ---- end if; end if; ! Append (Assoc_Node, Pragma_Argument_Associations (Prag_Node)); exit when Token /= Tok_Comma; Scan; -- past comma end loop; *************** package body Ch2 is *** 352,358 **** -- statement, and an assignment statement is the most likely -- candidate for this error) ! if Token = Tok_Colon_Equal and then Pragma_Name = Name_Debug then Error_Msg_SC ("argument for pragma Debug must be procedure call"); Resync_To_Semicolon; --- 351,357 ---- -- statement, and an assignment statement is the most likely -- candidate for this error) ! if Token = Tok_Colon_Equal and then Prag_Name = Name_Debug then Error_Msg_SC ("argument for pragma Debug must be procedure call"); Resync_To_Semicolon; *************** package body Ch2 is *** 378,390 **** -- case of pragma Source_File_Name, which assume the semicolon -- is already scanned out. ! if Chars (Pragma_Node) = Name_Style_Checks then ! Result := Par.Prag (Pragma_Node, Semicolon_Loc); Skip_Pragma_Semicolon; return Result; else Skip_Pragma_Semicolon; ! return Par.Prag (Pragma_Node, Semicolon_Loc); end if; exception --- 377,389 ---- -- case of pragma Source_File_Name, which assume the semicolon -- is already scanned out. ! if Prag_Name = Name_Style_Checks then ! Result := Par.Prag (Prag_Node, Semicolon_Loc); Skip_Pragma_Semicolon; return Result; else Skip_Pragma_Semicolon; ! return Par.Prag (Prag_Node, Semicolon_Loc); end if; exception *************** package body Ch2 is *** 434,447 **** -- Error recovery: Cannot raise Error_Resync procedure P_Pragmas_Opt (List : List_Id) is ! P : Node_Id; begin while Token = Tok_Pragma loop P := P_Pragma; ! if Chars (P) = Name_Assert or else Chars (P) = Name_Debug then ! Error_Msg_Name_1 := Chars (P); Error_Msg_N ("pragma% must be in declaration/statement context", P); else --- 433,450 ---- -- Error recovery: Cannot raise Error_Resync procedure P_Pragmas_Opt (List : List_Id) is ! P : Node_Id; begin while Token = Tok_Pragma loop P := P_Pragma; ! if Nkind (P) /= N_Error ! and then (Pragma_Name (P) = Name_Assert ! or else ! Pragma_Name (P) = Name_Debug) ! then ! Error_Msg_Name_1 := Pragma_Name (P); Error_Msg_N ("pragma% must be in declaration/statement context", P); else diff -Nrcpad gcc-4.3.3/gcc/ada/par-ch3.adb gcc-4.4.0/gcc/ada/par-ch3.adb *** gcc-4.3.3/gcc/ada/par-ch3.adb Wed Dec 19 16:24:06 2007 --- gcc-4.4.0/gcc/ada/par-ch3.adb Fri Aug 1 10:44:17 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Ch3 is *** 206,211 **** --- 206,223 ---- Ident_Node := Token_Node; Scan; -- past the reserved identifier + -- If we already have a defining identifier, clean it out and make + -- a new clean identifier. This situation arises in some error cases + -- and we need to fix it. + + if Nkind (Ident_Node) = N_Defining_Identifier then + Ident_Node := + Make_Identifier (Sloc (Ident_Node), + Chars => Chars (Ident_Node)); + end if; + + -- Change identifier to defining identifier if not in error + if Ident_Node /= Error then Change_Identifier_To_Defining_Identifier (Ident_Node); end if; *************** package body Ch3 is *** 290,309 **** Scan; -- past TYPE Ident_Node := P_Defining_Identifier (C_Is); ! -- Otherwise this is an error case, and we may already have converted ! -- the current token to a defining identifier, so don't do it again! else T_Type; ! ! if Token = Tok_Identifier ! and then Nkind (Token_Node) = N_Defining_Identifier ! then ! Ident_Node := Token_Node; ! Scan; -- past defining identifier ! else ! Ident_Node := P_Defining_Identifier (C_Is); ! end if; end if; Discr_Sloc := Token_Ptr; --- 302,313 ---- Scan; -- past TYPE Ident_Node := P_Defining_Identifier (C_Is); ! -- Otherwise this is an error case else T_Type; ! Type_Token_Location := Type_Loc; ! Ident_Node := P_Defining_Identifier (C_Is); end if; Discr_Sloc := Token_Ptr; *************** package body Ch3 is *** 412,418 **** Scan; -- past ALIASED end if; ! -- The following procesing deals with either a private type declaration -- or a full type declaration. In the private type case, we build the -- N_Private_Type_Declaration node, setting its Tagged_Present and -- Limited_Present flags, on encountering the Private keyword, and --- 416,422 ---- Scan; -- past ALIASED end if; ! -- The following processing deals with either a private type declaration -- or a full type declaration. In the private type case, we build the -- N_Private_Type_Declaration node, setting its Tagged_Present and -- Limited_Present flags, on encountering the Private keyword, and *************** package body Ch3 is *** 767,772 **** --- 771,780 ---- -- Interface else + if Token /= Tok_Interface then + Error_Msg_SC ("NEW or INTERFACE expected"); + end if; + Typedef_Node := P_Interface_Type_Definition (Abstract_Present); Abstract_Present := True; *************** package body Ch3 is *** 1316,1322 **** Check_Misspelling_Of (Tok_Renames); if Token = Tok_Renames then ! Error_Msg_SP ("extra "":"" ignored"); Scan; -- past RENAMES return True; else --- 1324,1330 ---- Check_Misspelling_Of (Tok_Renames); if Token = Tok_Renames then ! Error_Msg_SP ("|extra "":"" ignored"); Scan; -- past RENAMES return True; else *************** package body Ch3 is *** 1352,1358 **** -- If we have a comma, then scan out the list of identifiers elsif Token = Tok_Comma then - while Comma_Present loop Num_Idents := Num_Idents + 1; Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); --- 1360,1365 ---- *************** package body Ch3 is *** 2070,2076 **** return Range_Node; -- Case of subtype mark (optionally qualified simple name or an ! -- attribute whose prefix is an optionally qualifed simple name) elsif Expr_Form = EF_Simple_Name or else Nkind (Expr_Node) = N_Attribute_Reference --- 2077,2083 ---- return Range_Node; -- Case of subtype mark (optionally qualified simple name or an ! -- attribute whose prefix is an optionally qualified simple name) elsif Expr_Form = EF_Simple_Name or else Nkind (Expr_Node) = N_Attribute_Reference *************** package body Ch3 is *** 2290,2296 **** -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order if Token = Tok_Delta then ! Error_Msg_SC ("DELTA must come before DIGITS"); Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc); Scan; -- past DELTA Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren); --- 2297,2303 ---- -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order if Token = Tok_Delta then ! Error_Msg_SC ("|DELTA must come before DIGITS"); Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc); Scan; -- past DELTA Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren); *************** package body Ch3 is *** 2883,2889 **** end P_Known_Discriminant_Part_Opt; ------------------------------------- ! -- 3.7 DIscriminant Specification -- ------------------------------------- -- Parsed by P_Known_Discriminant_Part_Opt (3.7) --- 2890,2896 ---- end P_Known_Discriminant_Part_Opt; ------------------------------------- ! -- 3.7 Discriminant Specification -- ------------------------------------- -- Parsed by P_Known_Discriminant_Part_Opt (3.7) *************** package body Ch3 is *** 3542,3548 **** else begin Expr_Node := P_Expression_Or_Range_Attribute; ! Check_No_Right_Paren; if Token = Tok_Colon and then Nkind (Expr_Node) = N_Identifier --- 3549,3555 ---- else begin Expr_Node := P_Expression_Or_Range_Attribute; ! Ignore (Tok_Right_Paren); if Token = Tok_Colon and then Nkind (Expr_Node) = N_Identifier *************** package body Ch3 is *** 3657,3663 **** -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have -- a list of interfaces we build a derived_type_definition node. This ! -- simplifies the semantic analysis (and hence further mainteinance) else if Token /= Tok_And then --- 3664,3670 ---- -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have -- a list of interfaces we build a derived_type_definition node. This ! -- simplifies the semantic analysis (and hence further maintenance) else if Token /= Tok_And then *************** package body Ch3 is *** 3927,3934 **** if Token = Tok_All then if Ada_Version < Ada_05 then Error_Msg_SP ! ("access-all in this context is an Ada 2005 extension"); ! Error_Msg_SP ("\unit should be compiled with -gnat05 switch"); end if; Scan; -- past ALL --- 3934,3940 ---- if Token = Tok_All then if Ada_Version < Ada_05 then Error_Msg_SP ! ("ALL is not permitted for anonymous access types"); end if; Scan; -- past ALL *************** package body Ch3 is *** 4176,4182 **** -- Otherwise we saved the semicolon position, so complain else ! Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc); end if; -- The next job is to fix up any declarations that occurred --- 4182,4188 ---- -- Otherwise we saved the semicolon position, so complain else ! Error_Msg ("|"";"" should be IS", SIS_Semicolon_Sloc); end if; -- The next job is to fix up any declarations that occurred diff -Nrcpad gcc-4.3.3/gcc/ada/par-ch4.adb gcc-4.4.0/gcc/ada/par-ch4.adb *** gcc-4.3.3/gcc/ada/par-ch4.adb Thu Dec 13 10:22:06 2007 --- gcc-4.4.0/gcc/ada/par-ch4.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Stringt; use Stringt; *** 32,40 **** separate (Par) package body Ch4 is ! --------------- ! -- Local map -- ! --------------- Is_Parameterless_Attribute : constant Attribute_Class_Array := (Attribute_Body_Version => True, --- 32,38 ---- separate (Par) package body Ch4 is ! -- Attributes that cannot have arguments Is_Parameterless_Attribute : constant Attribute_Class_Array := (Attribute_Body_Version => True, *************** package body Ch4 is *** 51,56 **** --- 49,62 ---- -- list because it may denote a slice operation (X'Img (1 .. 2)) or -- a type conversion (X'Class (Y)). + -- Note that this map designates the minimum set of attributes where a + -- construct in parentheses that is not an argument can appear right + -- after the attribute. For attributes like 'Size, we do not put them + -- in the map. If someone writes X'Size (3), that's illegal in any case, + -- but we get a better error message by parsing the (3) as an illegal + -- argument to the attribute, rather than some meaningless junk that + -- follows the attribute. + ----------------------- -- Local Subprograms -- ----------------------- *************** package body Ch4 is *** 405,411 **** begin if Token_Is_At_Start_Of_Line then Restore_Scan_State (Scan_State); -- to apostrophe ! Error_Msg_SC ("""''"" should be "";"""); Token := Tok_Semicolon; return True; else --- 411,417 ---- begin if Token_Is_At_Start_Of_Line then Restore_Scan_State (Scan_State); -- to apostrophe ! Error_Msg_SC ("|""''"" should be "";"""); Token := Tok_Semicolon; return True; else *************** package body Ch4 is *** 501,511 **** Set_Prefix (Name_Node, Prefix_Node); Set_Attribute_Name (Name_Node, Attr_Name); ! -- Scan attribute arguments/designator if Token = Tok_Left_Paren ! and then ! not Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name)) then Set_Expressions (Name_Node, New_List); Scan; -- past left paren --- 507,518 ---- Set_Prefix (Name_Node, Prefix_Node); Set_Attribute_Name (Name_Node, Attr_Name); ! -- Scan attribute arguments/designator. We skip this if we know ! -- that the attribute cannot have an argument. if Token = Tok_Left_Paren ! and then not ! Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name)) then Set_Expressions (Name_Node, New_List); Scan; -- past left paren *************** package body Ch4 is *** 1136,1144 **** end if; end P_Aggregate; ! ------------------------------------------------- ! -- 4.3 Aggregate or Parenthesized Expresssion -- ! ------------------------------------------------- -- This procedure parses out either an aggregate or a parenthesized -- expression (these two constructs are closely related, since a --- 1143,1151 ---- end if; end P_Aggregate; ! ------------------------------------------------ ! -- 4.3 Aggregate or Parenthesized Expression -- ! ------------------------------------------------ -- This procedure parses out either an aggregate or a parenthesized -- expression (these two constructs are closely related, since a *************** package body Ch4 is *** 1599,1605 **** function P_Expression_No_Right_Paren return Node_Id is Expr : constant Node_Id := P_Expression; begin ! Check_No_Right_Paren; return Expr; end P_Expression_No_Right_Paren; --- 1606,1612 ---- function P_Expression_No_Right_Paren return Node_Id is Expr : constant Node_Id := P_Expression; begin ! Ignore (Tok_Right_Paren); return Expr; end P_Expression_No_Right_Paren; *************** package body Ch4 is *** 1891,1897 **** Node1 := P_Term; end if; ! -- In the following, we special-case a sequence of concatentations of -- string literals, such as "aaa" & "bbb" & ... & "ccc", with nothing -- else mixed in. For such a sequence, we return a tree representing -- "" & "aaabbb...ccc" (a single concatenation). This is done only if --- 1898,1904 ---- Node1 := P_Term; end if; ! -- In the following, we special-case a sequence of concatenations of -- string literals, such as "aaa" & "bbb" & ... & "ccc", with nothing -- else mixed in. For such a sequence, we return a tree representing -- "" & "aaabbb...ccc" (a single concatenation). This is done only if *************** package body Ch4 is *** 2332,2338 **** return P_Identifier; elsif Prev_Token = Tok_Comma then ! Error_Msg_SP ("extra "","" ignored"); raise Error_Resync; else --- 2339,2345 ---- return P_Identifier; elsif Prev_Token = Tok_Comma then ! Error_Msg_SP ("|extra "","" ignored"); raise Error_Resync; else *************** package body Ch4 is *** 2430,2436 **** begin if Token = Tok_Box then ! Error_Msg_SC ("""'<'>"" should be ""/="""); end if; Op_Kind := Relop_Node (Token); --- 2437,2443 ---- begin if Token = Tok_Box then ! Error_Msg_SC ("|""'<'>"" should be ""/="""); end if; Op_Kind := Relop_Node (Token); diff -Nrcpad gcc-4.3.3/gcc/ada/par-ch5.adb gcc-4.4.0/gcc/ada/par-ch5.adb *** gcc-4.3.3/gcc/ada/par-ch5.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/par-ch5.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Ch5 is *** 203,212 **** Statement_Required := SS_Flags.Sreq; loop ! while Token = Tok_Semicolon loop ! Error_Msg_SC ("unexpected semicolon ignored"); ! Scan; -- past junk semicolon ! end loop; begin if Style_Check then --- 203,209 ---- Statement_Required := SS_Flags.Sreq; loop ! Ignore (Tok_Semicolon); begin if Style_Check then *************** package body Ch5 is *** 565,574 **** -- Skip junk right parens in this context ! while Token = Tok_Right_Paren loop ! Error_Msg_SC ("extra right paren"); ! Scan; -- past ) ! end loop; -- Check context following call --- 562,568 ---- -- Skip junk right parens in this context ! Ignore (Tok_Right_Paren); -- Check context following call *************** package body Ch5 is *** 990,996 **** -- LABEL ::= <> ! -- STATEMENT_INDENTIFIER ::= DIRECT_NAME -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier -- (not an OPERATOR_SYMBOL) --- 984,990 ---- -- LABEL ::= <> ! -- STATEMENT_IDENTIFIER ::= DIRECT_NAME -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier -- (not an OPERATOR_SYMBOL) *************** package body Ch5 is *** 1073,1079 **** -- scanned out and is in Prev_Token. procedure Check_If_Column; ! -- An internal procedure used to check that THEN, ELSE ELSE, or ELSIF -- appear in the right place if column checking is enabled (i.e. if -- they are the first token on the line, then they must appear in -- the same column as the opening IF). --- 1067,1073 ---- -- scanned out and is in Prev_Token. procedure Check_If_Column; ! -- An internal procedure used to check that THEN, ELSE, or ELSIF -- appear in the right place if column checking is enabled (i.e. if -- they are the first token on the line, then they must appear in -- the same column as the opening IF). *************** package body Ch5 is *** 2200,2206 **** -- What we are interested in is whether it was a case of a bad IS. if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then ! Error_Msg ("IS should be "";""", Scope.Table (Scope.Last + 1).S_Is); Set_Bad_Is_Detected (Parent, True); end if; --- 2194,2200 ---- -- What we are interested in is whether it was a case of a bad IS. if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then ! Error_Msg ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is); Set_Bad_Is_Detected (Parent, True); end if; *************** package body Ch5 is *** 2235,2241 **** if Token = Tok_And or else Token = Tok_Or then Error_Msg_SC ("unexpected logical operator"); ! Scan; if (Prev_Token = Tok_And and then Token = Tok_Then) or else --- 2229,2235 ---- if Token = Tok_And or else Token = Tok_Or then Error_Msg_SC ("unexpected logical operator"); ! Scan; -- past logical operator if (Prev_Token = Tok_And and then Token = Tok_Then) or else diff -Nrcpad gcc-4.3.3/gcc/ada/par-ch6.adb gcc-4.4.0/gcc/ada/par-ch6.adb *** gcc-4.3.3/gcc/ada/par-ch6.adb Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/par-ch6.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Ch6 is *** 64,72 **** if Token = Tok_Return then Restore_Scan_State (Scan_State); ! Error_Msg_SC ("unexpected semicolon ignored"); Scan; -- rescan past junk semicolon - else Restore_Scan_State (Scan_State); end if; --- 64,71 ---- if Token = Tok_Return then Restore_Scan_State (Scan_State); ! Error_Msg_SC ("|extra "";"" ignored"); Scan; -- rescan past junk semicolon else Restore_Scan_State (Scan_State); end if; *************** package body Ch6 is *** 203,209 **** -- Note: in the case of OVERRIDING keyword used in Ada 95 mode, the -- declaration circuit already gave an error message and changed the ! -- tokem to Tok_Overriding. elsif Token = Tok_Overriding then Scan; -- past OVERRIDING --- 202,208 ---- -- Note: in the case of OVERRIDING keyword used in Ada 95 mode, the -- declaration circuit already gave an error message and changed the ! -- token to Tok_Overriding. elsif Token = Tok_Overriding then Scan; -- past OVERRIDING *************** package body Ch6 is *** 265,275 **** end if; Scope.Table (Scope.Last).Labl := Name_Node; ! ! if Token = Tok_Colon then ! Error_Msg_SC ("redundant colon ignored"); ! Scan; -- past colon ! end if; -- Deal with generic instantiation, the one case in which we do not -- have a subprogram specification as part of whatever we are parsing --- 264,270 ---- end if; Scope.Table (Scope.Last).Labl := Name_Node; ! Ignore (Tok_Colon); -- Deal with generic instantiation, the one case in which we do not -- have a subprogram specification as part of whatever we are parsing *************** package body Ch6 is *** 280,286 **** if Token = Tok_New then if not Pf_Flags.Gins then ! Error_Msg_SC ("generic instantation not allowed here!"); end if; Scan; -- past NEW --- 275,281 ---- if Token = Tok_New then if not Pf_Flags.Gins then ! Error_Msg_SC ("generic instantiation not allowed here!"); end if; Scan; -- past NEW *************** package body Ch6 is *** 411,416 **** --- 406,424 ---- Discard_Junk_Node (P_Expression); end if; + -- Deal with semicolon followed by IS. We want to treat this as IS + + if Token = Tok_Semicolon then + Save_Scan_State (Scan_State); + Scan; -- past semicolon + + if Token = Tok_Is then + Error_Msg_SP ("extra "";"" ignored"); + else + Restore_Scan_State (Scan_State); + end if; + end if; + -- Deal with case of semicolon ending a subprogram declaration if Token = Tok_Semicolon then *************** package body Ch6 is *** 424,431 **** -- semicolon, and go process the body. if Token = Tok_Is then ! Error_Msg_SP ("unexpected semicolon ignored"); ! T_Is; -- ignroe redundant IS's goto Subprogram_Body; -- If BEGIN follows in an appropriate column, we immediately --- 432,439 ---- -- semicolon, and go process the body. if Token = Tok_Is then ! Error_Msg_SP ("|extra "";"" ignored"); ! T_Is; -- scan past IS goto Subprogram_Body; -- If BEGIN follows in an appropriate column, we immediately *************** package body Ch6 is *** 436,442 **** elsif Token = Tok_Begin and then Start_Column >= Scope.Table (Scope.Last).Ecol then ! Error_Msg_SP (""";"" should be IS!"); goto Subprogram_Body; else --- 444,450 ---- elsif Token = Tok_Begin and then Start_Column >= Scope.Table (Scope.Last).Ecol then ! Error_Msg_SP ("|"";"" should be IS!"); goto Subprogram_Body; else *************** package body Ch6 is *** 540,546 **** -- semicolon which should really be an IS else ! Error_Msg_AP ("missing "";"""); SIS_Missing_Semicolon_Message := Get_Msg_Id; goto Subprogram_Declaration; end if; --- 548,554 ---- -- semicolon which should really be an IS else ! Error_Msg_AP ("|missing "";"""); SIS_Missing_Semicolon_Message := Get_Msg_Id; goto Subprogram_Declaration; end if; *************** package body Ch6 is *** 1203,1209 **** -- that semicolon should have been a right parenthesis and exit if Token = Tok_Is or else Token = Tok_Return then ! Error_Msg_SP ("expected "")"" in place of "";"""); exit Specification_Loop; end if; --- 1211,1217 ---- -- that semicolon should have been a right parenthesis and exit if Token = Tok_Is or else Token = Tok_Return then ! Error_Msg_SP ("|"";"" should be "")"""); exit Specification_Loop; end if; *************** package body Ch6 is *** 1289,1295 **** end if; if Token = Tok_In then ! Error_Msg_SC ("IN must preceed OUT in parameter mode"); Scan; -- past IN Set_In_Present (Node, True); end if; --- 1297,1303 ---- end if; if Token = Tok_In then ! Error_Msg_SC ("IN must precede OUT in parameter mode"); Scan; -- past IN Set_In_Present (Node, True); end if; diff -Nrcpad gcc-4.3.3/gcc/ada/par-ch9.adb gcc-4.4.0/gcc/ada/par-ch9.adb *** gcc-4.3.3/gcc/ada/par-ch9.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/par-ch9.adb Tue May 20 12:48:30 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Ch9 is *** 154,160 **** Scan; -- past semicolon if Token = Tok_Entry then ! Error_Msg_SP (""";"" should be IS"); Set_Task_Definition (Task_Node, P_Task_Definition); else Pop_Scope_Stack; -- Remove unused entry --- 154,160 ---- Scan; -- past semicolon if Token = Tok_Entry then ! Error_Msg_SP ("|"";"" should be IS"); Set_Task_Definition (Task_Node, P_Task_Definition); else Pop_Scope_Stack; -- Remove unused entry *************** package body Ch9 is *** 371,376 **** --- 371,377 ---- Name_Node : Node_Id; Protected_Node : Node_Id; Protected_Sloc : Source_Ptr; + Scan_State : Saved_Scan_State; begin Push_Scope_Stack; *************** package body Ch9 is *** 439,444 **** --- 440,474 ---- Scope.Table (Scope.Last).Labl := Name_Node; end if; + -- Check for semicolon not followed by IS, this is something like + + -- protected type r; + + -- where we want + + -- protected type r IS END; + + if Token = Tok_Semicolon then + Save_Scan_State (Scan_State); -- at semicolon + Scan; -- past semicolon + + if Token /= Tok_Is then + Restore_Scan_State (Scan_State); + Error_Msg_SC ("missing IS"); + Set_Protected_Definition (Protected_Node, + Make_Protected_Definition (Token_Ptr, + Visible_Declarations => Empty_List, + End_Label => Empty)); + + SIS_Entry_Active := False; + End_Statements (Protected_Definition (Protected_Node)); + Scan; -- past semicolon + return Protected_Node; + end if; + + Error_Msg_SP ("|extra ""("" ignored"); + end if; + T_Is; -- Ada 2005 (AI-345) *************** package body Ch9 is *** 447,453 **** Scan; -- past NEW if Ada_Version < Ada_05 then ! Error_Msg_SP ("task interface is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; --- 477,483 ---- Scan; -- past NEW if Ada_Version < Ada_05 then ! Error_Msg_SP ("protected interface is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; *************** package body Ch9 is *** 466,476 **** end if; Scan; -- past WITH - - if Token = Tok_Private then - Error_Msg_SP - ("PRIVATE not allowed in protected type declaration"); - end if; end if; Set_Protected_Definition (Protected_Node, P_Protected_Definition); --- 496,501 ---- *************** package body Ch9 is *** 531,538 **** Append (Item_Node, Visible_Declarations (Def_Node)); end loop; ! -- Deal with PRIVATE part (including graceful handling ! -- of multiple PRIVATE parts). Private_Loop : while Token = Tok_Private loop if No (Private_Declarations (Def_Node)) then --- 556,563 ---- Append (Item_Node, Visible_Declarations (Def_Node)); end loop; ! -- Deal with PRIVATE part (including graceful handling of multiple ! -- PRIVATE parts). Private_Loop : while Token = Tok_Private loop if No (Private_Declarations (Def_Node)) then *************** package body Ch9 is *** 817,823 **** Restore_Scan_State (Scan_State); -- to Id Set_Parameter_Specifications (Decl_Node, P_Formal_Part); ! -- Else if Id wi no comma or colon, must be discrete subtype defn else Restore_Scan_State (Scan_State); -- to Id --- 842,849 ---- Restore_Scan_State (Scan_State); -- to Id Set_Parameter_Specifications (Decl_Node, P_Formal_Part); ! -- Else if Id without comma or colon, must be discrete subtype ! -- defn else Restore_Scan_State (Scan_State); -- to Id *************** package body Ch9 is *** 1081,1087 **** Bnode := P_Expression_No_Right_Paren; if Token = Tok_Colon_Equal then ! Error_Msg_SC (""":="" should be ""="""); Scan; Bnode := P_Expression_No_Right_Paren; end if; --- 1107,1113 ---- Bnode := P_Expression_No_Right_Paren; if Token = Tok_Colon_Equal then ! Error_Msg_SC ("|"":="" should be ""="""); Scan; Bnode := P_Expression_No_Right_Paren; end if; *************** package body Ch9 is *** 1328,1334 **** Ecall_Node := P_Name; -- ?? The following two clauses exactly parallel code in ch5 ! -- and should be commoned sometime if Nkind (Ecall_Node) = N_Indexed_Component then declare --- 1354,1360 ---- Ecall_Node := P_Name; -- ?? The following two clauses exactly parallel code in ch5 ! -- and should be combined sometime if Nkind (Ecall_Node) = N_Indexed_Component then declare *************** package body Ch9 is *** 1447,1453 **** End_Statements; ! -- Here we have a selective accept or an an asynchronous select (first -- token after SELECT is other than a designator token). else --- 1473,1479 ---- End_Statements; ! -- Here we have a selective accept or an asynchronous select (first -- token after SELECT is other than a designator token). else *************** package body Ch9 is *** 1638,1644 **** -- Note: the reason that we accept THEN ABORT as a terminator for -- the sequence of statements is for error recovery which allows ! -- for misuse of an accept statement as a triggering statememt. Set_Statements (Accept_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); --- 1664,1670 ---- -- Note: the reason that we accept THEN ABORT as a terminator for -- the sequence of statements is for error recovery which allows ! -- for misuse of an accept statement as a triggering statement. Set_Statements (Accept_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); *************** package body Ch9 is *** 1666,1672 **** -- Note: the reason that we accept THEN ABORT as a terminator for -- the sequence of statements is for error recovery which allows ! -- for misuse of an accept statement as a triggering statememt. Set_Statements (Delay_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); --- 1692,1698 ---- -- Note: the reason that we accept THEN ABORT as a terminator for -- the sequence of statements is for error recovery which allows ! -- for misuse of an accept statement as a triggering statement. Set_Statements (Delay_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); diff -Nrcpad gcc-4.3.3/gcc/ada/par-endh.adb gcc-4.4.0/gcc/ada/par-endh.adb *** gcc-4.3.3/gcc/ada/par-endh.adb Thu Dec 13 10:27:58 2007 --- gcc-4.4.0/gcc/ada/par-endh.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Endh is *** 302,308 **** -- opening label, with the components all marked as not -- from source, and Is_End_Label set in the identifier -- or operator symbol. The location for all components ! -- is the curent token location. -- Case of child unit name --- 302,308 ---- -- opening label, with the components all marked as not -- from source, and Is_End_Label set in the identifier -- or operator symbol. The location for all components ! -- is the current token location. -- Case of child unit name *************** package body Endh is *** 975,981 **** else -- A special check. If we have END; followed by an end of file, -- WITH or SEPARATE, then if we are not at the outer level, then ! -- we have a sytax error. Consider the example: -- ... -- declare --- 975,981 ---- else -- A special check. If we have END; followed by an end of file, -- WITH or SEPARATE, then if we are not at the outer level, then ! -- we have a syntax error. Consider the example: -- ... -- declare *************** package body Endh is *** 1128,1134 **** -- First we see how good the current END entry is with respect to -- what we expect. It is considered pretty good if the token is OK, ! -- and either the label or the column matches. an END for RECORD is -- always considered to be pretty good in the record case. This is -- because not only does a record disallow a nested structure, but -- also it is unlikely that such nesting could occur by accident. --- 1128,1134 ---- -- First we see how good the current END entry is with respect to -- what we expect. It is considered pretty good if the token is OK, ! -- and either the label or the column matches. An END for RECORD is -- always considered to be pretty good in the record case. This is -- because not only does a record disallow a nested structure, but -- also it is unlikely that such nesting could occur by accident. diff -Nrcpad gcc-4.3.3/gcc/ada/par-labl.adb gcc-4.4.0/gcc/ada/par-labl.adb *** gcc-4.3.3/gcc/ada/par-labl.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/par-labl.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** procedure Labl is *** 177,186 **** procedure No_Header (N : Elmt_Id); -- The label N is known not to be a loop header. Scan forward and ! -- remove all subsequent goto's that may have this node as a target. procedure Process_Goto (N : Elmt_Id); ! -- N is a forward jump. Scan forward and remove all subsequent goto's -- that may have the same target, to preclude spurious loops. procedure Rewrite_As_Loop --- 177,186 ---- procedure No_Header (N : Elmt_Id); -- The label N is known not to be a loop header. Scan forward and ! -- remove all subsequent gotos that may have this node as a target. procedure Process_Goto (N : Elmt_Id); ! -- N is a forward jump. Scan forward and remove all subsequent gotos -- that may have the same target, to preclude spurious loops. procedure Rewrite_As_Loop diff -Nrcpad gcc-4.3.3/gcc/ada/par-prag.adb gcc-4.4.0/gcc/ada/par-prag.adb *** gcc-4.3.3/gcc/ada/par-prag.adb Wed Dec 19 16:22:02 2007 --- gcc-4.4.0/gcc/ada/par-prag.adb Fri Aug 22 15:07:34 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with System.WCh_Con; use System.WCh_Con; *** 43,50 **** separate (Par) function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is ! Pragma_Name : constant Name_Id := Chars (Pragma_Node); ! Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name); Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node); Arg_Count : Nat; Arg_Node : Node_Id; --- 43,50 ---- separate (Par) function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is ! Prag_Name : constant Name_Id := Pragma_Name (Pragma_Node); ! Prag_Id : constant Pragma_Id := Get_Pragma_Id (Prag_Name); Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node); Arg_Count : Nat; Arg_Node : Node_Id; *************** function Prag (Pragma_Node : Node_Id; Se *** 234,250 **** elsif Id = Name_No_Dependence then Set_Restriction_No_Dependence (Unit => Expr, ! Warn => Prag_Id = Pragma_Restriction_Warnings); end if; Next (Arg); end loop; end Process_Restrictions_Or_Restriction_Warnings; ! -- Start if processing for Prag begin ! Error_Msg_Name_1 := Pragma_Name; -- Ignore unrecognized pragma. We let Sem post the warning for this, since -- it is a semantic error, not a syntactic one (we have already checked --- 234,251 ---- elsif Id = Name_No_Dependence then Set_Restriction_No_Dependence (Unit => Expr, ! Warn => Prag_Id = Pragma_Restriction_Warnings ! or else Treat_Restrictions_As_Warnings); end if; Next (Arg); end loop; end Process_Restrictions_Or_Restriction_Warnings; ! -- Start of processing for Prag begin ! Error_Msg_Name_1 := Prag_Name; -- Ignore unrecognized pragma. We let Sem post the warning for this, since -- it is a semantic error, not a syntactic one (we have already checked *************** begin *** 527,533 **** -- Process Casing argument of pattern form of pragma procedure Process_Dot_Replacement (Arg : Node_Id); ! -- Process Dot_Replacement argument of patterm form of pragma --------------- -- Get_Fname -- --- 528,534 ---- -- Process Casing argument of pattern form of pragma procedure Process_Dot_Replacement (Arg : Node_Id); ! -- Process Dot_Replacement argument of pattern form of pragma --------------- -- Get_Fname -- *************** begin *** 626,632 **** -- Source_File_Name_Project pragmas. begin ! if Get_Pragma_Id (Pragma_Name) = Pragma_Source_File_Name then if Project_File_In_Use = In_Use then Error_Msg ("pragma Source_File_Name cannot be used " & --- 627,633 ---- -- Source_File_Name_Project pragmas. begin ! if Prag_Id = Pragma_Source_File_Name then if Project_File_In_Use = In_Use then Error_Msg ("pragma Source_File_Name cannot be used " & *************** begin *** 1031,1036 **** --- 1032,1041 ---- raise Constraint_Error; end if; + Upper_Half_Encoding := + Wide_Character_Encoding_Method in + WC_Upper_Half_Encoding_Method; + exception when Constraint_Error => Error_Msg_N ("invalid argument for pragma%", Arg1); *************** begin *** 1045,1050 **** --- 1050,1056 ---- when Pragma_Abort_Defer | Pragma_Assertion_Policy | + Pragma_Assume_No_Invalid_Values | Pragma_AST_Entry | Pragma_All_Calls_Remote | Pragma_Annotate | *************** begin *** 1053,1059 **** --- 1059,1067 ---- Pragma_Atomic | Pragma_Atomic_Components | Pragma_Attach_Handler | + Pragma_Check | Pragma_Check_Name | + Pragma_Check_Policy | Pragma_CIL_Constructor | Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning | *************** begin *** 1135,1145 **** --- 1143,1156 ---- Pragma_No_Strict_Aliasing | Pragma_Normalize_Scalars | Pragma_Optimize | + Pragma_Optimize_Alignment | Pragma_Pack | Pragma_Passive | Pragma_Preelaborable_Initialization | Pragma_Polling | Pragma_Persistent_BSS | + Pragma_Postcondition | + Pragma_Precondition | Pragma_Preelaborate | Pragma_Preelaborate_05 | Pragma_Priority | *************** begin *** 1152,1157 **** --- 1163,1169 ---- Pragma_Pure_05 | Pragma_Pure_Function | Pragma_Queuing_Policy | + Pragma_Relative_Deadline | Pragma_Remote_Call_Interface | Pragma_Remote_Types | Pragma_Restricted_Run_Time | diff -Nrcpad gcc-4.3.3/gcc/ada/par-sync.adb gcc-4.4.0/gcc/ada/par-sync.adb *** gcc-4.3.3/gcc/ada/par-sync.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/par-sync.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Sync is *** 81,87 **** loop -- Terminating tokens are those in class Eterm and also RANGE, -- DIGITS or DELTA if not preceded by an apostrophe (if they are ! -- preceded by an apostrophe, then they are attributes). In addiion, -- at the outer parentheses level only, we also consider a comma, -- right parenthesis or vertical bar to terminate an expression. --- 81,87 ---- loop -- Terminating tokens are those in class Eterm and also RANGE, -- DIGITS or DELTA if not preceded by an apostrophe (if they are ! -- preceded by an apostrophe, then they are attributes). In addition, -- at the outer parentheses level only, we also consider a comma, -- right parenthesis or vertical bar to terminate an expression. *************** package body Sync is *** 132,138 **** procedure Resync_Init is begin -- The following check makes sure we do not get stuck in an infinite ! -- loop resynchonizing and getting nowhere. If we are called to do a -- resynchronize and we are exactly at the same point that we left off -- on the last resynchronize call, then we force at least one token to -- be skipped so that we make progress! --- 132,138 ---- procedure Resync_Init is begin -- The following check makes sure we do not get stuck in an infinite ! -- loop resynchronizing and getting nowhere. If we are called to do a -- resynchronize and we are exactly at the same point that we left off -- on the last resynchronize call, then we force at least one token to -- be skipped so that we make progress! *************** package body Sync is *** 255,261 **** end if; end loop; ! -- Fall out of loop with resyncrhonization complete Resync_Resume; end Resync_Past_Semicolon_Or_To_Loop_Or_Then; --- 255,261 ---- end if; end loop; ! -- Fall out of loop with resynchronization complete Resync_Resume; end Resync_Past_Semicolon_Or_To_Loop_Or_Then; *************** package body Sync is *** 299,305 **** end if; end loop; ! -- Fall out of loop with resyncrhonization complete Resync_Resume; end Resync_To_When; --- 299,305 ---- end if; end loop; ! -- Fall out of loop with resynchronization complete Resync_Resume; end Resync_To_When; diff -Nrcpad gcc-4.3.3/gcc/ada/par-tchk.adb gcc-4.4.0/gcc/ada/par-tchk.adb *** gcc-4.3.3/gcc/ada/par-tchk.adb Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/par-tchk.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Tchk is *** 83,93 **** -- A little recovery helper, accept then in place of => elsif Token = Tok_Then then ! Error_Msg_BC ("missing ""='>"""); Scan; -- past THEN used in place of => elsif Token = Tok_Colon_Equal then ! Error_Msg_SC (""":="" should be ""='>"""); Scan; -- past := used in place of => else --- 83,93 ---- -- A little recovery helper, accept then in place of => elsif Token = Tok_Then then ! Error_Msg_BC ("|THEN should be ""='>"""); Scan; -- past THEN used in place of => elsif Token = Tok_Colon_Equal then ! Error_Msg_SC ("|"":="" should be ""='>"""); Scan; -- past := used in place of => else *************** package body Tchk is *** 149,163 **** Scan; elsif Token = Tok_Equal then ! Error_Msg_SC ("""="" should be "":="""); Scan; elsif Token = Tok_Colon then ! Error_Msg_SC (""":"" should be "":="""); Scan; elsif Token = Tok_Is then ! Error_Msg_SC ("IS should be "":="""); Scan; else --- 149,163 ---- Scan; elsif Token = Tok_Equal then ! Error_Msg_SC ("|""="" should be "":="""); Scan; elsif Token = Tok_Colon then ! Error_Msg_SC ("|"":"" should be "":="""); Scan; elsif Token = Tok_Is then ! Error_Msg_SC ("|IS should be "":="""); Scan; else *************** package body Tchk is *** 257,281 **** procedure T_Is is begin if Token = Tok_Is then Scan; Ignore (Tok_Semicolon); -- Allow OF, => or = to substitute for IS with complaint ! elsif Token = Tok_Arrow ! or else Token = Tok_Of ! or else Token = Tok_Equal ! then ! Error_Msg_SC ("missing IS"); ! Scan; -- token used in place of IS else Wrong_Token (Tok_Is, AP); end if; while Token = Tok_Is loop ! Error_Msg_SC ("extra IS ignored"); Scan; end loop; end T_Is; --- 257,295 ---- procedure T_Is is begin + Ignore (Tok_Semicolon); + + -- If we have IS scan past it + if Token = Tok_Is then Scan; + -- And ignore any following semicolons + Ignore (Tok_Semicolon); -- Allow OF, => or = to substitute for IS with complaint ! elsif Token = Tok_Arrow then ! Error_Msg_SC ("|""=>"" should be IS"); ! Scan; -- past => ! ! elsif Token = Tok_Of then ! Error_Msg_SC ("|OF should be IS"); ! Scan; -- past OF ! ! elsif Token = Tok_Equal then ! Error_Msg_SC ("|""="" should be IS"); ! Scan; -- past = ! else Wrong_Token (Tok_Is, AP); end if; + -- Ignore extra IS keywords + while Token = Tok_Is loop ! Error_Msg_SC ("|extra IS ignored"); Scan; end loop; end T_Is; *************** package body Tchk is *** 379,385 **** if Token = Tok_Right_Paren then Scan; else ! Error_Msg_AP ("missing "")"""); end if; end T_Right_Paren; --- 393,399 ---- if Token = Tok_Right_Paren then Scan; else ! Error_Msg_AP ("|missing "")"""); end if; end T_Right_Paren; *************** package body Tchk is *** 394,417 **** Scan; if Token = Tok_Semicolon then ! Error_Msg_SC ("extra "";"" ignored"); Scan; end if; return; elsif Token = Tok_Colon then ! Error_Msg_SC (""":"" should be "";"""); Scan; return; elsif Token = Tok_Comma then ! Error_Msg_SC (""","" should be "";"""); Scan; return; elsif Token = Tok_Dot then ! Error_Msg_SC ("""."" should be "";"""); Scan; return; --- 408,431 ---- Scan; if Token = Tok_Semicolon then ! Error_Msg_SC ("|extra "";"" ignored"); Scan; end if; return; elsif Token = Tok_Colon then ! Error_Msg_SC ("|"":"" should be "";"""); Scan; return; elsif Token = Tok_Comma then ! Error_Msg_SC ("|"","" should be "";"""); Scan; return; elsif Token = Tok_Dot then ! Error_Msg_SC ("|""."" should be "";"""); Scan; return; *************** package body Tchk is *** 434,440 **** return; -- Deal with pragma. If pragma is not at start of line, it is considered ! -- misplaced otherwise we treat it as a normal missing semicolong case. elsif Token = Tok_Pragma and then not Token_Is_At_Start_Of_Line --- 448,454 ---- return; -- Deal with pragma. If pragma is not at start of line, it is considered ! -- misplaced otherwise we treat it as a normal missing semicolon case. elsif Token = Tok_Pragma and then not Token_Is_At_Start_Of_Line *************** package body Tchk is *** 678,684 **** else -- Deal with pragma. If pragma is not at start of line, it is -- considered misplaced otherwise we treat it as a normal ! -- missing semicolong case. if Token = Tok_Pragma and then not Token_Is_At_Start_Of_Line --- 692,698 ---- else -- Deal with pragma. If pragma is not at start of line, it is -- considered misplaced otherwise we treat it as a normal ! -- missing semicolon case. if Token = Tok_Pragma and then not Token_Is_At_Start_Of_Line *************** package body Tchk is *** 812,818 **** if Token = Tok_Right_Paren then Scan; else ! Error_Msg_AP ("missing "")""!"); end if; end U_Right_Paren; --- 826,832 ---- if Token = Tok_Right_Paren then Scan; else ! Error_Msg_AP ("|missing "")""!"); end if; end U_Right_Paren; *************** package body Tchk is *** 831,837 **** Scan; if Token = T then ! Error_Msg_SP ("extra "";"" ignored"); Scan; else Error_Msg_SP (M); --- 845,851 ---- Scan; if Token = T then ! Error_Msg_SP ("|extra "";"" ignored"); Scan; else Error_Msg_SP (M); *************** package body Tchk is *** 841,847 **** Scan; if Token = T then ! Error_Msg_SP ("extra "","" ignored"); Scan; else --- 855,861 ---- Scan; if Token = T then ! Error_Msg_SP ("|extra "","" ignored"); Scan; else diff -Nrcpad gcc-4.3.3/gcc/ada/par-util.adb gcc-4.4.0/gcc/ada/par-util.adb *** gcc-4.3.3/gcc/ada/par-util.adb Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/par-util.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Util is *** 76,82 **** Token := T; return True; ! -- A special check for an illegal abbrevation elsif Name_Len < S'Length and then Name_Len >= 4 --- 76,82 ---- Token := T; return True; ! -- A special check for an illegal abbreviation elsif Name_Len < S'Length and then Name_Len >= 4 *************** package body Util is *** 109,115 **** and then S = Name_Buffer (1 .. SL) then Scan_Ptr := Token_Ptr + S'Length; ! Error_Msg_S ("missing space"); Token := T; return True; end if; --- 109,115 ---- and then S = Name_Buffer (1 .. SL) then Scan_Ptr := Token_Ptr + S'Length; ! Error_Msg_S ("|missing space"); Token := T; return True; end if; *************** package body Util is *** 176,193 **** end if; end Check_Misspelling_Of; - -------------------------- - -- Check_No_Right_Paren -- - -------------------------- - - procedure Check_No_Right_Paren is - begin - if Token = Tok_Right_Paren then - Error_Msg_SC ("unexpected right parenthesis"); - Scan; -- past unexpected right paren - end if; - end Check_No_Right_Paren; - ----------------------------- -- Check_Simple_Expression -- ----------------------------- --- 176,181 ---- *************** package body Util is *** 343,349 **** <> Restore_Scan_State (Scan_State); ! Error_Msg_SC (""";"" illegal here, replaced by "","""); Scan; -- past the semicolon return True; --- 331,337 ---- <> Restore_Scan_State (Scan_State); ! Error_Msg_SC ("|"";"" should be "","""); Scan; -- past the semicolon return True; *************** package body Util is *** 391,428 **** procedure Ignore (T : Token_Type) is begin ! if Token = T then if T = Tok_Comma then ! Error_Msg_SC ("unexpected "","" ignored"); elsif T = Tok_Left_Paren then ! Error_Msg_SC ("unexpected ""("" ignored"); elsif T = Tok_Right_Paren then ! Error_Msg_SC ("unexpected "")"" ignored"); elsif T = Tok_Semicolon then ! Error_Msg_SC ("unexpected "";"" ignored"); else declare Tname : constant String := Token_Type'Image (Token); - Msg : String := "unexpected keyword ????????????????????????"; - begin ! -- Loop to copy characters of keyword name (ignoring Tok_) ! ! for J in 5 .. Tname'Last loop ! Msg (J + 14) := Fold_Upper (Tname (J)); ! end loop; ! ! Msg (Tname'Last + 15 .. Tname'Last + 22) := " ignored"; ! Error_Msg_SC (Msg (1 .. Tname'Last + 22)); end; end if; Scan; -- Scan past ignored token ! end if; end Ignore; ---------------------------- --- 379,411 ---- procedure Ignore (T : Token_Type) is begin ! while Token = T loop if T = Tok_Comma then ! Error_Msg_SC ("|extra "","" ignored"); elsif T = Tok_Left_Paren then ! Error_Msg_SC ("|extra ""("" ignored"); elsif T = Tok_Right_Paren then ! Error_Msg_SC ("|extra "")"" ignored"); elsif T = Tok_Semicolon then ! Error_Msg_SC ("|extra "";"" ignored"); ! ! elsif T = Tok_Colon then ! Error_Msg_SC ("|extra "":"" ignored"); else declare Tname : constant String := Token_Type'Image (Token); begin ! Error_Msg_SC ! ("|extra " & Tname (5 .. Tname'Last) & "ignored"); end; end if; Scan; -- Scan past ignored token ! end loop; end Ignore; ---------------------------- *************** package body Util is *** 438,444 **** declare Ident_Casing : constant Casing_Type := Identifier_Casing (Current_Source_File); - Key_Casing : constant Casing_Type := Keyword_Casing (Current_Source_File); --- 421,426 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/par.adb gcc-4.4.0/gcc/ada/par.adb *** gcc-4.3.3/gcc/ada/par.adb Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/par.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** is *** 187,193 **** -- 4. We encounter a valid pragma INTERFACE or IMPORT that effectively -- supplies the missing body. In this case we reset the entry. ! -- 5. We encounter the end of the declarative region without encoutering -- a BEGIN first. In this situation we simply reset the entry. We know -- that there is a missing body, but it seems more reasonable to let the -- later semantic checking discover this. --- 187,193 ---- -- 4. We encounter a valid pragma INTERFACE or IMPORT that effectively -- supplies the missing body. In this case we reset the entry. ! -- 5. We encounter the end of the declarative region without encountering -- a BEGIN first. In this situation we simply reset the entry. We know -- that there is a missing body, but it seems more reasonable to let the -- later semantic checking discover this. *************** is *** 197,203 **** ---------------------------------------------------- -- Note: throughout the parser, the terms reserved word and keyword ! -- are used interchangably to refer to the same set of reserved -- keywords (including until, protected, etc). -- If a reserved word is used in place of an identifier, the parser --- 197,203 ---- ---------------------------------------------------- -- Note: throughout the parser, the terms reserved word and keyword ! -- are used interchangeably to refer to the same set of reserved -- keywords (including until, protected, etc). -- If a reserved word is used in place of an identifier, the parser *************** is *** 213,226 **** -- further confirmation. -- In the case of an identifier appearing in the identifier list of a ! -- declaration, the appearence of a comma or colon right after the -- keyword on the same line is taken as confirmation. For an enumeration -- literal, a comma or right paren right after the identifier is also -- treated as adequate confirmation. -- The following type is used in calls to Is_Reserved_Identifier and -- also to P_Defining_Identifier and P_Identifier. The default for all ! -- these functins is that reserved words in reserved word case are not -- considered to be reserved identifiers. The Id_Check value indicates -- tokens, which if they appear immediately after the identifier, are -- taken as confirming that the use of an identifier was expected --- 213,226 ---- -- further confirmation. -- In the case of an identifier appearing in the identifier list of a ! -- declaration, the appearance of a comma or colon right after the -- keyword on the same line is taken as confirmation. For an enumeration -- literal, a comma or right paren right after the identifier is also -- treated as adequate confirmation. -- The following type is used in calls to Is_Reserved_Identifier and -- also to P_Defining_Identifier and P_Identifier. The default for all ! -- these functions is that reserved words in reserved word case are not -- considered to be reserved identifiers. The Id_Check value indicates -- tokens, which if they appear immediately after the identifier, are -- taken as confirming that the use of an identifier was expected *************** is *** 282,288 **** -- end; -- The trouble is that the section of text from PROCEDURE B through END; ! -- consitutes a valid procedure body, and the danger is that we find out -- far too late that something is wrong (indeed most compilers will behave -- uncomfortably on the above example). --- 282,288 ---- -- end; -- The trouble is that the section of text from PROCEDURE B through END; ! -- constitutes a valid procedure body, and the danger is that we find out -- far too late that something is wrong (indeed most compilers will behave -- uncomfortably on the above example). *************** is *** 296,302 **** -- reserve the END; for the outer level.) For more details on this aspect -- of the handling, see package Par.Endh. ! -- If we can avoid eating up the END; then the result in the absense of -- any additional steps would be to post a missing END referring back to -- the subprogram with the bogus IS. Similarly, if the enclosing package -- has no BEGIN, then the result is a missing BEGIN message, which again --- 296,302 ---- -- reserve the END; for the outer level.) For more details on this aspect -- of the handling, see package Par.Endh. ! -- If we can avoid eating up the END; then the result in the absence of -- any additional steps would be to post a missing END referring back to -- the subprogram with the bogus IS. Similarly, if the enclosing package -- has no BEGIN, then the result is a missing BEGIN message, which again *************** is *** 637,643 **** -- allowed). procedure Skip_Declaration (S : List_Id); ! -- Used when scanning statements to skip past a mispaced declaration -- The declaration is scanned out and appended to the given list. -- Token is known to be a declaration token (in Token_Class_Declk) -- on entry, so there definition is a declaration to be scanned. --- 637,643 ---- -- allowed). procedure Skip_Declaration (S : List_Id); ! -- Used when scanning statements to skip past a misplaced declaration -- The declaration is scanned out and appended to the given list. -- Token is known to be a declaration token (in Token_Class_Declk) -- on entry, so there definition is a declaration to be scanned. *************** is *** 914,920 **** -- Used if an error occurs while scanning a parenthesized list of items -- separated by semicolons. The scan pointer is advanced to the next -- semicolon or right parenthesis at the outer parenthesis level, or ! -- to the next is or RETURN keyword occurence, whichever comes first. procedure Resync_Cunit; -- Synchronize to next token which could be the start of a compilation --- 914,920 ---- -- Used if an error occurs while scanning a parenthesized list of items -- separated by semicolons. The scan pointer is advanced to the next -- semicolon or right parenthesis at the outer parenthesis level, or ! -- to the next is or RETURN keyword occurrence, whichever comes first. procedure Resync_Cunit; -- Synchronize to next token which could be the start of a compilation *************** is *** 1050,1059 **** -- it is returned unchanged. Otherwise an error message is issued -- and Error is returned. - procedure Check_No_Right_Paren; - -- Called to check that the current token is not a right paren. If it - -- is, then an error is given, and the right parenthesis is scanned out. - function Comma_Present return Boolean; -- Used in comma delimited lists to determine if a comma is present, or -- can reasonably be assumed to have been present (an error message is --- 1050,1055 ---- *************** is *** 1109,1115 **** pragma Inline (Push_Scope_Stack); -- Push a new entry onto the scope stack. Scope.Last (the stack pointer) -- is incremented. The Junk field is preinitialized to False. The caller ! -- is expected to fill in all remaining entries of the new new top stack -- entry at Scope.Table (Scope.Last). procedure Pop_Scope_Stack; --- 1105,1111 ---- pragma Inline (Push_Scope_Stack); -- Push a new entry onto the scope stack. Scope.Last (the stack pointer) -- is incremented. The Junk field is preinitialized to False. The caller ! -- is expected to fill in all remaining entries of the new top stack -- entry at Scope.Table (Scope.Last). procedure Pop_Scope_Stack; *************** begin *** 1256,1265 **** -- Give error if bad pragma ! if not Is_Configuration_Pragma_Name (Chars (P_Node)) ! and then Chars (P_Node) /= Name_Source_Reference then ! if Is_Pragma_Name (Chars (P_Node)) then Error_Msg_N ("only configuration pragmas allowed " & "in configuration file", P_Node); --- 1252,1261 ---- -- Give error if bad pragma ! if not Is_Configuration_Pragma_Name (Pragma_Name (P_Node)) ! and then Pragma_Name (P_Node) /= Name_Source_Reference then ! if Is_Pragma_Name (Pragma_Name (P_Node)) then Error_Msg_N ("only configuration pragmas allowed " & "in configuration file", P_Node); diff -Nrcpad gcc-4.3.3/gcc/ada/prep.adb gcc-4.4.0/gcc/ada/prep.adb *** gcc-4.3.3/gcc/ada/prep.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/prep.adb Mon Aug 4 09:17:44 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2008, 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- -- *************** package body Prep is *** 732,738 **** procedure List_Symbols (Foreword : String) is Order : array (0 .. Integer (Symbol_Table.Last (Mapping))) of Symbol_Id; ! -- After alphabetical sorting, this array stores thehe indices of -- the symbols in the order they are displayed. function Lt (Op1, Op2 : Natural) return Boolean; --- 732,738 ---- procedure List_Symbols (Foreword : String) is Order : array (0 .. Integer (Symbol_Table.Last (Mapping))) of Symbol_Id; ! -- After alphabetical sorting, this array stores the indices of -- the symbols in the order they are displayed. function Lt (Op1, Op2 : Natural) return Boolean; *************** package body Prep is *** 1043,1052 **** -- Preprocess -- ---------------- ! procedure Preprocess is Start_Of_Processing : Source_Ptr; Cond : Boolean; Preprocessor_Line : Boolean := False; procedure Output (From, To : Source_Ptr); -- Output the characters with indices From .. To in the buffer --- 1043,1054 ---- -- Preprocess -- ---------------- ! procedure Preprocess (Source_Modified : out Boolean) is Start_Of_Processing : Source_Ptr; Cond : Boolean; Preprocessor_Line : Boolean := False; + No_Error_Found : Boolean := True; + Modified : Boolean := False; procedure Output (From, To : Source_Ptr); -- Output the characters with indices From .. To in the buffer *************** package body Prep is *** 1118,1192 **** -- Preprocessor line if Token = Tok_Special and then Special_Character = '#' then ! Preprocessor_Line := True; ! Scan.all; ! ! case Token is ! ! -- #if ! ! when Tok_If => ! declare ! If_Ptr : constant Source_Ptr := Token_Ptr; ! ! begin ! Scan.all; ! Cond := Expression (not Deleting); ! ! -- Check for an eventual "then" ! ! if Token = Tok_Then then ! Scan.all; ! end if; ! ! -- It is an error to have trailing characters after ! -- the condition or "then". ! ! if Token /= Tok_End_Of_Line ! and then Token /= Tok_EOF ! then ! Error_Msg ! ("extraneous text on preprocessor line", ! Token_Ptr); ! Go_To_End_Of_Line; ! end if; ! ! declare ! -- Set the initial state of this new "#if". ! -- This must be done before incrementing the ! -- Last of the table, otherwise function ! -- Deleting does not report the correct value. ! ! New_State : constant Pp_State := ! (If_Ptr => If_Ptr, ! Else_Ptr => 0, ! Deleting => Deleting or (not Cond), ! Match_Seen => Deleting or Cond); ! ! begin ! Pp_States.Increment_Last; ! Pp_States.Table (Pp_States.Last) := New_State; ! end; ! end; ! ! -- #elsif ! when Tok_Elsif => ! Cond := False; ! if Pp_States.Last = 0 ! or else Pp_States.Table (Pp_States.Last).Else_Ptr ! /= 0 ! then ! Error_Msg ("no IF for this ELSIF", Token_Ptr); ! else ! Cond := ! not Pp_States.Table (Pp_States.Last).Match_Seen; ! end if; Scan.all; ! Cond := Expression (Cond); -- Check for an eventual "then" --- 1120,1140 ---- -- Preprocessor line if Token = Tok_Special and then Special_Character = '#' then ! Modified := True; ! Preprocessor_Line := True; ! Scan.all; ! case Token is ! -- #if ! when Tok_If => ! declare ! If_Ptr : constant Source_Ptr := Token_Ptr; + begin Scan.all; ! Cond := Expression (not Deleting); -- Check for an eventual "then" *************** package body Prep is *** 1203,1338 **** Error_Msg ("extraneous text on preprocessor line", Token_Ptr); ! Go_To_End_Of_Line; end if; ! -- Depending on the value of the condition, set the ! -- new values of Deleting and Match_Seen. ! if Pp_States.Last > 0 then ! if Pp_States.Table (Pp_States.Last).Match_Seen then ! Pp_States.Table (Pp_States.Last).Deleting := ! True; ! else ! if Cond then ! Pp_States.Table (Pp_States.Last).Match_Seen := ! True; ! Pp_States.Table (Pp_States.Last).Deleting := ! False; ! end if; ! end if; ! end if; ! -- #else ! when Tok_Else => ! if Pp_States.Last = 0 then ! Error_Msg ("no IF for this ELSE", Token_Ptr); ! elsif ! Pp_States.Table (Pp_States.Last).Else_Ptr /= 0 ! then ! Error_Msg ("duplicate ELSE line", Token_Ptr); ! end if; ! -- Set the possibly new values of Deleting and ! -- Match_Seen. ! if Pp_States.Last > 0 then ! if Pp_States.Table (Pp_States.Last).Match_Seen then ! Pp_States.Table (Pp_States.Last).Deleting := ! True; ! else Pp_States.Table (Pp_States.Last).Match_Seen := True; Pp_States.Table (Pp_States.Last).Deleting := False; end if; ! -- Set the Else_Ptr to check for illegal #elsif ! -- later. ! Pp_States.Table (Pp_States.Last).Else_Ptr := ! Token_Ptr; ! end if; ! Scan.all; ! -- It is an error to have characters after "#else" ! if Token /= Tok_End_Of_Line ! and then Token /= Tok_EOF ! then ! Error_Msg ! ("extraneous text on preprocessor line", ! Token_Ptr); ! Go_To_End_Of_Line; ! end if; ! -- #end if; ! when Tok_End => ! if Pp_States.Last = 0 then ! Error_Msg ("no IF for this END", Token_Ptr); end if; Scan.all; ! if Token /= Tok_If then ! Error_Msg ("IF expected", Token_Ptr); else Scan.all; ! if Token /= Tok_Semicolon then ! Error_Msg ("`;` Expected", Token_Ptr); ! ! else ! Scan.all; ! ! -- It is an error to have character after ! -- "#end if;". ! if Token /= Tok_End_Of_Line ! and then Token /= Tok_EOF ! then ! Error_Msg ! ("extraneous text on preprocessor line", ! Token_Ptr); ! end if; end if; end if; ! -- In case of one of the errors above, skip the tokens ! -- until the end of line is reached. ! Go_To_End_Of_Line; ! -- Decrement the depth of the #if stack ! if Pp_States.Last > 0 then ! Pp_States.Decrement_Last; ! end if; ! -- Illegal preprocessor line ! when others => ! if Pp_States.Last = 0 then ! Error_Msg ("IF expected", Token_Ptr); ! elsif ! Pp_States.Table (Pp_States.Last).Else_Ptr = 0 ! then ! Error_Msg ("IF, ELSIF, ELSE, or `END IF` expected", ! Token_Ptr); ! else ! Error_Msg ("IF or `END IF` expected", Token_Ptr); ! end if; ! -- Skip to the end of this illegal line ! Go_To_End_Of_Line; ! end case; -- Not a preprocessor line --- 1151,1351 ---- Error_Msg ("extraneous text on preprocessor line", Token_Ptr); ! No_Error_Found := False; Go_To_End_Of_Line; end if; ! declare ! -- Set the initial state of this new "#if". This ! -- must be done before incrementing the Last of ! -- the table, otherwise function Deleting does ! -- not report the correct value. ! New_State : constant Pp_State := ! (If_Ptr => If_Ptr, ! Else_Ptr => 0, ! Deleting => Deleting or (not Cond), ! Match_Seen => Deleting or Cond); ! begin ! Pp_States.Increment_Last; ! Pp_States.Table (Pp_States.Last) := New_State; ! end; ! end; ! -- #elsif ! when Tok_Elsif => ! Cond := False; ! if Pp_States.Last = 0 ! or else Pp_States.Table (Pp_States.Last).Else_Ptr /= 0 ! then ! Error_Msg ("no IF for this ELSIF", Token_Ptr); ! No_Error_Found := False; ! else ! Cond := ! not Pp_States.Table (Pp_States.Last).Match_Seen; ! end if; ! ! Scan.all; ! Cond := Expression (Cond); ! ! -- Check for an eventual "then" ! ! if Token = Tok_Then then ! Scan.all; ! end if; ! ! -- It is an error to have trailing characters after ! -- the condition or "then". ! ! if Token /= Tok_End_Of_Line ! and then Token /= Tok_EOF ! then ! Error_Msg ! ("extraneous text on preprocessor line", ! Token_Ptr); ! No_Error_Found := False; ! ! Go_To_End_Of_Line; ! end if; ! ! -- Depending on the value of the condition, set the ! -- new values of Deleting and Match_Seen. ! if Pp_States.Last > 0 then ! if Pp_States.Table (Pp_States.Last).Match_Seen then ! Pp_States.Table (Pp_States.Last).Deleting := True; ! else ! if Cond then Pp_States.Table (Pp_States.Last).Match_Seen := True; Pp_States.Table (Pp_States.Last).Deleting := False; end if; + end if; + end if; ! -- #else ! when Tok_Else => ! if Pp_States.Last = 0 then ! Error_Msg ("no IF for this ELSE", Token_Ptr); ! No_Error_Found := False; ! elsif ! Pp_States.Table (Pp_States.Last).Else_Ptr /= 0 ! then ! Error_Msg ("duplicate ELSE line", Token_Ptr); ! No_Error_Found := False; ! end if; ! -- Set the possibly new values of Deleting and ! -- Match_Seen. ! if Pp_States.Last > 0 then ! if Pp_States.Table (Pp_States.Last).Match_Seen then ! Pp_States.Table (Pp_States.Last).Deleting := ! True; ! else ! Pp_States.Table (Pp_States.Last).Match_Seen := ! True; ! Pp_States.Table (Pp_States.Last).Deleting := ! False; end if; + -- Set the Else_Ptr to check for illegal #elsif + -- later. + + Pp_States.Table (Pp_States.Last).Else_Ptr := + Token_Ptr; + end if; + + Scan.all; + + -- It is an error to have characters after "#else" + if Token /= Tok_End_Of_Line + and then Token /= Tok_EOF + then + Error_Msg + ("extraneous text on preprocessor line", + Token_Ptr); + No_Error_Found := False; + Go_To_End_Of_Line; + end if; + + -- #end if; + + when Tok_End => + if Pp_States.Last = 0 then + Error_Msg ("no IF for this END", Token_Ptr); + No_Error_Found := False; + end if; + + Scan.all; + + if Token /= Tok_If then + Error_Msg ("IF expected", Token_Ptr); + No_Error_Found := False; + + else Scan.all; ! if Token /= Tok_Semicolon then ! Error_Msg ("`;` Expected", Token_Ptr); ! No_Error_Found := False; else Scan.all; ! -- It is an error to have character after ! -- "#end if;". ! if Token /= Tok_End_Of_Line ! and then Token /= Tok_EOF ! then ! Error_Msg ! ("extraneous text on preprocessor line", ! Token_Ptr); ! No_Error_Found := False; end if; end if; + end if; ! -- In case of one of the errors above, skip the tokens ! -- until the end of line is reached. ! Go_To_End_Of_Line; ! -- Decrement the depth of the #if stack ! if Pp_States.Last > 0 then ! Pp_States.Decrement_Last; ! end if; ! -- Illegal preprocessor line ! when others => ! No_Error_Found := False; ! if Pp_States.Last = 0 then ! Error_Msg ("IF expected", Token_Ptr); ! elsif ! Pp_States.Table (Pp_States.Last).Else_Ptr = 0 ! then ! Error_Msg ("IF, ELSIF, ELSE, or `END IF` expected", ! Token_Ptr); ! else ! Error_Msg ("IF or `END IF` expected", Token_Ptr); ! end if; ! -- Skip to the end of this illegal line ! ! Go_To_End_Of_Line; ! end case; -- Not a preprocessor line *************** package body Prep is *** 1352,1357 **** --- 1365,1372 ---- if Token = Tok_Special and then Special_Character = '$' then + Modified := True; + declare Dollar_Ptr : constant Source_Ptr := Token_Ptr; Symbol : Symbol_Id; *************** package body Prep is *** 1438,1444 **** end if; -- Now, scan the first token of the next line. If the token is EOF, ! -- the scan ponter will not move, and the token will still be EOF. Set_Ignore_Errors (To => True); Scan.all; --- 1453,1459 ---- end if; -- Now, scan the first token of the next line. If the token is EOF, ! -- the scan pointer will not move, and the token will still be EOF. Set_Ignore_Errors (To => True); Scan.all; *************** package body Prep is *** 1449,1455 **** --- 1464,1473 ---- for Level in reverse 1 .. Pp_States.Last loop Error_Msg ("no `END IF` for this IF", Pp_States.Table (Level).If_Ptr); + No_Error_Found := False; end loop; + + Source_Modified := No_Error_Found and Modified; end Preprocess; end Prep; diff -Nrcpad gcc-4.3.3/gcc/ada/prep.ads gcc-4.4.0/gcc/ada/prep.ads *** gcc-4.3.3/gcc/ada/prep.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/prep.ads Mon Aug 4 09:17:44 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2008, 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- -- *************** package Prep is *** 106,114 **** -- Parse the definition file. The definition file must have already been -- loaded and the scanner initialized. ! procedure Preprocess; -- Preprocess the input file. The input file must have already been loaded ! -- and the scanner initialized. procedure Check_Command_Line_Symbol_Definition (Definition : String; --- 106,115 ---- -- Parse the definition file. The definition file must have already been -- loaded and the scanner initialized. ! procedure Preprocess (Source_Modified : out Boolean); -- Preprocess the input file. The input file must have already been loaded ! -- and the scanner initialized. Source_Modified is set to True iff the ! -- preprocessor modified the source text. procedure Check_Command_Line_Symbol_Definition (Definition : String; *************** package Prep is *** 124,130 **** -- Tok_Identifier with the corresponding Token_Name. procedure List_Symbols (Foreword : String); ! -- List the symbols used por preprocessing a file, with their values. -- If Foreword is not empty, Output Foreword before the list. end Prep; --- 125,131 ---- -- Tok_Identifier with the corresponding Token_Name. procedure List_Symbols (Foreword : String); ! -- List the symbols used for preprocessing a file, with their values. -- If Foreword is not empty, Output Foreword before the list. end Prep; diff -Nrcpad gcc-4.3.3/gcc/ada/prepcomp.adb gcc-4.4.0/gcc/ada/prepcomp.adb *** gcc-4.3.3/gcc/ada/prepcomp.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/prepcomp.adb Tue May 20 12:52:53 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2008, 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- -- *************** package body Prepcomp is *** 245,251 **** """ not found"); end if; ! -- Initialize the sanner and set its behavior for a processing data file Scn.Scanner.Initialize_Scanner (Source_Index_Of_Preproc_Data_File); Scn.Scanner.Set_End_Of_Line_As_Token (True); --- 245,251 ---- """ not found"); end if; ! -- Initialize scanner and set its behavior for processing a data file Scn.Scanner.Initialize_Scanner (Source_Index_Of_Preproc_Data_File); Scn.Scanner.Set_End_Of_Line_As_Token (True); diff -Nrcpad gcc-4.3.3/gcc/ada/prj-attr-pm.adb gcc-4.4.0/gcc/ada/prj-attr-pm.adb *** gcc-4.3.3/gcc/ada/prj-attr-pm.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/prj-attr-pm.adb Tue Aug 5 09:14:48 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2008, 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- -- *************** package body Prj.Attr.PM is *** 45,50 **** --- 45,51 ---- Optional_Index => False, Attr_Kind => Unknown, Read_Only => False, + Others_Allowed => False, Next => Package_Attributes.Table (To_Package.Value).First_Attribute); Package_Attributes.Table (To_Package.Value).First_Attribute := diff -Nrcpad gcc-4.3.3/gcc/ada/prj-attr.adb gcc-4.4.0/gcc/ada/prj-attr.adb *** gcc-4.3.3/gcc/ada/prj-attr.adb Wed Dec 19 16:24:17 2007 --- gcc-4.4.0/gcc/ada/prj-attr.adb Tue Aug 5 09:14:48 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** *** 25,34 **** with Osint; with Prj.Com; use Prj.Com; ! with System.Case_Util; use System.Case_Util; package body Prj.Attr is -- Data for predefined attributes and packages -- Names are in lower case and end with '#' --- 25,37 ---- with Osint; with Prj.Com; use Prj.Com; ! ! with GNAT.Case_Util; use GNAT.Case_Util; package body Prj.Attr is + use GNAT; + -- Data for predefined attributes and packages -- Names are in lower case and end with '#' *************** package body Prj.Attr is *** 53,58 **** --- 56,63 ---- -- The third optional letter is -- 'R' to indicate that the attribute is read-only + -- 'O' to indicate that others is allowed as an index for an associative + -- array -- End is indicated by two consecutive '#' *************** package body Prj.Attr is *** 74,79 **** --- 79,85 ---- "SVobject_dir#" & "SVexec_dir#" & "LVsource_dirs#" & + "Lainherit_source_path#" & "LVexcluded_source_dirs#" & -- Source files *************** package body Prj.Attr is *** 82,87 **** --- 88,95 ---- "LVlocally_removed_files#" & "LVexcluded_source_files#" & "SVsource_list_file#" & + "SVexcluded_source_list_file#" & + "LVinterfaces#" & -- Libraries *************** package body Prj.Attr is *** 105,110 **** --- 113,120 ---- "LVrun_path_option#" & "Satoolchain_version#" & "Satoolchain_description#" & + "Saobject_generated#" & + "Saobjects_linked#" & -- Configuration - Libraries *************** package body Prj.Attr is *** 114,119 **** --- 124,130 ---- -- Configuration - Archives "LVarchive_builder#" & + "LVarchive_builder_append_option#" & "LVarchive_indexer#" & "SVarchive_suffix#" & "LVlibrary_partial_linker#" & *************** package body Prj.Attr is *** 150,156 **** "Pcompiler#" & "Ladefault_switches#" & ! "Lcswitches#" & "SVlocal_configuration_pragmas#" & "Salocal_config_file#" & --- 161,167 ---- "Pcompiler#" & "Ladefault_switches#" & ! "LcOswitches#" & "SVlocal_configuration_pragmas#" & "Salocal_config_file#" & *************** package body Prj.Attr is *** 159,164 **** --- 170,176 ---- "Sadriver#" & "Larequired_switches#" & "Lapic_option#" & + "Sapath_syntax#" & -- Configuration - Mapping files *************** package body Prj.Attr is *** 190,196 **** "Pbuilder#" & "Ladefault_switches#" & ! "Lcswitches#" & "Scexecutable#" & "SVexecutable_suffix#" & "SVglobal_configuration_pragmas#" & --- 202,209 ---- "Pbuilder#" & "Ladefault_switches#" & ! "LcOswitches#" & ! "Lcglobal_compilation_switches#" & "Scexecutable#" & "SVexecutable_suffix#" & "SVglobal_configuration_pragmas#" & *************** package body Prj.Attr is *** 205,211 **** "Pbinder#" & "Ladefault_switches#" & ! "Lcswitches#" & -- Configuration - Binding --- 218,224 ---- "Pbinder#" & "Ladefault_switches#" & ! "LcOswitches#" & -- Configuration - Binding *************** package body Prj.Attr is *** 220,227 **** "Plinker#" & "LVrequired_switches#" & "Ladefault_switches#" & ! "Lcswitches#" & "LVlinker_options#" & -- Configuration - Linking --- 233,241 ---- "Plinker#" & "LVrequired_switches#" & "Ladefault_switches#" & ! "LcOswitches#" & "LVlinker_options#" & + "SVmap_file_option#" & -- Configuration - Linking *************** package body Prj.Attr is *** 234,276 **** "Pcross_reference#" & "Ladefault_switches#" & ! "Lbswitches#" & -- package Finder "Pfinder#" & "Ladefault_switches#" & ! "Lbswitches#" & -- package Pretty_Printer "Ppretty_printer#" & "Ladefault_switches#" & ! "Lbswitches#" & -- package gnatstub "Pgnatstub#" & "Ladefault_switches#" & ! "Lbswitches#" & -- package Check "Pcheck#" & "Ladefault_switches#" & ! "Lbswitches#" & -- package Eliminate "Peliminate#" & "Ladefault_switches#" & ! "Lbswitches#" & -- package Metrics "Pmetrics#" & "Ladefault_switches#" & ! "Lbswitches#" & -- package Ide --- 248,296 ---- "Pcross_reference#" & "Ladefault_switches#" & ! "LbOswitches#" & -- package Finder "Pfinder#" & "Ladefault_switches#" & ! "LbOswitches#" & -- package Pretty_Printer "Ppretty_printer#" & "Ladefault_switches#" & ! "LbOswitches#" & -- package gnatstub "Pgnatstub#" & "Ladefault_switches#" & ! "LbOswitches#" & -- package Check "Pcheck#" & "Ladefault_switches#" & ! "LbOswitches#" & ! ! -- package Synchronize ! ! "Psynchronize#" & ! "Ladefault_switches#" & ! "LbOswitches#" & -- package Eliminate "Peliminate#" & "Ladefault_switches#" & ! "LbOswitches#" & -- package Metrics "Pmetrics#" & "Ladefault_switches#" & ! "LbOswitches#" & -- package Ide *************** package body Prj.Attr is *** 296,304 **** --- 316,353 ---- Initialized : Boolean := False; -- A flag to avoid multiple initialization + Package_Names : String_List_Access := new Strings.String_List (1 .. 20); + Last_Package_Name : Natural := 0; + -- Package_Names (1 .. Last_Package_Name) contains the list of the known + -- package names, coming from the Initialization_Data string or from + -- calls to one of the two procedures Register_New_Package. + + procedure Add_Package_Name (Name : String); + -- Add a package name in the Package_Name list, extending it, if necessary + function Name_Id_Of (Name : String) return Name_Id; -- Returns the Name_Id for Name in lower case + ---------------------- + -- Add_Package_Name -- + ---------------------- + + procedure Add_Package_Name (Name : String) is + begin + if Last_Package_Name = Package_Names'Last then + declare + New_List : constant Strings.String_List_Access := + new Strings.String_List (1 .. Package_Names'Last * 2); + begin + New_List (Package_Names'Range) := Package_Names.all; + Package_Names := New_List; + end; + end if; + + Last_Package_Name := Last_Package_Name + 1; + Package_Names (Last_Package_Name) := new String'(Name); + end Add_Package_Name; + ----------------------- -- Attribute_Kind_Of -- ----------------------- *************** package body Prj.Attr is *** 364,369 **** --- 413,419 ---- Attribute_Name : Name_Id := No_Name; First_Attribute : Attr_Node_Id := Attr.First_Attribute; Read_Only : Boolean; + Others_Allowed : Boolean; function Attribute_Location return String; -- Returns a string depending if we are in the project level attributes *************** package body Prj.Attr is *** 433,438 **** --- 483,490 ---- First_Attribute => Empty_Attr); Start := Finish + 1; + Add_Package_Name (Get_Name_String (Package_Name)); + when 'S' => Var_Kind := Single; Optional_Index := False; *************** package body Prj.Attr is *** 489,500 **** Start := Start + 1; if Initialization_Data (Start) = 'R' then Read_Only := True; Start := Start + 1; ! else ! Read_Only := False; end if; Finish := Start; --- 541,556 ---- Start := Start + 1; + Read_Only := False; + Others_Allowed := False; + if Initialization_Data (Start) = 'R' then Read_Only := True; Start := Start + 1; ! elsif Initialization_Data (Start) = 'O' then ! Others_Allowed := True; ! Start := Start + 1; end if; Finish := Start; *************** package body Prj.Attr is *** 537,542 **** --- 593,599 ---- Optional_Index => Optional_Index, Attr_Kind => Attr_Kind, Read_Only => Read_Only, + Others_Allowed => Others_Allowed, Next => Empty_Attr); Start := Finish + 1; end if; *************** package body Prj.Attr is *** 594,599 **** --- 651,676 ---- end if; end Optional_Index_Of; + function Others_Allowed_For + (Attribute : Attribute_Node_Id) return Boolean + is + begin + if Attribute = Empty_Attribute then + return False; + else + return Attrs.Table (Attribute.Value).Others_Allowed; + end if; + end Others_Allowed_For; + + ----------------------- + -- Package_Name_List -- + ----------------------- + + function Package_Name_List return Strings.String_List is + begin + return Package_Names (1 .. Last_Package_Name); + end Package_Name_List; + ------------------------ -- Package_Node_Id_Of -- ------------------------ *************** package body Prj.Attr is *** 692,697 **** --- 769,775 ---- Optional_Index => Opt_Index, Attr_Kind => Real_Attr_Kind, Read_Only => False, + Others_Allowed => False, Next => First_Attr); Package_Attributes.Table (In_Package.Value).First_Attribute := *************** package body Prj.Attr is *** 729,734 **** --- 807,814 ---- (Name => Pkg_Name, Known => True, First_Attribute => Empty_Attr); + + Add_Package_Name (Get_Name_String (Pkg_Name)); end Register_New_Package; procedure Register_New_Package *************** package body Prj.Attr is *** 796,801 **** --- 876,882 ---- Optional_Index => Attributes (Index).Opt_Index, Attr_Kind => Attr_Kind, Read_Only => False, + Others_Allowed => False, Next => First_Attr); First_Attr := Attrs.Last; end loop; *************** package body Prj.Attr is *** 805,810 **** --- 886,893 ---- (Name => Pkg_Name, Known => True, First_Attribute => First_Attr); + + Add_Package_Name (Get_Name_String (Pkg_Name)); end Register_New_Package; --------------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/prj-attr.ads gcc-4.4.0/gcc/ada/prj-attr.ads *** gcc-4.3.3/gcc/ada/prj-attr.ads Wed Dec 19 16:24:17 2007 --- gcc-4.4.0/gcc/ada/prj-attr.ads Tue Aug 5 09:29:03 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** *** 30,37 **** --- 30,44 ---- with Table; + with GNAT.Strings; + package Prj.Attr is + function Package_Name_List return GNAT.Strings.String_List; + -- Returns the list of valid package names, including those added by + -- procedures Register_New_Package below. The String_Access components of + -- the returned String_List should never be freed. + procedure Initialize; -- Initialize the predefined project level attributes and the predefined -- packages and their attribute. This procedure should be called by *************** package Prj.Attr is *** 47,52 **** --- 54,60 ---- -- Characteristics of an attribute. Optional_Index indicates that there -- may be an optional index in the index of the associative array, as in -- for Switches ("files.ada" at 2) use ... + -- Above character literals should be documented ??? subtype Defined_Attribute_Kind is Attribute_Kind range Single .. Optional_Index_Case_Insensitive_Associative_Array; *************** package Prj.Attr is *** 161,166 **** --- 169,177 ---- -- Returns Empty_Attribute if After is either Empty_Attribute or is the -- last of the list. + function Others_Allowed_For (Attribute : Attribute_Node_Id) return Boolean; + -- True iff the index for an associative array attributes may be others + -------------- -- Packages -- -------------- *************** private *** 274,279 **** --- 285,291 ---- Optional_Index : Boolean; Attr_Kind : Attribute_Kind; Read_Only : Boolean; + Others_Allowed : Boolean; Next : Attr_Node_Id; end record; -- Data for an attribute diff -Nrcpad gcc-4.3.3/gcc/ada/prj-dect.adb gcc-4.4.0/gcc/ada/prj-dect.adb *** gcc-4.3.3/gcc/ada/prj-dect.adb Wed Dec 19 16:24:17 2007 --- gcc-4.4.0/gcc/ada/prj-dect.adb Tue Aug 5 09:14:48 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** *** 25,31 **** with Err_Vars; use Err_Vars; ! with GNAT.Case_Util; use GNAT.Case_Util; with Opt; use Opt; with Prj.Attr; use Prj.Attr; --- 25,32 ---- with Err_Vars; use Err_Vars; ! with GNAT.Case_Util; use GNAT.Case_Util; ! with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; with Opt; use Opt; with Prj.Attr; use Prj.Attr; *************** with Prj.Tree; use Prj.Tree; *** 36,43 **** --- 37,48 ---- with Snames; with Uintp; use Uintp; + with GNAT.Strings; + package body Prj.Dect is + use GNAT; + type Zone is (In_Project, In_Package, In_Case_Construction); -- Used to indicate if we are parsing a package (In_Package), -- a case construction (In_Case_Construction) or none of those two *************** package body Prj.Dect is *** 70,76 **** Current_Package : Project_Node_Id; Packages_To_Check : String_List_Access); -- Parse declarative items. Depending on In_Zone, some declarative ! -- items may be forbiden. procedure Parse_Package_Declaration (In_Tree : Project_Node_Tree_Ref; --- 75,81 ---- Current_Package : Project_Node_Id; Packages_To_Check : String_List_Access); -- Parse declarative items. Depending on In_Zone, some declarative ! -- items may be forbidden. procedure Parse_Package_Declaration (In_Tree : Project_Node_Tree_Ref; *************** package body Prj.Dect is *** 179,185 **** -- an unknown package. if Current_Attribute = Empty_Attribute then ! if Current_Package /= Empty_Node and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored then Pkg_Id := Package_Id_Of (Current_Package, In_Tree); --- 184,190 ---- -- an unknown package. if Current_Attribute = Empty_Attribute then ! if Present (Current_Package) and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored then Pkg_Id := Package_Id_Of (Current_Package, In_Tree); *************** package body Prj.Dect is *** 189,195 **** -- If not a valid attribute name, issue an error if inside -- a package that need to be checked. ! Ignore := Current_Package /= Empty_Node and then Packages_To_Check /= All_Packages; if Ignore then --- 194,200 ---- -- If not a valid attribute name, issue an error if inside -- a package that need to be checked. ! Ignore := Present (Current_Package) and then Packages_To_Check /= All_Packages; if Ignore then *************** package body Prj.Dect is *** 218,225 **** else if Is_Read_Only (Current_Attribute) then Error_Msg ! ("read-only attribute cannot be given a value", Token_Ptr); end if; --- 223,231 ---- else if Is_Read_Only (Current_Attribute) then + Error_Msg_Name_1 := Token_Name; Error_Msg ! ("read-only attribute %% cannot be given a value", Token_Ptr); end if; *************** package body Prj.Dect is *** 236,242 **** -- Change obsolete names of attributes to the new names ! if Current_Package /= Empty_Node and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored then case Name_Of (Attribute, In_Tree) is --- 242,248 ---- -- Change obsolete names of attributes to the new names ! if Present (Current_Package) and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored then case Name_Of (Attribute, In_Tree) is *************** package body Prj.Dect is *** 279,298 **** end if; Scan (In_Tree); -- past the left parenthesis - Expect (Tok_String_Literal, "literal string"); ! if Token = Tok_String_Literal then ! Get_Name_String (Token_Name); ! if Case_Insensitive (Attribute, In_Tree) then ! To_Lower (Name_Buffer (1 .. Name_Len)); end if; ! Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find); ! Scan (In_Tree); -- past the literal string index ! if Token = Tok_At then ! case Attribute_Kind_Of (Current_Attribute) is when Optional_Index_Associative_Array | Optional_Index_Case_Insensitive_Associative_Array => Scan (In_Tree); --- 285,317 ---- end if; Scan (In_Tree); -- past the left parenthesis ! if Others_Allowed_For (Current_Attribute) ! and then Token = Tok_Others ! then ! Set_Associative_Array_Index_Of ! (Attribute, In_Tree, All_Other_Names); ! Scan (In_Tree); -- past others ! else ! if Others_Allowed_For (Current_Attribute) then ! Expect (Tok_String_Literal, "literal string or others"); ! else ! Expect (Tok_String_Literal, "literal string"); end if; ! if Token = Tok_String_Literal then ! Get_Name_String (Token_Name); ! if Case_Insensitive (Attribute, In_Tree) then ! To_Lower (Name_Buffer (1 .. Name_Len)); ! end if; ! ! Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find); ! Scan (In_Tree); -- past the literal string index ! ! if Token = Tok_At then ! case Attribute_Kind_Of (Current_Attribute) is when Optional_Index_Associative_Array | Optional_Index_Case_Insensitive_Associative_Array => Scan (In_Tree); *************** package body Prj.Dect is *** 324,330 **** if Token = Tok_Integer_Literal then Scan (In_Tree); end if; ! end case; end if; end if; --- 343,350 ---- if Token = Tok_Integer_Literal then Scan (In_Tree); end if; ! end case; ! end if; end if; end if; *************** package body Prj.Dect is *** 398,404 **** The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Token_Name); ! if The_Project = Empty_Node then Error_Msg ("unknown project", Location); Scan (In_Tree); -- past the project name --- 418,424 ---- The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Token_Name); ! if No (The_Project) then Error_Msg ("unknown project", Location); Scan (In_Tree); -- past the project name *************** package body Prj.Dect is *** 409,415 **** -- If this is inside a package, a dot followed by the -- name of the package must followed the project name. ! if Current_Package /= Empty_Node then Expect (Tok_Dot, "`.`"); if Token /= Tok_Dot then --- 429,435 ---- -- If this is inside a package, a dot followed by the -- name of the package must followed the project name. ! if Present (Current_Package) then Expect (Tok_Dot, "`.`"); if Token /= Tok_Dot then *************** package body Prj.Dect is *** 440,446 **** -- Look for the package node ! while The_Package /= Empty_Node and then Name_Of (The_Package, In_Tree) /= Token_Name loop --- 460,466 ---- -- Look for the package node ! while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Token_Name loop *************** package body Prj.Dect is *** 452,458 **** -- If the package cannot be found in the -- project, issue an error. ! if The_Package = Empty_Node then The_Project := Empty_Node; Error_Msg_Name_2 := Project_Name; Error_Msg_Name_1 := Token_Name; --- 472,478 ---- -- If the package cannot be found in the -- project, issue an error. ! if No (The_Package) then The_Project := Empty_Node; Error_Msg_Name_2 := Project_Name; Error_Msg_Name_1 := Token_Name; *************** package body Prj.Dect is *** 468,474 **** end if; end if; ! if The_Project /= Empty_Node then -- Looking for ' --- 488,494 ---- end if; end if; ! if Present (The_Project) then -- Looking for ' *************** package body Prj.Dect is *** 498,504 **** end if; end if; ! if The_Project = Empty_Node then -- If there were any problem, set the attribute id to null, -- so that the node will not be recorded. --- 518,524 ---- end if; end if; ! if No (The_Project) then -- If there were any problem, set the attribute id to null, -- so that the node will not be recorded. *************** package body Prj.Dect is *** 541,547 **** -- for the attribute, issue an error. if Current_Attribute /= Empty_Attribute ! and then Expression /= Empty_Node and then Variable_Kind_Of (Current_Attribute) /= Expression_Kind_Of (Expression, In_Tree) then --- 561,567 ---- -- for the attribute, issue an error. if Current_Attribute /= Empty_Attribute ! and then Present (Expression) and then Variable_Kind_Of (Current_Attribute) /= Expression_Kind_Of (Expression, In_Tree) then *************** package body Prj.Dect is *** 634,643 **** end if; end if; ! if Case_Variable /= Empty_Node then String_Type := String_Type_Of (Case_Variable, In_Tree); ! if String_Type = Empty_Node then Error_Msg ("variable """ & Get_Name_String (Name_Of (Case_Variable, In_Tree)) & """ is not typed", --- 654,663 ---- end if; end if; ! if Present (Case_Variable) then String_Type := String_Type_Of (Case_Variable, In_Tree); ! if No (String_Type) then Error_Msg ("variable """ & Get_Name_String (Name_Of (Case_Variable, In_Tree)) & """ is not typed", *************** package body Prj.Dect is *** 808,822 **** The_Variable : Project_Node_Id := Empty_Node; begin ! if Current_Package /= Empty_Node then The_Variable := First_Variable_Of (Current_Package, In_Tree); ! elsif Current_Project /= Empty_Node then The_Variable := First_Variable_Of (Current_Project, In_Tree); end if; ! while The_Variable /= Empty_Node and then Name_Of (The_Variable, In_Tree) /= Token_Name loop --- 828,842 ---- The_Variable : Project_Node_Id := Empty_Node; begin ! if Present (Current_Package) then The_Variable := First_Variable_Of (Current_Package, In_Tree); ! elsif Present (Current_Project) then The_Variable := First_Variable_Of (Current_Project, In_Tree); end if; ! while Present (The_Variable) and then Name_Of (The_Variable, In_Tree) /= Token_Name loop *************** package body Prj.Dect is *** 826,832 **** -- It is an error to declare a variable in a case -- construction for the first time. ! if The_Variable = Empty_Node then Error_Msg ("a variable cannot be declared " & "for the first time here", --- 846,852 ---- -- It is an error to declare a variable in a case -- construction for the first time. ! if No (The_Variable) then Error_Msg ("a variable cannot be declared " & "for the first time here", *************** package body Prj.Dect is *** 911,917 **** when others => exit; ! -- We are leaving Parse_Declarative_Items positionned -- at the first token after the list of declarative items. -- It could be "end" (for a project, a package declaration or -- a case construction) or "when" (for a case construction) --- 931,937 ---- when others => exit; ! -- We are leaving Parse_Declarative_Items positioned -- at the first token after the list of declarative items. -- It could be "end" (for a project, a package declaration or -- a case construction) or "when" (for a case construction) *************** package body Prj.Dect is *** 923,930 **** -- Insert an N_Declarative_Item in the tree, but only if -- Current_Declaration is not an empty node. ! if Current_Declaration /= Empty_Node then ! if Current_Declarative_Item = Empty_Node then Current_Declarative_Item := Default_Project_Node (Of_Kind => N_Declarative_Item, In_Tree => In_Tree); --- 943,950 ---- -- Insert an N_Declarative_Item in the tree, but only if -- Current_Declaration is not an empty node. ! if Present (Current_Declaration) then ! if No (Current_Declarative_Item) then Current_Declarative_Item := Default_Project_Node (Of_Kind => N_Declarative_Item, In_Tree => In_Tree); *************** package body Prj.Dect is *** 983,993 **** if Current_Package = Empty_Package then if not Quiet_Output then ! Error_Msg ("?""" & ! Get_Name_String ! (Name_Of (Package_Declaration, In_Tree)) & ! """ is not a known package name", ! Token_Ptr); end if; -- Set the package declaration to "ignored" so that it is not --- 1003,1046 ---- if Current_Package = Empty_Package then if not Quiet_Output then ! declare ! List : constant Strings.String_List := Package_Name_List; ! Index : Natural; ! Name : constant String := Get_Name_String (Token_Name); ! ! begin ! -- Check for possible misspelling of a known package name ! ! Index := 0; ! loop ! if Index >= List'Last then ! Index := 0; ! exit; ! end if; ! ! Index := Index + 1; ! exit when ! GNAT.Spelling_Checker.Is_Bad_Spelling_Of ! (Name, List (Index).all); ! end loop; ! ! -- Issue warning(s) in verbose mode or when a possible ! -- misspelling has been found. ! ! if Verbose_Mode or else Index /= 0 then ! Error_Msg ("?""" & ! Get_Name_String ! (Name_Of (Package_Declaration, In_Tree)) & ! """ is not a known package name", ! Token_Ptr); ! end if; ! ! if Index /= 0 then ! Error_Msg ("\?possible misspelling of """ & ! List (Index).all & """", ! Token_Ptr); ! end if; ! end; end if; -- Set the package declaration to "ignored" so that it is not *************** package body Prj.Dect is *** 1018,1030 **** First_Package_Of (Current_Project, In_Tree); begin ! while Current /= Empty_Node and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_Package_In_Project (Current, In_Tree); end loop; ! if Current /= Empty_Node then Error_Msg ("package """ & Get_Name_String (Name_Of (Package_Declaration, In_Tree)) & --- 1071,1083 ---- First_Package_Of (Current_Project, In_Tree); begin ! while Present (Current) and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_Package_In_Project (Current, In_Tree); end loop; ! if Present (Current) then Error_Msg ("package """ & Get_Name_String (Name_Of (Package_Declaration, In_Tree)) & *************** package body Prj.Dect is *** 1072,1093 **** (Current_Project, In_Tree), In_Tree); begin ! while Clause /= Empty_Node loop -- Only non limited imported projects may be used in a -- renames declaration. The_Project := Non_Limited_Project_Node_Of (Clause, In_Tree); ! exit when The_Project /= Empty_Node and then Name_Of (The_Project, In_Tree) = Project_Name; Clause := Next_With_Clause_Of (Clause, In_Tree); end loop; ! if Clause = Empty_Node then -- As we have not found the project in the imports, we check -- if it's the name of an eventual extended project. ! if Extended /= Empty_Node and then Name_Of (Extended, In_Tree) = Project_Name then Set_Project_Of_Renamed_Package_Of --- 1125,1146 ---- (Current_Project, In_Tree), In_Tree); begin ! while Present (Clause) loop -- Only non limited imported projects may be used in a -- renames declaration. The_Project := Non_Limited_Project_Node_Of (Clause, In_Tree); ! exit when Present (The_Project) and then Name_Of (The_Project, In_Tree) = Project_Name; Clause := Next_With_Clause_Of (Clause, In_Tree); end loop; ! if No (Clause) then -- As we have not found the project in the imports, we check -- if it's the name of an eventual extended project. ! if Present (Extended) and then Name_Of (Extended, In_Tree) = Project_Name then Set_Project_Of_Renamed_Package_Of *************** package body Prj.Dect is *** 1114,1121 **** if Name_Of (Package_Declaration, In_Tree) /= Token_Name then Error_Msg ("not the same package name", Token_Ptr); elsif ! Project_Of_Renamed_Package_Of ! (Package_Declaration, In_Tree) /= Empty_Node then declare Current : Project_Node_Id := --- 1167,1174 ---- if Name_Of (Package_Declaration, In_Tree) /= Token_Name then Error_Msg ("not the same package name", Token_Ptr); elsif ! Present (Project_Of_Renamed_Package_Of ! (Package_Declaration, In_Tree)) then declare Current : Project_Node_Id := *************** package body Prj.Dect is *** 1125,1138 **** In_Tree); begin ! while Current /= Empty_Node and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_Package_In_Project (Current, In_Tree); end loop; ! if Current = Empty_Node then Error_Msg ("""" & Get_Name_String (Token_Name) & --- 1178,1191 ---- In_Tree); begin ! while Present (Current) and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_Package_In_Project (Current, In_Tree); end loop; ! if No (Current) then Error_Msg ("""" & Get_Name_String (Token_Name) & *************** package body Prj.Dect is *** 1234,1260 **** Set_Name_Of (String_Type, In_Tree, To => Token_Name); Current := First_String_Type_Of (Current_Project, In_Tree); ! while Current /= Empty_Node and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_String_Type (Current, In_Tree); end loop; ! if Current /= Empty_Node then Error_Msg ("duplicate string type name """ & Get_Name_String (Token_Name) & """", Token_Ptr); else Current := First_Variable_Of (Current_Project, In_Tree); ! while Current /= Empty_Node and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_Variable (Current, In_Tree); end loop; ! if Current /= Empty_Node then Error_Msg ("""" & Get_Name_String (Token_Name) & """ is already a variable name", Token_Ptr); --- 1287,1313 ---- Set_Name_Of (String_Type, In_Tree, To => Token_Name); Current := First_String_Type_Of (Current_Project, In_Tree); ! while Present (Current) and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_String_Type (Current, In_Tree); end loop; ! if Present (Current) then Error_Msg ("duplicate string type name """ & Get_Name_String (Token_Name) & """", Token_Ptr); else Current := First_Variable_Of (Current_Project, In_Tree); ! while Present (Current) and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_Variable (Current, In_Tree); end loop; ! if Present (Current) then Error_Msg ("""" & Get_Name_String (Token_Name) & """ is already a variable name", Token_Ptr); *************** package body Prj.Dect is *** 1361,1368 **** if OK then declare ! Current : Project_Node_Id := ! First_String_Type_Of (Current_Project, In_Tree); begin if Project_String_Type_Name /= No_Name then --- 1414,1421 ---- if OK then declare ! Proj : Project_Node_Id := Current_Project; ! Current : Project_Node_Id := Empty_Node; begin if Project_String_Type_Name /= No_Name then *************** package body Prj.Dect is *** 1376,1382 **** begin if The_Project_Name_And_Node = ! Tree_Private_Part.No_Project_Name_And_Node then Error_Msg ("unknown project """ & Get_Name_String --- 1429,1435 ---- begin if The_Project_Name_And_Node = ! Tree_Private_Part.No_Project_Name_And_Node then Error_Msg ("unknown project """ & Get_Name_String *************** package body Prj.Dect is *** 1388,1409 **** Current := First_String_Type_Of (The_Project_Name_And_Node.Node, In_Tree); end if; end; - end if; ! while Current /= Empty_Node ! and then Name_Of (Current, In_Tree) /= String_Type_Name ! loop ! Current := Next_String_Type (Current, In_Tree); ! end loop; ! if Current = Empty_Node then Error_Msg ("unknown string type """ & Get_Name_String (String_Type_Name) & """", Type_Location); OK := False; else Set_String_Type_Of (Variable, In_Tree, To => Current); --- 1441,1485 ---- Current := First_String_Type_Of (The_Project_Name_And_Node.Node, In_Tree); + while + Present (Current) + and then + Name_Of (Current, In_Tree) /= String_Type_Name + loop + Current := Next_String_Type (Current, In_Tree); + end loop; end if; end; ! else ! -- Look for a string type with the correct name in this ! -- project or in any of its ancestors. ! loop ! Current := ! First_String_Type_Of (Proj, In_Tree); ! while ! Present (Current) ! and then ! Name_Of (Current, In_Tree) /= String_Type_Name ! loop ! Current := Next_String_Type (Current, In_Tree); ! end loop; ! ! exit when Present (Current); ! ! Proj := Parent_Project_Of (Proj, In_Tree); ! exit when No (Proj); ! end loop; ! end if; ! ! if No (Current) then Error_Msg ("unknown string type """ & Get_Name_String (String_Type_Name) & """", Type_Location); OK := False; + else Set_String_Type_Of (Variable, In_Tree, To => Current); *************** package body Prj.Dect is *** 1433,1439 **** Optional_Index => False); Set_Expression_Of (Variable, In_Tree, To => Expression); ! if Expression /= Empty_Node then -- A typed string must have a single string value, not a list if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration --- 1509,1515 ---- Optional_Index => False); Set_Expression_Of (Variable, In_Tree, To => Expression); ! if Present (Expression) then -- A typed string must have a single string value, not a list if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration *************** package body Prj.Dect is *** 1453,1479 **** The_Variable : Project_Node_Id := Empty_Node; begin ! if Current_Package /= Empty_Node then The_Variable := First_Variable_Of (Current_Package, In_Tree); ! elsif Current_Project /= Empty_Node then ! The_Variable := First_Variable_Of (Current_Project, In_Tree); end if; ! while The_Variable /= Empty_Node and then Name_Of (The_Variable, In_Tree) /= Variable_Name loop The_Variable := Next_Variable (The_Variable, In_Tree); end loop; ! if The_Variable = Empty_Node then ! if Current_Package /= Empty_Node then Set_Next_Variable (Variable, In_Tree, To => First_Variable_Of (Current_Package, In_Tree)); Set_First_Variable_Of (Current_Package, In_Tree, To => Variable); ! elsif Current_Project /= Empty_Node then Set_Next_Variable (Variable, In_Tree, To => First_Variable_Of (Current_Project, In_Tree)); --- 1529,1555 ---- The_Variable : Project_Node_Id := Empty_Node; begin ! if Present (Current_Package) then The_Variable := First_Variable_Of (Current_Package, In_Tree); ! elsif Present (Current_Project) then ! The_Variable := First_Variable_Of (Current_Project, In_Tree); end if; ! while Present (The_Variable) and then Name_Of (The_Variable, In_Tree) /= Variable_Name loop The_Variable := Next_Variable (The_Variable, In_Tree); end loop; ! if No (The_Variable) then ! if Present (Current_Package) then Set_Next_Variable (Variable, In_Tree, To => First_Variable_Of (Current_Package, In_Tree)); Set_First_Variable_Of (Current_Package, In_Tree, To => Variable); ! elsif Present (Current_Project) then Set_Next_Variable (Variable, In_Tree, To => First_Variable_Of (Current_Project, In_Tree)); *************** package body Prj.Dect is *** 1483,1490 **** else if Expression_Kind_Of (Variable, In_Tree) /= Undefined then ! if ! Expression_Kind_Of (The_Variable, In_Tree) = Undefined then Set_Expression_Kind_Of (The_Variable, In_Tree, --- 1559,1566 ---- else if Expression_Kind_Of (Variable, In_Tree) /= Undefined then ! if Expression_Kind_Of (The_Variable, In_Tree) = ! Undefined then Set_Expression_Kind_Of (The_Variable, In_Tree, *************** package body Prj.Dect is *** 1505,1511 **** end if; end; end if; - end Parse_Variable_Declaration; end Prj.Dect; --- 1581,1586 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/prj-env.adb gcc-4.4.0/gcc/ada/prj-env.adb *** gcc-4.3.3/gcc/ada/prj-env.adb Thu Dec 13 10:28:39 2007 --- gcc-4.4.0/gcc/ada/prj-env.adb Thu Jul 31 14:41:32 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package body Prj.Env is *** 251,257 **** if (Data.Library and then Including_Libraries) or else ! (Data.Object_Directory /= No_Path and then (not Including_Libraries or else not Data.Library)) then --- 251,257 ---- if (Data.Library and then Including_Libraries) or else ! (Data.Object_Directory /= No_Path_Information and then (not Including_Libraries or else not Data.Library)) then *************** package body Prj.Env is *** 260,278 **** -- files; otherwise add the object directory. if Data.Library then ! if Data.Object_Directory = No_Path or else ! Contains_ALI_Files (Data.Library_ALI_Dir) then ! Add_To_Path (Get_Name_String (Data.Library_ALI_Dir)); else ! Add_To_Path (Get_Name_String (Data.Object_Directory)); end if; else -- For a non library project, add the object directory ! Add_To_Path (Get_Name_String (Data.Object_Directory)); end if; end if; --- 260,281 ---- -- files; otherwise add the object directory. if Data.Library then ! if Data.Object_Directory = No_Path_Information or else ! Contains_ALI_Files (Data.Library_ALI_Dir.Name) then ! Add_To_Path ! (Get_Name_String (Data.Library_ALI_Dir.Name)); else ! Add_To_Path ! (Get_Name_String (Data.Object_Directory.Name)); end if; else -- For a non library project, add the object directory ! Add_To_Path ! (Get_Name_String (Data.Object_Directory.Name)); end if; end if; *************** package body Prj.Env is *** 520,526 **** -- If we don't know the path name of the body of this unit, -- we compute it, and we store it. ! if Data.File_Names (Body_Part).Path = No_Path then declare Current_Source : String_List_Id := In_Tree.Projects.Table --- 523,529 ---- -- If we don't know the path name of the body of this unit, -- we compute it, and we store it. ! if Data.File_Names (Body_Part).Path = No_Path_Information then declare Current_Source : String_List_Id := In_Tree.Projects.Table *************** package body Prj.Env is *** 530,536 **** begin -- By default, put the file name ! Data.File_Names (Body_Part).Path := Path_Name_Type (Data.File_Names (Body_Part).Name); -- For each source directory --- 533,539 ---- begin -- By default, put the file name ! Data.File_Names (Body_Part).Path.Name := Path_Name_Type (Data.File_Names (Body_Part).Name); -- For each source directory *************** package body Prj.Env is *** 550,556 **** if Path /= null then Name_Len := Path'Length; Name_Buffer (1 .. Name_Len) := Path.all; ! Data.File_Names (Body_Part).Path := Name_Enter; exit; else --- 553,559 ---- if Path /= null then Name_Len := Path'Length; Name_Buffer (1 .. Name_Len) := Path.all; ! Data.File_Names (Body_Part).Path.Name := Name_Enter; exit; else *************** package body Prj.Env is *** 566,572 **** -- Returned the stored value ! return Namet.Get_Name_String (Data.File_Names (Body_Part).Path); end Body_Path_Name_Of; ------------------------ --- 569,575 ---- -- Returned the stored value ! return Namet.Get_Name_String (Data.File_Names (Body_Part).Path.Name); end Body_Path_Name_Of; ------------------------ *************** package body Prj.Env is *** 1005,1017 **** -- If there is a spec, put it in the mapping if Data.Name /= No_File then ! if Data.Path = Slash then Fmap.Add_Forbidden_File_Name (Data.Name); else Fmap.Add_To_File_Map (Unit_Name => Unit_Name_Type (The_Unit_Data.Name), File_Name => Data.Name, ! Path_Name => File_Name_Type (Data.Path)); end if; end if; --- 1008,1020 ---- -- If there is a spec, put it in the mapping if Data.Name /= No_File then ! if Data.Path.Name = Slash then Fmap.Add_Forbidden_File_Name (Data.Name); else Fmap.Add_To_File_Map (Unit_Name => Unit_Name_Type (The_Unit_Data.Name), File_Name => Data.Name, ! Path_Name => File_Name_Type (Data.Path.Name)); end if; end if; *************** package body Prj.Env is *** 1020,1032 **** -- If there is a body (or subunit) put it in the mapping if Data.Name /= No_File then ! if Data.Path = Slash then Fmap.Add_Forbidden_File_Name (Data.Name); else Fmap.Add_To_File_Map (Unit_Name => Unit_Name_Type (The_Unit_Data.Name), File_Name => Data.Name, ! Path_Name => File_Name_Type (Data.Path)); end if; end if; end if; --- 1023,1035 ---- -- If there is a body (or subunit) put it in the mapping if Data.Name /= No_File then ! if Data.Path.Name = Slash then Fmap.Add_Forbidden_File_Name (Data.Name); else Fmap.Add_To_File_Map (Unit_Name => Unit_Name_Type (The_Unit_Data.Name), File_Name => Data.Name, ! Path_Name => File_Name_Type (Data.Path.Name)); end if; end if; end if; *************** package body Prj.Env is *** 1111,1117 **** -- Line with the path name ! Get_Name_String (Data.Path); Put_Name_Buffer; end Put_Data; --- 1114,1120 ---- -- Line with the path name ! Get_Name_String (Data.Path.Name); Put_Name_Buffer; end Put_Data; *************** package body Prj.Env is *** 1334,1340 **** if Src_Data.Language_Name = Language and then not Src_Data.Locally_Removed and then Src_Data.Replaced_By = No_Source ! and then Src_Data.Path /= No_Path then if Src_Data.Unit /= No_Name then Get_Name_String (Src_Data.Unit); --- 1337,1343 ---- if Src_Data.Language_Name = Language and then not Src_Data.Locally_Removed and then Src_Data.Replaced_By = No_Source ! and then Src_Data.Path.Name /= No_Path then if Src_Data.Unit /= No_Name then Get_Name_String (Src_Data.Unit); *************** package body Prj.Env is *** 1359,1365 **** Get_Name_String (Src_Data.File); Put_Name_Buffer; ! Get_Name_String (Src_Data.Path); Put_Name_Buffer; end if; --- 1362,1368 ---- Get_Name_String (Src_Data.File); Put_Name_Buffer; ! Get_Name_String (Src_Data.Path.Name); Put_Name_Buffer; end if; *************** package body Prj.Env is *** 1542,1548 **** if Full_Path then return Get_Name_String ! (Unit.File_Names (Body_Part).Path); else return Get_Name_String (Current_Name); --- 1545,1551 ---- if Full_Path then return Get_Name_String ! (Unit.File_Names (Body_Part).Path.Name); else return Get_Name_String (Current_Name); *************** package body Prj.Env is *** 1558,1564 **** if Full_Path then return Get_Name_String ! (Unit.File_Names (Body_Part).Path); else return Extended_Body_Name; --- 1561,1567 ---- if Full_Path then return Get_Name_String ! (Unit.File_Names (Body_Part).Path.Name); else return Extended_Body_Name; *************** package body Prj.Env is *** 1605,1611 **** if Full_Path then return Get_Name_String ! (Unit.File_Names (Specification).Path); else return Get_Name_String (Current_Name); end if; --- 1608,1614 ---- if Full_Path then return Get_Name_String ! (Unit.File_Names (Specification).Path.Name); else return Get_Name_String (Current_Name); end if; *************** package body Prj.Env is *** 1620,1626 **** if Full_Path then return Get_Name_String ! (Unit.File_Names (Specification).Path); else return Extended_Spec_Name; end if; --- 1623,1629 ---- if Full_Path then return Get_Name_String ! (Unit.File_Names (Specification).Path.Name); else return Extended_Spec_Name; end if; *************** package body Prj.Env is *** 1723,1730 **** -- If there is an object directory, call Action with its name ! if Data.Object_Directory /= No_Path then ! Get_Name_String (Data.Display_Object_Dir); Action (Name_Buffer (1 .. Name_Len)); end if; --- 1726,1733 ---- -- If there is an object directory, call Action with its name ! if Data.Object_Directory /= No_Path_Information then ! Get_Name_String (Data.Object_Directory.Display_Name); Action (Name_Buffer (1 .. Name_Len)); end if; *************** package body Prj.Env is *** 1899,1914 **** and then Namet.Get_Name_String (Unit.File_Names (Specification).Name) = Original_Name) ! or else (Unit.File_Names (Specification).Path /= No_Path and then Namet.Get_Name_String ! (Unit.File_Names (Specification).Path) = Original_Name) then Project := Ultimate_Extension_Of (Project => Unit.File_Names (Specification).Project, In_Tree => In_Tree); ! Path := Unit.File_Names (Specification).Display_Path; if Current_Verbosity > Default then Write_Str ("Done: Specification."); --- 1902,1918 ---- and then Namet.Get_Name_String (Unit.File_Names (Specification).Name) = Original_Name) ! or else (Unit.File_Names (Specification).Path /= ! No_Path_Information and then Namet.Get_Name_String ! (Unit.File_Names (Specification).Path.Name) = Original_Name) then Project := Ultimate_Extension_Of (Project => Unit.File_Names (Specification).Project, In_Tree => In_Tree); ! Path := Unit.File_Names (Specification).Path.Display_Name; if Current_Verbosity > Default then Write_Str ("Done: Specification."); *************** package body Prj.Env is *** 1921,1935 **** and then Namet.Get_Name_String (Unit.File_Names (Body_Part).Name) = Original_Name) ! or else (Unit.File_Names (Body_Part).Path /= No_Path and then Namet.Get_Name_String ! (Unit.File_Names (Body_Part).Path) = Original_Name) then Project := Ultimate_Extension_Of (Project => Unit.File_Names (Body_Part).Project, In_Tree => In_Tree); ! Path := Unit.File_Names (Body_Part).Display_Path; if Current_Verbosity > Default then Write_Str ("Done: Body."); --- 1925,1939 ---- and then Namet.Get_Name_String (Unit.File_Names (Body_Part).Name) = Original_Name) ! or else (Unit.File_Names (Body_Part).Path /= No_Path_Information and then Namet.Get_Name_String ! (Unit.File_Names (Body_Part).Path.Name) = Original_Name) then Project := Ultimate_Extension_Of (Project => Unit.File_Names (Body_Part).Project, In_Tree => In_Tree); ! Path := Unit.File_Names (Body_Part).Path.Display_Name; if Current_Verbosity > Default then Write_Str ("Done: Body."); *************** package body Prj.Env is *** 2121,2127 **** Write_Str (" Project: "); Get_Name_String (In_Tree.Projects.Table ! (Unit.File_Names (Specification).Project).Path_Name); Write_Line (Name_Buffer (1 .. Name_Len)); end if; --- 2125,2131 ---- Write_Str (" Project: "); Get_Name_String (In_Tree.Projects.Table ! (Unit.File_Names (Specification).Project).Path.Name); Write_Line (Name_Buffer (1 .. Name_Len)); end if; *************** package body Prj.Env is *** 2139,2145 **** Write_Str (" Project: "); Get_Name_String (In_Tree.Projects.Table ! (Unit.File_Names (Body_Part).Project).Path_Name); Write_Line (Name_Buffer (1 .. Name_Len)); end if; --- 2143,2149 ---- Write_Str (" Project: "); Get_Name_String (In_Tree.Projects.Table ! (Unit.File_Names (Body_Part).Project).Path.Name); Write_Line (Name_Buffer (1 .. Name_Len)); end if; *************** package body Prj.Env is *** 2328,2334 **** if (Data.Library and Including_Libraries) or else ! (Data.Object_Directory /= No_Path and then (not Including_Libraries or else not Data.Library)) then --- 2332,2338 ---- if (Data.Library and Including_Libraries) or else ! (Data.Object_Directory /= No_Path_Information and then (not Including_Libraries or else not Data.Library)) then *************** package body Prj.Env is *** 2338,2365 **** -- otherwise add the object directory. if Data.Library then ! if Data.Object_Directory = No_Path ! or else Contains_ALI_Files (Data.Library_ALI_Dir) then Add_To_Object_Path ! (Data.Library_ALI_Dir, In_Tree); else Add_To_Object_Path ! (Data.Object_Directory, In_Tree); end if; ! -- For a non-library project, add the object ! -- directory, if it is not a virtual project, and if ! -- there are Ada sources or if the project is an ! -- extending project. if There Are No Ada sources, ! -- adding the object directory could disrupt the order ! -- of the object dirs in the path. ! elsif not Data.Virtual ! and then There_Are_Ada_Sources (In_Tree, Project) ! then ! Add_To_Object_Path ! (Data.Object_Directory, In_Tree); end if; end if; end if; --- 2342,2390 ---- -- otherwise add the object directory. if Data.Library then ! if Data.Object_Directory = No_Path_Information ! or else Contains_ALI_Files ! (Data.Library_ALI_Dir.Name) then Add_To_Object_Path ! (Data.Library_ALI_Dir.Name, In_Tree); else Add_To_Object_Path ! (Data.Object_Directory.Name, In_Tree); end if; ! -- For a non-library project, add object directory if ! -- it is not a virtual project, and if there are Ada ! -- sources in the project or one of the projects it ! -- extends. If there are no Ada sources, adding the ! -- object directory could disrupt the order of the ! -- object dirs in the path. ! elsif not Data.Virtual then ! declare ! Add_Object_Dir : Boolean := False; ! Prj : Project_Id := Project; ! ! begin ! while not Add_Object_Dir ! and then Prj /= No_Project ! loop ! if In_Tree.Projects.Table ! (Prj).Ada_Sources /= Nil_String ! then ! Add_Object_Dir := True; ! ! else ! Prj := ! In_Tree.Projects.Table (Prj).Extends; ! end if; ! end loop; ! ! if Add_Object_Dir then ! Add_To_Object_Path ! (Data.Object_Directory.Name, In_Tree); ! end if; ! end; end if; end if; end if; *************** package body Prj.Env is *** 2566,2572 **** Data : Unit_Data := In_Tree.Units.Table (Unit); begin ! if Data.File_Names (Specification).Path = No_Path then declare Current_Source : String_List_Id := In_Tree.Projects.Table --- 2591,2597 ---- Data : Unit_Data := In_Tree.Units.Table (Unit); begin ! if Data.File_Names (Specification).Path.Name = No_Path then declare Current_Source : String_List_Id := In_Tree.Projects.Table *************** package body Prj.Env is *** 2574,2580 **** Path : GNAT.OS_Lib.String_Access; begin ! Data.File_Names (Specification).Path := Path_Name_Type (Data.File_Names (Specification).Name); while Current_Source /= Nil_String loop --- 2599,2605 ---- Path : GNAT.OS_Lib.String_Access; begin ! Data.File_Names (Specification).Path.Name := Path_Name_Type (Data.File_Names (Specification).Name); while Current_Source /= Nil_String loop *************** package body Prj.Env is *** 2588,2594 **** if Path /= null then Name_Len := Path'Length; Name_Buffer (1 .. Name_Len) := Path.all; ! Data.File_Names (Specification).Path := Name_Enter; exit; else Current_Source := --- 2613,2619 ---- if Path /= null then Name_Len := Path'Length; Name_Buffer (1 .. Name_Len) := Path.all; ! Data.File_Names (Specification).Path.Name := Name_Enter; exit; else Current_Source := *************** package body Prj.Env is *** 2601,2607 **** end; end if; ! return Namet.Get_Name_String (Data.File_Names (Specification).Path); end Spec_Path_Name_Of; --------------------------- --- 2626,2632 ---- end; end if; ! return Namet.Get_Name_String (Data.File_Names (Specification).Path.Name); end Spec_Path_Name_Of; --------------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/prj-env.ads gcc-4.4.0/gcc/ada/prj-env.ads *** gcc-4.3.3/gcc/ada/prj-env.ads Wed Sep 26 10:44:55 2007 --- gcc-4.4.0/gcc/ada/prj-env.ads Tue May 27 11:00:07 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package Prj.Env is *** 85,98 **** function Ada_Include_Path (Project : Project_Id; In_Tree : Project_Tree_Ref) return String_Access; ! -- Get the ADA_INCLUDE_PATH of a Project file. For the first call, compute ! -- it and cache it. function Ada_Include_Path (Project : Project_Id; In_Tree : Project_Tree_Ref; Recursive : Boolean) return String; ! -- Get the ADA_INCLUDE_PATH of a Project file. If Recursive it True, -- get all the source directories of the imported and modified project -- files (recursively). If Recursive is False, just get the path for the -- source directories of Project. Note: the resulting String may be empty --- 85,98 ---- function Ada_Include_Path (Project : Project_Id; In_Tree : Project_Tree_Ref) return String_Access; ! -- Get the source search path of a Project file. For the first call, ! -- compute it and cache it. function Ada_Include_Path (Project : Project_Id; In_Tree : Project_Tree_Ref; Recursive : Boolean) return String; ! -- Get the source search path of a Project file. If Recursive it True, -- get all the source directories of the imported and modified project -- files (recursively). If Recursive is False, just get the path for the -- source directories of Project. Note: the resulting String may be empty diff -Nrcpad gcc-4.3.3/gcc/ada/prj-ext.adb gcc-4.4.0/gcc/ada/prj-ext.adb *** gcc-4.3.3/gcc/ada/prj-ext.adb Thu Dec 13 10:28:39 2007 --- gcc-4.4.0/gcc/ada/prj-ext.adb Tue Apr 8 06:48:54 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2008, 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- -- *************** package body Prj.Ext is *** 180,186 **** end if; -- Scan the directory path to see if "-" is one of the directories. ! -- Remove each occurence of "-" and set Add_Default_Dir to False. -- Also resolve relative paths and symbolic links. First := 3; --- 180,186 ---- end if; -- Scan the directory path to see if "-" is one of the directories. ! -- Remove each occurrence of "-" and set Add_Default_Dir to False. -- Also resolve relative paths and symbolic links. First := 3; *************** package body Prj.Ext is *** 260,278 **** Prefix := new String'(Executable_Prefix_Path); if Prefix.all /= "" then ! if Get_Mode = Ada_Only then ! Current_Project_Path := ! new String'(Name_Buffer (1 .. Name_Len) & ! Path_Separator & ! Prefix.all & Directory_Separator & "gnat"); ! ! else ! Current_Project_Path := ! new String'(Name_Buffer (1 .. Name_Len) & ! Path_Separator & ! Prefix.all & Directory_Separator & ! "share" & Directory_Separator & "gpr"); end if; end if; else --- 260,276 ---- Prefix := new String'(Executable_Prefix_Path); if Prefix.all /= "" then ! if Get_Mode = Multi_Language then ! Add_Str_To_Name_Buffer ! (Path_Separator & Prefix.all & ! Directory_Separator & "share" & ! Directory_Separator & "gpr"); end if; + + Add_Str_To_Name_Buffer + (Path_Separator & Prefix.all & + Directory_Separator & "lib" & + Directory_Separator & "gnat"); end if; else diff -Nrcpad gcc-4.3.3/gcc/ada/prj-makr.adb gcc-4.4.0/gcc/ada/prj-makr.adb *** gcc-4.3.3/gcc/ada/prj-makr.adb Thu Dec 13 10:28:39 2007 --- gcc-4.4.0/gcc/ada/prj-makr.adb Thu May 29 08:56:01 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** with GNAT.Directory_Operations; use GNAT *** 41,47 **** with System.Case_Util; use System.Case_Util; with System.CRTL; - with System.Regexp; use System.Regexp; package body Prj.Makr is --- 41,46 ---- *************** package body Prj.Makr is *** 50,55 **** --- 49,103 ---- -- All the following need comments ??? All global variables and -- subprograms must be fully commented. + Very_Verbose : Boolean := False; + -- Set in call to Initialize to indicate very verbose output + + Project_File : Boolean := False; + -- True when gnatname is creating/modifying a project file. False when + -- gnatname is creating a configuration pragmas file. + + Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data; + -- The project tree where the project file is parsed + + Args : Argument_List_Access; + -- The list of arguments for calls to the compiler to get the unit names + -- and kinds (spec or body) in the Ada sources. + + Path_Name : String_Access; + + Path_Last : Natural; + + Directory_Last : Natural := 0; + + Output_Name : String_Access; + Output_Name_Last : Natural; + Output_Name_Id : Name_Id; + + Project_Naming_File_Name : String_Access; + -- String (1 .. Output_Name'Length + Naming_File_Suffix'Length); + + Project_Naming_Last : Natural; + Project_Naming_Id : Name_Id := No_Name; + + Source_List_Path : String_Access; + -- (1 .. Output_Name'Length + Source_List_File_Suffix'Length); + Source_List_Last : Natural; + + Source_List_FD : File_Descriptor; + + Project_Node : Project_Node_Id := Empty_Node; + Project_Declaration : Project_Node_Id := Empty_Node; + Source_Dirs_List : Project_Node_Id := Empty_Node; + + Project_Naming_Node : Project_Node_Id := Empty_Node; + Project_Naming_Decl : Project_Node_Id := Empty_Node; + Naming_Package : Project_Node_Id := Empty_Node; + Naming_Package_Comments : Project_Node_Id := Empty_Node; + + Source_Files_Comments : Project_Node_Id := Empty_Node; + Source_Dirs_Comments : Project_Node_Id := Empty_Node; + Source_List_File_Comments : Project_Node_Id := Empty_Node; + Naming_String : aliased String := "naming"; Gnatname_Packages : aliased String_List := (1 => Naming_String'Access); *************** package body Prj.Makr is *** 91,96 **** --- 139,174 ---- Table_Initial => 10, Table_Increment => 100, Table_Name => "Prj.Makr.Processed_Directories"); + -- The list of already processed directories for each section, to avoid + -- processing several times the same directory in the same section. + + package Source_Directories is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Makr.Source_Directories"); + -- The complete list of directories to be put in attribute Source_Dirs in + -- the project file. + + type Source is record + File_Name : Name_Id; + Unit_Name : Name_Id; + Index : Int := 0; + Spec : Boolean; + end record; + + package Sources is new Table.Table + (Table_Component_Type => Source, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Makr.Sources"); + -- The list of Ada sources found, with their unit name and kind, to be put + -- in the source attribute and package Naming of the project file, or in + -- the pragmas Source_File_Name in the configuration pragmas file. --------- -- Dup -- *************** package body Prj.Makr is *** 112,677 **** Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd)); end Dup2; ! ---------- ! -- Make -- ! ---------- ! ! procedure Make ! (File_Path : String; ! Project_File : Boolean; ! Directories : Argument_List; ! Name_Patterns : Argument_List; ! Excluded_Patterns : Argument_List; ! Foreign_Patterns : Argument_List; ! Preproc_Switches : Argument_List; ! Very_Verbose : Boolean) ! is ! Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data; ! ! Path_Name : String (1 .. File_Path'Length + ! Project_File_Extension'Length); ! Path_Last : Natural := File_Path'Length; ! ! Directory_Last : Natural := 0; ! ! Output_Name : String (Path_Name'Range); ! Output_Name_Last : Natural; ! Output_Name_Id : Name_Id; ! ! Project_Node : Project_Node_Id := Empty_Node; ! Project_Declaration : Project_Node_Id := Empty_Node; ! Source_Dirs_List : Project_Node_Id := Empty_Node; ! Current_Source_Dir : Project_Node_Id := Empty_Node; ! ! Project_Naming_Node : Project_Node_Id := Empty_Node; ! Project_Naming_Decl : Project_Node_Id := Empty_Node; ! Naming_Package : Project_Node_Id := Empty_Node; ! Naming_Package_Comments : Project_Node_Id := Empty_Node; ! Source_Files_Comments : Project_Node_Id := Empty_Node; ! Source_Dirs_Comments : Project_Node_Id := Empty_Node; ! Source_List_File_Comments : Project_Node_Id := Empty_Node; ! Project_Naming_File_Name : String (1 .. Output_Name'Length + ! Naming_File_Suffix'Length); ! Project_Naming_Last : Natural; ! Project_Naming_Id : Name_Id := No_Name; ! Excluded_Expressions : array (Excluded_Patterns'Range) of Regexp; ! Regular_Expressions : array (Name_Patterns'Range) of Regexp; ! Foreign_Expressions : array (Foreign_Patterns'Range) of Regexp; ! Source_List_Path : String (1 .. Output_Name'Length + ! Source_List_File_Suffix'Length); ! Source_List_Last : Natural; ! Source_List_FD : File_Descriptor; ! Args : Argument_List (1 .. Preproc_Switches'Length + 6); ! type SFN_Pragma is record ! Unit : Name_Id; ! File : Name_Id; ! Index : Int := 0; ! Spec : Boolean; ! end record; ! package SFN_Pragmas is new Table.Table ! (Table_Component_Type => SFN_Pragma, ! Table_Index_Type => Natural, ! Table_Low_Bound => 0, ! Table_Initial => 50, ! Table_Increment => 100, ! Table_Name => "Prj.Makr.SFN_Pragmas"); ! procedure Process_Directory (Dir_Name : String; Recursively : Boolean); ! -- Look for Ada and foreign sources in a directory, according to the ! -- patterns. When Recursively is True, after looking for sources in ! -- Dir_Name, look also in its subdirectories, if any. ! ----------------------- ! -- Process_Directory -- ! ----------------------- ! procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is ! Matched : Matched_Type := False; ! Str : String (1 .. 2_000); ! Canon : String (1 .. 2_000); ! Last : Natural; ! Dir : Dir_Type; ! Process : Boolean := True; ! Temp_File_Name : String_Access := null; ! Save_Last_Pragma_Index : Natural := 0; ! File_Name_Id : Name_Id := No_Name; ! SFN_Prag : SFN_Pragma; ! begin ! -- Avoid processing the same directory more than once ! for Index in 1 .. Processed_Directories.Last loop ! if Processed_Directories.Table (Index).all = Dir_Name then ! Process := False; ! exit; ! end if; ! end loop; ! if Process then ! if Opt.Verbose_Mode then ! Output.Write_Str ("Processing directory """); ! Output.Write_Str (Dir_Name); ! Output.Write_Line (""""); ! end if; ! Processed_Directories. Increment_Last; ! Processed_Directories.Table (Processed_Directories.Last) := ! new String'(Dir_Name); ! -- Get the source file names from the directory. Fails if the ! -- directory does not exist. ! begin ! Open (Dir, Dir_Name); ! exception ! when Directory_Error => ! Prj.Com.Fail ("cannot open directory """, Dir_Name, """"); ! end; ! -- Process each regular file in the directory ! File_Loop : loop ! Read (Dir, Str, Last); ! exit File_Loop when Last = 0; ! -- Copy the file name and put it in canonical case to match ! -- against the patterns that have themselves already been put ! -- in canonical case. ! Canon (1 .. Last) := Str (1 .. Last); ! Canonical_Case_File_Name (Canon (1 .. Last)); ! if Is_Regular_File ! (Dir_Name & Directory_Separator & Str (1 .. Last)) ! then ! Matched := True; ! Name_Len := Last; ! Name_Buffer (1 .. Name_Len) := Str (1 .. Last); ! File_Name_Id := Name_Find; ! -- First, check if the file name matches at least one of ! -- the excluded expressions; ! for Index in Excluded_Expressions'Range loop ! if ! Match (Canon (1 .. Last), Excluded_Expressions (Index)) ! then ! Matched := Excluded; ! exit; ! end if; ! end loop; ! -- If it does not match any of the excluded expressions, ! -- check if the file name matches at least one of the ! -- regular expressions. ! if Matched = True then ! Matched := False; ! for Index in Regular_Expressions'Range loop ! if ! Match ! (Canon (1 .. Last), Regular_Expressions (Index)) ! then ! Matched := True; ! exit; ! end if; ! end loop; ! end if; ! if Very_Verbose ! or else (Matched = True and then Opt.Verbose_Mode) ! then ! Output.Write_Str (" Checking """); ! Output.Write_Str (Str (1 .. Last)); ! Output.Write_Line (""": "); ! end if; ! -- If the file name matches one of the regular expressions, ! -- parse it to get its unit name. ! if Matched = True then ! declare ! FD : File_Descriptor; ! Success : Boolean; ! Saved_Output : File_Descriptor; ! Saved_Error : File_Descriptor; ! begin ! -- If we don't have the path of the compiler yet, ! -- get it now. The compiler name may have a prefix, ! -- so we get the potentially prefixed name. ! if Gcc_Path = null then ! declare ! Prefix_Gcc : String_Access := ! Program_Name (Gcc); ! begin ! Gcc_Path := ! Locate_Exec_On_Path (Prefix_Gcc.all); ! Free (Prefix_Gcc); ! end; ! if Gcc_Path = null then ! Prj.Com.Fail ("could not locate " & Gcc); ! end if; ! end if; ! -- If we don't have yet the file name of the ! -- temporary file, get it now. ! if Temp_File_Name = null then ! Create_Temp_File (FD, Temp_File_Name); ! if FD = Invalid_FD then ! Prj.Com.Fail ! ("could not create temporary file"); ! end if; ! Close (FD); ! Delete_File (Temp_File_Name.all, Success); ! end if; ! Args (Args'Last) := new String' ! (Dir_Name & ! Directory_Separator & ! Str (1 .. Last)); ! -- Create the temporary file ! FD := Create_Output_Text_File ! (Name => Temp_File_Name.all); ! if FD = Invalid_FD then ! Prj.Com.Fail ! ("could not create temporary file"); ! end if; ! -- Save the standard output and error ! Saved_Output := Dup (Standout); ! Saved_Error := Dup (Standerr); ! -- Set standard output and error to the temporary file ! Dup2 (FD, Standout); ! Dup2 (FD, Standerr); ! -- And spawn the compiler ! Spawn (Gcc_Path.all, Args, Success); ! -- Restore the standard output and error ! Dup2 (Saved_Output, Standout); ! Dup2 (Saved_Error, Standerr); ! -- Close the temporary file ! Close (FD); ! -- And close the saved standard output and error to ! -- avoid too many file descriptors. ! Close (Saved_Output); ! Close (Saved_Error); ! -- Now that standard output is restored, check if ! -- the compiler ran correctly. ! -- Read the lines of the temporary file: ! -- they should contain the kind and name of the unit. ! declare ! File : Text_File; ! Text_Line : String (1 .. 1_000); ! Text_Last : Natural; ! begin ! Open (File, Temp_File_Name.all); ! if not Is_Valid (File) then ! Prj.Com.Fail ! ("could not read temporary file"); ! end if; ! Save_Last_Pragma_Index := SFN_Pragmas.Last; ! if End_Of_File (File) then ! if Opt.Verbose_Mode then ! if not Success then ! Output.Write_Str (" (process died) "); ! end if; ! end if; ! else ! Line_Loop : while not End_Of_File (File) loop ! Get_Line (File, Text_Line, Text_Last); ! -- Find the first closing parenthesis ! Char_Loop : for J in 1 .. Text_Last loop ! if Text_Line (J) = ')' then ! if J >= 13 and then ! Text_Line (1 .. 4) = "Unit" ! then ! -- Add entry to SFN_Pragmas table ! Name_Len := J - 12; ! Name_Buffer (1 .. Name_Len) := ! Text_Line (6 .. J - 7); ! SFN_Prag := ! (Unit => Name_Find, ! File => File_Name_Id, ! Index => 0, ! Spec => Text_Line (J - 5 .. J) = ! "(spec)"); ! SFN_Pragmas.Increment_Last; ! SFN_Pragmas.Table ! (SFN_Pragmas.Last) := SFN_Prag; ! end if; ! exit Char_Loop; ! end if; ! end loop Char_Loop; ! end loop Line_Loop; ! end if; ! if Save_Last_Pragma_Index = SFN_Pragmas.Last then ! if Opt.Verbose_Mode then ! Output.Write_Line (" not a unit"); ! end if; ! else ! if SFN_Pragmas.Last > ! Save_Last_Pragma_Index + 1 ! then ! for Index in Save_Last_Pragma_Index + 1 .. ! SFN_Pragmas.Last ! loop ! SFN_Pragmas.Table (Index).Index := ! Int (Index - Save_Last_Pragma_Index); ! end loop; ! end if; ! for Index in Save_Last_Pragma_Index + 1 .. ! SFN_Pragmas.Last ! loop ! SFN_Prag := SFN_Pragmas.Table (Index); ! if Opt.Verbose_Mode then ! if SFN_Prag.Spec then ! Output.Write_Str (" spec of "); ! else ! Output.Write_Str (" body of "); ! end if; ! Output.Write_Line ! (Get_Name_String (SFN_Prag.Unit)); ! end if; ! if Project_File then ! -- Add the corresponding attribute in the ! -- Naming package of the naming project. ! declare ! Decl_Item : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => ! N_Declarative_Item, ! In_Tree => Tree); ! Attribute : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => ! N_Attribute_Declaration, ! In_Tree => Tree); ! Expression : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Expression, ! And_Expr_Kind => Single, ! In_Tree => Tree); ! Term : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Term, ! And_Expr_Kind => Single, ! In_Tree => Tree); ! Value : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Literal_String, ! And_Expr_Kind => Single, ! In_Tree => Tree); ! begin ! Set_Next_Declarative_Item ! (Decl_Item, ! To => First_Declarative_Item_Of ! (Naming_Package, Tree), ! In_Tree => Tree); ! Set_First_Declarative_Item_Of ! (Naming_Package, ! To => Decl_Item, ! In_Tree => Tree); ! Set_Current_Item_Node ! (Decl_Item, ! To => Attribute, ! In_Tree => Tree); ! -- Is it a spec or a body? ! if SFN_Prag.Spec then ! Set_Name_Of ! (Attribute, Tree, ! To => Name_Spec); ! else ! Set_Name_Of ! (Attribute, Tree, ! To => Name_Body); ! end if; ! -- Get the name of the unit ! Get_Name_String (SFN_Prag.Unit); ! To_Lower (Name_Buffer (1 .. Name_Len)); ! Set_Associative_Array_Index_Of ! (Attribute, Tree, To => Name_Find); ! Set_Expression_Of ! (Attribute, Tree, To => Expression); ! Set_First_Term ! (Expression, Tree, To => Term); ! Set_Current_Term ! (Term, Tree, To => Value); ! -- And set the name of the file ! Set_String_Value_Of ! (Value, Tree, To => File_Name_Id); ! Set_Source_Index_Of ! (Value, Tree, To => SFN_Prag.Index); ! end; ! end if; ! end loop; ! if Project_File then ! -- Add source file name to source list ! -- file. ! Last := Last + 1; ! Str (Last) := ASCII.LF; ! if Write (Source_List_FD, ! Str (1)'Address, ! Last) /= Last ! then ! Prj.Com.Fail ("disk full"); ! end if; ! end if; ! end if; ! Close (File); ! Delete_File (Temp_File_Name.all, Success); ! end; ! end; ! -- File name matches none of the regular expressions ! else ! -- If file is not excluded, see if this is foreign source ! if Matched /= Excluded then ! for Index in Foreign_Expressions'Range loop ! if Match (Canon (1 .. Last), ! Foreign_Expressions (Index)) ! then ! Matched := True; ! exit; ! end if; ! end loop; ! end if; ! if Very_Verbose then ! case Matched is ! when False => ! Output.Write_Line ("no match"); ! when Excluded => ! Output.Write_Line ("excluded"); ! when True => ! Output.Write_Line ("foreign source"); ! end case; ! end if; ! if Project_File and Matched = True then ! -- Add source file name to source list file ! Last := Last + 1; ! Str (Last) := ASCII.LF; ! if Write (Source_List_FD, ! Str (1)'Address, ! Last) /= Last ! then ! Prj.Com.Fail ("disk full"); ! end if; ! end if; ! end if; end if; - end loop File_Loop; ! Close (Dir); ! end if; ! ! -- If Recursively is True, call itself for each subdirectory. ! -- We do that, even when this directory has already been processed, ! -- because all of its subdirectories may not have been processed. ! ! if Recursively then ! Open (Dir, Dir_Name); ! ! loop ! Read (Dir, Str, Last); ! exit when Last = 0; ! -- Do not call itself for "." or ".." ! if Is_Directory ! (Dir_Name & Directory_Separator & Str (1 .. Last)) ! and then Str (1 .. Last) /= "." ! and then Str (1 .. Last) /= ".." ! then ! Process_Directory ! (Dir_Name & Directory_Separator & Str (1 .. Last), ! Recursively => True); end if; - end loop; ! Close (Dir); ! end if; ! end Process_Directory; ! -- Start of processing for Make begin -- Do some needed initializations Csets.Initialize; --- 190,777 ---- Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd)); end Dup2; ! -------------- ! -- Finalize -- ! -------------- ! procedure Finalize is ! Discard : Boolean; ! pragma Warnings (Off, Discard); ! Current_Source_Dir : Project_Node_Id := Empty_Node; ! begin ! if Project_File then ! -- If there were no already existing project file, or if the parsing ! -- was unsuccessful, create an empty project node with the correct ! -- name and its project declaration node. ! if No (Project_Node) then ! Project_Node := ! Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); ! Set_Name_Of (Project_Node, Tree, To => Output_Name_Id); ! Set_Project_Declaration_Of ! (Project_Node, Tree, ! To => Default_Project_Node ! (Of_Kind => N_Project_Declaration, In_Tree => Tree)); ! end if; ! end if; ! -- Delete the file if it already exists ! Delete_File ! (Path_Name (Directory_Last + 1 .. Path_Last), ! Success => Discard); ! -- Create a new one ! if Opt.Verbose_Mode then ! Output.Write_Str ("Creating new file """); ! Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last)); ! Output.Write_Line (""""); ! end if; ! Output_FD := Create_New_File ! (Path_Name (Directory_Last + 1 .. Path_Last), ! Fmode => Text); ! -- Fails if project file cannot be created ! if Output_FD = Invalid_FD then ! Prj.Com.Fail ! ("cannot create new """, Path_Name (1 .. Path_Last), """"); ! end if; ! if Project_File then ! -- Delete the source list file, if it already exists ! declare ! Discard : Boolean; ! pragma Warnings (Off, Discard); ! begin ! Delete_File ! (Source_List_Path (1 .. Source_List_Last), ! Success => Discard); ! end; ! -- And create a new source list file. Fail if file cannot be created. ! Source_List_FD := Create_New_File ! (Name => Source_List_Path (1 .. Source_List_Last), ! Fmode => Text); ! if Source_List_FD = Invalid_FD then ! Prj.Com.Fail ! ("cannot create file """, ! Source_List_Path (1 .. Source_List_Last), ! """"); ! end if; ! if Opt.Verbose_Mode then ! Output.Write_Str ("Naming project file name is """); ! Output.Write_Str ! (Project_Naming_File_Name (1 .. Project_Naming_Last)); ! Output.Write_Line (""""); ! end if; ! -- Create the naming project node ! Project_Naming_Node := ! Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); ! Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id); ! Project_Naming_Decl := ! Default_Project_Node ! (Of_Kind => N_Project_Declaration, In_Tree => Tree); ! Set_Project_Declaration_Of ! (Project_Naming_Node, Tree, Project_Naming_Decl); ! Naming_Package := ! Default_Project_Node ! (Of_Kind => N_Package_Declaration, In_Tree => Tree); ! Set_Name_Of (Naming_Package, Tree, To => Name_Naming); ! -- Add an attribute declaration for Source_Files as an empty list (to ! -- indicate there are no sources in the naming project) and a package ! -- Naming (that will be filled later). ! declare ! Decl_Item : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Declarative_Item, In_Tree => Tree); ! Attribute : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Attribute_Declaration, ! In_Tree => Tree, ! And_Expr_Kind => List); ! Expression : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Expression, ! In_Tree => Tree, ! And_Expr_Kind => List); ! Term : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Term, ! In_Tree => Tree, ! And_Expr_Kind => List); ! Empty_List : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Literal_String_List, ! In_Tree => Tree); ! begin ! Set_First_Declarative_Item_Of ! (Project_Naming_Decl, Tree, To => Decl_Item); ! Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package); ! Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); ! Set_Name_Of (Attribute, Tree, To => Name_Source_Files); ! Set_Expression_Of (Attribute, Tree, To => Expression); ! Set_First_Term (Expression, Tree, To => Term); ! Set_Current_Term (Term, Tree, To => Empty_List); ! end; ! -- Add a with clause on the naming project in the main project, if ! -- there is not already one. ! declare ! With_Clause : Project_Node_Id := ! First_With_Clause_Of (Project_Node, Tree); ! begin ! while Present (With_Clause) loop ! exit when ! Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id; ! With_Clause := Next_With_Clause_Of (With_Clause, Tree); ! end loop; ! if No (With_Clause) then ! With_Clause := Default_Project_Node ! (Of_Kind => N_With_Clause, In_Tree => Tree); ! Set_Next_With_Clause_Of ! (With_Clause, Tree, ! To => First_With_Clause_Of (Project_Node, Tree)); ! Set_First_With_Clause_Of ! (Project_Node, Tree, To => With_Clause); ! Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id); ! -- We set the project node to something different than ! -- Empty_Node, so that Prj.PP does not generate a limited ! -- with clause. ! Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node); ! Name_Len := Project_Naming_Last; ! Name_Buffer (1 .. Name_Len) := ! Project_Naming_File_Name (1 .. Project_Naming_Last); ! Set_String_Value_Of (With_Clause, Tree, To => Name_Find); ! end if; ! end; ! Project_Declaration := Project_Declaration_Of (Project_Node, Tree); ! -- Add a package Naming in the main project, that is a renaming of ! -- package Naming in the naming project. ! declare ! Decl_Item : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Declarative_Item, ! In_Tree => Tree); ! Naming : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Package_Declaration, ! In_Tree => Tree); ! begin ! Set_Next_Declarative_Item ! (Decl_Item, Tree, ! To => First_Declarative_Item_Of (Project_Declaration, Tree)); ! Set_First_Declarative_Item_Of ! (Project_Declaration, Tree, To => Decl_Item); ! Set_Current_Item_Node (Decl_Item, Tree, To => Naming); ! Set_Name_Of (Naming, Tree, To => Name_Naming); ! Set_Project_Of_Renamed_Package_Of ! (Naming, Tree, To => Project_Naming_Node); ! -- Attach the comments, if any, that were saved for package ! -- Naming. ! Tree.Project_Nodes.Table (Naming).Comments := ! Naming_Package_Comments; ! end; ! -- Add an attribute declaration for Source_Dirs, initialized as an ! -- empty list. ! declare ! Decl_Item : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Declarative_Item, ! In_Tree => Tree); ! Attribute : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Attribute_Declaration, ! In_Tree => Tree, ! And_Expr_Kind => List); ! Expression : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Expression, ! In_Tree => Tree, ! And_Expr_Kind => List); ! Term : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Term, In_Tree => Tree, ! And_Expr_Kind => List); ! begin ! Set_Next_Declarative_Item ! (Decl_Item, Tree, ! To => First_Declarative_Item_Of (Project_Declaration, Tree)); ! Set_First_Declarative_Item_Of ! (Project_Declaration, Tree, To => Decl_Item); ! Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); ! Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs); ! Set_Expression_Of (Attribute, Tree, To => Expression); ! Set_First_Term (Expression, Tree, To => Term); ! Source_Dirs_List := ! Default_Project_Node ! (Of_Kind => N_Literal_String_List, ! In_Tree => Tree, ! And_Expr_Kind => List); ! Set_Current_Term (Term, Tree, To => Source_Dirs_List); ! -- Attach the comments, if any, that were saved for attribute ! -- Source_Dirs. ! Tree.Project_Nodes.Table (Attribute).Comments := ! Source_Dirs_Comments; ! end; ! -- Put the source directories in attribute Source_Dirs ! for Source_Dir_Index in 1 .. Source_Directories.Last loop ! declare ! Expression : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Expression, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! Term : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Term, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! Value : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Literal_String, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! begin ! if No (Current_Source_Dir) then ! Set_First_Expression_In_List ! (Source_Dirs_List, Tree, To => Expression); ! else ! Set_Next_Expression_In_List ! (Current_Source_Dir, Tree, To => Expression); ! end if; ! Current_Source_Dir := Expression; ! Set_First_Term (Expression, Tree, To => Term); ! Set_Current_Term (Term, Tree, To => Value); ! Name_Len := 0; ! Add_Str_To_Name_Buffer ! (Source_Directories.Table (Source_Dir_Index).all); ! Set_String_Value_Of (Value, Tree, To => Name_Find); ! end; ! end loop; ! -- Add an attribute declaration for Source_Files or Source_List_File ! -- with the source list file name that will be created. ! declare ! Decl_Item : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Declarative_Item, ! In_Tree => Tree); ! Attribute : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Attribute_Declaration, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! Expression : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Expression, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! Term : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Term, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! Value : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Literal_String, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! begin ! Set_Next_Declarative_Item ! (Decl_Item, Tree, ! To => First_Declarative_Item_Of (Project_Declaration, Tree)); ! Set_First_Declarative_Item_Of ! (Project_Declaration, Tree, To => Decl_Item); ! Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); ! Set_Name_Of (Attribute, Tree, To => Name_Source_List_File); ! Set_Expression_Of (Attribute, Tree, To => Expression); ! Set_First_Term (Expression, Tree, To => Term); ! Set_Current_Term (Term, Tree, To => Value); ! Name_Len := Source_List_Last; ! Name_Buffer (1 .. Name_Len) := ! Source_List_Path (1 .. Source_List_Last); ! Set_String_Value_Of (Value, Tree, To => Name_Find); ! -- If there was no comments for attribute Source_List_File, put ! -- those for Source_Files, if they exist. ! if Present (Source_List_File_Comments) then ! Tree.Project_Nodes.Table (Attribute).Comments := ! Source_List_File_Comments; ! else ! Tree.Project_Nodes.Table (Attribute).Comments := ! Source_Files_Comments; ! end if; ! end; ! -- Put the sources in the source list files and in the naming ! -- project. ! for Source_Index in 1 .. Sources.Last loop ! -- Add the corresponding attribute in the ! -- Naming package of the naming project. ! declare ! Current_Source : constant Source := ! Sources.Table (Source_Index); ! Decl_Item : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => ! N_Declarative_Item, ! In_Tree => Tree); ! Attribute : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => ! N_Attribute_Declaration, ! In_Tree => Tree); ! Expression : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Expression, ! And_Expr_Kind => Single, ! In_Tree => Tree); ! Term : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Term, ! And_Expr_Kind => Single, ! In_Tree => Tree); ! Value : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Literal_String, ! And_Expr_Kind => Single, ! In_Tree => Tree); ! begin ! -- Add source file name to the source list file ! Get_Name_String (Current_Source.File_Name); ! Add_Char_To_Name_Buffer (ASCII.LF); ! if Write (Source_List_FD, ! Name_Buffer (1)'Address, ! Name_Len) /= Name_Len ! then ! Prj.Com.Fail ("disk full"); ! end if; ! -- For an Ada source, add entry in package Naming ! if Current_Source.Unit_Name /= No_Name then ! Set_Next_Declarative_Item ! (Decl_Item, ! To => First_Declarative_Item_Of ! (Naming_Package, Tree), ! In_Tree => Tree); ! Set_First_Declarative_Item_Of ! (Naming_Package, ! To => Decl_Item, ! In_Tree => Tree); ! Set_Current_Item_Node ! (Decl_Item, ! To => Attribute, ! In_Tree => Tree); ! -- Is it a spec or a body? ! if Current_Source.Spec then ! Set_Name_Of ! (Attribute, Tree, ! To => Name_Spec); ! else ! Set_Name_Of ! (Attribute, Tree, ! To => Name_Body); ! end if; ! -- Get the name of the unit ! Get_Name_String (Current_Source.Unit_Name); ! To_Lower (Name_Buffer (1 .. Name_Len)); ! Set_Associative_Array_Index_Of ! (Attribute, Tree, To => Name_Find); ! Set_Expression_Of ! (Attribute, Tree, To => Expression); ! Set_First_Term ! (Expression, Tree, To => Term); ! Set_Current_Term ! (Term, Tree, To => Value); ! -- And set the name of the file ! Set_String_Value_Of ! (Value, Tree, To => Current_Source.File_Name); ! Set_Source_Index_Of ! (Value, Tree, To => Current_Source.Index); ! end if; ! end; ! end loop; ! -- Close the source list file ! Close (Source_List_FD); ! -- Output the project file ! Prj.PP.Pretty_Print ! (Project_Node, Tree, ! W_Char => Write_A_Char'Access, ! W_Eol => Write_Eol'Access, ! W_Str => Write_A_String'Access, ! Backward_Compatibility => False); ! Close (Output_FD); ! -- Delete the naming project file if it already exists ! Delete_File ! (Project_Naming_File_Name (1 .. Project_Naming_Last), ! Success => Discard); ! -- Create a new one ! if Opt.Verbose_Mode then ! Output.Write_Str ("Creating new naming project file """); ! Output.Write_Str (Project_Naming_File_Name ! (1 .. Project_Naming_Last)); ! Output.Write_Line (""""); ! end if; ! Output_FD := Create_New_File ! (Project_Naming_File_Name (1 .. Project_Naming_Last), ! Fmode => Text); ! -- Fails if naming project file cannot be created ! if Output_FD = Invalid_FD then ! Prj.Com.Fail ! ("cannot create new """, ! Project_Naming_File_Name (1 .. Project_Naming_Last), ! """"); ! end if; ! -- Output the naming project file ! Prj.PP.Pretty_Print ! (Project_Naming_Node, Tree, ! W_Char => Write_A_Char'Access, ! W_Eol => Write_Eol'Access, ! W_Str => Write_A_String'Access, ! Backward_Compatibility => False); ! Close (Output_FD); ! else ! -- For each Ada source, write a pragma Source_File_Name to the ! -- configuration pragmas file. ! for Index in 1 .. Sources.Last loop ! if Sources.Table (Index).Unit_Name /= No_Name then ! Write_A_String ("pragma Source_File_Name"); ! Write_Eol; ! Write_A_String (" ("); ! Write_A_String ! (Get_Name_String (Sources.Table (Index).Unit_Name)); ! Write_A_String (","); ! Write_Eol; ! if Sources.Table (Index).Spec then ! Write_A_String (" Spec_File_Name => """); ! else ! Write_A_String (" Body_File_Name => """); end if; ! Write_A_String ! (Get_Name_String (Sources.Table (Index).File_Name)); ! Write_A_String (""""); ! if Sources.Table (Index).Index /= 0 then ! Write_A_String (", Index =>"); ! Write_A_String (Sources.Table (Index).Index'Img); end if; ! Write_A_String (");"); ! Write_Eol; ! end if; ! end loop; ! Close (Output_FD); ! end if; ! end Finalize; ! ! ---------------- ! -- Initialize -- ! ---------------- + procedure Initialize + (File_Path : String; + Project_File : Boolean; + Preproc_Switches : Argument_List; + Very_Verbose : Boolean) + is begin + Makr.Very_Verbose := Initialize.Very_Verbose; + Makr.Project_File := Initialize.Project_File; + -- Do some needed initializations Csets.Initialize; *************** package body Prj.Makr is *** 680,691 **** Prj.Initialize (No_Project_Tree); Prj.Tree.Initialize (Tree); ! SFN_Pragmas.Set_Last (0); ! ! Processed_Directories.Set_Last (0); -- Initialize the compiler switches Args (1) := new String'("-c"); Args (2) := new String'("-gnats"); Args (3) := new String'("-gnatu"); --- 780,791 ---- Prj.Initialize (No_Project_Tree); Prj.Tree.Initialize (Tree); ! Sources.Set_Last (0); ! Source_Directories.Set_Last (0); -- Initialize the compiler switches + Args := new Argument_List (1 .. Preproc_Switches'Length + 6); Args (1) := new String'("-c"); Args (2) := new String'("-gnats"); Args (3) := new String'("-gnatu"); *************** package body Prj.Makr is *** 695,700 **** --- 795,804 ---- -- Get the path and file names + Path_Name := new + String (1 .. File_Path'Length + Project_File_Extension'Length); + Path_Last := File_Path'Length; + if File_Names_Case_Sensitive then Path_Name (1 .. Path_Last) := File_Path; else *************** package body Prj.Makr is *** 722,729 **** Path_Last := Path_Name'Last; end if; ! Output_Name (1 .. Path_Last) := To_Lower (Path_Name (1 .. Path_Last)); ! Output_Name_Last := Path_Last - Project_File_Extension'Length; -- If there is already a project file with the specified name, parse -- it to get the components that are not automatically generated. --- 826,833 ---- Path_Last := Path_Name'Last; end if; ! Output_Name := new String'(To_Lower (Path_Name (1 .. Path_Last))); ! Output_Name_Last := Output_Name'Last - 4; -- If there is already a project file with the specified name, parse -- it to get the components that are not automatically generated. *************** package body Prj.Makr is *** 731,744 **** if Is_Regular_File (Output_Name (1 .. Path_Last)) then if Opt.Verbose_Mode then Output.Write_Str ("Parsing already existing project file """); ! Output.Write_Str (Output_Name (1 .. Output_Name_Last)); Output.Write_Line (""""); end if; Part.Parse (In_Tree => Tree, Project => Project_Node, ! Project_File_Name => Output_Name (1 .. Output_Name_Last), Always_Errout_Finalize => False, Store_Comments => True, Current_Directory => Get_Current_Dir, --- 835,848 ---- if Is_Regular_File (Output_Name (1 .. Path_Last)) then if Opt.Verbose_Mode then Output.Write_Str ("Parsing already existing project file """); ! Output.Write_Str (Output_Name.all); Output.Write_Line (""""); end if; Part.Parse (In_Tree => Tree, Project => Project_Node, ! Project_File_Name => Output_Name.all, Always_Errout_Finalize => False, Store_Comments => True, Current_Directory => Get_Current_Dir, *************** package body Prj.Makr is *** 746,752 **** -- Fail if parsing was not successful ! if Project_Node = Empty_Node then Fail ("parsing of existing project file failed"); else --- 850,856 ---- -- Fail if parsing was not successful ! if No (Project_Node) then Fail ("parsing of existing project file failed"); else *************** package body Prj.Makr is *** 762,772 **** Previous : Project_Node_Id := Empty_Node; begin ! while With_Clause /= Empty_Node loop if Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id then ! if Previous = Empty_Node then Set_First_With_Clause_Of (Project_Node, Tree, To => Next_With_Clause_Of (With_Clause, Tree)); --- 866,876 ---- Previous : Project_Node_Id := Empty_Node; begin ! while Present (With_Clause) loop if Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id then ! if No (Previous) then Set_First_With_Clause_Of (Project_Node, Tree, To => Next_With_Clause_Of (With_Clause, Tree)); *************** package body Prj.Makr is *** 803,809 **** Comments : Project_Node_Id; begin ! while Declaration /= Empty_Node loop Current_Node := Current_Item_Node (Declaration, Tree); Kind_Of_Node := Kind_Of (Current_Node, Tree); --- 907,913 ---- Comments : Project_Node_Id; begin ! while Present (Declaration) loop Current_Node := Current_Item_Node (Declaration, Tree); Kind_Of_Node := Kind_Of (Current_Node, Tree); *************** package body Prj.Makr is *** 834,840 **** Naming_Package_Comments := Comments; end if; ! if Previous = Empty_Node then Set_First_Declarative_Item_Of (Project_Declaration_Of (Project_Node, Tree), Tree, --- 938,944 ---- Naming_Package_Comments := Comments; end if; ! if No (Previous) then Set_First_Declarative_Item_Of (Project_Declaration_Of (Project_Node, Tree), Tree, *************** package body Prj.Makr is *** 874,885 **** -- Create the project naming file name Project_Naming_Last := Output_Name_Last; ! Project_Naming_File_Name (1 .. Project_Naming_Last) := ! Output_Name (1 .. Project_Naming_Last); ! Project_Naming_File_Name ! (Project_Naming_Last + 1 .. ! Project_Naming_Last + Naming_File_Suffix'Length) := ! Naming_File_Suffix; Project_Naming_Last := Project_Naming_Last + Naming_File_Suffix'Length; --- 978,987 ---- -- Create the project naming file name Project_Naming_Last := Output_Name_Last; ! Project_Naming_File_Name := ! new String'(Output_Name (1 .. Output_Name_Last) & ! Naming_File_Suffix & ! Project_File_Extension); Project_Naming_Last := Project_Naming_Last + Naming_File_Suffix'Length; *************** package body Prj.Makr is *** 890,912 **** Project_Naming_File_Name (1 .. Name_Len); Project_Naming_Id := Name_Find; - Project_Naming_File_Name - (Project_Naming_Last + 1 .. - Project_Naming_Last + Project_File_Extension'Length) := - Project_File_Extension; Project_Naming_Last := Project_Naming_Last + Project_File_Extension'Length; -- Create the source list file name Source_List_Last := Output_Name_Last; ! Source_List_Path (1 .. Source_List_Last) := ! Output_Name (1 .. Source_List_Last); ! Source_List_Path ! (Source_List_Last + 1 .. ! Source_List_Last + Source_List_File_Suffix'Length) := ! Source_List_File_Suffix; ! Source_List_Last := Source_List_Last + Source_List_File_Suffix'Length; -- Add the project file extension to the project name --- 992,1008 ---- Project_Naming_File_Name (1 .. Name_Len); Project_Naming_Id := Name_Find; Project_Naming_Last := Project_Naming_Last + Project_File_Extension'Length; -- Create the source list file name Source_List_Last := Output_Name_Last; ! Source_List_Path := ! new String'(Output_Name (1 .. Output_Name_Last) & ! Source_List_File_Suffix); ! Source_List_Last := ! Output_Name_Last + Source_List_File_Suffix'Length; -- Add the project file extension to the project name *************** package body Prj.Makr is *** 915,920 **** --- 1011,1017 ---- Output_Name_Last + Project_File_Extension'Length) := Project_File_Extension; Output_Name_Last := Output_Name_Last + Project_File_Extension'Length; + end if; -- Change the current directory to the directory of the project file, *************** package body Prj.Makr is *** 931,1474 **** """"); end; end if; ! if Project_File then ! ! -- Delete the source list file, if it already exists ! ! declare ! Discard : Boolean; ! pragma Warnings (Off, Discard); ! begin ! Delete_File ! (Source_List_Path (1 .. Source_List_Last), ! Success => Discard); ! end; ! -- And create a new source list file. ! -- Fail if file cannot be created. ! Source_List_FD := Create_New_File ! (Name => Source_List_Path (1 .. Source_List_Last), ! Fmode => Text); ! if Source_List_FD = Invalid_FD then ! Prj.Com.Fail ! ("cannot create file """, ! Source_List_Path (1 .. Source_List_Last), ! """"); ! end if; ! end if; ! -- Compile the regular expressions. Fails immediately if any of ! -- the specified strings is in error. ! for Index in Excluded_Expressions'Range loop ! if Very_Verbose then ! Output.Write_Str ("Excluded pattern: """); ! Output.Write_Str (Excluded_Patterns (Index).all); ! Output.Write_Line (""""); ! end if; ! begin ! Excluded_Expressions (Index) := ! Compile (Pattern => Excluded_Patterns (Index).all, Glob => True); ! exception ! when Error_In_Regexp => ! Prj.Com.Fail ! ("invalid regular expression """, ! Excluded_Patterns (Index).all, ! """"); ! end; ! end loop; ! for Index in Foreign_Expressions'Range loop ! if Very_Verbose then ! Output.Write_Str ("Foreign pattern: """); ! Output.Write_Str (Foreign_Patterns (Index).all); ! Output.Write_Line (""""); ! end if; ! begin ! Foreign_Expressions (Index) := ! Compile (Pattern => Foreign_Patterns (Index).all, Glob => True); ! exception ! when Error_In_Regexp => ! Prj.Com.Fail ! ("invalid regular expression """, ! Foreign_Patterns (Index).all, ! """"); ! end; ! end loop; ! for Index in Regular_Expressions'Range loop ! if Very_Verbose then ! Output.Write_Str ("Pattern: """); ! Output.Write_Str (Name_Patterns (Index).all); ! Output.Write_Line (""""); ! end if; ! begin ! Regular_Expressions (Index) := ! Compile (Pattern => Name_Patterns (Index).all, Glob => True); ! exception ! when Error_In_Regexp => ! Prj.Com.Fail ! ("invalid regular expression """, ! Name_Patterns (Index).all, ! """"); ! end; ! end loop; ! if Project_File then ! if Opt.Verbose_Mode then ! Output.Write_Str ("Naming project file name is """); ! Output.Write_Str ! (Project_Naming_File_Name (1 .. Project_Naming_Last)); ! Output.Write_Line (""""); ! end if; ! -- If there were no already existing project file, or if the parsing ! -- was unsuccessful, create an empty project node with the correct ! -- name and its project declaration node. ! if Project_Node = Empty_Node then ! Project_Node := ! Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); ! Set_Name_Of (Project_Node, Tree, To => Output_Name_Id); ! Set_Project_Declaration_Of ! (Project_Node, Tree, ! To => Default_Project_Node ! (Of_Kind => N_Project_Declaration, In_Tree => Tree)); ! end if; ! -- Create the naming project node, and add an attribute declaration ! -- for Source_Files as an empty list, to indicate there are no ! -- sources in the naming project. ! Project_Naming_Node := ! Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); ! Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id); ! Project_Naming_Decl := ! Default_Project_Node ! (Of_Kind => N_Project_Declaration, In_Tree => Tree); ! Set_Project_Declaration_Of ! (Project_Naming_Node, Tree, Project_Naming_Decl); ! Naming_Package := ! Default_Project_Node ! (Of_Kind => N_Package_Declaration, In_Tree => Tree); ! Set_Name_Of (Naming_Package, Tree, To => Name_Naming); ! declare ! Decl_Item : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Declarative_Item, In_Tree => Tree); ! Attribute : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Attribute_Declaration, ! In_Tree => Tree, ! And_Expr_Kind => List); ! Expression : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Expression, ! In_Tree => Tree, ! And_Expr_Kind => List); ! Term : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Term, ! In_Tree => Tree, ! And_Expr_Kind => List); ! Empty_List : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Literal_String_List, ! In_Tree => Tree); ! begin ! Set_First_Declarative_Item_Of ! (Project_Naming_Decl, Tree, To => Decl_Item); ! Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package); ! Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); ! Set_Name_Of (Attribute, Tree, To => Name_Source_Files); ! Set_Expression_Of (Attribute, Tree, To => Expression); ! Set_First_Term (Expression, Tree, To => Term); ! Set_Current_Term (Term, Tree, To => Empty_List); ! end; ! -- Add a with clause on the naming project in the main project, if ! -- there is not already one. ! declare ! With_Clause : Project_Node_Id := ! First_With_Clause_Of (Project_Node, Tree); ! begin ! while With_Clause /= Empty_Node loop ! exit when ! Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id; ! With_Clause := Next_With_Clause_Of (With_Clause, Tree); ! end loop; ! if With_Clause = Empty_Node then ! With_Clause := Default_Project_Node ! (Of_Kind => N_With_Clause, In_Tree => Tree); ! Set_Next_With_Clause_Of ! (With_Clause, Tree, ! To => First_With_Clause_Of (Project_Node, Tree)); ! Set_First_With_Clause_Of ! (Project_Node, Tree, To => With_Clause); ! Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id); ! -- We set the project node to something different than ! -- Empty_Node, so that Prj.PP does not generate a limited ! -- with clause. ! Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node); ! Name_Len := Project_Naming_Last; ! Name_Buffer (1 .. Name_Len) := ! Project_Naming_File_Name (1 .. Project_Naming_Last); ! Set_String_Value_Of (With_Clause, Tree, To => Name_Find); ! end if; ! end; ! Project_Declaration := Project_Declaration_Of (Project_Node, Tree); ! -- Add a renaming declaration for package Naming in the main project ! declare ! Decl_Item : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Declarative_Item, ! In_Tree => Tree); ! Naming : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Package_Declaration, ! In_Tree => Tree); ! begin ! Set_Next_Declarative_Item ! (Decl_Item, Tree, ! To => First_Declarative_Item_Of (Project_Declaration, Tree)); ! Set_First_Declarative_Item_Of ! (Project_Declaration, Tree, To => Decl_Item); ! Set_Current_Item_Node (Decl_Item, Tree, To => Naming); ! Set_Name_Of (Naming, Tree, To => Name_Naming); ! Set_Project_Of_Renamed_Package_Of ! (Naming, Tree, To => Project_Naming_Node); ! -- Attach the comments, if any, that were saved for package ! -- Naming. ! Tree.Project_Nodes.Table (Naming).Comments := ! Naming_Package_Comments; ! end; ! -- Add an attribute declaration for Source_Dirs, initialized as an ! -- empty list. Directories will be added as they are read from the ! -- directory list file. ! declare ! Decl_Item : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Declarative_Item, ! In_Tree => Tree); ! Attribute : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Attribute_Declaration, ! In_Tree => Tree, ! And_Expr_Kind => List); ! Expression : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Expression, ! In_Tree => Tree, ! And_Expr_Kind => List); ! Term : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Term, In_Tree => Tree, ! And_Expr_Kind => List); ! begin ! Set_Next_Declarative_Item ! (Decl_Item, Tree, ! To => First_Declarative_Item_Of (Project_Declaration, Tree)); ! Set_First_Declarative_Item_Of ! (Project_Declaration, Tree, To => Decl_Item); ! Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); ! Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs); ! Set_Expression_Of (Attribute, Tree, To => Expression); ! Set_First_Term (Expression, Tree, To => Term); ! Source_Dirs_List := ! Default_Project_Node ! (Of_Kind => N_Literal_String_List, ! In_Tree => Tree, ! And_Expr_Kind => List); ! Set_Current_Term (Term, Tree, To => Source_Dirs_List); ! -- Attach the comments, if any, that were saved for attribute ! -- Source_Dirs. ! Tree.Project_Nodes.Table (Attribute).Comments := ! Source_Dirs_Comments; ! end; ! -- Add an attribute declaration for Source_List_File with the ! -- source list file name that will be created. ! declare ! Decl_Item : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Declarative_Item, ! In_Tree => Tree); ! Attribute : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Attribute_Declaration, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! Expression : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Expression, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! Term : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Term, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! Value : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Literal_String, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! begin ! Set_Next_Declarative_Item ! (Decl_Item, Tree, ! To => First_Declarative_Item_Of (Project_Declaration, Tree)); ! Set_First_Declarative_Item_Of ! (Project_Declaration, Tree, To => Decl_Item); ! Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); ! Set_Name_Of (Attribute, Tree, To => Name_Source_List_File); ! Set_Expression_Of (Attribute, Tree, To => Expression); ! Set_First_Term (Expression, Tree, To => Term); ! Set_Current_Term (Term, Tree, To => Value); ! Name_Len := Source_List_Last; ! Name_Buffer (1 .. Name_Len) := ! Source_List_Path (1 .. Source_List_Last); ! Set_String_Value_Of (Value, Tree, To => Name_Find); ! -- If there was no comments for attribute Source_List_File, put ! -- those for Source_Files, if they exist. ! if Source_List_File_Comments /= Empty_Node then ! Tree.Project_Nodes.Table (Attribute).Comments := ! Source_List_File_Comments; ! else ! Tree.Project_Nodes.Table (Attribute).Comments := ! Source_Files_Comments; ! end if; ! end; ! end if; ! -- Process each directory ! for Index in Directories'Range loop ! declare ! Dir_Name : constant String := Directories (Index).all; ! Last : Natural := Dir_Name'Last; ! Recursively : Boolean := False; ! begin ! if Dir_Name'Length >= 4 ! and then (Dir_Name (Last - 2 .. Last) = "/**") ! then ! Last := Last - 3; ! Recursively := True; ! end if; ! if Project_File then ! -- Add the directory in the list for attribute Source_Dirs ! declare ! Expression : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Expression, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! Term : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Term, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! Value : constant Project_Node_Id := ! Default_Project_Node ! (Of_Kind => N_Literal_String, ! In_Tree => Tree, ! And_Expr_Kind => Single); ! begin ! if Current_Source_Dir = Empty_Node then ! Set_First_Expression_In_List ! (Source_Dirs_List, Tree, To => Expression); ! else ! Set_Next_Expression_In_List ! (Current_Source_Dir, Tree, To => Expression); ! end if; ! Current_Source_Dir := Expression; ! Set_First_Term (Expression, Tree, To => Term); ! Set_Current_Term (Term, Tree, To => Value); ! Name_Len := Dir_Name'Length; ! Name_Buffer (1 .. Name_Len) := Dir_Name; ! Set_String_Value_Of (Value, Tree, To => Name_Find); ! end; ! end if; ! Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively); ! end; ! end loop; ! if Project_File then ! Close (Source_List_FD); ! end if; ! declare ! Discard : Boolean; ! pragma Warnings (Off, Discard); ! begin ! -- Delete the file if it already exists ! Delete_File ! (Path_Name (Directory_Last + 1 .. Path_Last), ! Success => Discard); ! -- Create a new one ! if Opt.Verbose_Mode then ! Output.Write_Str ("Creating new file """); ! Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last)); ! Output.Write_Line (""""); ! end if; ! Output_FD := Create_New_File ! (Path_Name (Directory_Last + 1 .. Path_Last), ! Fmode => Text); ! -- Fails if project file cannot be created ! if Output_FD = Invalid_FD then ! Prj.Com.Fail ! ("cannot create new """, Path_Name (1 .. Path_Last), """"); ! end if; ! if Project_File then ! -- Output the project file ! Prj.PP.Pretty_Print ! (Project_Node, Tree, ! W_Char => Write_A_Char'Access, ! W_Eol => Write_Eol'Access, ! W_Str => Write_A_String'Access, ! Backward_Compatibility => False); ! Close (Output_FD); ! -- Delete the naming project file if it already exists ! Delete_File ! (Project_Naming_File_Name (1 .. Project_Naming_Last), ! Success => Discard); ! -- Create a new one ! if Opt.Verbose_Mode then ! Output.Write_Str ("Creating new naming project file """); ! Output.Write_Str (Project_Naming_File_Name ! (1 .. Project_Naming_Last)); ! Output.Write_Line (""""); ! end if; ! Output_FD := Create_New_File ! (Project_Naming_File_Name (1 .. Project_Naming_Last), ! Fmode => Text); ! -- Fails if naming project file cannot be created ! if Output_FD = Invalid_FD then ! Prj.Com.Fail ! ("cannot create new """, ! Project_Naming_File_Name (1 .. Project_Naming_Last), ! """"); ! end if; ! -- Output the naming project file ! Prj.PP.Pretty_Print ! (Project_Naming_Node, Tree, ! W_Char => Write_A_Char'Access, ! W_Eol => Write_Eol'Access, ! W_Str => Write_A_String'Access, ! Backward_Compatibility => False); ! Close (Output_FD); ! else ! -- Write to the output file each entry in the SFN_Pragmas table ! -- as an pragma Source_File_Name. ! for Index in 1 .. SFN_Pragmas.Last loop ! Write_A_String ("pragma Source_File_Name"); ! Write_Eol; ! Write_A_String (" ("); ! Write_A_String ! (Get_Name_String (SFN_Pragmas.Table (Index).Unit)); ! Write_A_String (","); ! Write_Eol; ! if SFN_Pragmas.Table (Index).Spec then ! Write_A_String (" Spec_File_Name => """); ! else ! Write_A_String (" Body_File_Name => """); end if; ! Write_A_String ! (Get_Name_String (SFN_Pragmas.Table (Index).File)); ! ! Write_A_String (""""); ! ! if SFN_Pragmas.Table (Index).Index /= 0 then ! Write_A_String (", Index =>"); ! Write_A_String (SFN_Pragmas.Table (Index).Index'Img); ! end if; ! Write_A_String (");"); ! Write_Eol; ! end loop; ! Close (Output_FD); ! end if; ! end; ! end Make; ---------------- -- Write_Char -- --- 1028,1470 ---- """"); end; end if; + end Initialize; ! ------------- ! -- Process -- ! ------------- ! procedure Process ! (Directories : Argument_List; ! Name_Patterns : Regexp_List; ! Excluded_Patterns : Regexp_List; ! Foreign_Patterns : Regexp_List) ! is ! procedure Process_Directory (Dir_Name : String; Recursively : Boolean); ! -- Look for Ada and foreign sources in a directory, according to the ! -- patterns. When Recursively is True, after looking for sources in ! -- Dir_Name, look also in its subdirectories, if any. ! ----------------------- ! -- Process_Directory -- ! ----------------------- ! procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is ! Matched : Matched_Type := False; ! Str : String (1 .. 2_000); ! Canon : String (1 .. 2_000); ! Last : Natural; ! Dir : Dir_Type; ! Do_Process : Boolean := True; ! Temp_File_Name : String_Access := null; ! Save_Last_Source_Index : Natural := 0; ! File_Name_Id : Name_Id := No_Name; ! Current_Source : Source; ! begin ! -- Avoid processing the same directory more than once ! for Index in 1 .. Processed_Directories.Last loop ! if Processed_Directories.Table (Index).all = Dir_Name then ! Do_Process := False; ! exit; ! end if; ! end loop; ! if Do_Process then ! if Opt.Verbose_Mode then ! Output.Write_Str ("Processing directory """); ! Output.Write_Str (Dir_Name); ! Output.Write_Line (""""); ! end if; ! Processed_Directories. Increment_Last; ! Processed_Directories.Table (Processed_Directories.Last) := ! new String'(Dir_Name); ! -- Get the source file names from the directory. Fails if the ! -- directory does not exist. ! begin ! Open (Dir, Dir_Name); ! exception ! when Directory_Error => ! Prj.Com.Fail ("cannot open directory """, Dir_Name, """"); ! end; ! -- Process each regular file in the directory ! File_Loop : loop ! Read (Dir, Str, Last); ! exit File_Loop when Last = 0; ! -- Copy the file name and put it in canonical case to match ! -- against the patterns that have themselves already been put ! -- in canonical case. ! Canon (1 .. Last) := Str (1 .. Last); ! Canonical_Case_File_Name (Canon (1 .. Last)); ! if Is_Regular_File ! (Dir_Name & Directory_Separator & Str (1 .. Last)) ! then ! Matched := True; ! Name_Len := Last; ! Name_Buffer (1 .. Name_Len) := Str (1 .. Last); ! File_Name_Id := Name_Find; ! -- First, check if the file name matches at least one of ! -- the excluded expressions; ! for Index in Excluded_Patterns'Range loop ! if ! Match (Canon (1 .. Last), Excluded_Patterns (Index)) ! then ! Matched := Excluded; ! exit; ! end if; ! end loop; ! -- If it does not match any of the excluded expressions, ! -- check if the file name matches at least one of the ! -- regular expressions. ! if Matched = True then ! Matched := False; ! for Index in Name_Patterns'Range loop ! if ! Match ! (Canon (1 .. Last), Name_Patterns (Index)) ! then ! Matched := True; ! exit; ! end if; ! end loop; ! end if; ! if Very_Verbose ! or else (Matched = True and then Opt.Verbose_Mode) ! then ! Output.Write_Str (" Checking """); ! Output.Write_Str (Str (1 .. Last)); ! Output.Write_Line (""": "); ! end if; ! -- If the file name matches one of the regular expressions, ! -- parse it to get its unit name. ! if Matched = True then ! declare ! FD : File_Descriptor; ! Success : Boolean; ! Saved_Output : File_Descriptor; ! Saved_Error : File_Descriptor; ! begin ! -- If we don't have the path of the compiler yet, ! -- get it now. The compiler name may have a prefix, ! -- so we get the potentially prefixed name. ! if Gcc_Path = null then ! declare ! Prefix_Gcc : String_Access := ! Program_Name (Gcc, "gnatname"); ! begin ! Gcc_Path := ! Locate_Exec_On_Path (Prefix_Gcc.all); ! Free (Prefix_Gcc); ! end; ! if Gcc_Path = null then ! Prj.Com.Fail ("could not locate " & Gcc); ! end if; ! end if; ! -- If we don't have yet the file name of the ! -- temporary file, get it now. ! if Temp_File_Name = null then ! Create_Temp_File (FD, Temp_File_Name); ! if FD = Invalid_FD then ! Prj.Com.Fail ! ("could not create temporary file"); ! end if; ! Close (FD); ! Delete_File (Temp_File_Name.all, Success); ! end if; ! Args (Args'Last) := new String' ! (Dir_Name & ! Directory_Separator & ! Str (1 .. Last)); ! -- Create the temporary file ! FD := Create_Output_Text_File ! (Name => Temp_File_Name.all); ! if FD = Invalid_FD then ! Prj.Com.Fail ! ("could not create temporary file"); ! end if; ! -- Save the standard output and error ! Saved_Output := Dup (Standout); ! Saved_Error := Dup (Standerr); ! -- Set standard output and error to the temporary file ! Dup2 (FD, Standout); ! Dup2 (FD, Standerr); ! -- And spawn the compiler ! Spawn (Gcc_Path.all, Args.all, Success); ! -- Restore the standard output and error ! Dup2 (Saved_Output, Standout); ! Dup2 (Saved_Error, Standerr); ! -- Close the temporary file ! Close (FD); ! -- And close the saved standard output and error to ! -- avoid too many file descriptors. ! Close (Saved_Output); ! Close (Saved_Error); ! -- Now that standard output is restored, check if ! -- the compiler ran correctly. ! -- Read the lines of the temporary file: ! -- they should contain the kind and name of the unit. ! declare ! File : Text_File; ! Text_Line : String (1 .. 1_000); ! Text_Last : Natural; ! begin ! Open (File, Temp_File_Name.all); ! if not Is_Valid (File) then ! Prj.Com.Fail ! ("could not read temporary file"); ! end if; ! Save_Last_Source_Index := Sources.Last; ! if End_Of_File (File) then ! if Opt.Verbose_Mode then ! if not Success then ! Output.Write_Str (" (process died) "); ! end if; ! end if; ! else ! Line_Loop : while not End_Of_File (File) loop ! Get_Line (File, Text_Line, Text_Last); ! -- Find the first closing parenthesis ! Char_Loop : for J in 1 .. Text_Last loop ! if Text_Line (J) = ')' then ! if J >= 13 and then ! Text_Line (1 .. 4) = "Unit" ! then ! -- Add entry to Sources table ! Name_Len := J - 12; ! Name_Buffer (1 .. Name_Len) := ! Text_Line (6 .. J - 7); ! Current_Source := ! (Unit_Name => Name_Find, ! File_Name => File_Name_Id, ! Index => 0, ! Spec => Text_Line (J - 5 .. J) = ! "(spec)"); ! Sources.Append (Current_Source); ! end if; ! exit Char_Loop; ! end if; ! end loop Char_Loop; ! end loop Line_Loop; ! end if; ! if Save_Last_Source_Index = Sources.Last then ! if Opt.Verbose_Mode then ! Output.Write_Line (" not a unit"); ! end if; ! else ! if Sources.Last > ! Save_Last_Source_Index + 1 ! then ! for Index in Save_Last_Source_Index + 1 .. ! Sources.Last ! loop ! Sources.Table (Index).Index := ! Int (Index - Save_Last_Source_Index); ! end loop; ! end if; ! for Index in Save_Last_Source_Index + 1 .. ! Sources.Last ! loop ! Current_Source := Sources.Table (Index); ! if Opt.Verbose_Mode then ! if Current_Source.Spec then ! Output.Write_Str (" spec of "); ! else ! Output.Write_Str (" body of "); ! end if; ! Output.Write_Line ! (Get_Name_String ! (Current_Source.Unit_Name)); ! end if; ! end loop; ! end if; ! Close (File); ! Delete_File (Temp_File_Name.all, Success); ! end; ! end; ! -- File name matches none of the regular expressions ! else ! -- If file is not excluded, see if this is foreign source ! if Matched /= Excluded then ! for Index in Foreign_Patterns'Range loop ! if Match (Canon (1 .. Last), ! Foreign_Patterns (Index)) ! then ! Matched := True; ! exit; ! end if; ! end loop; ! end if; ! if Very_Verbose then ! case Matched is ! when False => ! Output.Write_Line ("no match"); ! when Excluded => ! Output.Write_Line ("excluded"); ! when True => ! Output.Write_Line ("foreign source"); ! end case; ! end if; ! if Matched = True then ! -- Add source file name without unit name ! Name_Len := 0; ! Add_Str_To_Name_Buffer (Canon (1 .. Last)); ! Sources.Append ! ((File_Name => Name_Find, ! Unit_Name => No_Name, ! Index => 0, ! Spec => False)); ! end if; ! end if; ! end if; ! end loop File_Loop; ! Close (Dir); ! end if; ! -- If Recursively is True, call itself for each subdirectory. ! -- We do that, even when this directory has already been processed, ! -- because all of its subdirectories may not have been processed. ! if Recursively then ! Open (Dir, Dir_Name); ! loop ! Read (Dir, Str, Last); ! exit when Last = 0; ! -- Do not call itself for "." or ".." ! if Is_Directory ! (Dir_Name & Directory_Separator & Str (1 .. Last)) ! and then Str (1 .. Last) /= "." ! and then Str (1 .. Last) /= ".." ! then ! Process_Directory ! (Dir_Name & Directory_Separator & Str (1 .. Last), ! Recursively => True); ! end if; ! end loop; ! Close (Dir); ! end if; ! end Process_Directory; ! -- Start of processing for Process ! begin ! Processed_Directories.Set_Last (0); ! -- Process each directory ! for Index in Directories'Range loop ! declare ! Dir_Name : constant String := Directories (Index).all; ! Last : Natural := Dir_Name'Last; ! Recursively : Boolean := False; ! Found : Boolean; ! Canonical : String (1 .. Dir_Name'Length) := Dir_Name; ! begin ! Canonical_Case_File_Name (Canonical); ! Found := False; ! for J in 1 .. Source_Directories.Last loop ! if Source_Directories.Table (J).all = Canonical then ! Found := True; ! exit; end if; + end loop; ! if not Found then ! Source_Directories.Append (new String'(Canonical)); ! end if; ! if Dir_Name'Length >= 4 ! and then (Dir_Name (Last - 2 .. Last) = "/**") ! then ! Last := Last - 3; ! Recursively := True; ! end if; ! Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively); ! end; ! end loop; ! end Process; ---------------- -- Write_Char -- diff -Nrcpad gcc-4.3.3/gcc/ada/prj-makr.ads gcc-4.4.0/gcc/ada/prj-makr.ads *** gcc-4.3.3/gcc/ada/prj-makr.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/prj-makr.ads Thu Jul 31 07:51:44 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** *** 25,68 **** -- Support for procedure Gnatname ! -- For arbitrary naming schemes, create or update a project file, ! -- or create a configuration pragmas file. package Prj.Makr is ! procedure Make (File_Path : String; Project_File : Boolean; - Directories : Argument_List; - Name_Patterns : Argument_List; - Excluded_Patterns : Argument_List; - Foreign_Patterns : Argument_List; Preproc_Switches : Argument_List; Very_Verbose : Boolean); ! -- Create a project file or a configuration pragmas file -- ! -- Project_File is the path name of the project file. If the project ! -- file already exists parse it and keep all the elements that are not ! -- automatically generated. -- ! -- Directory_List_File is the path name of a text file that ! -- contains on each non empty line the path names of the source ! -- directories for the project file. The source directories ! -- are relative to the directory of the project file. -- ! -- File_Name_Patterns is a GNAT.Regexp string pattern such as ! -- ".*\.ads|.*\.adb" or any other pattern. -- ! -- A project file (without any sources) is automatically generated ! -- with the name _naming. It contains a package Naming with ! -- all the specs and bodies for the project. ! -- A file containing the source file names is automatically ! -- generated and used as the Source_File_List for the project file. ! -- It includes all sources that follow the Foreign_Patterns (except those ! -- that follow Excluded_Patterns). ! -- Preproc_switches is a list of optional preprocessor switches -gnatep= ! -- and -gnateD that are used when invoking the compiler to find the ! -- unit name and kind. end Prj.Makr; --- 25,87 ---- -- Support for procedure Gnatname ! -- For arbitrary naming schemes, create or update a project file, or create a ! -- configuration pragmas file. ! ! with System.Regexp; use System.Regexp; package Prj.Makr is ! procedure Initialize (File_Path : String; Project_File : Boolean; Preproc_Switches : Argument_List; Very_Verbose : Boolean); ! -- Start the creation of a configuration pragmas file or the creation or ! -- modification of a project file, for gnatname. -- ! -- When Project_File is False, File_Path is the name of a configuration ! -- pragmas file to create. When Project_File is True, File_Path is the name ! -- of a project file to create if it does not exist or to modify if it ! -- already exists. -- ! -- Preproc_Switches is a list of switches to be used when invoking the ! -- compiler to get the name and kind of unit of a source file. -- ! -- Very_Verbose controls the verbosity of the output, in conjunction with ! -- Opt.Verbose_Mode. ! ! type Regexp_List is array (Positive range <>) of Regexp; ! ! procedure Process ! (Directories : Argument_List; ! Name_Patterns : Regexp_List; ! Excluded_Patterns : Regexp_List; ! Foreign_Patterns : Regexp_List); ! -- Look for source files in the specified directories, with the specified ! -- patterns. -- ! -- Directories is the list of source directories where to look for sources. ! -- ! -- Name_Patterns is a potentially empty list of file name patterns to check ! -- for Ada Sources. ! -- ! -- Excluded_Patterns is a potentially empty list of file name patterns that ! -- should not be checked for Ada or non Ada sources. ! -- ! -- Foreign_Patterns is a potentially empty list of file name patterns to ! -- check for non Ada sources. ! -- ! -- At least one of Name_Patterns and Foreign_Patterns is not empty ! -- ! -- Note that this procedure currently assumes that it is only used by ! -- gnatname. If other processes start using it, then an additional ! -- parameter would need to be added, and call to Osint.Program_Name ! -- updated accordingly in the body. ! procedure Finalize; ! -- Write the configuration pragmas file or the project file indicated in a ! -- call to procedure Initialize, after one or several calls to procedure ! -- Process. end Prj.Makr; diff -Nrcpad gcc-4.3.3/gcc/ada/prj-nmsc.adb gcc-4.4.0/gcc/ada/prj-nmsc.adb *** gcc-4.3.3/gcc/ada/prj-nmsc.adb Wed Dec 19 16:24:17 2007 --- gcc-4.4.0/gcc/ada/prj-nmsc.adb Wed Aug 20 15:29:33 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2008, 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- -- *************** package body Prj.Nmsc is *** 65,73 **** ALI_Suffix : constant String := ".ali"; -- File suffix for ali files - Object_Suffix : constant String := Get_Target_Object_Suffix.all; - -- File suffix for object files - type Name_Location is record Name : File_Name_Type; Location : Source_Ptr; --- 65,70 ---- *************** package body Prj.Nmsc is *** 138,143 **** --- 135,143 ---- Unit : Name_Id; Next : Ada_Naming_Exception_Id := No_Ada_Naming_Exception; end record; + -- Comment needed??? + + -- Why is the following commented out ??? -- No_Unit : constant Unit_Info := -- (Specification, No_Name, No_Ada_Naming_Exception); *************** package body Prj.Nmsc is *** 159,170 **** --- 159,181 ---- -- A hash table to store naming exceptions for Ada. For each file name -- there is one or several unit in table Ada_Naming_Exception_Table. + package Object_File_Names is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => File_Name_Type, + No_Element => No_File, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + -- A hash table to store the object file names for a project, to check that + -- two different sources have different object file names. + type File_Found is record File : File_Name_Type := No_File; Found : Boolean := False; Location : Source_Ptr := No_Location; end record; No_File_Found : constant File_Found := (No_File, False, No_Location); + -- Comments needed ??? package Excluded_Sources_Htable is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, *************** package body Prj.Nmsc is *** 174,187 **** Hash => Hash, Equal => "="); -- A hash table to store the excluded files, if any. This is filled by ! -- Find_Excluded_Sources below procedure Find_Excluded_Sources ! (In_Tree : Project_Tree_Ref; Data : Project_Data); -- Find the list of files that should not be considered as source files ! -- for this project. ! -- Sets the list in the Excluded_Sources_Htable function Hash (Unit : Unit_Info) return Header_Num; --- 185,198 ---- Hash => Hash, Equal => "="); -- A hash table to store the excluded files, if any. This is filled by ! -- Find_Excluded_Sources below. procedure Find_Excluded_Sources ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; Data : Project_Data); -- Find the list of files that should not be considered as source files ! -- for this project. Sets the list in the Excluded_Sources_Htable. function Hash (Unit : Unit_Info) return Header_Num; *************** package body Prj.Nmsc is *** 199,206 **** Key => Unit_Info, Hash => Hash, Equal => "="); ! -- A table to check if a unit with an exceptional name will hide ! -- a source with a file name following the naming convention. procedure Add_Source (Id : out Source_Id; --- 210,217 ---- Key => Unit_Info, Hash => Hash, Equal => "="); ! -- A table to check if a unit with an exceptional name will hide a source ! -- with a file name following the naming convention. procedure Add_Source (Id : out Source_Id; *************** package body Prj.Nmsc is *** 224,229 **** --- 235,241 ---- -- Add a new source to the different lists: list of all sources in the -- project tree, list of source of a project and list of sources of a -- language. + -- -- If Path is specified, the file is also added to Source_Paths_HT. -- If Source_To_Replace is specified, it points to the source in the -- extended project that the new file is overriding. *************** package body Prj.Nmsc is *** 252,271 **** Data : in out Project_Data); -- Check the configuration attributes for the project - procedure Check_For_Source - (File_Name : File_Name_Type; - Path_Name : Path_Name_Type; - Project : Project_Id; - In_Tree : Project_Tree_Ref; - Data : in out Project_Data; - Location : Source_Ptr; - Language : Language_Index; - Suffix : String; - Naming_Exception : Boolean); - -- Check if a file, with name File_Name and path Path_Name, in a source - -- directory is a source for language Language in project Project of - -- project tree In_Tree. ??? - procedure Check_If_Externally_Built (Project : Project_Id; In_Tree : Project_Tree_Ref; --- 264,269 ---- *************** package body Prj.Nmsc is *** 273,287 **** -- Check attribute Externally_Built of project Project in project tree -- In_Tree and modify its data Data if it has the value "true". ! procedure Check_Library_Attributes (Project : Project_Id; In_Tree : Project_Tree_Ref; - Current_Dir : String; Data : in out Project_Data); -- Check the library attributes of project Project in project tree In_Tree -- and modify its data Data accordingly. -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it procedure Check_Package_Naming (Project : Project_Id; --- 271,292 ---- -- Check attribute Externally_Built of project Project in project tree -- In_Tree and modify its data Data if it has the value "true". ! procedure Check_Interfaces (Project : Project_Id; In_Tree : Project_Tree_Ref; Data : in out Project_Data); + -- If a list of sources is specified in attribute Interfaces, set + -- In_Interfaces only for the sources specified in the list. + + procedure Check_Library_Attributes + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Current_Dir : String; + Data : in out Project_Data); -- Check the library attributes of project Project in project tree In_Tree -- and modify its data Data accordingly. -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it. procedure Check_Package_Naming (Project : Project_Id; *************** package body Prj.Nmsc is *** 315,333 **** -- Check if project Project in project tree In_Tree is a Stand-Alone -- Library project, and modify its data Data accordingly if it is one. -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it procedure Get_Path_Names_And_Record_Ada_Sources ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! Current_Dir : String); -- Find the path names of the source files in the Source_Names table -- in the source directories and record those that are Ada sources. function Compute_Directory_Last (Dir : String) return Natural; -- Return the index of the last significant character in Dir. This is used ! -- to avoid duplicates '/' at the end of directory names procedure Error_Msg (Project : Project_Id; --- 320,338 ---- -- Check if project Project in project tree In_Tree is a Stand-Alone -- Library project, and modify its data Data accordingly if it is one. -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it. procedure Get_Path_Names_And_Record_Ada_Sources ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! Current_Dir : String); -- Find the path names of the source files in the Source_Names table -- in the source directories and record those that are Ada sources. function Compute_Directory_Last (Dir : String) return Natural; -- Return the index of the last significant character in Dir. This is used ! -- to avoid duplicate '/' (slash) characters at the end of directory names. procedure Error_Msg (Project : Project_Id; *************** package body Prj.Nmsc is *** 345,370 **** Current_Dir : String); -- Find all the Ada sources in all of the source directories of a project -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it ! ! procedure Find_Sources ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! For_Language : Language_Index; ! Current_Dir : String); ! -- Find all the sources in all of the source directories of a project for ! -- a specified language. procedure Search_Directories ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! For_All_Sources : Boolean); -- Search the source directories to find the sources. ! -- If For_All_Sources is True, check each regular file name against ! -- the naming schemes of the different languages. Otherwise consider ! -- only the file names in the hash table Source_Names. procedure Check_File (Project : Project_Id; --- 350,366 ---- Current_Dir : String); -- Find all the Ada sources in all of the source directories of a project -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it. procedure Search_Directories ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! For_All_Sources : Boolean); -- Search the source directories to find the sources. ! -- If For_All_Sources is True, check each regular file name against the ! -- naming schemes of the different languages. Otherwise consider only the ! -- file names in the hash table Source_Names. procedure Check_File (Project : Project_Id; *************** package body Prj.Nmsc is *** 408,415 **** --- 404,413 ---- Kind : out Source_Kind); -- Check if the file name File_Name conforms to one of the naming -- schemes of the project. + -- -- If the file does not match one of the naming schemes, set Language -- to No_Language_Index. + -- -- Filename is the name of the file being investigated. It has been -- normalized (case-folded). File_Name is the same value. *************** package body Prj.Nmsc is *** 423,430 **** Data : in out Project_Data); -- Get the object directory, the exec directory and the source directories -- of a project. -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it procedure Get_Mains (Project : Project_Id; --- 421,429 ---- Data : in out Project_Data); -- Get the object directory, the exec directory and the source directories -- of a project. + -- -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it. procedure Get_Mains (Project : Project_Id; *************** package body Prj.Nmsc is *** 442,456 **** -- Source_Names. procedure Find_Explicit_Sources ! (Lang : Language_Index; ! Current_Dir : String; Project : Project_Id; In_Tree : Project_Tree_Ref; Data : in out Project_Data); -- Process the Source_Files and Source_List_File attributes, and store -- the list of source files into the Source_Names htable. ! -- Lang indicates which language is being processed when in Ada_Only ! -- mode (all languages are processed anyway when in Multi_Language mode) procedure Get_Unit (In_Tree : Project_Tree_Ref; --- 441,455 ---- -- Source_Names. procedure Find_Explicit_Sources ! (Current_Dir : String; Project : Project_Id; In_Tree : Project_Tree_Ref; Data : in out Project_Data); -- Process the Source_Files and Source_List_File attributes, and store -- the list of source files into the Source_Names htable. ! -- ! -- Lang indicates which language is being processed when in Ada_Only mode ! -- (all languages are processed anyway when in Multi_Language mode). procedure Get_Unit (In_Tree : Project_Tree_Ref; *************** package body Prj.Nmsc is *** 461,476 **** Unit_Kind : out Spec_Or_Body; Needs_Pragma : out Boolean); -- Find out, from a file name, the unit name, the unit kind and if a ! -- specific SFN pragma is needed. If the file name corresponds to no ! -- unit, then Unit_Name will be No_Name. If the file is a multi-unit source ! -- or an exception to the naming scheme, then Exception_Id is set to ! -- the unit or units that the source contains. function Is_Illegal_Suffix (Suffix : String; Dot_Replacement_Is_A_Single_Dot : Boolean) return Boolean; ! -- Returns True if the string Suffix cannot be used as ! -- a spec suffix, a body suffix or a separate suffix. procedure Locate_Directory (Project : Project_Id; --- 460,475 ---- Unit_Kind : out Spec_Or_Body; Needs_Pragma : out Boolean); -- Find out, from a file name, the unit name, the unit kind and if a ! -- specific SFN pragma is needed. If the file name corresponds to no unit, ! -- then Unit_Name will be No_Name. If the file is a multi-unit source or an ! -- exception to the naming scheme, then Exception_Id is set to the unit or ! -- units that the source contains. function Is_Illegal_Suffix (Suffix : String; Dot_Replacement_Is_A_Single_Dot : Boolean) return Boolean; ! -- Returns True if the string Suffix cannot be used as a spec suffix, a ! -- body suffix or a separate suffix. procedure Locate_Directory (Project : Project_Id; *************** package body Prj.Nmsc is *** 489,512 **** -- is True and Create is a non null string, an attempt is made to create -- the directory. If the directory does not exist and Project_Setup is -- false, then Dir and Display are set to No_Name. -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it procedure Look_For_Sources ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! Current_Dir : String); -- Find all the sources of project Project in project tree In_Tree and -- update its Data accordingly. -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it function Path_Name_Of (File_Name : File_Name_Type; Directory : Path_Name_Type) return String; ! -- Returns the path name of a (non project) file. ! -- Returns an empty string if file cannot be found. procedure Prepare_Ada_Naming_Exceptions (List : Array_Element_Id; --- 488,513 ---- -- is True and Create is a non null string, an attempt is made to create -- the directory. If the directory does not exist and Project_Setup is -- false, then Dir and Display are set to No_Name. + -- -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it. procedure Look_For_Sources ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! Current_Dir : String); -- Find all the sources of project Project in project tree In_Tree and -- update its Data accordingly. + -- -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it. function Path_Name_Of (File_Name : File_Name_Type; Directory : Path_Name_Type) return String; ! -- Returns the path name of a (non project) file. Returns an empty string ! -- if file cannot be found. procedure Prepare_Ada_Naming_Exceptions (List : Array_Element_Id; *************** package body Prj.Nmsc is *** 534,551 **** Current_Dir : String); -- Put a unit in the list of units of a project, if the file name -- corresponds to a valid unit name. -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it ! ! procedure Record_Other_Sources ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! Language : Language_Index; ! Naming_Exceptions : Boolean); ! -- Record the sources of a language in a project. ! -- When Naming_Exceptions is True, mark the found sources as such, to ! -- later remove those that are not named in a list of sources. procedure Remove_Source (Id : Source_Id; --- 535,543 ---- Current_Dir : String); -- Put a unit in the list of units of a project, if the file name -- corresponds to a valid unit name. + -- -- Current_Dir should represent the current directory, and is passed for ! -- efficiency to avoid system calls to recompute it. procedure Remove_Source (Id : Source_Id; *************** package body Prj.Nmsc is *** 553,564 **** Project : Project_Id; Data : in out Project_Data; In_Tree : Project_Tree_Ref); procedure Report_No_Sources ! (Project : Project_Id; ! Lang_Name : String; ! In_Tree : Project_Tree_Ref; ! Location : Source_Ptr); -- Report an error or a warning depending on the value of When_No_Sources -- when there are no sources for language Lang_Name. --- 545,558 ---- Project : Project_Id; Data : in out Project_Data; In_Tree : Project_Tree_Ref); + -- ??? needs comment procedure Report_No_Sources ! (Project : Project_Id; ! Lang_Name : String; ! In_Tree : Project_Tree_Ref; ! Location : Source_Ptr; ! Continuation : Boolean := False); -- Report an error or a warning depending on the value of When_No_Sources -- when there are no sources for language Lang_Name. *************** package body Prj.Nmsc is *** 566,586 **** (Data : Project_Data; In_Tree : Project_Tree_Ref); -- List all the source directories of a project - function Suffix_For - (Language : Language_Index; - Naming : Naming_Data; - In_Tree : Project_Tree_Ref) return File_Name_Type; - -- Get the suffix for the source of a language from a package naming. - -- If not specified, return the default for the language. - procedure Warn_If_Not_Sources (Project : Project_Id; In_Tree : Project_Tree_Ref; Conventions : Array_Element_Id; Specs : Boolean; Extending : Boolean); ! -- Check that individual naming conventions apply to immediate ! -- sources of the project; if not, issue a warning. ---------------- -- Add_Source -- --- 560,573 ---- (Data : Project_Data; In_Tree : Project_Tree_Ref); -- List all the source directories of a project procedure Warn_If_Not_Sources (Project : Project_Id; In_Tree : Project_Tree_Ref; Conventions : Array_Element_Id; Specs : Boolean; Extending : Boolean); ! -- Check that individual naming conventions apply to immediate sources of ! -- the project. If not, issue a warning. ---------------- -- Add_Source -- *************** package body Prj.Nmsc is *** 608,616 **** is Source : constant Source_Id := Data.Last_Source; Src_Data : Source_Data := No_Source_Data; begin ! -- This is a new source. Create an entry for it in the Sources table. Source_Data_Table.Increment_Last (In_Tree.Sources); Id := Source_Data_Table.Last (In_Tree.Sources); --- 595,605 ---- is Source : constant Source_Id := Data.Last_Source; Src_Data : Source_Data := No_Source_Data; + Config : constant Language_Config := + In_Tree.Languages_Data.Table (Lang_Id).Config; begin ! -- This is a new source so create an entry for it in the Sources table Source_Data_Table.Increment_Last (In_Tree.Sources); Id := Source_Data_Table.Last (In_Tree.Sources); *************** package body Prj.Nmsc is *** 619,654 **** Write_Str ("Adding source #"); Write_Str (Id'Img); Write_Str (", File : "); if Lang_Kind = Unit_Based then Write_Str (", Unit : "); Write_Str (Get_Name_String (Unit)); end if; ! Write_Line (Get_Name_String (File_Name)); end if; Src_Data.Project := Project; Src_Data.Language_Name := Lang; Src_Data.Language := Lang_Id; Src_Data.Lang_Kind := Lang_Kind; Src_Data.Kind := Kind; Src_Data.Alternate_Languages := Alternate_Languages; Src_Data.Other_Part := Other_Part; Src_Data.Unit := Unit; Src_Data.Index := Index; Src_Data.File := File_Name; - Src_Data.Object := Object_Name (File_Name); Src_Data.Display_File := Display_File; ! Src_Data.Dependency := ! In_Tree.Languages_Data.Table (Lang_Id).Config.Dependency_Kind; ! Src_Data.Dep_Name := Dependency_Name (File_Name, Src_Data.Dependency); ! Src_Data.Switches := Switches_Name (File_Name); Src_Data.Naming_Exception := Naming_Exception; if Path /= No_Path then ! Src_Data.Path := Path; ! Src_Data.Display_Path := Display_Path; Source_Paths_Htable.Set (In_Tree.Source_Paths_HT, Path, Id); end if; --- 608,658 ---- Write_Str ("Adding source #"); Write_Str (Id'Img); Write_Str (", File : "); + Write_Str (Get_Name_String (File_Name)); if Lang_Kind = Unit_Based then Write_Str (", Unit : "); Write_Str (Get_Name_String (Unit)); end if; ! Write_Eol; end if; Src_Data.Project := Project; Src_Data.Language_Name := Lang; Src_Data.Language := Lang_Id; Src_Data.Lang_Kind := Lang_Kind; + Src_Data.Compiled := In_Tree.Languages_Data.Table + (Lang_Id).Config.Compiler_Driver /= + Empty_File_Name; Src_Data.Kind := Kind; Src_Data.Alternate_Languages := Alternate_Languages; Src_Data.Other_Part := Other_Part; + + Src_Data.Object_Exists := Config.Object_Generated; + Src_Data.Object_Linked := Config.Objects_Linked; + + if Other_Part /= No_Source then + In_Tree.Sources.Table (Other_Part).Other_Part := Id; + end if; + Src_Data.Unit := Unit; Src_Data.Index := Index; Src_Data.File := File_Name; Src_Data.Display_File := Display_File; ! Src_Data.Dependency := In_Tree.Languages_Data.Table ! (Lang_Id).Config.Dependency_Kind; Src_Data.Naming_Exception := Naming_Exception; + if Src_Data.Compiled and then Src_Data.Object_Exists then + Src_Data.Object := Object_Name (File_Name); + Src_Data.Dep_Name := + Dependency_Name (File_Name, Src_Data.Dependency); + Src_Data.Switches := Switches_Name (File_Name); + end if; + if Path /= No_Path then ! Src_Data.Path := (Path, Display_Path); Source_Paths_Htable.Set (In_Tree.Source_Paths_HT, Path, Id); end if; *************** package body Prj.Nmsc is *** 731,736 **** --- 735,748 ---- Check_Programming_Languages (In_Tree, Project, Data); + if Data.Qualifier = Dry and then Data.Source_Dirs /= Nil_String then + Error_Msg + (Project, In_Tree, + "an abstract project need to have no language, no sources or no " & + "source directories", + Data.Location); + end if; + -- Check configuration in multi language mode if Must_Check_Configuration then *************** package body Prj.Nmsc is *** 787,792 **** --- 799,805 ---- Src_Data : Source_Data; Alt_Lang : Alternate_Language_Id; Alt_Lang_Data : Alternate_Language_Data; + Continuation : Boolean := False; begin Language := Data.First_Language_Processing; *************** package body Prj.Nmsc is *** 818,824 **** (In_Tree.Languages_Data.Table (Language).Display_Name), In_Tree, ! Data.Location); end if; Language := In_Tree.Languages_Data.Table (Language).Next; --- 831,839 ---- (In_Tree.Languages_Data.Table (Language).Display_Name), In_Tree, ! Data.Location, ! Continuation); ! Continuation := True; end if; Language := In_Tree.Languages_Data.Table (Language).Next; *************** package body Prj.Nmsc is *** 827,832 **** --- 842,855 ---- end if; end if; + if Get_Mode = Multi_Language then + + -- If a list of sources is specified in attribute Interfaces, set + -- In_Interfaces only for the sources specified in the list. + + Check_Interfaces (Project, In_Tree, Data); + end if; + -- If it is a library project file, check if it is a standalone library if Data.Library then *************** package body Prj.Nmsc is *** 1272,1283 **** while Element_Id /= No_Array_Element loop Element := In_Tree.Array_Elements.Table (Element_Id); ! -- Get the name of the language ! Get_Language_Index_Of (Element.Index); ! if Lang_Index /= No_Language_Index then ! case Current_Array.Name is when Name_Driver => -- Attribute Driver () --- 1295,1308 ---- while Element_Id /= No_Array_Element loop Element := In_Tree.Array_Elements.Table (Element_Id); ! if Element.Index /= All_Other_Names then ! -- Get the name of the language ! Get_Language_Index_Of (Element.Index); ! ! if Lang_Index /= No_Language_Index then ! case Current_Array.Name is when Name_Driver => -- Attribute Driver () *************** package body Prj.Nmsc is *** 1319,1325 **** when others => null; ! end case; end if; Element_Id := Element.Next; --- 1344,1351 ---- when others => null; ! end case; ! end if; end if; Element_Id := Element.Next; *************** package body Prj.Nmsc is *** 1382,1399 **** while Element_Id /= No_Array_Element loop Element := In_Tree.Array_Elements.Table (Element_Id); ! -- Get the name of the language ! Get_Language_Index_Of (Element.Index); ! if Lang_Index /= No_Language_Index then ! case Current_Array.Name is when Name_Dependency_Switches => -- Attribute Dependency_Switches () if In_Tree.Languages_Data.Table ! (Lang_Index).Config.Dependency_Kind = None then In_Tree.Languages_Data.Table (Lang_Index).Config.Dependency_Kind := --- 1408,1427 ---- while Element_Id /= No_Array_Element loop Element := In_Tree.Array_Elements.Table (Element_Id); ! if Element.Index /= All_Other_Names then ! -- Get the name of the language ! Get_Language_Index_Of (Element.Index); ! ! if Lang_Index /= No_Language_Index then ! case Current_Array.Name is when Name_Dependency_Switches => -- Attribute Dependency_Switches () if In_Tree.Languages_Data.Table ! (Lang_Index).Config.Dependency_Kind = None then In_Tree.Languages_Data.Table (Lang_Index).Config.Dependency_Kind := *************** package body Prj.Nmsc is *** 1415,1425 **** -- Attribute Dependency_Driver () if In_Tree.Languages_Data.Table ! (Lang_Index).Config.Dependency_Kind = None then In_Tree.Languages_Data.Table (Lang_Index).Config.Dependency_Kind := ! Makefile; end if; List := Element.Value.Values; --- 1443,1453 ---- -- Attribute Dependency_Driver () if In_Tree.Languages_Data.Table ! (Lang_Index).Config.Dependency_Kind = None then In_Tree.Languages_Data.Table (Lang_Index).Config.Dependency_Kind := ! Makefile; end if; List := Element.Value.Values; *************** package body Prj.Nmsc is *** 1466,1472 **** In_Tree.Languages_Data.Table (Lang_Index).Config.Include_Path_File := ! Element.Value.Value; when Name_Driver => --- 1494,1500 ---- In_Tree.Languages_Data.Table (Lang_Index).Config.Include_Path_File := ! Element.Value.Value; when Name_Driver => *************** package body Prj.Nmsc is *** 1474,1499 **** Get_Name_String (Element.Value.Value); - if Name_Len = 0 then - Error_Msg - (Project, - In_Tree, - "compiler driver name cannot be empty", - Element.Value.Location); - end if; - In_Tree.Languages_Data.Table (Lang_Index).Config.Compiler_Driver := ! File_Name_Type (Element.Value.Value); when Name_Required_Switches => Put (Into_List => In_Tree.Languages_Data.Table (Lang_Index).Config. ! Compiler_Required_Switches, From_List => Element.Value.Values, In_Tree => In_Tree); when Name_Pic_Option => -- Attribute Compiler_Pic_Option () --- 1502,1535 ---- Get_Name_String (Element.Value.Value); In_Tree.Languages_Data.Table (Lang_Index).Config.Compiler_Driver := ! File_Name_Type (Element.Value.Value); when Name_Required_Switches => Put (Into_List => In_Tree.Languages_Data.Table (Lang_Index).Config. ! Compiler_Required_Switches, From_List => Element.Value.Values, In_Tree => In_Tree); + when Name_Path_Syntax => + begin + In_Tree.Languages_Data.Table + (Lang_Index).Config.Path_Syntax := + Path_Syntax_Kind'Value + (Get_Name_String (Element.Value.Value)); + + exception + when Constraint_Error => + Error_Msg + (Project, + In_Tree, + "invalid value for Path_Syntax", + Element.Value.Location); + end; + when Name_Pic_Option => -- Attribute Compiler_Pic_Option () *************** package body Prj.Nmsc is *** 1565,1572 **** end if; Put (Into_List => ! In_Tree.Languages_Data.Table ! (Lang_Index).Config.Config_File_Switches, From_List => List, In_Tree => In_Tree); --- 1601,1608 ---- end if; Put (Into_List => ! In_Tree.Languages_Data.Table ! (Lang_Index).Config.Config_File_Switches, From_List => List, In_Tree => In_Tree); *************** package body Prj.Nmsc is *** 1576,1582 **** In_Tree.Languages_Data.Table (Lang_Index).Config.Objects_Path := ! Element.Value.Value; when Name_Objects_Path_File => --- 1612,1618 ---- In_Tree.Languages_Data.Table (Lang_Index).Config.Objects_Path := ! Element.Value.Value; when Name_Objects_Path_File => *************** package body Prj.Nmsc is *** 1584,1590 **** In_Tree.Languages_Data.Table (Lang_Index).Config.Objects_Path_File := ! Element.Value.Value; when Name_Config_Body_File_Name => --- 1620,1626 ---- In_Tree.Languages_Data.Table (Lang_Index).Config.Objects_Path_File := ! Element.Value.Value; when Name_Config_Body_File_Name => *************** package body Prj.Nmsc is *** 1592,1598 **** In_Tree.Languages_Data.Table (Lang_Index).Config.Config_Body := ! Element.Value.Value; when Name_Config_Body_File_Name_Pattern => --- 1628,1634 ---- In_Tree.Languages_Data.Table (Lang_Index).Config.Config_Body := ! Element.Value.Value; when Name_Config_Body_File_Name_Pattern => *************** package body Prj.Nmsc is *** 1609,1615 **** In_Tree.Languages_Data.Table (Lang_Index).Config.Config_Spec := ! Element.Value.Value; when Name_Config_Spec_File_Name_Pattern => --- 1645,1651 ---- In_Tree.Languages_Data.Table (Lang_Index).Config.Config_Spec := ! Element.Value.Value; when Name_Config_Spec_File_Name_Pattern => *************** package body Prj.Nmsc is *** 1618,1624 **** In_Tree.Languages_Data.Table (Lang_Index).Config.Config_Spec_Pattern := ! Element.Value.Value; when Name_Config_File_Unique => --- 1654,1660 ---- In_Tree.Languages_Data.Table (Lang_Index).Config.Config_Spec_Pattern := ! Element.Value.Value; when Name_Config_File_Unique => *************** package body Prj.Nmsc is *** 1640,1646 **** when others => null; ! end case; end if; Element_Id := Element.Next; --- 1676,1683 ---- when others => null; ! end case; ! end if; end if; Element_Id := Element.Next; *************** package body Prj.Nmsc is *** 1663,1670 **** Attribute_Id := Attributes; while Attribute_Id /= No_Variable loop ! Attribute := ! In_Tree.Variable_Elements.Table (Attribute_Id); if not Attribute.Value.Default then if Attribute.Name = Name_Separate_Suffix then --- 1700,1706 ---- Attribute_Id := Attributes; while Attribute_Id /= No_Variable loop ! Attribute := In_Tree.Variable_Elements.Table (Attribute_Id); if not Attribute.Value.Default then if Attribute.Name = Name_Separate_Suffix then *************** package body Prj.Nmsc is *** 1781,1789 **** Data.Config.Linker := Path_Name_Type (Attribute.Value.Value); ! elsif ! Attribute.Name = Name_Required_Switches ! then -- Attribute Required_Switches: the minimum -- options to use when invoking the linker --- 1817,1823 ---- Data.Config.Linker := Path_Name_Type (Attribute.Value.Value); ! elsif Attribute.Name = Name_Required_Switches then -- Attribute Required_Switches: the minimum -- options to use when invoking the linker *************** package body Prj.Nmsc is *** 1793,1798 **** --- 1827,1834 ---- From_List => Attribute.Value.Values, In_Tree => In_Tree); + elsif Attribute.Name = Name_Map_File_Option then + Data.Config.Map_File_Option := Attribute.Value.Value; end if; end if; *************** package body Prj.Nmsc is *** 1892,1897 **** --- 1928,1947 ---- From_List => List, In_Tree => In_Tree); + elsif Attribute.Name = Name_Archive_Builder_Append_Option then + + -- Attribute Archive_Builder: the archive builder + -- (usually "ar") and its minimum options (usually "cr"). + + List := Attribute.Value.Values; + + if List /= Nil_String then + Put + (Into_List => Data.Config.Archive_Builder_Append_Option, + From_List => List, + In_Tree => In_Tree); + end if; + elsif Attribute.Name = Name_Archive_Indexer then -- Attribute Archive_Indexer: the optional archive *************** package body Prj.Nmsc is *** 1932,1937 **** --- 1982,1991 ---- From_List => List, In_Tree => In_Tree); + elsif Attribute.Name = Name_Library_GCC then + Data.Config.Shared_Lib_Driver := + File_Name_Type (Attribute.Value.Value); + elsif Attribute.Name = Name_Archive_Suffix then Data.Config.Archive_Suffix := File_Name_Type (Attribute.Value.Value); *************** package body Prj.Nmsc is *** 2042,2050 **** Error_Msg (Project, In_Tree, ! "invalid value """ & ! Get_Name_String (Attribute.Value.Value) & ! """ for Symbolic_Link_Supported", Attribute.Value.Location); end; --- 2096,2104 ---- Error_Msg (Project, In_Tree, ! "invalid value """ ! & Get_Name_String (Attribute.Value.Value) ! & """ for Symbolic_Link_Supported", Attribute.Value.Location); end; *************** package body Prj.Nmsc is *** 2068,2096 **** Attribute.Value.Location); end; ! elsif ! Attribute.Name = Name_Library_Auto_Init_Supported ! then declare pragma Unsuppress (All_Checks); begin Data.Config.Auto_Init_Supported := ! Boolean'Value (Get_Name_String ! (Attribute.Value.Value)); exception when Constraint_Error => Error_Msg (Project, In_Tree, ! "invalid value """ & ! Get_Name_String (Attribute.Value.Value) & ! """ for Library_Auto_Init_Supported", Attribute.Value.Location); end; ! elsif ! Attribute.Name = Name_Shared_Library_Minimum_Switches ! then List := Attribute.Value.Values; if List /= Nil_String then --- 2122,2145 ---- Attribute.Value.Location); end; ! elsif Attribute.Name = Name_Library_Auto_Init_Supported then declare pragma Unsuppress (All_Checks); begin Data.Config.Auto_Init_Supported := ! Boolean'Value (Get_Name_String (Attribute.Value.Value)); exception when Constraint_Error => Error_Msg (Project, In_Tree, ! "invalid value """ ! & Get_Name_String (Attribute.Value.Value) ! & """ for Library_Auto_Init_Supported", Attribute.Value.Location); end; ! elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then List := Attribute.Value.Values; if List /= Nil_String then *************** package body Prj.Nmsc is *** 2099,2107 **** In_Tree => In_Tree); end if; ! elsif ! Attribute.Name = Name_Library_Version_Switches ! then List := Attribute.Value.Values; if List /= Nil_String then --- 2148,2154 ---- In_Tree => In_Tree); end if; ! elsif Attribute.Name = Name_Library_Version_Switches then List := Attribute.Value.Values; if List /= Nil_String then *************** package body Prj.Nmsc is *** 2125,2130 **** --- 2172,2178 ---- Current_Array : Array_Data; Element_Id : Array_Element_Id; Element : Array_Element; + List : String_List_Id; begin -- Process the associative array attributes at project level *************** package body Prj.Nmsc is *** 2143,2148 **** --- 2191,2209 ---- if Lang_Index /= No_Language_Index then case Current_Array.Name is + when Name_Inherit_Source_Path => + List := Element.Value.Values; + + if List /= Nil_String then + Put + (Into_List => + In_Tree.Languages_Data.Table (Lang_Index). + Config.Include_Compatible_Languages, + From_List => List, + In_Tree => In_Tree, + Lower_Case => True); + end if; + when Name_Toolchain_Description => -- Attribute Toolchain_Description () *************** package body Prj.Nmsc is *** 2167,2172 **** --- 2228,2296 ---- (Lang_Index).Config.Runtime_Library_Dir := Element.Value.Value; + when Name_Object_Generated => + declare + pragma Unsuppress (All_Checks); + Value : Boolean; + + begin + Value := + Boolean'Value + (Get_Name_String (Element.Value.Value)); + + In_Tree.Languages_Data.Table + (Lang_Index).Config.Object_Generated := Value; + + -- If no object is generated, no object may be + -- linked. + + if not Value then + In_Tree.Languages_Data.Table + (Lang_Index).Config.Objects_Linked := False; + end if; + + exception + when Constraint_Error => + Error_Msg + (Project, + In_Tree, + "invalid value """ + & Get_Name_String (Element.Value.Value) + & """ for Object_Generated", + Element.Value.Location); + end; + + when Name_Objects_Linked => + declare + pragma Unsuppress (All_Checks); + Value : Boolean; + + begin + Value := + Boolean'Value + (Get_Name_String (Element.Value.Value)); + + -- No change if Object_Generated is False, as this + -- forces Objects_Linked to be False too. + + if In_Tree.Languages_Data.Table + (Lang_Index).Config.Object_Generated + then + In_Tree.Languages_Data.Table + (Lang_Index).Config.Objects_Linked := + Value; + end if; + + exception + when Constraint_Error => + Error_Msg + (Project, + In_Tree, + "invalid value """ + & Get_Name_String (Element.Value.Value) + & """ for Objects_Linked", + Element.Value.Location); + end; when others => null; end case; *************** package body Prj.Nmsc is *** 2302,2627 **** end loop; end Check_Configuration; ! ---------------------- ! -- Check_For_Source -- ! ---------------------- ! procedure Check_For_Source ! (File_Name : File_Name_Type; ! Path_Name : Path_Name_Type; ! Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! Location : Source_Ptr; ! Language : Language_Index; ! Suffix : String; ! Naming_Exception : Boolean) is ! Name : String := Get_Name_String (File_Name); ! Real_Location : Source_Ptr := Location; begin ! Canonical_Case_File_Name (Name); ! -- A file is a source of a language if Naming_Exception is True (case ! -- of naming exceptions) or if its file name ends with the suffix. ! if Naming_Exception ! or else ! (Name'Length > Suffix'Length ! and then ! Name (Name'Last - Suffix'Length + 1 .. Name'Last) = Suffix) ! then ! if Real_Location = No_Location then ! Real_Location := Data.Location; end if; ! declare ! Path_Id : Path_Name_Type; ! C_Path_Id : Path_Name_Type; ! -- The path name id (in canonical case) ! ! File_Id : File_Name_Type; ! -- The file name id (in canonical case) ! ! Obj_Id : File_Name_Type; ! -- The object file name ! ! Obj_Path_Id : Path_Name_Type; ! -- The object path name ! ! Dep_Id : File_Name_Type; ! -- The dependency file name ! ! Dep_Path_Id : Path_Name_Type; ! -- The dependency path name ! ! Dot_Pos : Natural := 0; ! -- Position of the last dot in Name ! Source : Other_Source; ! Source_Id : Other_Source_Id := Data.First_Other_Source; ! begin ! -- Get the file name id ! if Osint.File_Names_Case_Sensitive then ! File_Id := File_Name; ! else ! Name_Len := Name'Length; ! Name_Buffer (1 .. Name_Len) := Name; ! File_Id := Name_Find; ! end if; ! -- Get the path name id ! Path_Id := Path_Name; ! if Osint.File_Names_Case_Sensitive then ! C_Path_Id := Path_Name; ! else ! declare ! C_Path : String := Get_Name_String (Path_Name); ! begin ! Canonical_Case_File_Name (C_Path); ! Name_Len := C_Path'Length; ! Name_Buffer (1 .. Name_Len) := C_Path; ! C_Path_Id := Name_Find; ! end; ! end if; ! -- Find the position of the last dot ! for J in reverse Name'Range loop ! if Name (J) = '.' then ! Dot_Pos := J; ! exit; ! end if; ! end loop; ! if Dot_Pos <= Name'First then ! Dot_Pos := Name'Last + 1; ! end if; ! -- Compute the object file name ! Get_Name_String (File_Id); ! Name_Len := Dot_Pos - Name'First; ! for J in Object_Suffix'Range loop ! Name_Len := Name_Len + 1; ! Name_Buffer (Name_Len) := Object_Suffix (J); end loop; ! Obj_Id := Name_Find; ! ! -- Compute the object path name ! ! Get_Name_String (Data.Display_Object_Dir); ! ! if Name_Buffer (Name_Len) /= Directory_Separator ! and then Name_Buffer (Name_Len) /= '/' ! then ! Name_Len := Name_Len + 1; ! Name_Buffer (Name_Len) := Directory_Separator; ! end if; ! ! Add_Str_To_Name_Buffer (Get_Name_String (Obj_Id)); ! Obj_Path_Id := Name_Find; ! ! -- Compute the dependency file name ! ! Get_Name_String (File_Id); ! Name_Len := Dot_Pos - Name'First + 1; ! Name_Buffer (Name_Len) := '.'; ! Name_Len := Name_Len + 1; ! Name_Buffer (Name_Len) := 'd'; ! Dep_Id := Name_Find; ! ! -- Compute the dependency path name ! ! Get_Name_String (Data.Display_Object_Dir); ! ! if Name_Buffer (Name_Len) /= Directory_Separator ! and then Name_Buffer (Name_Len) /= '/' ! then ! Name_Len := Name_Len + 1; ! Name_Buffer (Name_Len) := Directory_Separator; ! end if; ! ! Add_Str_To_Name_Buffer (Get_Name_String (Dep_Id)); ! Dep_Path_Id := Name_Find; ! ! -- Check if source is already in the list of source for this ! -- project: it may have already been specified as a naming ! -- exception for the same language or an other language, or ! -- they may be two identical file names in different source ! -- directories. ! ! while Source_Id /= No_Other_Source loop ! Source := In_Tree.Other_Sources.Table (Source_Id); ! if Source.File_Name = File_Id then ! -- Two sources of different languages cannot have the same ! -- file name. ! if Source.Language /= Language then ! Error_Msg_File_1 := File_Name; ! Error_Msg ! (Project, In_Tree, ! "{ cannot be a source of several languages", ! Real_Location); ! return; ! -- No problem if a file has already been specified as ! -- a naming exception of this language. ! elsif Source.Path_Name = C_Path_Id then ! -- Reset the naming exception flag, if this is not a ! -- naming exception. ! if not Naming_Exception then ! In_Tree.Other_Sources.Table ! (Source_Id).Naming_Exception := False; end if; ! return; ! ! -- There are several files with the same names, but the ! -- order of the source directories is known (no /**): ! -- only the first one encountered is kept, the other ones ! -- are ignored. ! ! elsif Data.Known_Order_Of_Source_Dirs then ! return; ! ! -- But it is an error if the order of the source directories ! -- is not known. ! ! else ! Error_Msg_File_1 := File_Name; ! Error_Msg ! (Project, In_Tree, ! "{ is found in several source directories", ! Real_Location); ! return; end if; ! -- Two sources with different file names cannot have the same ! -- object file name. ! ! elsif Source.Object_Name = Obj_Id then ! Error_Msg_File_1 := File_Id; ! Error_Msg_File_2 := Source.File_Name; ! Error_Msg_File_3 := Obj_Id; ! Error_Msg ! (Project, In_Tree, ! "{ and { have the same object file {", ! Real_Location); ! return; ! end if; ! ! Source_Id := Source.Next; ! end loop; ! ! if Current_Verbosity = High then ! Write_Str (" found "); ! Display_Language_Name (Language); ! Write_Str (" source """); ! Write_Str (Get_Name_String (File_Name)); ! Write_Line (""""); ! Write_Str (" object path = "); ! Write_Line (Get_Name_String (Obj_Path_Id)); ! end if; ! ! -- Create the Other_Source record ! ! Source := ! (Language => Language, ! File_Name => File_Id, ! Path_Name => Path_Id, ! Source_TS => File_Stamp (Path_Id), ! Object_Name => Obj_Id, ! Object_Path => Obj_Path_Id, ! Object_TS => File_Stamp (Obj_Path_Id), ! Dep_Name => Dep_Id, ! Dep_Path => Dep_Path_Id, ! Dep_TS => File_Stamp (Dep_Path_Id), ! Naming_Exception => Naming_Exception, ! Next => No_Other_Source); ! ! -- And add it to the Other_Sources table ! ! Other_Source_Table.Increment_Last (In_Tree.Other_Sources); ! In_Tree.Other_Sources.Table ! (Other_Source_Table.Last (In_Tree.Other_Sources)) := Source; ! ! -- There are sources of languages other than Ada in this project ! ! Data.Other_Sources_Present := True; ! -- And there are sources of this language in this project ! Set (Language, True, Data, In_Tree); ! -- Add this source to the list of sources of languages other than ! -- Ada of the project. ! if Data.First_Other_Source = No_Other_Source then ! Data.First_Other_Source := ! Other_Source_Table.Last (In_Tree.Other_Sources); ! else ! In_Tree.Other_Sources.Table (Data.Last_Other_Source).Next := ! Other_Source_Table.Last (In_Tree.Other_Sources); end if; ! Data.Last_Other_Source := ! Other_Source_Table.Last (In_Tree.Other_Sources); ! end; ! end if; ! end Check_For_Source; ! ! ------------------------------- ! -- Check_If_Externally_Built -- ! ------------------------------- ! ! procedure Check_If_Externally_Built ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data) ! is ! Externally_Built : constant Variable_Value := ! Util.Value_Of ! (Name_Externally_Built, ! Data.Decl.Attributes, In_Tree); ! begin ! if not Externally_Built.Default then ! Get_Name_String (Externally_Built.Value); ! To_Lower (Name_Buffer (1 .. Name_Len)); ! if Name_Buffer (1 .. Name_Len) = "true" then ! Data.Externally_Built := True; ! elsif Name_Buffer (1 .. Name_Len) /= "false" then ! Error_Msg (Project, In_Tree, ! "Externally_Built may only be true or false", ! Externally_Built.Location); ! end if; ! end if; ! if Current_Verbosity = High then ! Write_Str ("Project is "); ! if not Data.Externally_Built then ! Write_Str ("not "); end if; - - Write_Line ("externally built."); end if; ! end Check_If_Externally_Built; -------------------------- -- Check_Naming_Schemes -- --- 2426,2611 ---- end loop; end Check_Configuration; ! ------------------------------- ! -- Check_If_Externally_Built -- ! ------------------------------- ! procedure Check_If_Externally_Built ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data) is ! Externally_Built : constant Variable_Value := ! Util.Value_Of ! (Name_Externally_Built, ! Data.Decl.Attributes, In_Tree); begin ! if not Externally_Built.Default then ! Get_Name_String (Externally_Built.Value); ! To_Lower (Name_Buffer (1 .. Name_Len)); ! if Name_Buffer (1 .. Name_Len) = "true" then ! Data.Externally_Built := True; ! elsif Name_Buffer (1 .. Name_Len) /= "false" then ! Error_Msg (Project, In_Tree, ! "Externally_Built may only be true or false", ! Externally_Built.Location); end if; + end if; ! -- A virtual project extending an externally built project is itself ! -- externally built. ! if Data.Virtual and then Data.Extends /= No_Project then ! Data.Externally_Built := ! In_Tree.Projects.Table (Data.Extends).Externally_Built; ! end if; ! if Current_Verbosity = High then ! Write_Str ("Project is "); ! if not Data.Externally_Built then ! Write_Str ("not "); ! end if; ! Write_Line ("externally built."); ! end if; ! end Check_If_Externally_Built; ! ---------------------- ! -- Check_Interfaces -- ! ---------------------- ! procedure Check_Interfaces ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data) ! is ! Interfaces : constant Prj.Variable_Value := ! Prj.Util.Value_Of ! (Snames.Name_Interfaces, ! Data.Decl.Attributes, ! In_Tree); ! List : String_List_Id; ! Element : String_Element; ! Name : File_Name_Type; ! Source : Source_Id; ! Src_Data : Source_Data; ! Project_2 : Project_Id; ! Data_2 : Project_Data; ! begin ! if not Interfaces.Default then ! -- Set In_Interfaces to False for all sources. It will be set to True ! -- later for the sources in the Interfaces list. ! Project_2 := Project; ! Data_2 := Data; ! loop ! Source := Data_2.First_Source; ! while Source /= No_Source loop ! Src_Data := In_Tree.Sources.Table (Source); ! Src_Data.In_Interfaces := False; ! In_Tree.Sources.Table (Source) := Src_Data; ! Source := Src_Data.Next_In_Project; end loop; ! Project_2 := Data_2.Extends; ! exit when Project_2 = No_Project; ! Data_2 := In_Tree.Projects.Table (Project_2); ! end loop; ! List := Interfaces.Values; ! while List /= Nil_String loop ! Element := In_Tree.String_Elements.Table (List); ! Get_Name_String (Element.Value); ! Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); ! Name := Name_Find; ! Project_2 := Project; ! Data_2 := Data; ! Big_Loop : ! loop ! Source := Data_2.First_Source; ! while Source /= No_Source loop ! Src_Data := In_Tree.Sources.Table (Source); ! if Src_Data.File = Name then ! if not Src_Data.Locally_Removed then ! In_Tree.Sources.Table (Source).In_Interfaces := True; ! In_Tree.Sources.Table ! (Source).Declared_In_Interfaces := True; ! if Src_Data.Other_Part /= No_Source then ! In_Tree.Sources.Table ! (Src_Data.Other_Part).In_Interfaces := True; ! In_Tree.Sources.Table ! (Src_Data.Other_Part).Declared_In_Interfaces := ! True; ! end if; ! if Current_Verbosity = High then ! Write_Str (" interface: "); ! Write_Line (Get_Name_String (Src_Data.Path.Name)); ! end if; end if; ! exit Big_Loop; end if; ! Source := Src_Data.Next_In_Project; ! end loop; ! Project_2 := Data_2.Extends; ! exit Big_Loop when Project_2 = No_Project; ! Data_2 := In_Tree.Projects.Table (Project_2); ! end loop Big_Loop; ! if Source = No_Source then ! Error_Msg_File_1 := File_Name_Type (Element.Value); ! Error_Msg_Name_1 := Data.Name; ! Error_Msg ! (Project, ! In_Tree, ! "{ cannot be an interface of project %% " & ! "as it is not one of its sources", ! Element.Location); end if; ! List := Element.Next; ! end loop; ! Data.Interfaces_Defined := True; ! elsif Data.Extends /= No_Project then ! Data.Interfaces_Defined := ! In_Tree.Projects.Table (Data.Extends).Interfaces_Defined; ! if Data.Interfaces_Defined then ! Source := Data.First_Source; ! while Source /= No_Source loop ! Src_Data := In_Tree.Sources.Table (Source); ! if not Src_Data.Declared_In_Interfaces then ! Src_Data.In_Interfaces := False; ! In_Tree.Sources.Table (Source) := Src_Data; ! end if; ! Source := Src_Data.Next_In_Project; ! end loop; end if; end if; ! end Check_Interfaces; -------------------------- -- Check_Naming_Schemes -- *************** package body Prj.Nmsc is *** 2945,2956 **** else Error_Msg_Name_1 := Unit; ! Error_Msg (Project, In_Tree, ! "unit%% cannot belong to two projects " & ! "simultaneously", Element.Value.Location); end if; end if; --- 2929,2940 ---- else Error_Msg_Name_1 := Unit; ! Error_Msg_Name_2 := ! In_Tree.Projects.Table (Other_Project).Name; Error_Msg (Project, In_Tree, ! "%% is already a source of project %%", Element.Value.Location); end if; end if; *************** package body Prj.Nmsc is *** 3533,3538 **** --- 3517,3524 ---- Support_For_Libraries : Library_Support; + Library_Directory_Present : Boolean; + procedure Check_Library (Proj : Project_Id; Extends : Boolean); -- Check if an imported or extended project if also a library project *************** package body Prj.Nmsc is *** 3542,3579 **** procedure Check_Library (Proj : Project_Id; Extends : Boolean) is Proj_Data : Project_Data; begin if Proj /= No_Project then Proj_Data := In_Tree.Projects.Table (Proj); if not Proj_Data.Library then -- The only not library projects that are OK are those that ! -- have no sources. ! if Proj_Data.Source_Dirs /= Nil_String then Error_Msg_Name_1 := Data.Name; Error_Msg_Name_2 := Proj_Data.Name; if Extends then ! Error_Msg ! (Project, In_Tree, ! Continuation.all & ! "library project %% cannot extend project %% " & ! "that is not a library project", ! Data.Location); ! else Error_Msg (Project, In_Tree, Continuation.all & ! "library project %% cannot import project %% " & ! "that is not a library project", Data.Location); end if; - - Continuation := Continuation_String'Access; end if; elsif Data.Library_Kind /= Static and then --- 3528,3580 ---- procedure Check_Library (Proj : Project_Id; Extends : Boolean) is Proj_Data : Project_Data; + Src_Id : Source_Id; + Src : Source_Data; begin if Proj /= No_Project then Proj_Data := In_Tree.Projects.Table (Proj); if not Proj_Data.Library then + -- The only not library projects that are OK are those that ! -- have no sources. However, header files from non-Ada ! -- languages are OK, as there is nothing to compile. ! Src_Id := Proj_Data.First_Source; ! while Src_Id /= No_Source loop ! Src := In_Tree.Sources.Table (Src_Id); + exit when Src.Lang_Kind /= File_Based + or else Src.Kind /= Spec; + + Src_Id := Src.Next_In_Project; + end loop; + + if Src_Id /= No_Source then Error_Msg_Name_1 := Data.Name; Error_Msg_Name_2 := Proj_Data.Name; if Extends then ! if Data.Library_Kind /= Static then ! Error_Msg ! (Project, In_Tree, ! Continuation.all & ! "shared library project %% cannot extend " & ! "project %% that is not a library project", ! Data.Location); ! Continuation := Continuation_String'Access; ! end if; ! elsif Data.Library_Kind /= Static then Error_Msg (Project, In_Tree, Continuation.all & ! "shared library project %% cannot import project %% " & ! "that is not a shared library project", Data.Location); + Continuation := Continuation_String'Access; end if; end if; elsif Data.Library_Kind /= Static and then *************** package body Prj.Nmsc is *** 3607,3612 **** --- 3608,3615 ---- -- Start of processing for Check_Library_Attributes begin + Library_Directory_Present := Lib_Dir.Value /= Empty_String; + -- Special case of extending project if Data.Extends /= No_Project then *************** package body Prj.Nmsc is *** 3620,3636 **** -- directory is specified. if Extended_Data.Library then ! if Lib_Name.Default then ! Data.Library_Name := Extended_Data.Library_Name; ! end if; ! if Lib_Dir.Default then ! if not Data.Virtual then ! Error_Msg ! (Project, In_Tree, ! "a project extending a library project must " & ! "specify an attribute Library_Dir", ! Data.Location); end if; end if; end if; --- 3623,3654 ---- -- directory is specified. if Extended_Data.Library then ! if Data.Qualifier = Standard then ! Error_Msg ! (Project, In_Tree, ! "a standard project cannot extend a library project", ! Data.Location); ! else ! if Lib_Name.Default then ! Data.Library_Name := Extended_Data.Library_Name; ! end if; ! ! if Lib_Dir.Default then ! if not Data.Virtual then ! Error_Msg ! (Project, In_Tree, ! "a project extending a library project must " & ! "specify an attribute Library_Dir", ! Data.Location); ! ! else ! -- For a virtual project extending a library project, ! -- inherit library directory. ! ! Data.Library_Dir := Extended_Data.Library_Dir; ! Library_Directory_Present := True; ! end if; end if; end if; end if; *************** package body Prj.Nmsc is *** 3661,3686 **** pragma Assert (Lib_Dir.Kind = Single); ! if Lib_Dir.Value = Empty_String then if Current_Verbosity = High then Write_Line ("No library directory"); end if; else ! -- Find path name, check that it is a directory ! Locate_Directory ! (Project, ! In_Tree, ! File_Name_Type (Lib_Dir.Value), ! Data.Display_Directory, ! Data.Library_Dir, ! Data.Display_Library_Dir, ! Create => "library", ! Current_Dir => Current_Dir, ! Location => Lib_Dir.Location); ! if Data.Library_Dir = No_Path then -- Get the absolute name of the library directory that -- does not exist, to report an error. --- 3679,3706 ---- pragma Assert (Lib_Dir.Kind = Single); ! if not Library_Directory_Present then if Current_Verbosity = High then Write_Line ("No library directory"); end if; else ! -- Find path name (unless inherited), check that it is a directory ! if Data.Library_Dir = No_Path_Information then ! Locate_Directory ! (Project, ! In_Tree, ! File_Name_Type (Lib_Dir.Value), ! Data.Directory.Display_Name, ! Data.Library_Dir.Name, ! Data.Library_Dir.Display_Name, ! Create => "library", ! Current_Dir => Current_Dir, ! Location => Lib_Dir.Location); ! end if; ! if Data.Library_Dir = No_Path_Information then -- Get the absolute name of the library directory that -- does not exist, to report an error. *************** package body Prj.Nmsc is *** 3695,3701 **** File_Name_Type (Lib_Dir.Value); else ! Get_Name_String (Data.Display_Directory); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; --- 3715,3721 ---- File_Name_Type (Lib_Dir.Value); else ! Get_Name_String (Data.Directory.Display_Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; *************** package body Prj.Nmsc is *** 3720,3733 **** -- The library directory cannot be the same as the Object -- directory. ! elsif Data.Library_Dir = Data.Object_Directory then Error_Msg (Project, In_Tree, "library directory cannot be the same " & "as object directory", Lib_Dir.Location); ! Data.Library_Dir := No_Path; ! Data.Display_Library_Dir := No_Path; else declare --- 3740,3752 ---- -- The library directory cannot be the same as the Object -- directory. ! elsif Data.Library_Dir.Name = Data.Object_Directory.Name then Error_Msg (Project, In_Tree, "library directory cannot be the same " & "as object directory", Lib_Dir.Location); ! Data.Library_Dir := No_Path_Information; else declare *************** package body Prj.Nmsc is *** 3744,3750 **** Dir_Elem := In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; ! if Data.Library_Dir = Path_Name_Type (Dir_Elem.Value) then Err_Vars.Error_Msg_File_1 := File_Name_Type (Dir_Elem.Value); Error_Msg --- 3763,3771 ---- Dir_Elem := In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; ! if ! Data.Library_Dir.Name = Path_Name_Type (Dir_Elem.Value) ! then Err_Vars.Error_Msg_File_1 := File_Name_Type (Dir_Elem.Value); Error_Msg *************** package body Prj.Nmsc is *** 3772,3778 **** In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; ! if Data.Library_Dir = Path_Name_Type (Dir_Elem.Value) then Err_Vars.Error_Msg_File_1 := --- 3793,3799 ---- In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; ! if Data.Library_Dir.Name = Path_Name_Type (Dir_Elem.Value) then Err_Vars.Error_Msg_File_1 := *************** package body Prj.Nmsc is *** 3794,3808 **** end if; if not OK then ! Data.Library_Dir := No_Path; ! Data.Display_Library_Dir := No_Path; elsif Current_Verbosity = High then -- Display the Library directory in high verbosity Write_Str ("Library directory ="""); ! Write_Str (Get_Name_String (Data.Display_Library_Dir)); Write_Line (""""); end if; end; --- 3815,3829 ---- end if; if not OK then ! Data.Library_Dir := No_Path_Information; elsif Current_Verbosity = High then -- Display the Library directory in high verbosity Write_Str ("Library directory ="""); ! Write_Str ! (Get_Name_String (Data.Library_Dir.Display_Name)); Write_Line (""""); end if; end; *************** package body Prj.Nmsc is *** 3812,3821 **** end if; Data.Library := ! Data.Library_Dir /= No_Path and then Data.Library_Name /= No_Name; if Data.Library then if Get_Mode = Multi_Language then Support_For_Libraries := Data.Config.Lib_Support; --- 3833,3866 ---- end if; Data.Library := ! Data.Library_Dir /= No_Path_Information and then Data.Library_Name /= No_Name; + if Data.Extends = No_Project then + case Data.Qualifier is + when Standard => + if Data.Library then + Error_Msg + (Project, In_Tree, + "a standard project cannot be a library project", + Lib_Name.Location); + end if; + + when Library => + if not Data.Library then + Error_Msg + (Project, In_Tree, + "not a library project", + Data.Location); + end if; + + when others => + null; + + end case; + end if; + if Data.Library then if Get_Mode = Multi_Language then Support_For_Libraries := Data.Config.Lib_Support; *************** package body Prj.Nmsc is *** 3837,3843 **** Write_Line ("No library ALI directory specified"); end if; Data.Library_ALI_Dir := Data.Library_Dir; - Data.Display_Library_ALI_Dir := Data.Display_Library_Dir; else -- Find path name, check that it is a directory --- 3882,3887 ---- *************** package body Prj.Nmsc is *** 3846,3859 **** (Project, In_Tree, File_Name_Type (Lib_ALI_Dir.Value), ! Data.Display_Directory, ! Data.Library_ALI_Dir, ! Data.Display_Library_ALI_Dir, Create => "library ALI", Current_Dir => Current_Dir, Location => Lib_ALI_Dir.Location); ! if Data.Library_ALI_Dir = No_Path then -- Get the absolute name of the library ALI directory that -- does not exist, to report an error. --- 3890,3903 ---- (Project, In_Tree, File_Name_Type (Lib_ALI_Dir.Value), ! Data.Directory.Display_Name, ! Data.Library_ALI_Dir.Name, ! Data.Library_ALI_Dir.Display_Name, Create => "library ALI", Current_Dir => Current_Dir, Location => Lib_ALI_Dir.Location); ! if Data.Library_ALI_Dir = No_Path_Information then -- Get the absolute name of the library ALI directory that -- does not exist, to report an error. *************** package body Prj.Nmsc is *** 3868,3874 **** File_Name_Type (Lib_Dir.Value); else ! Get_Name_String (Data.Display_Directory); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; --- 3912,3918 ---- File_Name_Type (Lib_Dir.Value); else ! Get_Name_String (Data.Directory.Display_Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; *************** package body Prj.Nmsc is *** 3902,3909 **** "library 'A'L'I directory cannot be the same " & "as object directory", Lib_ALI_Dir.Location); ! Data.Library_ALI_Dir := No_Path; ! Data.Display_Library_ALI_Dir := No_Path; else declare --- 3946,3952 ---- "library 'A'L'I directory cannot be the same " & "as object directory", Lib_ALI_Dir.Location); ! Data.Library_ALI_Dir := No_Path_Information; else declare *************** package body Prj.Nmsc is *** 3920,3926 **** Dir_Elem := In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; ! if Data.Library_ALI_Dir = Path_Name_Type (Dir_Elem.Value) then Err_Vars.Error_Msg_File_1 := --- 3963,3969 ---- Dir_Elem := In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; ! if Data.Library_ALI_Dir.Name = Path_Name_Type (Dir_Elem.Value) then Err_Vars.Error_Msg_File_1 := *************** package body Prj.Nmsc is *** 3954,3960 **** In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; ! if Data.Library_ALI_Dir = Path_Name_Type (Dir_Elem.Value) then Err_Vars.Error_Msg_File_1 := --- 3997,4003 ---- In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; ! if Data.Library_ALI_Dir.Name = Path_Name_Type (Dir_Elem.Value) then Err_Vars.Error_Msg_File_1 := *************** package body Prj.Nmsc is *** 3977,3984 **** end if; if not OK then ! Data.Library_ALI_Dir := No_Path; ! Data.Display_Library_ALI_Dir := No_Path; elsif Current_Verbosity = High then --- 4020,4026 ---- end if; if not OK then ! Data.Library_ALI_Dir := No_Path_Information; elsif Current_Verbosity = High then *************** package body Prj.Nmsc is *** 3987,3993 **** Write_Str ("Library ALI directory ="""); Write_Str ! (Get_Name_String (Data.Display_Library_ALI_Dir)); Write_Line (""""); end if; end; --- 4029,4036 ---- Write_Str ("Library ALI directory ="""); Write_Str ! (Get_Name_String ! (Data.Library_ALI_Dir.Display_Name)); Write_Line (""""); end if; end; *************** package body Prj.Nmsc is *** 4082,4087 **** --- 4125,4171 ---- end if; end if; + -- Check if Linker'Switches or Linker'Default_Switches are declared. + -- Warn if they are declared, as it is a common error to think that + -- library are "linked" with Linker switches. + + if Data.Library then + declare + Linker_Package_Id : constant Package_Id := + Util.Value_Of + (Name_Linker, Data.Decl.Packages, In_Tree); + Linker_Package : Package_Element; + Switches : Array_Element_Id := No_Array_Element; + + begin + if Linker_Package_Id /= No_Package then + Linker_Package := In_Tree.Packages.Table (Linker_Package_Id); + + Switches := + Value_Of + (Name => Name_Switches, + In_Arrays => Linker_Package.Decl.Arrays, + In_Tree => In_Tree); + + if Switches = No_Array_Element then + Switches := + Value_Of + (Name => Name_Default_Switches, + In_Arrays => Linker_Package.Decl.Arrays, + In_Tree => In_Tree); + end if; + + if Switches /= No_Array_Element then + Error_Msg + (Project, In_Tree, + "?Linker switches not taken into account in library " & + "projects", + No_Location); + end if; + end if; + end; + end if; + if Data.Extends /= No_Project then In_Tree.Projects.Table (Data.Extends).Library := False; end if; *************** package body Prj.Nmsc is *** 4126,4132 **** Suffix2 : Array_Element_Id; begin ! -- If some suffixs have been specified, we make sure that -- for each language for which a default suffix has been -- specified, there is a suffix specified, either the one -- in the project file or if there were none, the default. --- 4210,4216 ---- Suffix2 : Array_Element_Id; begin ! -- If some suffixes have been specified, we make sure that -- for each language for which a default suffix has been -- specified, there is a suffix specified, either the one -- in the project file or if there were none, the default. *************** package body Prj.Nmsc is *** 4168,4174 **** Suffix := Element.Next; end loop; ! -- Put the resulting array as the specification suffixs Data.Naming.Spec_Suffix := Spec_Suffixs; end if; --- 4252,4258 ---- Suffix := Element.Next; end loop; ! -- Put the resulting array as the specification suffixes Data.Naming.Spec_Suffix := Spec_Suffixs; end if; *************** package body Prj.Nmsc is *** 4250,4256 **** Suffix := Element.Next; end loop; ! -- Put the resulting array as the implementation suffixs Data.Naming.Body_Suffix := Impl_Suffixs; end if; --- 4334,4340 ---- Suffix := Element.Next; end loop; ! -- Put the resulting array as the implementation suffixes Data.Naming.Body_Suffix := Impl_Suffixs; end if; *************** package body Prj.Nmsc is *** 4336,4351 **** (Name => Name_Ada, Next => No_Name_List); -- Attribute Languages is not specified. So, it defaults to ! -- a project of language Ada only. ! ! Data.Langs (Ada_Language_Index) := True; ! ! -- No sources of languages other than Ada Data.Other_Sources_Present := False; else ! -- If the configuration file does not define a language either if Def_Lang.Default then if not Default_Language_Is_Ada then --- 4420,4432 ---- (Name => Name_Ada, Next => No_Name_List); -- Attribute Languages is not specified. So, it defaults to ! -- a project of language Ada only. No sources of languages ! -- other than Ada Data.Other_Sources_Present := False; else ! -- Fail if there is no default language defined if Def_Lang.Default then if not Default_Language_Is_Ada then *************** package body Prj.Nmsc is *** 4360,4367 **** end if; else - -- ??? Are we supporting a single default language in the - -- configuration file ? Get_Name_String (Def_Lang.Value); To_Lower (Name_Buffer (1 .. Name_Len)); Def_Lang_Id := Name_Find; --- 4441,4446 ---- *************** package body Prj.Nmsc is *** 4412,4430 **** NL_Id : Name_List_Index := No_Name_List; begin ! if Get_Mode = Ada_Only then ! ! -- Assume that there is no language specified yet ! Data.Other_Sources_Present := False; ! Data.Ada_Sources_Present := False; ! end if; -- If there are no languages declared, there are no sources if Current = Nil_String then Data.Source_Dirs := Nil_String; else -- Look through all the languages specified in attribute -- Languages. --- 4491,4514 ---- NL_Id : Name_List_Index := No_Name_List; begin ! -- Assume there are no language declared ! Data.Ada_Sources_Present := False; ! Data.Other_Sources_Present := False; -- If there are no languages declared, there are no sources if Current = Nil_String then Data.Source_Dirs := Nil_String; + if Data.Qualifier = Standard then + Error_Msg + (Project, + In_Tree, + "a standard project cannot have no language declared", + Languages.Location); + end if; + else -- Look through all the languages specified in attribute -- Languages. *************** package body Prj.Nmsc is *** 4467,4487 **** (Lang_Name, No_Name_List); if Get_Mode = Ada_Only then ! Index := Language_Indexes.Get (Lang_Name); ! ! if Index = No_Language_Index then ! Add_Language_Name (Lang_Name); ! Index := Last_Language_Index; ! end if; ! ! Set (Index, True, Data, In_Tree); ! Set (Language_Processing => ! Default_Language_Processing_Data, ! For_Language => Index, ! In_Project => Data, ! In_Tree => In_Tree); ! if Index = Ada_Language_Index then Data.Ada_Sources_Present := True; else --- 4551,4559 ---- (Lang_Name, No_Name_List); if Get_Mode = Ada_Only then ! -- Check for language Ada ! if Lang_Name = Name_Ada then Data.Ada_Sources_Present := True; else *************** package body Prj.Nmsc is *** 4715,4722 **** In_Tree.Units.Table (The_Unit_Id); if The_Unit_Data.File_Names (Body_Part).Name /= No_File ! and then The_Unit_Data.File_Names (Body_Part).Path /= ! Slash then if Check_Project (The_Unit_Data.File_Names (Body_Part).Project, --- 4787,4794 ---- In_Tree.Units.Table (The_Unit_Id); if The_Unit_Data.File_Names (Body_Part).Name /= No_File ! and then The_Unit_Data.File_Names ! (Body_Part).Path.Name /= Slash then if Check_Project (The_Unit_Data.File_Names (Body_Part).Project, *************** package body Prj.Nmsc is *** 4736,4742 **** Src_Ind := Sinput.P.Load_Project_File (Get_Name_String (The_Unit_Data.File_Names ! (Body_Part).Path)); if Sinput.P.Source_File_Is_Subunit (Src_Ind) --- 4808,4814 ---- Src_Ind := Sinput.P.Load_Project_File (Get_Name_String (The_Unit_Data.File_Names ! (Body_Part).Path.Name)); if Sinput.P.Source_File_Is_Subunit (Src_Ind) *************** package body Prj.Nmsc is *** 4770,4776 **** elsif The_Unit_Data.File_Names (Specification).Name /= No_File and then The_Unit_Data.File_Names ! (Specification).Path /= Slash and then Check_Project (The_Unit_Data.File_Names (Specification).Project, --- 4842,4848 ---- elsif The_Unit_Data.File_Names (Specification).Name /= No_File and then The_Unit_Data.File_Names ! (Specification).Path.Name /= Slash and then Check_Project (The_Unit_Data.File_Names (Specification).Project, *************** package body Prj.Nmsc is *** 4853,4860 **** In_Tree.Sources.Table (Source).Other_Part /= No_Source then ! Source := ! In_Tree.Sources.Table (Source).Other_Part; end if; String_Element_Table.Increment_Last --- 4925,4931 ---- In_Tree.Sources.Table (Source).Other_Part /= No_Source then ! Source := In_Tree.Sources.Table (Source).Other_Part; end if; String_Element_Table.Increment_Last *************** package body Prj.Nmsc is *** 4945,4960 **** (Project, In_Tree, Dir_Id, ! Data.Display_Directory, ! Data.Library_Src_Dir, ! Data.Display_Library_Src_Dir, Create => "library source copy", Current_Dir => Current_Dir, Location => Lib_Src_Dir.Location); -- If directory does not exist, report an error ! if Data.Library_Src_Dir = No_Path then -- Get the absolute name of the library directory that does -- not exist, to report an error. --- 5016,5031 ---- (Project, In_Tree, Dir_Id, ! Data.Directory.Display_Name, ! Data.Library_Src_Dir.Name, ! Data.Library_Src_Dir.Display_Name, Create => "library source copy", Current_Dir => Current_Dir, Location => Lib_Src_Dir.Location); -- If directory does not exist, report an error ! if Data.Library_Src_Dir = No_Path_Information then -- Get the absolute name of the library directory that does -- not exist, to report an error. *************** package body Prj.Nmsc is *** 4968,4974 **** Err_Vars.Error_Msg_File_1 := Dir_Id; else ! Get_Name_String (Data.Directory); if Name_Buffer (Name_Len) /= Directory_Separator --- 5039,5045 ---- Err_Vars.Error_Msg_File_1 := Dir_Id; else ! Get_Name_String (Data.Directory.Name); if Name_Buffer (Name_Len) /= Directory_Separator *************** package body Prj.Nmsc is *** 5003,5009 **** "directory to copy interfaces cannot be " & "the object directory", Lib_Src_Dir.Location); ! Data.Library_Src_Dir := No_Path; else declare --- 5074,5080 ---- "directory to copy interfaces cannot be " & "the object directory", Lib_Src_Dir.Location); ! Data.Library_Src_Dir := No_Path_Information; else declare *************** package body Prj.Nmsc is *** 5020,5026 **** -- Report error if it is one of the source directories ! if Data.Library_Src_Dir = Path_Name_Type (Src_Dir.Value) then Error_Msg --- 5091,5097 ---- -- Report error if it is one of the source directories ! if Data.Library_Src_Dir.Name = Path_Name_Type (Src_Dir.Value) then Error_Msg *************** package body Prj.Nmsc is *** 5028,5041 **** "directory to copy interfaces cannot " & "be one of the source directories", Lib_Src_Dir.Location); ! Data.Library_Src_Dir := No_Path; exit; end if; Src_Dirs := Src_Dir.Next; end loop; ! if Data.Library_Src_Dir /= No_Path then -- It cannot be a source directory of any other -- project either. --- 5099,5112 ---- "directory to copy interfaces cannot " & "be one of the source directories", Lib_Src_Dir.Location); ! Data.Library_Src_Dir := No_Path_Information; exit; end if; Src_Dirs := Src_Dir.Next; end loop; ! if Data.Library_Src_Dir /= No_Path_Information then -- It cannot be a source directory of any other -- project either. *************** package body Prj.Nmsc is *** 5052,5058 **** -- Report error if it is one of the source -- directories ! if Data.Library_Src_Dir = Path_Name_Type (Src_Dir.Value) then Error_Msg_File_1 := --- 5123,5129 ---- -- Report error if it is one of the source -- directories ! if Data.Library_Src_Dir.Name = Path_Name_Type (Src_Dir.Value) then Error_Msg_File_1 := *************** package body Prj.Nmsc is *** 5065,5071 **** "be the same as source directory { of " & "project %%", Lib_Src_Dir.Location); ! Data.Library_Src_Dir := No_Path; exit Project_Loop; end if; --- 5136,5142 ---- "be the same as source directory { of " & "project %%", Lib_Src_Dir.Location); ! Data.Library_Src_Dir := No_Path_Information; exit Project_Loop; end if; *************** package body Prj.Nmsc is *** 5078,5088 **** -- In high verbosity, if there is a valid Library_Src_Dir, -- display its path name. ! if Data.Library_Src_Dir /= No_Path and then Current_Verbosity = High then Write_Str ("Directory to copy interfaces ="""); ! Write_Str (Get_Name_String (Data.Library_Src_Dir)); Write_Line (""""); end if; end if; --- 5149,5159 ---- -- In high verbosity, if there is a valid Library_Src_Dir, -- display its path name. ! if Data.Library_Src_Dir /= No_Path_Information and then Current_Verbosity = High then Write_Str ("Directory to copy interfaces ="""); ! Write_Str (Get_Name_String (Data.Library_Src_Dir.Name)); Write_Line (""""); end if; end if; *************** package body Prj.Nmsc is *** 5171,5184 **** Error_Msg (Project, In_Tree, "symbol file name { is illegal. " & ! "Name canot include directory info.", Lib_Symbol_File.Location); end if; end if; end if; -- If attribute Library_Reference_Symbol_File is not defined, ! -- symbol policy cannot be Compilant or Controlled. if Lib_Ref_Symbol_File.Default then if Data.Symbol_Data.Symbol_Policy = Compliant --- 5242,5255 ---- Error_Msg (Project, In_Tree, "symbol file name { is illegal. " & ! "Name cannot include directory info.", Lib_Symbol_File.Location); end if; end if; end if; -- If attribute Library_Reference_Symbol_File is not defined, ! -- symbol policy cannot be Compliant or Controlled. if Lib_Ref_Symbol_File.Default then if Data.Symbol_Data.Symbol_Policy = Compliant *************** package body Prj.Nmsc is *** 5207,5213 **** else if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then Name_Len := 0; ! Add_Str_To_Name_Buffer (Get_Name_String (Data.Directory)); Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer (Get_Name_String (Lib_Ref_Symbol_File.Value)); --- 5278,5285 ---- else if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then Name_Len := 0; ! Add_Str_To_Name_Buffer ! (Get_Name_String (Data.Directory.Name)); Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer (Get_Name_String (Lib_Ref_Symbol_File.Value)); *************** package body Prj.Nmsc is *** 5256,5262 **** Symb_Path : constant String := Normalize_Pathname (Get_Name_String ! (Data.Object_Directory) & Directory_Separator & Name_Buffer (1 .. Name_Len), Directory => Current_Dir, --- 5328,5334 ---- Symb_Path : constant String := Normalize_Pathname (Get_Name_String ! (Data.Object_Directory.Name) & Directory_Separator & Name_Buffer (1 .. Name_Len), Directory => Current_Dir, *************** package body Prj.Nmsc is *** 5419,5429 **** if Msg (First) = '\' then First := First + 1; ! -- Warning character is always the first one in this package ! -- this is an undocumented kludge??? ! elsif Msg (First) = '?' then First := First + 1; Add ("Warning: "); --- 5491,5502 ---- if Msg (First) = '\' then First := First + 1; + end if; ! -- Warning character is always the first one in this package ! -- this is an undocumented kludge??? ! if Msg (First) = '?' then First := First + 1; Add ("Warning: "); *************** package body Prj.Nmsc is *** 5582,5736 **** end Find_Ada_Sources; - ------------------ - -- Find_Sources -- - ------------------ - - procedure Find_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Data : in out Project_Data; - For_Language : Language_Index; - Current_Dir : String) - is - Source_Dir : String_List_Id; - Element : String_Element; - Dir : Dir_Type; - Current_Source : String_List_Id := Nil_String; - Source_Recorded : Boolean := False; - - begin - if Current_Verbosity = High then - Write_Line ("Looking for sources:"); - end if; - - -- Loop through subdirectories - - Source_Dir := Data.Source_Dirs; - while Source_Dir /= Nil_String loop - begin - Source_Recorded := False; - Element := In_Tree.String_Elements.Table (Source_Dir); - - if Element.Value /= No_Name then - Get_Name_String (Element.Display_Value); - - declare - Source_Directory : constant String := - Name_Buffer (1 .. Name_Len) & - Directory_Separator; - - Dir_Last : constant Natural := - Compute_Directory_Last (Source_Directory); - - begin - if Current_Verbosity = High then - Write_Str ("Source_Dir = "); - Write_Line (Source_Directory); - end if; - - -- We look to every entry in the source directory - - Open (Dir, Source_Directory - (Source_Directory'First .. Dir_Last)); - - loop - Read (Dir, Name_Buffer, Name_Len); - - if Current_Verbosity = High then - Write_Str (" Checking "); - Write_Line (Name_Buffer (1 .. Name_Len)); - end if; - - exit when Name_Len = 0; - - declare - File_Name : constant File_Name_Type := Name_Find; - Path : constant String := - Normalize_Pathname - (Name => Name_Buffer (1 .. Name_Len), - Directory => Source_Directory - (Source_Directory'First .. Dir_Last), - Resolve_Links => Opt.Follow_Links_For_Files, - Case_Sensitive => True); - Path_Name : Path_Name_Type; - - begin - Name_Len := Path'Length; - Name_Buffer (1 .. Name_Len) := Path; - Path_Name := Name_Find; - - if For_Language = Ada_Language_Index then - - -- We attempt to register it as a source. However, - -- there is no error if the file does not contain - -- a valid source. But there is an error if we have - -- a duplicate unit name. - - Record_Ada_Source - (File_Name => File_Name, - Path_Name => Path_Name, - Project => Project, - In_Tree => In_Tree, - Data => Data, - Location => No_Location, - Current_Source => Current_Source, - Source_Recorded => Source_Recorded, - Current_Dir => Current_Dir); - - else - Check_For_Source - (File_Name => File_Name, - Path_Name => Path_Name, - Project => Project, - In_Tree => In_Tree, - Data => Data, - Location => No_Location, - Language => For_Language, - Suffix => - Body_Suffix_Of (For_Language, Data, In_Tree), - Naming_Exception => False); - end if; - end; - end loop; - - Close (Dir); - end; - end if; - - exception - when Directory_Error => - null; - end; - - if Source_Recorded then - In_Tree.String_Elements.Table (Source_Dir).Flag := - True; - end if; - - Source_Dir := Element.Next; - end loop; - - if Current_Verbosity = High then - Write_Line ("end Looking for sources."); - end if; - - if For_Language = Ada_Language_Index then - - -- If we have looked for sources and found none, then it is an error, - -- except if it is an extending project. If a non extending project - -- is not supposed to contain any source files, then never call - -- Find_Sources. - - if Current_Source /= Nil_String then - Data.Ada_Sources_Present := True; - - elsif Data.Extends = No_Project then - Report_No_Sources (Project, "Ada", In_Tree, Data.Location); - end if; - end if; - end Find_Sources; - -------------------------------- -- Free_Ada_Naming_Exceptions -- -------------------------------- --- 5655,5660 ---- *************** package body Prj.Nmsc is *** 5879,5890 **** String_Element_Table.Increment_Last (In_Tree.String_Elements); Element := ! (Value => Canonical_Path, Display_Value => Non_Canonical_Path, ! Location => No_Location, ! Flag => False, ! Next => Nil_String, ! Index => 0); -- Case of first source directory --- 5803,5814 ---- String_Element_Table.Increment_Last (In_Tree.String_Elements); Element := ! (Value => Canonical_Path, Display_Value => Non_Canonical_Path, ! Location => No_Location, ! Flag => False, ! Next => Nil_String, ! Index => 0); -- Case of first source directory *************** package body Prj.Nmsc is *** 6016,6022 **** Normalize_Pathname (Name => Get_Name_String (Base_Dir), Directory => ! Get_Name_String (Data.Display_Directory), Resolve_Links => False, Case_Sensitive => True); --- 5940,5946 ---- Normalize_Pathname (Name => Get_Name_String (Base_Dir), Directory => ! Get_Name_String (Data.Directory.Display_Name), Resolve_Links => False, Case_Sensitive => True); *************** package body Prj.Nmsc is *** 6068,6074 **** (Project => Project, In_Tree => In_Tree, Name => From, ! Parent => Data.Display_Directory, Dir => Path_Name, Display => Display_Path_Name, Current_Dir => Current_Dir); --- 5992,5998 ---- (Project => Project, In_Tree => In_Tree, Name => From, ! Parent => Data.Directory.Display_Name, Dir => Path_Name, Display => Display_Path_Name, Current_Dir => Current_Dir); *************** package body Prj.Nmsc is *** 6202,6209 **** -- We set the object directory to its default ! Data.Object_Directory := Data.Directory; ! Data.Display_Object_Dir := Data.Display_Directory; if Object_Dir.Value /= Empty_String then Get_Name_String (Object_Dir.Value); --- 6126,6132 ---- -- We set the object directory to its default ! Data.Object_Directory := Data.Directory; if Object_Dir.Value /= Empty_String then Get_Name_String (Object_Dir.Value); *************** package body Prj.Nmsc is *** 6221,6234 **** (Project, In_Tree, File_Name_Type (Object_Dir.Value), ! Data.Display_Directory, ! Data.Object_Directory, ! Data.Display_Object_Dir, Create => "object", Location => Object_Dir.Location, Current_Dir => Current_Dir); ! if Data.Object_Directory = No_Path then -- The object directory does not exist, report an error if the -- project is not externally built. --- 6144,6157 ---- (Project, In_Tree, File_Name_Type (Object_Dir.Value), ! Data.Directory.Display_Name, ! Data.Object_Directory.Name, ! Data.Object_Directory.Display_Name, Create => "object", Location => Object_Dir.Location, Current_Dir => Current_Dir); ! if Data.Object_Directory = No_Path_Information then -- The object directory does not exist, report an error if the -- project is not externally built. *************** package body Prj.Nmsc is *** 6247,6271 **** -- tools that recover from errors; for example, these tools -- could create the non existent directory. ! Data.Display_Object_Dir := Path_Name_Type (Object_Dir.Value); if Osint.File_Names_Case_Sensitive then ! Data.Object_Directory := Path_Name_Type (Object_Dir.Value); else Get_Name_String (Object_Dir.Value); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); ! Data.Object_Directory := Name_Find; end if; end if; end if; end if; if Current_Verbosity = High then ! if Data.Object_Directory = No_Path then Write_Line ("No object directory"); else Write_Str ("Object directory: """); ! Write_Str (Get_Name_String (Data.Display_Object_Dir)); Write_Line (""""); end if; end if; --- 6170,6210 ---- -- tools that recover from errors; for example, these tools -- could create the non existent directory. ! Data.Object_Directory.Display_Name := ! Path_Name_Type (Object_Dir.Value); if Osint.File_Names_Case_Sensitive then ! Data.Object_Directory.Name := ! Path_Name_Type (Object_Dir.Value); else Get_Name_String (Object_Dir.Value); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); ! Data.Object_Directory.Name := Name_Find; end if; end if; end if; + + elsif Subdirs /= null then + Name_Len := 1; + Name_Buffer (1) := '.'; + Locate_Directory + (Project, + In_Tree, + Name_Find, + Data.Directory.Display_Name, + Data.Object_Directory.Name, + Data.Object_Directory.Display_Name, + Create => "object", + Location => Object_Dir.Location, + Current_Dir => Current_Dir); end if; if Current_Verbosity = High then ! if Data.Object_Directory = No_Path_Information then Write_Line ("No object directory"); else Write_Str ("Object directory: """); ! Write_Str (Get_Name_String (Data.Object_Directory.Display_Name)); Write_Line (""""); end if; end if; *************** package body Prj.Nmsc is *** 6278,6284 **** -- We set the object directory to its default Data.Exec_Directory := Data.Object_Directory; - Data.Display_Exec_Dir := Data.Display_Object_Dir; if Exec_Dir.Value /= Empty_String then Get_Name_String (Exec_Dir.Value); --- 6217,6222 ---- *************** package body Prj.Nmsc is *** 6290,6309 **** Exec_Dir.Location); else ! -- We check that the specified object directory does exist Locate_Directory (Project, In_Tree, File_Name_Type (Exec_Dir.Value), ! Data.Display_Directory, ! Data.Exec_Directory, ! Data.Display_Exec_Dir, Create => "exec", Location => Exec_Dir.Location, Current_Dir => Current_Dir); ! if Data.Exec_Directory = No_Path then Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); Error_Msg (Project, In_Tree, --- 6228,6247 ---- Exec_Dir.Location); else ! -- We check that the specified exec directory does exist Locate_Directory (Project, In_Tree, File_Name_Type (Exec_Dir.Value), ! Data.Directory.Display_Name, ! Data.Exec_Directory.Name, ! Data.Exec_Directory.Display_Name, Create => "exec", Location => Exec_Dir.Location, Current_Dir => Current_Dir); ! if Data.Exec_Directory = No_Path_Information then Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); Error_Msg (Project, In_Tree, *************** package body Prj.Nmsc is *** 6314,6324 **** end if; if Current_Verbosity = High then ! if Data.Exec_Directory = No_Path then Write_Line ("No exec directory"); else Write_Str ("Exec directory: """); ! Write_Str (Get_Name_String (Data.Display_Exec_Dir)); Write_Line (""""); end if; end if; --- 6252,6262 ---- end if; if Current_Verbosity = High then ! if Data.Exec_Directory = No_Path_Information then Write_Line ("No exec directory"); else Write_Str ("Exec directory: """); ! Write_Str (Get_Name_String (Data.Exec_Directory.Display_Name)); Write_Line (""""); end if; end if; *************** package body Prj.Nmsc is *** 6336,6345 **** then Data.Source_Dirs := Nil_String; if Data.Extends = No_Project and then Data.Object_Directory = Data.Directory then ! Data.Object_Directory := No_Path; end if; elsif Source_Dirs.Default then --- 6274,6291 ---- then Data.Source_Dirs := Nil_String; + if Data.Qualifier = Standard then + Error_Msg + (Project, + In_Tree, + "a standard project cannot have no sources", + Source_Files.Location); + end if; + if Data.Extends = No_Project and then Data.Object_Directory = Data.Directory then ! Data.Object_Directory := No_Path_Information; end if; elsif Source_Dirs.Default then *************** package body Prj.Nmsc is *** 6352,6359 **** Data.Source_Dirs := String_Element_Table.Last (In_Tree.String_Elements); In_Tree.String_Elements.Table (Data.Source_Dirs) := ! (Value => Name_Id (Data.Directory), ! Display_Value => Name_Id (Data.Display_Directory), Location => No_Location, Flag => False, Next => Nil_String, --- 6298,6305 ---- Data.Source_Dirs := String_Element_Table.Last (In_Tree.String_Elements); In_Tree.String_Elements.Table (Data.Source_Dirs) := ! (Value => Name_Id (Data.Directory.Name), ! Display_Value => Name_Id (Data.Directory.Display_Name), Location => No_Location, Flag => False, Next => Nil_String, *************** package body Prj.Nmsc is *** 6362,6372 **** if Current_Verbosity = High then Write_Line ("Single source directory:"); Write_Str (" """); ! Write_Str (Get_Name_String (Data.Display_Directory)); Write_Line (""""); end if; elsif Source_Dirs.Values = Nil_String then -- If Source_Dirs is an empty string list, this means that this -- project contains no source. For projects that don't extend other --- 6308,6325 ---- if Current_Verbosity = High then Write_Line ("Single source directory:"); Write_Str (" """); ! Write_Str (Get_Name_String (Data.Directory.Display_Name)); Write_Line (""""); end if; elsif Source_Dirs.Values = Nil_String then + if Data.Qualifier = Standard then + Error_Msg + (Project, + In_Tree, + "a standard project cannot have no source directories", + Source_Dirs.Location); + end if; -- If Source_Dirs is an empty string list, this means that this -- project contains no source. For projects that don't extend other *************** package body Prj.Nmsc is *** 6376,6385 **** if Data.Extends = No_Project and then Data.Object_Directory = Data.Directory then ! Data.Object_Directory := No_Path; end if; ! Data.Source_Dirs := Nil_String; else declare --- 6329,6338 ---- if Data.Extends = No_Project and then Data.Object_Directory = Data.Directory then ! Data.Object_Directory := No_Path_Information; end if; ! Data.Source_Dirs := Nil_String; else declare *************** package body Prj.Nmsc is *** 6391,6398 **** Source_Dir := Source_Dirs.Values; while Source_Dir /= Nil_String loop ! Element := ! In_Tree.String_Elements.Table (Source_Dir); Find_Source_Dirs (File_Name_Type (Element.Value), Element.Location); Source_Dir := Element.Next; --- 6344,6350 ---- Source_Dir := Source_Dirs.Values; while Source_Dir /= Nil_String loop ! Element := In_Tree.String_Elements.Table (Source_Dir); Find_Source_Dirs (File_Name_Type (Element.Value), Element.Location); Source_Dir := Element.Next; *************** package body Prj.Nmsc is *** 6412,6419 **** Source_Dir := Excluded_Source_Dirs.Values; while Source_Dir /= Nil_String loop ! Element := ! In_Tree.String_Elements.Table (Source_Dir); Find_Source_Dirs (File_Name_Type (Element.Value), Element.Location, --- 6364,6370 ---- Source_Dir := Excluded_Source_Dirs.Values; while Source_Dir /= Nil_String loop ! Element := In_Tree.String_Elements.Table (Source_Dir); Find_Source_Dirs (File_Name_Type (Element.Value), Element.Location, *************** package body Prj.Nmsc is *** 6469,6475 **** -- inherit the Mains from the project we are extending. if Mains.Default then ! if Data.Extends /= No_Project then Data.Mains := In_Tree.Projects.Table (Data.Extends).Mains; end if; --- 6420,6426 ---- -- inherit the Mains from the project we are extending. if Mains.Default then ! if not Data.Library and then Data.Extends /= No_Project then Data.Mains := In_Tree.Projects.Table (Data.Extends).Mains; end if; *************** package body Prj.Nmsc is *** 6517,6522 **** --- 6468,6474 ---- if not Prj.Util.Is_Valid (File) then Error_Msg (Project, In_Tree, "file does not exist", Location); + else -- Read the lines one by one *************** package body Prj.Nmsc is *** 6622,6630 **** Last : Natural := File'Last; Standard_GNAT : Boolean; Spec : constant File_Name_Type := ! Spec_Suffix_Id_Of (In_Tree, Name_Ada, Naming); Body_Suff : constant File_Name_Type := ! Body_Suffix_Id_Of (In_Tree, Name_Ada, Naming); begin Standard_GNAT := Spec = Default_Ada_Spec_Suffix --- 6574,6582 ---- Last : Natural := File'Last; Standard_GNAT : Boolean; Spec : constant File_Name_Type := ! Spec_Suffix_Id_Of (In_Tree, Name_Ada, Naming); Body_Suff : constant File_Name_Type := ! Body_Suffix_Id_Of (In_Tree, Name_Ada, Naming); begin Standard_GNAT := Spec = Default_Ada_Spec_Suffix *************** package body Prj.Nmsc is *** 6939,6946 **** Current_Dir : String; Location : Source_Ptr := No_Location) is - The_Name : String := Get_Name_String (Name); - The_Parent : constant String := Get_Name_String (Parent) & Directory_Separator; --- 6891,6896 ---- *************** package body Prj.Nmsc is *** 6949,6966 **** Full_Name : File_Name_Type; begin -- Convert '/' to directory separator (for Windows) ! for J in The_Name'Range loop ! if The_Name (J) = '/' then ! The_Name (J) := Directory_Separator; end if; end loop; if Current_Verbosity = High then Write_Str ("Locate_Directory ("""); ! Write_Str (The_Name); Write_Str (""", """); Write_Str (The_Parent); Write_Line (""")"); --- 6899,6933 ---- Full_Name : File_Name_Type; + The_Name : File_Name_Type; + begin + Get_Name_String (Name); + + -- Add Subdirs.all if it is a directory that may be created and + -- Subdirs is not null; + + if Create /= "" and then Subdirs /= null then + if Name_Buffer (Name_Len) /= Directory_Separator then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Add_Str_To_Name_Buffer (Subdirs.all); + end if; + -- Convert '/' to directory separator (for Windows) ! for J in 1 .. Name_Len loop ! if Name_Buffer (J) = '/' then ! Name_Buffer (J) := Directory_Separator; end if; end loop; + The_Name := Name_Find; + if Current_Verbosity = High then Write_Str ("Locate_Directory ("""); ! Write_Str (Get_Name_String (The_Name)); Write_Str (""", """); Write_Str (The_Parent); Write_Line (""")"); *************** package body Prj.Nmsc is *** 6969,6982 **** Dir := No_Path; Display := No_Path; ! if Is_Absolute_Path (The_Name) then ! Full_Name := Name; else Name_Len := 0; Add_Str_To_Name_Buffer (The_Parent (The_Parent'First .. The_Parent_Last)); ! Add_Str_To_Name_Buffer (The_Name); Full_Name := Name_Find; end if; --- 6936,6949 ---- Dir := No_Path; Display := No_Path; ! if Is_Absolute_Path (Get_Name_String (The_Name)) then ! Full_Name := The_Name; else Name_Len := 0; Add_Str_To_Name_Buffer (The_Parent (The_Parent'First .. The_Parent_Last)); ! Add_Str_To_Name_Buffer (Get_Name_String (The_Name)); Full_Name := Name_Find; end if; *************** package body Prj.Nmsc is *** 6984,6990 **** Full_Path_Name : constant String := Get_Name_String (Full_Name); begin ! if Setup_Projects and then Create'Length > 0 and then not Is_Directory (Full_Path_Name) then begin --- 6951,6958 ---- Full_Path_Name : constant String := Get_Name_String (Full_Name); begin ! if (Setup_Projects or else Subdirs /= null) ! and then Create'Length > 0 and then not Is_Directory (Full_Path_Name) then begin *************** package body Prj.Nmsc is *** 7042,7064 **** --------------------------- procedure Find_Excluded_Sources ! (In_Tree : Project_Tree_Ref; Data : Project_Data) is Excluded_Sources : Variable_Value; ! Current : String_List_Id; ! Element : String_Element; Location : Source_Ptr; ! Name : File_Name_Type; begin ! -- If Excluded_Source_Files is not declared, check ! -- Locally_Removed_Files. Excluded_Sources := Util.Value_Of (Name_Excluded_Source_Files, Data.Decl.Attributes, In_Tree); if Excluded_Sources.Default then Excluded_Sources := Util.Value_Of (Name_Locally_Removed_Files, Data.Decl.Attributes, In_Tree); --- 7010,7050 ---- --------------------------- procedure Find_Excluded_Sources ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; Data : Project_Data) is Excluded_Sources : Variable_Value; ! ! Excluded_Source_List_File : Variable_Value; ! ! Current : String_List_Id; ! ! Element : String_Element; ! Location : Source_Ptr; ! ! Name : File_Name_Type; ! ! File : Prj.Util.Text_File; ! Line : String (1 .. 300); ! Last : Natural; ! ! Locally_Removed : Boolean := False; begin ! Excluded_Source_List_File := ! Util.Value_Of ! (Name_Excluded_Source_List_File, Data.Decl.Attributes, In_Tree); Excluded_Sources := Util.Value_Of (Name_Excluded_Source_Files, Data.Decl.Attributes, In_Tree); + -- If Excluded_Source_Files is not declared, check + -- Locally_Removed_Files. + if Excluded_Sources.Default then + Locally_Removed := True; Excluded_Sources := Util.Value_Of (Name_Locally_Removed_Files, Data.Decl.Attributes, In_Tree); *************** package body Prj.Nmsc is *** 7069,7074 **** --- 7055,7076 ---- -- If there are excluded sources, put them in the table if not Excluded_Sources.Default then + if not Excluded_Source_List_File.Default then + if Locally_Removed then + Error_Msg + (Project, In_Tree, + "?both attributes Locally_Removed_Files and " & + "Excluded_Source_List_File are present", + Excluded_Source_List_File.Location); + else + Error_Msg + (Project, In_Tree, + "?both attributes Excluded_Source_Files and " & + "Excluded_Source_List_File are present", + Excluded_Source_List_File.Location); + end if; + end if; + Current := Excluded_Sources.Values; while Current /= Nil_String loop Element := In_Tree.String_Elements.Table (Current); *************** package body Prj.Nmsc is *** 7093,7098 **** --- 7095,7172 ---- Excluded_Sources_Htable.Set (Name, (Name, False, Location)); Current := Element.Next; end loop; + + elsif not Excluded_Source_List_File.Default then + Location := Excluded_Source_List_File.Location; + + declare + Source_File_Path_Name : constant String := + Path_Name_Of + (File_Name_Type + (Excluded_Source_List_File.Value), + Data.Directory.Name); + + begin + if Source_File_Path_Name'Length = 0 then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Excluded_Source_List_File.Value); + Error_Msg + (Project, In_Tree, + "file with excluded sources { does not exist", + Excluded_Source_List_File.Location); + + else + -- Open the file + + Prj.Util.Open (File, Source_File_Path_Name); + + if not Prj.Util.Is_Valid (File) then + Error_Msg + (Project, In_Tree, "file does not exist", Location); + else + -- Read the lines one by one + + while not Prj.Util.End_Of_File (File) loop + Prj.Util.Get_Line (File, Line, Last); + + -- A non empty, non comment line should contain a file + -- name + + if Last /= 0 + and then (Last = 1 or else Line (1 .. 2) /= "--") + then + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := Line (1 .. Last); + Canonical_Case_File_Name + (Name_Buffer (1 .. Name_Len)); + Name := Name_Find; + + -- Check that there is no directory information + + for J in 1 .. Last loop + if Line (J) = '/' + or else Line (J) = Directory_Separator + then + Error_Msg_File_1 := Name; + Error_Msg + (Project, + In_Tree, + "file name cannot include " & + "directory information ({)", + Location); + exit; + end if; + end loop; + + Excluded_Sources_Htable.Set + (Name, (Name, False, Location)); + end if; + end loop; + + Prj.Util.Close (File); + end if; + end if; + end; end if; end Find_Excluded_Sources; *************** package body Prj.Nmsc is *** 7101,7108 **** --------------------------- procedure Find_Explicit_Sources ! (Lang : Language_Index; ! Current_Dir : String; Project : Project_Id; In_Tree : Project_Tree_Ref; Data : in out Project_Data) --- 7175,7181 ---- --------------------------- procedure Find_Explicit_Sources ! (Current_Dir : String; Project : Project_Id; In_Tree : Project_Tree_Ref; Data : in out Project_Data) *************** package body Prj.Nmsc is *** 7131,7137 **** if not Source_List_File.Default then Error_Msg (Project, In_Tree, ! "?both variables source_files and " & "source_list_file are present", Source_List_File.Location); end if; --- 7204,7210 ---- if not Source_List_File.Default then Error_Msg (Project, In_Tree, ! "?both attributes source_files and " & "source_list_file are present", Source_List_File.Location); end if; *************** package body Prj.Nmsc is *** 7149,7166 **** Data.Ada_Sources_Present := Current /= Nil_String; end if; ! -- If we are processing other languages in the case of gprmake, ! -- we should not reset the list of sources, which was already ! -- initialized for the Ada files. ! ! if Get_Mode /= Ada_Only or else Lang /= Ada_Language_Index then if Current = Nil_String then ! case Get_Mode is ! when Ada_Only => ! Data.Source_Dirs := Nil_String; ! when Multi_Language => ! Data.First_Language_Processing := No_Language_Index; ! end case; -- This project contains no source. For projects that -- don't extend other projects, this also means that --- 7222,7230 ---- Data.Ada_Sources_Present := Current /= Nil_String; end if; ! if Get_Mode = Multi_Language then if Current = Nil_String then ! Data.First_Language_Processing := No_Language_Index; -- This project contains no source. For projects that -- don't extend other projects, this also means that *************** package body Prj.Nmsc is *** 7170,7176 **** if Data.Extends = No_Project and then Data.Object_Directory = Data.Directory then ! Data.Object_Directory := No_Path; end if; end if; end if; --- 7234,7240 ---- if Data.Extends = No_Project and then Data.Object_Directory = Data.Directory then ! Data.Object_Directory := No_Path_Information; end if; end if; end if; *************** package body Prj.Nmsc is *** 7213,7219 **** end loop; -- In Multi_Language mode, check whether the file is ! -- already there (??? Is this really needed, and why ?) case Get_Mode is when Ada_Only => --- 7277,7285 ---- end loop; -- In Multi_Language mode, check whether the file is ! -- already there: the same file name may be in the list; if ! -- the source is missing, the error will be on the first ! -- mention of the source file name. case Get_Mode is when Ada_Only => *************** package body Prj.Nmsc is *** 7236,7252 **** end loop; if Get_Mode = Ada_Only then ! if Lang = Ada_Language_Index then ! Get_Path_Names_And_Record_Ada_Sources ! (Project, In_Tree, Data, Current_Dir); ! else ! Record_Other_Sources ! (Project => Project, ! In_Tree => In_Tree, ! Data => Data, ! Language => Lang, ! Naming_Exceptions => False); ! end if; end if; end; --- 7302,7309 ---- end loop; if Get_Mode = Ada_Only then ! Get_Path_Names_And_Record_Ada_Sources ! (Project, In_Tree, Data, Current_Dir); end if; end; *************** package body Prj.Nmsc is *** 7261,7267 **** declare Source_File_Path_Name : constant String := Path_Name_Of ! (File_Name_Type (Source_List_File.Value), Data.Directory); begin if Source_File_Path_Name'Length = 0 then --- 7318,7324 ---- declare Source_File_Path_Name : constant String := Path_Name_Of ! (File_Name_Type (Source_List_File.Value), Data.Directory.Name); begin if Source_File_Path_Name'Length = 0 then *************** package body Prj.Nmsc is *** 7280,7297 **** if Get_Mode = Ada_Only then -- Look in the source directories to find those sources ! if Lang = Ada_Language_Index then ! Get_Path_Names_And_Record_Ada_Sources ! (Project, In_Tree, Data, Current_Dir); ! ! else ! Record_Other_Sources ! (Project => Project, ! In_Tree => In_Tree, ! Data => Data, ! Language => Lang, ! Naming_Exceptions => False); ! end if; end if; end if; end; --- 7337,7344 ---- if Get_Mode = Ada_Only then -- Look in the source directories to find those sources ! Get_Path_Names_And_Record_Ada_Sources ! (Project, In_Tree, Data, Current_Dir); end if; end if; end; *************** package body Prj.Nmsc is *** 7301,7322 **** -- specified. Find all the files that satisfy the naming -- scheme in all the source directories. ! case Get_Mode is ! when Ada_Only => ! if Lang = Ada_Language_Index then ! Find_Ada_Sources (Project, In_Tree, Data, Current_Dir); ! else ! -- Find all the files that satisfy the naming scheme in ! -- all the source directories. All the naming exceptions ! -- that effectively exist are also part of the source ! -- of this language. ! ! Find_Sources (Project, In_Tree, Data, Lang, Current_Dir); ! end if; ! ! when Multi_Language => ! null; ! end case; end if; if Get_Mode = Multi_Language then --- 7348,7356 ---- -- specified. Find all the files that satisfy the naming -- scheme in all the source directories. ! if Get_Mode = Ada_Only then ! Find_Ada_Sources (Project, In_Tree, Data, Current_Dir); ! end if; end if; if Get_Mode = Multi_Language then *************** package body Prj.Nmsc is *** 7324,7336 **** (Project, In_Tree, Data, For_All_Sources => Sources.Default and then Source_List_File.Default); end if; if Get_Mode = Ada_Only - and then Lang = Ada_Language_Index and then Data.Extends = No_Project then ! -- We should have found at least one source. If not, report an error. if Data.Ada_Sources = Nil_String then Report_No_Sources --- 7358,7423 ---- (Project, In_Tree, Data, For_All_Sources => Sources.Default and then Source_List_File.Default); + + -- Check if all exceptions have been found. + -- For Ada, it is an error if an exception is not found. + -- For other language, the source is simply removed. + + declare + Source : Source_Id; + Src_Data : Source_Data; + + begin + Source := Data.First_Source; + while Source /= No_Source loop + Src_Data := In_Tree.Sources.Table (Source); + + if Src_Data.Naming_Exception + and then Src_Data.Path = No_Path_Information + then + if Src_Data.Unit /= No_Name then + Error_Msg_Name_1 := Name_Id (Src_Data.Display_File); + Error_Msg_Name_2 := Name_Id (Src_Data.Unit); + Error_Msg + (Project, In_Tree, + "source file %% for unit %% not found", + No_Location); + end if; + + Remove_Source (Source, No_Source, Project, Data, In_Tree); + end if; + + Source := Src_Data.Next_In_Project; + end loop; + end; + + -- Check that all sources in Source_Files or the file + -- Source_List_File has been found. + + declare + Name_Loc : Name_Location; + + begin + Name_Loc := Source_Names.Get_First; + while Name_Loc /= No_Name_Location loop + if (not Name_Loc.Except) and then (not Name_Loc.Found) then + Error_Msg_Name_1 := Name_Id (Name_Loc.Name); + Error_Msg + (Project, + In_Tree, + "file %% not found", + Name_Loc.Location); + end if; + + Name_Loc := Source_Names.Get_Next; + end loop; + end; end if; if Get_Mode = Ada_Only and then Data.Extends = No_Project then ! -- We should have found at least one source, if not report an error if Data.Ada_Sources = Nil_String then Report_No_Sources *************** package body Prj.Nmsc is *** 7345,7356 **** ------------------------------------------- procedure Get_Path_Names_And_Record_Ada_Sources ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! Current_Dir : String) is ! Source_Dir : String_List_Id := Data.Source_Dirs; Element : String_Element; Path : Path_Name_Type; Dir : Dir_Type; --- 7432,7443 ---- ------------------------------------------- procedure Get_Path_Names_And_Record_Ada_Sources ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! Current_Dir : String) is ! Source_Dir : String_List_Id; Element : String_Element; Path : Path_Name_Type; Dir : Dir_Type; *************** package body Prj.Nmsc is *** 7364,7372 **** Source_Recorded : Boolean := False; begin ! -- We look in all source directories for the file names in the ! -- hash table Source_Names while Source_Dir /= Nil_String loop Source_Recorded := False; Element := In_Tree.String_Elements.Table (Source_Dir); --- 7451,7460 ---- Source_Recorded : Boolean := False; begin ! -- We look in all source directories for the file names in the hash ! -- table Source_Names. + Source_Dir := Data.Source_Dirs; while Source_Dir /= Nil_String loop Source_Recorded := False; Element := In_Tree.String_Elements.Table (Source_Dir); *************** package body Prj.Nmsc is *** 7496,7501 **** --- 7584,7593 ---- First_Language : Language_Index; OK : Boolean; + Last_Spec : Natural; + Last_Body : Natural; + Last_Sep : Natural; + begin Unit := No_Name; Alternate_Languages := No_Alternate_Language; *************** package body Prj.Nmsc is *** 7628,7640 **** end if; end loop; when others => OK := False; end case; end if; if OK then ! OK := False; if Config.Naming_Data.Separate_Suffix /= No_File and then --- 7720,7737 ---- end if; end loop; + when Mixed_Case => + null; + when others => OK := False; end case; end if; if OK then ! Last_Spec := Natural'Last; ! Last_Body := Natural'Last; ! Last_Sep := Natural'Last; if Config.Naming_Data.Separate_Suffix /= No_File and then *************** package body Prj.Nmsc is *** 7652,7667 **** (Last - Suffix'Length + 1 .. Last) = Suffix then ! Kind := Sep; ! Last := Last - Suffix'Length; ! OK := True; end if; end; end if; ! if not OK ! and then Config.Naming_Data.Body_Suffix /= No_File ! then declare Suffix : constant String := Get_Name_String --- 7749,7760 ---- (Last - Suffix'Length + 1 .. Last) = Suffix then ! Last_Sep := Last - Suffix'Length; end if; end; end if; ! if Config.Naming_Data.Body_Suffix /= No_File then declare Suffix : constant String := Get_Name_String *************** package body Prj.Nmsc is *** 7673,7688 **** (Last - Suffix'Length + 1 .. Last) = Suffix then ! Kind := Impl; ! Last := Last - Suffix'Length; ! OK := True; end if; end; end if; ! if not OK ! and then Config.Naming_Data.Spec_Suffix /= No_File ! then declare Suffix : constant String := Get_Name_String --- 7766,7777 ---- (Last - Suffix'Length + 1 .. Last) = Suffix then ! Last_Body := Last - Suffix'Length; end if; end; end if; ! if Config.Naming_Data.Spec_Suffix /= No_File then declare Suffix : constant String := Get_Name_String *************** package body Prj.Nmsc is *** 7694,7705 **** (Last - Suffix'Length + 1 .. Last) = Suffix then ! Kind := Spec; ! Last := Last - Suffix'Length; ! OK := True; end if; end; end if; end if; if OK then --- 7783,7816 ---- (Last - Suffix'Length + 1 .. Last) = Suffix then ! Last_Spec := Last - Suffix'Length; end if; end; end if; + + declare + Last_Min : constant Natural := + Natural'Min (Natural'Min (Last_Spec, + Last_Body), + Last_Sep); + + begin + OK := Last_Min < Last; + + if OK then + Last := Last_Min; + + if Last_Min = Last_Spec then + Kind := Spec; + + elsif Last_Min = Last_Body then + Kind := Impl; + + else + Kind := Sep; + end if; + end if; + end; end if; if OK then *************** package body Prj.Nmsc is *** 7891,7896 **** --- 8002,8008 ---- Alternate_Languages : Alternate_Language_Id := No_Alternate_Language; Language : Language_Index; Source : Source_Id; + Other_Part : Source_Id; Add_Src : Boolean; Src_Ind : Source_File_Index; Src_Data : Source_Data; *************** package body Prj.Nmsc is *** 7933,7945 **** else Name_Loc.Found := True; if Name_Loc.Source = No_Source then Check_Name := True; else ! In_Tree.Sources.Table (Name_Loc.Source).Path := Path_Id; ! In_Tree.Sources.Table ! (Name_Loc.Source).Display_Path := Display_Path_Id; Source_Paths_Htable.Set (In_Tree.Source_Paths_HT, --- 8045,8058 ---- else Name_Loc.Found := True; + Source_Names.Set (File_Name, Name_Loc); + if Name_Loc.Source = No_Source then Check_Name := True; else ! In_Tree.Sources.Table (Name_Loc.Source).Path := ! (Path_Id, Display_Path_Id); Source_Paths_Htable.Set (In_Tree.Source_Paths_HT, *************** package body Prj.Nmsc is *** 7964,7969 **** --- 8077,8084 ---- end if; if Check_Name then + Other_Part := No_Source; + Check_Naming_Schemes (In_Tree => In_Tree, Data => Data, *************** package body Prj.Nmsc is *** 7978,7985 **** Kind => Kind); if Language = No_Language_Index then if Name_Loc.Found then - -- A file name in a list must be a source of a language. Error_Msg_File_1 := File_Name; Error_Msg (Project, --- 8093,8102 ---- Kind => Kind); if Language = No_Language_Index then + + -- A file name in a list must be a source of a language + if Name_Loc.Found then Error_Msg_File_1 := File_Name; Error_Msg (Project, *************** package body Prj.Nmsc is *** 7996,8006 **** while Source /= No_Source loop Src_Data := In_Tree.Sources.Table (Source); ! if (Unit /= No_Name ! and then Src_Data.Unit = Unit ! and then Src_Data.Kind = Kind) ! or else (Unit = No_Name ! and then Src_Data.File = File_Name) then -- Duplication of file/unit in same project is only -- allowed if order of source directories is known. --- 8113,8136 ---- while Source /= No_Source loop Src_Data := In_Tree.Sources.Table (Source); ! if Unit /= No_Name ! and then Src_Data.Unit = Unit ! and then ! ((Src_Data.Kind = Spec and then Kind = Impl) ! or else ! (Src_Data.Kind = Impl and then Kind = Spec)) ! then ! Other_Part := Source; ! ! elsif (Unit /= No_Name ! and then Src_Data.Unit = Unit ! and then ! (Src_Data.Kind = Kind ! or else ! (Src_Data.Kind = Sep and then Kind = Impl) ! or else ! (Src_Data.Kind = Impl and then Kind = Sep))) ! or else (Unit = No_Name and then Src_Data.File = File_Name) then -- Duplication of file/unit in same project is only -- allowed if order of source directories is known. *************** package body Prj.Nmsc is *** 8012,8028 **** elsif Unit /= No_Name then Error_Msg_Name_1 := Unit; Error_Msg ! (Project, In_Tree, ! "duplicate unit %%", ! No_Location); Add_Src := False; else Error_Msg_File_1 := File_Name; Error_Msg ! (Project, In_Tree, ! "duplicate source file " & ! "name {", No_Location); Add_Src := False; end if; --- 8142,8154 ---- elsif Unit /= No_Name then Error_Msg_Name_1 := Unit; Error_Msg ! (Project, In_Tree, "duplicate unit %%", No_Location); Add_Src := False; else Error_Msg_File_1 := File_Name; Error_Msg ! (Project, In_Tree, "duplicate source file name {", No_Location); Add_Src := False; end if; *************** package body Prj.Nmsc is *** 8040,8052 **** then Source_To_Replace := Source; ! elsif Unit /= No_Name then Error_Msg_Name_1 := Unit; Error_Msg (Project, In_Tree, ! "unit %% cannot belong to " & ! "several projects", No_Location); Add_Src := False; end if; end if; --- 8166,8191 ---- then Source_To_Replace := Source; ! elsif Unit /= No_Name ! and then not Src_Data.Locally_Removed ! then Error_Msg_Name_1 := Unit; Error_Msg (Project, In_Tree, ! "unit %% cannot belong to several projects", No_Location); + + Error_Msg_Name_1 := In_Tree.Projects.Table (Project).Name; + Error_Msg_Name_2 := Name_Id (Display_Path_Id); + Error_Msg + (Project, In_Tree, "\ project %%, %%", No_Location); + + Error_Msg_Name_1 := + In_Tree.Projects.Table (Src_Data.Project).Name; + Error_Msg_Name_2 := Name_Id (Src_Data.Path.Display_Name); + Error_Msg + (Project, In_Tree, "\ project %%, %%", No_Location); + Add_Src := False; end if; end if; *************** package body Prj.Nmsc is *** 8067,8072 **** --- 8206,8212 ---- Alternate_Languages => Alternate_Languages, File_Name => File_Name, Display_File => Display_File_Name, + Other_Part => Other_Part, Unit => Unit, Path => Path_Id, Display_Path => Display_Path_Id, *************** package body Prj.Nmsc is *** 8081,8090 **** ------------------------ procedure Search_Directories ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! For_All_Sources : Boolean) is Source_Dir : String_List_Id; Element : String_Element; --- 8221,8230 ---- ------------------------ procedure Search_Directories ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! For_All_Sources : Boolean) is Source_Dir : String_List_Id; Element : String_Element; *************** package body Prj.Nmsc is *** 8110,8120 **** declare Source_Directory : constant String := ! Name_Buffer (1 .. Name_Len) & ! Directory_Separator; ! Dir_Last : constant Natural := ! Compute_Directory_Last ! (Source_Directory); begin if Current_Verbosity = High then --- 8250,8261 ---- declare Source_Directory : constant String := ! Name_Buffer (1 .. Name_Len) & ! Directory_Separator; ! ! Dir_Last : constant Natural := ! Compute_Directory_Last ! (Source_Directory); begin if Current_Verbosity = High then *************** package body Prj.Nmsc is *** 8134,8139 **** --- 8275,8281 ---- -- ??? Duplicate system call here, we just did a -- a similar one. Maybe Ada.Directories would be more -- appropriate here + if Is_Regular_File (Source_Directory & Name (1 .. Last)) then *************** package body Prj.Nmsc is *** 8156,8162 **** declare FF : File_Found := ! Excluded_Sources_Htable.Get (File_Name); begin if FF /= No_File_Found then --- 8298,8304 ---- declare FF : File_Found := ! Excluded_Sources_Htable.Get (File_Name); begin if FF /= No_File_Found then *************** package body Prj.Nmsc is *** 8196,8201 **** --- 8338,8344 ---- when Directory_Error => null; end; + Source_Dir := Element.Next; end loop; *************** package body Prj.Nmsc is *** 8209,8225 **** ---------------------- procedure Look_For_Sources ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! Current_Dir : String) is procedure Remove_Locally_Removed_Files_From_Units; -- Mark all locally removed sources as such in the Units table - procedure Process_Other_Sources_In_Ada_Only_Mode; - -- Find sources for language other than Ada when in Ada_Only mode - procedure Process_Sources_In_Multi_Language_Mode; -- Find all source files when in multi language mode --- 8352,8365 ---- ---------------------- procedure Look_For_Sources ! (Project : Project_Id; ! In_Tree : Project_Tree_Ref; ! Data : in out Project_Data; ! Current_Dir : String) is procedure Remove_Locally_Removed_Files_From_Units; -- Mark all locally removed sources as such in the Units table procedure Process_Sources_In_Multi_Language_Mode; -- Find all source files when in multi language mode *************** package body Prj.Nmsc is *** 8228,8238 **** --------------------------------------------- procedure Remove_Locally_Removed_Files_From_Units is ! Excluded : File_Found := Excluded_Sources_Htable.Get_First; OK : Boolean; Unit : Unit_Data; Extended : Project_Id; begin while Excluded /= No_File_Found loop OK := False; --- 8368,8380 ---- --------------------------------------------- procedure Remove_Locally_Removed_Files_From_Units is ! Excluded : File_Found; OK : Boolean; Unit : Unit_Data; Extended : Project_Id; + begin + Excluded := Excluded_Sources_Htable.Get_First; while Excluded /= No_File_Found loop OK := False; *************** package body Prj.Nmsc is *** 8254,8260 **** if Extended = Project or else Project_Extends (Project, Extended, In_Tree) then ! Unit.File_Names (Kind).Path := Slash; Unit.File_Names (Kind).Needs_Pragma := False; In_Tree.Units.Table (Index) := Unit; Add_Forbidden_File_Name --- 8396,8402 ---- if Extended = Project or else Project_Extends (Project, Extended, In_Tree) then ! Unit.File_Names (Kind).Path.Name := Slash; Unit.File_Names (Kind).Needs_Pragma := False; In_Tree.Units.Table (Index) := Unit; Add_Forbidden_File_Name *************** package body Prj.Nmsc is *** 8282,8412 **** end Remove_Locally_Removed_Files_From_Units; -------------------------------------------- - -- Process_Other_Sources_In_Ada_Only_Mode -- - -------------------------------------------- - - procedure Process_Other_Sources_In_Ada_Only_Mode is - begin - -- Set Source_Present to False. It will be set back to True - -- whenever a source is found. - - Data.Other_Sources_Present := False; - for Lang in Ada_Language_Index + 1 .. Last_Language_Index loop - - -- For each language (other than Ada) in the project file - - if Is_Present (Lang, Data, In_Tree) then - - -- Reset the indication that there are sources of this - -- language. It will be set back to True whenever we find - -- a source of the language. - - Set (Lang, False, Data, In_Tree); - - -- First, get the source suffix for the language - - Set (Suffix => Suffix_For (Lang, Data.Naming, In_Tree), - For_Language => Lang, - In_Project => Data, - In_Tree => In_Tree); - - -- Then, deal with the naming exceptions, if any - - Source_Names.Reset; - - declare - Naming_Exceptions : constant Variable_Value := - Value_Of - (Index => Language_Names.Table (Lang), - Src_Index => 0, - In_Array => Data.Naming.Implementation_Exceptions, - In_Tree => In_Tree); - Element_Id : String_List_Id; - Element : String_Element; - File_Id : File_Name_Type; - Source_Found : Boolean := False; - - begin - -- If there are naming exceptions, look through them one - -- by one. - - if Naming_Exceptions /= Nil_Variable_Value then - Element_Id := Naming_Exceptions.Values; - - while Element_Id /= Nil_String loop - Element := In_Tree.String_Elements.Table (Element_Id); - - if Osint.File_Names_Case_Sensitive then - File_Id := File_Name_Type (Element.Value); - else - Get_Name_String (Element.Value); - Canonical_Case_File_Name - (Name_Buffer (1 .. Name_Len)); - File_Id := Name_Find; - end if; - - -- Put each naming exception in the Source_Names - -- hash table, but if there are repetition, don't - -- bother after the first instance. - - if Source_Names.Get (File_Id) = No_Name_Location then - Source_Found := True; - Source_Names.Set - (File_Id, - (Name => File_Id, - Location => Element.Location, - Source => No_Source, - Except => False, - Found => False)); - end if; - - Element_Id := Element.Next; - end loop; - - -- If there is at least one naming exception, record - -- those that are found in the source directories. - - if Source_Found then - Record_Other_Sources - (Project => Project, - In_Tree => In_Tree, - Data => Data, - Language => Lang, - Naming_Exceptions => True); - end if; - - end if; - end; - - -- Now, check if a list of sources is declared either through - -- a string list (attribute Source_Files) or a text file - -- (attribute Source_List_File). If a source list is declared, - -- we will consider only those naming exceptions that are - -- on the list. - - Source_Names.Reset; - Find_Explicit_Sources - (Lang, Current_Dir, Project, In_Tree, Data); - end if; - end loop; - end Process_Other_Sources_In_Ada_Only_Mode; - - -------------------------------------------- -- Process_Sources_In_Multi_Language_Mode -- -------------------------------------------- procedure Process_Sources_In_Multi_Language_Mode is ! Source : Source_Id := Data.First_Source; ! Src_Data : Source_Data; ! Name_Loc : Name_Location; ! OK : Boolean; ! FF : File_Found; begin ! -- First, put all the naming exceptions, if any, in the Source_Names ! -- table. Unit_Exceptions.Reset; while Source /= No_Source loop Src_Data := In_Tree.Sources.Table (Source); --- 8424,8445 ---- end Remove_Locally_Removed_Files_From_Units; -------------------------------------------- -- Process_Sources_In_Multi_Language_Mode -- -------------------------------------------- procedure Process_Sources_In_Multi_Language_Mode is ! Source : Source_Id; ! Src_Data : Source_Data; ! Name_Loc : Name_Location; ! OK : Boolean; ! FF : File_Found; ! begin ! -- First, put all naming exceptions if any, in the Source_Names table Unit_Exceptions.Reset; + Source := Data.First_Source; while Source /= No_Source loop Src_Data := In_Tree.Sources.Table (Source); *************** package body Prj.Nmsc is *** 8417,8424 **** then Error_Msg_File_1 := Src_Data.File; Error_Msg ! (Project, ! In_Tree, "{ cannot be both excluded and an exception file name", No_Location); end if; --- 8450,8456 ---- then Error_Msg_File_1 := Src_Data.File; Error_Msg ! (Project, In_Tree, "{ cannot be both excluded and an exception file name", No_Location); end if; *************** package body Prj.Nmsc is *** 8444,8450 **** if Src_Data.Unit /= No_Name then declare Unit_Except : Unit_Exception := ! Unit_Exceptions.Get (Src_Data.Unit); begin Unit_Except.Name := Src_Data.Unit; --- 8476,8482 ---- if Src_Data.Unit /= No_Name then declare Unit_Except : Unit_Exception := ! Unit_Exceptions.Get (Src_Data.Unit); begin Unit_Except.Name := Src_Data.Unit; *************** package body Prj.Nmsc is *** 8463,8472 **** end loop; Find_Explicit_Sources ! (Ada_Language_Index, Current_Dir, Project, In_Tree, Data); ! FF := Excluded_Sources_Htable.Get_First; while FF /= No_File_Found loop OK := False; Source := In_Tree.First_Source; --- 8495,8505 ---- end loop; Find_Explicit_Sources ! (Current_Dir, Project, In_Tree, Data); ! -- Mark as such the sources that are declared as excluded + FF := Excluded_Sources_Htable.Get_First; while FF /= No_File_Found loop OK := False; Source := In_Tree.First_Source; *************** package body Prj.Nmsc is *** 8476,8488 **** if Src_Data.File = FF.File then ! -- Check that this is from this project or a ! -- project that the current project extends. if Src_Data.Project = Project or else Is_Extending (Project, Src_Data.Project, In_Tree) then Src_Data.Locally_Removed := True; In_Tree.Sources.Table (Source) := Src_Data; Add_Forbidden_File_Name (FF.File); OK := True; --- 8509,8522 ---- if Src_Data.File = FF.File then ! -- Check that this is from this project or a project that ! -- the current project extends. if Src_Data.Project = Project or else Is_Extending (Project, Src_Data.Project, In_Tree) then Src_Data.Locally_Removed := True; + Src_Data.In_Interfaces := False; In_Tree.Sources.Table (Source) := Src_Data; Add_Forbidden_File_Name (FF.File); OK := True; *************** package body Prj.Nmsc is *** 8500,8525 **** FF := Excluded_Sources_Htable.Get_Next; end loop; end Process_Sources_In_Multi_Language_Mode; -- Start of processing for Look_For_Sources begin Source_Names.Reset; ! Find_Excluded_Sources (In_Tree, Data); case Get_Mode is when Ada_Only => if Is_A_Language (In_Tree, Data, Name_Ada) then ! Find_Explicit_Sources ! (Ada_Language_Index, Current_Dir, Project, In_Tree, Data); Remove_Locally_Removed_Files_From_Units; end if; - if Data.Other_Sources_Present then - Process_Other_Sources_In_Ada_Only_Mode; - end if; - when Multi_Language => if Data.First_Language_Processing /= No_Language_Index then Process_Sources_In_Multi_Language_Mode; --- 8534,8646 ---- FF := Excluded_Sources_Htable.Get_Next; end loop; + + -- Check that two sources of this project do not have the same object + -- file name. + + Check_Object_File_Names : declare + Src_Id : Source_Id; + Src_Data : Source_Data; + Source_Name : File_Name_Type; + + procedure Check_Object; + -- Check if object file name of the current source is already in + -- hash table Object_File_Names. If it is, report an error. If it + -- is not, put it there with the file name of the current source. + + ------------------ + -- Check_Object -- + ------------------ + + procedure Check_Object is + begin + Source_Name := Object_File_Names.Get (Src_Data.Object); + + if Source_Name /= No_File then + Error_Msg_File_1 := Src_Data.File; + Error_Msg_File_2 := Source_Name; + Error_Msg + (Project, + In_Tree, + "{ and { have the same object file name", + No_Location); + + else + Object_File_Names.Set (Src_Data.Object, Src_Data.File); + end if; + end Check_Object; + + -- Start of processing for Check_Object_File_Names + + begin + Object_File_Names.Reset; + Src_Id := In_Tree.First_Source; + while Src_Id /= No_Source loop + Src_Data := In_Tree.Sources.Table (Src_Id); + + if Src_Data.Compiled and then Src_Data.Object_Exists + and then Project_Extends (Project, Src_Data.Project, In_Tree) + then + if Src_Data.Unit = No_Name then + if Src_Data.Kind = Impl then + Check_Object; + end if; + + else + case Src_Data.Kind is + when Spec => + if Src_Data.Other_Part = No_Source then + Check_Object; + end if; + + when Sep => + null; + + when Impl => + if Src_Data.Other_Part /= No_Source then + Check_Object; + + else + -- Check if it is a subunit + + declare + Src_Ind : constant Source_File_Index := + Sinput.P.Load_Project_File + (Get_Name_String + (Src_Data.Path.Name)); + + begin + if Sinput.P.Source_File_Is_Subunit + (Src_Ind) + then + In_Tree.Sources.Table (Src_Id).Kind := Sep; + else + Check_Object; + end if; + end; + end if; + end case; + end if; + end if; + + Src_Id := Src_Data.Next_In_Sources; + end loop; + end Check_Object_File_Names; end Process_Sources_In_Multi_Language_Mode; -- Start of processing for Look_For_Sources begin Source_Names.Reset; ! Find_Excluded_Sources (Project, In_Tree, Data); case Get_Mode is when Ada_Only => if Is_A_Language (In_Tree, Data, Name_Ada) then ! Find_Explicit_Sources (Current_Dir, Project, In_Tree, Data); Remove_Locally_Removed_Files_From_Units; end if; when Multi_Language => if Data.First_Language_Processing /= No_Language_Index then Process_Sources_In_Multi_Language_Mode; *************** package body Prj.Nmsc is *** 8535,8549 **** (File_Name : File_Name_Type; Directory : Path_Name_Type) return String is ! Result : String_Access; ! The_Directory : constant String := Get_Name_String (Directory); begin Get_Name_String (File_Name); ! Result := Locate_Regular_File ! (File_Name => Name_Buffer (1 .. Name_Len), ! Path => The_Directory); if Result = null then return ""; --- 8656,8670 ---- (File_Name : File_Name_Type; Directory : Path_Name_Type) return String is ! Result : String_Access; The_Directory : constant String := Get_Name_String (Directory); begin Get_Name_String (File_Name); ! Result := ! Locate_Regular_File ! (File_Name => Name_Buffer (1 .. Name_Len), ! Path => The_Directory); if Result = null then return ""; *************** package body Prj.Nmsc is *** 8604,8609 **** --- 8725,8731 ---- In_Tree : Project_Tree_Ref) return Boolean is Current : Project_Id := Extending; + begin loop if Current = No_Project then *************** package body Prj.Nmsc is *** 8662,8672 **** declare Canonical_Path : constant String := ! Normalize_Pathname ! (Get_Name_String (Path_Name), ! Directory => Current_Dir, ! Resolve_Links => Opt.Follow_Links_For_Files, ! Case_Sensitive => False); begin Name_Len := 0; Add_Str_To_Name_Buffer (Canonical_Path); --- 8784,8794 ---- declare Canonical_Path : constant String := ! Normalize_Pathname ! (Get_Name_String (Path_Name), ! Directory => Current_Dir, ! Resolve_Links => Opt.Follow_Links_For_Files, ! Case_Sensitive => False); begin Name_Len := 0; Add_Str_To_Name_Buffer (Canonical_Path); *************** package body Prj.Nmsc is *** 8686,8693 **** Unit_Kind => Unit_Kind, Needs_Pragma => Needs_Pragma); ! if Exception_Id = No_Ada_Naming_Exception and then ! Unit_Name = No_Name then if Current_Verbosity = High then Write_Str (" """); --- 8808,8815 ---- Unit_Kind => Unit_Kind, Needs_Pragma => Needs_Pragma); ! if Exception_Id = No_Ada_Naming_Exception ! and then Unit_Name = No_Name then if Current_Verbosity = High then Write_Str (" """); *************** package body Prj.Nmsc is *** 8734,8764 **** -- Put the file name in the list of sources of the project ! String_Element_Table.Increment_Last ! (In_Tree.String_Elements); In_Tree.String_Elements.Table ! (String_Element_Table.Last ! (In_Tree.String_Elements)) := ! (Value => Name_Id (Canonical_File_Name), ! Display_Value => Name_Id (File_Name), ! Location => No_Location, ! Flag => False, ! Next => Nil_String, ! Index => Unit_Ind); if Current_Source = Nil_String then ! Data.Ada_Sources := String_Element_Table.Last ! (In_Tree.String_Elements); ! Data.Sources := Data.Ada_Sources; else ! In_Tree.String_Elements.Table ! (Current_Source).Next := ! String_Element_Table.Last ! (In_Tree.String_Elements); end if; ! Current_Source := String_Element_Table.Last ! (In_Tree.String_Elements); -- Put the unit in unit list --- 8856,8881 ---- -- Put the file name in the list of sources of the project ! String_Element_Table.Increment_Last (In_Tree.String_Elements); In_Tree.String_Elements.Table ! (String_Element_Table.Last (In_Tree.String_Elements)) := ! (Value => Name_Id (Canonical_File_Name), ! Display_Value => Name_Id (File_Name), ! Location => No_Location, ! Flag => False, ! Next => Nil_String, ! Index => Unit_Ind); if Current_Source = Nil_String then ! Data.Ada_Sources := ! String_Element_Table.Last (In_Tree.String_Elements); else ! In_Tree.String_Elements.Table (Current_Source).Next := ! String_Element_Table.Last (In_Tree.String_Elements); end if; ! Current_Source := ! String_Element_Table.Last (In_Tree.String_Elements); -- Put the unit in unit list *************** package body Prj.Nmsc is *** 8783,8798 **** The_Unit_Data := In_Tree.Units.Table (The_Unit); if (The_Unit_Data.File_Names (Unit_Kind).Name = ! Canonical_File_Name ! and then ! The_Unit_Data.File_Names (Unit_Kind).Path = Slash) or else The_Unit_Data.File_Names (Unit_Kind).Name = No_File or else Project_Extends (Data.Extends, The_Unit_Data.File_Names (Unit_Kind).Project, In_Tree) then ! if The_Unit_Data.File_Names (Unit_Kind).Path = Slash then Remove_Forbidden_File_Name (The_Unit_Data.File_Names (Unit_Kind).Name); end if; --- 8900,8918 ---- The_Unit_Data := In_Tree.Units.Table (The_Unit); if (The_Unit_Data.File_Names (Unit_Kind).Name = ! Canonical_File_Name ! and then ! The_Unit_Data.File_Names ! (Unit_Kind).Path.Name = Slash) or else The_Unit_Data.File_Names (Unit_Kind).Name = No_File or else Project_Extends (Data.Extends, The_Unit_Data.File_Names (Unit_Kind).Project, In_Tree) then ! if ! The_Unit_Data.File_Names (Unit_Kind).Path.Name = Slash ! then Remove_Forbidden_File_Name (The_Unit_Data.File_Names (Unit_Kind).Name); end if; *************** package body Prj.Nmsc is *** 8809,8833 **** (Name => Canonical_File_Name, Index => Unit_Ind, Display_Name => File_Name, ! Path => Canonical_Path_Name, ! Display_Path => Path_Name, Project => Project, Needs_Pragma => Needs_Pragma); ! In_Tree.Units.Table (The_Unit) := ! The_Unit_Data; Source_Recorded := True; elsif The_Unit_Data.File_Names (Unit_Kind).Project = Project ! and then (Data.Known_Order_Of_Source_Dirs or else ! The_Unit_Data.File_Names (Unit_Kind).Path = ! Canonical_Path_Name) then if Previous_Source = Nil_String then Data.Ada_Sources := Nil_String; - Data.Sources := Nil_String; else ! In_Tree.String_Elements.Table ! (Previous_Source).Next := Nil_String; String_Element_Table.Decrement_Last (In_Tree.String_Elements); end if; --- 8929,8951 ---- (Name => Canonical_File_Name, Index => Unit_Ind, Display_Name => File_Name, ! Path => (Canonical_Path_Name, Path_Name), Project => Project, Needs_Pragma => Needs_Pragma); ! In_Tree.Units.Table (The_Unit) := The_Unit_Data; Source_Recorded := True; elsif The_Unit_Data.File_Names (Unit_Kind).Project = Project ! and then (Data.Known_Order_Of_Source_Dirs ! or else ! The_Unit_Data.File_Names ! (Unit_Kind).Path.Name = Canonical_Path_Name) then if Previous_Source = Nil_String then Data.Ada_Sources := Nil_String; else ! In_Tree.String_Elements.Table (Previous_Source).Next := ! Nil_String; String_Element_Table.Decrement_Last (In_Tree.String_Elements); end if; *************** package body Prj.Nmsc is *** 8840,8859 **** if The_Location = No_Location then The_Location := ! In_Tree.Projects.Table ! (Project).Location; end if; Err_Vars.Error_Msg_Name_1 := Unit_Name; Error_Msg ! (Project, In_Tree, "duplicate source %%", The_Location); Err_Vars.Error_Msg_Name_1 := In_Tree.Projects.Table (The_Unit_Data.File_Names (Unit_Kind).Project).Name; Err_Vars.Error_Msg_File_1 := File_Name_Type ! (The_Unit_Data.File_Names (Unit_Kind).Path); Error_Msg (Project, In_Tree, "\ project file %%, {", The_Location); --- 8958,8976 ---- if The_Location = No_Location then The_Location := ! In_Tree.Projects.Table (Project).Location; end if; Err_Vars.Error_Msg_Name_1 := Unit_Name; Error_Msg ! (Project, In_Tree, "duplicate unit %%", The_Location); Err_Vars.Error_Msg_Name_1 := In_Tree.Projects.Table (The_Unit_Data.File_Names (Unit_Kind).Project).Name; Err_Vars.Error_Msg_File_1 := File_Name_Type ! (The_Unit_Data.File_Names (Unit_Kind).Path.Name); Error_Msg (Project, In_Tree, "\ project file %%, {", The_Location); *************** package body Prj.Nmsc is *** 8871,8890 **** else -- First, check if there is no other unit with this file ! -- name in another project. If it is, report an error. ! -- Of course, we do that only for the first unit in the ! -- source file. ! Unit_Prj := Files_Htable.Get ! (In_Tree.Files_HT, Canonical_File_Name); if not File_Name_Recorded and then Unit_Prj /= No_Unit_Project then Error_Msg_File_1 := File_Name; Error_Msg_Name_1 := ! In_Tree.Projects.Table ! (Unit_Prj.Project).Name; Error_Msg (Project, In_Tree, "{ is already a source of project %%", --- 8988,9005 ---- else -- First, check if there is no other unit with this file ! -- name in another project. If it is, report error but note ! -- we do that only for the first unit in the source file. ! Unit_Prj := ! Files_Htable.Get (In_Tree.Files_HT, Canonical_File_Name); if not File_Name_Recorded and then Unit_Prj /= No_Unit_Project then Error_Msg_File_1 := File_Name; Error_Msg_Name_1 := ! In_Tree.Projects.Table (Unit_Prj.Project).Name; Error_Msg (Project, In_Tree, "{ is already a source of project %%", *************** package body Prj.Nmsc is *** 8905,8916 **** (Name => Canonical_File_Name, Index => Unit_Ind, Display_Name => File_Name, ! Path => Canonical_Path_Name, ! Display_Path => Path_Name, Project => Project, Needs_Pragma => Needs_Pragma); ! In_Tree.Units.Table (The_Unit) := ! The_Unit_Data; Source_Recorded := True; end if; end if; --- 9020,9029 ---- (Name => Canonical_File_Name, Index => Unit_Ind, Display_Name => File_Name, ! Path => (Canonical_Path_Name, Path_Name), Project => Project, Needs_Pragma => Needs_Pragma); ! In_Tree.Units.Table (The_Unit) := The_Unit_Data; Source_Recorded := True; end if; end if; *************** package body Prj.Nmsc is *** 8922,9103 **** end if; end Record_Ada_Source; - -------------------------- - -- Record_Other_Sources -- - -------------------------- - - procedure Record_Other_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Data : in out Project_Data; - Language : Language_Index; - Naming_Exceptions : Boolean) - is - Source_Dir : String_List_Id; - Element : String_Element; - Path : Path_Name_Type; - Dir : Dir_Type; - Canonical_Name : File_Name_Type; - Name_Str : String (1 .. 1_024); - Last : Natural := 0; - NL : Name_Location; - First_Error : Boolean := True; - Suffix : constant String := - Body_Suffix_Of (Language, Data, In_Tree); - - begin - Source_Dir := Data.Source_Dirs; - while Source_Dir /= Nil_String loop - Element := In_Tree.String_Elements.Table (Source_Dir); - - declare - Dir_Path : constant String := - Get_Name_String (Element.Display_Value); - begin - if Current_Verbosity = High then - Write_Str ("checking directory """); - Write_Str (Dir_Path); - Write_Str (""" for "); - - if Naming_Exceptions then - Write_Str ("naming exceptions"); - - else - Write_Str ("sources"); - end if; - - Write_Str (" of Language "); - Display_Language_Name (Language); - end if; - - Open (Dir, Dir_Path); - - loop - Read (Dir, Name_Str, Last); - exit when Last = 0; - - if Is_Regular_File - (Dir_Path & Directory_Separator & Name_Str (1 .. Last)) - then - Name_Len := Last; - Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last); - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Canonical_Name := Name_Find; - NL := Source_Names.Get (Canonical_Name); - - if NL /= No_Name_Location then - if NL.Found then - if not Data.Known_Order_Of_Source_Dirs then - Error_Msg_File_1 := Canonical_Name; - Error_Msg - (Project, In_Tree, - "{ is found in several source directories", - NL.Location); - end if; - - else - NL.Found := True; - Source_Names.Set (Canonical_Name, NL); - Name_Len := Dir_Path'Length; - Name_Buffer (1 .. Name_Len) := Dir_Path; - Add_Char_To_Name_Buffer (Directory_Separator); - Add_Str_To_Name_Buffer (Name_Str (1 .. Last)); - Path := Name_Find; - - Check_For_Source - (File_Name => Canonical_Name, - Path_Name => Path, - Project => Project, - In_Tree => In_Tree, - Data => Data, - Location => NL.Location, - Language => Language, - Suffix => Suffix, - Naming_Exception => Naming_Exceptions); - end if; - end if; - end if; - end loop; - - Close (Dir); - end; - - Source_Dir := Element.Next; - end loop; - - if not Naming_Exceptions then - NL := Source_Names.Get_First; - - -- It is an error if a source file name in a source list or - -- in a source list file is not found. - - while NL /= No_Name_Location loop - if not NL.Found then - Err_Vars.Error_Msg_File_1 := NL.Name; - - if First_Error then - Error_Msg - (Project, In_Tree, - "source file { cannot be found", - NL.Location); - First_Error := False; - - else - Error_Msg - (Project, In_Tree, - "\source file { cannot be found", - NL.Location); - end if; - end if; - - NL := Source_Names.Get_Next; - end loop; - - -- Any naming exception of this language that is not in a list - -- of sources must be removed. - - declare - Source_Id : Other_Source_Id := Data.First_Other_Source; - Prev_Id : Other_Source_Id := No_Other_Source; - Source : Other_Source; - - begin - while Source_Id /= No_Other_Source loop - Source := In_Tree.Other_Sources.Table (Source_Id); - - if Source.Language = Language - and then Source.Naming_Exception - then - if Current_Verbosity = High then - Write_Str ("Naming exception """); - Write_Str (Get_Name_String (Source.File_Name)); - Write_Str (""" is not in the list of sources,"); - Write_Line (" so it is removed."); - end if; - - if Prev_Id = No_Other_Source then - Data.First_Other_Source := Source.Next; - - else - In_Tree.Other_Sources.Table - (Prev_Id).Next := Source.Next; - end if; - - Source_Id := Source.Next; - - if Source_Id = No_Other_Source then - Data.Last_Other_Source := Prev_Id; - end if; - - else - Prev_Id := Source_Id; - Source_Id := Source.Next; - end if; - end loop; - end; - end if; - end Record_Other_Sources; - ------------------- -- Remove_Source -- ------------------- --- 9035,9040 ---- *************** package body Prj.Nmsc is *** 9110,9116 **** In_Tree : Project_Tree_Ref) is Src_Data : constant Source_Data := In_Tree.Sources.Table (Id); - Source : Source_Id; begin --- 9047,9052 ---- *************** package body Prj.Nmsc is *** 9119,9125 **** Write_Line (Id'Img); end if; ! In_Tree.Sources.Table (Id).Replaced_By := Replaced_By; -- Remove the source from the global source list --- 9055,9065 ---- Write_Line (Id'Img); end if; ! if Replaced_By /= No_Source then ! In_Tree.Sources.Table (Id).Replaced_By := Replaced_By; ! In_Tree.Sources.Table (Replaced_By).Declared_In_Interfaces := ! In_Tree.Sources.Table (Id).Declared_In_Interfaces; ! end if; -- Remove the source from the global source list *************** package body Prj.Nmsc is *** 9211,9220 **** ----------------------- procedure Report_No_Sources ! (Project : Project_Id; ! Lang_Name : String; ! In_Tree : Project_Tree_Ref; ! Location : Source_Ptr) is begin case When_No_Sources is --- 9151,9161 ---- ----------------------- procedure Report_No_Sources ! (Project : Project_Id; ! Lang_Name : String; ! In_Tree : Project_Tree_Ref; ! Location : Source_Ptr; ! Continuation : Boolean := False) is begin case When_No_Sources is *************** package body Prj.Nmsc is *** 9222,9232 **** null; when Warning | Error => ! Error_Msg_Warn := When_No_Sources = Warning; ! Error_Msg ! (Project, In_Tree, ! " ! declare ! Msg : constant String := ! " Language_Names.Table (Language), - Src_Index => 0, - In_Array => Naming.Body_Suffix, - In_Tree => In_Tree); - begin - -- If no suffix for this language in package Naming, use the default - - if Suffix = Nil_Variable_Value then - Name_Len := 0; - - case Language is - when Ada_Language_Index => - Add_Str_To_Name_Buffer (".adb"); - - when C_Language_Index => - Add_Str_To_Name_Buffer (".c"); - - when C_Plus_Plus_Language_Index => - Add_Str_To_Name_Buffer (".cpp"); - - when others => - return No_File; - end case; - - -- Otherwise use the one specified - - else - Get_Name_String (Suffix.Value); - end if; - - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - return Name_Find; - end Suffix_For; - ------------------------- -- Warn_If_Not_Sources -- ------------------------- --- 9209,9214 ---- *************** package body Prj.Nmsc is *** 9313,9341 **** Specs : Boolean; Extending : Boolean) is ! Conv : Array_Element_Id := Conventions; Unit : Name_Id; The_Unit_Id : Unit_Index; The_Unit_Data : Unit_Data; Location : Source_Ptr; begin while Conv /= No_Array_Element loop Unit := In_Tree.Array_Elements.Table (Conv).Index; Error_Msg_Name_1 := Unit; Get_Name_String (Unit); To_Lower (Name_Buffer (1 .. Name_Len)); Unit := Name_Find; ! The_Unit_Id := Units_Htable.Get ! (In_Tree.Units_HT, Unit); ! Location := In_Tree.Array_Elements.Table ! (Conv).Value.Location; if The_Unit_Id = No_Unit_Index then ! Error_Msg ! (Project, In_Tree, ! "?unknown unit %%", ! Location); else The_Unit_Data := In_Tree.Units.Table (The_Unit_Id); --- 9222,9246 ---- Specs : Boolean; Extending : Boolean) is ! Conv : Array_Element_Id; Unit : Name_Id; The_Unit_Id : Unit_Index; The_Unit_Data : Unit_Data; Location : Source_Ptr; begin + Conv := Conventions; while Conv /= No_Array_Element loop Unit := In_Tree.Array_Elements.Table (Conv).Index; Error_Msg_Name_1 := Unit; Get_Name_String (Unit); To_Lower (Name_Buffer (1 .. Name_Len)); Unit := Name_Find; ! The_Unit_Id := Units_Htable.Get (In_Tree.Units_HT, Unit); ! Location := In_Tree.Array_Elements.Table (Conv).Value.Location; if The_Unit_Id = No_Unit_Index then ! Error_Msg (Project, In_Tree, "?unknown unit %%", Location); else The_Unit_Data := In_Tree.Units.Table (The_Unit_Id); diff -Nrcpad gcc-4.3.3/gcc/ada/prj-nmsc.ads gcc-4.4.0/gcc/ada/prj-nmsc.ads *** gcc-4.3.3/gcc/ada/prj-nmsc.ads Thu Dec 13 10:28:39 2007 --- gcc-4.4.0/gcc/ada/prj-nmsc.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2008, 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- -- *************** *** 28,34 **** private package Prj.Nmsc is -- It would be nicer to have a higher level statement of what these ! -- procedures do (related to their names), rather than just an english -- language summary of the implementation ??? procedure Check --- 28,34 ---- private package Prj.Nmsc is -- It would be nicer to have a higher level statement of what these ! -- procedures do (related to their names), rather than just an English -- language summary of the implementation ??? procedure Check diff -Nrcpad gcc-4.3.3/gcc/ada/prj-pars.adb gcc-4.4.0/gcc/ada/prj-pars.adb *** gcc-4.3.3/gcc/ada/prj-pars.adb Thu Dec 13 10:28:39 2007 --- gcc-4.4.0/gcc/ada/prj-pars.adb Tue May 20 12:45:54 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package body Prj.Pars is *** 70,76 **** -- If there were no error, process the tree ! if Project_Node /= Empty_Node then Prj.Proc.Process (In_Tree => In_Tree, Project => The_Project, --- 70,76 ---- -- If there were no error, process the tree ! if Present (Project_Node) then Prj.Proc.Process (In_Tree => In_Tree, Project => The_Project, diff -Nrcpad gcc-4.3.3/gcc/ada/prj-part.adb gcc-4.4.0/gcc/ada/prj-part.adb *** gcc-4.3.3/gcc/ada/prj-part.adb Thu Dec 13 10:28:39 2007 --- gcc-4.4.0/gcc/ada/prj-part.adb Fri Aug 1 07:41:55 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** with Table; *** 39,44 **** --- 39,46 ---- with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Exceptions; use Ada.Exceptions; + with GNAT.Directory_Operations; use GNAT.Directory_Operations; + with System.HTable; use System.HTable; package body Prj.Part is *************** package body Prj.Part is *** 72,84 **** Table_Increment => 100, Table_Name => "Prj.Part.Withs"); -- Table used to store temporarily paths and locations of imported ! -- projects. These imported projects will be effectively parsed after the ! -- name of the current project has been extablished. type Names_And_Id is record Path_Name : Path_Name_Type; Canonical_Path_Name : Path_Name_Type; Id : Project_Node_Id; end record; package Project_Stack is new Table.Table --- 74,89 ---- Table_Increment => 100, Table_Name => "Prj.Part.Withs"); -- Table used to store temporarily paths and locations of imported ! -- projects. These imported projects will be effectively parsed later: just ! -- before parsing the current project for the non limited withed projects, ! -- after getting its name; after complete parsing of the current project ! -- for the limited withed projects. type Names_And_Id is record Path_Name : Path_Name_Type; Canonical_Path_Name : Path_Name_Type; Id : Project_Node_Id; + Limited_With : Boolean; end record; package Project_Stack is new Table.Table *************** package body Prj.Part is *** 144,171 **** -- does not (because it is already extended), but other projects that it -- imports may need to be virtually extended. procedure Pre_Parse_Context_Clause (In_Tree : Project_Node_Tree_Ref; Context_Clause : out With_Id); ! -- Parse the context clause of a project. ! -- Store the paths and locations of the imported projects in table Withs. ! -- Does nothing if there is no context clause (if the current ! -- token is not "with" or "limited" followed by "with"). procedure Post_Parse_Context_Clause (Context_Clause : With_Id; In_Tree : Project_Node_Tree_Ref; ! Imported_Projects : out Project_Node_Id; Project_Directory : Path_Name_Type; From_Extended : Extension_Origin; In_Limited : Boolean; Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String); ! -- Parse the imported projects that have been stored in table Withs, ! -- if any. From_Extended is used for the call to Parse_Single_Project ! -- below. When In_Limited is True, the importing path includes at least ! -- one "limited with". function Project_Path_Name_Of (Project_File_Name : String; --- 149,202 ---- -- does not (because it is already extended), but other projects that it -- imports may need to be virtually extended. + type Extension_Origin is (None, Extending_Simple, Extending_All); + -- Type of parameter From_Extended for procedures Parse_Single_Project and + -- Post_Parse_Context_Clause. Extending_All means that we are parsing the + -- tree rooted at an extending all project. + + procedure Parse_Single_Project + (In_Tree : Project_Node_Tree_Ref; + Project : out Project_Node_Id; + Extends_All : out Boolean; + Path_Name : String; + Extended : Boolean; + From_Extended : Extension_Origin; + In_Limited : Boolean; + Packages_To_Check : String_List_Access; + Depth : Natural; + Current_Dir : String); + -- Parse a project file. This is a recursive procedure: it calls itself for + -- imported and extended projects. When From_Extended is not None, if the + -- project has already been parsed and is an extended project A, return the + -- ultimate (not extended) project that extends A. When In_Limited is True, + -- the importing path includes at least one "limited with". When parsing + -- configuration projects, do not allow a depth > 1. + procedure Pre_Parse_Context_Clause (In_Tree : Project_Node_Tree_Ref; Context_Clause : out With_Id); ! -- Parse the context clause of a project. Store the paths and locations of ! -- the imported projects in table Withs. Does nothing if there is no ! -- context clause (if the current token is not "with" or "limited" followed ! -- by "with"). procedure Post_Parse_Context_Clause (Context_Clause : With_Id; In_Tree : Project_Node_Tree_Ref; ! Limited_Withs : Boolean; ! Imported_Projects : in out Project_Node_Id; Project_Directory : Path_Name_Type; From_Extended : Extension_Origin; In_Limited : Boolean; Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String); ! -- Parse the imported projects that have been stored in table Withs, if ! -- any. From_Extended is used for the call to Parse_Single_Project below. ! -- When In_Limited is True, the importing path includes at least one ! -- "limited with". When Limited_Withs is False, only non limited withed ! -- projects are parsed. When Limited_Withs is True, only limited withed ! -- projects are parsed. function Project_Path_Name_Of (Project_File_Name : String; *************** package body Prj.Part is *** 327,333 **** E => (Name => Virtual_Name_Id, Node => Virtual_Project, Canonical_Path => No_Path, ! Extended => False)); end Create_Virtual_Extending_Project; ---------------------------- --- 358,365 ---- E => (Name => Virtual_Name_Id, Node => Virtual_Project, Canonical_Path => No_Path, ! Extended => False, ! Proj_Qualifier => Unspecified)); end Create_Virtual_Extending_Project; ---------------------------- *************** package body Prj.Part is *** 390,410 **** -- Nothing to do if Proj is not defined or if it has already been -- processed. ! if Proj /= Empty_Node and then not Processed_Hash.Get (Proj) then -- Make sure the project will not be processed again Processed_Hash.Set (Proj, True); Declaration := Project_Declaration_Of (Proj, In_Tree); ! if Declaration /= Empty_Node then Extended := Extended_Project_Of (Declaration, In_Tree); end if; -- If this is a project that may need a virtual extending project -- and it is not itself an extending project, put it in the list. ! if Potentially_Virtual and then Extended = Empty_Node then Virtual_Hash.Set (Proj, Proj); end if; --- 422,442 ---- -- Nothing to do if Proj is not defined or if it has already been -- processed. ! if Present (Proj) and then not Processed_Hash.Get (Proj) then -- Make sure the project will not be processed again Processed_Hash.Set (Proj, True); Declaration := Project_Declaration_Of (Proj, In_Tree); ! if Present (Declaration) then Extended := Extended_Project_Of (Declaration, In_Tree); end if; -- If this is a project that may need a virtual extending project -- and it is not itself an extending project, put it in the list. ! if Potentially_Virtual and then No (Extended) then Virtual_Hash.Set (Proj, Proj); end if; *************** package body Prj.Part is *** 412,421 **** With_Clause := First_With_Clause_Of (Proj, In_Tree); ! while With_Clause /= Empty_Node loop Imported := Project_Node_Of (With_Clause, In_Tree); ! if Imported /= Empty_Node then Look_For_Virtual_Projects_For (Imported, In_Tree, Potentially_Virtual => True); end if; --- 444,453 ---- With_Clause := First_With_Clause_Of (Proj, In_Tree); ! while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); ! if Present (Imported) then Look_For_Virtual_Projects_For (Imported, In_Tree, Potentially_Virtual => True); end if; *************** package body Prj.Part is *** 506,512 **** -- virtual extending projects and check that there are no illegally -- imported projects. ! if Project /= Empty_Node and then Is_Extending_All (Project, In_Tree) then -- First look for projects that potentially need a virtual --- 538,544 ---- -- virtual extending projects and check that there are no illegally -- imported projects. ! if Present (Project) and then Is_Extending_All (Project, In_Tree) then -- First look for projects that potentially need a virtual *************** package body Prj.Part is *** 543,552 **** begin With_Clause := First_With_Clause_Of (Project, In_Tree); ! while With_Clause /= Empty_Node loop Imported := Project_Node_Of (With_Clause, In_Tree); ! if Imported /= Empty_Node then Declaration := Project_Declaration_Of (Imported, In_Tree); if Extended_Project_Of (Declaration, In_Tree) /= --- 575,584 ---- begin With_Clause := First_With_Clause_Of (Project, In_Tree); ! while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); ! if Present (Imported) then Declaration := Project_Declaration_Of (Imported, In_Tree); if Extended_Project_Of (Declaration, In_Tree) /= *************** package body Prj.Part is *** 555,561 **** loop Imported := Extended_Project_Of (Declaration, In_Tree); ! exit when Imported = Empty_Node; Virtual_Hash.Remove (Imported); Declaration := Project_Declaration_Of (Imported, In_Tree); --- 587,593 ---- loop Imported := Extended_Project_Of (Declaration, In_Tree); ! exit when No (Imported); Virtual_Hash.Remove (Imported); Declaration := Project_Declaration_Of (Imported, In_Tree); *************** package body Prj.Part is *** 572,578 **** declare Proj : Project_Node_Id := Virtual_Hash.Get_First; begin ! while Proj /= Empty_Node loop Create_Virtual_Extending_Project (Proj, Project, In_Tree); Proj := Virtual_Hash.Get_Next; end loop; --- 604,610 ---- declare Proj : Project_Node_Id := Virtual_Hash.Get_First; begin ! while Present (Proj) loop Create_Virtual_Extending_Project (Proj, Project, In_Tree); Proj := Virtual_Hash.Get_Next; end loop; *************** package body Prj.Part is *** 586,592 **** Project := Empty_Node; end if; ! if Project = Empty_Node or else Always_Errout_Finalize then Prj.Err.Finalize; end if; end; --- 618,624 ---- Project := Empty_Node; end if; ! if No (Project) or else Always_Errout_Finalize then Prj.Err.Finalize; end if; end; *************** package body Prj.Part is *** 645,651 **** Comma_Loop : loop ! Scan (In_Tree); -- scan past WITH or "," Expect (Tok_String_Literal, "literal string"); --- 677,683 ---- Comma_Loop : loop ! Scan (In_Tree); -- past WITH or "," Expect (Tok_String_Literal, "literal string"); *************** package body Prj.Part is *** 682,688 **** -- End of (possibly multiple) with clause; ! Scan (In_Tree); -- scan past the semicolon. exit Comma_Loop; elsif Token = Tok_Comma then --- 714,720 ---- -- End of (possibly multiple) with clause; ! Scan (In_Tree); -- past the semicolon exit Comma_Loop; elsif Token = Tok_Comma then *************** package body Prj.Part is *** 707,713 **** procedure Post_Parse_Context_Clause (Context_Clause : With_Id; In_Tree : Project_Node_Tree_Ref; ! Imported_Projects : out Project_Node_Id; Project_Directory : Path_Name_Type; From_Extended : Extension_Origin; In_Limited : Boolean; --- 739,746 ---- procedure Post_Parse_Context_Clause (Context_Clause : With_Id; In_Tree : Project_Node_Tree_Ref; ! Limited_Withs : Boolean; ! Imported_Projects : in out Project_Node_Id; Project_Directory : Path_Name_Type; From_Extended : Extension_Origin; In_Limited : Boolean; *************** package body Prj.Part is *** 717,723 **** is Current_With_Clause : With_Id := Context_Clause; ! Current_Project : Project_Node_Id := Empty_Node; Previous_Project : Project_Node_Id := Empty_Node; Next_Project : Project_Node_Id := Empty_Node; --- 750,756 ---- is Current_With_Clause : With_Id := Context_Clause; ! Current_Project : Project_Node_Id := Imported_Projects; Previous_Project : Project_Node_Id := Empty_Node; Next_Project : Project_Node_Id := Empty_Node; *************** package body Prj.Part is *** 725,887 **** Get_Name_String (Project_Directory); Current_With : With_Record; - Limited_With : Boolean := False; Extends_All : Boolean := False; begin ! Imported_Projects := Empty_Node; while Current_With_Clause /= No_With loop Current_With := Withs.Table (Current_With_Clause); Current_With_Clause := Current_With.Next; ! Limited_With := In_Limited or Current_With.Limited_With; ! ! declare ! Original_Path : constant String := ! Get_Name_String (Current_With.Path); ! ! Imported_Path_Name : constant String := ! Project_Path_Name_Of ! (Original_Path, Project_Directory_Path); ! Resolved_Path : constant String := ! Normalize_Pathname ! (Imported_Path_Name, ! Directory => Current_Dir, ! Resolve_Links => Opt.Follow_Links_For_Files, ! Case_Sensitive => True); ! Withed_Project : Project_Node_Id := Empty_Node; ! begin ! if Imported_Path_Name = "" then ! -- The project file cannot be found ! Error_Msg_File_1 := File_Name_Type (Current_With.Path); ! Error_Msg ("unknown project file: {", Current_With.Location); ! -- If this is not imported by the main project file, ! -- display the import path. ! if Project_Stack.Last > 1 then ! for Index in reverse 1 .. Project_Stack.Last loop ! Error_Msg_File_1 := ! File_Name_Type (Project_Stack.Table (Index).Path_Name); ! Error_Msg ("\imported by {", Current_With.Location); ! end loop; ! end if; ! else ! -- New with clause ! Previous_Project := Current_Project; ! if Current_Project = Empty_Node then ! -- First with clause of the context clause ! Current_Project := Current_With.Node; ! Imported_Projects := Current_Project; ! else ! Next_Project := Current_With.Node; ! Set_Next_With_Clause_Of ! (Current_Project, In_Tree, Next_Project); ! Current_Project := Next_Project; ! end if; ! Set_String_Value_Of ! (Current_Project, In_Tree, Name_Id (Current_With.Path)); ! Set_Location_Of ! (Current_Project, In_Tree, Current_With.Location); ! -- If this is a "limited with", check if we have a circularity. ! -- If we have one, get the project id of the limited imported ! -- project file, and do not parse it. ! if Limited_With and then Project_Stack.Last > 1 then ! declare ! Canonical_Path_Name : Path_Name_Type; ! begin ! Name_Len := Resolved_Path'Length; ! Name_Buffer (1 .. Name_Len) := Resolved_Path; ! Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); ! Canonical_Path_Name := Name_Find; ! for Index in 1 .. Project_Stack.Last loop ! if Project_Stack.Table (Index).Canonical_Path_Name = Canonical_Path_Name ! then ! -- We have found the limited imported project, ! -- get its project id, and do not parse it. ! Withed_Project := Project_Stack.Table (Index).Id; ! exit; ! end if; ! end loop; ! end; ! end if; ! -- Parse the imported project, if its project id is unknown ! if Withed_Project = Empty_Node then ! Parse_Single_Project ! (In_Tree => In_Tree, ! Project => Withed_Project, ! Extends_All => Extends_All, ! Path_Name => Imported_Path_Name, ! Extended => False, ! From_Extended => From_Extended, ! In_Limited => Limited_With, ! Packages_To_Check => Packages_To_Check, ! Depth => Depth, ! Current_Dir => Current_Dir); ! else ! Extends_All := Is_Extending_All (Withed_Project, In_Tree); ! end if; ! if Withed_Project = Empty_Node then ! -- If parsing was not successful, remove the ! -- context clause. ! Current_Project := Previous_Project; ! if Current_Project = Empty_Node then ! Imported_Projects := Empty_Node; else ! Set_Next_With_Clause_Of ! (Current_Project, In_Tree, Empty_Node); ! end if; ! else ! -- If parsing was successful, record project name ! -- and path name in with clause ! Set_Project_Node_Of ! (Node => Current_Project, ! In_Tree => In_Tree, ! To => Withed_Project, ! Limited_With => Current_With.Limited_With); ! Set_Name_Of ! (Current_Project, ! In_Tree, ! Name_Of (Withed_Project, In_Tree)); ! Name_Len := Resolved_Path'Length; ! Name_Buffer (1 .. Name_Len) := Resolved_Path; ! Set_Path_Name_Of (Current_Project, In_Tree, Name_Find); ! if Extends_All then ! Set_Is_Extending_All (Current_Project, In_Tree); end if; end if; ! end if; ! end; end loop; end Post_Parse_Context_Clause; --- 758,934 ---- Get_Name_String (Project_Directory); Current_With : With_Record; Extends_All : Boolean := False; begin ! -- Set Current_Project to the last project in the current list, if the ! -- list is not empty. ! ! if Present (Current_Project) then ! while ! Present (Next_With_Clause_Of (Current_Project, In_Tree)) ! loop ! Current_Project := Next_With_Clause_Of (Current_Project, In_Tree); ! end loop; ! end if; while Current_With_Clause /= No_With loop Current_With := Withs.Table (Current_With_Clause); Current_With_Clause := Current_With.Next; ! if Limited_Withs = Current_With.Limited_With then ! declare ! Original_Path : constant String := ! Get_Name_String (Current_With.Path); ! Imported_Path_Name : constant String := ! Project_Path_Name_Of ! (Original_Path, ! Project_Directory_Path); ! Resolved_Path : constant String := ! Normalize_Pathname ! (Imported_Path_Name, ! Directory => Current_Dir, ! Resolve_Links => ! Opt.Follow_Links_For_Files, ! Case_Sensitive => True); ! Withed_Project : Project_Node_Id := Empty_Node; ! begin ! if Imported_Path_Name = "" then ! -- The project file cannot be found ! Error_Msg_File_1 := File_Name_Type (Current_With.Path); ! Error_Msg ! ("unknown project file: {", Current_With.Location); ! -- If this is not imported by the main project file, display ! -- the import path. ! if Project_Stack.Last > 1 then ! for Index in reverse 1 .. Project_Stack.Last loop ! Error_Msg_File_1 := ! File_Name_Type ! (Project_Stack.Table (Index).Path_Name); ! Error_Msg ! ("\imported by {", Current_With.Location); ! end loop; ! end if; ! else ! -- New with clause ! Previous_Project := Current_Project; ! if No (Current_Project) then ! -- First with clause of the context clause ! Current_Project := Current_With.Node; ! Imported_Projects := Current_Project; ! else ! Next_Project := Current_With.Node; ! Set_Next_With_Clause_Of ! (Current_Project, In_Tree, Next_Project); ! Current_Project := Next_Project; ! end if; ! Set_String_Value_Of ! (Current_Project, ! In_Tree, ! Name_Id (Current_With.Path)); ! Set_Location_Of ! (Current_Project, In_Tree, Current_With.Location); ! -- If it is a limited with, check if we have a circularity. ! -- If we have one, get the project id of the limited ! -- imported project file, and do not parse it. ! if Limited_Withs and then Project_Stack.Last > 1 then ! declare ! Canonical_Path_Name : Path_Name_Type; ! begin ! Name_Len := Resolved_Path'Length; ! Name_Buffer (1 .. Name_Len) := Resolved_Path; ! Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); ! Canonical_Path_Name := Name_Find; ! for Index in 1 .. Project_Stack.Last loop ! if Project_Stack.Table (Index).Canonical_Path_Name = Canonical_Path_Name ! then ! -- We have found the limited imported project, ! -- get its project id, and do not parse it. ! Withed_Project := Project_Stack.Table (Index).Id; ! exit; ! end if; ! end loop; ! end; ! end if; ! -- Parse the imported project, if its project id is unknown ! if No (Withed_Project) then ! Parse_Single_Project ! (In_Tree => In_Tree, ! Project => Withed_Project, ! Extends_All => Extends_All, ! Path_Name => Imported_Path_Name, ! Extended => False, ! From_Extended => From_Extended, ! In_Limited => Limited_Withs, ! Packages_To_Check => Packages_To_Check, ! Depth => Depth, ! Current_Dir => Current_Dir); ! else ! Extends_All := Is_Extending_All (Withed_Project, In_Tree); ! end if; ! if No (Withed_Project) then ! -- If parsing unsuccessful, remove the context clause ! Current_Project := Previous_Project; + if No (Current_Project) then + Imported_Projects := Empty_Node; + + else + Set_Next_With_Clause_Of + (Current_Project, In_Tree, Empty_Node); + end if; else ! -- If parsing was successful, record project name and ! -- path name in with clause ! Set_Project_Node_Of ! (Node => Current_Project, ! In_Tree => In_Tree, ! To => Withed_Project, ! Limited_With => Current_With.Limited_With); ! Set_Name_Of ! (Current_Project, ! In_Tree, ! Name_Of (Withed_Project, In_Tree)); ! Name_Len := Resolved_Path'Length; ! Name_Buffer (1 .. Name_Len) := Resolved_Path; ! Set_Path_Name_Of (Current_Project, In_Tree, Name_Find); ! if Extends_All then ! Set_Is_Extending_All (Current_Project, In_Tree); ! end if; end if; end if; ! end; ! end if; end loop; end Post_Parse_Context_Clause; *************** package body Prj.Part is *** 909,930 **** Extending : Boolean := False; ! Extended_Project : Project_Node_Id := Empty_Node; A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_First (In_Tree.Projects_HT); ! Name_From_Path : constant Name_Id := Project_Name_From (Path_Name); ! Name_Of_Project : Name_Id := No_Name; ! First_With : With_Id; use Tree_Private_Part; Project_Comment_State : Tree.Comment_State; begin Extends_All := False; --- 956,982 ---- Extending : Boolean := False; ! Extended_Project : Project_Node_Id := Empty_Node; A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_First (In_Tree.Projects_HT); ! Name_From_Path : constant Name_Id := Project_Name_From (Path_Name); Name_Of_Project : Name_Id := No_Name; ! Duplicated : Boolean := False; ! ! First_With : With_Id; ! Imported_Projects : Project_Node_Id := Empty_Node; use Tree_Private_Part; Project_Comment_State : Tree.Comment_State; + Proj_Qualifier : Project_Qualifier := Unspecified; + Qualifier_Location : Source_Ptr; + begin Extends_All := False; *************** package body Prj.Part is *** 939,945 **** Directory => Current_Dir, Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => False); - begin Name_Len := Normed_Path'Length; Name_Buffer (1 .. Name_Len) := Normed_Path; --- 991,996 ---- *************** package body Prj.Part is *** 951,957 **** -- Check for a circular dependency ! for Index in 1 .. Project_Stack.Last loop if Canonical_Path_Name = Project_Stack.Table (Index).Canonical_Path_Name then --- 1002,1010 ---- -- Check for a circular dependency ! for Index in reverse 1 .. Project_Stack.Last loop ! exit when Project_Stack.Table (Index).Limited_With; ! if Canonical_Path_Name = Project_Stack.Table (Index).Canonical_Path_Name then *************** package body Prj.Part is *** 982,991 **** -- Put the new path name on the stack ! Project_Stack.Increment_Last; ! Project_Stack.Table (Project_Stack.Last).Path_Name := Normed_Path_Name; ! Project_Stack.Table (Project_Stack.Last).Canonical_Path_Name := ! Canonical_Path_Name; -- Check if the project file has already been parsed --- 1035,1045 ---- -- Put the new path name on the stack ! Project_Stack.Append ! ((Path_Name => Normed_Path_Name, ! Canonical_Path_Name => Canonical_Path_Name, ! Id => Empty_Node, ! Limited_With => In_Limited)); -- Check if the project file has already been parsed *************** package body Prj.Part is *** 996,1004 **** if Extended then if A_Project_Name_And_Node.Extended then ! Error_Msg ! ("cannot extend the same project file several times", ! Token_Ptr); else Error_Msg ("cannot extend an already imported project file", --- 1050,1060 ---- if Extended then if A_Project_Name_And_Node.Extended then ! if A_Project_Name_And_Node.Proj_Qualifier /= Dry then ! Error_Msg ! ("cannot extend the same project file several times", ! Token_Ptr); ! end if; else Error_Msg ("cannot extend an already imported project file", *************** package body Prj.Part is *** 1009,1017 **** Extends_All := Is_Extending_All (A_Project_Name_And_Node.Node, In_Tree); ! -- If the imported project is an extended project A, ! -- and we are in an extended project, replace A with the ! -- ultimate project extending A. if From_Extended /= None then declare --- 1065,1073 ---- Extends_All := Is_Extending_All (A_Project_Name_And_Node.Node, In_Tree); ! -- If the imported project is an extended project A, and we are ! -- in an extended project, replace A with the ultimate project ! -- extending A. if From_Extended /= None then declare *************** package body Prj.Part is *** 1048,1055 **** Tree_Private_Part.Projects_Htable.Get_Next (In_Tree.Projects_HT); end loop; ! -- We never encountered this project file ! -- Save the scan state, load the project file and start to scan it. Save_Project_Scan_State (Project_Scan_State); Source_Index := Load_Project_File (Path_Name); --- 1104,1111 ---- Tree_Private_Part.Projects_Htable.Get_Next (In_Tree.Projects_HT); end loop; ! -- We never encountered this project file. Save the scan state, load the ! -- project file and start to scan it. Save_Project_Scan_State (Project_Scan_State); Source_Index := Load_Project_File (Path_Name); *************** package body Prj.Part is *** 1067,1076 **** Tree.Reset_State; Scan (In_Tree); ! if (not In_Configuration) and then (Name_From_Path = No_Name) then ! -- The project file name is not correct (no or bad extension, ! -- or not following Ada identifier's syntax). Error_Msg_File_1 := File_Name_Type (Canonical_Path_Name); Error_Msg ("?{ is not a valid path name for a project file", --- 1123,1132 ---- Tree.Reset_State; Scan (In_Tree); ! if not In_Configuration and then Name_From_Path = No_Name then ! -- The project file name is not correct (no or bad extension, or not ! -- following Ada identifier's syntax). Error_Msg_File_1 := File_Name_Type (Canonical_Path_Name); Error_Msg ("?{ is not a valid path name for a project file", *************** package body Prj.Part is *** 1084,1099 **** Write_Eol; end if; -- Is there any imported project? ! Pre_Parse_Context_Clause (In_Tree, First_With); - Project_Directory := Immediate_Directory_Of (Normed_Path_Name); Project := Default_Project_Node (Of_Kind => N_Project, In_Tree => In_Tree); Project_Stack.Table (Project_Stack.Last).Id := Project; Set_Directory_Of (Project, In_Tree, Project_Directory); Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name); Set_Location_Of (Project, In_Tree, Token_Ptr); Expect (Tok_Project, "PROJECT"); --- 1140,1212 ---- Write_Eol; end if; + Project_Directory := Immediate_Directory_Of (Normed_Path_Name); + -- Is there any imported project? ! Pre_Parse_Context_Clause ! (In_Tree => In_Tree, ! Context_Clause => First_With); Project := Default_Project_Node (Of_Kind => N_Project, In_Tree => In_Tree); Project_Stack.Table (Project_Stack.Last).Id := Project; Set_Directory_Of (Project, In_Tree, Project_Directory); Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name); + + -- Check if there is a qualifier before the reserved word "project" + + Qualifier_Location := Token_Ptr; + + if Token = Tok_Abstract then + Proj_Qualifier := Dry; + Scan (In_Tree); + + elsif Token = Tok_Identifier then + case Token_Name is + when Snames.Name_Standard => + Proj_Qualifier := Standard; + Scan (In_Tree); + + when Snames.Name_Aggregate => + Proj_Qualifier := Aggregate; + Scan (In_Tree); + + if Token = Tok_Identifier and then + Token_Name = Snames.Name_Library + then + Proj_Qualifier := Aggregate_Library; + Scan (In_Tree); + end if; + + when Snames.Name_Library => + Proj_Qualifier := Library; + Scan (In_Tree); + + when Snames.Name_Configuration => + if not In_Configuration then + Error_Msg ("configuration projects cannot belong to a user" & + " project tree", + Token_Ptr); + end if; + + Scan (In_Tree); + + when others => + null; + end case; + end if; + + if Proj_Qualifier /= Unspecified then + if In_Configuration then + Error_Msg ("a configuration project cannot be qualified except " & + "as configuration project", + Qualifier_Location); + end if; + + Set_Project_Qualifier_Of (Project, In_Tree, Proj_Qualifier); + end if; + Set_Location_Of (Project, In_Tree, Token_Ptr); Expect (Tok_Project, "PROJECT"); *************** package body Prj.Part is *** 1101,1107 **** -- Mark location of PROJECT token if present if Token = Tok_Project then ! Scan (In_Tree); -- scan past PROJECT Set_Location_Of (Project, In_Tree, Token_Ptr); end if; --- 1214,1220 ---- -- Mark location of PROJECT token if present if Token = Tok_Project then ! Scan (In_Tree); -- past PROJECT Set_Location_Of (Project, In_Tree, Token_Ptr); end if; *************** package body Prj.Part is *** 1156,1162 **** Extending := True; ! Scan (In_Tree); -- scan past EXTENDS if Token = Tok_All then Extends_All := True; --- 1269,1275 ---- Extending := True; ! Scan (In_Tree); -- past EXTENDS if Token = Tok_All then Extends_All := True; *************** package body Prj.Part is *** 1196,1202 **** begin -- Output a warning if the actual name is not the expected name ! if (not In_Configuration) and then (Name_From_Path /= No_Name) and then Expected_Name /= Name_From_Path then --- 1309,1315 ---- begin -- Output a warning if the actual name is not the expected name ! if not In_Configuration and then (Name_From_Path /= No_Name) and then Expected_Name /= Name_From_Path then *************** package body Prj.Part is *** 1216,1222 **** end; declare - Imported_Projects : Project_Node_Id := Empty_Node; From_Ext : Extension_Origin := None; begin --- 1329,1334 ---- *************** package body Prj.Part is *** 1235,1240 **** --- 1347,1353 ---- Post_Parse_Context_Clause (In_Tree => In_Tree, Context_Clause => First_With, + Limited_Withs => False, Imported_Projects => Imported_Projects, Project_Directory => Project_Directory, From_Extended => From_Ext, *************** package body Prj.Part is *** 1267,1272 **** --- 1380,1386 ---- -- Report an error if we already have a project with this name if Project_Name /= No_Name then + Duplicated := True; Error_Msg_Name_1 := Project_Name; Error_Msg ("duplicate project name %%", *************** package body Prj.Part is *** 1275,1293 **** Name_Id (Path_Name_Of (Name_And_Node.Node, In_Tree)); Error_Msg ("\already in %%", Location_Of (Project, In_Tree)); - - else - -- Otherwise, add the name of the project to the hash table, - -- so that we can check that no other subsequent project - -- will have the same name. - - Tree_Private_Part.Projects_Htable.Set - (T => In_Tree.Projects_HT, - K => Name_Of_Project, - E => (Name => Name_Of_Project, - Node => Project, - Canonical_Path => Canonical_Path_Name, - Extended => Extended)); end if; end; end if; --- 1389,1394 ---- *************** package body Prj.Part is *** 1361,1378 **** Current_Dir => Current_Dir); end; ! -- A project that extends an extending-all project is also ! -- an extending-all project. ! if Extended_Project /= Empty_Node ! and then Is_Extending_All (Extended_Project, In_Tree) ! then ! Set_Is_Extending_All (Project, In_Tree); end if; end if; end; ! Scan (In_Tree); -- scan past the extended project path end if; end if; --- 1462,1494 ---- Current_Dir => Current_Dir); end; ! if Present (Extended_Project) then ! -- A project that extends an extending-all project is ! -- also an extending-all project. ! ! if Is_Extending_All (Extended_Project, In_Tree) then ! Set_Is_Extending_All (Project, In_Tree); ! end if; ! ! -- An abstract project can only extend an abstract ! -- project, otherwise we may have an abstract project ! -- with sources, if it inherits sources from the project ! -- it extends. ! ! if Proj_Qualifier = Dry and then ! Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry ! then ! Error_Msg ! ("an abstract project can only extend " & ! "another abstract project", ! Qualifier_Location); ! end if; end if; end if; end; ! Scan (In_Tree); -- past the extended project path end if; end if; *************** package body Prj.Part is *** 1387,1393 **** begin With_Clause_Loop : ! while With_Clause /= Empty_Node loop Imported := Project_Node_Of (With_Clause, In_Tree); if Is_Extending_All (With_Clause, In_Tree) then --- 1503,1509 ---- begin With_Clause_Loop : ! while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); if Is_Extending_All (With_Clause, In_Tree) then *************** package body Prj.Part is *** 1427,1439 **** declare Parent_Name : constant Name_Id := Name_Find; Parent_Found : Boolean := False; With_Clause : Project_Node_Id := First_With_Clause_Of (Project, In_Tree); begin -- If there is an extended project, check its name ! if Extended_Project /= Empty_Node then Parent_Found := Name_Of (Extended_Project, In_Tree) = Parent_Name; end if; --- 1543,1557 ---- declare Parent_Name : constant Name_Id := Name_Find; Parent_Found : Boolean := False; + Parent_Node : Project_Node_Id := Empty_Node; With_Clause : Project_Node_Id := First_With_Clause_Of (Project, In_Tree); begin -- If there is an extended project, check its name ! if Present (Extended_Project) then ! Parent_Node := Extended_Project; Parent_Found := Name_Of (Extended_Project, In_Tree) = Parent_Name; end if; *************** package body Prj.Part is *** 1441,1456 **** -- If the parent project is not the extended project, -- check each imported project until we find the parent project. ! while not Parent_Found and then With_Clause /= Empty_Node loop ! Parent_Found := ! Name_Of (Project_Node_Of (With_Clause, In_Tree), In_Tree) = ! Parent_Name; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; ! -- If the parent project was not found, report an error - if not Parent_Found then Error_Msg_Name_1 := Name_Of_Project; Error_Msg_Name_2 := Parent_Name; Error_Msg ("project %% does not import or extend project %%", --- 1559,1576 ---- -- If the parent project is not the extended project, -- check each imported project until we find the parent project. ! while not Parent_Found and then Present (With_Clause) loop ! Parent_Node := Project_Node_Of (With_Clause, In_Tree); ! Parent_Found := Name_Of (Parent_Node, In_Tree) = Parent_Name; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; ! if Parent_Found then ! Set_Parent_Project_Of (Project, In_Tree, To => Parent_Node); ! ! else ! -- If the parent project was not found, report an error Error_Msg_Name_1 := Name_Of_Project; Error_Msg_Name_2 := Parent_Name; Error_Msg ("project %% does not import or extend project %%", *************** package body Prj.Part is *** 1478,1484 **** Packages_To_Check => Packages_To_Check); Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration); ! if Extended_Project /= Empty_Node then Set_Extending_Project_Of (Project_Declaration_Of (Extended_Project, In_Tree), In_Tree, To => Project); --- 1598,1606 ---- Packages_To_Check => Packages_To_Check); Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration); ! if Present (Extended_Project) ! and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry ! then Set_Extending_Project_Of (Project_Declaration_Of (Extended_Project, In_Tree), In_Tree, To => Project); *************** package body Prj.Part is *** 1553,1558 **** --- 1675,1725 ---- end if; end if; + if not Duplicated and then Name_Of_Project /= No_Name then + + -- Add the name of the project to the hash table, so that we can + -- check that no other subsequent project will have the same name. + + Tree_Private_Part.Projects_Htable.Set + (T => In_Tree.Projects_HT, + K => Name_Of_Project, + E => (Name => Name_Of_Project, + Node => Project, + Canonical_Path => Canonical_Path_Name, + Extended => Extended, + Proj_Qualifier => Proj_Qualifier)); + end if; + + declare + From_Ext : Extension_Origin := None; + + begin + -- Extending_All is always propagated + + if From_Extended = Extending_All or else Extends_All then + From_Ext := Extending_All; + + -- Otherwise, From_Extended is set to Extending_Single if the + -- current project is an extending project. + + elsif Extended then + From_Ext := Extending_Simple; + end if; + + Post_Parse_Context_Clause + (In_Tree => In_Tree, + Context_Clause => First_With, + Limited_Withs => True, + Imported_Projects => Imported_Projects, + Project_Directory => Project_Directory, + From_Extended => From_Ext, + In_Limited => In_Limited, + Packages_To_Check => Packages_To_Check, + Depth => Depth + 1, + Current_Dir => Current_Dir); + Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); + end; + -- Restore the scan state, in case we are not the main project Restore_Project_Scan_State (Project_Scan_State); *************** package body Prj.Part is *** 1610,1628 **** -- If we have a dot, check that it is followed by the correct extension if First > 0 and then Canonical (First) = '.' then ! if ((not In_Configuration) and then ! Canonical (First .. Last) = Project_File_Extension and then ! First /= 1) ! or else ! (In_Configuration and then ! Canonical (First .. Last) = Config_Project_File_Extension and then ! First /= 1) then -- Look for the last directory separator, if any First := First - 1; Last := First; - while First > 0 and then Canonical (First) /= '/' and then Canonical (First) /= Dir_Sep --- 1777,1795 ---- -- If we have a dot, check that it is followed by the correct extension if First > 0 and then Canonical (First) = '.' then ! if (not In_Configuration ! and then Canonical (First .. Last) = Project_File_Extension ! and then First /= 1) ! or else ! (In_Configuration ! and then ! Canonical (First .. Last) = Config_Project_File_Extension ! and then First /= 1) then -- Look for the last directory separator, if any First := First - 1; Last := First; while First > 0 and then Canonical (First) /= '/' and then Canonical (First) /= Dir_Sep *************** package body Prj.Part is *** 1722,1736 **** ------------------- function Try_Path_Name (Path : String) return String_Access is begin if Current_Verbosity = High then Write_Str (" Trying "); ! Write_Str (Path); end if; ! return Locate_Regular_File ! (File_Name => Path, ! Path => Project_Path); end Try_Path_Name; -- Local Declarations --- 1889,1953 ---- ------------------- function Try_Path_Name (Path : String) return String_Access is + Prj_Path : constant String := Project_Path; + First : Natural; + Last : Natural; + Result : String_Access := null; + begin if Current_Verbosity = High then Write_Str (" Trying "); ! Write_Line (Path); end if; ! if Is_Absolute_Path (Path) then ! if Is_Regular_File (Path) then ! Result := new String'(Path); ! end if; ! ! else ! -- Because we don't want to resolve symbolic links, we cannot use ! -- Locate_Regular_File. So, we try each possible path ! -- successively. ! ! First := Prj_Path'First; ! while First <= Prj_Path'Last loop ! while First <= Prj_Path'Last ! and then Prj_Path (First) = Path_Separator ! loop ! First := First + 1; ! end loop; ! ! exit when First > Prj_Path'Last; ! ! Last := First; ! while Last < Prj_Path'Last ! and then Prj_Path (Last + 1) /= Path_Separator ! loop ! Last := Last + 1; ! end loop; ! ! Name_Len := 0; ! ! if not Is_Absolute_Path (Prj_Path (First .. Last)) then ! Add_Str_To_Name_Buffer (Get_Current_Dir); ! Add_Char_To_Name_Buffer (Directory_Separator); ! end if; ! ! Add_Str_To_Name_Buffer (Prj_Path (First .. Last)); ! Add_Char_To_Name_Buffer (Directory_Separator); ! Add_Str_To_Name_Buffer (Path); ! ! if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then ! Result := new String'(Name_Buffer (1 .. Name_Len)); ! exit; ! end if; ! ! First := Last + 1; ! end loop; ! end if; ! ! return Result; end Try_Path_Name; -- Local Declarations diff -Nrcpad gcc-4.3.3/gcc/ada/prj-part.ads gcc-4.4.0/gcc/ada/prj-part.ads *** gcc-4.3.3/gcc/ada/prj-part.ads Thu Dec 13 10:28:39 2007 --- gcc-4.4.0/gcc/ada/prj-part.ads Thu Jul 31 12:37:42 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2008, 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- -- *************** package Prj.Part is *** 49,76 **** -- Current_Directory is used for optimization purposes only, avoiding extra -- system calls. - type Extension_Origin is (None, Extending_Simple, Extending_All); - -- Type of parameter From_Extended for procedures Parse_Single_Project and - -- Post_Parse_Context_Clause. Extending_All means that we are parsing the - -- tree rooted at an extending all project. - - procedure Parse_Single_Project - (In_Tree : Project_Node_Tree_Ref; - Project : out Project_Node_Id; - Extends_All : out Boolean; - Path_Name : String; - Extended : Boolean; - From_Extended : Extension_Origin; - In_Limited : Boolean; - Packages_To_Check : String_List_Access; - Depth : Natural; - Current_Dir : String); - -- Parse a project file. - -- Recursive procedure: it calls itself for imported and extended - -- projects. When From_Extended is not None, if the project has already - -- been parsed and is an extended project A, return the ultimate - -- (not extended) project that extends A. When In_Limited is True, - -- the importing path includes at least one "limited with". - -- When parsing configuration projects, do not allow a depth > 1. - end Prj.Part; --- 49,52 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/prj-pp.adb gcc-4.4.0/gcc/ada/prj-pp.adb *** gcc-4.3.3/gcc/ada/prj-pp.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/prj-pp.adb Tue May 20 12:45:54 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package body Prj.PP is *** 40,46 **** Column : Natural := 0; -- Column number of the last character in the line. Used to avoid ! -- outputing lines longer than Max_Line_Length. First_With_In_List : Boolean := True; -- Indicate that the next with clause is first in a list such as --- 40,46 ---- Column : Natural := 0; -- Column number of the last character in the line. Used to avoid ! -- outputting lines longer than Max_Line_Length. First_With_In_List : Boolean := True; -- Indicate that the next with clause is first in a list such as *************** package body Prj.PP is *** 73,79 **** W_Char : Write_Char_Ap := null; W_Eol : Write_Eol_Ap := null; W_Str : Write_Str_Ap := null; ! Backward_Compatibility : Boolean) is procedure Print (Node : Project_Node_Id; Indent : Natural); -- A recursive procedure that traverses a project file tree and outputs --- 73,81 ---- W_Char : Write_Char_Ap := null; W_Eol : Write_Eol_Ap := null; W_Str : Write_Str_Ap := null; ! Backward_Compatibility : Boolean; ! Id : Prj.Project_Id := Prj.No_Project; ! Id_Tree : Prj.Project_Tree_Ref := null) is procedure Print (Node : Project_Node_Id; Indent : Natural); -- A recursive procedure that traverses a project file tree and outputs *************** package body Prj.PP is *** 317,329 **** procedure Print (Node : Project_Node_Id; Indent : Natural) is begin ! if Node /= Empty_Node then case Kind_Of (Node, In_Tree) is when N_Project => pragma Debug (Indicate_Tested (N_Project)); ! if First_With_Clause_Of (Node, In_Tree) /= Empty_Node then -- with clause(s) --- 319,331 ---- procedure Print (Node : Project_Node_Id; Indent : Natural) is begin ! if Present (Node) then case Kind_Of (Node, In_Tree) is when N_Project => pragma Debug (Indicate_Tested (N_Project)); ! if Present (First_With_Clause_Of (Node, In_Tree)) then -- with clause(s) *************** package body Prj.PP is *** 335,341 **** Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Write_String ("project "); ! Output_Name (Name_Of (Node, In_Tree)); -- Check if this project extends another project --- 337,348 ---- Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Write_String ("project "); ! ! if Id /= Prj.No_Project then ! Output_Name (Id_Tree.Projects.Table (Id).Display_Name); ! else ! Output_Name (Name_Of (Node, In_Tree)); ! end if; -- Check if this project extends another project *************** package body Prj.PP is *** 363,369 **** Indent + Increment); Start_Line (Indent); Write_String ("end "); ! Output_Name (Name_Of (Node, In_Tree)); Write_Line (";"); Print (First_Comment_After_End (Node, In_Tree), Indent); --- 370,382 ---- Indent + Increment); Start_Line (Indent); Write_String ("end "); ! ! if Id /= Prj.No_Project then ! Output_Name (Id_Tree.Projects.Table (Id).Display_Name); ! else ! Output_Name (Name_Of (Node, In_Tree)); ! end if; ! Write_Line (";"); Print (First_Comment_After_End (Node, In_Tree), Indent); *************** package body Prj.PP is *** 411,417 **** pragma Debug (Indicate_Tested (N_Project_Declaration)); if ! First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node then Print (First_Declarative_Item_Of (Node, In_Tree), --- 424,430 ---- pragma Debug (Indicate_Tested (N_Project_Declaration)); if ! Present (First_Declarative_Item_Of (Node, In_Tree)) then Print (First_Declarative_Item_Of (Node, In_Tree), *************** package body Prj.PP is *** 485,496 **** First_Literal_String (Node, In_Tree); begin ! while String_Node /= Empty_Node loop Output_String (String_Value_Of (String_Node, In_Tree)); String_Node := Next_Literal_String (String_Node, In_Tree); ! if String_Node /= Empty_Node then Write_String (", "); end if; end loop; --- 498,509 ---- First_Literal_String (Node, In_Tree); begin ! while Present (String_Node) loop Output_String (String_Value_Of (String_Node, In_Tree)); String_Node := Next_Literal_String (String_Node, In_Tree); ! if Present (String_Node) then Write_String (", "); end if; end loop; *************** package body Prj.PP is *** 530,536 **** end if; Write_String (" use "); ! Print (Expression_Of (Node, In_Tree), Indent); Write_String (";"); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); --- 543,586 ---- end if; Write_String (" use "); ! ! if Present (Expression_Of (Node, In_Tree)) then ! Print (Expression_Of (Node, In_Tree), Indent); ! ! else ! -- Full associative array declaration ! ! if ! Present (Associative_Project_Of (Node, In_Tree)) ! then ! Output_Name ! (Name_Of ! (Associative_Project_Of (Node, In_Tree), ! In_Tree)); ! ! if ! Present (Associative_Package_Of (Node, In_Tree)) ! then ! Write_String ("."); ! Output_Name ! (Name_Of ! (Associative_Package_Of (Node, In_Tree), ! In_Tree)); ! end if; ! ! elsif ! Present (Associative_Package_Of (Node, In_Tree)) ! then ! Output_Name ! (Name_Of ! (Associative_Package_Of (Node, In_Tree), ! In_Tree)); ! end if; ! ! Write_String ("'"); ! Output_Attribute_Name (Name_Of (Node, In_Tree)); ! end if; ! Write_String (";"); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); *************** package body Prj.PP is *** 567,577 **** Term : Project_Node_Id := First_Term (Node, In_Tree); begin ! while Term /= Empty_Node loop Print (Term, Indent); Term := Next_Term (Term, In_Tree); ! if Term /= Empty_Node then Write_String (" & "); end if; end loop; --- 617,627 ---- Term : Project_Node_Id := First_Term (Node, In_Tree); begin ! while Present (Term) loop Print (Term, Indent); Term := Next_Term (Term, In_Tree); ! if Present (Term) then Write_String (" & "); end if; end loop; *************** package body Prj.PP is *** 590,601 **** First_Expression_In_List (Node, In_Tree); begin ! while Expression /= Empty_Node loop Print (Expression, Indent); Expression := Next_Expression_In_List (Expression, In_Tree); ! if Expression /= Empty_Node then Write_String (", "); end if; end loop; --- 640,651 ---- First_Expression_In_List (Node, In_Tree); begin ! while Present (Expression) loop Print (Expression, Indent); Expression := Next_Expression_In_List (Expression, In_Tree); ! if Present (Expression) then Write_String (", "); end if; end loop; *************** package body Prj.PP is *** 605,617 **** when N_Variable_Reference => pragma Debug (Indicate_Tested (N_Variable_Reference)); ! if Project_Node_Of (Node, In_Tree) /= Empty_Node then Output_Name (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree)); Write_String ("."); end if; ! if Package_Node_Of (Node, In_Tree) /= Empty_Node then Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree)); Write_String ("."); --- 655,667 ---- when N_Variable_Reference => pragma Debug (Indicate_Tested (N_Variable_Reference)); ! if Present (Project_Node_Of (Node, In_Tree)) then Output_Name (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree)); Write_String ("."); end if; ! if Present (Package_Node_Of (Node, In_Tree)) then Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree)); Write_String ("."); *************** package body Prj.PP is *** 624,630 **** Write_String ("external ("); Print (External_Reference_Of (Node, In_Tree), Indent); ! if External_Default_Of (Node, In_Tree) /= Empty_Node then Write_String (", "); Print (External_Default_Of (Node, In_Tree), Indent); end if; --- 674,680 ---- Write_String ("external ("); Print (External_Reference_Of (Node, In_Tree), Indent); ! if Present (External_Default_Of (Node, In_Tree)) then Write_String (", "); Print (External_Default_Of (Node, In_Tree), Indent); end if; *************** package body Prj.PP is *** 634,652 **** when N_Attribute_Reference => pragma Debug (Indicate_Tested (N_Attribute_Reference)); ! if Project_Node_Of (Node, In_Tree) /= Empty_Node and then Project_Node_Of (Node, In_Tree) /= Project then Output_Name (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree)); ! if Package_Node_Of (Node, In_Tree) /= Empty_Node then Write_String ("."); Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree)); end if; ! elsif Package_Node_Of (Node, In_Tree) /= Empty_Node then Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree)); --- 684,702 ---- when N_Attribute_Reference => pragma Debug (Indicate_Tested (N_Attribute_Reference)); ! if Present (Project_Node_Of (Node, In_Tree)) and then Project_Node_Of (Node, In_Tree) /= Project then Output_Name (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree)); ! if Present (Package_Node_Of (Node, In_Tree)) then Write_String ("."); Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree)); end if; ! elsif Present (Package_Node_Of (Node, In_Tree)) then Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree)); *************** package body Prj.PP is *** 678,687 **** begin Case_Item := First_Case_Item_Of (Node, In_Tree); ! while Case_Item /= Empty_Node loop ! if First_Declarative_Item_Of (Case_Item, In_Tree) /= ! Empty_Node ! or else not Eliminate_Empty_Case_Constructions then Is_Non_Empty := True; exit; --- 728,737 ---- begin Case_Item := First_Case_Item_Of (Node, In_Tree); ! while Present (Case_Item) loop ! if Present ! (First_Declarative_Item_Of (Case_Item, In_Tree)) ! or else not Eliminate_Empty_Case_Constructions then Is_Non_Empty := True; exit; *************** package body Prj.PP is *** 708,714 **** Case_Item : Project_Node_Id := First_Case_Item_Of (Node, In_Tree); begin ! while Case_Item /= Empty_Node loop pragma Assert (Kind_Of (Case_Item, In_Tree) = N_Case_Item); Print (Case_Item, Indent + Increment); --- 758,764 ---- Case_Item : Project_Node_Id := First_Case_Item_Of (Node, In_Tree); begin ! while Present (Case_Item) loop pragma Assert (Kind_Of (Case_Item, In_Tree) = N_Case_Item); Print (Case_Item, Indent + Increment); *************** package body Prj.PP is *** 729,735 **** when N_Case_Item => pragma Debug (Indicate_Tested (N_Case_Item)); ! if First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node or else not Eliminate_Empty_Case_Constructions then Write_Empty_Line; --- 779,785 ---- when N_Case_Item => pragma Debug (Indicate_Tested (N_Case_Item)); ! if Present (First_Declarative_Item_Of (Node, In_Tree)) or else not Eliminate_Empty_Case_Constructions then Write_Empty_Line; *************** package body Prj.PP is *** 737,743 **** Start_Line (Indent); Write_String ("when "); ! if First_Choice_Of (Node, In_Tree) = Empty_Node then Write_String ("others"); else --- 787,793 ---- Start_Line (Indent); Write_String ("when "); ! if No (First_Choice_Of (Node, In_Tree)) then Write_String ("others"); else *************** package body Prj.PP is *** 745,755 **** Label : Project_Node_Id := First_Choice_Of (Node, In_Tree); begin ! while Label /= Empty_Node loop Print (Label, Indent); Label := Next_Literal_String (Label, In_Tree); ! if Label /= Empty_Node then Write_String (" | "); end if; end loop; --- 795,805 ---- Label : Project_Node_Id := First_Choice_Of (Node, In_Tree); begin ! while Present (Label) loop Print (Label, Indent); Label := Next_Literal_String (Label, In_Tree); ! if Present (Label) then Write_String (" | "); end if; end loop; *************** package body Prj.PP is *** 766,772 **** First : constant Project_Node_Id := First_Declarative_Item_Of (Node, In_Tree); begin ! if First = Empty_Node then Write_Empty_Line; else Print (First, Indent + Increment); --- 816,822 ---- First : constant Project_Node_Id := First_Declarative_Item_Of (Node, In_Tree); begin ! if No (First) then Write_Empty_Line; else Print (First, Indent + Increment); diff -Nrcpad gcc-4.3.3/gcc/ada/prj-pp.ads gcc-4.4.0/gcc/ada/prj-pp.ads *** gcc-4.3.3/gcc/ada/prj-pp.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/prj-pp.ads Tue Apr 8 06:58:02 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package Prj.PP is *** 52,58 **** W_Char : Write_Char_Ap := null; W_Eol : Write_Eol_Ap := null; W_Str : Write_Str_Ap := null; ! Backward_Compatibility : Boolean); -- Output a project file, using either the default output routines, or the -- ones specified by W_Char, W_Eol and W_Str. -- --- 52,60 ---- W_Char : Write_Char_Ap := null; W_Eol : Write_Eol_Ap := null; W_Str : Write_Str_Ap := null; ! Backward_Compatibility : Boolean; ! Id : Prj.Project_Id := Prj.No_Project; ! Id_Tree : Prj.Project_Tree_Ref := null); -- Output a project file, using either the default output routines, or the -- ones specified by W_Char, W_Eol and W_Str. -- *************** package Prj.PP is *** 73,78 **** --- 75,83 ---- -- Spec_Suffix, Body, Body_Suffix) will be replaced by obsolete ones -- (Specification, Specification_Suffix, Implementation, -- Implementation_Suffix). + -- + -- Id is used to compute the display name of the project including its + -- proper casing. private diff -Nrcpad gcc-4.3.3/gcc/ada/prj-proc.adb gcc-4.4.0/gcc/ada/prj-proc.adb *** gcc-4.3.3/gcc/ada/prj-proc.adb Thu Dec 13 10:28:39 2007 --- gcc-4.4.0/gcc/ada/prj-proc.adb Wed Aug 20 15:51:02 2008 *************** *** 1,5 **** ------------------------------------------------------------------------------ - -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- 1,4 ---- *************** *** 7,13 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package body Prj.Proc is *** 84,95 **** -- Current_Dir is for optimization purposes, avoiding extra system calls. procedure Copy_Package_Declarations ! (From : Declarations; ! To : in out Declarations; ! New_Loc : Source_Ptr; ! In_Tree : Project_Tree_Ref); -- Copy a package declaration From to To for a renamed package. Change the ! -- locations of all the attributes to New_Loc. function Expression (Project : Project_Id; --- 83,97 ---- -- Current_Dir is for optimization purposes, avoiding extra system calls. procedure Copy_Package_Declarations ! (From : Declarations; ! To : in out Declarations; ! New_Loc : Source_Ptr; ! Naming_Restricted : Boolean; ! In_Tree : Project_Tree_Ref); -- Copy a package declaration From to To for a renamed package. Change the ! -- locations of all the attributes to New_Loc. When Naming_Restricted is ! -- True, do not copy attributes Body, Spec, Implementation and ! -- Specification. function Expression (Project : Project_Id; *************** package body Prj.Proc is *** 311,320 **** ------------------------------- procedure Copy_Package_Declarations ! (From : Declarations; ! To : in out Declarations; ! New_Loc : Source_Ptr; ! In_Tree : Project_Tree_Ref) is V1 : Variable_Id := From.Attributes; V2 : Variable_Id := No_Variable; --- 313,323 ---- ------------------------------- procedure Copy_Package_Declarations ! (From : Declarations; ! To : in out Declarations; ! New_Loc : Source_Ptr; ! Naming_Restricted : Boolean; ! In_Tree : Project_Tree_Ref) is V1 : Variable_Id := From.Attributes; V2 : Variable_Id := No_Variable; *************** package body Prj.Proc is *** 369,435 **** while A1 /= No_Array loop - -- Copy the array - Arr := In_Tree.Arrays.Table (A1); A1 := Arr.Next; ! -- Remove the Next component ! Arr.Next := No_Array; ! Array_Table.Increment_Last (In_Tree.Arrays); ! -- Create new Array declaration ! if To.Arrays = No_Array then ! To.Arrays := Array_Table.Last (In_Tree.Arrays); ! else ! In_Tree.Arrays.Table (A2).Next := ! Array_Table.Last (In_Tree.Arrays); ! end if; ! A2 := Array_Table.Last (In_Tree.Arrays); ! -- Don't store the array, as its first element has not been set yet ! -- Copy the array elements of the array ! E1 := Arr.Value; ! Arr.Value := No_Array_Element; ! while E1 /= No_Array_Element loop ! -- Copy the array element ! Elm := In_Tree.Array_Elements.Table (E1); ! E1 := Elm.Next; ! -- Remove the Next component ! Elm.Next := No_Array_Element; ! -- Change the location ! Elm.Value.Location := New_Loc; ! Array_Element_Table.Increment_Last (In_Tree.Array_Elements); ! -- Create new array element ! if Arr.Value = No_Array_Element then ! Arr.Value := Array_Element_Table.Last (In_Tree.Array_Elements); ! else ! In_Tree.Array_Elements.Table (E2).Next := ! Array_Element_Table.Last (In_Tree.Array_Elements); ! end if; ! E2 := Array_Element_Table.Last (In_Tree.Array_Elements); ! In_Tree.Array_Elements.Table (E2) := Elm; ! end loop; ! -- Finally, store the new array ! In_Tree.Arrays.Table (A2) := Arr; end loop; end Copy_Package_Declarations; --- 372,444 ---- while A1 /= No_Array loop Arr := In_Tree.Arrays.Table (A1); A1 := Arr.Next; ! if not Naming_Restricted or else ! (Arr.Name /= Snames.Name_Body ! and then Arr.Name /= Snames.Name_Spec ! and then Arr.Name /= Snames.Name_Implementation ! and then Arr.Name /= Snames.Name_Specification) ! then ! -- Remove the Next component ! Arr.Next := No_Array; ! Array_Table.Increment_Last (In_Tree.Arrays); ! -- Create new Array declaration ! if To.Arrays = No_Array then ! To.Arrays := Array_Table.Last (In_Tree.Arrays); ! else ! In_Tree.Arrays.Table (A2).Next := ! Array_Table.Last (In_Tree.Arrays); ! end if; ! A2 := Array_Table.Last (In_Tree.Arrays); ! -- Don't store the array as its first element has not been set yet ! -- Copy the array elements of the array ! E1 := Arr.Value; ! Arr.Value := No_Array_Element; ! while E1 /= No_Array_Element loop ! -- Copy the array element ! Elm := In_Tree.Array_Elements.Table (E1); ! E1 := Elm.Next; ! -- Remove the Next component ! Elm.Next := No_Array_Element; ! -- Change the location ! Elm.Value.Location := New_Loc; ! Array_Element_Table.Increment_Last (In_Tree.Array_Elements); ! -- Create new array element ! if Arr.Value = No_Array_Element then ! Arr.Value := ! Array_Element_Table.Last (In_Tree.Array_Elements); ! else ! In_Tree.Array_Elements.Table (E2).Next := ! Array_Element_Table.Last (In_Tree.Array_Elements); ! end if; ! E2 := Array_Element_Table.Last (In_Tree.Array_Elements); ! In_Tree.Array_Elements.Table (E2) := Elm; ! end loop; ! -- Finally, store the new array ! In_Tree.Arrays.Table (A2) := Arr; ! end if; end loop; end Copy_Package_Declarations; *************** package body Prj.Proc is *** 464,470 **** -- Process each term of the expression, starting with First_Term ! while The_Term /= Empty_Node loop The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree); case Kind_Of (The_Current_Term, From_Project_Node_Tree) is --- 473,479 ---- -- Process each term of the expression, starting with First_Term ! while Present (The_Term) loop The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree); case Kind_Of (The_Current_Term, From_Project_Node_Tree) is *************** package body Prj.Proc is *** 536,542 **** Value : Variable_Value; begin ! if String_Node /= Empty_Node then -- If String_Node is nil, it is an empty list, -- there is nothing to do --- 545,551 ---- Value : Variable_Value; begin ! if Present (String_Node) then -- If String_Node is nil, it is an empty list, -- there is nothing to do *************** package body Prj.Proc is *** 587,593 **** Next_Expression_In_List (String_Node, From_Project_Node_Tree); ! exit when String_Node = Empty_Node; Value := Expression --- 596,602 ---- Next_Expression_In_List (String_Node, From_Project_Node_Tree); ! exit when No (String_Node); Value := Expression *************** package body Prj.Proc is *** 638,644 **** Index : Name_Id := No_Name; begin ! if Term_Project /= Empty_Node and then Term_Project /= From_Project_Node then -- This variable or attribute comes from another project --- 647,653 ---- Index : Name_Id := No_Name; begin ! if Present (Term_Project) and then Term_Project /= From_Project_Node then -- This variable or attribute comes from another project *************** package body Prj.Proc is *** 651,657 **** With_Name => The_Name); end if; ! if Term_Package /= Empty_Node then -- This is an attribute of a package --- 660,666 ---- With_Name => The_Name); end if; ! if Present (Term_Package) then -- This is an attribute of a package *************** package body Prj.Proc is *** 1004,1014 **** -- If there is a default value for the external reference, -- get its value. ! if Default_Node /= Empty_Node then Def_Var := Expression (Project => Project, In_Tree => In_Tree, ! From_Project_Node => Default_Node, From_Project_Node_Tree => From_Project_Node_Tree, Pkg => Pkg, First_Term => --- 1013,1023 ---- -- If there is a default value for the external reference, -- get its value. ! if Present (Default_Node) then Def_Var := Expression (Project => Project, In_Tree => In_Tree, ! From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Pkg => Pkg, First_Term => *************** package body Prj.Proc is *** 1104,1167 **** In_Tree : Project_Tree_Ref; With_Name : Name_Id) return Project_Id is ! Data : constant Project_Data := ! In_Tree.Projects.Table (Project); ! List : Project_List := Data.Imported_Projects; ! Result : Project_Id := No_Project; ! Temp_Result : Project_Id := No_Project; begin -- First check if it is the name of an extended project ! if Data.Extends /= No_Project ! and then In_Tree.Projects.Table (Data.Extends).Name = ! With_Name ! then ! return Data.Extends; ! else ! -- Then check the name of each imported project ! while List /= Empty_Project_List loop ! Result := In_Tree.Project_Lists.Table (List).Project; ! -- If the project is directly imported, then returns its ID ! if ! In_Tree.Projects.Table (Result).Name = With_Name ! then ! return Result; ! end if; ! -- If a project extending the project is imported, then keep ! -- this extending project as a possibility. It will be the ! -- returned ID if the project is not imported directly. ! declare ! Proj : Project_Id := ! In_Tree.Projects.Table (Result).Extends; ! begin ! while Proj /= No_Project loop ! if In_Tree.Projects.Table (Proj).Name = ! With_Name ! then ! Temp_Result := Result; ! exit; ! end if; ! Proj := In_Tree.Projects.Table (Proj).Extends; ! end loop; ! end; ! List := In_Tree.Project_Lists.Table (List).Next; ! end loop; ! pragma Assert ! (Temp_Result /= No_Project, ! "project not found"); ! return Temp_Result; ! end if; end Imported_Or_Extended_Project_From; ------------------ --- 1113,1171 ---- In_Tree : Project_Tree_Ref; With_Name : Name_Id) return Project_Id is ! Data : constant Project_Data := In_Tree.Projects.Table (Project); ! List : Project_List; ! Result : Project_Id; ! Temp_Result : Project_Id; begin -- First check if it is the name of an extended project ! Result := Data.Extends; ! while Result /= No_Project loop ! if In_Tree.Projects.Table (Result).Name = With_Name then ! return Result; ! else ! Result := In_Tree.Projects.Table (Result).Extends; ! end if; ! end loop; ! -- Then check the name of each imported project ! Temp_Result := No_Project; ! List := Data.Imported_Projects; ! while List /= Empty_Project_List loop ! Result := In_Tree.Project_Lists.Table (List).Project; ! -- If the project is directly imported, then returns its ID ! if In_Tree.Projects.Table (Result).Name = With_Name then ! return Result; ! end if; ! -- If a project extending the project is imported, then keep this ! -- extending project as a possibility. It will be the returned ID ! -- if the project is not imported directly. ! declare ! Proj : Project_Id := In_Tree.Projects.Table (Result).Extends; ! begin ! while Proj /= No_Project loop ! if In_Tree.Projects.Table (Proj).Name = With_Name then ! Temp_Result := Result; ! exit; ! end if; ! Proj := In_Tree.Projects.Table (Proj).Extends; ! end loop; ! end; ! List := In_Tree.Project_Lists.Table (List).Next; ! end loop; ! pragma Assert (Temp_Result /= No_Project, "project not found"); ! return Temp_Result; end Imported_Or_Extended_Project_From; ------------------ *************** package body Prj.Proc is *** 1258,1264 **** Current_Item := Empty_Node; Current_Declarative_Item := Item; ! while Current_Declarative_Item /= Empty_Node loop -- Get its data --- 1262,1268 ---- Current_Item := Empty_Node; Current_Declarative_Item := Item; ! while Present (Current_Declarative_Item) loop -- Get its data *************** package body Prj.Proc is *** 1320,1326 **** In_Tree.Packages.Table (New_Pkg) := The_New_Package; ! if Project_Of_Renamed_Package /= Empty_Node then -- Renamed package --- 1324,1330 ---- In_Tree.Packages.Table (New_Pkg) := The_New_Package; ! if Present (Project_Of_Renamed_Package) then -- Renamed package *************** package body Prj.Proc is *** 1349,1362 **** -- renaming declaration. Copy_Package_Declarations ! (From => In_Tree.Packages.Table (Renamed_Package).Decl, ! To => In_Tree.Packages.Table (New_Pkg).Decl, ! New_Loc => Location_Of (Current_Item, From_Project_Node_Tree), ! In_Tree => In_Tree); end; -- Standard package declaration, not renaming --- 1353,1367 ---- -- renaming declaration. Copy_Package_Declarations ! (From => In_Tree.Packages.Table (Renamed_Package).Decl, ! To => In_Tree.Packages.Table (New_Pkg).Decl, ! New_Loc => Location_Of (Current_Item, From_Project_Node_Tree), ! Naming_Restricted => False, ! In_Tree => In_Tree); end; -- Standard package declaration, not renaming *************** package body Prj.Proc is *** 1412,1417 **** --- 1417,1427 ---- From_Project_Node_Tree); -- The name of the attribute + Current_Location : constant Source_Ptr := + Location_Of + (Current_Item, + From_Project_Node_Tree); + New_Array : Array_Id; -- The new associative array created *************** package body Prj.Proc is *** 1478,1497 **** if Pkg /= No_Package then In_Tree.Arrays.Table (New_Array) := ! (Name => Current_Item_Name, ! Value => No_Array_Element, ! Next => ! In_Tree.Packages.Table (Pkg).Decl.Arrays); In_Tree.Packages.Table (Pkg).Decl.Arrays := New_Array; else In_Tree.Arrays.Table (New_Array) := ! (Name => Current_Item_Name, ! Value => No_Array_Element, ! Next => ! In_Tree.Projects.Table (Project).Decl.Arrays); In_Tree.Projects.Table (Project).Decl.Arrays := New_Array; --- 1488,1509 ---- if Pkg /= No_Package then In_Tree.Arrays.Table (New_Array) := ! (Name => Current_Item_Name, ! Location => Current_Location, ! Value => No_Array_Element, ! Next => In_Tree.Packages.Table ! (Pkg).Decl.Arrays); In_Tree.Packages.Table (Pkg).Decl.Arrays := New_Array; else In_Tree.Arrays.Table (New_Array) := ! (Name => Current_Item_Name, ! Location => Current_Location, ! Value => No_Array_Element, ! Next => In_Tree.Projects.Table ! (Project).Decl.Arrays); In_Tree.Projects.Table (Project).Decl.Arrays := New_Array; *************** package body Prj.Proc is *** 1521,1528 **** pragma Assert (Orig_Project /= No_Project, "original project not found"); ! if Associative_Package_Of ! (Current_Item, From_Project_Node_Tree) = Empty_Node then Orig_Array := In_Tree.Projects.Table --- 1533,1540 ---- pragma Assert (Orig_Project /= No_Project, "original project not found"); ! if No (Associative_Package_Of ! (Current_Item, From_Project_Node_Tree)) then Orig_Array := In_Tree.Projects.Table *************** package body Prj.Proc is *** 1627,1634 **** if Next_Element = No_Array_Element then Array_Element_Table.Increment_Last (In_Tree.Array_Elements); ! New_Element := Array_Element_Table.Last ! (In_Tree.Array_Elements); else New_Element := Next_Element; --- 1639,1649 ---- if Next_Element = No_Array_Element then Array_Element_Table.Increment_Last (In_Tree.Array_Elements); ! New_Element := ! Array_Element_Table.Last ! (In_Tree.Array_Elements); ! In_Tree.Array_Elements.Table ! (Prev_Element).Next := New_Element; else New_Element := Next_Element; *************** package body Prj.Proc is *** 1642,1649 **** In_Tree.Array_Elements.Table (New_Element) := ! In_Tree.Array_Elements.Table ! (Orig_Element); In_Tree.Array_Elements.Table (New_Element).Value.Project := Project; --- 1657,1663 ---- In_Tree.Array_Elements.Table (New_Element) := ! In_Tree.Array_Elements.Table (Orig_Element); In_Tree.Array_Elements.Table (New_Element).Value.Project := Project; *************** package body Prj.Proc is *** 1699,1704 **** --- 1713,1723 ---- (Current_Item, From_Project_Node_Tree); + Current_Location : constant Source_Ptr := + Location_Of + (Current_Item, + From_Project_Node_Tree); + begin -- Process a typed variable declaration *************** package body Prj.Proc is *** 1736,1742 **** (String_Type_Of (Current_Item, From_Project_Node_Tree), From_Project_Node_Tree); ! while Current_String /= Empty_Node and then String_Value_Of (Current_String, From_Project_Node_Tree) /= --- 1755,1761 ---- (String_Type_Of (Current_Item, From_Project_Node_Tree), From_Project_Node_Tree); ! while Present (Current_String) and then String_Value_Of (Current_String, From_Project_Node_Tree) /= *************** package body Prj.Proc is *** 1750,1756 **** -- Report an error if the string value is not -- one for the string type. ! if Current_String = Empty_Node then Error_Msg_Name_1 := New_Value.Value; Error_Msg_Name_2 := Name_Of --- 1769,1775 ---- -- Report an error if the string value is not -- one for the string type. ! if No (Current_String) then Error_Msg_Name_1 := New_Value.Value; Error_Msg_Name_2 := Name_Of *************** package body Prj.Proc is *** 1853,1873 **** if Pkg /= No_Package then In_Tree.Variable_Elements.Table (The_Variable) := ! (Next => In_Tree.Packages.Table (Pkg).Decl.Variables, ! Name => Current_Item_Name, ! Value => New_Value); In_Tree.Packages.Table (Pkg).Decl.Variables := The_Variable; else In_Tree.Variable_Elements.Table (The_Variable) := ! (Next => In_Tree.Projects.Table (Project).Decl.Variables, ! Name => Current_Item_Name, ! Value => New_Value); In_Tree.Projects.Table (Project).Decl.Variables := The_Variable; --- 1872,1892 ---- if Pkg /= No_Package then In_Tree.Variable_Elements.Table (The_Variable) := ! (Next => In_Tree.Packages.Table (Pkg).Decl.Variables, ! Name => Current_Item_Name, ! Value => New_Value); In_Tree.Packages.Table (Pkg).Decl.Variables := The_Variable; else In_Tree.Variable_Elements.Table (The_Variable) := ! (Next => In_Tree.Projects.Table (Project).Decl.Variables, ! Name => Current_Item_Name, ! Value => New_Value); In_Tree.Projects.Table (Project).Decl.Variables := The_Variable; *************** package body Prj.Proc is *** 1878,1936 **** else In_Tree.Variable_Elements.Table ! (The_Variable).Value := ! New_Value; ! end if; -- Associative array attribute else - -- Get the string index - - Get_Name_String - (Associative_Array_Index_Of - (Current_Item, From_Project_Node_Tree)); - - -- Put in lower case, if necessary - declare ! Lower : Boolean; begin ! Lower := ! Case_Insensitive ! (Current_Item, From_Project_Node_Tree); ! -- In multi-language mode (gprbuild), the index is ! -- always case insensitive if it does not include ! -- any dot. ! if Get_Mode = Multi_Language and then not Lower then ! for J in 1 .. Name_Len loop ! if Name_Buffer (J) = '.' then ! Lower := False; ! exit; ! end if; ! end loop; ! end if; ! if Lower then ! GNAT.Case_Util.To_Lower ! (Name_Buffer (1 .. Name_Len)); ! end if; ! end; ! declare ! The_Array : Array_Id; ! The_Array_Element : Array_Element_Id := ! No_Array_Element; ! Index_Name : constant Name_Id := Name_Find; ! -- The name id of the index - begin -- Look for the array in the appropriate list if Pkg /= No_Package then --- 1897,1955 ---- else In_Tree.Variable_Elements.Table ! (The_Variable).Value := New_Value; end if; -- Associative array attribute else declare ! Index_Name : Name_Id := ! Associative_Array_Index_Of ! (Current_Item, From_Project_Node_Tree); ! Lower : Boolean; ! The_Array : Array_Id; ! ! The_Array_Element : Array_Element_Id := ! No_Array_Element; begin ! if Index_Name /= All_Other_Names then ! -- Get the string index ! Get_Name_String ! (Associative_Array_Index_Of ! (Current_Item, From_Project_Node_Tree)); ! -- Put in lower case, if necessary ! Lower := ! Case_Insensitive ! (Current_Item, From_Project_Node_Tree); ! -- In multi-language mode (gprbuild), the index ! -- is always case insensitive if it does not ! -- include any dot. ! if Get_Mode = Multi_Language ! and then not Lower ! then ! for J in 1 .. Name_Len loop ! if Name_Buffer (J) = '.' then ! Lower := False; ! exit; ! end if; ! end loop; ! end if; ! if Lower then ! GNAT.Case_Util.To_Lower ! (Name_Buffer (1 .. Name_Len)); ! end if; ! ! Index_Name := Name_Find; ! end if; -- Look for the array in the appropriate list if Pkg /= No_Package then *************** package body Prj.Proc is *** 1963,1984 **** if Pkg /= No_Package then In_Tree.Arrays.Table (The_Array) := ! (Name => Current_Item_Name, ! Value => No_Array_Element, ! Next => ! In_Tree.Packages.Table ! (Pkg).Decl.Arrays); In_Tree.Packages.Table (Pkg).Decl.Arrays := The_Array; else In_Tree.Arrays.Table (The_Array) := ! (Name => Current_Item_Name, ! Value => No_Array_Element, ! Next => ! In_Tree.Projects.Table ! (Project).Decl.Arrays); In_Tree.Projects.Table (Project).Decl.Arrays := The_Array; --- 1982,2003 ---- if Pkg /= No_Package then In_Tree.Arrays.Table (The_Array) := ! (Name => Current_Item_Name, ! Location => Current_Location, ! Value => No_Array_Element, ! Next => In_Tree.Packages.Table ! (Pkg).Decl.Arrays); In_Tree.Packages.Table (Pkg).Decl.Arrays := The_Array; else In_Tree.Arrays.Table (The_Array) := ! (Name => Current_Item_Name, ! Location => Current_Location, ! Value => No_Array_Element, ! Next => In_Tree.Projects.Table ! (Project).Decl.Arrays); In_Tree.Projects.Table (Project).Decl.Arrays := The_Array; *************** package body Prj.Proc is *** 2007,2013 **** -- If no such element were found, create a new one -- and insert it in the element list, with the ! -- propoer value. if The_Array_Element = No_Array_Element then Array_Element_Table.Increment_Last --- 2026,2032 ---- -- If no such element were found, create a new one -- and insert it in the element list, with the ! -- proper value. if The_Array_Element = No_Array_Element then Array_Element_Table.Increment_Last *************** package body Prj.Proc is *** 2025,2031 **** not Case_Insensitive (Current_Item, From_Project_Node_Tree), Value => New_Value, ! Next => In_Tree.Arrays.Table (The_Array).Value); In_Tree.Arrays.Table (The_Array).Value := The_Array_Element; --- 2044,2050 ---- not Case_Insensitive (Current_Item, From_Project_Node_Tree), Value => New_Value, ! Next => In_Tree.Arrays.Table (The_Array).Value); In_Tree.Arrays.Table (The_Array).Value := The_Array_Element; *************** package body Prj.Proc is *** 2074,2081 **** -- If a project was specified for the case variable, -- get its id. ! if Project_Node_Of ! (Variable_Node, From_Project_Node_Tree) /= Empty_Node then Name := Name_Of --- 2093,2100 ---- -- If a project was specified for the case variable, -- get its id. ! if Present (Project_Node_Of ! (Variable_Node, From_Project_Node_Tree)) then Name := Name_Of *************** package body Prj.Proc is *** 2090,2097 **** -- If a package were specified for the case variable, -- get its id. ! if Package_Node_Of ! (Variable_Node, From_Project_Node_Tree) /= Empty_Node then Name := Name_Of --- 2109,2116 ---- -- If a package were specified for the case variable, -- get its id. ! if Present (Package_Node_Of ! (Variable_Node, From_Project_Node_Tree)) then Name := Name_Of *************** package body Prj.Proc is *** 2127,2134 **** if Var_Id = No_Variable and then ! Package_Node_Of ! (Variable_Node, From_Project_Node_Tree) = Empty_Node then Var_Id := In_Tree.Projects.Table (The_Project).Decl.Variables; --- 2146,2153 ---- if Var_Id = No_Variable and then ! No (Package_Node_Of ! (Variable_Node, From_Project_Node_Tree)) then Var_Id := In_Tree.Projects.Table (The_Project).Decl.Variables; *************** package body Prj.Proc is *** 2178,2191 **** Case_Item := First_Case_Item_Of (Current_Item, From_Project_Node_Tree); Case_Item_Loop : ! while Case_Item /= Empty_Node loop Choice_String := First_Choice_Of (Case_Item, From_Project_Node_Tree); -- When Choice_String is nil, it means that it is -- the "when others =>" alternative. ! if Choice_String = Empty_Node then Decl_Item := First_Declarative_Item_Of (Case_Item, From_Project_Node_Tree); --- 2197,2210 ---- Case_Item := First_Case_Item_Of (Current_Item, From_Project_Node_Tree); Case_Item_Loop : ! while Present (Case_Item) loop Choice_String := First_Choice_Of (Case_Item, From_Project_Node_Tree); -- When Choice_String is nil, it means that it is -- the "when others =>" alternative. ! if No (Choice_String) then Decl_Item := First_Declarative_Item_Of (Case_Item, From_Project_Node_Tree); *************** package body Prj.Proc is *** 2195,2201 **** -- Look into all the alternative of this case item Choice_Loop : ! while Choice_String /= Empty_Node loop if Case_Value = String_Value_Of (Choice_String, From_Project_Node_Tree) --- 2214,2220 ---- -- Look into all the alternative of this case item Choice_Loop : ! while Present (Choice_String) loop if Case_Value = String_Value_Of (Choice_String, From_Project_Node_Tree) *************** package body Prj.Proc is *** 2217,2223 **** -- If there is an alternative, then we process it ! if Decl_Item /= Empty_Node then Process_Declarative_Items (Project => Project, In_Tree => In_Tree, --- 2236,2242 ---- -- If there is an alternative, then we process it ! if Present (Decl_Item) then Process_Declarative_Items (Project => Project, In_Tree => In_Tree, *************** package body Prj.Proc is *** 2321,2333 **** declare Object_Dir : constant Path_Name_Type := In_Tree.Projects.Table ! (Project).Object_Directory; begin for Index in Project_Table.First .. Project_Table.Last (In_Tree.Projects) loop if In_Tree.Projects.Table (Index).Virtual then ! In_Tree.Projects.Table (Index).Object_Directory := Object_Dir; end if; end loop; --- 2340,2352 ---- declare Object_Dir : constant Path_Name_Type := In_Tree.Projects.Table ! (Project).Object_Directory.Name; begin for Index in Project_Table.First .. Project_Table.Last (In_Tree.Projects) loop if In_Tree.Projects.Table (Index).Virtual then ! In_Tree.Projects.Table (Index).Object_Directory.Name := Object_Dir; end if; end loop; *************** package body Prj.Proc is *** 2344,2350 **** Extending := In_Tree.Projects.Table (Proj).Extended_By; if Extending /= No_Project then ! Obj_Dir := In_Tree.Projects.Table (Proj).Object_Directory; -- Check that a project being extended does not share its -- object directory with any project that extends it, directly --- 2363,2369 ---- Extending := In_Tree.Projects.Table (Proj).Extended_By; if Extending /= No_Project then ! Obj_Dir := In_Tree.Projects.Table (Proj).Object_Directory.Name; -- Check that a project being extended does not share its -- object directory with any project that extends it, directly *************** package body Prj.Proc is *** 2357,2364 **** if In_Tree.Projects.Table (Extending2).Ada_Sources /= Nil_String and then ! In_Tree.Projects.Table (Extending2).Object_Directory = ! Obj_Dir then if In_Tree.Projects.Table (Extending2).Virtual then Error_Msg_Name_1 := --- 2376,2383 ---- if In_Tree.Projects.Table (Extending2).Ada_Sources /= Nil_String and then ! In_Tree.Projects.Table ! (Extending2).Object_Directory.Name = Obj_Dir then if In_Tree.Projects.Table (Extending2).Virtual then Error_Msg_Name_1 := *************** package body Prj.Proc is *** 2492,2498 **** With_Clause : Project_Node_Id; begin ! if From_Project_Node = Empty_Node then Project := No_Project; else --- 2511,2517 ---- With_Clause : Project_Node_Id; begin ! if No (From_Project_Node) then Project := No_Project; else *************** package body Prj.Proc is *** 2530,2535 **** --- 2549,2559 ---- Processed_Projects.Set (Name, Project); Processed_Data.Name := Name; + Processed_Data.Qualifier := + Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree); + In_Tree.Projects.Table (Project).Name := Name; + In_Tree.Projects.Table (Project).Qualifier := + Processed_Data.Qualifier; Get_Name_String (Name); *************** package body Prj.Proc is *** 2563,2582 **** Processed_Data.Display_Name := Name_Find; end if; ! Processed_Data.Display_Path_Name := Path_Name_Of (From_Project_Node, From_Project_Node_Tree); ! Get_Name_String (Processed_Data.Display_Path_Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); ! Processed_Data.Path_Name := Name_Find; Processed_Data.Location := Location_Of (From_Project_Node, From_Project_Node_Tree); ! Processed_Data.Display_Directory := Directory_Of (From_Project_Node, From_Project_Node_Tree); ! Get_Name_String (Processed_Data.Display_Directory); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); ! Processed_Data.Directory := Name_Find; Processed_Data.Extended_By := Extended_By; --- 2587,2606 ---- Processed_Data.Display_Name := Name_Find; end if; ! Processed_Data.Path.Display_Name := Path_Name_Of (From_Project_Node, From_Project_Node_Tree); ! Get_Name_String (Processed_Data.Path.Display_Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); ! Processed_Data.Path.Name := Name_Find; Processed_Data.Location := Location_Of (From_Project_Node, From_Project_Node_Tree); ! Processed_Data.Directory.Display_Name := Directory_Of (From_Project_Node, From_Project_Node_Tree); ! Get_Name_String (Processed_Data.Directory.Display_Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); ! Processed_Data.Directory.Name := Name_Find; Processed_Data.Extended_By := Extended_By; *************** package body Prj.Proc is *** 2588,2648 **** Prj.Attr.Attribute_First, Project_Level => True); With_Clause := First_With_Clause_Of (From_Project_Node, From_Project_Node_Tree); ! while With_Clause /= Empty_Node loop declare New_Project : Project_Id; New_Data : Project_Data; begin ! Recursive_Process ! (In_Tree => In_Tree, ! Project => New_Project, ! From_Project_Node => ! Project_Node_Of (With_Clause, From_Project_Node_Tree), ! From_Project_Node_Tree => From_Project_Node_Tree, ! Extended_By => No_Project); ! New_Data := ! In_Tree.Projects.Table (New_Project); ! -- If we were the first project to import it, ! -- set First_Referred_By to us. ! if New_Data.First_Referred_By = No_Project then ! New_Data.First_Referred_By := Project; ! In_Tree.Projects.Table (New_Project) := ! New_Data; ! end if; ! -- Add this project to our list of imported projects ! Project_List_Table.Increment_Last ! (In_Tree.Project_Lists); ! In_Tree.Project_Lists.Table ! (Project_List_Table.Last ! (In_Tree.Project_Lists)) := ! (Project => New_Project, Next => Empty_Project_List); ! -- Imported is the id of the last imported project. ! -- If it is nil, then this imported project is our first. ! if Imported = Empty_Project_List then ! Processed_Data.Imported_Projects := ! Project_List_Table.Last ! (In_Tree.Project_Lists); - else In_Tree.Project_Lists.Table ! (Imported).Next := Project_List_Table.Last (In_Tree.Project_Lists); ! end if; ! Imported := Project_List_Table.Last ! (In_Tree.Project_Lists); With_Clause := ! Next_With_Clause_Of (With_Clause, From_Project_Node_Tree); end; end loop; --- 2612,2685 ---- Prj.Attr.Attribute_First, Project_Level => True); + -- Process non limited withed projects + With_Clause := First_With_Clause_Of (From_Project_Node, From_Project_Node_Tree); ! while Present (With_Clause) loop declare New_Project : Project_Id; New_Data : Project_Data; + Proj_Node : Project_Node_Id; begin ! Proj_Node := ! Non_Limited_Project_Node_Of ! (With_Clause, From_Project_Node_Tree); ! if Present (Proj_Node) then ! Recursive_Process ! (In_Tree => In_Tree, ! Project => New_Project, ! From_Project_Node => ! Project_Node_Of ! (With_Clause, From_Project_Node_Tree), ! From_Project_Node_Tree => From_Project_Node_Tree, ! Extended_By => No_Project); ! New_Data := ! In_Tree.Projects.Table (New_Project); ! -- If we were the first project to import it, ! -- set First_Referred_By to us. ! if New_Data.First_Referred_By = No_Project then ! New_Data.First_Referred_By := Project; ! In_Tree.Projects.Table (New_Project) := ! New_Data; ! end if; ! -- Add this project to our list of imported projects ! Project_List_Table.Increment_Last ! (In_Tree.Project_Lists); In_Tree.Project_Lists.Table ! (Project_List_Table.Last ! (In_Tree.Project_Lists)) := ! (Project => New_Project, Next => Empty_Project_List); ! ! -- Imported is the id of the last imported project. If it ! -- is nil, then this imported project is our first. ! ! if Imported = Empty_Project_List then ! Processed_Data.Imported_Projects := ! Project_List_Table.Last ! (In_Tree.Project_Lists); ! ! else ! In_Tree.Project_Lists.Table ! (Imported).Next := Project_List_Table.Last (In_Tree.Project_Lists); ! end if; ! Imported := Project_List_Table.Last ! (In_Tree.Project_Lists); ! end if; With_Clause := ! Next_With_Clause_Of ! (With_Clause, From_Project_Node_Tree); end; end loop; *************** package body Prj.Proc is *** 2672,2684 **** From_Project_Node_Tree)); -- If it is an extending project, inherit all packages ! -- from the extended project that are not explicitely defined -- or renamed. Also inherit the languages, if attribute Languages ! -- is not explicitely defined. ! if Processed_Data.Extends /= No_Project then ! Processed_Data := In_Tree.Projects.Table (Project); declare Extended_Pkg : Package_Id; Current_Pkg : Package_Id; --- 2709,2721 ---- From_Project_Node_Tree)); -- If it is an extending project, inherit all packages ! -- from the extended project that are not explicitly defined -- or renamed. Also inherit the languages, if attribute Languages ! -- is not explicitly defined. ! Processed_Data := In_Tree.Projects.Table (Project); + if Processed_Data.Extends /= No_Project then declare Extended_Pkg : Package_Id; Current_Pkg : Package_Id; *************** package body Prj.Proc is *** 2718,2727 **** Next => Processed_Data.Decl.Packages); Processed_Data.Decl.Packages := Current_Pkg; Copy_Package_Declarations ! (From => Element.Decl, ! To => In_Tree.Packages.Table (Current_Pkg).Decl, ! New_Loc => No_Location, ! In_Tree => In_Tree); end if; Extended_Pkg := Element.Next; --- 2755,2767 ---- Next => Processed_Data.Decl.Packages); Processed_Data.Decl.Packages := Current_Pkg; Copy_Package_Declarations ! (From => Element.Decl, ! To => ! In_Tree.Packages.Table (Current_Pkg).Decl, ! New_Loc => No_Location, ! Naming_Restricted => ! Element.Name = Snames.Name_Naming, ! In_Tree => In_Tree); end if; Extended_Pkg := Element.Next; *************** package body Prj.Proc is *** 2781,2786 **** --- 2821,2897 ---- In_Tree.Projects.Table (Project) := Processed_Data; end if; + + -- Process limited withed projects + + With_Clause := + First_With_Clause_Of + (From_Project_Node, From_Project_Node_Tree); + while Present (With_Clause) loop + declare + New_Project : Project_Id; + New_Data : Project_Data; + Proj_Node : Project_Node_Id; + + begin + Proj_Node := + Non_Limited_Project_Node_Of + (With_Clause, From_Project_Node_Tree); + + if No (Proj_Node) then + Recursive_Process + (In_Tree => In_Tree, + Project => New_Project, + From_Project_Node => + Project_Node_Of + (With_Clause, From_Project_Node_Tree), + From_Project_Node_Tree => From_Project_Node_Tree, + Extended_By => No_Project); + + New_Data := + In_Tree.Projects.Table (New_Project); + + -- If we were the first project to import it, set + -- First_Referred_By to us. + + if New_Data.First_Referred_By = No_Project then + New_Data.First_Referred_By := Project; + In_Tree.Projects.Table (New_Project) := + New_Data; + end if; + + -- Add this project to our list of imported projects + + Project_List_Table.Increment_Last + (In_Tree.Project_Lists); + + In_Tree.Project_Lists.Table + (Project_List_Table.Last + (In_Tree.Project_Lists)) := + (Project => New_Project, Next => Empty_Project_List); + + -- Imported is the id of the last imported project. If + -- it is nil, then this imported project is our first. + + if Imported = Empty_Project_List then + In_Tree.Projects.Table (Project).Imported_Projects := + Project_List_Table.Last + (In_Tree.Project_Lists); + else + In_Tree.Project_Lists.Table + (Imported).Next := Project_List_Table.Last + (In_Tree.Project_Lists); + end if; + + Imported := Project_List_Table.Last + (In_Tree.Project_Lists); + end if; + + With_Clause := + Next_With_Clause_Of + (With_Clause, From_Project_Node_Tree); + end; + end loop; end; end if; end Recursive_Process; diff -Nrcpad gcc-4.3.3/gcc/ada/prj-strt.adb gcc-4.4.0/gcc/ada/prj-strt.adb *** gcc-4.3.3/gcc/ada/prj-strt.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/prj-strt.adb Tue May 20 12:45:54 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package body Prj.Strt is *** 244,250 **** -- Change name of obsolete attributes ! if Reference /= Empty_Node then case Name_Of (Reference, In_Tree) is when Snames.Name_Specification => Set_Name_Of (Reference, In_Tree, To => Snames.Name_Spec); --- 244,250 ---- -- Change name of obsolete attributes ! if Present (Reference) then case Name_Of (Reference, In_Tree) is when Snames.Name_Specification => Set_Name_Of (Reference, In_Tree, To => Snames.Name_Spec); *************** package body Prj.Strt is *** 716,722 **** (Current_Project, In_Tree, Names.Table (1).Name); end if; ! if The_Project = Empty_Node then -- If it is neither a project name nor a package name, -- report an error. --- 716,722 ---- (Current_Project, In_Tree, Names.Table (1).Name); end if; ! if No (The_Project) then -- If it is neither a project name nor a package name, -- report an error. *************** package body Prj.Strt is *** 734,740 **** The_Package := First_Package_Of (Current_Project, In_Tree); ! while The_Package /= Empty_Node and then Name_Of (The_Package, In_Tree) /= Names.Table (1).Name loop --- 734,740 ---- The_Package := First_Package_Of (Current_Project, In_Tree); ! while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Names.Table (1).Name loop *************** package body Prj.Strt is *** 745,751 **** -- If it has not been already declared, report an -- error. ! if The_Package = Empty_Node then Error_Msg_Name_1 := Names.Table (1).Name; Error_Msg ("package % not yet defined", Names.Table (1).Location); --- 745,751 ---- -- If it has not been already declared, report an -- error. ! if No (The_Package) then Error_Msg_Name_1 := Names.Table (1).Name; Error_Msg ("package % not yet defined", Names.Table (1).Location); *************** package body Prj.Strt is *** 820,826 **** -- If the long project exists, then this is the prefix -- of the attribute. ! if The_Project /= Empty_Node then First_Attribute := Attribute_First; The_Package := Empty_Node; --- 820,826 ---- -- If the long project exists, then this is the prefix -- of the attribute. ! if Present (The_Project) then First_Attribute := Attribute_First; The_Package := Empty_Node; *************** package body Prj.Strt is *** 841,847 **** -- If short project does not exist, report an error ! if The_Project = Empty_Node then Error_Msg_Name_1 := Long_Project; Error_Msg_Name_2 := Short_Project; Error_Msg ("unknown projects % or %", --- 841,847 ---- -- If short project does not exist, report an error ! if No (The_Project) then Error_Msg_Name_1 := Long_Project; Error_Msg_Name_2 := Short_Project; Error_Msg ("unknown projects % or %", *************** package body Prj.Strt is *** 855,861 **** The_Package := First_Package_Of (The_Project, In_Tree); ! while The_Package /= Empty_Node and then Name_Of (The_Package, In_Tree) /= Names.Table (Names.Last).Name loop --- 855,861 ---- The_Package := First_Package_Of (The_Project, In_Tree); ! while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Names.Table (Names.Last).Name loop *************** package body Prj.Strt is *** 865,871 **** -- If it has not, then we report an error ! if The_Package = Empty_Node then Error_Msg_Name_1 := Names.Table (Names.Last).Name; Error_Msg_Name_2 := Short_Project; --- 865,871 ---- -- If it has not, then we report an error ! if No (The_Package) then Error_Msg_Name_1 := Names.Table (Names.Last).Name; Error_Msg_Name_2 := Short_Project; *************** package body Prj.Strt is *** 926,932 **** The_Package := First_Package_Of (Current_Project, In_Tree); ! while The_Package /= Empty_Node and then Name_Of (The_Package, In_Tree) /= Names.Table (1).Name loop --- 926,932 ---- The_Package := First_Package_Of (Current_Project, In_Tree); ! while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Names.Table (1).Name loop *************** package body Prj.Strt is *** 939,948 **** The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Names.Table (1).Name); ! if The_Project /= Empty_Node then Specified_Project := The_Project; ! elsif The_Package = Empty_Node then Error_Msg_Name_1 := Names.Table (1).Name; Error_Msg ("unknown package or project %", Names.Table (1).Location); --- 939,948 ---- The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Names.Table (1).Name); ! if Present (The_Project) then Specified_Project := The_Project; ! elsif No (The_Package) then Error_Msg_Name_1 := Names.Table (1).Name; Error_Msg ("unknown package or project %", Names.Table (1).Location); *************** package body Prj.Strt is *** 1004,1010 **** The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Long_Project); ! if The_Project /= Empty_Node then Specified_Project := The_Project; else --- 1004,1010 ---- The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Long_Project); ! if Present (The_Project) then Specified_Project := The_Project; else *************** package body Prj.Strt is *** 1017,1023 **** Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Short_Project); ! if The_Project = Empty_Node then -- Unknown prefix, report an error Error_Msg_Name_1 := Long_Project; --- 1017,1023 ---- Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Short_Project); ! if No (The_Project) then -- Unknown prefix, report an error Error_Msg_Name_1 := Long_Project; *************** package body Prj.Strt is *** 1034,1040 **** The_Package := First_Package_Of (The_Project, In_Tree); ! while The_Package /= Empty_Node and then Name_Of (The_Package, In_Tree) /= Names.Table (Names.Last - 1).Name loop --- 1034,1040 ---- The_Package := First_Package_Of (The_Project, In_Tree); ! while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Names.Table (Names.Last - 1).Name loop *************** package body Prj.Strt is *** 1042,1048 **** Next_Package_In_Project (The_Package, In_Tree); end loop; ! if The_Package = Empty_Node then -- The package does not exist, report an error --- 1042,1048 ---- Next_Package_In_Project (The_Package, In_Tree); end loop; ! if No (The_Package) then -- The package does not exist, report an error *************** package body Prj.Strt is *** 1065,1071 **** Set_Project_Node_Of (Variable, In_Tree, To => Specified_Project); Set_Package_Node_Of (Variable, In_Tree, To => Specified_Package); ! if Specified_Project /= Empty_Node then The_Project := Specified_Project; else The_Project := Current_Project; --- 1065,1071 ---- Set_Project_Node_Of (Variable, In_Tree, To => Specified_Project); Set_Package_Node_Of (Variable, In_Tree, To => Specified_Package); ! if Present (Specified_Project) then The_Project := Specified_Project; else The_Project := Current_Project; *************** package body Prj.Strt is *** 1078,1087 **** -- If a package was specified, check if the variable has been -- declared in this package. ! if Specified_Package /= Empty_Node then Current_Variable := First_Variable_Of (Specified_Package, In_Tree); ! while Current_Variable /= Empty_Node and then Name_Of (Current_Variable, In_Tree) /= Variable_Name loop --- 1078,1087 ---- -- If a package was specified, check if the variable has been -- declared in this package. ! if Present (Specified_Package) then Current_Variable := First_Variable_Of (Specified_Package, In_Tree); ! while Present (Current_Variable) and then Name_Of (Current_Variable, In_Tree) /= Variable_Name loop *************** package body Prj.Strt is *** 1093,1104 **** -- a package, first check if the variable has been declared in -- the package. ! if Specified_Project = Empty_Node ! and then Current_Package /= Empty_Node then Current_Variable := First_Variable_Of (Current_Package, In_Tree); ! while Current_Variable /= Empty_Node and then Name_Of (Current_Variable, In_Tree) /= Variable_Name loop Current_Variable := --- 1093,1104 ---- -- a package, first check if the variable has been declared in -- the package. ! if No (Specified_Project) ! and then Present (Current_Package) then Current_Variable := First_Variable_Of (Current_Package, In_Tree); ! while Present (Current_Variable) and then Name_Of (Current_Variable, In_Tree) /= Variable_Name loop Current_Variable := *************** package body Prj.Strt is *** 1107,1135 **** end if; -- If we have not found the variable in the package, check if the ! -- variable has been declared in the project. ! if Current_Variable = Empty_Node then ! Current_Variable := First_Variable_Of (The_Project, In_Tree); ! while Current_Variable /= Empty_Node ! and then Name_Of (Current_Variable, In_Tree) /= Variable_Name ! loop ! Current_Variable := ! Next_Variable (Current_Variable, In_Tree); ! end loop; end if; end if; -- If the variable was not found, report an error ! if Current_Variable = Empty_Node then Error_Msg_Name_1 := Variable_Name; Error_Msg ("unknown variable %", Names.Table (Names.Last).Location); end if; end if; ! if Current_Variable /= Empty_Node then Set_Expression_Kind_Of (Variable, In_Tree, To => Expression_Kind_Of (Current_Variable, In_Tree)); --- 1107,1153 ---- end if; -- If we have not found the variable in the package, check if the ! -- variable has been declared in the project, or in any of its ! -- ancestors. ! if No (Current_Variable) then ! declare ! Proj : Project_Node_Id := The_Project; ! ! begin ! loop ! Current_Variable := First_Variable_Of (Proj, In_Tree); ! while ! Present (Current_Variable) ! and then ! Name_Of (Current_Variable, In_Tree) /= Variable_Name ! loop ! Current_Variable := ! Next_Variable (Current_Variable, In_Tree); ! end loop; ! ! exit when Present (Current_Variable); ! ! Proj := Parent_Project_Of (Proj, In_Tree); ! ! Set_Project_Node_Of (Variable, In_Tree, To => Proj); ! ! exit when No (Proj); ! end loop; ! end; end if; end if; -- If the variable was not found, report an error ! if No (Current_Variable) then Error_Msg_Name_1 := Variable_Name; Error_Msg ("unknown variable %", Names.Table (Names.Last).Location); end if; end if; ! if Present (Current_Variable) then Set_Expression_Kind_Of (Variable, In_Tree, To => Expression_Kind_Of (Current_Variable, In_Tree)); *************** package body Prj.Strt is *** 1185,1193 **** -- Add the literal of the string type to the Choices table ! if String_Type /= Empty_Node then Current_String := First_Literal_String (String_Type, In_Tree); ! while Current_String /= Empty_Node loop Add (This_String => String_Value_Of (Current_String, In_Tree)); Current_String := Next_Literal_String (Current_String, In_Tree); end loop; --- 1203,1211 ---- -- Add the literal of the string type to the Choices table ! if Present (String_Type) then Current_String := First_Literal_String (String_Type, In_Tree); ! while Present (Current_String) loop Add (This_String => String_Value_Of (Current_String, In_Tree)); Current_String := Next_Literal_String (Current_String, In_Tree); end loop; *************** package body Prj.Strt is *** 1290,1296 **** -- If Current_Expression is empty, it means that the -- expression is the first in the string list. ! if Current_Expression = Empty_Node then Set_First_Expression_In_List (Term_Id, In_Tree, To => Next_Expression); else --- 1308,1314 ---- -- If Current_Expression is empty, it means that the -- expression is the first in the string list. ! if No (Current_Expression) then Set_First_Expression_In_List (Term_Id, In_Tree, To => Next_Expression); else *************** package body Prj.Strt is *** 1382,1388 **** Current_Package => Current_Package); Set_Current_Term (Term, In_Tree, To => Reference); ! if Reference /= Empty_Node then -- If we don't know the expression kind (first term), then it -- has the kind of the variable or attribute reference. --- 1400,1406 ---- Current_Package => Current_Package); Set_Current_Term (Term, In_Tree, To => Reference); ! if Present (Reference) then -- If we don't know the expression kind (first term), then it -- has the kind of the variable or attribute reference. *************** package body Prj.Strt is *** 1425,1431 **** -- Same checks as above for the expression kind ! if Reference /= Empty_Node then if Expr_Kind = Undefined then Expr_Kind := Expression_Kind_Of (Reference, In_Tree); --- 1443,1449 ---- -- Same checks as above for the expression kind ! if Present (Reference) then if Expr_Kind = Undefined then Expr_Kind := Expression_Kind_Of (Reference, In_Tree); diff -Nrcpad gcc-4.3.3/gcc/ada/prj-strt.ads gcc-4.4.0/gcc/ada/prj-strt.ads *** gcc-4.3.3/gcc/ada/prj-strt.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/prj-strt.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** private package Prj.Strt is *** 101,106 **** -- On exit, Variable is the node of the variable or attribute reference. -- A variable reference is made of one to three simple names. -- An attribute reference is made of one or two simple names, ! -- followed by an apostroph, followed by the attribute simple name. end Prj.Strt; --- 101,106 ---- -- On exit, Variable is the node of the variable or attribute reference. -- A variable reference is made of one to three simple names. -- An attribute reference is made of one or two simple names, ! -- followed by an apostrophe, followed by the attribute simple name. end Prj.Strt; diff -Nrcpad gcc-4.3.3/gcc/ada/prj-tree.adb gcc-4.4.0/gcc/ada/prj-tree.adb *** gcc-4.3.3/gcc/ada/prj-tree.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/prj-tree.adb Tue May 20 12:45:54 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package body Prj.Tree is *** 94,106 **** begin pragma Assert ! (To /= Empty_Node and then In_Tree.Project_Nodes.Table (To).Kind /= N_Comment); Zone := In_Tree.Project_Nodes.Table (To).Comments; ! if Zone = Empty_Node then -- Create new N_Comment_Zones node --- 94,106 ---- begin pragma Assert ! (Present (To) and then In_Tree.Project_Nodes.Table (To).Kind /= N_Comment); Zone := In_Tree.Project_Nodes.Table (To).Comments; ! if No (Zone) then -- Create new N_Comment_Zones node *************** package body Prj.Tree is *** 108,113 **** --- 108,114 ---- In_Tree.Project_Nodes.Table (Project_Node_Table.Last (In_Tree.Project_Nodes)) := (Kind => N_Comment_Zones, + Qualifier => Unspecified, Expr_Kind => Undefined, Location => No_Location, Directory => No_Path, *************** package body Prj.Tree is *** 121,126 **** --- 122,128 ---- Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, + Field4 => Empty_Node, Flag1 => False, Flag2 => False, Comments => Empty_Node); *************** package body Prj.Tree is *** 153,158 **** --- 155,161 ---- In_Tree.Project_Nodes.Table (Project_Node_Table.Last (In_Tree.Project_Nodes)) := (Kind => N_Comment, + Qualifier => Unspecified, Expr_Kind => Undefined, Flag1 => Comments.Table (J).Follows_Empty_Line, Flag2 => *************** package body Prj.Tree is *** 169,180 **** Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, Comments => Empty_Node); -- If this is the first comment, put it in the right field of -- the node Zone. ! if Previous = Empty_Node then case Where is when Before => In_Tree.Project_Nodes.Table (Zone).Field1 := --- 172,184 ---- Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, + Field4 => Empty_Node, Comments => Empty_Node); -- If this is the first comment, put it in the right field of -- the node Zone. ! if No (Previous) then case Where is when Before => In_Tree.Project_Nodes.Table (Zone).Field1 := *************** package body Prj.Tree is *** 226,232 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration or else --- 230,236 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration or else *************** package body Prj.Tree is *** 244,250 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); return In_Tree.Project_Nodes.Table (Node).Field3; --- 248,254 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); return In_Tree.Project_Nodes.Table (Node).Field3; *************** package body Prj.Tree is *** 260,266 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); return In_Tree.Project_Nodes.Table (Node).Field2; --- 264,270 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); return In_Tree.Project_Nodes.Table (Node).Field2; *************** package body Prj.Tree is *** 275,281 **** In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration or else --- 279,285 ---- In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration or else *************** package body Prj.Tree is *** 293,299 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); return In_Tree.Project_Nodes.Table (Node).Field1; --- 297,303 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); return In_Tree.Project_Nodes.Table (Node).Field1; *************** package body Prj.Tree is *** 310,326 **** Zone : Project_Node_Id; begin ! pragma Assert (Node /= Empty_Node); Zone := In_Tree.Project_Nodes.Table (Node).Comments; -- If there is not already an N_Comment_Zones associated, create a new -- one and associate it with node Node. ! if Zone = Empty_Node then Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); Zone := Project_Node_Table.Last (In_Tree.Project_Nodes); In_Tree.Project_Nodes.Table (Zone) := (Kind => N_Comment_Zones, Location => No_Location, Directory => No_Path, Expr_Kind => Undefined, --- 314,331 ---- Zone : Project_Node_Id; begin ! pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; -- If there is not already an N_Comment_Zones associated, create a new -- one and associate it with node Node. ! if No (Zone) then Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); Zone := Project_Node_Table.Last (In_Tree.Project_Nodes); In_Tree.Project_Nodes.Table (Zone) := (Kind => N_Comment_Zones, + Qualifier => Unspecified, Location => No_Location, Directory => No_Path, Expr_Kind => Undefined, *************** package body Prj.Tree is *** 334,339 **** --- 339,345 ---- Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, + Field4 => Empty_Node, Flag1 => False, Flag2 => False, Comments => Empty_Node); *************** package body Prj.Tree is *** 353,359 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); return In_Tree.Project_Nodes.Table (Node).Field1; --- 359,365 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); return In_Tree.Project_Nodes.Table (Node).Field1; *************** package body Prj.Tree is *** 369,375 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); return In_Tree.Project_Nodes.Table (Node).Field1; --- 375,381 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); return In_Tree.Project_Nodes.Table (Node).Field1; *************** package body Prj.Tree is *** 395,400 **** --- 401,407 ---- In_Tree.Project_Nodes.Table (Project_Node_Table.Last (In_Tree.Project_Nodes)) := (Kind => Of_Kind, + Qualifier => Unspecified, Location => No_Location, Directory => No_Path, Expr_Kind => And_Expr_Kind, *************** package body Prj.Tree is *** 408,413 **** --- 415,421 ---- Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, + Field4 => Empty_Node, Flag1 => False, Flag2 => False, Comments => Empty_Node); *************** package body Prj.Tree is *** 429,434 **** --- 437,443 ---- In_Tree.Project_Nodes.Table (Project_Node_Table.Last (In_Tree.Project_Nodes)) := (Kind => N_Comment_Zones, + Qualifier => Unspecified, Expr_Kind => Undefined, Location => No_Location, Directory => No_Path, *************** package body Prj.Tree is *** 442,447 **** --- 451,457 ---- Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, + Field4 => Empty_Node, Flag1 => False, Flag2 => False, Comments => Empty_Node); *************** package body Prj.Tree is *** 458,463 **** --- 468,474 ---- In_Tree.Project_Nodes.Table (Project_Node_Table.Last (In_Tree.Project_Nodes)) := (Kind => N_Comment, + Qualifier => Unspecified, Expr_Kind => Undefined, Flag1 => Comments.Table (J).Follows_Empty_Line, Flag2 => *************** package body Prj.Tree is *** 474,485 **** Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, Comments => Empty_Node); -- Link it to the N_Comment_Zones node, if it is the first, -- otherwise to the previous one. ! if Previous = Empty_Node then In_Tree.Project_Nodes.Table (Zone).Field1 := Project_Node_Table.Last (In_Tree.Project_Nodes); --- 485,497 ---- Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, + Field4 => Empty_Node, Comments => Empty_Node); -- Link it to the N_Comment_Zones node, if it is the first, -- otherwise to the previous one. ! if No (Previous) then In_Tree.Project_Nodes.Table (Zone).Field1 := Project_Node_Table.Last (In_Tree.Project_Nodes); *************** package body Prj.Tree is *** 512,518 **** In_Tree : Project_Node_Tree_Ref) return Path_Name_Type is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Directory; --- 524,530 ---- In_Tree : Project_Node_Tree_Ref) return Path_Name_Type is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Directory; *************** package body Prj.Tree is *** 528,537 **** Zone : Project_Node_Id := Empty_Node; begin ! pragma Assert (Node /= Empty_Node); Zone := In_Tree.Project_Nodes.Table (Node).Comments; ! if Zone = Empty_Node then return No_Name; else return In_Tree.Project_Nodes.Table (Zone).Value; --- 540,549 ---- Zone : Project_Node_Id := Empty_Node; begin ! pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; ! if No (Zone) then return No_Name; else return In_Tree.Project_Nodes.Table (Zone).Value; *************** package body Prj.Tree is *** 547,553 **** In_Tree : Project_Node_Tree_Ref) return Variable_Kind is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String or else --- 559,565 ---- In_Tree : Project_Node_Tree_Ref) return Variable_Kind is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String or else *************** package body Prj.Tree is *** 582,588 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration --- 594,600 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration *************** package body Prj.Tree is *** 606,612 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); return In_Tree.Project_Nodes.Table (Node).Field2; --- 618,624 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); return In_Tree.Project_Nodes.Table (Node).Field2; *************** package body Prj.Tree is *** 622,628 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return Path_Name_Type (In_Tree.Project_Nodes.Table (Node).Value); --- 634,640 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return Path_Name_Type (In_Tree.Project_Nodes.Table (Node).Value); *************** package body Prj.Tree is *** 637,643 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); return In_Tree.Project_Nodes.Table (Node).Field3; --- 649,655 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); return In_Tree.Project_Nodes.Table (Node).Field3; *************** package body Prj.Tree is *** 653,659 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); return In_Tree.Project_Nodes.Table (Node).Field1; --- 665,671 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); return In_Tree.Project_Nodes.Table (Node).Field1; *************** package body Prj.Tree is *** 670,676 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); return In_Tree.Project_Nodes.Table (Node).Field2; --- 682,688 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); return In_Tree.Project_Nodes.Table (Node).Field2; *************** package body Prj.Tree is *** 686,692 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); return In_Tree.Project_Nodes.Table (Node).Field2; --- 698,704 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); return In_Tree.Project_Nodes.Table (Node).Field2; *************** package body Prj.Tree is *** 703,709 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); return In_Tree.Project_Nodes.Table (Node).Field1; --- 715,721 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); return In_Tree.Project_Nodes.Table (Node).Field1; *************** package body Prj.Tree is *** 719,728 **** is Zone : Project_Node_Id := Empty_Node; begin ! pragma Assert (Node /= Empty_Node); Zone := In_Tree.Project_Nodes.Table (Node).Comments; ! if Zone = Empty_Node then return Empty_Node; else --- 731,740 ---- is Zone : Project_Node_Id := Empty_Node; begin ! pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; ! if No (Zone) then return Empty_Node; else *************** package body Prj.Tree is *** 742,751 **** Zone : Project_Node_Id := Empty_Node; begin ! pragma Assert (Node /= Empty_Node); Zone := In_Tree.Project_Nodes.Table (Node).Comments; ! if Zone = Empty_Node then return Empty_Node; else --- 754,763 ---- Zone : Project_Node_Id := Empty_Node; begin ! pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; ! if No (Zone) then return Empty_Node; else *************** package body Prj.Tree is *** 764,773 **** Zone : Project_Node_Id := Empty_Node; begin ! pragma Assert (Node /= Empty_Node); Zone := In_Tree.Project_Nodes.Table (Node).Comments; ! if Zone = Empty_Node then return Empty_Node; else --- 776,785 ---- Zone : Project_Node_Id := Empty_Node; begin ! pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; ! if No (Zone) then return Empty_Node; else *************** package body Prj.Tree is *** 786,795 **** Zone : Project_Node_Id := Empty_Node; begin ! pragma Assert (Node /= Empty_Node); Zone := In_Tree.Project_Nodes.Table (Node).Comments; ! if Zone = Empty_Node then return Empty_Node; else --- 798,807 ---- Zone : Project_Node_Id := Empty_Node; begin ! pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; ! if No (Zone) then return Empty_Node; else *************** package body Prj.Tree is *** 807,813 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration or else --- 819,825 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration or else *************** package body Prj.Tree is *** 832,838 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List); return In_Tree.Project_Nodes.Table (Node).Field1; --- 844,850 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List); return In_Tree.Project_Nodes.Table (Node).Field1; *************** package body Prj.Tree is *** 848,854 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); --- 860,866 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); *************** package body Prj.Tree is *** 865,871 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Packages; --- 877,883 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Packages; *************** package body Prj.Tree is *** 881,887 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Field3; --- 893,899 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Field3; *************** package body Prj.Tree is *** 897,903 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); return In_Tree.Project_Nodes.Table (Node).Field1; --- 909,915 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); return In_Tree.Project_Nodes.Table (Node).Field1; *************** package body Prj.Tree is *** 913,919 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else --- 925,931 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else *************** package body Prj.Tree is *** 932,938 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Field1; --- 944,950 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Field1; *************** package body Prj.Tree is *** 947,953 **** In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); return In_Tree.Project_Nodes.Table (Node).Flag1; --- 959,965 ---- In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); return In_Tree.Project_Nodes.Table (Node).Flag1; *************** package body Prj.Tree is *** 982,988 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); return In_Tree.Project_Nodes.Table (Node).Flag2; --- 994,1000 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); return In_Tree.Project_Nodes.Table (Node).Flag2; *************** package body Prj.Tree is *** 997,1003 **** In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else --- 1009,1015 ---- In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else *************** package body Prj.Tree is *** 1014,1020 **** In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); return In_Tree.Project_Nodes.Table (Node).Flag1; --- 1026,1032 ---- In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); return In_Tree.Project_Nodes.Table (Node).Flag1; *************** package body Prj.Tree is *** 1036,1064 **** begin -- First check all the imported projects ! while With_Clause /= Empty_Node loop -- Only non limited imported project may be used as prefix -- of variable or attributes. Result := Non_Limited_Project_Node_Of (With_Clause, In_Tree); ! exit when Result /= Empty_Node and then Name_Of (Result, In_Tree) = With_Name; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; ! -- If it is not an imported project, it might be the imported project ! if With_Clause = Empty_Node then ! Result := ! Extended_Project_Of ! (Project_Declaration_Of (Project, In_Tree), In_Tree); ! if Result /= Empty_Node ! and then Name_Of (Result, In_Tree) /= With_Name ! then ! Result := Empty_Node; ! end if; end if; return Result; --- 1048,1076 ---- begin -- First check all the imported projects ! while Present (With_Clause) loop -- Only non limited imported project may be used as prefix -- of variable or attributes. Result := Non_Limited_Project_Node_Of (With_Clause, In_Tree); ! exit when Present (Result) and then Name_Of (Result, In_Tree) = With_Name; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; ! -- If it is not an imported project, it might be an extended project ! if No (With_Clause) then ! Result := Project; ! loop ! Result := ! Extended_Project_Of ! (Project_Declaration_Of (Result, In_Tree), In_Tree); ! exit when No (Result) ! or else Name_Of (Result, In_Tree) = With_Name; ! end loop; end if; return Result; *************** package body Prj.Tree is *** 1072,1078 **** (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Kind is begin ! pragma Assert (Node /= Empty_Node); return In_Tree.Project_Nodes.Table (Node).Kind; end Kind_Of; --- 1084,1090 ---- (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Kind is begin ! pragma Assert (Present (Node)); return In_Tree.Project_Nodes.Table (Node).Kind; end Kind_Of; *************** package body Prj.Tree is *** 1084,1090 **** (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Source_Ptr is begin ! pragma Assert (Node /= Empty_Node); return In_Tree.Project_Nodes.Table (Node).Location; end Location_Of; --- 1096,1102 ---- (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Source_Ptr is begin ! pragma Assert (Present (Node)); return In_Tree.Project_Nodes.Table (Node).Location; end Location_Of; *************** package body Prj.Tree is *** 1096,1102 **** (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Name_Id is begin ! pragma Assert (Node /= Empty_Node); return In_Tree.Project_Nodes.Table (Node).Name; end Name_Of; --- 1108,1114 ---- (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Name_Id is begin ! pragma Assert (Present (Node)); return In_Tree.Project_Nodes.Table (Node).Name; end Name_Of; *************** package body Prj.Tree is *** 1110,1116 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); return In_Tree.Project_Nodes.Table (Node).Field3; --- 1122,1128 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); return In_Tree.Project_Nodes.Table (Node).Field3; *************** package body Prj.Tree is *** 1125,1131 **** In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); return In_Tree.Project_Nodes.Table (Node).Comments; --- 1137,1143 ---- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); return In_Tree.Project_Nodes.Table (Node).Comments; *************** package body Prj.Tree is *** 1141,1147 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); return In_Tree.Project_Nodes.Table (Node).Field2; --- 1153,1159 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); return In_Tree.Project_Nodes.Table (Node).Field2; *************** package body Prj.Tree is *** 1157,1163 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); return In_Tree.Project_Nodes.Table (Node).Field2; --- 1169,1175 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); return In_Tree.Project_Nodes.Table (Node).Field2; *************** package body Prj.Tree is *** 1174,1180 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String); return In_Tree.Project_Nodes.Table (Node).Field1; --- 1186,1192 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String); return In_Tree.Project_Nodes.Table (Node).Field1; *************** package body Prj.Tree is *** 1190,1196 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); return In_Tree.Project_Nodes.Table (Node).Field3; --- 1202,1208 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); return In_Tree.Project_Nodes.Table (Node).Field3; *************** package body Prj.Tree is *** 1207,1213 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); --- 1219,1225 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); *************** package body Prj.Tree is *** 1224,1230 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); return In_Tree.Project_Nodes.Table (Node).Field2; --- 1236,1242 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); return In_Tree.Project_Nodes.Table (Node).Field2; *************** package body Prj.Tree is *** 1241,1247 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration --- 1253,1259 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration *************** package body Prj.Tree is *** 1262,1273 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); return In_Tree.Project_Nodes.Table (Node).Field2; end Next_With_Clause_Of; --------------------------------- -- Non_Limited_Project_Node_Of -- --------------------------------- --- 1274,1294 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); return In_Tree.Project_Nodes.Table (Node).Field2; end Next_With_Clause_Of; + -------- + -- No -- + -------- + + function No (Node : Project_Node_Id) return Boolean is + begin + return Node = Empty_Node; + end No; + --------------------------------- -- Non_Limited_Project_Node_Of -- --------------------------------- *************** package body Prj.Tree is *** 1278,1284 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause)); return In_Tree.Project_Nodes.Table (Node).Field3; --- 1299,1305 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause)); return In_Tree.Project_Nodes.Table (Node).Field3; *************** package body Prj.Tree is *** 1294,1300 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); return In_Tree.Project_Nodes.Table (Node).Pkg_Id; --- 1315,1321 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); return In_Tree.Project_Nodes.Table (Node).Pkg_Id; *************** package body Prj.Tree is *** 1310,1316 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference or else --- 1331,1337 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference or else *************** package body Prj.Tree is *** 1328,1334 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else --- 1349,1355 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else *************** package body Prj.Tree is *** 1336,1341 **** --- 1357,1371 ---- return In_Tree.Project_Nodes.Table (Node).Path_Name; end Path_Name_Of; + ------------- + -- Present -- + ------------- + + function Present (Node : Project_Node_Id) return Boolean is + begin + return Node /= Empty_Node; + end Present; + ---------------------------- -- Project_Declaration_Of -- ---------------------------- *************** package body Prj.Tree is *** 1346,1357 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Field2; end Project_Declaration_Of; ------------------------------------------- -- Project_File_Includes_Unkept_Comments -- ------------------------------------------- --- 1376,1419 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Field2; end Project_Declaration_Of; + -------------------------- + -- Project_Qualifier_Of -- + -------------------------- + + function Project_Qualifier_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Qualifier + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + return In_Tree.Project_Nodes.Table (Node).Qualifier; + end Project_Qualifier_Of; + + ----------------------- + -- Parent_Project_Of -- + ----------------------- + + function Parent_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + return In_Tree.Project_Nodes.Table (Node).Field4; + end Parent_Project_Of; + ------------------------------------------- -- Project_File_Includes_Unkept_Comments -- ------------------------------------------- *************** package body Prj.Tree is *** 1376,1382 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause or else --- 1438,1444 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause or else *************** package body Prj.Tree is *** 1396,1402 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); return In_Tree.Project_Nodes.Table (Node).Field1; --- 1458,1464 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); return In_Tree.Project_Nodes.Table (Node).Field1; *************** package body Prj.Tree is *** 1512,1518 **** -- an end of line node specified, associate the comment with -- this node. ! elsif End_Of_Line_Node /= Empty_Node then declare Zones : constant Project_Node_Id := Comment_Zones_Of (End_Of_Line_Node, In_Tree); --- 1574,1580 ---- -- an end of line node specified, associate the comment with -- this node. ! elsif Present (End_Of_Line_Node) then declare Zones : constant Project_Node_Id := Comment_Zones_Of (End_Of_Line_Node, In_Tree); *************** package body Prj.Tree is *** 1537,1549 **** if Comments.Last > 0 and then not Comments.Table (1).Follows_Empty_Line then ! if Previous_Line_Node /= Empty_Node then Add_Comments (To => Previous_Line_Node, Where => After, In_Tree => In_Tree); ! elsif Previous_End_Node /= Empty_Node then Add_Comments (To => Previous_End_Node, Where => After_End, --- 1599,1611 ---- if Comments.Last > 0 and then not Comments.Table (1).Follows_Empty_Line then ! if Present (Previous_Line_Node) then Add_Comments (To => Previous_Line_Node, Where => After, In_Tree => In_Tree); ! elsif Present (Previous_End_Node) then Add_Comments (To => Previous_End_Node, Where => After_End, *************** package body Prj.Tree is *** 1595,1601 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration or else --- 1657,1663 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration or else *************** package body Prj.Tree is *** 1614,1620 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration); In_Tree.Project_Nodes.Table (Node).Field3 := To; --- 1676,1682 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration); In_Tree.Project_Nodes.Table (Node).Field3 := To; *************** package body Prj.Tree is *** 1631,1637 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); --- 1693,1699 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); *************** package body Prj.Tree is *** 1649,1655 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration or else --- 1711,1717 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration or else *************** package body Prj.Tree is *** 1668,1674 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); In_Tree.Project_Nodes.Table (Node).Field1 := To; --- 1730,1736 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); In_Tree.Project_Nodes.Table (Node).Field1 := To; *************** package body Prj.Tree is *** 1685,1691 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); In_Tree.Project_Nodes.Table (Node).Field1 := To; --- 1747,1753 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); In_Tree.Project_Nodes.Table (Node).Field1 := To; *************** package body Prj.Tree is *** 1702,1708 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); In_Tree.Project_Nodes.Table (Node).Field1 := To; --- 1764,1770 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); In_Tree.Project_Nodes.Table (Node).Field1 := To; *************** package body Prj.Tree is *** 1719,1725 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Directory := To; --- 1781,1787 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Directory := To; *************** package body Prj.Tree is *** 1745,1751 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String or else --- 1807,1813 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String or else *************** package body Prj.Tree is *** 1780,1786 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration --- 1842,1848 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration *************** package body Prj.Tree is *** 1804,1810 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); In_Tree.Project_Nodes.Table (Node).Field1 := To; --- 1866,1872 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); In_Tree.Project_Nodes.Table (Node).Field1 := To; *************** package body Prj.Tree is *** 1821,1827 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); In_Tree.Project_Nodes.Table (Node).Field2 := To; --- 1883,1889 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); In_Tree.Project_Nodes.Table (Node).Field2 := To; *************** package body Prj.Tree is *** 1838,1844 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); In_Tree.Project_Nodes.Table (Node).Field2 := To; --- 1900,1906 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); In_Tree.Project_Nodes.Table (Node).Field2 := To; *************** package body Prj.Tree is *** 1855,1861 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); In_Tree.Project_Nodes.Table (Node).Field1 := To; --- 1917,1923 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); In_Tree.Project_Nodes.Table (Node).Field1 := To; *************** package body Prj.Tree is *** 1929,1935 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); In_Tree.Project_Nodes.Table (Node).Field3 := To; --- 1991,1997 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); In_Tree.Project_Nodes.Table (Node).Field3 := To; *************** package body Prj.Tree is *** 1946,1952 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); In_Tree.Project_Nodes.Table (Node).Comments := To; --- 2008,2014 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); In_Tree.Project_Nodes.Table (Node).Comments := To; *************** package body Prj.Tree is *** 1963,1969 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration or else --- 2025,2031 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration or else *************** package body Prj.Tree is *** 1989,1995 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List); In_Tree.Project_Nodes.Table (Node).Field1 := To; --- 2051,2057 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List); In_Tree.Project_Nodes.Table (Node).Field1 := To; *************** package body Prj.Tree is *** 2006,2012 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); --- 2068,2074 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); *************** package body Prj.Tree is *** 2024,2030 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Packages := To; --- 2086,2092 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Packages := To; *************** package body Prj.Tree is *** 2041,2047 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Field3 := To; --- 2103,2109 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Field3 := To; *************** package body Prj.Tree is *** 2058,2064 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); In_Tree.Project_Nodes.Table (Node).Field1 := To; --- 2120,2126 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); In_Tree.Project_Nodes.Table (Node).Field1 := To; *************** package body Prj.Tree is *** 2075,2081 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else --- 2137,2143 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else *************** package body Prj.Tree is *** 2094,2100 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Field1 := To; --- 2156,2162 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Field1 := To; *************** package body Prj.Tree is *** 2110,2116 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else --- 2172,2178 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else *************** package body Prj.Tree is *** 2128,2134 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); In_Tree.Project_Nodes.Table (Node).Flag1 := True; --- 2190,2196 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); In_Tree.Project_Nodes.Table (Node).Flag1 := True; *************** package body Prj.Tree is *** 2144,2150 **** To : Project_Node_Kind) is begin ! pragma Assert (Node /= Empty_Node); In_Tree.Project_Nodes.Table (Node).Kind := To; end Set_Kind_Of; --- 2206,2212 ---- To : Project_Node_Kind) is begin ! pragma Assert (Present (Node)); In_Tree.Project_Nodes.Table (Node).Kind := To; end Set_Kind_Of; *************** package body Prj.Tree is *** 2158,2164 **** To : Source_Ptr) is begin ! pragma Assert (Node /= Empty_Node); In_Tree.Project_Nodes.Table (Node).Location := To; end Set_Location_Of; --- 2220,2226 ---- To : Source_Ptr) is begin ! pragma Assert (Present (Node)); In_Tree.Project_Nodes.Table (Node).Location := To; end Set_Location_Of; *************** package body Prj.Tree is *** 2173,2179 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); In_Tree.Project_Nodes.Table (Node).Field2 := To; --- 2235,2241 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); In_Tree.Project_Nodes.Table (Node).Field2 := To; *************** package body Prj.Tree is *** 2190,2196 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Value := Name_Id (To); --- 2252,2258 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Value := Name_Id (To); *************** package body Prj.Tree is *** 2207,2213 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); In_Tree.Project_Nodes.Table (Node).Field3 := To; --- 2269,2275 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); In_Tree.Project_Nodes.Table (Node).Field3 := To; *************** package body Prj.Tree is *** 2223,2229 **** To : Name_Id) is begin ! pragma Assert (Node /= Empty_Node); In_Tree.Project_Nodes.Table (Node).Name := To; end Set_Name_Of; --- 2285,2291 ---- To : Name_Id) is begin ! pragma Assert (Present (Node)); In_Tree.Project_Nodes.Table (Node).Name := To; end Set_Name_Of; *************** package body Prj.Tree is *** 2238,2244 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); In_Tree.Project_Nodes.Table (Node).Field2 := To; --- 2300,2306 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); In_Tree.Project_Nodes.Table (Node).Field2 := To; *************** package body Prj.Tree is *** 2265,2271 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); In_Tree.Project_Nodes.Table (Node).Field2 := To; --- 2327,2333 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); In_Tree.Project_Nodes.Table (Node).Field2 := To; *************** package body Prj.Tree is *** 2282,2288 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String); In_Tree.Project_Nodes.Table (Node).Field1 := To; --- 2344,2350 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String); In_Tree.Project_Nodes.Table (Node).Field1 := To; *************** package body Prj.Tree is *** 2299,2305 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); In_Tree.Project_Nodes.Table (Node).Field3 := To; --- 2361,2367 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); In_Tree.Project_Nodes.Table (Node).Field3 := To; *************** package body Prj.Tree is *** 2316,2322 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); --- 2378,2384 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); *************** package body Prj.Tree is *** 2334,2340 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); In_Tree.Project_Nodes.Table (Node).Field2 := To; --- 2396,2402 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); In_Tree.Project_Nodes.Table (Node).Field2 := To; *************** package body Prj.Tree is *** 2351,2357 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration --- 2413,2419 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration *************** package body Prj.Tree is *** 2372,2378 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); In_Tree.Project_Nodes.Table (Node).Field2 := To; --- 2434,2440 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); In_Tree.Project_Nodes.Table (Node).Field2 := To; *************** package body Prj.Tree is *** 2389,2395 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); In_Tree.Project_Nodes.Table (Node).Pkg_Id := To; --- 2451,2457 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); In_Tree.Project_Nodes.Table (Node).Pkg_Id := To; *************** package body Prj.Tree is *** 2406,2412 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference or else --- 2468,2474 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference or else *************** package body Prj.Tree is *** 2425,2431 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else --- 2487,2493 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else *************** package body Prj.Tree is *** 2461,2472 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_Project_Declaration_Of; ----------------------------------------------- -- Set_Project_File_Includes_Unkept_Comments -- ----------------------------------------------- --- 2523,2566 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_Project_Declaration_Of; + ------------------------------ + -- Set_Project_Qualifier_Of -- + ------------------------------ + + procedure Set_Project_Qualifier_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Qualifier) + is + begin + pragma Assert + (Present (Node) + and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + In_Tree.Project_Nodes.Table (Node).Qualifier := To; + end Set_Project_Qualifier_Of; + + --------------------------- + -- Set_Parent_Project_Of -- + --------------------------- + + procedure Set_Parent_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + In_Tree.Project_Nodes.Table (Node).Field4 := To; + end Set_Parent_Project_Of; + ----------------------------------------------- -- Set_Project_File_Includes_Unkept_Comments -- ----------------------------------------------- *************** package body Prj.Tree is *** 2494,2500 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause or else --- 2588,2594 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause or else *************** package body Prj.Tree is *** 2521,2527 **** is begin pragma Assert ! (Node /= Empty_Node and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); In_Tree.Project_Nodes.Table (Node).Field1 := To; --- 2615,2621 ---- is begin pragma Assert ! (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); In_Tree.Project_Nodes.Table (Node).Field1 := To; *************** package body Prj.Tree is *** 2538,2544 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String or else --- 2632,2638 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String or else *************** package body Prj.Tree is *** 2558,2564 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference --- 2652,2658 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference *************** package body Prj.Tree is *** 2586,2592 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause or else --- 2680,2686 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause or else *************** package body Prj.Tree is *** 2606,2612 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String or else --- 2700,2706 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String or else *************** package body Prj.Tree is *** 2625,2631 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference --- 2719,2725 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference *************** package body Prj.Tree is *** 2650,2656 **** is begin pragma Assert ! (Node /= Empty_Node and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause or else --- 2744,2750 ---- is begin pragma Assert ! (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause or else *************** package body Prj.Tree is *** 2671,2677 **** is begin pragma Assert ! (For_Typed_Variable /= Empty_Node and then (In_Tree.Project_Nodes.Table (For_Typed_Variable).Kind = N_Typed_Variable_Declaration)); --- 2765,2771 ---- is begin pragma Assert ! (Present (For_Typed_Variable) and then (In_Tree.Project_Nodes.Table (For_Typed_Variable).Kind = N_Typed_Variable_Declaration)); *************** package body Prj.Tree is *** 2683,2689 **** In_Tree); begin ! while Current_String /= Empty_Node and then String_Value_Of (Current_String, In_Tree) /= Value loop --- 2777,2783 ---- In_Tree); begin ! while Present (Current_String) and then String_Value_Of (Current_String, In_Tree) /= Value loop *************** package body Prj.Tree is *** 2691,2697 **** Next_Literal_String (Current_String, In_Tree); end loop; ! return Current_String /= Empty_Node; end; end Value_Is_Valid; --- 2785,2791 ---- Next_Literal_String (Current_String, In_Tree); end loop; ! return Present (Current_String); end; end Value_Is_Valid; diff -Nrcpad gcc-4.3.3/gcc/ada/prj-tree.ads gcc-4.4.0/gcc/ada/prj-tree.ads *** gcc-4.3.3/gcc/ada/prj-tree.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/prj-tree.ads Tue May 20 12:45:54 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package Prj.Tree is *** 63,69 **** -- N_Variable_Reference. subtype Package_Declaration_Id is Project_Node_Id; ! -- Used to designate a node whose expected kind is N_Proect_Declaration type Project_Node_Kind is (N_Project, --- 63,69 ---- -- N_Variable_Reference. subtype Package_Declaration_Id is Project_Node_Id; ! -- Used to designate a node whose expected kind is N_Project_Declaration type Project_Node_Kind is (N_Project, *************** package Prj.Tree is *** 90,95 **** --- 90,103 ---- -- of the fields in each node of Project_Node_Kind, look at package -- Tree_Private_Part. + function Present (Node : Project_Node_Id) return Boolean; + pragma Inline (Present); + -- Return True iff Node /= Empty_Node + + function No (Node : Project_Node_Id) return Boolean; + pragma Inline (No); + -- Return True iff Node = Empty_Node + procedure Initialize (Tree : Project_Node_Tree_Ref); -- Initialize the Project File tree: empty the Project_Nodes table -- and reset the Projects_Htable. *************** package Prj.Tree is *** 262,271 **** In_Tree : Project_Node_Tree_Ref) return Boolean; -- Valid only for N_Comment nodes function Project_File_Includes_Unkept_Comments (Node : Project_Node_Id; ! In_Tree : Project_Node_Tree_Ref) ! return Boolean; -- Valid only for N_Project nodes function Directory_Of --- 270,284 ---- In_Tree : Project_Node_Tree_Ref) return Boolean; -- Valid only for N_Comment nodes + function Parent_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Parent_Project_Of); + -- Valid only for N_Project nodes + function Project_File_Includes_Unkept_Comments (Node : Project_Node_Id; ! In_Tree : Project_Node_Tree_Ref) return Boolean; -- Valid only for N_Project nodes function Directory_Of *************** package Prj.Tree is *** 344,349 **** --- 357,368 ---- pragma Inline (Project_Declaration_Of); -- Only valid for N_Project nodes + function Project_Qualifier_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Qualifier; + pragma Inline (Project_Qualifier_Of); + -- Only valid for N_Project nodes + function Extending_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; *************** package Prj.Tree is *** 625,630 **** --- 644,654 ---- To : Project_Node_Id); pragma Inline (Set_Next_Comment); + procedure Set_Parent_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + procedure Set_Project_File_Includes_Unkept_Comments (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; *************** package Prj.Tree is *** 694,699 **** --- 718,729 ---- To : Project_Node_Id); pragma Inline (Set_Project_Declaration_Of); + procedure Set_Project_Qualifier_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Qualifier); + pragma Inline (Set_Project_Qualifier_Of); + procedure Set_Extending_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; *************** package Prj.Tree is *** 912,917 **** --- 942,949 ---- Kind : Project_Node_Kind; + Qualifier : Project_Qualifier := Unspecified; + Location : Source_Ptr := No_Location; Directory : Path_Name_Type := No_Path; *************** package Prj.Tree is *** 941,947 **** Src_Index : Int := 0; -- Index of a unit in a multi-unit source. ! -- Onli for some N_Attribute_Declaration and N_Literal_String. Path_Name : Path_Name_Type := No_Path; -- See below for what Project_Node_Kind it is used --- 973,979 ---- Src_Index : Int := 0; -- Index of a unit in a multi-unit source. ! -- Only for some N_Attribute_Declaration and N_Literal_String. Path_Name : Path_Name_Type := No_Path; -- See below for what Project_Node_Kind it is used *************** package Prj.Tree is *** 958,966 **** Field3 : Project_Node_Id := Empty_Node; -- See below the meaning for each Project_Node_Kind Flag1 : Boolean := False; -- This flag is significant only for: ! -- N_Attribute_Declaration and N_Atribute_Reference -- It indicates for an associative array attribute, that the -- index is case insensitive. -- N_Comment - it indicates that the comment is preceded by an --- 990,1001 ---- Field3 : Project_Node_Id := Empty_Node; -- See below the meaning for each Project_Node_Kind + Field4 : Project_Node_Id := Empty_Node; + -- See below the meaning for each Project_Node_Kind + Flag1 : Boolean := False; -- This flag is significant only for: ! -- N_Attribute_Declaration and N_Attribute_Reference -- It indicates for an associative array attribute, that the -- index is case insensitive. -- N_Comment - it indicates that the comment is preceded by an *************** package Prj.Tree is *** 1005,1010 **** --- 1040,1046 ---- -- -- Field1: first with clause -- -- Field2: project declaration -- -- Field3: first string type + -- -- Field4: parent project, if any -- -- Value: extended project path name (if any) -- N_With_Clause, *************** package Prj.Tree is *** 1014,1019 **** --- 1050,1056 ---- -- -- Field1: project node -- -- Field2: next with clause -- -- Field3: project node or empty if "limited with" + -- -- Field4: not used -- -- Value: literal string withed -- N_Project_Declaration, *************** package Prj.Tree is *** 1023,1028 **** --- 1060,1066 ---- -- -- Field1: first declarative item -- -- Field2: extended project -- -- Field3: extending project + -- -- Field4: not used -- -- Value: not used -- N_Declarative_Item, *************** package Prj.Tree is *** 1032,1037 **** --- 1070,1076 ---- -- -- Field1: current item node -- -- Field2: next declarative item -- -- Field3: not used + -- -- Field4: not used -- -- Value: not used -- N_Package_Declaration, *************** package Prj.Tree is *** 1041,1046 **** --- 1080,1086 ---- -- -- Field1: project of renamed package (if any) -- -- Field2: first declarative item -- -- Field3: next package in project + -- -- Field4: not used -- -- Value: not used -- N_String_Type_Declaration, *************** package Prj.Tree is *** 1050,1055 **** --- 1090,1096 ---- -- -- Field1: first literal string -- -- Field2: next string type -- -- Field3: not used + -- -- Field4: not used -- -- Value: not used -- N_Literal_String, *************** package Prj.Tree is *** 1059,1064 **** --- 1100,1106 ---- -- -- Field1: next literal string -- -- Field2: not used -- -- Field3: not used + -- -- Field4: not used -- -- Value: string value -- N_Attribute_Declaration, *************** package Prj.Tree is *** 1068,1073 **** --- 1110,1116 ---- -- -- Field1: expression -- -- Field2: project of full associative array -- -- Field3: package of full associative array + -- -- Field4: not used -- -- Value: associative array index -- -- (if an associative array element) *************** package Prj.Tree is *** 1078,1083 **** --- 1121,1127 ---- -- -- Field1: expression -- -- Field2: type of variable (N_String_Type_Declaration) -- -- Field3: next variable + -- -- Field4: not used -- -- Value: not used -- N_Variable_Declaration, *************** package Prj.Tree is *** 1091,1096 **** --- 1135,1141 ---- -- -- N_Variable_Declaration and -- -- N_Typed_Variable_Declaration -- -- Field3: next variable + -- -- Field4: not used -- -- Value: not used -- N_Expression, *************** package Prj.Tree is *** 1109,1114 **** --- 1154,1160 ---- -- -- Field1: current term -- -- Field2: next term in the expression -- -- Field3: not used + -- -- Field4: not used -- -- Value: not used -- N_Literal_String_List, *************** package Prj.Tree is *** 1121,1126 **** --- 1167,1173 ---- -- -- Field1: first expression -- -- Field2: not used -- -- Field3: not used + -- -- Field4: not used -- -- Value: not used -- N_Variable_Reference, *************** package Prj.Tree is *** 1130,1135 **** --- 1177,1183 ---- -- -- Field1: project (if specified) -- -- Field2: package (if specified) -- -- Field3: type of variable (N_String_Type_Declaration), if any + -- -- Field4: not used -- -- Value: not used -- N_External_Value, *************** package Prj.Tree is *** 1148,1153 **** --- 1196,1202 ---- -- -- Field1: project -- -- Field2: package (if attribute of a package) -- -- Field3: not used + -- -- Field4: not used -- -- Value: associative array index -- -- (if an associative array element) *************** package Prj.Tree is *** 1158,1163 **** --- 1207,1213 ---- -- -- Field1: case variable reference -- -- Field2: first case item -- -- Field3: not used + -- -- Field4: not used -- -- Value: not used -- N_Case_Item *************** package Prj.Tree is *** 1168,1173 **** --- 1218,1224 ---- -- -- for when others -- -- Field2: first declarative item -- -- Field3: next case item + -- -- Field4: not used -- -- Value: not used -- N_Comment_zones *************** package Prj.Tree is *** 1178,1183 **** --- 1229,1235 ---- -- -- Field2: comment after the construct -- -- Field3: comment before the "end" of the construct -- -- Value: end of line comment + -- -- Field4: not used -- -- Comments: comment after the "end" of the construct -- N_Comment *************** package Prj.Tree is *** 1187,1192 **** --- 1239,1245 ---- -- -- Field1: not used -- -- Field2: not used -- -- Field3: not used + -- -- Field4: not used -- -- Value: comment -- -- Flag1: comment is preceded by an empty line -- -- Flag2: comment is followed by an empty line *************** package Prj.Tree is *** 1215,1227 **** Extended : Boolean; -- True when the project is being extended by another project end record; No_Project_Name_And_Node : constant Project_Name_And_Node := (Name => No_Name, Node => Empty_Node, Canonical_Path => No_Path, ! Extended => True); package Projects_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, --- 1268,1284 ---- Extended : Boolean; -- True when the project is being extended by another project + + Proj_Qualifier : Project_Qualifier; + -- The project qualifier of the project, if any end record; No_Project_Name_And_Node : constant Project_Name_And_Node := (Name => No_Name, Node => Empty_Node, Canonical_Path => No_Path, ! Extended => True, ! Proj_Qualifier => Unspecified); package Projects_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, diff -Nrcpad gcc-4.3.3/gcc/ada/prj-util.adb gcc-4.4.0/gcc/ada/prj-util.adb *** gcc-4.3.3/gcc/ada/prj-util.adb Mon Oct 15 13:55:54 2007 --- gcc-4.4.0/gcc/ada/prj-util.adb Tue Aug 5 09:14:48 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package body Prj.Util is *** 109,115 **** In_Tree : Project_Tree_Ref; Main : File_Name_Type; Index : Int; ! Ada_Main : Boolean := True) return File_Name_Type is pragma Assert (Project /= No_Project); --- 109,116 ---- In_Tree : Project_Tree_Ref; Main : File_Name_Type; Index : Int; ! Ada_Main : Boolean := True; ! Language : String := "") return File_Name_Type is pragma Assert (Project /= No_Project); *************** package body Prj.Util is *** 136,148 **** Naming : constant Naming_Data := In_Tree.Projects.Table (Project).Naming; ! Body_Suffix : constant String := ! Body_Suffix_Of (In_Tree, "ada", Naming); ! Spec_Suffix : constant String := ! Spec_Suffix_Of (In_Tree, "ada", Naming); begin if Builder_Package /= No_Package then if Get_Mode = Multi_Language then Executable_Suffix_Name := --- 137,191 ---- Naming : constant Naming_Data := In_Tree.Projects.Table (Project).Naming; ! Spec_Suffix : Name_Id := No_Name; ! Body_Suffix : Name_Id := No_Name; ! Spec_Suffix_Length : Natural := 0; ! Body_Suffix_Length : Natural := 0; ! ! procedure Get_Suffixes ! (B_Suffix : String; ! S_Suffix : String); ! -- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix ! ! ------------------ ! -- Get_Suffixes -- ! ------------------ ! ! procedure Get_Suffixes ! (B_Suffix : String; ! S_Suffix : String) ! is ! begin ! if B_Suffix'Length > 0 then ! Name_Len := B_Suffix'Length; ! Name_Buffer (1 .. Name_Len) := B_Suffix; ! Body_Suffix := Name_Find; ! Body_Suffix_Length := B_Suffix'Length; ! end if; ! ! if S_Suffix'Length > 0 then ! Name_Len := S_Suffix'Length; ! Name_Buffer (1 .. Name_Len) := S_Suffix; ! Spec_Suffix := Name_Find; ! Spec_Suffix_Length := S_Suffix'Length; ! end if; ! end Get_Suffixes; ! ! -- Start of processing for Executable_Of begin + if Ada_Main then + Get_Suffixes + (B_Suffix => Body_Suffix_Of (In_Tree, "ada", Naming), + S_Suffix => Spec_Suffix_Of (In_Tree, "ada", Naming)); + + elsif Language /= "" then + Get_Suffixes + (B_Suffix => Body_Suffix_Of (In_Tree, Language, Naming), + S_Suffix => Spec_Suffix_Of (In_Tree, Language, Naming)); + end if; + if Builder_Package /= No_Package then if Get_Mode = Multi_Language then Executable_Suffix_Name := *************** package body Prj.Util is *** 176,196 **** Truncated : Boolean := False; begin ! if Last > Body_Suffix'Length ! and then Name (Last - Body_Suffix'Length + 1 .. Last) = ! Body_Suffix then Truncated := True; ! Last := Last - Body_Suffix'Length; end if; if not Truncated ! and then Last > Spec_Suffix'Length ! and then Name (Last - Spec_Suffix'Length + 1 .. Last) = ! Spec_Suffix then Truncated := True; ! Last := Last - Spec_Suffix'Length; end if; if Truncated then --- 219,239 ---- Truncated : Boolean := False; begin ! if Last > Natural (Length_Of_Name (Body_Suffix)) ! and then Name (Last - Body_Suffix_Length + 1 .. Last) = ! Get_Name_String (Body_Suffix) then Truncated := True; ! Last := Last - Body_Suffix_Length; end if; if not Truncated ! and then Last > Spec_Suffix_Length ! and then Name (Last - Spec_Suffix_Length + 1 .. Last) = ! Get_Name_String (Spec_Suffix) then Truncated := True; ! Last := Last - Spec_Suffix_Length; end if; if Truncated then *************** package body Prj.Util is *** 238,258 **** -- otherwise remove any suffix ('.' followed by other characters), if -- there is one. ! if Ada_Main and then Name_Len > Body_Suffix'Length ! and then Name_Buffer (Name_Len - Body_Suffix'Length + 1 .. Name_Len) = ! Body_Suffix then -- Found the body termination, remove it ! Name_Len := Name_Len - Body_Suffix'Length; ! elsif Ada_Main and then Name_Len > Spec_Suffix'Length ! and then Name_Buffer (Name_Len - Spec_Suffix'Length + 1 .. Name_Len) = ! Spec_Suffix then -- Found the spec termination, remove it ! Name_Len := Name_Len - Spec_Suffix'Length; else -- Remove any suffix, if there is one --- 281,304 ---- -- otherwise remove any suffix ('.' followed by other characters), if -- there is one. ! if Body_Suffix /= No_Name ! and then Name_Len > Body_Suffix_Length ! and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) = ! Get_Name_String (Body_Suffix) then -- Found the body termination, remove it ! Name_Len := Name_Len - Body_Suffix_Length; ! elsif Spec_Suffix /= No_Name ! and then Name_Len > Spec_Suffix_Length ! and then ! Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) = ! Get_Name_String (Spec_Suffix) then -- Found the spec termination, remove it ! Name_Len := Name_Len - Spec_Suffix_Length; else -- Remove any suffix, if there is one *************** package body Prj.Util is *** 284,291 **** Result : File_Name_Type; begin ! Executable_Extension_On_Target := ! In_Tree.Projects.Table (Project).Config.Executable_Suffix; Result := Executable_Name (Name_Find); Executable_Extension_On_Target := Saved_EEOT; return Result; --- 330,342 ---- Result : File_Name_Type; begin ! if In_Tree.Projects.Table (Project).Config.Executable_Suffix /= ! No_Name ! then ! Executable_Extension_On_Target := ! In_Tree.Projects.Table (Project).Config.Executable_Suffix; ! end if; ! Result := Executable_Name (Name_Find); Executable_Extension_On_Target := Saved_EEOT; return Result; *************** package body Prj.Util is *** 418,437 **** --------- procedure Put ! (Into_List : in out Name_List_Index; ! From_List : String_List_Id; ! In_Tree : Project_Tree_Ref) is Current_Name : Name_List_Index; List : String_List_Id; Element : String_Element; Last : Name_List_Index := Name_List_Table.Last (In_Tree.Name_Lists); begin Current_Name := Into_List; ! while Current_Name /= No_Name_List and then ! In_Tree.Name_Lists.Table (Current_Name).Next /= No_Name_List loop Current_Name := In_Tree.Name_Lists.Table (Current_Name).Next; end loop; --- 469,490 ---- --------- procedure Put ! (Into_List : in out Name_List_Index; ! From_List : String_List_Id; ! In_Tree : Project_Tree_Ref; ! Lower_Case : Boolean := False) is Current_Name : Name_List_Index; List : String_List_Id; Element : String_Element; Last : Name_List_Index := Name_List_Table.Last (In_Tree.Name_Lists); + Value : Name_Id; begin Current_Name := Into_List; ! while Current_Name /= No_Name_List ! and then In_Tree.Name_Lists.Table (Current_Name).Next /= No_Name_List loop Current_Name := In_Tree.Name_Lists.Table (Current_Name).Next; end loop; *************** package body Prj.Util is *** 439,448 **** List := From_List; while List /= Nil_String loop Element := In_Tree.String_Elements.Table (List); Name_List_Table.Append ! (In_Tree.Name_Lists, ! (Name => Element.Value, Next => No_Name_List)); Last := Last + 1; --- 492,507 ---- List := From_List; while List /= Nil_String loop Element := In_Tree.String_Elements.Table (List); + Value := Element.Value; + + if Lower_Case then + Get_Name_String (Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Value := Name_Find; + end if; Name_List_Table.Append ! (In_Tree.Name_Lists, (Name => Value, Next => No_Name_List)); Last := Last + 1; *************** package body Prj.Util is *** 541,549 **** Real_Index_1 := Index; if not Element.Index_Case_Sensitive or Force_Lower_Case_Index then ! Get_Name_String (Index); ! To_Lower (Name_Buffer (1 .. Name_Len)); ! Real_Index_1 := Name_Find; end if; while Current /= No_Array_Element loop --- 600,610 ---- Real_Index_1 := Index; if not Element.Index_Case_Sensitive or Force_Lower_Case_Index then ! if Index /= All_Other_Names then ! Get_Name_String (Index); ! To_Lower (Name_Buffer (1 .. Name_Len)); ! Real_Index_1 := Name_Find; ! end if; end if; while Current /= No_Array_Element loop *************** package body Prj.Util is *** 551,559 **** Real_Index_2 := Element.Index; if not Element.Index_Case_Sensitive or Force_Lower_Case_Index then ! Get_Name_String (Element.Index); ! To_Lower (Name_Buffer (1 .. Name_Len)); ! Real_Index_2 := Name_Find; end if; if Real_Index_1 = Real_Index_2 and then --- 612,622 ---- Real_Index_2 := Element.Index; if not Element.Index_Case_Sensitive or Force_Lower_Case_Index then ! if Element.Index /= All_Other_Names then ! Get_Name_String (Element.Index); ! To_Lower (Name_Buffer (1 .. Name_Len)); ! Real_Index_2 := Name_Find; ! end if; end if; if Real_Index_1 = Real_Index_2 and then diff -Nrcpad gcc-4.3.3/gcc/ada/prj-util.ads gcc-4.4.0/gcc/ada/prj-util.ads *** gcc-4.3.3/gcc/ada/prj-util.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/prj-util.ads Thu Jul 31 11:04:00 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** *** 27,49 **** package Prj.Util is function Executable_Of (Project : Project_Id; In_Tree : Project_Tree_Ref; Main : File_Name_Type; Index : Int; ! Ada_Main : Boolean := True) return File_Name_Type; -- Return the value of the attribute Builder'Executable for file Main in -- the project Project, if it exists. If there is no attribute Executable -- for Main, remove the suffix from Main; then, if the attribute -- Executable_Suffix is specified, add this suffix, otherwise add the -- standard executable suffix for the platform. procedure Put ! (Into_List : in out Name_List_Index; ! From_List : String_List_Id; ! In_Tree : Project_Tree_Ref); -- Append a name list to a string list procedure Duplicate (This : in out Name_List_Index; --- 27,56 ---- package Prj.Util is + -- ??? throughout this spec, parameters are not well enough documented + function Executable_Of (Project : Project_Id; In_Tree : Project_Tree_Ref; Main : File_Name_Type; Index : Int; ! Ada_Main : Boolean := True; ! Language : String := "") return File_Name_Type; -- Return the value of the attribute Builder'Executable for file Main in -- the project Project, if it exists. If there is no attribute Executable -- for Main, remove the suffix from Main; then, if the attribute -- Executable_Suffix is specified, add this suffix, otherwise add the -- standard executable suffix for the platform. + -- What is Ada_Main??? + -- What is Language??? procedure Put ! (Into_List : in out Name_List_Index; ! From_List : String_List_Id; ! In_Tree : Project_Tree_Ref; ! Lower_Case : Boolean := False); -- Append a name list to a string list + -- Describe parameters??? procedure Duplicate (This : in out Name_List_Index; *************** package Prj.Util is *** 139,152 **** -- the last character of each line, if possible. type Text_File is limited private; ! -- Represents a text file. Default is invalid text file function Is_Valid (File : Text_File) return Boolean; ! -- Returns True if File designates an open text file that ! -- has not yet been closed. procedure Open (File : out Text_File; Name : String); ! -- Open a text file. If this procedure fails, File is invalid function End_Of_File (File : Text_File) return Boolean; -- Returns True if the end of the text file File has been reached. Fails if --- 146,159 ---- -- the last character of each line, if possible. type Text_File is limited private; ! -- Represents a text file (default is invalid text file) function Is_Valid (File : Text_File) return Boolean; ! -- Returns True if File designates an open text file that has not yet been ! -- closed. procedure Open (File : out Text_File; Name : String); ! -- Open a text file to read (file is invalid if text file cannot be opened) function End_Of_File (File : Text_File) return Boolean; -- Returns True if the end of the text file File has been reached. Fails if *************** package Prj.Util is *** 156,162 **** (File : Text_File; Line : out String; Last : out Natural); ! -- Reads a line from an open text file. Fails if File is invalid procedure Close (File : in out Text_File); -- Close an open text file. File becomes invalid. Fails if File is already --- 163,169 ---- (File : Text_File; Line : out String; Last : out Natural); ! -- Reads a line from an open text file (fails if file is invalid) procedure Close (File : in out Text_File); -- Close an open text file. File becomes invalid. Fails if File is already diff -Nrcpad gcc-4.3.3/gcc/ada/prj.adb gcc-4.4.0/gcc/ada/prj.adb *** gcc-4.3.3/gcc/ada/prj.adb Thu Dec 13 10:28:39 2007 --- gcc-4.4.0/gcc/ada/prj.adb Fri Aug 1 09:02:58 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** with Prj.Attr; *** 32,40 **** --- 32,42 ---- with Prj.Env; with Prj.Err; use Prj.Err; with Snames; use Snames; + with Table; with Uintp; use Uintp; with System.Case_Util; use System.Case_Util; + with System.HTable; package body Prj is *************** package body Prj is *** 50,57 **** The_Empty_String : Name_Id; - Name_C_Plus_Plus : Name_Id; - Default_Ada_Spec_Suffix_Id : File_Name_Type; Default_Ada_Body_Suffix_Id : File_Name_Type; Slash_Id : Path_Name_Type; --- 52,57 ---- *************** package body Prj is *** 83,171 **** Specs => No_Array_Element, Bodies => No_Array_Element, Specification_Exceptions => No_Array_Element, ! Implementation_Exceptions => No_Array_Element, ! Impl_Suffixes => No_Impl_Suffixes, ! Supp_Suffixes => No_Supp_Language_Index); Project_Empty : constant Project_Data := ! (Externally_Built => False, ! Config => Default_Project_Config, ! Languages => No_Name_List, ! First_Referred_By => No_Project, ! Name => No_Name, ! Display_Name => No_Name, ! Path_Name => No_Path, ! Display_Path_Name => No_Path, ! Virtual => False, ! Location => No_Location, ! Mains => Nil_String, ! Directory => No_Path, ! Display_Directory => No_Path, ! Dir_Path => null, ! Library => False, ! Library_Dir => No_Path, ! Display_Library_Dir => No_Path, ! Library_Src_Dir => No_Path, ! Display_Library_Src_Dir => No_Path, ! Library_ALI_Dir => No_Path, ! Display_Library_ALI_Dir => No_Path, ! Library_Name => No_Name, ! Library_Kind => Static, ! Lib_Internal_Name => No_Name, ! Standalone_Library => False, ! Lib_Interface_ALIs => Nil_String, ! Lib_Auto_Init => False, ! Libgnarl_Needed => Unknown, ! Symbol_Data => No_Symbols, ! Ada_Sources => Nil_String, ! Sources => Nil_String, ! First_Source => No_Source, ! Last_Source => No_Source, ! Unit_Based_Language_Name => No_Name, ! Unit_Based_Language_Index => No_Language_Index, ! Imported_Directories_Switches => null, ! Include_Path => null, ! Include_Data_Set => False, ! Include_Language => No_Language_Index, ! Source_Dirs => Nil_String, ! Known_Order_Of_Source_Dirs => True, ! Object_Directory => No_Path, ! Display_Object_Dir => No_Path, ! Library_TS => Empty_Time_Stamp, ! Exec_Directory => No_Path, ! Display_Exec_Dir => No_Path, ! Extends => No_Project, ! Extended_By => No_Project, ! Naming => Std_Naming_Data, ! First_Language_Processing => No_Language_Index, ! Decl => No_Declarations, ! Imported_Projects => Empty_Project_List, ! All_Imported_Projects => Empty_Project_List, ! Ada_Include_Path => null, ! Ada_Objects_Path => null, ! Objects_Path => null, ! Include_Path_File => No_Path, ! Objects_Path_File_With_Libs => No_Path, ! Objects_Path_File_Without_Libs => No_Path, ! Config_File_Name => No_Path, ! Config_File_Temp => False, ! Linker_Name => No_File, ! Linker_Path => No_Path, ! Minimum_Linker_Options => No_Name_List, ! Config_Checked => False, ! Checked => False, ! Seen => False, ! Need_To_Build_Lib => False, ! Depth => 0, ! Unkept_Comments => False, ! Langs => No_Languages, ! Supp_Languages => No_Supp_Language_Index, ! Ada_Sources_Present => True, ! Other_Sources_Present => True, ! First_Other_Source => No_Other_Source, ! Last_Other_Source => No_Other_Source, ! First_Lang_Processing => Default_First_Language_Processing_Data, ! Supp_Language_Processing => No_Supp_Language_Index); package Temp_Files is new Table.Table (Table_Component_Type => Path_Name_Type, --- 83,154 ---- Specs => No_Array_Element, Bodies => No_Array_Element, Specification_Exceptions => No_Array_Element, ! Implementation_Exceptions => No_Array_Element); Project_Empty : constant Project_Data := ! (Qualifier => Unspecified, ! Externally_Built => False, ! Config => Default_Project_Config, ! Languages => No_Name_List, ! First_Referred_By => No_Project, ! Name => No_Name, ! Display_Name => No_Name, ! Path => No_Path_Information, ! Virtual => False, ! Location => No_Location, ! Mains => Nil_String, ! Directory => No_Path_Information, ! Dir_Path => null, ! Library => False, ! Library_Dir => No_Path_Information, ! Library_Src_Dir => No_Path_Information, ! Library_ALI_Dir => No_Path_Information, ! Library_Name => No_Name, ! Library_Kind => Static, ! Lib_Internal_Name => No_Name, ! Standalone_Library => False, ! Lib_Interface_ALIs => Nil_String, ! Lib_Auto_Init => False, ! Libgnarl_Needed => Unknown, ! Symbol_Data => No_Symbols, ! Ada_Sources_Present => True, ! Other_Sources_Present => True, ! Ada_Sources => Nil_String, ! First_Source => No_Source, ! Last_Source => No_Source, ! Interfaces_Defined => False, ! Unit_Based_Language_Name => No_Name, ! Unit_Based_Language_Index => No_Language_Index, ! Imported_Directories_Switches => null, ! Include_Path => null, ! Include_Data_Set => False, ! Include_Language => No_Language_Index, ! Source_Dirs => Nil_String, ! Known_Order_Of_Source_Dirs => True, ! Object_Directory => No_Path_Information, ! Library_TS => Empty_Time_Stamp, ! Exec_Directory => No_Path_Information, ! Extends => No_Project, ! Extended_By => No_Project, ! Naming => Std_Naming_Data, ! First_Language_Processing => No_Language_Index, ! Decl => No_Declarations, ! Imported_Projects => Empty_Project_List, ! All_Imported_Projects => Empty_Project_List, ! Ada_Include_Path => null, ! Ada_Objects_Path => null, ! Objects_Path => null, ! Include_Path_File => No_Path, ! Objects_Path_File_With_Libs => No_Path, ! Objects_Path_File_Without_Libs => No_Path, ! Config_File_Name => No_Path, ! Config_File_Temp => False, ! Config_Checked => False, ! Checked => False, ! Seen => False, ! Need_To_Build_Lib => False, ! Depth => 0, ! Unkept_Comments => False); package Temp_Files is new Table.Table (Table_Component_Type => Path_Name_Type, *************** package body Prj is *** 177,194 **** -- Table to store the path name of all the created temporary files, so that -- they can be deleted at the end, or when the program is interrupted. - ----------------------- - -- Add_Language_Name -- - ----------------------- - - procedure Add_Language_Name (Name : Name_Id) is - begin - Last_Language_Index := Last_Language_Index + 1; - Language_Indexes.Set (Name, Last_Language_Index); - Language_Names.Increment_Last; - Language_Names.Table (Last_Language_Index) := Name; - end Add_Language_Name; - ------------------- -- Add_To_Buffer -- ------------------- --- 160,165 ---- *************** package body Prj is *** 344,364 **** return ""; end Body_Suffix_Of; - function Body_Suffix_Of - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return String - is - Suffix_Id : constant File_Name_Type := - Suffix_Of (Language, In_Project, In_Tree); - begin - if Suffix_Id /= No_File then - return Get_Name_String (Suffix_Id); - else - return "." & Get_Name_String (Language_Names.Table (Language)); - end if; - end Body_Suffix_Of; - ----------------------------- -- Default_Ada_Body_Suffix -- ----------------------------- --- 315,320 ---- *************** package body Prj is *** 433,449 **** Write_Str (Name_Buffer (1 .. Name_Len)); end Display_Language_Name; - --------------------------- - -- Display_Language_Name -- - --------------------------- - - procedure Display_Language_Name (Language : Language_Index) is - begin - Get_Name_String (Language_Names.Table (Language)); - To_Upper (Name_Buffer (1 .. 1)); - Write_Str (Name_Buffer (1 .. Name_Len)); - end Display_Language_Name; - ---------------- -- Empty_File -- ---------------- --- 389,394 ---- *************** package body Prj is *** 596,601 **** --- 541,551 ---- return Hash (Get_Name_String (Name)); end Hash; + function Hash (Project : Project_Id) return Header_Num is + begin + return Header_Num (Project mod Max_Header_Num); + end Hash; + ----------- -- Image -- ----------- *************** package body Prj is *** 626,631 **** --- 576,582 ---- Name_Len := 0; The_Empty_String := Name_Find; Empty_Name := The_Empty_String; + Empty_File_Name := File_Name_Type (The_Empty_String); Name_Len := 4; Name_Buffer (1 .. 4) := ".ads"; Default_Ada_Spec_Suffix_Id := Name_Find; *************** package body Prj is *** 635,656 **** Name_Len := 1; Name_Buffer (1) := '/'; Slash_Id := Name_Find; - Name_Len := 3; - Name_Buffer (1 .. 3) := "c++"; - Name_C_Plus_Plus := Name_Find; Prj.Env.Initialize; Prj.Attr.Initialize; Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project)); Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends)); Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External)); - - Language_Indexes.Reset; - Last_Language_Index := No_Language_Index; - Language_Names.Init; - Add_Language_Name (Name_Ada); - Add_Language_Name (Name_C); - Add_Language_Name (Name_C_Plus_Plus); end if; if Tree /= No_Project_Tree then --- 586,597 ---- *************** package body Prj is *** 726,809 **** return False; end Is_Extending; - ---------------- - -- Is_Present -- - ---------------- - - function Is_Present - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return Boolean - is - begin - case Language is - when No_Language_Index => - return False; - - when First_Language_Indexes => - return In_Project.Langs (Language); - - when others => - declare - Supp : Supp_Language; - Supp_Index : Supp_Language_Index; - - begin - Supp_Index := In_Project.Supp_Languages; - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Present_Languages.Table (Supp_Index); - - if Supp.Index = Language then - return Supp.Present; - end if; - - Supp_Index := Supp.Next; - end loop; - - return False; - end; - end case; - end Is_Present; - - --------------------------------- - -- Language_Processing_Data_Of -- - --------------------------------- - - function Language_Processing_Data_Of - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return Language_Processing_Data - is - begin - case Language is - when No_Language_Index => - return Default_Language_Processing_Data; - - when First_Language_Indexes => - return In_Project.First_Lang_Processing (Language); - - when others => - declare - Supp : Supp_Language_Data; - Supp_Index : Supp_Language_Index; - - begin - Supp_Index := In_Project.Supp_Language_Processing; - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Supp_Languages.Table (Supp_Index); - - if Supp.Index = Language then - return Supp.Data; - end if; - - Supp_Index := Supp.Next; - end loop; - - return Default_Language_Processing_Data; - end; - end case; - end Language_Processing_Data_Of; - ----------------------- -- Objects_Exist_For -- ----------------------- --- 667,672 ---- *************** package body Prj is *** 827,833 **** if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then return In_Tree.Languages_Data.Table ! (Lang).Config.Objects_Generated; end if; Lang := In_Tree.Languages_Data.Table (Lang).Next; --- 690,696 ---- if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then return In_Tree.Languages_Data.Table ! (Lang).Config.Object_Generated; end if; Lang := In_Tree.Languages_Data.Table (Lang).Next; *************** package body Prj is *** 881,887 **** Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len)); Lang := Name_Find; ! -- Look for an element of the spec sufix array indexed by the language -- name. If one is found, put the default value. Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix; --- 744,750 ---- Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len)); Lang := Name_Find; ! -- Look for an element of the spec suffix array indexed by the language -- name. If one is found, put the default value. Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix; *************** package body Prj is *** 921,927 **** Array_Element_Table.Last (In_Tree.Array_Elements); end if; ! -- Look for an element of the body sufix array indexed by the language -- name. If one is found, put the default value. Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix; --- 784,790 ---- Array_Element_Table.Last (In_Tree.Array_Elements); end if; ! -- Look for an element of the body suffix array indexed by the language -- name. If one is found, put the default value. Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix; *************** package body Prj is *** 977,989 **** begin Prj.Env.Initialize; - -- gprmake tables - - Present_Language_Table.Init (Tree.Present_Languages); - Supp_Suffix_Table.Init (Tree.Supp_Suffixes); - Supp_Language_Table.Init (Tree.Supp_Languages); - Other_Source_Table.Init (Tree.Other_Sources); - -- Visible tables Language_Data_Table.Init (Tree.Languages_Data); --- 840,845 ---- *************** package body Prj is *** 1037,1180 **** and then Left.Separate_Suffix = Right.Separate_Suffix; end Same_Naming_Scheme; - --------- - -- Set -- - --------- - - procedure Set - (Language : Language_Index; - Present : Boolean; - In_Project : in out Project_Data; - In_Tree : Project_Tree_Ref) - is - begin - case Language is - when No_Language_Index => - null; - - when First_Language_Indexes => - In_Project.Langs (Language) := Present; - - when others => - declare - Supp : Supp_Language; - Supp_Index : Supp_Language_Index; - - begin - Supp_Index := In_Project.Supp_Languages; - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Present_Languages.Table (Supp_Index); - - if Supp.Index = Language then - In_Tree.Present_Languages.Table (Supp_Index).Present := - Present; - return; - end if; - - Supp_Index := Supp.Next; - end loop; - - Supp := (Index => Language, Present => Present, - Next => In_Project.Supp_Languages); - Present_Language_Table.Increment_Last - (In_Tree.Present_Languages); - Supp_Index := - Present_Language_Table.Last (In_Tree.Present_Languages); - In_Tree.Present_Languages.Table (Supp_Index) := - Supp; - In_Project.Supp_Languages := Supp_Index; - end; - end case; - end Set; - - procedure Set - (Language_Processing : Language_Processing_Data; - For_Language : Language_Index; - In_Project : in out Project_Data; - In_Tree : Project_Tree_Ref) - is - begin - case For_Language is - when No_Language_Index => - null; - - when First_Language_Indexes => - In_Project.First_Lang_Processing (For_Language) := - Language_Processing; - - when others => - declare - Supp : Supp_Language_Data; - Supp_Index : Supp_Language_Index; - - begin - Supp_Index := In_Project.Supp_Language_Processing; - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Supp_Languages.Table (Supp_Index); - - if Supp.Index = For_Language then - In_Tree.Supp_Languages.Table - (Supp_Index).Data := Language_Processing; - return; - end if; - - Supp_Index := Supp.Next; - end loop; - - Supp := (Index => For_Language, Data => Language_Processing, - Next => In_Project.Supp_Language_Processing); - Supp_Language_Table.Increment_Last - (In_Tree.Supp_Languages); - Supp_Index := Supp_Language_Table.Last - (In_Tree.Supp_Languages); - In_Tree.Supp_Languages.Table (Supp_Index) := Supp; - In_Project.Supp_Language_Processing := Supp_Index; - end; - end case; - end Set; - - procedure Set - (Suffix : File_Name_Type; - For_Language : Language_Index; - In_Project : in out Project_Data; - In_Tree : Project_Tree_Ref) - is - begin - case For_Language is - when No_Language_Index => - null; - - when First_Language_Indexes => - In_Project.Naming.Impl_Suffixes (For_Language) := Suffix; - - when others => - declare - Supp : Supp_Suffix; - Supp_Index : Supp_Language_Index; - - begin - Supp_Index := In_Project.Naming.Supp_Suffixes; - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Supp_Suffixes.Table (Supp_Index); - - if Supp.Index = For_Language then - In_Tree.Supp_Suffixes.Table (Supp_Index).Suffix := Suffix; - return; - end if; - - Supp_Index := Supp.Next; - end loop; - - Supp := (Index => For_Language, Suffix => Suffix, - Next => In_Project.Naming.Supp_Suffixes); - Supp_Suffix_Table.Increment_Last (In_Tree.Supp_Suffixes); - Supp_Index := Supp_Suffix_Table.Last (In_Tree.Supp_Suffixes); - In_Tree.Supp_Suffixes.Table (Supp_Index) := Supp; - In_Project.Naming.Supp_Suffixes := Supp_Index; - end; - end case; - end Set; - --------------------- -- Set_Body_Suffix -- --------------------- --- 893,898 ---- *************** package body Prj is *** 1418,1468 **** if Tree = No_Project_Tree then Prj.Initialize (Tree => No_Project_Tree); return Std_Naming_Data; - else return Tree.Private_Part.Default_Naming; end if; end Standard_Naming_Data; - --------------- - -- Suffix_Of -- - --------------- - - function Suffix_Of - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return File_Name_Type - is - begin - case Language is - when No_Language_Index => - return No_File; - - when First_Language_Indexes => - return In_Project.Naming.Impl_Suffixes (Language); - - when others => - declare - Supp : Supp_Suffix; - Supp_Index : Supp_Language_Index; - - begin - Supp_Index := In_Project.Naming.Supp_Suffixes; - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Supp_Suffixes.Table (Supp_Index); - - if Supp.Index = Language then - return Supp.Suffix; - end if; - - Supp_Index := Supp.Next; - end loop; - - return No_File; - end; - end case; - end Suffix_Of; - ------------------- -- Switches_Name -- ------------------- --- 1136,1146 ---- *************** package body Prj is *** 1474,1502 **** return Extend_Name (Source_File_Name, Switches_Dependency_Suffix); end Switches_Name; - --------------------------- - -- There_Are_Ada_Sources -- - --------------------------- - - function There_Are_Ada_Sources - (In_Tree : Project_Tree_Ref; - Project : Project_Id) return Boolean - is - Prj : Project_Id; - - begin - Prj := Project; - while Prj /= No_Project loop - if In_Tree.Projects.Table (Prj).Ada_Sources /= Nil_String then - return True; - end if; - - Prj := In_Tree.Projects.Table (Prj).Extends; - end loop; - - return False; - end There_Are_Ada_Sources; - ----------- -- Value -- ----------- --- 1152,1157 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/prj.ads gcc-4.4.0/gcc/ada/prj.ads *** gcc-4.3.3/gcc/ada/prj.ads Thu Dec 13 10:28:39 2007 --- gcc-4.4.0/gcc/ada/prj.ads Fri Aug 22 13:26:09 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** *** 32,48 **** with Casing; use Casing; with Namet; use Namet; with Scans; use Scans; - with Table; with Types; use Types; with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; with GNAT.Dynamic_Tables; with GNAT.OS_Lib; use GNAT.OS_Lib; - with System.HTable; - package Prj is type Library_Support is (None, Static_Only, Full); -- Support for Library Project File. -- - None: Library Project Files are not supported at all --- 32,57 ---- with Casing; use Casing; with Namet; use Namet; with Scans; use Scans; with Types; use Types; with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; with GNAT.Dynamic_Tables; with GNAT.OS_Lib; use GNAT.OS_Lib; package Prj is + All_Other_Names : constant Name_Id := Names_High_Bound; + -- Name used to replace others as an index of an associative array + -- attribute in situations where this is allowed. + + Subdirs_Option : constant String := "--subdirs="; + -- Switch used to indicate that the real directories (object, exec, + -- library, ...) are subdirectories of those in the project file. + + Subdirs : String_Ptr := null; + -- The value after the equal sign in switch --subdirs=... + -- Contains the relative subdirectory. + type Library_Support is (None, Static_Only, Full); -- Support for Library Project File. -- - None: Library Project Files are not supported at all *************** package Prj is *** 55,60 **** --- 64,86 ---- -- Tri-state to decide if -lgnarl is needed when linking type Mode is (Multi_Language, Ada_Only); + -- Ada_Only: mode for gnatmake, gnatclean, gnatname, the GNAT driver + -- Multi_Language: mode for gprbuild, gprclean + + type Project_Qualifier is + (Unspecified, + Standard, + Library, + Dry, + Aggregate, + Aggregate_Library); + -- Qualifiers that can prefix the reserved word "project" in a project + -- file: + -- Standard: standard project ... + -- Library: library project is ... + -- Dry: abstract project is + -- Aggregate: aggregate project is + -- Aggregate_Library: aggregate library project is ... function Get_Mode return Mode; pragma Inline (Get_Mode); *************** package Prj is *** 68,76 **** -- Ada. Calling Set_Mode will reset this variable, default is for Ada_Only. Must_Check_Configuration : Boolean := False; ! -- Whether the contents of the configuration file must be checked. This is ! -- in general only needed by gprbuild itself, since other applications can ! -- ignore such errors when they don't need to build directly. Calling -- Set_Mode will reset this variable, default is for Ada_Only. function In_Configuration return Boolean; --- 94,102 ---- -- Ada. Calling Set_Mode will reset this variable, default is for Ada_Only. Must_Check_Configuration : Boolean := False; ! -- True when the contents of the configuration file must be checked. This ! -- is in general only needed by gprbuild itself, since other applications ! -- can ignore such errors when they don't need to build directly. Calling -- Set_Mode will reset this variable, default is for Ada_Only. function In_Configuration return Boolean; *************** package Prj is *** 124,129 **** --- 150,162 ---- function Empty_String return Name_Id; -- Return the id for an empty string "" + type Path_Information is record + Name : Path_Name_Type := No_Path; + Display_Name : Path_Name_Type := No_Path; + end record; + + No_Path_Information : constant Path_Information := (No_Path, No_Path); + type Project_Id is new Nat; No_Project : constant Project_Id := 0; -- Id of a Project File *************** package Prj is *** 220,228 **** type Array_Id is new Nat; No_Array : constant Array_Id := 0; type Array_Data is record ! Name : Name_Id := No_Name; ! Value : Array_Element_Id := No_Array_Element; ! Next : Array_Id := No_Array; end record; -- Each Array_Data value represents an array. -- Value is the id of the first element. --- 253,262 ---- type Array_Id is new Nat; No_Array : constant Array_Id := 0; type Array_Data is record ! Name : Name_Id := No_Name; ! Location : Source_Ptr := No_Location; ! Value : Array_Element_Id := No_Array_Element; ! Next : Array_Id := No_Array; end record; -- Each Array_Data value represents an array. -- Value is the id of the first element. *************** package Prj is *** 281,287 **** Language : Language_Index); -- Output the name of a language ! type Header_Num is range 0 .. 6150; -- Size for hash table below. The upper bound is an arbitrary value, the -- value here was chosen after testing to determine a good compromise -- between speed of access and memory usage. --- 315,322 ---- Language : Language_Index); -- Output the name of a language ! Max_Header_Num : constant := 6150; ! type Header_Num is range 0 .. Max_Header_Num; -- Size for hash table below. The upper bound is an arbitrary value, the -- value here was chosen after testing to determine a good compromise -- between speed of access and memory usage. *************** package Prj is *** 291,296 **** --- 326,334 ---- function Hash (Name : Path_Name_Type) return Header_Num; -- Used for computing hash values for names put into above hash table + function Hash (Project : Project_Id) return Header_Num; + -- Used for hash tables where Project_Id is the Key + type Language_Kind is (File_Based, Unit_Based); -- Type for the kind of language. All languages are file based, except Ada -- which is unit based. *************** package Prj is *** 365,377 **** No_Source : constant Source_Id := 0; type Language_Config is record Kind : Language_Kind := File_Based; -- Kind of language. All languages are file based, except Ada which is -- unit based. Naming_Data : Lang_Naming_Data; ! -- The naming data for the languages (prefixs, etc) Compiler_Driver : File_Name_Type := No_File; -- The name of the executable for the compiler of the language --- 403,428 ---- No_Source : constant Source_Id := 0; + type Path_Syntax_Kind is + (Canonical, + -- Unix style + + Host); + -- Host specific syntax, for example on VMS (the default) + type Language_Config is record Kind : Language_Kind := File_Based; -- Kind of language. All languages are file based, except Ada which is -- unit based. Naming_Data : Lang_Naming_Data; ! -- The naming data for the languages (prefixes, etc.) ! ! Include_Compatible_Languages : Name_List_Index := No_Name_List; ! -- The list of languages that are "include compatible" with this ! -- language. A language B (for example "C") is "include compatible" with ! -- a language A (for example "C++") if it is expected that sources of ! -- language A may "include" header files from language B. Compiler_Driver : File_Name_Type := No_File; -- The name of the executable for the compiler of the language *************** package Prj is *** 383,393 **** --- 434,455 ---- -- The list of switches that are required as a minimum to invoke the -- compiler driver. + Path_Syntax : Path_Syntax_Kind := Host; + -- Value may be Canonical (Unix style) or Host (host syntax, for example + -- on VMS for DEC C). + Compilation_PIC_Option : Name_List_Index := No_Name_List; -- The option(s) to compile a source in Position Independent Code for -- shared libraries. Specified in the configuration. When not specified, -- there is no need for such switch. + Object_Generated : Boolean := True; + -- False in no object file is generated + + Objects_Linked : Boolean := True; + -- False if object files are not use to link executables and build + -- libraries. + Runtime_Library_Dir : Name_Id := No_Name; -- Path name of the runtime library directory, if any *************** package Prj is *** 470,476 **** -- Hold the value of attribute Binder'Required_Switches for the language Binder_Prefix : Name_Id := No_Name; ! -- Hold the value of attribute Binder'Prefixthe language Toolchain_Version : Name_Id := No_Name; -- Hold the value of attribute Toolchain_Version for the language --- 532,538 ---- -- Hold the value of attribute Binder'Required_Switches for the language Binder_Prefix : Name_Id := No_Name; ! -- Hold the value of attribute Binder'Prefix for the language Toolchain_Version : Name_Id := No_Name; -- Hold the value of attribute Toolchain_Version for the language *************** package Prj is *** 478,525 **** Toolchain_Description : Name_Id := No_Name; -- Hold the value of attribute Toolchain_Description for the language - PIC_Option : Name_Id := No_Name; - -- Hold the value of attribute Compiler'PIC_Option for the language - - Objects_Generated : Boolean := True; - -- Indicates if objects are generated for the language - end record; -- Record describing the configuration of a language No_Language_Config : constant Language_Config := ! (Kind => File_Based, ! Naming_Data => No_Lang_Naming_Data, ! Compiler_Driver => No_File, ! Compiler_Driver_Path => null, ! Compiler_Required_Switches => No_Name_List, ! Compilation_PIC_Option => No_Name_List, ! Runtime_Library_Dir => No_Name, ! Mapping_File_Switches => No_Name_List, ! Mapping_Spec_Suffix => No_File, ! Mapping_Body_Suffix => No_File, ! Config_File_Switches => No_Name_List, ! Dependency_Kind => Makefile, ! Dependency_Option => No_Name_List, ! Compute_Dependency => No_Name_List, ! Include_Option => No_Name_List, ! Include_Path => No_Name, ! Include_Path_File => No_Name, ! Objects_Path => No_Name, ! Objects_Path_File => No_Name, ! Config_Body => No_Name, ! Config_Spec => No_Name, ! Config_Body_Pattern => No_Name, ! Config_Spec_Pattern => No_Name, ! Config_File_Unique => False, ! Binder_Driver => No_File, ! Binder_Driver_Path => No_Path, ! Binder_Required_Switches => No_Name_List, ! Binder_Prefix => No_Name, ! Toolchain_Version => No_Name, ! Toolchain_Description => No_Name, ! PIC_Option => No_Name, ! Objects_Generated => True); type Language_Data is record Name : Name_Id := No_Name; --- 540,583 ---- Toolchain_Description : Name_Id := No_Name; -- Hold the value of attribute Toolchain_Description for the language end record; -- Record describing the configuration of a language No_Language_Config : constant Language_Config := ! (Kind => File_Based, ! Naming_Data => No_Lang_Naming_Data, ! Include_Compatible_Languages => No_Name_List, ! Compiler_Driver => No_File, ! Compiler_Driver_Path => null, ! Compiler_Required_Switches => No_Name_List, ! Path_Syntax => Canonical, ! Compilation_PIC_Option => No_Name_List, ! Object_Generated => True, ! Objects_Linked => True, ! Runtime_Library_Dir => No_Name, ! Mapping_File_Switches => No_Name_List, ! Mapping_Spec_Suffix => No_File, ! Mapping_Body_Suffix => No_File, ! Config_File_Switches => No_Name_List, ! Dependency_Kind => Makefile, ! Dependency_Option => No_Name_List, ! Compute_Dependency => No_Name_List, ! Include_Option => No_Name_List, ! Include_Path => No_Name, ! Include_Path_File => No_Name, ! Objects_Path => No_Name, ! Objects_Path_File => No_Name, ! Config_Body => No_Name, ! Config_Spec => No_Name, ! Config_Body_Pattern => No_Name, ! Config_Spec_Pattern => No_Name, ! Config_File_Unique => False, ! Binder_Driver => No_File, ! Binder_Driver_Path => No_Path, ! Binder_Required_Switches => No_Name_List, ! Binder_Prefix => No_Name, ! Toolchain_Version => No_Name, ! Toolchain_Description => No_Name); type Language_Data is record Name : Name_Id := No_Name; *************** package Prj is *** 580,585 **** --- 638,653 ---- Lang_Kind : Language_Kind := File_Based; -- Kind of the language + Compiled : Boolean := True; + -- False when there is no compiler for the language + + In_Interfaces : Boolean := True; + -- False when the source is not included in interfaces, when attribute + -- Interfaces is declared. + + Declared_In_Interfaces : Boolean := False; + -- True when source is declared in attribute Interfaces + Alternate_Languages : Alternate_Language_Id := No_Alternate_Language; -- List of languages a header file may also be, in addition of -- language Language_Name. *************** package Prj is *** 616,626 **** Display_File : File_Name_Type := No_File; -- File name of the source, for display purposes ! Path : Path_Name_Type := No_Path; ! -- Canonical path name of the source ! ! Display_Path : Path_Name_Type := No_Path; ! -- Path name of the source, for display purposes Source_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Time stamp of the source file --- 684,691 ---- Display_File : File_Name_Type := No_File; -- File name of the source, for display purposes ! Path : Path_Information := No_Path_Information; ! -- Path name of the source Source_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Time stamp of the source file *************** package Prj is *** 631,636 **** --- 696,705 ---- Object_Exists : Boolean := True; -- True if an object file exists + Object_Linked : Boolean := True; + -- False if the object file is not use to link executables or included + -- in libraries. + Object : File_Name_Type := No_File; -- File name of the object file *************** package Prj is *** 640,718 **** Object_Path : Path_Name_Type := No_Path; -- Object path of the real object file ! Object_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Object file time stamp ! Dep_Name : File_Name_Type := No_File; -- Dependency file simple name ! Current_Dep_Path : Path_Name_Type := No_Path; -- Path name of an existing dependency file ! Dep_Path : Path_Name_Type := No_Path; -- Path name of the real dependency file ! Dep_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Dependency file time stamp ! Switches : File_Name_Type := No_File; -- File name of the switches file ! Switches_Path : Path_Name_Type := No_Path; -- Path name of the switches file ! Switches_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Switches file time stamp ! Naming_Exception : Boolean := False; -- True if the source has an exceptional name ! Next_In_Sources : Source_Id := No_Source; -- Link to another source in the project tree ! Next_In_Project : Source_Id := No_Source; -- Link to another source in the project ! Next_In_Lang : Source_Id := No_Source; -- Link to another source of the same language end record; No_Source_Data : constant Source_Data := ! (Project => No_Project, ! Language_Name => No_Name, ! Language => No_Language_Index, ! Lang_Kind => File_Based, ! Alternate_Languages => No_Alternate_Language, ! Kind => Spec, ! Dependency => None, ! Other_Part => No_Source, ! Unit => No_Name, ! Index => 0, ! Locally_Removed => False, ! Get_Object => False, ! Replaced_By => No_Source, ! File => No_File, ! Display_File => No_File, ! Path => No_Path, ! Display_Path => No_Path, ! Source_TS => Empty_Time_Stamp, ! Object_Project => No_Project, ! Object_Exists => True, ! Object => No_File, ! Current_Object_Path => No_Path, ! Object_Path => No_Path, ! Object_TS => Empty_Time_Stamp, ! Dep_Name => No_File, ! Current_Dep_Path => No_Path, ! Dep_Path => No_Path, ! Dep_TS => Empty_Time_Stamp, ! Switches => No_File, ! Switches_Path => No_Path, ! Switches_TS => Empty_Time_Stamp, ! Naming_Exception => False, ! Next_In_Sources => No_Source, ! Next_In_Project => No_Source, ! Next_In_Lang => No_Source); package Source_Data_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Source_Data, --- 709,790 ---- Object_Path : Path_Name_Type := No_Path; -- Object path of the real object file ! Object_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Object file time stamp ! Dep_Name : File_Name_Type := No_File; -- Dependency file simple name ! Current_Dep_Path : Path_Name_Type := No_Path; -- Path name of an existing dependency file ! Dep_Path : Path_Name_Type := No_Path; -- Path name of the real dependency file ! Dep_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Dependency file time stamp ! Switches : File_Name_Type := No_File; -- File name of the switches file ! Switches_Path : Path_Name_Type := No_Path; -- Path name of the switches file ! Switches_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Switches file time stamp ! Naming_Exception : Boolean := False; -- True if the source has an exceptional name ! Next_In_Sources : Source_Id := No_Source; -- Link to another source in the project tree ! Next_In_Project : Source_Id := No_Source; -- Link to another source in the project ! Next_In_Lang : Source_Id := No_Source; -- Link to another source of the same language end record; No_Source_Data : constant Source_Data := ! (Project => No_Project, ! Language_Name => No_Name, ! Language => No_Language_Index, ! Lang_Kind => File_Based, ! Compiled => True, ! In_Interfaces => True, ! Declared_In_Interfaces => False, ! Alternate_Languages => No_Alternate_Language, ! Kind => Spec, ! Dependency => None, ! Other_Part => No_Source, ! Unit => No_Name, ! Index => 0, ! Locally_Removed => False, ! Get_Object => False, ! Replaced_By => No_Source, ! File => No_File, ! Display_File => No_File, ! Path => No_Path_Information, ! Source_TS => Empty_Time_Stamp, ! Object_Project => No_Project, ! Object_Exists => True, ! Object_Linked => True, ! Object => No_File, ! Current_Object_Path => No_Path, ! Object_Path => No_Path, ! Object_TS => Empty_Time_Stamp, ! Dep_Name => No_File, ! Current_Dep_Path => No_Path, ! Dep_Path => No_Path, ! Dep_TS => Empty_Time_Stamp, ! Switches => No_File, ! Switches_Path => No_Path, ! Switches_TS => Empty_Time_Stamp, ! Naming_Exception => False, ! Next_In_Sources => No_Source, ! Next_In_Project => No_Source, ! Next_In_Lang => No_Source); package Source_Data_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Source_Data, *************** package Prj is *** 771,934 **** -- Similar to 'Value (but avoid use of this attribute in compiler) -- Raises Constraint_Error if not a Casing_Type image. - -- Declarations for gprmake: - - First_Language_Index : constant Language_Index := 1; - First_Language_Indexes_Last : constant Language_Index := 5; - - Ada_Language_Index : constant Language_Index := - First_Language_Index; - C_Language_Index : constant Language_Index := - Ada_Language_Index + 1; - C_Plus_Plus_Language_Index : constant Language_Index := - C_Language_Index + 1; - - Last_Language_Index : Language_Index := No_Language_Index; - - subtype First_Language_Indexes is Language_Index - range First_Language_Index .. First_Language_Indexes_Last; - - package Language_Indexes is new System.HTable.Simple_HTable - (Header_Num => Header_Num, - Element => Language_Index, - No_Element => No_Language_Index, - Key => Name_Id, - Hash => Hash, - Equal => "="); - -- Mapping of language names to language indexes - - package Language_Names is new Table.Table - (Table_Component_Type => Name_Id, - Table_Index_Type => Language_Index, - Table_Low_Bound => 1, - Table_Initial => 4, - Table_Increment => 100, - Table_Name => "Prj.Language_Names"); - -- The table for the name of programming languages - - procedure Add_Language_Name (Name : Name_Id); - - procedure Display_Language_Name (Language : Language_Index); - - type Languages_In_Project is array (First_Language_Indexes) of Boolean; - -- Set of supported languages used in a project - - No_Languages : constant Languages_In_Project := (others => False); - -- No supported languages are used - - type Supp_Language_Index is new Nat; - No_Supp_Language_Index : constant Supp_Language_Index := 0; - - type Supp_Language is record - Index : Language_Index := No_Language_Index; - Present : Boolean := False; - Next : Supp_Language_Index := No_Supp_Language_Index; - end record; - - package Present_Language_Table is new GNAT.Dynamic_Tables - (Table_Component_Type => Supp_Language, - Table_Index_Type => Supp_Language_Index, - Table_Low_Bound => 1, - Table_Initial => 4, - Table_Increment => 100); - -- The table for the presence of languages with an index that is outside - -- of First_Language_Indexes. - - type Impl_Suffix_Array is array (First_Language_Indexes) of File_Name_Type; - -- Suffixes for the non spec sources of the different supported languages - -- in a project. - - No_Impl_Suffixes : constant Impl_Suffix_Array := (others => No_File); - -- A default value for the non spec source suffixes - - type Supp_Suffix is record - Index : Language_Index := No_Language_Index; - Suffix : File_Name_Type := No_File; - Next : Supp_Language_Index := No_Supp_Language_Index; - end record; - - package Supp_Suffix_Table is new GNAT.Dynamic_Tables - (Table_Component_Type => Supp_Suffix, - Table_Index_Type => Supp_Language_Index, - Table_Low_Bound => 1, - Table_Initial => 4, - Table_Increment => 100); - -- The table for the presence of languages with an index that is outside - -- of First_Language_Indexes. - - type Lang_Kind is (GNU, Other); - - type Language_Processing_Data is record - Compiler_Drivers : Name_List_Index := No_Name_List; - Compiler_Paths : Name_Id := No_Name; - Compiler_Kinds : Lang_Kind := GNU; - Dependency_Options : Name_List_Index := No_Name_List; - Compute_Dependencies : Name_List_Index := No_Name_List; - Include_Options : Name_List_Index := No_Name_List; - Binder_Drivers : Name_Id := No_Name; - Binder_Driver_Paths : Name_Id := No_Name; - end record; - - Default_Language_Processing_Data : - constant Language_Processing_Data := - (Compiler_Drivers => No_Name_List, - Compiler_Paths => No_Name, - Compiler_Kinds => GNU, - Dependency_Options => No_Name_List, - Compute_Dependencies => No_Name_List, - Include_Options => No_Name_List, - Binder_Drivers => No_Name, - Binder_Driver_Paths => No_Name); - - type First_Language_Processing_Data is - array (First_Language_Indexes) of Language_Processing_Data; - - Default_First_Language_Processing_Data : - constant First_Language_Processing_Data := - (others => Default_Language_Processing_Data); - - type Supp_Language_Data is record - Index : Language_Index := No_Language_Index; - Data : Language_Processing_Data := Default_Language_Processing_Data; - Next : Supp_Language_Index := No_Supp_Language_Index; - end record; - - package Supp_Language_Table is new GNAT.Dynamic_Tables - (Table_Component_Type => Supp_Language_Data, - Table_Index_Type => Supp_Language_Index, - Table_Low_Bound => 1, - Table_Initial => 4, - Table_Increment => 100); - -- The table for language data when there are more languages than - -- in First_Language_Indexes. - - type Other_Source_Id is new Nat; - No_Other_Source : constant Other_Source_Id := 0; - - type Other_Source is record - Language : Language_Index; -- language of the source - File_Name : File_Name_Type; -- source file simple name - Path_Name : Path_Name_Type; -- source full path name - Source_TS : Time_Stamp_Type; -- source file time stamp - Object_Name : File_Name_Type; -- object file simple name - Object_Path : Path_Name_Type; -- object full path name - Object_TS : Time_Stamp_Type; -- object file time stamp - Dep_Name : File_Name_Type; -- dependency file simple name - Dep_Path : Path_Name_Type; -- dependency full path name - Dep_TS : Time_Stamp_Type; -- dependency file time stamp - Naming_Exception : Boolean := False; -- True if a naming exception - Next : Other_Source_Id := No_Other_Source; - end record; - -- Data for a source in a language other than Ada - - package Other_Source_Table is new GNAT.Dynamic_Tables - (Table_Component_Type => Other_Source, - Table_Index_Type => Other_Source_Id, - Table_Low_Bound => 1, - Table_Initial => 200, - Table_Increment => 100); - -- The table for sources of languages other than Ada - -- The following record contains data for a naming scheme type Naming_Data is record --- 843,848 ---- *************** package Prj is *** 977,986 **** -- An associative array listing body file names that do not have the -- body suffix. Not used by Ada. Indexed by programming language name. - -- For gprmake: - - Impl_Suffixes : Impl_Suffix_Array := No_Impl_Suffixes; - Supp_Suffixes : Supp_Language_Index := No_Supp_Language_Index; end record; function Spec_Suffix_Of --- 891,896 ---- *************** package Prj is *** 1061,1175 **** -- The table that contains the lists of project files type Project_Configuration is record ! Run_Path_Option : Name_List_Index := No_Name_List; ! -- The option to use when linking to specify the path where to look ! -- for libraries. ! Executable_Suffix : Name_Id := No_Name; ! -- The suffix of executables, when specified in the configuration or ! -- in package Builder of the main project. When this is not ! -- specified, the executable suffix is the default for the platform. ! -- Linking ! Linker : Path_Name_Type := No_Path; ! -- Path name of the linker driver; specified in the configuration ! -- or in the package Builder of the main project. ! Minimum_Linker_Options : Name_List_Index := No_Name_List; ! -- The minimum options for the linker driver; specified in the ! -- configuration. ! Linker_Executable_Option : Name_List_Index := No_Name_List; ! -- The option(s) to indicate the name of the executable in the ! -- linker command. Specified in the configuration. When not ! -- specified, default to -o . ! Linker_Lib_Dir_Option : Name_Id := No_Name; ! -- The option to specify where to find a library for linking. ! -- Specified in the configuration. When not specified, defaults to ! -- "-L". ! Linker_Lib_Name_Option : Name_Id := No_Name; ! -- The option to specify the name of a library for linking. ! -- Specified in the configuration. When not specified, defaults to ! -- "-l". ! -- Libraries ! Library_Builder : Path_Name_Type := No_Path; ! -- The executable to build library. Specified in the configuration. ! Lib_Support : Library_Support := None; ! -- The level of library support. Specified in the configuration. ! -- Support is none, static libraries only or both static and shared ! -- libraries. ! -- Archives ! Archive_Builder : Name_List_Index := No_Name_List; ! -- The name of the executable to build archives, with the minimum ! -- switches. Specified in the configuration. ! Archive_Indexer : Name_List_Index := No_Name_List; ! -- The name of the executable to index archives, with the minimum ! -- switches. Specified in the configuration. ! Archive_Suffix : File_Name_Type := No_File; ! -- The suffix of archives. Specified in the configuration. When not ! -- specified, defaults to ".a". ! Lib_Partial_Linker : Name_List_Index := No_Name_List; ! -- Shared libraries ! Shared_Lib_Prefix : File_Name_Type := No_File; ! -- Part of a shared library file name that precedes the name of the ! -- library. Specified in the configuration. When not specified, ! -- defaults to "lib". ! Shared_Lib_Suffix : File_Name_Type := No_File; ! -- Suffix of shared libraries, after the library name in the shared ! -- library name. Specified in the configuration. When not specified, ! -- default to ".so". ! Shared_Lib_Min_Options : Name_List_Index := No_Name_List; ! -- ! Lib_Version_Options : Name_List_Index := No_Name_List; ! -- ! Symbolic_Link_Supported : Boolean := False; ! -- ! Lib_Maj_Min_Id_Supported : Boolean := False; ! -- ! Auto_Init_Supported : Boolean := False; ! -- end record; Default_Project_Config : constant Project_Configuration := ! (Run_Path_Option => No_Name_List, ! Executable_Suffix => No_Name, ! Linker => No_Path, ! Minimum_Linker_Options => No_Name_List, ! Linker_Executable_Option => No_Name_List, ! Linker_Lib_Dir_Option => No_Name, ! Linker_Lib_Name_Option => No_Name, ! Library_Builder => No_Path, ! Lib_Support => None, ! Archive_Builder => No_Name_List, ! Archive_Indexer => No_Name_List, ! Archive_Suffix => No_File, ! Lib_Partial_Linker => No_Name_List, ! Shared_Lib_Prefix => No_File, ! Shared_Lib_Suffix => No_File, ! Shared_Lib_Min_Options => No_Name_List, ! Lib_Version_Options => No_Name_List, ! Symbolic_Link_Supported => False, ! Lib_Maj_Min_Id_Supported => False, ! Auto_Init_Supported => False); -- The following record describes a project file representation --- 971,1095 ---- -- The table that contains the lists of project files type Project_Configuration is record ! Run_Path_Option : Name_List_Index := No_Name_List; ! -- The option to use when linking to specify the path where to look for ! -- libraries. ! Executable_Suffix : Name_Id := No_Name; ! -- The suffix of executables, when specified in the configuration or in ! -- package Builder of the main project. When this is not specified, the ! -- executable suffix is the default for the platform. ! -- Linking ! Linker : Path_Name_Type := No_Path; ! -- Path name of the linker driver. Specified in the configuration or in ! -- the package Builder of the main project. ! Map_File_Option : Name_Id := No_Name; ! -- Option to use when invoking the linker to build a map file ! Minimum_Linker_Options : Name_List_Index := No_Name_List; ! -- The minimum options for the linker driver. Specified in the ! -- configuration. ! Linker_Executable_Option : Name_List_Index := No_Name_List; ! -- The option(s) to indicate the name of the executable in the linker ! -- command. Specified in the configuration. When not specified, default ! -- to -o . ! Linker_Lib_Dir_Option : Name_Id := No_Name; ! -- The option to specify where to find a library for linking. Specified ! -- in the configuration. When not specified, defaults to "-L". ! Linker_Lib_Name_Option : Name_Id := No_Name; ! -- The option to specify the name of a library for linking. Specified in ! -- the configuration. When not specified, defaults to "-l". ! -- Libraries ! Library_Builder : Path_Name_Type := No_Path; ! -- The executable to build library (specified in the configuration) ! Lib_Support : Library_Support := None; ! -- The level of library support. Specified in the configuration. Support ! -- is none, static libraries only or both static and shared libraries. ! Archive_Builder : Name_List_Index := No_Name_List; ! -- The name of the executable to build archives, with the minimum ! -- switches. Specified in the configuration. ! Archive_Builder_Append_Option : Name_List_Index := No_Name_List; ! -- The options to append object files to an archive ! Archive_Indexer : Name_List_Index := No_Name_List; ! -- The name of the executable to index archives, with the minimum ! -- switches. Specified in the configuration. ! Archive_Suffix : File_Name_Type := No_File; ! -- The suffix of archives. Specified in the configuration. When not ! -- specified, defaults to ".a". ! Lib_Partial_Linker : Name_List_Index := No_Name_List; ! -- Shared libraries ! Shared_Lib_Driver : File_Name_Type := No_File; ! -- The driver to link shared libraries. Set with attribute Library_GCC. ! -- Default to gcc. ! Shared_Lib_Prefix : File_Name_Type := No_File; ! -- Part of a shared library file name that precedes the name of the ! -- library. Specified in the configuration. When not specified, defaults ! -- to "lib". ! Shared_Lib_Suffix : File_Name_Type := No_File; ! -- Suffix of shared libraries, after the library name in the shared ! -- library name. Specified in the configuration. When not specified, ! -- default to ".so". ! Shared_Lib_Min_Options : Name_List_Index := No_Name_List; ! -- The minimum options to use when building a shared library ! Lib_Version_Options : Name_List_Index := No_Name_List; ! -- The options to use to specify a library version ! Symbolic_Link_Supported : Boolean := False; ! -- True if the platform supports symbolic link files ! ! Lib_Maj_Min_Id_Supported : Boolean := False; ! -- True if platform supports library major and minor options, such as ! -- libname.so -> libname.so.2 -> libname.so.2.4 ! ! Auto_Init_Supported : Boolean := False; ! -- True if automatic initialisation is supported for shared stand-alone ! -- libraries. end record; Default_Project_Config : constant Project_Configuration := ! (Run_Path_Option => No_Name_List, ! Executable_Suffix => No_Name, ! Linker => No_Path, ! Map_File_Option => No_Name, ! Minimum_Linker_Options => No_Name_List, ! Linker_Executable_Option => No_Name_List, ! Linker_Lib_Dir_Option => No_Name, ! Linker_Lib_Name_Option => No_Name, ! Library_Builder => No_Path, ! Lib_Support => None, ! Archive_Builder => No_Name_List, ! Archive_Builder_Append_Option => No_Name_List, ! Archive_Indexer => No_Name_List, ! Archive_Suffix => No_File, ! Lib_Partial_Linker => No_Name_List, ! Shared_Lib_Driver => No_File, ! Shared_Lib_Prefix => No_File, ! Shared_Lib_Suffix => No_File, ! Shared_Lib_Min_Options => No_Name_List, ! Lib_Version_Options => No_Name_List, ! Symbolic_Link_Supported => False, ! Lib_Maj_Min_Id_Supported => False, ! Auto_Init_Supported => False); -- The following record describes a project file representation *************** package Prj is *** 1178,1195 **** -- separator. type Project_Data is record - Externally_Built : Boolean := False; - -- True if the project is externally built. In such case, the Project - -- Manager will not modify anything in this project. ! Languages : Name_List_Index := No_Name_List; ! -- The list of languages of the sources of this project ! ! Config : Project_Configuration; ! ! First_Referred_By : Project_Id := No_Project; ! -- The project, if any, that was the first to be known as importing or ! -- extending this project Name : Name_Id := No_Name; -- The name of the project --- 1098,1107 ---- -- separator. type Project_Data is record ! ------------- ! -- General -- ! ------------- Name : Name_Id := No_Name; -- The name of the project *************** package Prj is *** 1197,1208 **** Display_Name : Name_Id := No_Name; -- The name of the project with the spelling of its declaration ! Path_Name : Path_Name_Type := No_Path; ! -- The path name of the project file ! Display_Path_Name : Path_Name_Type := No_Path; ! -- The path name used for display purposes. May be different from ! -- Path_Name for platforms where the file names are case-insensitive. Virtual : Boolean := False; -- True for virtual extending projects --- 1109,1125 ---- Display_Name : Name_Id := No_Name; -- The name of the project with the spelling of its declaration ! Qualifier : Project_Qualifier := Unspecified; ! -- The eventual qualifier for this project ! Externally_Built : Boolean := False; ! -- True if the project is externally built. In such case, the Project ! -- Manager will not modify anything in this project. ! ! Config : Project_Configuration; ! ! Path : Path_Information := No_Path_Information; ! -- The path name of the project file Virtual : Boolean := False; -- True for virtual extending projects *************** package Prj is *** 1210,1271 **** Location : Source_Ptr := No_Location; -- The location in the project file source of the reserved word project Mains : String_List_Id := Nil_String; -- List of mains specified by attribute Main ! Directory : Path_Name_Type := No_Path; ! -- Path name of the directory where the project file resides ! Display_Directory : Path_Name_Type := No_Path; ! -- The path name of the project directory, for display purposes. May be ! -- different from Directory for platforms where the file names are ! -- case-insensitive. Dir_Path : String_Access; ! -- Same as Directory, but as an access to String Library : Boolean := False; -- True if this is a library project ! Library_Dir : Path_Name_Type := No_Path; -- If a library project, path name of the directory where the library -- resides. - Display_Library_Dir : Path_Name_Type := No_Path; - -- The path name of the library directory, for display purposes. May be - -- different from Library_Dir for platforms where the file names are - -- case-insensitive. - Library_TS : Time_Stamp_Type := Empty_Time_Stamp; -- The timestamp of a library file in a library project ! Library_Src_Dir : Path_Name_Type := No_Path; -- If a Stand-Alone Library project, path name of the directory where -- the sources of the interfaces of the library are copied. By default, -- if attribute Library_Src_Dir is not specified, sources of the -- interfaces are not copied anywhere. ! Display_Library_Src_Dir : Path_Name_Type := No_Path; ! -- The path name of the library source directory, for display purposes. ! -- May be different from Library_Src_Dir for platforms where the file ! -- names are case-insensitive. ! ! Library_ALI_Dir : Path_Name_Type := No_Path; -- In a library project, path name of the directory where the ALI files -- are copied. If attribute Library_ALI_Dir is not specified, ALI files -- are copied in the Library_Dir. - Display_Library_ALI_Dir : Path_Name_Type := No_Path; - -- The path name of the library ALI directory, for display purposes. May - -- be different from Library_ALI_Dir for platforms where the file names - -- are case-insensitive. - - Library_Name : Name_Id := No_Name; - -- If a library project, name of the library - - Library_Kind : Lib_Kind := Static; - -- If a library project, kind of library - Lib_Internal_Name : Name_Id := No_Name; -- If a library project, internal name store inside the library --- 1127,1230 ---- Location : Source_Ptr := No_Location; -- The location in the project file source of the reserved word project + Naming : Naming_Data := Standard_Naming_Data; + -- The naming scheme of this project file + + --------------- + -- Languages -- + --------------- + + Languages : Name_List_Index := No_Name_List; + -- The list of languages of the sources of this project + + Include_Language : Language_Index := No_Language_Index; + + First_Language_Processing : Language_Index := No_Language_Index; + -- First index of the language data in the project + + Unit_Based_Language_Name : Name_Id := No_Name; + Unit_Based_Language_Index : Language_Index := No_Language_Index; + -- The name and index, if any, of the unit-based language of some + -- sources of the project. There may be only one unit-based language + -- in one project. + + -------------- + -- Projects -- + -------------- + + First_Referred_By : Project_Id := No_Project; + -- The project, if any, that was the first to be known as importing or + -- extending this project + Mains : String_List_Id := Nil_String; -- List of mains specified by attribute Main ! Extends : Project_Id := No_Project; ! -- The reference of the project file, if any, that this project file ! -- extends. ! Extended_By : Project_Id := No_Project; ! -- The reference of the project file, if any, that extends this project ! -- file. ! ! Decl : Declarations := No_Declarations; ! -- The declarations (variables, attributes and packages) of this project ! -- file. ! ! Imported_Projects : Project_List := Empty_Project_List; ! -- The list of all directly imported projects, if any ! ! All_Imported_Projects : Project_List := Empty_Project_List; ! -- The list of all projects imported directly or indirectly, if any ! ! ----------------- ! -- Directories -- ! ----------------- ! ! Directory : Path_Information := No_Path_Information; ! -- Path name of the directory where the project file resides Dir_Path : String_Access; ! -- Same as Directory.Name, but as an access to String ! ! Object_Directory : Path_Information := No_Path_Information; ! -- The path name of the object directory of this project file ! ! Exec_Directory : Path_Information := No_Path_Information; ! -- The path name of the exec directory of this project file. Default is ! -- equal to Object_Directory. ! ! ------------- ! -- Library -- ! ------------- Library : Boolean := False; -- True if this is a library project ! Library_Name : Name_Id := No_Name; ! -- If a library project, name of the library ! ! Library_Kind : Lib_Kind := Static; ! -- If a library project, kind of library ! ! Library_Dir : Path_Information := No_Path_Information; -- If a library project, path name of the directory where the library -- resides. Library_TS : Time_Stamp_Type := Empty_Time_Stamp; -- The timestamp of a library file in a library project ! Library_Src_Dir : Path_Information := No_Path_Information; -- If a Stand-Alone Library project, path name of the directory where -- the sources of the interfaces of the library are copied. By default, -- if attribute Library_Src_Dir is not specified, sources of the -- interfaces are not copied anywhere. ! Library_ALI_Dir : Path_Information := No_Path_Information; -- In a library project, path name of the directory where the ALI files -- are copied. If attribute Library_ALI_Dir is not specified, ALI files -- are copied in the Library_Dir. Lib_Internal_Name : Name_Id := No_Name; -- If a library project, internal name store inside the library *************** package Prj is *** 1280,1314 **** -- For non static Stand-Alone Library Project Files, indicate if -- the library initialisation should be automatic. - Libgnarl_Needed : Yes_No_Unknown := Unknown; - -- Set to True when libgnarl is needed to link - Symbol_Data : Symbol_Record := No_Symbols; -- Symbol file name, reference symbol file name, symbol policy ! Ada_Sources : String_List_Id := Nil_String; ! -- The list of all the Ada source file names (gnatmake only). ! Sources : String_List_Id := Nil_String; ! -- Identical to Ada_Sources. For upward compatibility of GPS. First_Source : Source_Id := No_Source; Last_Source : Source_Id := No_Source; -- Head and tail of the list of sources ! Unit_Based_Language_Name : Name_Id := No_Name; ! Unit_Based_Language_Index : Language_Index := No_Language_Index; ! -- The name and index, if any, of the unit-based language of some ! -- sources of the project. There may be only one unit-based language ! -- in one project. Imported_Directories_Switches : Argument_List_Access := null; -- List of the source search switches (-I) to be used when -- compiling. Include_Path : String_Access := null; ! -- Value of the environment variable to indicate the source search path, ! -- instead of a list of switches (Imported_Directories_Switches). Include_Path_File : Path_Name_Type := No_Path; -- The path name of the of the source search directory file --- 1239,1281 ---- -- For non static Stand-Alone Library Project Files, indicate if -- the library initialisation should be automatic. Symbol_Data : Symbol_Record := No_Symbols; -- Symbol file name, reference symbol file name, symbol policy ! Need_To_Build_Lib : Boolean := False; ! -- Indicates that the library of a Library Project needs to be built or ! -- rebuilt. ! ------------- ! -- Sources -- ! ------------- ! ! Ada_Sources_Present : Boolean := True; ! -- True if there are Ada sources in the project ! ! Other_Sources_Present : Boolean := True; ! -- True if there are non-Ada sources in the project ! ! Ada_Sources : String_List_Id := Nil_String; ! -- The list of all the Ada source file names (gnatmake only) First_Source : Source_Id := No_Source; Last_Source : Source_Id := No_Source; -- Head and tail of the list of sources ! Interfaces_Defined : Boolean := False; ! -- True if attribute Interfaces is declared for the project or any ! -- project it extends. Imported_Directories_Switches : Argument_List_Access := null; -- List of the source search switches (-I) to be used when -- compiling. Include_Path : String_Access := null; ! -- The search source path for the project. Used as the value for an ! -- environment variable, specified by attribute Include_Path ! -- (). The names of the environment variables are in component ! -- Include_Path of the records Language_Config. Include_Path_File : Path_Name_Type := No_Path; -- The path name of the of the source search directory file *************** package Prj is *** 1316,1323 **** Include_Data_Set : Boolean := False; -- Set True when Imported_Directories_Switches or Include_Path are set - Include_Language : Language_Index := No_Language_Index; - Source_Dirs : String_List_Id := Nil_String; -- The list of all the source directories --- 1283,1288 ---- *************** package Prj is *** 1326,1382 **** -- the ordering of the source subdirs depend on the OS. If True, -- duplicate file names in the same project file are allowed. - Object_Directory : Path_Name_Type := No_Path; - -- The path name of the object directory of this project file - - Display_Object_Dir : Path_Name_Type := No_Path; - -- The path name of the object directory, for display purposes. May be - -- different from Object_Directory for platforms where the file names - -- are case-insensitive. - - Exec_Directory : Path_Name_Type := No_Path; - -- The path name of the exec directory of this project file. Default is - -- equal to Object_Directory. - - Display_Exec_Dir : Path_Name_Type := No_Path; - -- The path name of the exec directory, for display purposes. May be - -- different from Exec_Directory for platforms where the file names are - -- case-insensitive. - - Extends : Project_Id := No_Project; - -- The reference of the project file, if any, that this project file - -- extends. - - Extended_By : Project_Id := No_Project; - -- The reference of the project file, if any, that extends this project - -- file. - - Naming : Naming_Data := Standard_Naming_Data; - -- The naming scheme of this project file - - First_Language_Processing : Language_Index := No_Language_Index; - -- First index of the language data in the project - - Decl : Declarations := No_Declarations; - -- The declarations (variables, attributes and packages) of this project - -- file. - - Imported_Projects : Project_List := Empty_Project_List; - -- The list of all directly imported projects, if any - - All_Imported_Projects : Project_List := Empty_Project_List; - -- The list of all projects imported directly or indirectly, if any - Ada_Include_Path : String_Access := null; ! -- The cached value of ADA_INCLUDE_PATH for this project file. Do not ! -- use this field directly outside of the compiler, use -- Prj.Env.Ada_Include_Path instead. Ada_Objects_Path : String_Access := null; -- The cached value of ADA_OBJECTS_PATH for this project file. Do not -- use this field directly outside of the compiler, use -- Prj.Env.Ada_Objects_Path instead. Objects_Path : String_Access := null; -- The cached value of the object dir path, used during the binding -- phase of gprbuild. --- 1291,1314 ---- -- the ordering of the source subdirs depend on the OS. If True, -- duplicate file names in the same project file are allowed. Ada_Include_Path : String_Access := null; ! -- The cached value of source search path for this project file. Set by ! -- the first call to Prj.Env.Ada_Include_Path for the project. Do not ! -- use this field directly outside of the project manager, use -- Prj.Env.Ada_Include_Path instead. + ------------------- + -- Miscellaneous -- + ------------------- + Ada_Objects_Path : String_Access := null; -- The cached value of ADA_OBJECTS_PATH for this project file. Do not -- use this field directly outside of the compiler, use -- Prj.Env.Ada_Objects_Path instead. + Libgnarl_Needed : Yes_No_Unknown := Unknown; + -- Set to True when libgnarl is needed to link + Objects_Path : String_Access := null; -- The cached value of the object dir path, used during the binding -- phase of gprbuild. *************** package Prj is *** 1396,1411 **** -- An indication that the configuration pragmas file is a temporary file -- that must be deleted at the end. - Linker_Name : File_Name_Type := No_File; - -- Value of attribute Language_Processing'Linker in the project file - - Linker_Path : Path_Name_Type := No_Path; - -- Path of linker when attribute Language_Processing'Linker is specified - - Minimum_Linker_Options : Name_List_Index := No_Name_List; - -- List of options specified in attribute - -- Language_Processing'Minimum_Linker_Options. - Config_Checked : Boolean := False; -- A flag to avoid checking repetitively the configuration pragmas file --- 1328,1333 ---- *************** package Prj is *** 1417,1426 **** -- A flag to mark a project as "visited" to avoid processing the same -- project several time. - Need_To_Build_Lib : Boolean := False; - -- Indicates that the library of a Library Project needs to be built or - -- rebuilt. - Depth : Natural := 0; -- The maximum depth of a project in the project graph. Depth of main -- project is 0. --- 1339,1344 ---- *************** package Prj is *** 1429,1460 **** -- True if there are comments in the project sources that cannot be kept -- in the project tree. - ------------------ - -- For gprmake -- - ------------------ - - Langs : Languages_In_Project := No_Languages; - Supp_Languages : Supp_Language_Index := No_Supp_Language_Index; - -- Indicate the different languages of the source of this project - - Ada_Sources_Present : Boolean := True; - -- True if there are Ada sources in the project - - Other_Sources_Present : Boolean := True; - -- True if there are sources from languages other than Ada in the - -- project. - - First_Other_Source : Other_Source_Id := No_Other_Source; - -- First source of a language other than Ada - - Last_Other_Source : Other_Source_Id := No_Other_Source; - -- Last source of a language other than Ada - - First_Lang_Processing : First_Language_Processing_Data := - Default_First_Language_Processing_Data; - Supp_Language_Processing : Supp_Language_Index := - No_Supp_Language_Index; - -- Language configurations end record; function Empty_Project (Tree : Project_Tree_Ref) return Project_Data; --- 1347,1352 ---- *************** package Prj is *** 1465,1481 **** (Extending : Project_Id; Extended : Project_Id; In_Tree : Project_Tree_Ref) return Boolean; function Is_A_Language (Tree : Project_Tree_Ref; Data : Project_Data; Language_Name : Name_Id) return Boolean; ! -- Whether Language_Name is one of the languages used for the project. ! -- Language_Name must be lower cased. ! ! function There_Are_Ada_Sources ! (In_Tree : Project_Tree_Ref; ! Project : Project_Id) return Boolean; Project_Error : exception; -- Raised by some subprograms in Prj.Attr --- 1357,1370 ---- (Extending : Project_Id; Extended : Project_Id; In_Tree : Project_Tree_Ref) return Boolean; + -- ??? needs comment function Is_A_Language (Tree : Project_Tree_Ref; Data : Project_Data; Language_Name : Name_Id) return Boolean; ! -- Return True when Language_Name (which must be lower case) is one of the ! -- languages used for the project. Project_Error : exception; -- Raised by some subprograms in Prj.Attr *************** package Prj is *** 1488,1504 **** Table_Increment => 100); -- The set of all project files ! type Spec_Or_Body is ! (Specification, Body_Part); type File_Name_Data is record ! Name : File_Name_Type := No_File; ! Index : Int := 0; ! Display_Name : File_Name_Type := No_File; ! Path : Path_Name_Type := No_Path; ! Display_Path : Path_Name_Type := No_Path; ! Project : Project_Id := No_Project; ! Needs_Pragma : Boolean := False; end record; -- File and Path name of a spec or body --- 1377,1391 ---- Table_Increment => 100); -- The set of all project files ! type Spec_Or_Body is (Specification, Body_Part); type File_Name_Data is record ! Name : File_Name_Type := No_File; ! Index : Int := 0; ! Display_Name : File_Name_Type := No_File; ! Path : Path_Information := No_Path_Information; ! Project : Project_Id := No_Project; ! Needs_Pragma : Boolean := False; end record; -- File and Path name of a spec or body *************** package Prj is *** 1577,1589 **** Files_HT : Files_Htable.Instance; Source_Paths_HT : Source_Paths_Htable.Instance; - -- For gprmake: - - Present_Languages : Present_Language_Table.Instance; - Supp_Suffixes : Supp_Suffix_Table.Instance; - Supp_Languages : Supp_Language_Table.Instance; - Other_Sources : Other_Source_Table.Instance; - -- Private part Private_Part : Private_Project_Tree_Data; --- 1464,1469 ---- *************** package Prj is *** 1597,1604 **** -- Use to customize error reporting in Prj.Proc and Prj.Nmsc procedure Expect (The_Token : Token_Type; Token_Image : String); ! -- Check that the current token is The_Token. If it is not, then ! -- output an error message. procedure Initialize (Tree : Project_Tree_Ref); -- This procedure must be called before using any services from the Prj --- 1477,1484 ---- -- Use to customize error reporting in Prj.Proc and Prj.Nmsc procedure Expect (The_Token : Token_Type; Token_Image : String); ! -- Check that the current token is The_Token. If it is not, then output ! -- an error message. procedure Initialize (Tree : Project_Tree_Ref); -- This procedure must be called before using any services from the Prj *************** package Prj is *** 1656,1714 **** (Source_File_Name : File_Name_Type) return File_Name_Type; -- Returns the switches file name corresponding to a source file name - -- For gprmake - - function Body_Suffix_Of - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return String; - -- Returns the suffix of sources of language Language in project In_Project - -- in project tree In_Tree. - - function Is_Present - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return Boolean; - -- Return True when Language is one of the languages used in - -- project In_Project. - - procedure Set - (Language : Language_Index; - Present : Boolean; - In_Project : in out Project_Data; - In_Tree : Project_Tree_Ref); - -- Indicate if Language is or not a language used in project In_Project - - function Language_Processing_Data_Of - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return Language_Processing_Data; - -- Return the Language_Processing_Data for language Language in project - -- In_Project. Return the default when no Language_Processing_Data are - -- defined for the language. - - procedure Set - (Language_Processing : Language_Processing_Data; - For_Language : Language_Index; - In_Project : in out Project_Data; - In_Tree : Project_Tree_Ref); - -- Set the Language_Processing_Data for language Language in project - -- In_Project. - - function Suffix_Of - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return File_Name_Type; - -- Return the suffix for language Language in project In_Project. Return - -- No_Name when no suffix is defined for the language. - - procedure Set - (Suffix : File_Name_Type; - For_Language : Language_Index; - In_Project : in out Project_Data; - In_Tree : Project_Tree_Ref); - -- Set the suffix for language Language in project In_Project - ---------------- -- Temp Files -- ---------------- --- 1536,1541 ---- *************** private *** 1739,1746 **** -- normally forbidden for project names, there cannot be any name clash. Empty_Name : Name_Id; ! -- Name_Id for an empty name (no characters). Initialized by the call ! -- to procedure Initialize. procedure Add_To_Buffer (S : String; --- 1566,1577 ---- -- normally forbidden for project names, there cannot be any name clash. Empty_Name : Name_Id; ! -- Name_Id for an empty name (no characters). Initialized in procedure ! -- Initialize. ! ! Empty_File_Name : File_Name_Type; ! -- Empty File_Name_Type (no characters). Initialized in procedure ! -- Initialize. procedure Add_To_Buffer (S : String; diff -Nrcpad gcc-4.3.3/gcc/ada/raise-gcc.c gcc-4.4.0/gcc/ada/raise-gcc.c *** gcc-4.3.3/gcc/ada/raise-gcc.c Fri Sep 7 19:57:59 2007 --- gcc-4.4.0/gcc/ada/raise-gcc.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** *** 35,40 **** --- 34,40 ---- #ifdef IN_RTS #include "tconfig.h" + #include "tsystem.h" /* In the top-of-tree GCC, tconfig does not include tm.h, but in GCC 3.2 it does. To avoid branching raise.c just for that purpose, we kludge by looking for a symbol always defined by tm.h and if it's not defined, *************** *** 43,49 **** #include "coretypes.h" #include "tm.h" #endif - #include "tsystem.h" #include #include typedef char bool; --- 43,48 ---- *************** db_phases (int phases) *** 362,368 **** context stack and not the actual call chain. The ACTION and TTYPES tables remain unchanged, which allows to search them ! during the propagation phase to determine wether or not the propagated exception is handled somewhere. When it is, we only "jump" up once directly to the context where the handler will be found. Besides, this allows "break exception unhandled" to work also --- 361,367 ---- context stack and not the actual call chain. The ACTION and TTYPES tables remain unchanged, which allows to search them ! during the propagation phase to determine whether or not the propagated exception is handled somewhere. When it is, we only "jump" up once directly to the context where the handler will be found. Besides, this allows "break exception unhandled" to work also *************** db_action_for (action_descriptor *action *** 663,678 **** return; } - /* Search the call_site_table of REGION for an entry appropriate for the ! UW_CONTEXT's ip. If one is found, store the associated landing_pad and ! action_table entry, and set the ACTION kind to unknown for further ! analysis. Otherwise, set the ACTION kind to nothing. There are two variants of this routine, depending on the underlying ! mechanism (dwarf/sjlj), which account for differences in the tables ! organization. ! */ #ifdef __USING_SJLJ_EXCEPTIONS__ --- 662,682 ---- return; } /* Search the call_site_table of REGION for an entry appropriate for the ! UW_CONTEXT's IP. If one is found, store the associated landing_pad ! and action_table entry, and set the ACTION kind to unknown for further ! analysis. Otherwise, set the ACTION kind to nothing. There are two variants of this routine, depending on the underlying ! mechanism (DWARF/SJLJ), which account for differences in the tables. */ ! ! #ifdef __APPLE__ ! /* On MacOS X, versions older than 10.5 don't export _Unwind_GetIPInfo. */ ! #undef HAVE_GETIPINFO ! #if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ >= 1050 ! #define HAVE_GETIPINFO 1 ! #endif ! #endif #ifdef __USING_SJLJ_EXCEPTIONS__ *************** get_call_site_action_for (_Unwind_Contex *** 683,696 **** region_descriptor *region, action_descriptor *action) { ! _Unwind_Ptr call_site ! = _Unwind_GetIP (uw_context) - 1; ! /* Subtract 1 because GetIP returns the actual call_site value + 1. */ /* call_site is a direct index into the call-site table, with two special ! values : -1 for no-action and 0 for "terminate". The latter should never ! show up for Ada. To test for the former, beware that _Unwind_Ptr might be ! unsigned. */ if ((int)call_site < 0) { --- 687,707 ---- region_descriptor *region, action_descriptor *action) { ! int ip_before_insn = 0; ! #ifdef HAVE_GETIPINFO ! _Unwind_Ptr call_site = _Unwind_GetIPInfo (uw_context, &ip_before_insn); ! #else ! _Unwind_Ptr call_site = _Unwind_GetIP (uw_context); ! #endif ! /* Subtract 1 if necessary because GetIPInfo returns the actual call site ! value + 1 in this case. */ ! if (!ip_before_insn) ! call_site--; /* call_site is a direct index into the call-site table, with two special ! values : -1 for no-action and 0 for "terminate". The latter should never ! show up for Ada. To test for the former, beware that _Unwind_Ptr might ! be unsigned. */ if ((int)call_site < 0) { *************** get_call_site_action_for (_Unwind_Contex *** 712,729 **** action->kind = unknown; /* We have a direct index into the call-site table, but this table is ! made of leb128 values, the encoding length of which is variable. We can't merely compute an offset from the index, then, but have to read all the entries before the one of interest. */ ! const unsigned char * p = region->call_site_table; do { p = read_uleb128 (p, &cs_lp); p = read_uleb128 (p, &cs_action); } while (--call_site); - action->landing_pad = cs_lp + 1; if (cs_action) --- 723,739 ---- action->kind = unknown; /* We have a direct index into the call-site table, but this table is ! made of leb128 values, the encoding length of which is variable. We can't merely compute an offset from the index, then, but have to read all the entries before the one of interest. */ ! const unsigned char *p = region->call_site_table; do { p = read_uleb128 (p, &cs_lp); p = read_uleb128 (p, &cs_action); } while (--call_site); action->landing_pad = cs_lp + 1; if (cs_action) *************** get_call_site_action_for (_Unwind_Contex *** 735,763 **** } } ! #else ! /* ! __USING_SJLJ_EXCEPTIONS__ */ static void get_call_site_action_for (_Unwind_Context *uw_context, region_descriptor *region, action_descriptor *action) { ! _Unwind_Ptr ip ! = _Unwind_GetIP (uw_context) - 1; ! /* Subtract 1 because GetIP yields a call return address while we are ! interested in information for the call point. This does not always yield ! the exact call instruction address but always brings the ip back within ! the corresponding region. ! ! ??? When unwinding up from a signal handler triggered by a trap on some ! instruction, we usually have the faulting instruction address here and ! subtracting 1 might get us into the wrong region. */ ! ! const unsigned char * p ! = region->call_site_table; ! /* Unless we are able to determine otherwise ... */ action->kind = nothing; db (DB_CSITE, "\n"); --- 745,772 ---- } } ! #else /* !__USING_SJLJ_EXCEPTIONS__ */ static void get_call_site_action_for (_Unwind_Context *uw_context, region_descriptor *region, action_descriptor *action) { ! const unsigned char *p = region->call_site_table; ! int ip_before_insn = 0; ! #ifdef HAVE_GETIPINFO ! _Unwind_Ptr ip = _Unwind_GetIPInfo (uw_context, &ip_before_insn); ! #else ! _Unwind_Ptr ip = _Unwind_GetIP (uw_context); ! #endif ! /* Subtract 1 if necessary because GetIPInfo yields a call return address ! in this case, while we are interested in information for the call point. ! This does not always yield the exact call instruction address but always ! brings the IP back within the corresponding region. */ ! if (!ip_before_insn) ! ip--; ! /* Unless we are able to determine otherwise... */ action->kind = nothing; db (DB_CSITE, "\n"); *************** get_call_site_action_for (_Unwind_Contex *** 778,784 **** region->base+cs_start, cs_start, cs_len, region->lp_base+cs_lp, cs_lp); ! /* The table is sorted, so if we've passed the ip, stop. */ if (ip < region->base + cs_start) break; --- 787,793 ---- region->base+cs_start, cs_start, cs_len, region->lp_base+cs_lp, cs_lp); ! /* The table is sorted, so if we've passed the IP, stop. */ if (ip < region->base + cs_start) break; *************** get_call_site_action_for (_Unwind_Contex *** 807,817 **** db (DB_CSITE, "---\n"); } ! #endif /* With CHOICE an exception choice representing an "exception - when" argument, and PROPAGATED_EXCEPTION a pointer to the currently propagated ! occurrence, return true iif the latter matches the former, that is, if PROPAGATED_EXCEPTION is caught by the handling code controlled by CHOICE. This takes care of the special Non_Ada_Error case on VMS. */ --- 816,826 ---- db (DB_CSITE, "---\n"); } ! #endif /* __USING_SJLJ_EXCEPTIONS__ */ /* With CHOICE an exception choice representing an "exception - when" argument, and PROPAGATED_EXCEPTION a pointer to the currently propagated ! occurrence, return true if the latter matches the former, that is, if PROPAGATED_EXCEPTION is caught by the handling code controlled by CHOICE. This takes care of the special Non_Ada_Error case on VMS. */ *************** PERSONALITY_FUNCTION (version_arg_t vers *** 1135,1141 **** /* If we are going to install a cleanup context, decrement the cleanup count. This is required in a FORCED_UNWINDing phase (for an unhandled exception), as this is used from the forced unwinding handler in ! Ada.Exceptions.Exception_Propagation to decide wether unwinding should proceed further or Unhandled_Exception_Terminate should be called. */ if (action.kind == cleanup) Adjust_N_Cleanups_For (gnat_exception, -1); --- 1144,1150 ---- /* If we are going to install a cleanup context, decrement the cleanup count. This is required in a FORCED_UNWINDing phase (for an unhandled exception), as this is used from the forced unwinding handler in ! Ada.Exceptions.Exception_Propagation to decide whether unwinding should proceed further or Unhandled_Exception_Terminate should be called. */ if (action.kind == cleanup) Adjust_N_Cleanups_For (gnat_exception, -1); diff -Nrcpad gcc-4.3.3/gcc/ada/raise.c gcc-4.4.0/gcc/ada/raise.c *** gcc-4.3.3/gcc/ada/raise.c Tue Nov 15 13:52:55 2005 --- gcc-4.4.0/gcc/ada/raise.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2005, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * diff -Nrcpad gcc-4.3.3/gcc/ada/raise.h gcc-4.4.0/gcc/ada/raise.h *** gcc-4.3.3/gcc/ada/raise.h Tue Oct 31 18:05:19 2006 --- gcc-4.4.0/gcc/ada/raise.h Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Header File * * * ! * Copyright (C) 1992-2006, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Header File * * * ! * Copyright (C) 1992-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * diff -Nrcpad gcc-4.3.3/gcc/ada/repinfo.adb gcc-4.4.0/gcc/ada/repinfo.adb *** gcc-4.3.3/gcc/ada/repinfo.adb Tue Aug 14 08:46:03 2007 --- gcc-4.4.0/gcc/ada/repinfo.adb Thu Apr 9 23:23:07 2009 *************** *** 6,31 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- --- 6,29 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- ! -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- *************** package body Repinfo is *** 1095,1101 **** -- Bit_And_Expr, for which there is no direct support in uintp. Uint -- values out of the Int range are expected to be seen in such -- expressions only with overflowing byte sizes around, introducing ! -- inherent unreliabilties in computations anyway. ------- -- B -- --- 1093,1099 ---- -- Bit_And_Expr, for which there is no direct support in uintp. Uint -- values out of the Int range are expected to be seen in such -- expressions only with overflowing byte sizes around, introducing ! -- inherent unreliabilities in computations anyway. ------- -- B -- diff -Nrcpad gcc-4.3.3/gcc/ada/repinfo.ads gcc-4.4.0/gcc/ada/repinfo.ads *** gcc-4.3.3/gcc/ada/repinfo.ads Wed Jun 6 10:23:26 2007 --- gcc-4.4.0/gcc/ada/repinfo.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Repinfo is *** 88,94 **** -- which contains the Size (more accurately the Object_SIze) value -- for the type or subtype. ! -- For E_Component and E_Distriminant entities, the Esize (size -- of component) and Component_Bit_Offset fields. Note that gigi -- does not (yet ???) back annotate Normalized_Position/First_Bit. --- 86,92 ---- -- which contains the Size (more accurately the Object_SIze) value -- for the type or subtype. ! -- For E_Component and E_Discriminant entities, the Esize (size -- of component) and Component_Bit_Offset fields. Note that gigi -- does not (yet ???) back annotate Normalized_Position/First_Bit. *************** package Repinfo is *** 156,167 **** Truth_Or_Expr : constant TCode := 19; -- Boolean or 2 Truth_Xor_Expr : constant TCode := 20; -- Boolean xor 2 Truth_Not_Expr : constant TCode := 21; -- Boolean not 1 ! Lt_Expr : constant TCode := 22; -- comparision < 2 ! Le_Expr : constant TCode := 23; -- comparision <= 2 ! Gt_Expr : constant TCode := 24; -- comparision > 2 ! Ge_Expr : constant TCode := 25; -- comparision >= 2 ! Eq_Expr : constant TCode := 26; -- comparision = 2 ! Ne_Expr : constant TCode := 27; -- comparision /= 2 Bit_And_Expr : constant TCode := 28; -- Binary and 2 -- The following entry is used to represent a discriminant value in --- 154,165 ---- Truth_Or_Expr : constant TCode := 19; -- Boolean or 2 Truth_Xor_Expr : constant TCode := 20; -- Boolean xor 2 Truth_Not_Expr : constant TCode := 21; -- Boolean not 1 ! Lt_Expr : constant TCode := 22; -- comparison < 2 ! Le_Expr : constant TCode := 23; -- comparison <= 2 ! Gt_Expr : constant TCode := 24; -- comparison > 2 ! Ge_Expr : constant TCode := 25; -- comparison >= 2 ! Eq_Expr : constant TCode := 26; -- comparison = 2 ! Ne_Expr : constant TCode := 27; -- comparison /= 2 Bit_And_Expr : constant TCode := 28; -- Binary and 2 -- The following entry is used to represent a discriminant value in *************** package Repinfo is *** 188,194 **** -- => Discrim_Val, Op1 => discriminant_number). function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref; ! -- Creates a refrerence to the discriminant whose entity is Discr -------------------------------------------------------- -- Front-End Interface for Dynamic Size/Offset Values -- --- 186,192 ---- -- => Discrim_Val, Op1 => discriminant_number). function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref; ! -- Creates a reference to the discriminant whose entity is Discr -------------------------------------------------------- -- Front-End Interface for Dynamic Size/Offset Values -- *************** package Repinfo is *** 223,229 **** -- In the case of components, if the location of the component is static, -- then all four fields (Component_Bit_Offset, Normalized_Position, Esize, ! -- and Normalized_First_Bit) are set to appropraite values. In the case of -- a non-static component location, Component_Bit_Offset is not used and -- is left set to Unknown. Normalized_Position and Normalized_First_Bit -- are set appropriately. --- 221,227 ---- -- In the case of components, if the location of the component is static, -- then all four fields (Component_Bit_Offset, Normalized_Position, Esize, ! -- and Normalized_First_Bit) are set to appropriate values. In the case of -- a non-static component location, Component_Bit_Offset is not used and -- is left set to Unknown. Normalized_Position and Normalized_First_Bit -- are set appropriately. *************** package Repinfo is *** 258,264 **** -- Create_Dynamic_SO_Ref. The approach is that the front end makes -- the necessary Create_Dynamic_SO_Ref calls to associate the node -- and entity id values and the back end makes Get_Dynamic_SO_Ref ! -- calls to retrive them. -------------------- -- ASIS_Interface -- --- 256,262 ---- -- Create_Dynamic_SO_Ref. The approach is that the front end makes -- the necessary Create_Dynamic_SO_Ref calls to associate the node -- and entity id values and the back end makes Get_Dynamic_SO_Ref ! -- calls to retrieve them. -------------------- -- ASIS_Interface -- diff -Nrcpad gcc-4.3.3/gcc/ada/repinfo.h gcc-4.4.0/gcc/ada/repinfo.h *** gcc-4.3.3/gcc/ada/repinfo.h Tue Nov 15 13:53:22 2005 --- gcc-4.4.0/gcc/ada/repinfo.h Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Header File * * * ! * Copyright (C) 1999-2005 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Header File * * * ! * Copyright (C) 1999-2009 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * diff -Nrcpad gcc-4.3.3/gcc/ada/restrict.adb gcc-4.4.0/gcc/ada/restrict.adb *** gcc-4.3.3/gcc/ada/restrict.adb Thu Dec 13 10:28:48 2007 --- gcc-4.4.0/gcc/ada/restrict.adb Mon Aug 4 08:37:31 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** *** 26,31 **** --- 26,32 ---- with Atree; use Atree; with Casing; use Casing; with Errout; use Errout; + with Debug; use Debug; with Fname; use Fname; with Fname.UF; use Fname.UF; with Lib; use Lib; *************** package body Restrict is *** 51,72 **** -- Local Subprograms -- ----------------------- ! procedure Restriction_Msg (Msg : String; R : String; N : Node_Id); ! -- Output error message at node N with given text, replacing the ! -- '%' in the message with the name of the restriction given as R, ! -- cased according to the current identifier casing. We do not use ! -- the normal insertion mechanism, since this requires an entry ! -- in the Names table, and this table will be locked if we are ! -- generating a message from gigi. function Same_Unit (U1, U2 : Node_Id) return Boolean; -- Returns True iff U1 and U2 represent the same library unit. Used for -- handling of No_Dependence => Unit restriction case. function Suppress_Restriction_Message (N : Node_Id) return Boolean; ! -- N is the node for a possible restriction violation message, but ! -- the message is to be suppressed if this is an internal file and ! -- this file is not the main unit. ------------------- -- Abort_Allowed -- --- 52,71 ---- -- Local Subprograms -- ----------------------- ! procedure Restriction_Msg (R : Restriction_Id; N : Node_Id); ! -- Called if a violation of restriction R at node N is found. This routine ! -- outputs the appropriate message or messages taking care of warning vs ! -- real violation, serious vs non-serious, implicit vs explicit, the second ! -- message giving the profile name if needed, and the location information. function Same_Unit (U1, U2 : Node_Id) return Boolean; -- Returns True iff U1 and U2 represent the same library unit. Used for -- handling of No_Dependence => Unit restriction case. function Suppress_Restriction_Message (N : Node_Id) return Boolean; ! -- N is the node for a possible restriction violation message, but the ! -- message is to be suppressed if this is an internal file and this file is ! -- not the main unit. Returns True if message is to be suppressed. ------------------- -- Abort_Allowed -- *************** package body Restrict is *** 147,153 **** if Name_Len < 5 or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads" and then ! Name_Buffer (Name_Len - 4 .. Name_Len) /= ".adb") then return; end if; --- 146,152 ---- if Name_Len < 5 or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads" and then ! Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb") then return; end if; *************** package body Restrict is *** 171,179 **** end if; end loop; ! -- If not predefied unit, then one special check still remains. ! -- GNAT.Current_Exception is not allowed if we have restriction ! -- No_Exception_Propagation active. else if Name_Buffer (1 .. 8) = "g-curexc" then --- 170,178 ---- end if; end loop; ! -- If not predefined unit, then one special check still ! -- remains. GNAT.Current_Exception is not allowed if we have ! -- restriction No_Exception_Propagation active. else if Name_Buffer (1 .. 8) = "g-curexc" then *************** package body Restrict is *** 193,200 **** N : Node_Id; V : Uint := Uint_Minus_1) is - Rimage : constant String := Restriction_Id'Image (R); - VV : Integer; -- V converted to integer form. If V is greater than Integer'Last, -- it is reset to minus 1 (unknown value). --- 192,197 ---- *************** package body Restrict is *** 310,335 **** and then Restrictions.Value (R) = 0) or else Restrictions.Count (R) > Restrictions.Value (R) then ! Error_Msg_Sloc := Restrictions_Loc (R); ! ! -- If we have a location for the Restrictions pragma, output it ! ! if Error_Msg_Sloc > No_Location ! or else Error_Msg_Sloc = System_Location ! then ! if Restriction_Warnings (R) then ! Restriction_Msg ("|violation of restriction %#?", Rimage, N); ! else ! Restriction_Msg ("|violation of restriction %#", Rimage, N); ! end if; ! ! -- Otherwise we have the case of an implicit restriction ! -- (e.g. a restriction implicitly set by another pragma) ! ! else ! Restriction_Msg ! ("|violation of implicit restriction %", Rimage, N); ! end if; end if; end Check_Restriction; --- 307,313 ---- and then Restrictions.Value (R) = 0) or else Restrictions.Count (R) > Restrictions.Value (R) then ! Restriction_Msg (R, N); end if; end Check_Restriction; *************** package body Restrict is *** 430,435 **** --- 408,425 ---- Restrictions.Set (No_Exception_Propagation)); end No_Exception_Handlers_Set; + ------------------------------------- + -- No_Exception_Propagation_Active -- + ------------------------------------- + + function No_Exception_Propagation_Active return Boolean is + begin + return (No_Run_Time_Mode + or else Configurable_Run_Time_Mode + or else Debug_Flag_Dot_G) + and then Restriction_Active (No_Exception_Propagation); + end No_Exception_Propagation_Active; + ---------------------------------- -- Process_Restriction_Synonyms -- ---------------------------------- *************** package body Restrict is *** 521,563 **** -- Restriction_Msg -- --------------------- ! procedure Restriction_Msg (Msg : String; R : String; N : Node_Id) is ! B : String (1 .. Msg'Length + 2 * R'Length + 1); ! P : Natural := 1; ! begin ! Name_Buffer (1 .. R'Last) := R; ! Name_Len := R'Length; ! Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N)))); ! P := 0; ! for J in Msg'Range loop ! if Msg (J) = '%' then ! P := P + 1; ! B (P) := '`'; ! -- Put characters of image in message, quoting upper case letters ! for J in 1 .. Name_Len loop ! if Name_Buffer (J) in 'A' .. 'Z' then ! P := P + 1; ! B (P) := '''; ! end if; ! P := P + 1; ! B (P) := Name_Buffer (J); ! end loop; ! P := P + 1; ! B (P) := '`'; else ! P := P + 1; ! B (P) := Msg (J); end if; ! end loop; ! Error_Msg_N (B (1 .. P), N); end Restriction_Msg; --------------- --- 511,657 ---- -- Restriction_Msg -- --------------------- ! procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is ! Msg : String (1 .. 100); ! Len : Natural := 0; ! procedure Add_Char (C : Character); ! -- Append given character to Msg, bumping Len ! procedure Add_Str (S : String); ! -- Append given string to Msg, bumping Len appropriately ! procedure Id_Case (S : String; Quotes : Boolean := True); ! -- Given a string S, case it according to current identifier casing, ! -- and store in Error_Msg_String. Then append `~` to the message buffer ! -- to output the string unchanged surrounded in quotes. The quotes are ! -- suppressed if Quotes = False. ! -------------- ! -- Add_Char -- ! -------------- ! procedure Add_Char (C : Character) is ! begin ! Len := Len + 1; ! Msg (Len) := C; ! end Add_Char; ! ------------- ! -- Add_Str -- ! ------------- ! ! procedure Add_Str (S : String) is ! begin ! Msg (Len + 1 .. Len + S'Length) := S; ! Len := Len + S'Length; ! end Add_Str; ! ! ------------- ! -- Id_Case -- ! ------------- ! ! procedure Id_Case (S : String; Quotes : Boolean := True) is ! begin ! Name_Buffer (1 .. S'Last) := S; ! Name_Len := S'Length; ! Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N)))); ! Error_Msg_Strlen := Name_Len; ! Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + if Quotes then + Add_Str ("`~`"); else ! Add_Char ('~'); end if; ! end Id_Case; ! -- Start of processing for Restriction_Msg ! ! begin ! -- Set warning message if warning ! ! if Restriction_Warnings (R) then ! Add_Char ('?'); ! ! -- If real violation (not warning), then mark it as non-serious unless ! -- it is a violation of No_Finalization in which case we leave it as a ! -- serious message, since otherwise we get crashes during attempts to ! -- expand stuff that is not properly formed due to assumptions made ! -- about no finalization being present. ! ! elsif R /= No_Finalization then ! Add_Char ('|'); ! end if; ! ! Error_Msg_Sloc := Restrictions_Loc (R); ! ! -- Set main message, adding implicit if no source location ! ! if Error_Msg_Sloc > No_Location ! or else Error_Msg_Sloc = System_Location ! then ! Add_Str ("violation of restriction "); ! else ! Add_Str ("violation of implicit restriction "); ! Error_Msg_Sloc := No_Location; ! end if; ! ! -- Case of parametrized restriction ! ! if R in All_Parameter_Restrictions then ! Add_Char ('`'); ! Id_Case (Restriction_Id'Image (R), Quotes => False); ! Add_Str (" = ^`"); ! Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R))); ! ! -- Case of boolean restriction ! ! else ! Id_Case (Restriction_Id'Image (R)); ! end if; ! ! -- Case of no secondary profile continuation message ! ! if Restriction_Profile_Name (R) = No_Profile then ! if Error_Msg_Sloc /= No_Location then ! Add_Char ('#'); ! end if; ! ! Add_Char ('!'); ! Error_Msg_N (Msg (1 .. Len), N); ! ! -- Case of secondary profile continuation message present ! ! else ! Add_Char ('!'); ! Error_Msg_N (Msg (1 .. Len), N); ! ! Len := 0; ! Add_Char ('\'); ! ! -- Set as warning if warning case ! ! if Restriction_Warnings (R) then ! Add_Char ('?'); ! end if; ! ! -- Set main message ! ! Add_Str ("from profile "); ! Id_Case (Profile_Name'Image (Restriction_Profile_Name (R))); ! ! -- Add location if we have one ! ! if Error_Msg_Sloc /= No_Location then ! Add_Char ('#'); ! end if; ! ! -- Output unconditional message and we are done ! ! Add_Char ('!'); ! Error_Msg_N (Msg (1 .. Len), N); ! end if; end Restriction_Msg; --------------- *************** package body Restrict is *** 612,617 **** --- 706,715 ---- Set_Restriction (J, N, V (J)); end if; + -- Record that this came from a Profile[_Warnings] restriction + + Restriction_Profile_Name (J) := P; + -- Set warning flag, except that we do not set the warning -- flag if the restriction was already active and this is -- the warning case. That avoids a warning overriding a real *************** package body Restrict is *** 661,673 **** Restricted_Profile_Cached := False; end if; ! -- Set location, but preserve location of system ! -- restriction for nice error msg with run time name if Restrictions_Loc (R) /= System_Location then Restrictions_Loc (R) := Sloc (N); end if; -- Record the restriction if we are in the main unit, or in the extended -- main unit. The reason that we test separately for Main_Unit is that -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in --- 759,775 ---- Restricted_Profile_Cached := False; end if; ! -- Set location, but preserve location of system restriction for nice ! -- error msg with run time name. if Restrictions_Loc (R) /= System_Location then Restrictions_Loc (R) := Sloc (N); end if; + -- Note restriction came from restriction pragma, not profile + + Restriction_Profile_Name (R) := No_Profile; + -- Record the restriction if we are in the main unit, or in the extended -- main unit. The reason that we test separately for Main_Unit is that -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in *************** package body Restrict is *** 709,720 **** Restrictions_Loc (R) := Sloc (N); end if; ! -- Record the restriction if we are in the main unit, ! -- or in the extended main unit. The reason that we ! -- test separately for Main_Unit is that gnat.adc is ! -- processed with Current_Sem_Unit = Main_Unit, but ! -- nodes in gnat.adc do not appear to be the extended ! -- main source unit (they probably should do ???) if Current_Sem_Unit = Main_Unit or else In_Extended_Main_Source_Unit (N) --- 811,821 ---- Restrictions_Loc (R) := Sloc (N); end if; ! -- Record the restriction if we are in the main unit, or in the extended ! -- main unit. The reason that we test separately for Main_Unit is that ! -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in ! -- gnat.adc do not appear to be the extended main source unit (they ! -- probably should do ???) if Current_Sem_Unit = Main_Unit or else In_Extended_Main_Source_Unit (N) *************** package body Restrict is *** 729,734 **** --- 830,839 ---- Main_Restrictions.Value (R) := V; end if; end if; + + -- Note restriction came from restriction pragma, not profile + + Restriction_Profile_Name (R) := No_Profile; end Set_Restriction; ----------------------------------- *************** package body Restrict is *** 736,743 **** ----------------------------------- procedure Set_Restriction_No_Dependence ! (Unit : Node_Id; ! Warn : Boolean) is begin -- Loop to check for duplicate entry --- 841,849 ---- ----------------------------------- procedure Set_Restriction_No_Dependence ! (Unit : Node_Id; ! Warn : Boolean; ! Profile : Profile_Name := No_Profile) is begin -- Loop to check for duplicate entry *************** package body Restrict is *** 760,766 **** -- Entry is not currently in table ! No_Dependence.Append ((Unit, Warn)); end Set_Restriction_No_Dependence; ---------------------------------- --- 866,872 ---- -- Entry is not currently in table ! No_Dependence.Append ((Unit, Warn, Profile)); end Set_Restriction_No_Dependence; ---------------------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/restrict.ads gcc-4.4.0/gcc/ada/restrict.ads *** gcc-4.3.3/gcc/ada/restrict.ads Thu Dec 13 10:28:48 2007 --- gcc-4.4.0/gcc/ada/restrict.ads Mon Aug 4 08:37:31 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Restrict is *** 37,43 **** -- This variable records restrictions found in any units in the main -- extended unit, and in the case of restrictions checked for partition -- consistency, restrictions found in any with'ed units, parent specs ! -- etc, since we may as well check as much as we can at compile time. -- These variables should not be referenced directly by clients. Instead -- use Check_Restrictions to record a violation of a restriction, and -- Restriction_Active to test if a given restriction is active. --- 37,43 ---- -- This variable records restrictions found in any units in the main -- extended unit, and in the case of restrictions checked for partition -- consistency, restrictions found in any with'ed units, parent specs ! -- etc., since we may as well check as much as we can at compile time. -- These variables should not be referenced directly by clients. Instead -- use Check_Restrictions to record a violation of a restriction, and -- Restriction_Active to test if a given restriction is active. *************** package Restrict is *** 50,55 **** --- 50,61 ---- -- pragma, and a value of System_Location is used for restrictions -- set from package Standard by the processing in Targparm. + Restriction_Profile_Name : array (All_Restrictions) of Profile_Name; + -- Entries in this array are valid only if the corresponding restriction + -- in Restrictions set. The value is the corresponding profile name if the + -- restriction was set by a Profile or Profile_Warnings pragma. The value + -- is No_Profile in all other cases. + Main_Restrictions : Restrictions_Info := No_Restrictions; -- This variable records only restrictions found in any units of the -- main extended unit. These are the variables used for ali file output, *************** package Restrict is *** 105,118 **** --- 111,128 ---- Implementation_Restriction : array (All_Restrictions) of Boolean := (Simple_Barriers => True, + No_Asynchronous_Control => True, No_Calendar => True, No_Dispatching_Calls => True, No_Dynamic_Attachment => True, + No_Elaboration_Code => True, No_Enumeration_Maps => True, No_Entry_Calls_In_Elaboration_Code => True, No_Entry_Queue => True, No_Exception_Handlers => True, No_Exception_Registration => True, + No_Implementation_Attributes => True, + No_Implementation_Pragmas => True, No_Implicit_Conditionals => True, No_Implicit_Dynamic_Code => True, No_Implicit_Loops => True, *************** package Restrict is *** 126,137 **** No_Streams => True, No_Task_Attributes_Package => True, No_Task_Termination => True, No_Wide_Characters => True, Static_Priorities => True, Static_Storage_Size => True, - No_Implementation_Attributes => True, - No_Implementation_Pragmas => True, - No_Elaboration_Code => True, others => False); -- The following table records entries made by Restrictions pragmas --- 136,146 ---- No_Streams => True, No_Task_Attributes_Package => True, No_Task_Termination => True, + No_Unchecked_Conversion => True, + No_Unchecked_Deallocation => True, No_Wide_Characters => True, Static_Priorities => True, Static_Storage_Size => True, others => False); -- The following table records entries made by Restrictions pragmas *************** package Restrict is *** 151,156 **** --- 160,169 ---- Warn : Boolean; -- True if from Restriction_Warnings, False if from Restrictions + + Profile : Profile_Name; + -- Set to name of profile from which No_Dependence entry came, or to + -- No_Profile if a pragma Restriction set the No_Dependence entry. end record; package No_Dependence is new Table.Table ( *************** package Restrict is *** 187,200 **** V : Uint := Uint_Minus_1); -- Checks that the given restriction is not set, and if it is set, an -- appropriate message is posted on the given node. Also records the ! -- violation in the appropriate internal arrays. Note that it is ! -- mandatory to always use this routine to check if a restriction ! -- is violated. Such checks must never be done directly by the caller, ! -- since otherwise violations in the absence of restrictions are not ! -- properly recorded. The value of V is relevant only for parameter ! -- restrictions, and in this case indicates the exact count for the ! -- violation. If the exact count is not known, V is left at its ! -- default value of -1 which indicates an unknown count. procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id); -- Called when a dependence on a unit is created (either implicitly, or by --- 200,212 ---- V : Uint := Uint_Minus_1); -- Checks that the given restriction is not set, and if it is set, an -- appropriate message is posted on the given node. Also records the ! -- violation in the appropriate internal arrays. Note that it is mandatory ! -- to always use this routine to check if a restriction is violated. Such ! -- checks must never be done directly by the caller, since otherwise ! -- violations in the absence of restrictions are not properly recorded. The ! -- value of V is relevant only for parameter restrictions, and in this case ! -- indicates the exact count for the violation. If the exact count is not ! -- known, V is left at its default of -1 which indicates an unknown count. procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id); -- Called when a dependence on a unit is created (either implicitly, or by *************** package Restrict is *** 249,254 **** --- 261,270 ---- -- set. In the latter case, the source may contain handlers but they either -- get converted using the local goto transformation or deleted. + function No_Exception_Propagation_Active return Boolean; + -- Test to see if current restrictions settings specify that no + -- exception propagation is activated. + function Process_Restriction_Synonyms (N : Node_Id) return Name_Id; -- Id is a node whose Chars field contains the name of a restriction. -- If it is one of synonyms that we allow for historical purposes (for *************** package Restrict is *** 266,283 **** function Restricted_Profile return Boolean; -- Tests if set of restrictions corresponding to Profile (Restricted) is -- currently in effect (set by pragma Profile, or by an appropriate set ! -- of individual Restrictions pragms). Returns True only if all the -- required restrictions are set. procedure Set_Profile_Restrictions (P : Profile_Name; N : Node_Id; Warn : Boolean); ! -- Sets the set of restrictions associated with the given profile ! -- name. N is the node of the construct to which error messages ! -- are to be attached as required. Warn is set True for the case ! -- of Profile_Warnings where the restrictions are set as warnings ! -- rather than legality requirements. procedure Set_Restriction (R : All_Boolean_Restrictions; --- 282,300 ---- function Restricted_Profile return Boolean; -- Tests if set of restrictions corresponding to Profile (Restricted) is -- currently in effect (set by pragma Profile, or by an appropriate set ! -- of individual Restrictions pragmas). Returns True only if all the -- required restrictions are set. procedure Set_Profile_Restrictions (P : Profile_Name; N : Node_Id; Warn : Boolean); ! -- Sets the set of restrictions associated with the given profile name. N ! -- is the node of the construct to which error messages are to be attached ! -- as required. Warn is set True for the case of Profile_Warnings where the ! -- restrictions are set as warnings rather than legality requirements, and ! -- is also True for Profile if the Treat_Restrictions_As_Warnings flag is ! -- set. It is false for Profile if this flag is not set. procedure Set_Restriction (R : All_Boolean_Restrictions; *************** package Restrict is *** 294,309 **** -- parameter restriction, and the corresponding value V is given. procedure Set_Restriction_No_Dependence ! (Unit : Node_Id; ! Warn : Boolean); -- Sets given No_Dependence restriction in table if not there already. ! -- Warn is True if from Restriction_Warnings, False if from Restrictions. function Tasking_Allowed return Boolean; pragma Inline (Tasking_Allowed); ! -- Tests to see if tasking operations are allowed by the current ! -- restrictions settings. For tasking to be allowed Max_Tasks must ! -- be non-zero. private type Save_Cunit_Boolean_Restrictions is --- 311,329 ---- -- parameter restriction, and the corresponding value V is given. procedure Set_Restriction_No_Dependence ! (Unit : Node_Id; ! Warn : Boolean; ! Profile : Profile_Name := No_Profile); -- Sets given No_Dependence restriction in table if not there already. ! -- Warn is True if from Restriction_Warnings, or for Restrictions if flag ! -- Treat_Restrictions_As_Warnings is set. False if from Restrictions and ! -- this flag is not set. Profile is set to a non-default value if the ! -- No_Dependence restriction comes from a Profile pragma. function Tasking_Allowed return Boolean; pragma Inline (Tasking_Allowed); ! -- Tests if tasking operations are allowed by the current restrictions ! -- settings. For tasking to be allowed Max_Tasks must be non-zero. private type Save_Cunit_Boolean_Restrictions is diff -Nrcpad gcc-4.3.3/gcc/ada/rident.ads gcc-4.4.0/gcc/ada/rident.ads *** gcc-4.3.3/gcc/ada/rident.ads Fri Dec 9 17:14:34 2005 --- gcc-4.4.0/gcc/ada/rident.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/rtsfind.adb gcc-4.4.0/gcc/ada/rtsfind.adb *** gcc-4.3.3/gcc/ada/rtsfind.adb Thu Dec 13 10:29:02 2007 --- gcc-4.4.0/gcc/ada/rtsfind.adb Wed Jul 30 15:52:47 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Rtsfind is *** 100,108 **** -- for the same entity can be satisfied immediately. -- NOTE: In order to avoid conflicts between record components and subprgs ! -- that have the same name (ie. subprogram External_Tag and component ! -- External_Tag of package Ada.Tags) this table is not used with ! -- Record_Components. RE_Table : array (RE_Id) of Entity_Id; --- 100,108 ---- -- for the same entity can be satisfied immediately. -- NOTE: In order to avoid conflicts between record components and subprgs ! -- that have the same name (i.e. subprogram External_Tag and ! -- component External_Tag of package Ada.Tags) this table is not used ! -- with Record_Components. RE_Table : array (RE_Id) of Entity_Id; *************** package body Rtsfind is *** 145,151 **** -- value in RTU_Id. procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id); ! -- Internal procedure called if we can't sucessfully locate or process a -- run-time unit. The parameters give information about the error message -- to be given. S is a reason for failing to compile the file and U_Id is -- the unit id. RE_Id is the RE_Id originally passed to RTE. The message in --- 145,151 ---- -- value in RTU_Id. procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id); ! -- Internal procedure called if we can't successfully locate or process a -- run-time unit. The parameters give information about the error message -- to be given. S is a reason for failing to compile the file and U_Id is -- the unit id. RE_Id is the RE_Id originally passed to RTE. The message in *************** package body Rtsfind is *** 283,288 **** --- 283,291 ---- if U_Id in Ada_Calendar_Child then Name_Buffer (13) := '.'; + elsif U_Id in Ada_Dispatching_Child then + Name_Buffer (16) := '.'; + elsif U_Id in Ada_Finalization_Child then Name_Buffer (17) := '.'; *************** package body Rtsfind is *** 311,316 **** --- 314,323 ---- elsif U_Id in System_Child then Name_Buffer (7) := '.'; + if U_Id in System_Strings_Child then + Name_Buffer (15) := '.'; + end if; + if U_Id in System_Tasking_Child then Name_Buffer (15) := '.'; end if; *************** package body Rtsfind is *** 907,931 **** --------------- procedure Check_RPC is - - procedure Check_RPC_Failure (Msg : String); - pragma No_Return (Check_RPC_Failure); - -- Display Msg on standard error and raise Unrecoverable_Error - - ----------------------- - -- Check_RPC_Failure -- - ----------------------- - - procedure Check_RPC_Failure (Msg : String) is - begin - Set_Standard_Error; - Write_Str (Msg); - Write_Eol; - raise Unrecoverable_Error; - end Check_RPC_Failure; - - -- Start of processing for Check_RPC - begin -- Bypass this check if debug flag -gnatdR set --- 914,919 ---- *************** package body Rtsfind is *** 933,960 **** return; end if; ! -- Otherwise we need the check if we are going after one of ! -- the critical entities in System.RPC in stubs mode. ! ! -- ??? Should we do this for other s-parint entities too? ! if (Distribution_Stub_Mode = Generate_Receiver_Stub_Body ! or else ! Distribution_Stub_Mode = Generate_Caller_Stub_Body) ! and then (E = RE_Do_Rpc ! or else ! E = RE_Do_Apc ! or else ! E = RE_Params_Stream_Type ! or else ! E = RE_Request_Access) then ! if Get_PCS_Name = Name_No_DSA then ! Check_RPC_Failure ("distribution feature not supported"); ! elsif Get_PCS_Version /= Exp_Dist.PCS_Version_Number then ! Check_RPC_Failure ("PCS version mismatch"); end if; end if; end Check_RPC; --- 921,964 ---- return; end if; ! -- Otherwise we need the check if we are going after one of the ! -- critical entities in System.RPC / System.Partition_Interface. ! if E = RE_Do_Rpc ! or else ! E = RE_Do_Apc ! or else ! E = RE_Params_Stream_Type ! or else ! E = RE_Request_Access then ! -- If generating RCI stubs, check that we have a real PCS ! if (Distribution_Stub_Mode = Generate_Receiver_Stub_Body ! or else ! Distribution_Stub_Mode = Generate_Caller_Stub_Body) ! and then Get_PCS_Name = Name_No_DSA ! then ! Set_Standard_Error; ! Write_Str ("distribution feature not supported"); ! Write_Eol; ! raise Unrecoverable_Error; + -- In all cases, check Exp_Dist and System.Partition_Interface + -- consistency. + + elsif Get_PCS_Version /= + Exp_Dist.PCS_Version_Number (Get_PCS_Name) + then + Set_Standard_Error; + Write_Str ("PCS version mismatch: expander "); + Write_Int (Exp_Dist.PCS_Version_Number (Get_PCS_Name)); + Write_Str (", PCS ("); + Write_Name (Get_PCS_Name); + Write_Str (") "); + Write_Int (Get_PCS_Version); + Write_Eol; + raise Unrecoverable_Error; end if; end if; end Check_RPC; *************** package body Rtsfind is *** 1207,1213 **** -- If we didn't find the entity we want, something is wrong. The -- appropriate action will be taken by Check_CRT when we exit. ! -- Cenerate a with-clause if the current unit is part of the extended -- main code unit, and if we have not already added the with. The clause -- is added to the appropriate unit (the current one). We do not need to -- generate it for a call issued from RTE_Component_Available. --- 1211,1217 ---- -- If we didn't find the entity we want, something is wrong. The -- appropriate action will be taken by Check_CRT when we exit. ! -- Generate a with-clause if the current unit is part of the extended -- main code unit, and if we have not already added the with. The clause -- is added to the appropriate unit (the current one). We do not need to -- generate it for a call issued from RTE_Component_Available. diff -Nrcpad gcc-4.3.3/gcc/ada/rtsfind.ads gcc-4.4.0/gcc/ada/rtsfind.ads *** gcc-4.3.3/gcc/ada/rtsfind.ads Thu Dec 13 10:29:02 2007 --- gcc-4.4.0/gcc/ada/rtsfind.ads Fri Aug 22 12:41:03 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Rtsfind is *** 78,86 **** -- name is System.xxx. For example, the name System_Str_Concat refers to -- package System.Str_Concat. -- Names of the form System_Tasking_xxx are second level children of the -- package System.Tasking. For example, System_Tasking_Stages refers to ! -- refers to the package System.Tasking.Stages. -- Other names stand for themselves (e.g. System for package System) --- 78,89 ---- -- name is System.xxx. For example, the name System_Str_Concat refers to -- package System.Str_Concat. + -- Names of the form System_Strings_xxx are second level children of the + -- package System.Strings. + -- Names of the form System_Tasking_xxx are second level children of the -- package System.Tasking. For example, System_Tasking_Stages refers to ! -- the package System.Tasking.Stages. -- Other names stand for themselves (e.g. System for package System) *************** package Rtsfind is *** 112,117 **** --- 115,121 ---- -- Children of Ada Ada_Calendar, + Ada_Dispatching, Ada_Exceptions, Ada_Finalization, Ada_Interrupts, *************** package Rtsfind is *** 125,130 **** --- 129,138 ---- Ada_Calendar_Delays, + -- Children of Ada.Dispatching + + Ada_Dispatching_EDF, + -- Children of Ada.Finalization Ada_Finalization_List_Controller, *************** package Rtsfind is *** 136,141 **** --- 144,150 ---- -- Children of Ada.Real_Time Ada_Real_Time_Delays, + Ada_Real_Time_Timing_Events, -- Children of Ada.Streams *************** package Rtsfind is *** 200,205 **** --- 209,215 ---- System_Compare_Array_Unsigned_64, System_Compare_Array_Unsigned_8, System_DSA_Services, + System_DSA_Types, System_Exception_Table, System_Exceptions, System_Exn_Int, *************** package Rtsfind is *** 348,353 **** --- 358,367 ---- System_WWd_Enum, System_WWd_Wchar, + -- Children of System.Strings + + System_Strings_Stream_Ops, + -- Children of System.Tasking System_Tasking_Async_Delays, *************** package Rtsfind is *** 369,374 **** --- 383,392 ---- range Ada_Calendar_Delays .. Ada_Calendar_Delays; -- Range of values for children of Ada.Calendar + subtype Ada_Dispatching_Child is RTU_Id + range Ada_Dispatching_EDF .. Ada_Dispatching_EDF; + -- Range of values for children of Ada.Dispatching + subtype Ada_Finalization_Child is Ada_Child range Ada_Finalization_List_Controller .. Ada_Finalization_List_Controller; -- Range of values for children of Ada.Finalization *************** package Rtsfind is *** 378,384 **** -- Range of values for children of Ada.Interrupts subtype Ada_Real_Time_Child is Ada_Child ! range Ada_Real_Time_Delays .. Ada_Real_Time_Delays; -- Range of values for children of Ada.Real_Time subtype Ada_Streams_Child is Ada_Child --- 396,402 ---- -- Range of values for children of Ada.Interrupts subtype Ada_Real_Time_Child is Ada_Child ! range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events; -- Range of values for children of Ada.Real_Time subtype Ada_Streams_Child is Ada_Child *************** package Rtsfind is *** 404,409 **** --- 422,430 ---- range System_Address_Image .. System_Tasking_Stages; -- Range of values for children or grandchildren of System + subtype System_Strings_Child is RTU_Id + range System_Strings_Stream_Ops .. System_Strings_Stream_Ops; + subtype System_Tasking_Child is System_Child range System_Tasking_Async_Delays .. System_Tasking_Stages; -- Range of values for children of System.Tasking *************** package Rtsfind is *** 451,456 **** --- 472,485 ---- RE_Null, + RO_CA_Time, -- Ada.Calendar + + RO_CA_Delay_For, -- Ada.Calendar.Delays + RO_CA_Delay_Until, -- Ada.Calendar.Delays + RO_CA_To_Duration, -- Ada.Calendar.Delays + + RE_Set_Deadline, -- Ada.Dispatching.EDF + RE_Code_Loc, -- Ada.Exceptions RE_Current_Target_Exception, -- Ada.Exceptions (JGNAT use only) RE_Exception_Id, -- Ada.Exceptions *************** package Rtsfind is *** 480,486 **** RE_Detach_Handler, -- Ada.Interrupts RE_Reference, -- Ada.Interrupts ! RE_Names, -- Ada.Interupts.Names RE_Root_Stream_Type, -- Ada.Streams RE_Stream_Element, -- Ada.Streams --- 509,525 ---- RE_Detach_Handler, -- Ada.Interrupts RE_Reference, -- Ada.Interrupts ! RE_Names, -- Ada.Interrupts.Names ! ! RE_Clock, -- Ada.Real_Time ! RE_Time_Span, -- Ada.Real_Time ! RE_Time_Span_Zero, -- Ada.Real_Time ! RO_RT_Time, -- Ada.Real_Time ! ! RO_RT_Delay_Until, -- Ada.Real_Time.Delays ! RO_RT_To_Duration, -- Ada.Real_Time.Delays ! ! RE_Timing_Event, -- Ada_Real_Time_Timing_Events RE_Root_Stream_Type, -- Ada.Streams RE_Stream_Element, -- Ada.Streams *************** package Rtsfind is *** 497,502 **** --- 536,542 ---- RE_Dispatch_Table_Wrapper, -- Ada.Tags RE_Displace, -- Ada.Tags RE_DT, -- Ada.Tags + RE_DT_Offset_To_Top_Offset, -- Ada.Tags RE_DT_Predef_Prims_Offset, -- Ada.Tags RE_DT_Typeinfo_Ptr_Size, -- Ada.Tags RE_External_Tag, -- Ada.Tags *************** package Rtsfind is *** 520,525 **** --- 560,566 ---- RE_Num_Prims, -- Ada.Tags RE_Object_Specific_Data, -- Ada.Tags RE_Offset_To_Top, -- Ada.Tags + RE_Offset_To_Top_Ptr, -- Ada.Tags RE_Offset_To_Top_Function_Ptr, -- Ada.Tags RE_OSD_Table, -- Ada.Tags RE_OSD_Num_Prims, -- Ada.Tags *************** package Rtsfind is *** 534,553 **** RE_Predef_Prims, -- Ada.Tags RE_Predef_Prims_Table_Ptr, -- Ada.Tags RE_Prim_Op_Kind, -- Ada.Tags RE_Prims_Ptr, -- Ada.Tags RE_Primary_DT, -- Ada.Tags RE_Signature, -- Ada.Tags RE_SSD, -- Ada.Tags RE_TSD, -- Ada.Tags RE_Type_Specific_Data, -- Ada.Tags RE_Register_Tag, -- Ada.Tags RE_Transportable, -- Ada.Tags RE_Secondary_DT, -- Ada.Tags RE_Secondary_Tag, -- Ada.Tags RE_Select_Specific_Data, -- Ada.Tags RE_Set_Entry_Index, -- Ada.Tags ! RE_Set_Offset_To_Top, -- Ada.Tags RE_Set_Prim_Op_Kind, -- Ada.Tags RE_Tag, -- Ada.Tags RE_Tag_Error, -- Ada.Tags RE_Tag_Kind, -- Ada.Tags --- 575,598 ---- RE_Predef_Prims, -- Ada.Tags RE_Predef_Prims_Table_Ptr, -- Ada.Tags RE_Prim_Op_Kind, -- Ada.Tags + RE_Prim_Ptr, -- Ada.Tags RE_Prims_Ptr, -- Ada.Tags RE_Primary_DT, -- Ada.Tags RE_Signature, -- Ada.Tags RE_SSD, -- Ada.Tags RE_TSD, -- Ada.Tags RE_Type_Specific_Data, -- Ada.Tags + RE_Register_Interface_Offset, -- Ada.Tags RE_Register_Tag, -- Ada.Tags RE_Transportable, -- Ada.Tags RE_Secondary_DT, -- Ada.Tags RE_Secondary_Tag, -- Ada.Tags RE_Select_Specific_Data, -- Ada.Tags RE_Set_Entry_Index, -- Ada.Tags ! RE_Set_Dynamic_Offset_To_Top, -- Ada.Tags RE_Set_Prim_Op_Kind, -- Ada.Tags + RE_Size_Func, -- Ada.Tags + RE_Size_Ptr, -- Ada.Tags RE_Tag, -- Ada.Tags RE_Tag_Error, -- Ada.Tags RE_Tag_Kind, -- Ada.Tags *************** package Rtsfind is *** 563,583 **** RE_TK_Tagged, -- Ada.Tags RE_TK_Task, -- Ada.Tags RE_Abort_Task, -- Ada.Task_Identification RE_Current_Task, -- Ada.Task_Identification RO_AT_Task_Id, -- Ada.Task_Identification - RO_CA_Time, -- Ada.Calendar - - RO_CA_Delay_For, -- Ada.Calendar.Delays - RO_CA_Delay_Until, -- Ada.Calendar.Delays - RO_CA_To_Duration, -- Ada.Calendar.Delays - - RO_RT_Time, -- Ada.Real_Time - - RO_RT_Delay_Until, -- Ada.Real_Time.Delays - RO_RT_To_Duration, -- Ada.Real_Time.Delays - RE_Integer_64, -- Interfaces RE_Unsigned_8, -- Interfaces RE_Unsigned_16, -- Interfaces --- 608,620 ---- RE_TK_Tagged, -- Ada.Tags RE_TK_Task, -- Ada.Tags + RE_Set_Specific_Handler, -- Ada.Task_Termination + RE_Specific_Handler, -- Ada.Task_Termination + RE_Abort_Task, -- Ada.Task_Identification RE_Current_Task, -- Ada.Task_Identification RO_AT_Task_Id, -- Ada.Task_Identification RE_Integer_64, -- Interfaces RE_Unsigned_8, -- Interfaces RE_Unsigned_16, -- Interfaces *************** package Rtsfind is *** 660,665 **** --- 697,704 ---- RE_Get_Local_Partition_Id, -- System.DSA_Services RE_Get_Passive_Partition_Id, -- System.DSA_Services + RE_Any_Container_Ptr, -- System.DSA_Types + RE_Register_Exception, -- System.Exception_Table RE_Local_Raise, -- System.Exceptions *************** package Rtsfind is *** 749,754 **** --- 788,794 ---- RE_Default_Interrupt_Priority, -- System.Interrupts RE_Dynamic_Interrupt_Protection, -- System.Interrupts RE_Install_Handlers, -- System.Interrupts + RE_Install_Restricted_Handlers, -- System.Interrupts RE_Register_Interrupt_Handler, -- System.Interrupts RE_Static_Interrupt_Protection, -- System.Interrupts RE_System_Interrupt_Id, -- System.Interrupts *************** package Rtsfind is *** 1047,1052 **** --- 1087,1093 ---- RE_DSA_Implementation, -- System.Partition_Interface RE_PCS_Version, -- System.Partition_Interface + RE_Get_RACW, -- System.Partition_Interface RE_Get_RCI_Package_Receiver, -- System.Partition_Interface RE_Get_Unique_Remote_Pointer, -- System.Partition_Interface RE_RACW_Stub_Type_Access, -- System.Partition_Interface *************** package Rtsfind is *** 1119,1124 **** --- 1160,1166 ---- RE_BS_To_Any, -- System.Partition_Interface RE_Any_To_BS, -- System.Partition_Interface + RE_FA_A, -- System.Partition_Interface RE_FA_B, -- System.Partition_Interface RE_FA_C, -- System.Partition_Interface RE_FA_F, -- System.Partition_Interface *************** package Rtsfind is *** 1167,1173 **** RE_TC_Build, -- System.Partition_Interface RE_Get_TC, -- System.Partition_Interface RE_Set_TC, -- System.Partition_Interface ! RE_TC_Any, -- System.Partition_Interface RE_TC_B, -- System.Partition_Interface RE_TC_C, -- System.Partition_Interface RE_TC_F, -- System.Partition_Interface --- 1209,1215 ---- RE_TC_Build, -- System.Partition_Interface RE_Get_TC, -- System.Partition_Interface RE_Set_TC, -- System.Partition_Interface ! RE_TC_A, -- System.Partition_Interface RE_TC_B, -- System.Partition_Interface RE_TC_C, -- System.Partition_Interface RE_TC_F, -- System.Partition_Interface *************** package Rtsfind is *** 1219,1229 **** RE_SS_Mark, -- System.Secondary_Stack RE_SS_Release, -- System.Secondary_Stack - RE_Shared_Var_Close, -- System.Shared_Storage RE_Shared_Var_Lock, -- System.Shared_Storage - RE_Shared_Var_ROpen, -- System.Shared_Storage RE_Shared_Var_Unlock, -- System.Shared_Storage ! RE_Shared_Var_WOpen, -- System.Shared_Storage RE_Abort_Undefer_Direct, -- System.Standard_Library RE_Exception_Code, -- System.Standard_Library --- 1261,1269 ---- RE_SS_Mark, -- System.Secondary_Stack RE_SS_Release, -- System.Secondary_Stack RE_Shared_Var_Lock, -- System.Shared_Storage RE_Shared_Var_Unlock, -- System.Shared_Storage ! RE_Shared_Var_Procs, -- System.Shared_Storage RE_Abort_Undefer_Direct, -- System.Standard_Library RE_Exception_Code, -- System.Standard_Library *************** package Rtsfind is *** 1233,1243 **** RE_Storage_Offset, -- System.Storage_Elements RE_Storage_Array, -- System.Storage_Elements RE_To_Address, -- System.Storage_Elements - RE_Dummy_Communication_Block, -- System.Storage_Elements RE_Root_Storage_Pool, -- System.Storage_Pools ! RE_Allocate_Any, -- System_Storage_Pools, ! RE_Deallocate_Any, -- System_Storage_Pools, RE_I_AD, -- System.Stream_Attributes RE_I_AS, -- System.Stream_Attributes --- 1273,1282 ---- RE_Storage_Offset, -- System.Storage_Elements RE_Storage_Array, -- System.Storage_Elements RE_To_Address, -- System.Storage_Elements RE_Root_Storage_Pool, -- System.Storage_Pools ! RE_Allocate_Any, -- System.Storage_Pools, ! RE_Deallocate_Any, -- System.Storage_Pools, RE_I_AD, -- System.Stream_Attributes RE_I_AS, -- System.Stream_Attributes *************** package Rtsfind is *** 1292,1297 **** --- 1331,1361 ---- RE_Str_Concat_5, -- System.String_Ops_Concat_5 + RE_String_Input, -- System.Strings.Stream_Ops + RE_String_Input_Blk_IO, -- System.Strings.Stream_Ops + RE_String_Output, -- System.Strings.Stream_Ops + RE_String_Output_Blk_IO, -- System.Strings.Stream_Ops + RE_String_Read, -- System.Strings.Stream_Ops + RE_String_Read_Blk_IO, -- System.Strings.Stream_Ops + RE_String_Write, -- System.Strings.Stream_Ops + RE_String_Write_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_String_Input, -- System.Strings.Stream_Ops + RE_Wide_String_Input_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_String_Output, -- System.Strings.Stream_Ops + RE_Wide_String_Output_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_String_Read, -- System.Strings.Stream_Ops + RE_Wide_String_Read_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_String_Write, -- System.Strings.Stream_Ops + RE_Wide_String_Write_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Input, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Input_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Output, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Output_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Read, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Read_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Write, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Write_Blk_IO, -- System.Strings.Stream_Ops + RE_Task_Info_Type, -- System.Task_Info RE_Unspecified_Task_Info, -- System.Task_Info *************** package Rtsfind is *** 1331,1336 **** --- 1395,1401 ---- RE_Abort_Undefer, -- System.Soft_Links RE_Complete_Master, -- System.Soft_Links RE_Current_Master, -- System.Soft_Links + RE_Dummy_Communication_Block, -- System.Soft_Links RE_Enter_Master, -- System.Soft_Links RE_Get_Current_Excep, -- System.Soft_Links RE_Get_GNAT_Exception, -- System.Soft_Links *************** package Rtsfind is *** 1406,1411 **** --- 1471,1479 ---- RE_Mul_G, -- System.Vax_Float_Operations RE_Neg_F, -- System.Vax_Float_Operations RE_Neg_G, -- System.Vax_Float_Operations + RE_Return_D, -- System.Vax_Float_Operations + RE_Return_F, -- System.Vax_Float_Operations + RE_Return_G, -- System.Vax_Float_Operations RE_Sub_F, -- System.Vax_Float_Operations RE_Sub_G, -- System.Vax_Float_Operations *************** package Rtsfind is *** 1471,1477 **** --- 1539,1547 ---- RE_Lock_Entries, -- Tasking.Protected_Objects.Entries RO_PE_Get_Ceiling, -- Tasking.Protected_Objects.Entries RO_PE_Set_Ceiling, -- Tasking.Protected_Objects.Entries + RO_PE_Set_Entry_Name, -- Tasking.Protected_Objects.Entries RE_Unlock_Entries, -- Tasking.Protected_Objects.Entries + RE_Communication_Block, -- Protected_Objects.Operations RE_Protected_Entry_Call, -- Protected_Objects.Operations RE_Service_Entries, -- Protected_Objects.Operations *************** package Rtsfind is *** 1545,1560 **** RE_Free_Task, -- System.Tasking.Stages RE_Expunge_Unactivated_Tasks, -- System.Tasking.Stages RE_Move_Activation_Chain, -- System_Tasking_Stages RE_Terminated); -- System.Tasking.Stages ! -- The following declarations build a table that is indexed by the ! -- RTE function to determine the unit containing the given entity. ! -- This table is sorted in order of package names. RE_Unit_Table : array (RE_Id) of RTU_Id := ( RE_Null => RTU_Null, RE_Code_Loc => Ada_Exceptions, RE_Current_Target_Exception => Ada_Exceptions, -- of JGNAT RE_Exception_Id => Ada_Exceptions, --- 1615,1639 ---- RE_Free_Task, -- System.Tasking.Stages RE_Expunge_Unactivated_Tasks, -- System.Tasking.Stages RE_Move_Activation_Chain, -- System_Tasking_Stages + RO_TS_Set_Entry_Name, -- System.Tasking.Stages RE_Terminated); -- System.Tasking.Stages ! -- The following declarations build a table that is indexed by the RTE ! -- function to determine the unit containing the given entity. This table ! -- is sorted in order of package names. RE_Unit_Table : array (RE_Id) of RTU_Id := ( RE_Null => RTU_Null, + RO_CA_Time => Ada_Calendar, + + RO_CA_Delay_For => Ada_Calendar_Delays, + RO_CA_Delay_Until => Ada_Calendar_Delays, + RO_CA_To_Duration => Ada_Calendar_Delays, + + RE_Set_Deadline => Ada_Dispatching_EDF, + RE_Code_Loc => Ada_Exceptions, RE_Current_Target_Exception => Ada_Exceptions, -- of JGNAT RE_Exception_Id => Ada_Exceptions, *************** package Rtsfind is *** 1586,1591 **** --- 1665,1680 ---- RE_Names => Ada_Interrupts_Names, + RE_Clock => Ada_Real_Time, + RE_Time_Span => Ada_Real_Time, + RE_Time_Span_Zero => Ada_Real_Time, + RO_RT_Time => Ada_Real_Time, + + RO_RT_Delay_Until => Ada_Real_Time_Delays, + RO_RT_To_Duration => Ada_Real_Time_Delays, + + RE_Timing_Event => Ada_Real_Time_Timing_Events, + RE_Root_Stream_Type => Ada_Streams, RE_Stream_Element => Ada_Streams, *************** package Rtsfind is *** 1601,1606 **** --- 1690,1696 ---- RE_Dispatch_Table_Wrapper => Ada_Tags, RE_Displace => Ada_Tags, RE_DT => Ada_Tags, + RE_DT_Offset_To_Top_Offset => Ada_Tags, RE_DT_Predef_Prims_Offset => Ada_Tags, RE_DT_Typeinfo_Ptr_Size => Ada_Tags, RE_External_Tag => Ada_Tags, *************** package Rtsfind is *** 1624,1629 **** --- 1714,1720 ---- RE_Num_Prims => Ada_Tags, RE_Object_Specific_Data => Ada_Tags, RE_Offset_To_Top => Ada_Tags, + RE_Offset_To_Top_Ptr => Ada_Tags, RE_Offset_To_Top_Function_Ptr => Ada_Tags, RE_OSD_Table => Ada_Tags, RE_OSD_Num_Prims => Ada_Tags, *************** package Rtsfind is *** 1638,1657 **** RE_Predef_Prims => Ada_Tags, RE_Predef_Prims_Table_Ptr => Ada_Tags, RE_Prim_Op_Kind => Ada_Tags, RE_Prims_Ptr => Ada_Tags, RE_Primary_DT => Ada_Tags, RE_Signature => Ada_Tags, RE_SSD => Ada_Tags, RE_TSD => Ada_Tags, RE_Type_Specific_Data => Ada_Tags, RE_Register_Tag => Ada_Tags, RE_Transportable => Ada_Tags, RE_Secondary_DT => Ada_Tags, RE_Secondary_Tag => Ada_Tags, RE_Select_Specific_Data => Ada_Tags, RE_Set_Entry_Index => Ada_Tags, ! RE_Set_Offset_To_Top => Ada_Tags, RE_Set_Prim_Op_Kind => Ada_Tags, RE_Tag => Ada_Tags, RE_Tag_Error => Ada_Tags, RE_Tag_Kind => Ada_Tags, --- 1729,1752 ---- RE_Predef_Prims => Ada_Tags, RE_Predef_Prims_Table_Ptr => Ada_Tags, RE_Prim_Op_Kind => Ada_Tags, + RE_Prim_Ptr => Ada_Tags, RE_Prims_Ptr => Ada_Tags, RE_Primary_DT => Ada_Tags, RE_Signature => Ada_Tags, RE_SSD => Ada_Tags, RE_TSD => Ada_Tags, RE_Type_Specific_Data => Ada_Tags, + RE_Register_Interface_Offset => Ada_Tags, RE_Register_Tag => Ada_Tags, RE_Transportable => Ada_Tags, RE_Secondary_DT => Ada_Tags, RE_Secondary_Tag => Ada_Tags, RE_Select_Specific_Data => Ada_Tags, RE_Set_Entry_Index => Ada_Tags, ! RE_Set_Dynamic_Offset_To_Top => Ada_Tags, RE_Set_Prim_Op_Kind => Ada_Tags, + RE_Size_Func => Ada_Tags, + RE_Size_Ptr => Ada_Tags, RE_Tag => Ada_Tags, RE_Tag_Error => Ada_Tags, RE_Tag_Kind => Ada_Tags, *************** package Rtsfind is *** 1667,1685 **** RE_TK_Tagged => Ada_Tags, RE_TK_Task => Ada_Tags, RE_Abort_Task => Ada_Task_Identification, RE_Current_Task => Ada_Task_Identification, RO_AT_Task_Id => Ada_Task_Identification, - RO_CA_Time => Ada_Calendar, - RO_CA_Delay_For => Ada_Calendar_Delays, - RO_CA_Delay_Until => Ada_Calendar_Delays, - RO_CA_To_Duration => Ada_Calendar_Delays, - - RO_RT_Time => Ada_Real_Time, - RO_RT_Delay_Until => Ada_Real_Time_Delays, - RO_RT_To_Duration => Ada_Real_Time_Delays, - RE_Integer_64 => Interfaces, RE_Unsigned_8 => Interfaces, RE_Unsigned_16 => Interfaces, --- 1762,1774 ---- RE_TK_Tagged => Ada_Tags, RE_TK_Task => Ada_Tags, + RE_Set_Specific_Handler => Ada_Task_Termination, + RE_Specific_Handler => Ada_Task_Termination, + RE_Abort_Task => Ada_Task_Identification, RE_Current_Task => Ada_Task_Identification, RO_AT_Task_Id => Ada_Task_Identification, RE_Integer_64 => Interfaces, RE_Unsigned_8 => Interfaces, RE_Unsigned_16 => Interfaces, *************** package Rtsfind is *** 1762,1767 **** --- 1851,1858 ---- RE_Get_Local_Partition_Id => System_DSA_Services, RE_Get_Passive_Partition_Id => System_DSA_Services, + RE_Any_Container_Ptr => System_DSA_Types, + RE_Register_Exception => System_Exception_Table, RE_Local_Raise => System_Exceptions, *************** package Rtsfind is *** 1851,1856 **** --- 1942,1948 ---- RE_Default_Interrupt_Priority => System_Interrupts, RE_Dynamic_Interrupt_Protection => System_Interrupts, RE_Install_Handlers => System_Interrupts, + RE_Install_Restricted_Handlers => System_Interrupts, RE_Register_Interrupt_Handler => System_Interrupts, RE_Static_Interrupt_Protection => System_Interrupts, RE_System_Interrupt_Id => System_Interrupts, *************** package Rtsfind is *** 2149,2154 **** --- 2241,2247 ---- RE_DSA_Implementation => System_Partition_Interface, RE_PCS_Version => System_Partition_Interface, + RE_Get_RACW => System_Partition_Interface, RE_Get_RCI_Package_Receiver => System_Partition_Interface, RE_Get_Unique_Remote_Pointer => System_Partition_Interface, RE_RACW_Stub_Type_Access => System_Partition_Interface, *************** package Rtsfind is *** 2212,2217 **** --- 2305,2311 ---- RE_BS_To_Any => System_Partition_Interface, RE_Any_To_BS => System_Partition_Interface, + RE_FA_A => System_Partition_Interface, RE_FA_B => System_Partition_Interface, RE_FA_C => System_Partition_Interface, RE_FA_F => System_Partition_Interface, *************** package Rtsfind is *** 2260,2266 **** RE_TC_Build => System_Partition_Interface, RE_Get_TC => System_Partition_Interface, RE_Set_TC => System_Partition_Interface, ! RE_TC_Any => System_Partition_Interface, RE_TC_B => System_Partition_Interface, RE_TC_C => System_Partition_Interface, RE_TC_F => System_Partition_Interface, --- 2354,2360 ---- RE_TC_Build => System_Partition_Interface, RE_Get_TC => System_Partition_Interface, RE_Set_TC => System_Partition_Interface, ! RE_TC_A => System_Partition_Interface, RE_TC_B => System_Partition_Interface, RE_TC_C => System_Partition_Interface, RE_TC_F => System_Partition_Interface, *************** package Rtsfind is *** 2321,2331 **** RE_SS_Pool => System_Secondary_Stack, RE_SS_Release => System_Secondary_Stack, - RE_Shared_Var_Close => System_Shared_Storage, RE_Shared_Var_Lock => System_Shared_Storage, - RE_Shared_Var_ROpen => System_Shared_Storage, RE_Shared_Var_Unlock => System_Shared_Storage, ! RE_Shared_Var_WOpen => System_Shared_Storage, RE_Abort_Undefer_Direct => System_Standard_Library, RE_Exception_Code => System_Standard_Library, --- 2415,2423 ---- RE_SS_Pool => System_Secondary_Stack, RE_SS_Release => System_Secondary_Stack, RE_Shared_Var_Lock => System_Shared_Storage, RE_Shared_Var_Unlock => System_Shared_Storage, ! RE_Shared_Var_Procs => System_Shared_Storage, RE_Abort_Undefer_Direct => System_Standard_Library, RE_Exception_Code => System_Standard_Library, *************** package Rtsfind is *** 2335,2341 **** RE_Storage_Offset => System_Storage_Elements, RE_Storage_Array => System_Storage_Elements, RE_To_Address => System_Storage_Elements, - RE_Dummy_Communication_Block => System_Storage_Elements, RE_Root_Storage_Pool => System_Storage_Pools, RE_Allocate_Any => System_Storage_Pools, --- 2427,2432 ---- *************** package Rtsfind is *** 2394,2399 **** --- 2485,2515 ---- RE_Str_Concat_5 => System_String_Ops_Concat_5, + RE_String_Input => System_Strings_Stream_Ops, + RE_String_Input_Blk_IO => System_Strings_Stream_Ops, + RE_String_Output => System_Strings_Stream_Ops, + RE_String_Output_Blk_IO => System_Strings_Stream_Ops, + RE_String_Read => System_Strings_Stream_Ops, + RE_String_Read_Blk_IO => System_Strings_Stream_Ops, + RE_String_Write => System_Strings_Stream_Ops, + RE_String_Write_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_String_Input => System_Strings_Stream_Ops, + RE_Wide_String_Input_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_String_Output => System_Strings_Stream_Ops, + RE_Wide_String_Output_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_String_Read => System_Strings_Stream_Ops, + RE_Wide_String_Read_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_String_Write => System_Strings_Stream_Ops, + RE_Wide_String_Write_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Input => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Input_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Output => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Output_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Read => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Read_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Write => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Write_Blk_IO => System_Strings_Stream_Ops, + RE_Task_Info_Type => System_Task_Info, RE_Unspecified_Task_Info => System_Task_Info, *************** package Rtsfind is *** 2433,2438 **** --- 2549,2555 ---- RE_Abort_Undefer => System_Soft_Links, RE_Complete_Master => System_Soft_Links, RE_Current_Master => System_Soft_Links, + RE_Dummy_Communication_Block => System_Soft_Links, RE_Enter_Master => System_Soft_Links, RE_Get_Current_Excep => System_Soft_Links, RE_Get_GNAT_Exception => System_Soft_Links, *************** package Rtsfind is *** 2508,2513 **** --- 2625,2633 ---- RE_Mul_G => System_Vax_Float_Operations, RE_Neg_F => System_Vax_Float_Operations, RE_Neg_G => System_Vax_Float_Operations, + RE_Return_D => System_Vax_Float_Operations, + RE_Return_F => System_Vax_Float_Operations, + RE_Return_G => System_Vax_Float_Operations, RE_Sub_F => System_Vax_Float_Operations, RE_Sub_G => System_Vax_Float_Operations, *************** package Rtsfind is *** 2581,2588 **** --- 2701,2711 ---- System_Tasking_Protected_Objects_Entries, RO_PE_Set_Ceiling => System_Tasking_Protected_Objects_Entries, + RO_PE_Set_Entry_Name => + System_Tasking_Protected_Objects_Entries, RE_Unlock_Entries => System_Tasking_Protected_Objects_Entries, + RE_Communication_Block => System_Tasking_Protected_Objects_Operations, RE_Protected_Entry_Call => *************** package Rtsfind is *** 2683,2688 **** --- 2806,2812 ---- RE_Free_Task => System_Tasking_Stages, RE_Expunge_Unactivated_Tasks => System_Tasking_Stages, RE_Move_Activation_Chain => System_Tasking_Stages, + RO_TS_Set_Entry_Name => System_Tasking_Stages, RE_Terminated => System_Tasking_Stages); -------------------------------- *************** package Rtsfind is *** 2719,2725 **** -- run-time library, but allows only a subset of entities to be -- accessed. If any other entity is accessed, then it is treated -- as a configurable run-time violation, and the exception ! -- RE_Not_Availble is raised. -- The following array defines the set of units that contain entities -- that can be referenced in No_Run_Time mode. For each of these units, --- 2843,2849 ---- -- run-time library, but allows only a subset of entities to be -- accessed. If any other entity is accessed, then it is treated -- as a configurable run-time violation, and the exception ! -- RE_Not_Available is raised. -- The following array defines the set of units that contain entities -- that can be referenced in No_Run_Time mode. For each of these units, diff -Nrcpad gcc-4.3.3/gcc/ada/s-addima.adb gcc-4.4.0/gcc/ada/s-addima.adb *** gcc-4.3.3/gcc/ada/s-addima.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-addima.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-addima.ads gcc-4.4.0/gcc/ada/s-addima.ads *** gcc-4.3.3/gcc/ada/s-addima.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-addima.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2003 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-addope.adb gcc-4.4.0/gcc/ada/s-addope.adb *** gcc-4.3.3/gcc/ada/s-addope.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-addope.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-addope.ads gcc-4.4.0/gcc/ada/s-addope.ads *** gcc-4.3.3/gcc/ada/s-addope.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-addope.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-arit64.adb gcc-4.4.0/gcc/ada/s-arit64.adb *** gcc-4.3.3/gcc/ada/s-arit64.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-arit64.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-arit64.ads gcc-4.4.0/gcc/ada/s-arit64.ads *** gcc-4.3.3/gcc/ada/s-arit64.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-arit64.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Arith_64 is *** 63,69 **** -- or if the quotient does not fit in 64-bits. Round indicates if -- the result should be rounded. If Round is False, then Q, R are -- the normal quotient and remainder from a truncating division. ! -- If Round is True, then Q is the rounded quotient. the remainder -- R is not affected by the setting of the Round flag. procedure Double_Divide --- 61,67 ---- -- or if the quotient does not fit in 64-bits. Round indicates if -- the result should be rounded. If Round is False, then Q, R are -- the normal quotient and remainder from a truncating division. ! -- If Round is True, then Q is the rounded quotient. The remainder -- R is not affected by the setting of the Round flag. procedure Double_Divide diff -Nrcpad gcc-4.3.3/gcc/ada/s-assert.adb gcc-4.4.0/gcc/ada/s-assert.adb *** gcc-4.3.3/gcc/ada/s-assert.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-assert.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-assert.ads gcc-4.4.0/gcc/ada/s-assert.ads *** gcc-4.3.3/gcc/ada/s-assert.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-assert.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-asthan-vms-alpha.adb gcc-4.4.0/gcc/ada/s-asthan-vms-alpha.adb *** gcc-4.3.3/gcc/ada/s-asthan-vms-alpha.adb Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-asthan-vms-alpha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.AST_Handling is *** 149,155 **** -- Note: When we say it works fine, there is one delicate point, which -- is that the code for the AST procedure itself requires the original ! -- descriptor address. We handle this by saving the orignal descriptor -- address in this structure and restoring in Process_AST. type AST_Handler_Data is record --- 147,153 ---- -- Note: When we say it works fine, there is one delicate point, which -- is that the code for the AST procedure itself requires the original ! -- descriptor address. We handle this by saving the original descriptor -- address in this structure and restoring in Process_AST. type AST_Handler_Data is record *************** package body System.AST_Handling is *** 237,243 **** -- number of AST instances that can be stored in the buffer. Since -- these entries are immediately serviced by the high priority server -- task that does the actual entry queuing, it is very unusual to have ! -- any significant number of entries simulaneously queued. AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance; pragma Volatile_Components (AST_Service_Queue); --- 235,241 ---- -- number of AST instances that can be stored in the buffer. Since -- these entries are immediately serviced by the high priority server -- task that does the actual entry queuing, it is very unusual to have ! -- any significant number of entries simultaneously queued. AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance; pragma Volatile_Components (AST_Service_Queue); *************** package body System.AST_Handling is *** 545,560 **** -- from which we can obtain the task and entry number information. function To_Address is new Ada.Unchecked_Conversion ! (ST.Task_Id, System.Address); begin System.Machine_Code.Asm ! (Template => "addl $27,0,%0", Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr), Volatile => True); System.Machine_Code.Asm ! (Template => "ldl $27,%0", Inputs => Descriptor_Ref'Asm_Input ("m", Handler_Data_Ptr.Original_Descriptor_Ref), Volatile => True); --- 543,558 ---- -- from which we can obtain the task and entry number information. function To_Address is new Ada.Unchecked_Conversion ! (ST.Task_Id, System.Task_Primitives.Task_Address); begin System.Machine_Code.Asm ! (Template => "addq $27,0,%0", Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr), Volatile => True); System.Machine_Code.Asm ! (Template => "ldq $27,%0", Inputs => Descriptor_Ref'Asm_Input ("m", Handler_Data_Ptr.Original_Descriptor_Ref), Volatile => True); diff -Nrcpad gcc-4.3.3/gcc/ada/s-asthan.adb gcc-4.4.0/gcc/ada/s-asthan.adb *** gcc-4.3.3/gcc/ada/s-asthan.adb Wed Feb 15 09:29:17 2006 --- gcc-4.4.0/gcc/ada/s-asthan.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 33,44 **** -- This is the dummy version used on non-VMS systems - with Ada.Exceptions; - package body System.AST_Handling is - pragma Warnings (Off); -- kill warnings on unreferenced formals - ------------------------ -- Create_AST_Handler -- ------------------------ --- 31,38 ---- *************** package body System.AST_Handling is *** 48,57 **** Entryno : Natural) return System.Aux_DEC.AST_Handler is begin ! Ada.Exceptions.Raise_Exception ! (E => Program_Error'Identity, ! Message => "AST is implemented only on VMS systems"); ! return System.Aux_DEC.No_AST_Handler; end Create_AST_Handler; --- 42,48 ---- Entryno : Natural) return System.Aux_DEC.AST_Handler is begin ! raise Program_Error with "AST is implemented only on VMS systems"; return System.Aux_DEC.No_AST_Handler; end Create_AST_Handler; *************** package body System.AST_Handling is *** 61,72 **** Total_Number : out Natural) is begin ! Ada.Exceptions.Raise_Exception ! (E => Program_Error'Identity, ! Message => "AST is implemented only on VMS systems"); ! ! Actual_Number := 0; ! Total_Number := 0; end Expand_AST_Packet_Pool; end System.AST_Handling; --- 52,58 ---- Total_Number : out Natural) is begin ! raise Program_Error with "AST is implemented only on VMS systems"; end Expand_AST_Packet_Pool; end System.AST_Handling; diff -Nrcpad gcc-4.3.3/gcc/ada/s-asthan.ads gcc-4.4.0/gcc/ada/s-asthan.ads *** gcc-4.3.3/gcc/ada/s-asthan.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-asthan.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-atacco.adb gcc-4.4.0/gcc/ada/s-atacco.adb *** gcc-4.3.3/gcc/ada/s-atacco.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-atacco.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-atacco.ads gcc-4.4.0/gcc/ada/s-atacco.ads *** gcc-4.3.3/gcc/ada/s-atacco.ads Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/s-atacco.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-auxdec-empty.adb gcc-4.4.0/gcc/ada/s-auxdec-empty.adb *** gcc-4.3.3/gcc/ada/s-auxdec-empty.adb Thu Nov 17 11:13:18 2005 --- gcc-4.4.0/gcc/ada/s-auxdec-empty.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005 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- -- ! -- ware Foundation; either version 2, Or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- Or FITNESS FOr A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- fOr mOre details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, Or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005,2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-auxdec-empty.ads gcc-4.4.0/gcc/ada/s-auxdec-empty.ads *** gcc-4.3.3/gcc/ada/s-auxdec-empty.ads Thu Nov 17 11:13:18 2005 --- gcc-4.4.0/gcc/ada/s-auxdec-empty.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS For A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-auxdec-vms_64.ads gcc-4.4.0/gcc/ada/s-auxdec-vms_64.ads *** gcc-4.3.3/gcc/ada/s-auxdec-vms_64.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-auxdec-vms_64.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS For A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Aux_DEC is *** 96,104 **** function "or" (Left, Right : Largest_Integer) return Largest_Integer; function "xor" (Left, Right : Largest_Integer) return Largest_Integer; ! Address_Zero : constant Address; ! No_Addr : constant Address; ! Address_Size : constant := Standard'Address_Size; function "+" (Left : Address; Right : Integer) return Address; function "+" (Left : Integer; Right : Address) return Address; --- 94,103 ---- function "or" (Left, Right : Largest_Integer) return Largest_Integer; function "xor" (Left, Right : Largest_Integer) return Largest_Integer; ! Address_Zero : constant Address; ! No_Addr : constant Address; ! Address_Size : constant := Standard'Address_Size; ! Short_Address_Size : constant := 32; function "+" (Left : Address; Right : Integer) return Address; function "+" (Left : Integer; Right : Address) return Address; diff -Nrcpad gcc-4.3.3/gcc/ada/s-auxdec.adb gcc-4.4.0/gcc/ada/s-auxdec.adb *** gcc-4.3.3/gcc/ada/s-auxdec.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-auxdec.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, Or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- Or FITNESS FOr A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- fOr mOre details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, Or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-auxdec.ads gcc-4.4.0/gcc/ada/s-auxdec.ads *** gcc-4.3.3/gcc/ada/s-auxdec.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-auxdec.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS For A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Aux_DEC is *** 48,54 **** -- name Short_Address is used for the short address form. To avoid -- difficulties (in regression tests and elsewhere) with units that -- reference Short_Address, it is provided for other targets as a ! -- synonum for the normal Address type, and, as in the case where -- the lengths are different, Address and Short_Address can be -- freely inter-converted. --- 46,52 ---- -- name Short_Address is used for the short address form. To avoid -- difficulties (in regression tests and elsewhere) with units that -- reference Short_Address, it is provided for other targets as a ! -- synonym for the normal Address type, and, as in the case where -- the lengths are different, Address and Short_Address can be -- freely inter-converted. *************** package System.Aux_DEC is *** 86,94 **** function "or" (Left, Right : Largest_Integer) return Largest_Integer; function "xor" (Left, Right : Largest_Integer) return Largest_Integer; ! Address_Zero : constant Address; ! No_Addr : constant Address; ! Address_Size : constant := Standard'Address_Size; function "+" (Left : Address; Right : Integer) return Address; function "+" (Left : Integer; Right : Address) return Address; --- 84,93 ---- function "or" (Left, Right : Largest_Integer) return Largest_Integer; function "xor" (Left, Right : Largest_Integer) return Largest_Integer; ! Address_Zero : constant Address; ! No_Addr : constant Address; ! Address_Size : constant := Standard'Address_Size; ! Short_Address_Size : constant := Standard'Address_Size; function "+" (Left : Address; Right : Integer) return Address; function "+" (Left : Integer; Right : Address) return Address; diff -Nrcpad gcc-4.3.3/gcc/ada/s-bitops.adb gcc-4.4.0/gcc/ada/s-bitops.adb *** gcc-4.3.3/gcc/ada/s-bitops.adb Wed Jun 6 10:41:35 2007 --- gcc-4.4.0/gcc/ada/s-bitops.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-bitops.ads gcc-4.4.0/gcc/ada/s-bitops.ads *** gcc-4.3.3/gcc/ada/s-bitops.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-bitops.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-boarop.ads gcc-4.4.0/gcc/ada/s-boarop.ads *** gcc-4.3.3/gcc/ada/s-boarop.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-boarop.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-carsi8.adb gcc-4.4.0/gcc/ada/s-carsi8.adb *** gcc-4.3.3/gcc/ada/s-carsi8.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-carsi8.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Compare_Array_Signed *** 42,47 **** --- 40,46 ---- type Big_Words is array (Natural) of Word; type Big_Words_Ptr is access Big_Words; + for Big_Words_Ptr'Storage_Size use 0; -- Array type used to access by words type Byte is range -128 .. +127; *************** package body System.Compare_Array_Signed *** 50,55 **** --- 49,55 ---- type Big_Bytes is array (Natural) of Byte; type Big_Bytes_Ptr is access Big_Bytes; + for Big_Bytes_Ptr'Storage_Size use 0; -- Array type used to access by bytes function To_Big_Words is new diff -Nrcpad gcc-4.3.3/gcc/ada/s-carsi8.ads gcc-4.4.0/gcc/ada/s-carsi8.ads *** gcc-4.3.3/gcc/ada/s-carsi8.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-carsi8.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-carun8.adb gcc-4.4.0/gcc/ada/s-carun8.adb *** gcc-4.3.3/gcc/ada/s-carun8.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-carun8.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Compare_Array_Unsign *** 46,51 **** --- 44,50 ---- type Big_Words is array (Natural) of Word; type Big_Words_Ptr is access Big_Words; + for Big_Words_Ptr'Storage_Size use 0; -- Array type used to access by words type Byte is mod 2 ** 8; *************** package body System.Compare_Array_Unsign *** 53,58 **** --- 52,58 ---- type Big_Bytes is array (Natural) of Byte; type Big_Bytes_Ptr is access Big_Bytes; + for Big_Bytes_Ptr'Storage_Size use 0; -- Array type used to access by bytes function To_Big_Words is new diff -Nrcpad gcc-4.3.3/gcc/ada/s-carun8.ads gcc-4.4.0/gcc/ada/s-carun8.ads *** gcc-4.3.3/gcc/ada/s-carun8.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-carun8.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Compare_Array_Unsigned_8 *** 49,68 **** Right : System.Address; Left_Len : Natural; Right_Len : Natural) return Integer; ! -- Compare the array starting at address Left of length Left_Len ! -- with the array starting at address Right of length Right_Len. ! -- The comparison is in the normal Ada semantic sense of array ! -- comparison. The result is -1,0,+1 for LeftRight respectively. This function works with 4 byte words ! -- if the operands are aligned on 4-byte boundaries and long enough. function Compare_Array_U8_Unaligned (Left : System.Address; Right : System.Address; Left_Len : Natural; Right_Len : Natural) return Integer; ! -- Same functionality as Compare_Array_U8 but always proceeds by ! -- bytes. Used when the caller knows that the operands are unaligned, ! -- or short enough that it makes no sense to go by words. end System.Compare_Array_Unsigned_8; --- 47,66 ---- Right : System.Address; Left_Len : Natural; Right_Len : Natural) return Integer; ! -- Compare the array starting at address Left of length Left_Len with the ! -- array starting at address Right of length Right_Len. The comparison is ! -- in the normal Ada semantic sense of array comparison. The result is -1, ! -- 0, +1 for Left < Right, Left = Right, Left > Right respectively. This ! -- function works with 4 byte words if the operands are aligned on 4-byte ! -- boundaries and long enough. function Compare_Array_U8_Unaligned (Left : System.Address; Right : System.Address; Left_Len : Natural; Right_Len : Natural) return Integer; ! -- Same functionality as Compare_Array_U8 but always proceeds by bytes. ! -- Used when the caller knows that the operands are unaligned, or short ! -- enough that it makes no sense to go by words. end System.Compare_Array_Unsigned_8; diff -Nrcpad gcc-4.3.3/gcc/ada/s-casi16.adb gcc-4.4.0/gcc/ada/s-casi16.adb *** gcc-4.3.3/gcc/ada/s-casi16.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-casi16.adb Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME LIBRARY COMPONENTS -- -- -- ! -- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 16 -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY COMPONENTS -- -- -- ! -- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 1 6 -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Compare_Array_Signed *** 44,53 **** for Half'Size use 16; -- Used to process operands by half words ! type Uhalf is record ! H : Half; ! end record; ! pragma Pack (Uhalf); for Uhalf'Alignment use 1; -- Used to process operands when unaligned --- 42,48 ---- for Half'Size use 16; -- Used to process operands by half words ! type Uhalf is new Half; for Uhalf'Alignment use 1; -- Used to process operands when unaligned *************** package body System.Compare_Array_Signed *** 110,117 **** else while Clen /= 0 loop ! if U (L).H /= U (R).H then ! if U (L).H > U (R).H then return +1; else return -1; --- 105,112 ---- else while Clen /= 0 loop ! if U (L).all /= U (R).all then ! if U (L).all > U (R).all then return +1; else return -1; diff -Nrcpad gcc-4.3.3/gcc/ada/s-casi16.ads gcc-4.4.0/gcc/ada/s-casi16.ads *** gcc-4.3.3/gcc/ada/s-casi16.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-casi16.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-casi32.adb gcc-4.4.0/gcc/ada/s-casi32.adb *** gcc-4.3.3/gcc/ada/s-casi32.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-casi32.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Compare_Array_Signed *** 41,50 **** for Word'Size use 32; -- Used to process operands by words ! type Uword is record ! W : Word; ! end record; ! pragma Pack (Uword); for Uword'Alignment use 1; -- Used to process operands when unaligned --- 39,45 ---- for Word'Size use 32; -- Used to process operands by words ! type Uword is new Word; for Uword'Alignment use 1; -- Used to process operands when unaligned *************** package body System.Compare_Array_Signed *** 93,100 **** else while Clen /= 0 loop ! if U (L).W /= U (R).W then ! if U (L).W > U (R).W then return +1; else return -1; --- 88,95 ---- else while Clen /= 0 loop ! if U (L).all /= U (R).all then ! if U (L).all > U (R).all then return +1; else return -1; diff -Nrcpad gcc-4.3.3/gcc/ada/s-casi32.ads gcc-4.4.0/gcc/ada/s-casi32.ads *** gcc-4.3.3/gcc/ada/s-casi32.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-casi32.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-casi64.adb gcc-4.4.0/gcc/ada/s-casi64.adb *** gcc-4.3.3/gcc/ada/s-casi64.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-casi64.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Compare_Array_Signed *** 41,50 **** for Word'Size use 64; -- Used to process operands by words ! type Uword is record ! W : Word; ! end record; ! pragma Pack (Uword); for Uword'Alignment use 1; -- Used to process operands when unaligned --- 39,45 ---- for Word'Size use 64; -- Used to process operands by words ! type Uword is new Word; for Uword'Alignment use 1; -- Used to process operands when unaligned *************** package body System.Compare_Array_Signed *** 93,100 **** else while Clen /= 0 loop ! if U (L).W /= U (R).W then ! if U (L).W > U (R).W then return +1; else return -1; --- 88,95 ---- else while Clen /= 0 loop ! if U (L).all /= U (R).all then ! if U (L).all > U (R).all then return +1; else return -1; diff -Nrcpad gcc-4.3.3/gcc/ada/s-casi64.ads gcc-4.4.0/gcc/ada/s-casi64.ads *** gcc-4.3.3/gcc/ada/s-casi64.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-casi64.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-casuti.ads gcc-4.4.0/gcc/ada/s-casuti.ads *** gcc-4.3.3/gcc/ada/s-casuti.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-casuti.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Case_Util is *** 53,59 **** -- returns the input argument unchanged. procedure To_Upper (A : in out String); ! -- Folds all characters of string A to upper csae function To_Lower (A : Character) return Character; -- Converts A to lower case if it is an upper case letter, otherwise --- 51,57 ---- -- returns the input argument unchanged. procedure To_Upper (A : in out String); ! -- Folds all characters of string A to upper case function To_Lower (A : Character) return Character; -- Converts A to lower case if it is an upper case letter, otherwise diff -Nrcpad gcc-4.3.3/gcc/ada/s-caun16.adb gcc-4.4.0/gcc/ada/s-caun16.adb *** gcc-4.3.3/gcc/ada/s-caun16.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-caun16.adb Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME LIBRARY COMPONENTS -- -- -- ! -- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 16 -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY COMPONENTS -- -- -- ! -- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 1 6 -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Compare_Array_Unsign *** 44,53 **** for Half'Size use 16; -- Used to process operands by half words ! type Uhalf is record ! H : Half; ! end record; ! pragma Pack (Uhalf); for Uhalf'Alignment use 1; -- Used to process operands when unaligned --- 42,48 ---- for Half'Size use 16; -- Used to process operands by half words ! type Uhalf is new Half; for Uhalf'Alignment use 1; -- Used to process operands when unaligned *************** package body System.Compare_Array_Unsign *** 110,117 **** else while Clen /= 0 loop ! if U (L).H /= U (R).H then ! if U (L).H > U (R).H then return +1; else return -1; --- 105,112 ---- else while Clen /= 0 loop ! if U (L).all /= U (R).all then ! if U (L).all > U (R).all then return +1; else return -1; diff -Nrcpad gcc-4.3.3/gcc/ada/s-caun16.ads gcc-4.4.0/gcc/ada/s-caun16.ads *** gcc-4.3.3/gcc/ada/s-caun16.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-caun16.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-caun32.adb gcc-4.4.0/gcc/ada/s-caun32.adb *** gcc-4.3.3/gcc/ada/s-caun32.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-caun32.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Compare_Array_Unsign *** 41,50 **** for Word'Size use 32; -- Used to process operands by words ! type Uword is record ! W : Word; ! end record; ! pragma Pack (Uword); for Uword'Alignment use 1; -- Used to process operands when unaligned --- 39,45 ---- for Word'Size use 32; -- Used to process operands by words ! type Uword is new Word; for Uword'Alignment use 1; -- Used to process operands when unaligned *************** package body System.Compare_Array_Unsign *** 93,100 **** else while Clen /= 0 loop ! if U (L).W /= U (R).W then ! if U (L).W > U (R).W then return +1; else return -1; --- 88,95 ---- else while Clen /= 0 loop ! if U (L).all /= U (R).all then ! if U (L).all > U (R).all then return +1; else return -1; diff -Nrcpad gcc-4.3.3/gcc/ada/s-caun32.ads gcc-4.4.0/gcc/ada/s-caun32.ads *** gcc-4.3.3/gcc/ada/s-caun32.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-caun32.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-caun64.adb gcc-4.4.0/gcc/ada/s-caun64.adb *** gcc-4.3.3/gcc/ada/s-caun64.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-caun64.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Compare_Array_Unsign *** 40,49 **** type Word is mod 2 ** 64; -- Used to process operands by words ! type Uword is record ! W : Word; ! end record; ! pragma Pack (Uword); for Uword'Alignment use 1; -- Used to process operands when unaligned --- 38,44 ---- type Word is mod 2 ** 64; -- Used to process operands by words ! type Uword is new Word; for Uword'Alignment use 1; -- Used to process operands when unaligned *************** package body System.Compare_Array_Unsign *** 92,99 **** else while Clen /= 0 loop ! if U (L).W /= U (R).W then ! if U (L).W > U (R).W then return +1; else return -1; --- 87,94 ---- else while Clen /= 0 loop ! if U (L).all /= U (R).all then ! if U (L).all > U (R).all then return +1; else return -1; diff -Nrcpad gcc-4.3.3/gcc/ada/s-caun64.ads gcc-4.4.0/gcc/ada/s-caun64.ads *** gcc-4.3.3/gcc/ada/s-caun64.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-caun64.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-chepoo.ads gcc-4.4.0/gcc/ada/s-chepoo.ads *** gcc-4.3.3/gcc/ada/s-chepoo.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-chepoo.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-crc32.adb gcc-4.4.0/gcc/ada/s-crc32.adb *** gcc-4.3.3/gcc/ada/s-crc32.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-crc32.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-crc32.ads gcc-4.4.0/gcc/ada/s-crc32.ads *** gcc-4.3.3/gcc/ada/s-crc32.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-crc32.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-crtl.ads gcc-4.4.0/gcc/ada/s-crtl.ads *** gcc-4.3.3/gcc/ada/s-crtl.ads Fri Apr 6 09:23:12 2007 --- gcc-4.4.0/gcc/ada/s-crtl.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.CRTL is *** 133,138 **** --- 131,141 ---- function malloc (Size : size_t) return System.Address; pragma Import (C, malloc, "malloc"); + function malloc32 (Size : size_t) return System.Address; + pragma Import (C, malloc32, "malloc"); + -- An uncalled alias for malloc except on 64bit systems needing to + -- allocate 32bit memory. + procedure memcpy (S1 : System.Address; S2 : System.Address; N : size_t); pragma Import (C, memcpy, "memcpy"); *************** package System.CRTL is *** 148,160 **** function popen (command, mode : System.Address) return System.Address; pragma Import (C, popen, "popen"); - function read (fd : int; buffer : chars; nbytes : int) return int; - pragma Import (C, read, "read"); - function realloc (Ptr : System.Address; Size : size_t) return System.Address; pragma Import (C, realloc, "realloc"); procedure rewind (stream : FILEs); pragma Import (C, rewind, "rewind"); --- 151,166 ---- function popen (command, mode : System.Address) return System.Address; pragma Import (C, popen, "popen"); function realloc (Ptr : System.Address; Size : size_t) return System.Address; pragma Import (C, realloc, "realloc"); + function realloc32 + (Ptr : System.Address; Size : size_t) return System.Address; + pragma Import (C, realloc32, "realloc"); + -- An uncalled alias for realloc except on 64bit systems needing to + -- allocate 32bit memory. + procedure rewind (stream : FILEs); pragma Import (C, rewind, "rewind"); *************** package System.CRTL is *** 181,186 **** --- 187,201 ---- function unlink (filename : chars) return int; pragma Import (C, unlink, "unlink"); + function open (filename : chars; oflag : int) return int; + pragma Import (C, open, "open"); + + function close (fd : int) return int; + pragma Import (C, close, "close"); + + function read (fd : int; buffer : chars; nbytes : int) return int; + pragma Import (C, read, "read"); + function write (fd : int; buffer : chars; nbytes : int) return int; pragma Import (C, write, "write"); diff -Nrcpad gcc-4.3.3/gcc/ada/s-direio.adb gcc-4.4.0/gcc/ada/s-direio.adb *** gcc-4.3.3/gcc/ada/s-direio.adb Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-direio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Direct_IO is *** 251,265 **** ----------- procedure Reset (File : in out File_Type; Mode : FCB.File_Mode) is begin ! FIO.Reset (AP (File), Mode); File.Index := 1; File.Last_Op := Op_Read; end Reset; procedure Reset (File : in out File_Type) is begin ! FIO.Reset (AP (File)); File.Index := 1; File.Last_Op := Op_Read; end Reset; --- 249,273 ---- ----------- procedure Reset (File : in out File_Type; Mode : FCB.File_Mode) is + pragma Warnings (Off, File); + -- File is actually modified via Unrestricted_Access below, but + -- GNAT will generate a warning anyway. + -- Note that we do not use pragma Unmodified here, since in -gnatc + -- mode, GNAT will complain that File is modified for + -- "File.Index := 1;" + begin ! FIO.Reset (AP (File)'Unrestricted_Access, Mode); File.Index := 1; File.Last_Op := Op_Read; end Reset; procedure Reset (File : in out File_Type) is + pragma Warnings (Off, File); + -- See above (other Reset procedure) for explanations on this pragma + begin ! FIO.Reset (AP (File)'Unrestricted_Access); File.Index := 1; File.Last_Op := Op_Read; end Reset; diff -Nrcpad gcc-4.3.3/gcc/ada/s-direio.ads gcc-4.4.0/gcc/ada/s-direio.ads *** gcc-4.3.3/gcc/ada/s-direio.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-direio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Direct_IO is *** 111,117 **** Size : Interfaces.C_Streams.size_t); procedure Reset (File : in out File_Type; Mode : FCB.File_Mode); - procedure Reset (File : in out File_Type); procedure Set_Index (File : File_Type; To : Positive_Count); --- 109,114 ---- *************** package System.Direct_IO is *** 125,128 **** --- 122,142 ---- Zeroes : System.Storage_Elements.Storage_Array); -- Note: Zeroes is the buffer of zeroes used to fill out partial records + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, FCB.File_Mode), + Mechanism => (File => Reference)); + end System.Direct_IO; diff -Nrcpad gcc-4.3.3/gcc/ada/s-dsaser.ads gcc-4.4.0/gcc/ada/s-dsaser.ads *** gcc-4.3.3/gcc/ada/s-dsaser.ads Wed Sep 12 11:59:17 2007 --- gcc-4.4.0/gcc/ada/s-dsaser.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2009 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-except.adb gcc-4.4.0/gcc/ada/s-except.adb *** gcc-4.3.3/gcc/ada/s-except.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-except.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-except.ads gcc-4.4.0/gcc/ada/s-except.ads *** gcc-4.3.3/gcc/ada/s-except.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-except.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-exctab.adb gcc-4.4.0/gcc/ada/s-exctab.adb *** gcc-4.3.3/gcc/ada/s-exctab.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-exctab.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-exctab.ads gcc-4.4.0/gcc/ada/s-exctab.ads *** gcc-4.3.3/gcc/ada/s-exctab.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-exctab.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-exnint.adb gcc-4.4.0/gcc/ada/s-exnint.adb *** gcc-4.3.3/gcc/ada/s-exnint.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-exnint.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-exnint.ads gcc-4.4.0/gcc/ada/s-exnint.ads *** gcc-4.3.3/gcc/ada/s-exnint.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-exnint.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-exnllf.adb gcc-4.4.0/gcc/ada/s-exnllf.adb *** gcc-4.3.3/gcc/ada/s-exnllf.adb Tue Nov 15 14:05:30 2005 --- gcc-4.4.0/gcc/ada/s-exnllf.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-exnllf.ads gcc-4.4.0/gcc/ada/s-exnllf.ads *** gcc-4.3.3/gcc/ada/s-exnllf.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-exnllf.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-exnlli.adb gcc-4.4.0/gcc/ada/s-exnlli.adb *** gcc-4.3.3/gcc/ada/s-exnlli.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-exnlli.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-exnlli.ads gcc-4.4.0/gcc/ada/s-exnlli.ads *** gcc-4.3.3/gcc/ada/s-exnlli.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-exnlli.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-expint.adb gcc-4.4.0/gcc/ada/s-expint.adb *** gcc-4.3.3/gcc/ada/s-expint.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-expint.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-expint.ads gcc-4.4.0/gcc/ada/s-expint.ads *** gcc-4.3.3/gcc/ada/s-expint.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-expint.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-explli.adb gcc-4.4.0/gcc/ada/s-explli.adb *** gcc-4.3.3/gcc/ada/s-explli.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-explli.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-explli.ads gcc-4.4.0/gcc/ada/s-explli.ads *** gcc-4.3.3/gcc/ada/s-explli.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-explli.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-expllu.adb gcc-4.4.0/gcc/ada/s-expllu.adb *** gcc-4.3.3/gcc/ada/s-expllu.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-expllu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-expllu.ads gcc-4.4.0/gcc/ada/s-expllu.ads *** gcc-4.3.3/gcc/ada/s-expllu.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-expllu.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-expmod.adb gcc-4.4.0/gcc/ada/s-expmod.adb *** gcc-4.3.3/gcc/ada/s-expmod.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-expmod.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-expmod.ads gcc-4.4.0/gcc/ada/s-expmod.ads *** gcc-4.3.3/gcc/ada/s-expmod.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-expmod.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-expuns.adb gcc-4.4.0/gcc/ada/s-expuns.adb *** gcc-4.3.3/gcc/ada/s-expuns.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-expuns.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-expuns.ads gcc-4.4.0/gcc/ada/s-expuns.ads *** gcc-4.3.3/gcc/ada/s-expuns.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-expuns.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-fatflt.ads gcc-4.4.0/gcc/ada/s-fatflt.ads *** gcc-4.3.3/gcc/ada/s-fatflt.ads Tue Nov 15 13:57:25 2005 --- gcc-4.4.0/gcc/ada/s-fatflt.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** with System.Fat_Gen; *** 39,45 **** package System.Fat_Flt is pragma Pure; ! -- Note the only entity from this package that is acccessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. --- 37,43 ---- package System.Fat_Flt is pragma Pure; ! -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. diff -Nrcpad gcc-4.3.3/gcc/ada/s-fatgen.adb gcc-4.4.0/gcc/ada/s-fatgen.adb *** gcc-4.3.3/gcc/ada/s-fatgen.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/s-fatgen.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Fat_Gen is *** 54,60 **** Invrad : constant T := 1.0 / Rad; subtype Expbits is Integer range 0 .. 6; ! -- 2 ** (2 ** 7) might overflow. how big can radix-16 exponents get? Log_Power : constant array (Expbits) of Integer := (1, 2, 4, 8, 16, 32, 64); --- 52,58 ---- Invrad : constant T := 1.0 / Rad; subtype Expbits is Integer range 0 .. 6; ! -- 2 ** (2 ** 7) might overflow. How big can radix-16 exponents get? Log_Power : constant array (Expbits) of Integer := (1, 2, 4, 8, 16, 32, 64); *************** package body System.Fat_Gen is *** 569,575 **** return X; end if; ! -- Nonzero x. essentially, just multiply repeatedly by Rad ** (+-2**n) declare Y : T := X; --- 567,573 ---- return X; end if; ! -- Nonzero x essentially, just multiply repeatedly by Rad ** (+-2**n) declare Y : T := X; *************** package body System.Fat_Gen is *** 660,666 **** -- since the exponent is going to be reduced. -- Note that X_Frac has the same sign as X, so if X_Frac is -0.5, ! -- then we know that we have a ngeative number (and hence a -- negative power of 2). if X_Frac = -0.5 then --- 658,664 ---- -- since the exponent is going to be reduced. -- Note that X_Frac has the same sign as X, so if X_Frac is -0.5, ! -- then we know that we have a negative number (and hence a -- negative power of 2). if X_Frac = -0.5 then *************** package body System.Fat_Gen is *** 809,822 **** -- entire floating-point value. Do not take into account excessive -- padding, as occurs on IA-64 where 80 bits floats get padded to 128 -- bits. In general, the exponent field cannot be larger than 15 bits, ! -- even for 128-bit floating-poin t types, so the final format size -- won't be larger than T'Mantissa + 16. type Float_Rep is array (Rep_Index range 0 .. Rep_Index (Rep_Words - 1)) of Float_Word; pragma Suppress_Initialization (Float_Rep); ! -- This pragma supresses the generation of an initialization procedure -- for type Float_Rep when operating in Initialize/Normalize_Scalars -- mode. This is not just a matter of efficiency, but of functionality, -- since Valid has a pragma Inline_Always, which is not permitted if --- 807,820 ---- -- entire floating-point value. Do not take into account excessive -- padding, as occurs on IA-64 where 80 bits floats get padded to 128 -- bits. In general, the exponent field cannot be larger than 15 bits, ! -- even for 128-bit floating-point types, so the final format size -- won't be larger than T'Mantissa + 16. type Float_Rep is array (Rep_Index range 0 .. Rep_Index (Rep_Words - 1)) of Float_Word; pragma Suppress_Initialization (Float_Rep); ! -- This pragma suppresses the generation of an initialization procedure -- for type Float_Rep when operating in Initialize/Normalize_Scalars -- mode. This is not just a matter of efficiency, but of functionality, -- since Valid has a pragma Inline_Always, which is not permitted if *************** package body System.Fat_Gen is *** 873,880 **** begin if T'Denorm then ! -- All denormalized numbers are valid, so only invalid numbers are ! -- overflows and NaN's, both with exponent = Emax + 1. return E /= IEEE_Emax + 1; --- 871,878 ---- begin if T'Denorm then ! -- All denormalized numbers are valid, so the only invalid numbers ! -- are overflows and NaNs, both with exponent = Emax + 1. return E /= IEEE_Emax + 1; diff -Nrcpad gcc-4.3.3/gcc/ada/s-fatgen.ads gcc-4.4.0/gcc/ada/s-fatgen.ads *** gcc-4.3.3/gcc/ada/s-fatgen.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-fatgen.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-fatlfl.ads gcc-4.4.0/gcc/ada/s-fatlfl.ads *** gcc-4.3.3/gcc/ada/s-fatlfl.ads Tue Nov 15 13:57:25 2005 --- gcc-4.4.0/gcc/ada/s-fatlfl.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** with System.Fat_Gen; *** 39,45 **** package System.Fat_LFlt is pragma Pure; ! -- Note the only entity from this package that is acccessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. --- 37,43 ---- package System.Fat_LFlt is pragma Pure; ! -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. diff -Nrcpad gcc-4.3.3/gcc/ada/s-fatllf.ads gcc-4.4.0/gcc/ada/s-fatllf.ads *** gcc-4.3.3/gcc/ada/s-fatllf.ads Tue Nov 15 13:57:25 2005 --- gcc-4.4.0/gcc/ada/s-fatllf.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** with System.Fat_Gen; *** 39,45 **** package System.Fat_LLF is pragma Pure; ! -- Note the only entity from this package that is acccessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. --- 37,43 ---- package System.Fat_LLF is pragma Pure; ! -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. diff -Nrcpad gcc-4.3.3/gcc/ada/s-fatsfl.ads gcc-4.4.0/gcc/ada/s-fatsfl.ads *** gcc-4.3.3/gcc/ada/s-fatsfl.ads Tue Nov 15 13:57:25 2005 --- gcc-4.4.0/gcc/ada/s-fatsfl.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** with System.Fat_Gen; *** 39,45 **** package System.Fat_SFlt is pragma Pure; ! -- Note the only entity from this package that is acccessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. --- 37,43 ---- package System.Fat_SFlt is pragma Pure; ! -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. diff -Nrcpad gcc-4.3.3/gcc/ada/s-ficobl.ads gcc-4.4.0/gcc/ada/s-ficobl.ads *** gcc-4.3.3/gcc/ada/s-ficobl.ads Tue Aug 14 08:49:26 2007 --- gcc-4.4.0/gcc/ada/s-ficobl.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-fileio.adb gcc-4.4.0/gcc/ada/s-fileio.adb *** gcc-4.3.3/gcc/ada/s-fileio.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/s-fileio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 33,42 **** --- 31,42 ---- with Ada.Finalization; use Ada.Finalization; with Ada.IO_Exceptions; use Ada.IO_Exceptions; + with Interfaces.C; with Interfaces.C_Streams; use Interfaces.C_Streams; with System.CRTL; with System.Case_Util; use System.Case_Util; + with System.OS_Lib; with System.Soft_Links; with Ada.Unchecked_Deallocation; *************** package body System.File_IO is *** 47,52 **** --- 47,53 ---- package SSL renames System.Soft_Links; + use type Interfaces.C.int; use type System.CRTL.size_t; ---------------------- *************** package body System.File_IO is *** 206,214 **** -- Close -- ----------- ! procedure Close (File : in out AFCB_Ptr) is Close_Status : int := 0; Dup_Strm : Boolean := False; begin -- Take a task lock, to protect the global data value Open_Files --- 207,216 ---- -- Close -- ----------- ! procedure Close (File_Ptr : access AFCB_Ptr) is Close_Status : int := 0; Dup_Strm : Boolean := False; + File : AFCB_Ptr renames File_Ptr.all; begin -- Take a task lock, to protect the global data value Open_Files *************** package body System.File_IO is *** 296,302 **** -- Delete -- ------------ ! procedure Delete (File : in out AFCB_Ptr) is begin Check_File_Open (File); --- 298,305 ---- -- Delete -- ------------ ! procedure Delete (File_Ptr : access AFCB_Ptr) is ! File : AFCB_Ptr renames File_Ptr.all; begin Check_File_Open (File); *************** package body System.File_IO is *** 308,314 **** Filename : aliased constant String := File.Name.all; begin ! Close (File); -- Now unlink the external file. Note that we use the full name -- in this unlink, because the working directory may have changed --- 311,317 ---- Filename : aliased constant String := File.Name.all; begin ! Close (File_Ptr); -- Now unlink the external file. Note that we use the full name -- in this unlink, because the working directory may have changed *************** package body System.File_IO is *** 354,360 **** procedure Finalize (V : in out File_IO_Clean_Up_Type) is pragma Warnings (Off, V); ! Fptr1 : AFCB_Ptr; Fptr2 : AFCB_Ptr; Discard : int; --- 357,363 ---- procedure Finalize (V : in out File_IO_Clean_Up_Type) is pragma Warnings (Off, V); ! Fptr1 : aliased AFCB_Ptr; Fptr2 : AFCB_Ptr; Discard : int; *************** package body System.File_IO is *** 371,377 **** Fptr1 := Open_Files; while Fptr1 /= null loop Fptr2 := Fptr1.Next; ! Close (Fptr1); Fptr1 := Fptr2; end loop; --- 374,380 ---- Fptr1 := Open_Files; while Fptr1 /= null loop Fptr2 := Fptr1.Next; ! Close (Fptr1'Access); Fptr1 := Fptr2; end loop; *************** package body System.File_IO is *** 823,835 **** if Stream /= NULL_Stream then Full_Name_Len := Name'Length + 1; Fullname (1 .. Full_Name_Len - 1) := Name; ! Fullname (Full_Name_Len) := ASCII.Nul; -- Normal case of Open or Create else ! -- If temporary file case, get temporary file name and add ! -- to the list of temporary files to be deleted on exit. if Tempfile then if not Creat then --- 826,838 ---- if Stream /= NULL_Stream then Full_Name_Len := Name'Length + 1; Fullname (1 .. Full_Name_Len - 1) := Name; ! Fullname (Full_Name_Len) := ASCII.NUL; -- Normal case of Open or Create else ! -- If temporary file case, get temporary file name and add to the ! -- list of temporary files to be deleted on exit. if Tempfile then if not Creat then *************** package body System.File_IO is *** 963,969 **** -- mode returned by Fopen_Mode is not "r" or "r+", then we first -- make sure that the file exists as required by Ada semantics. ! if Creat = False and then Fopstr (1) /= 'r' then if file_exists (Namestr'Address) = 0 then raise Name_Error; end if; --- 966,972 ---- -- mode returned by Fopen_Mode is not "r" or "r+", then we first -- make sure that the file exists as required by Ada semantics. ! if not Creat and then Fopstr (1) /= 'r' then if file_exists (Namestr'Address) = 0 then raise Name_Error; end if; *************** package body System.File_IO is *** 982,992 **** Stream := fopen (Namestr'Address, Fopstr'Address, Encoding); if Stream = NULL_Stream then ! if file_exists (Namestr'Address) = 0 then ! raise Name_Error; ! else ! raise Use_Error; ! end if; end if; end if; end if; --- 985,1017 ---- Stream := fopen (Namestr'Address, Fopstr'Address, Encoding); if Stream = NULL_Stream then ! ! -- Raise Name_Error if trying to open a non-existent file. ! -- Otherwise raise Use_Error. ! ! -- Should we raise Device_Error for ENOSPC??? ! ! declare ! subtype Cint is Interfaces.C.int; ! ! function Is_File_Not_Found_Error ! (Errno_Value : Cint) return Cint; ! -- Non-zero when the given errno value indicates a non- ! -- existing file. ! ! pragma Import ! (C, Is_File_Not_Found_Error, ! "__gnat_is_file_not_found_error"); ! ! begin ! if ! Is_File_Not_Found_Error (Cint (System.OS_Lib.Errno)) /= 0 ! then ! raise Name_Error; ! else ! raise Use_Error; ! end if; ! end; end if; end if; end if; *************** package body System.File_IO is *** 1058,1086 **** -- The reset which does not change the mode simply does a rewind ! procedure Reset (File : in out AFCB_Ptr) is begin Check_File_Open (File); ! Reset (File, File.Mode); end Reset; -- The reset with a change in mode is done using freopen, and is -- not permitted except for regular files (since otherwise there -- is no name for the freopen, and in any case it seems meaningless) ! procedure Reset (File : in out AFCB_Ptr; Mode : File_Mode) is Fopstr : aliased Fopen_String; begin Check_File_Open (File); ! -- Change of mode not allowed for shared file or file with no name ! -- or file that is not a regular file, or for a system file. ! if File.Shared_Status = Yes ! or else File.Name'Length <= 1 ! or else File.Is_System_File ! or else not File.Is_Regular_File then raise Use_Error; --- 1083,1115 ---- -- The reset which does not change the mode simply does a rewind ! procedure Reset (File_Ptr : access AFCB_Ptr) is ! File : AFCB_Ptr renames File_Ptr.all; begin Check_File_Open (File); ! Reset (File_Ptr, File.Mode); end Reset; -- The reset with a change in mode is done using freopen, and is -- not permitted except for regular files (since otherwise there -- is no name for the freopen, and in any case it seems meaningless) ! procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is ! File : AFCB_Ptr renames File_Ptr.all; Fopstr : aliased Fopen_String; begin Check_File_Open (File); ! -- Change of mode not allowed for shared file or file with no name or ! -- file that is not a regular file, or for a system file. Note that we ! -- allow the "change" of mode if it is not in fact doing a change. ! if Mode /= File.Mode ! and then (File.Shared_Status = Yes ! or else File.Name'Length <= 1 ! or else File.Is_System_File ! or else not File.Is_Regular_File) then raise Use_Error; *************** package body System.File_IO is *** 1104,1110 **** (File.Name.all'Address, Fopstr'Address, File.Stream, File.Encoding); if File.Stream = NULL_Stream then ! Close (File); raise Use_Error; else --- 1133,1139 ---- (File.Name.all'Address, Fopstr'Address, File.Stream, File.Encoding); if File.Stream = NULL_Stream then ! Close (File_Ptr); raise Use_Error; else diff -Nrcpad gcc-4.3.3/gcc/ada/s-fileio.ads gcc-4.4.0/gcc/ada/s-fileio.ads *** gcc-4.3.3/gcc/ada/s-fileio.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-fileio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.File_IO is *** 100,119 **** -- this allocated file control block. If the open/create fails, then the -- fields of File are undefined, and File_Ptr is unchanged. ! procedure Close (File : in out FCB.AFCB_Ptr); -- The file is closed, all storage associated with it is released, and -- File is set to null. Note that this routine calls AFCB_Close to perform -- any specialized close actions, then closes the file at the system level, -- then frees the mode and form strings, and finally calls AFCB_Free to ! -- free the file control block itself, setting File to null. ! procedure Delete (File : in out FCB.AFCB_Ptr); -- The indicated file is unlinked ! procedure Reset (File : in out FCB.AFCB_Ptr; Mode : FCB.File_Mode); -- The file is reset, and the mode changed as indicated ! procedure Reset (File : in out FCB.AFCB_Ptr); -- The files is reset, and the mode is unchanged function Mode (File : FCB.AFCB_Ptr) return FCB.File_Mode; --- 98,120 ---- -- this allocated file control block. If the open/create fails, then the -- fields of File are undefined, and File_Ptr is unchanged. ! procedure Close (File_Ptr : access FCB.AFCB_Ptr); -- The file is closed, all storage associated with it is released, and -- File is set to null. Note that this routine calls AFCB_Close to perform -- any specialized close actions, then closes the file at the system level, -- then frees the mode and form strings, and finally calls AFCB_Free to ! -- free the file control block itself, setting File.all to null. Note that ! -- for this assignment to be done in all cases, including those where ! -- an exception is raised, we can't use an IN OUT parameter (which would ! -- not be copied back in case of abnormal return). ! procedure Delete (File_Ptr : access FCB.AFCB_Ptr); -- The indicated file is unlinked ! procedure Reset (File_Ptr : access FCB.AFCB_Ptr; Mode : FCB.File_Mode); -- The file is reset, and the mode changed as indicated ! procedure Reset (File_Ptr : access FCB.AFCB_Ptr); -- The files is reset, and the mode is unchanged function Mode (File : FCB.AFCB_Ptr) return FCB.File_Mode; diff -Nrcpad gcc-4.3.3/gcc/ada/s-filofl.ads gcc-4.4.0/gcc/ada/s-filofl.ads *** gcc-4.3.3/gcc/ada/s-filofl.ads Tue Nov 15 13:57:25 2005 --- gcc-4.4.0/gcc/ada/s-filofl.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005,2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 32,38 **** ------------------------------------------------------------------------------ -- This package contains an instantiation of the floating-point attribute ! -- runtime routines for IEEE long float. This is used on VMS targest where -- we can't just use Long_Float, since this may have been mapped to Vax_Float -- using a Float_Representation configuration pragma. --- 30,36 ---- ------------------------------------------------------------------------------ -- This package contains an instantiation of the floating-point attribute ! -- runtime routines for IEEE long float. This is used on VMS targets where -- we can't just use Long_Float, since this may have been mapped to Vax_Float -- using a Float_Representation configuration pragma. *************** package System.Fat_IEEE_Long_Float is *** 44,50 **** type Fat_IEEE_Long is digits 15; pragma Float_Representation (IEEE_Float, Fat_IEEE_Long); ! -- Note the only entity from this package that is acccessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. --- 42,48 ---- type Fat_IEEE_Long is digits 15; pragma Float_Representation (IEEE_Float, Fat_IEEE_Long); ! -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. diff -Nrcpad gcc-4.3.3/gcc/ada/s-finimp.adb gcc-4.4.0/gcc/ada/s-finimp.adb *** gcc-4.3.3/gcc/ada/s-finimp.adb Tue Aug 14 08:49:45 2007 --- gcc-4.4.0/gcc/ada/s-finimp.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Finalization_Impleme *** 100,106 **** -- Subtract the offset to the pointer procedure Reverse_Adjust (P : Finalizable_Ptr); ! -- Ajust the components in the reverse order in which they are stored -- on the finalization list. (Adjust and Finalization are not done in -- the same order) --- 98,104 ---- -- Subtract the offset to the pointer procedure Reverse_Adjust (P : Finalizable_Ptr); ! -- Adjust the components in the reverse order in which they are stored -- on the finalization list. (Adjust and Finalization are not done in -- the same order) *************** package body System.Finalization_Impleme *** 139,145 **** First_Comp := Object.F; Object.F := null; -- nothing adjusted yet. ! Ptr_Adjust (First_Comp); -- set addresss of first component. Reverse_Adjust (First_Comp); -- Then Adjust the controller itself --- 137,143 ---- First_Comp := Object.F; Object.F := null; -- nothing adjusted yet. ! Ptr_Adjust (First_Comp); -- set address of first component. Reverse_Adjust (First_Comp); -- Then Adjust the controller itself *************** package body System.Finalization_Impleme *** 412,418 **** -- At this stage, we know that the controller is part of the -- ancestor corresponding to the tag "The_Tag" and that its parent -- is variable sized. We assume that the _controller is the first ! -- compoment right after the parent. -- ??? note that it may not be true if there are new discriminants --- 410,416 ---- -- At this stage, we know that the controller is part of the -- ancestor corresponding to the tag "The_Tag" and that its parent -- is variable sized. We assume that the _controller is the first ! -- component right after the parent. -- ??? note that it may not be true if there are new discriminants diff -Nrcpad gcc-4.3.3/gcc/ada/s-finimp.ads gcc-4.4.0/gcc/ada/s-finimp.ads *** gcc-4.3.3/gcc/ada/s-finimp.ads Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-finimp.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Finalization_Implementati *** 66,72 **** -- packages. They will be finalized after the main program completion. procedure Finalize_Global_List; ! -- The procedure to be called in order to finalize the global list; procedure Attach_To_Final_List (L : in out SFR.Finalizable_Ptr; --- 64,70 ---- -- packages. They will be finalized after the main program completion. procedure Finalize_Global_List; ! -- The procedure to be called in order to finalize the global list procedure Attach_To_Final_List (L : in out SFR.Finalizable_Ptr; *************** package System.Finalization_Implementati *** 102,108 **** -- return object to the caller's finalization list. procedure Finalize_List (L : SFR.Finalizable_Ptr); ! -- Call Finalize on each element of the list L; procedure Finalize_One (Obj : in out SFR.Finalizable); -- Call Finalize on Obj and remove its final list --- 100,106 ---- -- return object to the caller's finalization list. procedure Finalize_List (L : SFR.Finalizable_Ptr); ! -- Call Finalize on each element of the list L procedure Finalize_One (Obj : in out SFR.Finalizable); -- Call Finalize on Obj and remove its final list diff -Nrcpad gcc-4.3.3/gcc/ada/s-finroo.adb gcc-4.4.0/gcc/ada/s-finroo.adb *** gcc-4.3.3/gcc/ada/s-finroo.adb Wed Jun 6 10:46:39 2007 --- gcc-4.4.0/gcc/ada/s-finroo.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-finroo.ads gcc-4.4.0/gcc/ada/s-finroo.ads *** gcc-4.3.3/gcc/ada/s-finroo.ads Tue Aug 14 08:49:26 2007 --- gcc-4.4.0/gcc/ada/s-finroo.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Finalization_Root is *** 61,67 **** procedure Finalize (Object : in out Root_Controlled); procedure Adjust (Object : in out Root_Controlled); ! -- Stream-oriented attibutes for Root_Controlled. These must be empty so -- as to not copy the finalization chain pointers. They are declared in -- a nested package so that they do not create primitive operations of -- Root_Controlled. Otherwise this would add unwanted primitives to (the --- 59,65 ---- procedure Finalize (Object : in out Root_Controlled); procedure Adjust (Object : in out Root_Controlled); ! -- Stream-oriented attributes for Root_Controlled. These must be empty so -- as to not copy the finalization chain pointers. They are declared in -- a nested package so that they do not create primitive operations of -- Root_Controlled. Otherwise this would add unwanted primitives to (the diff -Nrcpad gcc-4.3.3/gcc/ada/s-fishfl.ads gcc-4.4.0/gcc/ada/s-fishfl.ads *** gcc-4.3.3/gcc/ada/s-fishfl.ads Tue Nov 15 13:57:25 2005 --- gcc-4.4.0/gcc/ada/s-fishfl.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005,2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 32,38 **** ------------------------------------------------------------------------------ -- This package contains an instantiation of the floating-point attribute ! -- runtime routines for IEEE short float. This is used on VMS targest where -- we can't just use Float, since this may have been mapped to Vax_Float -- using a Float_Representation configuration pragma. --- 30,36 ---- ------------------------------------------------------------------------------ -- This package contains an instantiation of the floating-point attribute ! -- runtime routines for IEEE short float. This is used on VMS targets where -- we can't just use Float, since this may have been mapped to Vax_Float -- using a Float_Representation configuration pragma. *************** package System.Fat_IEEE_Short_Float is *** 44,50 **** type Fat_IEEE_Short is digits 6; pragma Float_Representation (IEEE_Float, Fat_IEEE_Short); ! -- Note the only entity from this package that is acccessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. --- 42,48 ---- type Fat_IEEE_Short is digits 6; pragma Float_Representation (IEEE_Float, Fat_IEEE_Short); ! -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. diff -Nrcpad gcc-4.3.3/gcc/ada/s-fore.adb gcc-4.4.0/gcc/ada/s-fore.adb *** gcc-4.3.3/gcc/ada/s-fore.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-fore.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-fore.ads gcc-4.4.0/gcc/ada/s-fore.ads *** gcc-4.3.3/gcc/ada/s-fore.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-fore.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-fvadfl.ads gcc-4.4.0/gcc/ada/s-fvadfl.ads *** gcc-4.3.3/gcc/ada/s-fvadfl.ads Tue Nov 15 13:57:25 2005 --- gcc-4.4.0/gcc/ada/s-fvadfl.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005,2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Fat_VAX_D_Float is *** 41,52 **** pragma Warnings (Off); -- This unit is normally used only for VMS, but we compile it for other ! -- targest for the convenience of testing vms code using -gnatdm. type Fat_VAX_D is digits 9; pragma Float_Representation (VAX_Float, Fat_VAX_D); ! -- Note the only entity from this package that is acccessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. --- 39,50 ---- pragma Warnings (Off); -- This unit is normally used only for VMS, but we compile it for other ! -- targets for the convenience of testing vms code using -gnatdm. type Fat_VAX_D is digits 9; pragma Float_Representation (VAX_Float, Fat_VAX_D); ! -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. diff -Nrcpad gcc-4.3.3/gcc/ada/s-fvaffl.ads gcc-4.4.0/gcc/ada/s-fvaffl.ads *** gcc-4.3.3/gcc/ada/s-fvaffl.ads Tue Nov 15 13:57:25 2005 --- gcc-4.4.0/gcc/ada/s-fvaffl.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005,2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Fat_VAX_F_Float is *** 41,52 **** pragma Warnings (Off); -- This unit is normally used only for VMS, but we compile it for other ! -- targest for the convenience of testing vms code using -gnatdm. type Fat_VAX_F is digits 6; pragma Float_Representation (VAX_Float, Fat_VAX_F); ! -- Note the only entity from this package that is acccessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. --- 39,50 ---- pragma Warnings (Off); -- This unit is normally used only for VMS, but we compile it for other ! -- targets for the convenience of testing vms code using -gnatdm. type Fat_VAX_F is digits 6; pragma Float_Representation (VAX_Float, Fat_VAX_F); ! -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. diff -Nrcpad gcc-4.3.3/gcc/ada/s-fvagfl.ads gcc-4.4.0/gcc/ada/s-fvagfl.ads *** gcc-4.3.3/gcc/ada/s-fvagfl.ads Tue Nov 15 13:57:25 2005 --- gcc-4.4.0/gcc/ada/s-fvagfl.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005,2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Fat_VAX_G_Float is *** 41,52 **** pragma Warnings (Off); -- This unit is normally used only for VMS, but we compile it for other ! -- targest for the convenience of testing vms code using -gnatdm. type Fat_VAX_G is digits 15; pragma Float_Representation (VAX_Float, Fat_VAX_G); ! -- Note the only entity from this package that is acccessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. --- 39,50 ---- pragma Warnings (Off); -- This unit is normally used only for VMS, but we compile it for other ! -- targets for the convenience of testing vms code using -gnatdm. type Fat_VAX_G is digits 15; pragma Float_Representation (VAX_Float, Fat_VAX_G); ! -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package -- (i.e. the individual floating-point attribute routines) are accessed -- by name using selected notation. diff -Nrcpad gcc-4.3.3/gcc/ada/s-gearop.adb gcc-4.4.0/gcc/ada/s-gearop.adb *** gcc-4.3.3/gcc/ada/s-gearop.adb Tue Aug 14 08:50:51 2007 --- gcc-4.4.0/gcc/ada/s-gearop.adb Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- SYSTEM.GENERIC_ARRAY_OPERATIONS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- S Y S T E M . G E N E R I C _ A R R A Y _ O P E R A T I O N S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-gearop.ads gcc-4.4.0/gcc/ada/s-gearop.ads *** gcc-4.3.3/gcc/ada/s-gearop.ads Fri Apr 6 09:23:23 2007 --- gcc-4.4.0/gcc/ada/s-gearop.ads Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- SYSTEM.GENERIC_ARRAY_OPERATIONS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- S Y S T E M . G E N E R I C _ A R R A Y _ O P E R A T I O N S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-gecobl.adb gcc-4.4.0/gcc/ada/s-gecobl.adb *** gcc-4.3.3/gcc/ada/s-gecobl.adb Tue Aug 14 08:50:51 2007 --- gcc-4.4.0/gcc/ada/s-gecobl.adb Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- SYSTEM.GENERIC_COMPLEX_BLAS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- S Y S T E M . G E N E R I C _ C O M P L E X _ B L A S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-gecobl.ads gcc-4.4.0/gcc/ada/s-gecobl.ads *** gcc-4.3.3/gcc/ada/s-gecobl.ads Tue Aug 14 08:50:51 2007 --- gcc-4.4.0/gcc/ada/s-gecobl.ads Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- SYSTEM.GENERIC_COMPLEX_BLAS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- S Y S T E M . G E N E R I C _ C O M P L E X _ B L A S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-gecola.adb gcc-4.4.0/gcc/ada/s-gecola.adb *** gcc-4.3.3/gcc/ada/s-gecola.adb Fri Apr 6 09:23:23 2007 --- gcc-4.4.0/gcc/ada/s-gecola.adb Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- SYSTEM.GENERIC_COMPLEX_LAPACK -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- S Y S T E M . G E N E R I C _ C O M P L E X _ L A P A C K -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-gecola.ads gcc-4.4.0/gcc/ada/s-gecola.ads *** gcc-4.3.3/gcc/ada/s-gecola.ads Fri Apr 6 09:23:23 2007 --- gcc-4.4.0/gcc/ada/s-gecola.ads Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- SYSTEM.GENERIC_COMPLEX_LAPACK -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- S Y S T E M . G E N E R I C _ C O M P L E X _ L A P A C K -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-gerebl.adb gcc-4.4.0/gcc/ada/s-gerebl.adb *** gcc-4.3.3/gcc/ada/s-gerebl.adb Fri Apr 6 09:23:23 2007 --- gcc-4.4.0/gcc/ada/s-gerebl.adb Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- SYSTEM.GENERIC_REAL_BLAS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- S Y S T E M . G E N E R I C _ R E A L _ B L A S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-gerebl.ads gcc-4.4.0/gcc/ada/s-gerebl.ads *** gcc-4.3.3/gcc/ada/s-gerebl.ads Fri Apr 6 09:23:23 2007 --- gcc-4.4.0/gcc/ada/s-gerebl.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-gerela.adb gcc-4.4.0/gcc/ada/s-gerela.adb *** gcc-4.3.3/gcc/ada/s-gerela.adb Tue Aug 14 08:50:51 2007 --- gcc-4.4.0/gcc/ada/s-gerela.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-gerela.ads gcc-4.4.0/gcc/ada/s-gerela.ads *** gcc-4.3.3/gcc/ada/s-gerela.ads Tue Aug 14 08:50:51 2007 --- gcc-4.4.0/gcc/ada/s-gerela.ads Thu Apr 9 23:23:07 2009 *************** *** 2,30 **** -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- SYSTEM.GENERIC_REAL_LAPACK -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- ! -- S Y S T E M . G E N E R I C _ R E A L _ L A P A C K -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2006-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-geveop.adb gcc-4.4.0/gcc/ada/s-geveop.adb *** gcc-4.3.3/gcc/ada/s-geveop.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-geveop.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-geveop.ads gcc-4.4.0/gcc/ada/s-geveop.ads *** gcc-4.3.3/gcc/ada/s-geveop.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-geveop.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-gloloc-mingw.adb gcc-4.4.0/gcc/ada/s-gloloc-mingw.adb *** gcc-4.3.3/gcc/ada/s-gloloc-mingw.adb Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/s-gloloc-mingw.adb Tue Apr 8 06:44:11 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- 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- -- *************** *** 33,42 **** -- This implementation is specific to NT with System.Task_Lock; with Interfaces.C.Strings; - with System.OS_Interface; package body System.Global_Locks is --- 33,43 ---- -- This implementation is specific to NT + with System.OS_Interface; with System.Task_Lock; + with System.Win32; with Interfaces.C.Strings; package body System.Global_Locks is *************** package body System.Global_Locks is *** 44,50 **** package OSI renames System.OS_Interface; package ICS renames Interfaces.C.Strings; ! subtype Lock_File_Entry is OSI.HANDLE; Last_Lock : Lock_Type := Null_Lock; Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry; --- 45,51 ---- package OSI renames System.OS_Interface; package ICS renames Interfaces.C.Strings; ! subtype Lock_File_Entry is Win32.HANDLE; Last_Lock : Lock_Type := Null_Lock; Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry; *************** package body System.Global_Locks is *** 53,62 **** -- Create_Lock -- ----------------- ! procedure Create_Lock ! (Lock : out Lock_Type; ! Name : String) ! is L : Lock_Type; begin --- 54,60 ---- -- Create_Lock -- ----------------- ! procedure Create_Lock (Lock : out Lock_Type; Name : String) is L : Lock_Type; begin *************** package body System.Global_Locks is *** 70,76 **** end if; Lock_Table (L) := ! OSI.CreateMutex (null, OSI.BOOL (False), ICS.New_String (Name)); Lock := L; end Create_Lock; --- 68,74 ---- end if; Lock_Table (L) := ! OSI.CreateMutex (null, Win32.FALSE, ICS.New_String (Name)); Lock := L; end Create_Lock; *************** package body System.Global_Locks is *** 78,89 **** -- Acquire_Lock -- ------------------ ! procedure Acquire_Lock ! (Lock : in out Lock_Type) ! is ! use type OSI.DWORD; - Res : OSI.DWORD; begin Res := OSI.WaitForSingleObject (Lock_Table (Lock), OSI.Wait_Infinite); --- 76,86 ---- -- Acquire_Lock -- ------------------ ! procedure Acquire_Lock (Lock : in out Lock_Type) is ! use type Win32.DWORD; ! ! Res : Win32.DWORD; begin Res := OSI.WaitForSingleObject (Lock_Table (Lock), OSI.Wait_Infinite); *************** package body System.Global_Locks is *** 96,111 **** -- Release_Lock -- ------------------ ! procedure Release_Lock ! (Lock : in out Lock_Type) ! is ! use type OSI.BOOL; - Res : OSI.BOOL; begin Res := OSI.ReleaseMutex (Lock_Table (Lock)); ! if Res = OSI.False then raise Lock_Error; end if; end Release_Lock; --- 93,107 ---- -- Release_Lock -- ------------------ ! procedure Release_Lock (Lock : in out Lock_Type) is ! use type Win32.BOOL; ! ! Res : Win32.BOOL; begin Res := OSI.ReleaseMutex (Lock_Table (Lock)); ! if Res = Win32.FALSE then raise Lock_Error; end if; end Release_Lock; diff -Nrcpad gcc-4.3.3/gcc/ada/s-gloloc.adb gcc-4.4.0/gcc/ada/s-gloloc.adb *** gcc-4.3.3/gcc/ada/s-gloloc.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-gloloc.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 32,38 **** ------------------------------------------------------------------------------ with System.Soft_Links; - -- used for Lock_Task, Unlock_Task package body System.Global_Locks is --- 30,35 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-gloloc.ads gcc-4.4.0/gcc/ada/s-gloloc.ads *** gcc-4.3.3/gcc/ada/s-gloloc.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-gloloc.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-hibaen.ads gcc-4.4.0/gcc/ada/s-hibaen.ads *** gcc-4.3.3/gcc/ada/s-hibaen.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-hibaen.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2003 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.HIE_Back_End is *** 73,79 **** -- This entity controls whether the front end allows generation of -- long shift instructions, i.e. shifts that operate on 64-bit values. -- Such shifts are required for the implementation of fixed-point ! -- types longer than 32 bits. This can safetly be set as High_Integrity -- on 64-bit machines that provide this operation at the hardware level, -- but on some 32-bit machines a run time call is required. If there -- is a certifiable version available of the relevant run-time routines, --- 71,77 ---- -- This entity controls whether the front end allows generation of -- long shift instructions, i.e. shifts that operate on 64-bit values. -- Such shifts are required for the implementation of fixed-point ! -- types longer than 32 bits. This can safely be set as High_Integrity -- on 64-bit machines that provide this operation at the hardware level, -- but on some 32-bit machines a run time call is required. If there -- is a certifiable version available of the relevant run-time routines, diff -Nrcpad gcc-4.3.3/gcc/ada/s-htable.ads gcc-4.4.0/gcc/ada/s-htable.ads *** gcc-4.3.3/gcc/ada/s-htable.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-htable.ads Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- 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- -- *************** package System.HTable is *** 183,189 **** function Get_Next return Elmt_Ptr; -- Returns a non-specified element that has not been returned by the -- same function since the last call to Get_First or Null_Ptr if ! -- there is no such element or Get_First has bever been called. If -- there is no call to 'Set' in between Get_Next calls, all the -- elements of the HTable will be traversed. --- 183,189 ---- function Get_Next return Elmt_Ptr; -- Returns a non-specified element that has not been returned by the -- same function since the last call to Get_First or Null_Ptr if ! -- there is no such element or Get_First has never been called. If -- there is no call to 'Set' in between Get_Next calls, all the -- elements of the HTable will be traversed. diff -Nrcpad gcc-4.3.3/gcc/ada/s-imenne.adb gcc-4.4.0/gcc/ada/s-imenne.adb *** gcc-4.3.3/gcc/ada/s-imenne.adb Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imenne.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imenne.ads gcc-4.4.0/gcc/ada/s-imenne.ads *** gcc-4.3.3/gcc/ada/s-imenne.ads Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imenne.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgbiu.adb gcc-4.4.0/gcc/ada/s-imgbiu.adb *** gcc-4.3.3/gcc/ada/s-imgbiu.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-imgbiu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgbiu.ads gcc-4.4.0/gcc/ada/s-imgbiu.ads *** gcc-4.3.3/gcc/ada/s-imgbiu.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-imgbiu.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgboo.adb gcc-4.4.0/gcc/ada/s-imgboo.adb *** gcc-4.3.3/gcc/ada/s-imgboo.adb Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgboo.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgboo.ads gcc-4.4.0/gcc/ada/s-imgboo.ads *** gcc-4.3.3/gcc/ada/s-imgboo.ads Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgboo.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgcha.adb gcc-4.4.0/gcc/ada/s-imgcha.adb *** gcc-4.3.3/gcc/ada/s-imgcha.adb Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgcha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Img_Char is *** 159,165 **** end; end if; ! -- Normal characters yield the character enlosed in quotes (RM 3.5(32)) else S (1) := '''; --- 157,163 ---- end; end if; ! -- Normal characters yield the character enclosed in quotes (RM 3.5(32)) else S (1) := '''; diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgcha.ads gcc-4.4.0/gcc/ada/s-imgcha.ads *** gcc-4.3.3/gcc/ada/s-imgcha.ads Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgcha.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgdec.adb gcc-4.4.0/gcc/ada/s-imgdec.adb *** gcc-4.3.3/gcc/ada/s-imgdec.adb Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgdec.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Img_Dec is *** 129,134 **** --- 127,136 ---- pragma Inline (Set_Zeroes); -- Set N zeroes, no effect if N is negative + ----------- + -- Round -- + ----------- + procedure Round (N : Natural) is D : Character; *************** package body System.Img_Dec is *** 250,256 **** if Exp > 0 then Set_Blanks_And_Sign (Fore - 1); ! Round (Aft + 2); Set (Digs (FD)); FD := FD + 1; ND := ND - 1; --- 252,258 ---- if Exp > 0 then Set_Blanks_And_Sign (Fore - 1); ! Round (Digits_After_Point + 2); Set (Digs (FD)); FD := FD + 1; ND := ND - 1; *************** package body System.Img_Dec is *** 258,264 **** if ND >= Digits_After_Point then Set_Digits (FD, FD + Digits_After_Point - 1); - else Set_Digits (FD, LD); Set_Zeroes (Digits_After_Point - ND); --- 260,265 ---- *************** package body System.Img_Dec is *** 317,343 **** Set_Blanks_And_Sign (Fore - 1); Set ('0'); Set ('.'); ! ! Set_Zeroes (Digits_After_Point - ND); Set_Digits (FD, LD); -- At least one digit before point in input else - Set_Blanks_And_Sign (Fore - Digits_Before_Point); - -- Less digits in input than are needed before point -- Input: 1PP Output: 100.000 if ND < Digits_Before_Point then ! Set_Digits (FD, LD); ! Set_Zeroes (Digits_Before_Point - ND); Set ('.'); Set_Zeroes (Digits_After_Point); -- Input has full amount of digits before decimal point else Set_Digits (FD, FD + Digits_Before_Point - 1); Set ('.'); Set_Digits (FD + Digits_Before_Point, LD); --- 318,359 ---- Set_Blanks_And_Sign (Fore - 1); Set ('0'); Set ('.'); ! Set_Zeroes (-Digits_Before_Point); Set_Digits (FD, LD); + Set_Zeroes (Digits_After_Point - Scale); -- At least one digit before point in input else -- Less digits in input than are needed before point -- Input: 1PP Output: 100.000 if ND < Digits_Before_Point then ! ! -- Special case, if the input is the single digit 0, then we ! -- do not want 000.000, but instead 0.000. ! ! if ND = 1 and then Digs (FD) = '0' then ! Set_Blanks_And_Sign (Fore - 1); ! Set ('0'); ! ! -- Normal case where we need to output scaling zeroes ! ! else ! Set_Blanks_And_Sign (Fore - Digits_Before_Point); ! Set_Digits (FD, LD); ! Set_Zeroes (Digits_Before_Point - ND); ! end if; ! ! -- Set period and zeroes after the period ! Set ('.'); Set_Zeroes (Digits_After_Point); -- Input has full amount of digits before decimal point else + Set_Blanks_And_Sign (Fore - Digits_Before_Point); Set_Digits (FD, FD + Digits_Before_Point - 1); Set ('.'); Set_Digits (FD + Digits_Before_Point, LD); diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgdec.ads gcc-4.4.0/gcc/ada/s-imgdec.ads *** gcc-4.3.3/gcc/ada/s-imgdec.ads Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgdec.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgenu.adb gcc-4.4.0/gcc/ada/s-imgenu.adb *** gcc-4.3.3/gcc/ada/s-imgenu.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-imgenu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgenu.ads gcc-4.4.0/gcc/ada/s-imgenu.ads *** gcc-4.3.3/gcc/ada/s-imgenu.ads Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgenu.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 39,46 **** -- Note: this is an obsolete package, replaced by System.Img_Enum_New, which -- provides procedures instead of functions for these enumeration image calls. -- The reason we maintain this package is that when bootstrapping with old ! -- compilers, the old compiler will search for this unit, expectinng to find ! -- these functions. The new commpiler will search for procedures in the new -- version of the unit. pragma Warnings (Off); --- 37,44 ---- -- Note: this is an obsolete package, replaced by System.Img_Enum_New, which -- provides procedures instead of functions for these enumeration image calls. -- The reason we maintain this package is that when bootstrapping with old ! -- compilers, the old compiler will search for this unit, expecting to find ! -- these functions. The new compiler will search for procedures in the new -- version of the unit. pragma Warnings (Off); diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgint.adb gcc-4.4.0/gcc/ada/s-imgint.adb *** gcc-4.3.3/gcc/ada/s-imgint.adb Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgint.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Img_Int is *** 65,71 **** end if; end Set_Digits; ! -- Start of processinng for Image_Integer begin P := 1; --- 63,69 ---- end if; end Set_Digits; ! -- Start of processing for Image_Integer begin P := 1; diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgint.ads gcc-4.4.0/gcc/ada/s-imgint.ads *** gcc-4.3.3/gcc/ada/s-imgint.ads Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgint.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgllb.adb gcc-4.4.0/gcc/ada/s-imgllb.adb *** gcc-4.3.3/gcc/ada/s-imgllb.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-imgllb.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgllb.ads gcc-4.4.0/gcc/ada/s-imgllb.ads *** gcc-4.3.3/gcc/ada/s-imgllb.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-imgllb.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imglld.adb gcc-4.4.0/gcc/ada/s-imglld.adb *** gcc-4.3.3/gcc/ada/s-imglld.adb Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imglld.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imglld.ads gcc-4.4.0/gcc/ada/s-imglld.ads *** gcc-4.3.3/gcc/ada/s-imglld.ads Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imglld.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imglli.adb gcc-4.4.0/gcc/ada/s-imglli.adb *** gcc-4.3.3/gcc/ada/s-imglli.adb Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imglli.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imglli.ads gcc-4.4.0/gcc/ada/s-imglli.ads *** gcc-4.3.3/gcc/ada/s-imglli.ads Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imglli.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgllu.adb gcc-4.4.0/gcc/ada/s-imgllu.adb *** gcc-4.3.3/gcc/ada/s-imgllu.adb Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgllu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgllu.ads gcc-4.4.0/gcc/ada/s-imgllu.ads *** gcc-4.3.3/gcc/ada/s-imgllu.ads Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgllu.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgllw.adb gcc-4.4.0/gcc/ada/s-imgllw.adb *** gcc-4.3.3/gcc/ada/s-imgllw.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-imgllw.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgllw.ads gcc-4.4.0/gcc/ada/s-imgllw.ads *** gcc-4.3.3/gcc/ada/s-imgllw.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-imgllw.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgrea.adb gcc-4.4.0/gcc/ada/s-imgrea.adb *** gcc-4.3.3/gcc/ada/s-imgrea.adb Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgrea.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Img_Real is *** 87,93 **** pragma Assert (S'First = 1); begin ! -- Decide wether a blank should be prepended before the call to -- Set_Image_Real. We generate a blank for positive values, and -- also for positive zeroes. For negative zeroes, we generate a -- space only if Signed_Zeroes is True (the RM only permits the --- 85,91 ---- pragma Assert (S'First = 1); begin ! -- Decide whether a blank should be prepended before the call to -- Set_Image_Real. We generate a blank for positive values, and -- also for positive zeroes. For negative zeroes, we generate a -- space only if Signed_Zeroes is True (the RM only permits the diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgrea.ads gcc-4.4.0/gcc/ada/s-imgrea.ads *** gcc-4.3.3/gcc/ada/s-imgrea.ads Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgrea.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imguns.adb gcc-4.4.0/gcc/ada/s-imguns.adb *** gcc-4.3.3/gcc/ada/s-imguns.adb Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imguns.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imguns.ads gcc-4.4.0/gcc/ada/s-imguns.ads *** gcc-4.3.3/gcc/ada/s-imguns.ads Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imguns.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgwch.adb gcc-4.4.0/gcc/ada/s-imgwch.adb *** gcc-4.3.3/gcc/ada/s-imgwch.adb Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgwch.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgwch.ads gcc-4.4.0/gcc/ada/s-imgwch.ads *** gcc-4.3.3/gcc/ada/s-imgwch.ads Thu Dec 13 10:30:04 2007 --- gcc-4.4.0/gcc/ada/s-imgwch.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgwiu.adb gcc-4.4.0/gcc/ada/s-imgwiu.adb *** gcc-4.3.3/gcc/ada/s-imgwiu.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-imgwiu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-imgwiu.ads gcc-4.4.0/gcc/ada/s-imgwiu.ads *** gcc-4.3.3/gcc/ada/s-imgwiu.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-imgwiu.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-inmaop-dummy.adb gcc-4.4.0/gcc/ada/s-inmaop-dummy.adb *** gcc-4.3.3/gcc/ada/s-inmaop-dummy.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-inmaop-dummy.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package body System.Interrupt_Management *** 134,142 **** null; end Empty_Interrupt_Mask; ! ----------------------- ! -- Add_To_Sigal_Mask -- ! ----------------------- procedure Add_To_Interrupt_Mask (Mask : access Interrupt_Mask; --- 132,140 ---- null; end Empty_Interrupt_Mask; ! --------------------------- ! -- Add_To_Interrupt_Mask -- ! --------------------------- procedure Add_To_Interrupt_Mask (Mask : access Interrupt_Mask; diff -Nrcpad gcc-4.3.3/gcc/ada/s-inmaop-posix.adb gcc-4.4.0/gcc/ada/s-inmaop-posix.adb *** gcc-4.3.3/gcc/ada/s-inmaop-posix.adb Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/s-inmaop-posix.adb Wed Mar 26 07:35:19 2008 *************** *** 2,14 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T . -- ! -- O P E R A T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, AdaCore -- -- -- -- GNARL 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- -- --- 2,13 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- -- -- -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNARL 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- -- *************** *** 33,52 **** -- -- ------------------------------------------------------------------------------ ! -- This is a POSIX-like version of this package. ! -- Note: this file can only be used for POSIX compliant systems. with Interfaces.C; - -- used for int - -- size_t - -- unsigned with System.OS_Interface; - -- used for various type, constant, and operations - with System.Storage_Elements; - -- used for To_Address - -- Integer_Address package body System.Interrupt_Management.Operations is --- 32,45 ---- -- -- ------------------------------------------------------------------------------ ! -- This is a POSIX-like version of this package ! ! -- Note: this file can only be used for POSIX compliant systems with Interfaces.C; with System.OS_Interface; with System.Storage_Elements; package body System.Interrupt_Management.Operations is diff -Nrcpad gcc-4.3.3/gcc/ada/s-inmaop-vms.adb gcc-4.4.0/gcc/ada/s-inmaop-vms.adb *** gcc-4.3.3/gcc/ada/s-inmaop-vms.adb Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-inmaop-vms.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 34,52 **** -- This is a OpenVMS/Alpha version of this package with System.OS_Interface; - -- used for various type, constant, and operations - with System.Aux_DEC; - -- used for Short_Address - with System.Parameters; - with System.Tasking; - with System.Tasking.Initialization; ! with System.Task_Primitives.Operations; - with System.Task_Primitives.Operations.DEC; with Ada.Unchecked_Conversion; --- 32,43 ---- -- This is a OpenVMS/Alpha version of this package with System.OS_Interface; with System.Aux_DEC; with System.Parameters; with System.Tasking; with System.Tasking.Initialization; ! with System.Task_Primitives; with System.Task_Primitives.Operations; with System.Task_Primitives.Operations.DEC; with Ada.Unchecked_Conversion; *************** package body System.Interrupt_Management *** 59,65 **** use type unsigned_short; function To_Address is ! new Ada.Unchecked_Conversion (Task_Id, System.Address); package POP renames System.Task_Primitives.Operations; --- 50,57 ---- use type unsigned_short; function To_Address is ! new Ada.Unchecked_Conversion ! (Task_Id, System.Task_Primitives.Task_Address); package POP renames System.Task_Primitives.Operations; diff -Nrcpad gcc-4.3.3/gcc/ada/s-inmaop.ads gcc-4.4.0/gcc/ada/s-inmaop.ads *** gcc-4.3.3/gcc/ada/s-inmaop.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-inmaop.ads Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T . -- ! -- O P E R A T I O N S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package System.Interrupt_Management.Oper *** 97,103 **** procedure Copy_Interrupt_Mask (X : out Interrupt_Mask; Y : Interrupt_Mask); pragma Inline (Copy_Interrupt_Mask); ! -- Assigment needed for limited private type Interrupt_Mask procedure Interrupt_Self_Process (Interrupt : Interrupt_ID); pragma Inline (Interrupt_Self_Process); --- 94,100 ---- procedure Copy_Interrupt_Mask (X : out Interrupt_Mask; Y : Interrupt_Mask); pragma Inline (Copy_Interrupt_Mask); ! -- Assignment needed for limited private type Interrupt_Mask procedure Interrupt_Self_Process (Interrupt : Interrupt_ID); pragma Inline (Interrupt_Self_Process); diff -Nrcpad gcc-4.3.3/gcc/ada/s-interr-dummy.adb gcc-4.4.0/gcc/ada/s-interr-dummy.adb *** gcc-4.3.3/gcc/ada/s-interr-dummy.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-interr-dummy.adb Tue Apr 8 06:46:28 2008 *************** *** 7,13 **** -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2005, AdaCore -- -- -- -- GNARL 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- -- --- 7,13 ---- -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNARL 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- -- *************** *** 34,41 **** -- This version is for systems that do not support interrupts (or signals) - with Ada.Exceptions; - package body System.Interrupts is pragma Warnings (Off); -- kill warnings on unreferenced formals --- 34,39 ---- *************** package body System.Interrupts is *** 187,192 **** --- 185,199 ---- Unimplemented; end Install_Handlers; + --------------------------------- + -- Install_Restricted_Handlers -- + --------------------------------- + + procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + begin + Unimplemented; + end Install_Restricted_Handlers; + ---------------- -- Is_Blocked -- ---------------- *************** package body System.Interrupts is *** 293,301 **** procedure Unimplemented is begin ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, "interrupts/signals not implemented"); ! raise Program_Error; end Unimplemented; end System.Interrupts; --- 300,306 ---- procedure Unimplemented is begin ! raise Program_Error with "interrupts/signals not implemented"; end Unimplemented; end System.Interrupts; diff -Nrcpad gcc-4.3.3/gcc/ada/s-interr-hwint.adb gcc-4.4.0/gcc/ada/s-interr-hwint.adb *** gcc-4.3.3/gcc/ada/s-interr-hwint.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-interr-hwint.adb Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,1105 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . I N T E R R U P T S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- + -- -- + -- GNARL 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNARL was developed by the GNARL team at Florida State University. -- + -- Extensive contributions were provided by Ada Core Technologies, Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- Invariants: + + -- All user-handleable signals are masked at all times in all tasks/threads + -- except possibly for the Interrupt_Manager task. + + -- When a user task wants to have the effect of masking/unmasking an signal, + -- it must call Block_Interrupt/Unblock_Interrupt, which will have the effect + -- of unmasking/masking the signal in the Interrupt_Manager task. These + -- comments do not apply to vectored hardware interrupts, which may be masked + -- or unmasked using routined interfaced to the relevant embedded RTOS system + -- calls. + + -- Once we associate a Signal_Server_Task with an signal, the task never goes + -- away, and we never remove the association. On the other hand, it is more + -- convenient to terminate an associated Interrupt_Server_Task for a vectored + -- hardware interrupt (since we use a binary semaphore for synchronization + -- with the umbrella handler). + + -- There is no more than one signal per Signal_Server_Task and no more than + -- one Signal_Server_Task per signal. The same relation holds for hardware + -- interrupts and Interrupt_Server_Task's at any given time. That is, only + -- one non-terminated Interrupt_Server_Task exists for a give interrupt at + -- any time. + + -- Within this package, the lock L is used to protect the various status + -- tables. If there is a Server_Task associated with a signal or interrupt, we + -- use the per-task lock of the Server_Task instead so that we protect the + -- status between Interrupt_Manager and Server_Task. Protection among service + -- requests are ensured via user calls to the Interrupt_Manager entries. + + -- This is reasonably generic version of this package, supporting vectored + -- hardware interrupts using non-RTOS specific adapter routines which + -- should easily implemented on any RTOS capable of supporting GNAT. + + with Ada.Unchecked_Conversion; + with Ada.Task_Identification; + + with Interfaces.C; use Interfaces.C; + with System.OS_Interface; use System.OS_Interface; + with System.Interrupt_Management; + with System.Task_Primitives.Operations; + with System.Storage_Elements; + with System.Tasking.Utilities; + + with System.Tasking.Rendezvous; + pragma Elaborate_All (System.Tasking.Rendezvous); + + package body System.Interrupts is + + use Tasking; + + package POP renames System.Task_Primitives.Operations; + + function To_Ada is new Ada.Unchecked_Conversion + (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id); + + function To_System is new Ada.Unchecked_Conversion + (Ada.Task_Identification.Task_Id, Task_Id); + + ----------------- + -- Local Tasks -- + ----------------- + + -- WARNING: System.Tasking.Stages performs calls to this task with + -- low-level constructs. Do not change this spec without synchronizing it. + + task Interrupt_Manager is + entry Detach_Interrupt_Entries (T : Task_Id); + + entry Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False); + + entry Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean); + + entry Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean); + + entry Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Interrupt : Interrupt_ID); + + pragma Interrupt_Priority (System.Interrupt_Priority'First); + end Interrupt_Manager; + + task type Interrupt_Server_Task + (Interrupt : Interrupt_ID; Int_Sema : Binary_Semaphore_Id) is + -- Server task for vectored hardware interrupt handling + pragma Interrupt_Priority (System.Interrupt_Priority'First + 2); + end Interrupt_Server_Task; + + type Interrupt_Task_Access is access Interrupt_Server_Task; + + ------------------------------- + -- Local Types and Variables -- + ------------------------------- + + type Entry_Assoc is record + T : Task_Id; + E : Task_Entry_Index; + end record; + + type Handler_Assoc is record + H : Parameterless_Handler; + Static : Boolean; -- Indicates static binding; + end record; + + User_Handler : array (Interrupt_ID) of Handler_Assoc := + (others => (null, Static => False)); + pragma Volatile_Components (User_Handler); + -- Holds the protected procedure handler (if any) and its Static + -- information for each interrupt or signal. A handler is static + -- iff it is specified through the pragma Attach_Handler. + + User_Entry : array (Interrupt_ID) of Entry_Assoc := + (others => (T => Null_Task, E => Null_Task_Entry)); + pragma Volatile_Components (User_Entry); + -- Holds the task and entry index (if any) for each interrupt / signal + + -- Type and Head, Tail of the list containing Registered Interrupt + -- Handlers. These definitions are used to register the handlers + -- specified by the pragma Interrupt_Handler. + + type Registered_Handler; + type R_Link is access all Registered_Handler; + + type Registered_Handler is record + H : System.Address := System.Null_Address; + Next : R_Link := null; + end record; + + Registered_Handler_Head : R_Link := null; + Registered_Handler_Tail : R_Link := null; + + Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id := + (others => System.Tasking.Null_Task); + pragma Atomic_Components (Server_ID); + -- Holds the Task_Id of the Server_Task for each interrupt / signal. + -- Task_Id is needed to accomplish locking per interrupt base. Also + -- is needed to determine whether to create a new Server_Task. + + Semaphore_ID_Map : array + (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) + of Binary_Semaphore_Id := (others => 0); + -- Array of binary semaphores associated with vectored interrupts + -- Note that the last bound should be Max_HW_Interrupt, but this will raise + -- Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes + -- instead. + + Interrupt_Access_Hold : Interrupt_Task_Access; + -- Variable for allocating an Interrupt_Server_Task + + Handler_Installed : array (HW_Interrupt) of Boolean := (others => False); + -- True if Notify_Interrupt was connected to the interrupt. Handlers + -- can be connected but disconnection is not possible on VxWorks. + -- Therefore we ensure Notify_Installed is connected at most once. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID); + -- Check if Id is a reserved interrupt, and if so raise Program_Error + -- with an appropriate message, otherwise return. + + procedure Finalize_Interrupt_Servers; + -- Unbind the handlers for hardware interrupt server tasks at program + -- termination. + + function Is_Registered (Handler : Parameterless_Handler) return Boolean; + -- See if Handler has been "pragma"ed using Interrupt_Handler. + -- Always consider a null handler as registered. + + procedure Notify_Interrupt (Param : System.Address); + pragma Convention (C, Notify_Interrupt); + -- Umbrella handler for vectored interrupts (not signals) + + procedure Install_Umbrella_Handler + (Interrupt : HW_Interrupt; + Handler : System.OS_Interface.Interrupt_Handler); + -- Install the runtime umbrella handler for a vectored hardware + -- interrupt + + procedure Unimplemented (Feature : String); + pragma No_Return (Unimplemented); + -- Used to mark a call to an unimplemented function. Raises Program_Error + -- with an appropriate message noting that Feature is unimplemented. + + -------------------- + -- Attach_Handler -- + -------------------- + + -- Calling this procedure with New_Handler = null and Static = True + -- means we want to detach the current handler regardless of the + -- previous handler's binding status (i.e. do not care if it is a + -- dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we + -- can detach handlers attached through pragma Attach_Handler. + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + Check_Reserved_Interrupt (Interrupt); + Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); + end Attach_Handler; + + ----------------------------- + -- Bind_Interrupt_To_Entry -- + ----------------------------- + + -- This procedure raises a Program_Error if it tries to + -- bind an interrupt to which an Entry or a Procedure is + -- already bound. + + procedure Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Int_Ref : System.Address) + is + Interrupt : constant Interrupt_ID := + Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); + + begin + Check_Reserved_Interrupt (Interrupt); + Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); + end Bind_Interrupt_To_Entry; + + --------------------- + -- Block_Interrupt -- + --------------------- + + procedure Block_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented ("Block_Interrupt"); + end Block_Interrupt; + + ------------------------------ + -- Check_Reserved_Interrupt -- + ------------------------------ + + procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + else + return; + end if; + end Check_Reserved_Interrupt; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler + is + begin + Check_Reserved_Interrupt (Interrupt); + + -- ??? Since Parameterless_Handler is not Atomic, the + -- current implementation is wrong. We need a new service in + -- Interrupt_Manager to ensure atomicity. + + return User_Handler (Interrupt).H; + end Current_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + -- Calling this procedure with Static = True means we want to Detach the + -- current handler regardless of the previous handler's binding status + -- (i.e. do not care if it is a dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we can + -- detach handlers attached through pragma Attach_Handler. + + procedure Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + Check_Reserved_Interrupt (Interrupt); + Interrupt_Manager.Detach_Handler (Interrupt, Static); + end Detach_Handler; + + ------------------------------ + -- Detach_Interrupt_Entries -- + ------------------------------ + + procedure Detach_Interrupt_Entries (T : Task_Id) is + begin + Interrupt_Manager.Detach_Interrupt_Entries (T); + end Detach_Interrupt_Entries; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + -- Calling this procedure with New_Handler = null and Static = True + -- means we want to detach the current handler regardless of the + -- previous handler's binding status (i.e. do not care if it is a + -- dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we + -- can detach handlers attached through pragma Attach_Handler. + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + Check_Reserved_Interrupt (Interrupt); + Interrupt_Manager.Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + end Exchange_Handler; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Static_Interrupt_Protection) is + begin + -- ??? loop to be executed only when we're not doing library level + -- finalization, since in this case all interrupt / signal tasks are + -- gone. + + if not Interrupt_Manager'Terminated then + for N in reverse Object.Previous_Handlers'Range loop + Interrupt_Manager.Attach_Handler + (New_Handler => Object.Previous_Handlers (N).Handler, + Interrupt => Object.Previous_Handlers (N).Interrupt, + Static => Object.Previous_Handlers (N).Static, + Restoration => True); + end loop; + end if; + + Tasking.Protected_Objects.Entries.Finalize + (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); + end Finalize; + + -------------------------------- + -- Finalize_Interrupt_Servers -- + -------------------------------- + + -- Restore default handlers for interrupt servers + + -- This is called by the Interrupt_Manager task when it receives the abort + -- signal during program finalization. + + procedure Finalize_Interrupt_Servers is + HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0; + + begin + if HW_Interrupts then + for Int in HW_Interrupt loop + if Server_ID (Interrupt_ID (Int)) /= null + and then + not Ada.Task_Identification.Is_Terminated + (To_Ada (Server_ID (Interrupt_ID (Int)))) + then + Interrupt_Manager.Attach_Handler + (New_Handler => null, + Interrupt => Interrupt_ID (Int), + Static => True, + Restoration => True); + end if; + end loop; + end if; + end Finalize_Interrupt_Servers; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) + return Boolean + is + pragma Unreferenced (Object); + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) + return Boolean + is + pragma Unreferenced (Object); + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + ---------------------- + -- Ignore_Interrupt -- + ---------------------- + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented ("Ignore_Interrupt"); + end Ignore_Interrupt; + + ---------------------- + -- Install_Handlers -- + ---------------------- + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : New_Handler_Array) + is + begin + for N in New_Handlers'Range loop + + -- We need a lock around this ??? + + Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; + Object.Previous_Handlers (N).Static := User_Handler + (New_Handlers (N).Interrupt).Static; + + -- We call Exchange_Handler and not directly Interrupt_Manager. + -- Exchange_Handler so we get the Is_Reserved check. + + Exchange_Handler + (Old_Handler => Object.Previous_Handlers (N).Handler, + New_Handler => New_Handlers (N).Handler, + Interrupt => New_Handlers (N).Interrupt, + Static => True); + end loop; + end Install_Handlers; + + --------------------------------- + -- Install_Restricted_Handlers -- + --------------------------------- + + procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + begin + for N in Handlers'Range loop + Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); + end loop; + end Install_Restricted_Handlers; + + ------------------------------ + -- Install_Umbrella_Handler -- + ------------------------------ + + procedure Install_Umbrella_Handler + (Interrupt : HW_Interrupt; + Handler : System.OS_Interface.Interrupt_Handler) + is + Vec : constant Interrupt_Vector := + Interrupt_Number_To_Vector (int (Interrupt)); + + Status : int; + + begin + -- Only install umbrella handler when no Ada handler has already been + -- installed. Note that the interrupt number is passed as a parameter + -- when an interrupt occurs, so the umbrella handler has a different + -- wrapper generated by intConnect for each interrupt number. + + if not Handler_Installed (Interrupt) then + Status := + Interrupt_Connect (Vec, Handler, System.Address (Interrupt)); + pragma Assert (Status = 0); + + Handler_Installed (Interrupt) := True; + end if; + end Install_Umbrella_Handler; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented ("Is_Blocked"); + return False; + end Is_Blocked; + + ----------------------- + -- Is_Entry_Attached -- + ----------------------- + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + Check_Reserved_Interrupt (Interrupt); + return User_Entry (Interrupt).T /= Null_Task; + end Is_Entry_Attached; + + ------------------------- + -- Is_Handler_Attached -- + ------------------------- + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + Check_Reserved_Interrupt (Interrupt); + return User_Handler (Interrupt).H /= null; + end Is_Handler_Attached; + + ---------------- + -- Is_Ignored -- + ---------------- + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented ("Is_Ignored"); + return False; + end Is_Ignored; + + ------------------- + -- Is_Registered -- + ------------------- + + function Is_Registered (Handler : Parameterless_Handler) return Boolean is + type Fat_Ptr is record + Object_Addr : System.Address; + Handler_Addr : System.Address; + end record; + + function To_Fat_Ptr is new Ada.Unchecked_Conversion + (Parameterless_Handler, Fat_Ptr); + + Ptr : R_Link; + Fat : Fat_Ptr; + + begin + if Handler = null then + return True; + end if; + + Fat := To_Fat_Ptr (Handler); + + Ptr := Registered_Handler_Head; + + while Ptr /= null loop + if Ptr.H = Fat.Handler_Addr then + return True; + end if; + + Ptr := Ptr.Next; + end loop; + + return False; + end Is_Registered; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + use System.Interrupt_Management; + begin + return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt)); + end Is_Reserved; + + ---------------------- + -- Notify_Interrupt -- + ---------------------- + + -- Umbrella handler for vectored hardware interrupts (as opposed to + -- signals and exceptions). As opposed to the signal implementation, + -- this handler is installed in the vector table when the first Ada + -- handler is attached to the interrupt. However because VxWorks don't + -- support disconnecting handlers, this subprogram always test whether + -- or not an Ada handler is effectively attached. + + -- Otherwise, the handler that existed prior to program startup is + -- in the vector table. This ensures that handlers installed by + -- the BSP are active unless explicitly replaced in the program text. + + -- Each Interrupt_Server_Task has an associated binary semaphore + -- on which it pends once it's been started. This routine determines + -- The appropriate semaphore and issues a semGive call, waking + -- the server task. When a handler is unbound, + -- System.Interrupts.Unbind_Handler issues a Binary_Semaphore_Flush, + -- and the server task deletes its semaphore and terminates. + + procedure Notify_Interrupt (Param : System.Address) is + Interrupt : constant Interrupt_ID := Interrupt_ID (Param); + + Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt); + + Status : int; + + begin + if Id /= 0 then + Status := Binary_Semaphore_Release (Id); + pragma Assert (Status = 0); + end if; + end Notify_Interrupt; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + begin + Check_Reserved_Interrupt (Interrupt); + return Storage_Elements.To_Address + (Storage_Elements.Integer_Address (Interrupt)); + end Reference; + + -------------------------------- + -- Register_Interrupt_Handler -- + -------------------------------- + + procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is + New_Node_Ptr : R_Link; + + begin + -- This routine registers a handler as usable for dynamic + -- interrupt handler association. Routines attaching and detaching + -- handlers dynamically should determine whether the handler is + -- registered. Program_Error should be raised if it is not registered. + + -- Pragma Interrupt_Handler can only appear in a library + -- level PO definition and instantiation. Therefore, we do not need + -- to implement an unregister operation. Nor do we need to + -- protect the queue structure with a lock. + + pragma Assert (Handler_Addr /= System.Null_Address); + + New_Node_Ptr := new Registered_Handler; + New_Node_Ptr.H := Handler_Addr; + + if Registered_Handler_Head = null then + Registered_Handler_Head := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + + else + Registered_Handler_Tail.Next := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + end if; + end Register_Interrupt_Handler; + + ----------------------- + -- Unblock_Interrupt -- + ----------------------- + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented ("Unblock_Interrupt"); + end Unblock_Interrupt; + + ------------------ + -- Unblocked_By -- + ------------------ + + function Unblocked_By + (Interrupt : Interrupt_ID) return System.Tasking.Task_Id + is + begin + Unimplemented ("Unblocked_By"); + return Null_Task; + end Unblocked_By; + + ------------------------ + -- Unignore_Interrupt -- + ------------------------ + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented ("Unignore_Interrupt"); + end Unignore_Interrupt; + + ------------------- + -- Unimplemented -- + ------------------- + + procedure Unimplemented (Feature : String) is + begin + raise Program_Error with Feature & " not implemented on VxWorks"; + end Unimplemented; + + ----------------------- + -- Interrupt_Manager -- + ----------------------- + + task body Interrupt_Manager is + + -------------------- + -- Local Routines -- + -------------------- + + procedure Bind_Handler (Interrupt : Interrupt_ID); + -- This procedure does not do anything if a signal is blocked. + -- Otherwise, we have to interrupt Server_Task for status change through + -- a wakeup signal. + + procedure Unbind_Handler (Interrupt : Interrupt_ID); + -- This procedure does not do anything if a signal is blocked. + -- Otherwise, we have to interrupt Server_Task for status change + -- through an abort signal. + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False); + + procedure Unprotected_Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean); + + ------------------ + -- Bind_Handler -- + ------------------ + + procedure Bind_Handler (Interrupt : Interrupt_ID) is + begin + Install_Umbrella_Handler + (HW_Interrupt (Interrupt), Notify_Interrupt'Access); + end Bind_Handler; + + -------------------- + -- Unbind_Handler -- + -------------------- + + procedure Unbind_Handler (Interrupt : Interrupt_ID) is + Status : int; + begin + + -- Flush server task off semaphore, allowing it to terminate + + Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt)); + pragma Assert (Status = 0); + end Unbind_Handler; + + -------------------------------- + -- Unprotected_Detach_Handler -- + -------------------------------- + + procedure Unprotected_Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean) + is + Old_Handler : Parameterless_Handler; + begin + if User_Entry (Interrupt).T /= Null_Task then + -- If an interrupt entry is installed raise + -- Program_Error. (propagate it to the caller). + + raise Program_Error with + "An interrupt entry is already installed"; + end if; + + -- Note : Static = True will pass the following check. This is the + -- case when we want to detach a handler regardless of the static + -- status of the Current_Handler. + + if not Static and then User_Handler (Interrupt).Static then + + -- Trying to detach a static Interrupt Handler. raise + -- Program_Error. + + raise Program_Error with + "Trying to detach a static Interrupt Handler"; + end if; + + Old_Handler := User_Handler (Interrupt).H; + + -- The new handler + + User_Handler (Interrupt).H := null; + User_Handler (Interrupt).Static := False; + + if Old_Handler /= null then + Unbind_Handler (Interrupt); + end if; + end Unprotected_Detach_Handler; + + ---------------------------------- + -- Unprotected_Exchange_Handler -- + ---------------------------------- + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False) + is + begin + if User_Entry (Interrupt).T /= Null_Task then + + -- If an interrupt entry is already installed, raise + -- Program_Error. (propagate it to the caller). + + raise Program_Error with "An interrupt is already installed"; + end if; + + -- Note : A null handler with Static = True will + -- pass the following check. This is the case when we want to + -- detach a handler regardless of the Static status + -- of Current_Handler. + -- We don't check anything if Restoration is True, since we + -- may be detaching a static handler to restore a dynamic one. + + if not Restoration and then not Static + and then (User_Handler (Interrupt).Static + + -- Trying to overwrite a static Interrupt Handler with a + -- dynamic Handler + + -- The new handler is not specified as an + -- Interrupt Handler by a pragma. + + or else not Is_Registered (New_Handler)) + then + raise Program_Error with + "Trying to overwrite a static Interrupt Handler with a " & + "dynamic Handler"; + end if; + + -- Save the old handler + + Old_Handler := User_Handler (Interrupt).H; + + -- The new handler + + User_Handler (Interrupt).H := New_Handler; + + if New_Handler = null then + + -- The null handler means we are detaching the handler + + User_Handler (Interrupt).Static := False; + + else + User_Handler (Interrupt).Static := Static; + end if; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_Id info in Server_ID array. + + if New_Handler /= null + and then + (Server_ID (Interrupt) = Null_Task + or else + Ada.Task_Identification.Is_Terminated + (To_Ada (Server_ID (Interrupt)))) + then + Interrupt_Access_Hold := + new Interrupt_Server_Task (Interrupt, Binary_Semaphore_Create); + Server_ID (Interrupt) := + To_System (Interrupt_Access_Hold.all'Identity); + end if; + + if (New_Handler = null) and then Old_Handler /= null then + + -- Restore default handler + + Unbind_Handler (Interrupt); + + elsif Old_Handler = null then + + -- Save default handler + + Bind_Handler (Interrupt); + end if; + end Unprotected_Exchange_Handler; + + -- Start of processing for Interrupt_Manager + + begin + -- By making this task independent of any master, when the process + -- goes away, the Interrupt_Manager will terminate gracefully. + + System.Tasking.Utilities.Make_Independent; + + loop + -- A block is needed to absorb Program_Error exception + + declare + Old_Handler : Parameterless_Handler; + + begin + select + accept Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static, Restoration); + end Attach_Handler; + + or + accept Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + end Exchange_Handler; + + or + accept Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Detach_Handler (Interrupt, Static); + end Detach_Handler; + or + accept Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Interrupt : Interrupt_ID) + do + -- If there is a binding already (either a procedure or an + -- entry), raise Program_Error (propagate it to the caller). + + if User_Handler (Interrupt).H /= null + or else User_Entry (Interrupt).T /= Null_Task + then + raise Program_Error with + "A binding for this interrupt is already present"; + end if; + + User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); + + -- Indicate the attachment of interrupt entry in the ATCB. + -- This is needed so when an interrupt entry task terminates + -- the binding can be cleaned. The call to unbinding must be + -- make by the task before it terminates. + + T.Interrupt_Entry := True; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_Id info in Server_ID array. + + if Server_ID (Interrupt) = Null_Task + or else + Ada.Task_Identification.Is_Terminated + (To_Ada (Server_ID (Interrupt))) + then + Interrupt_Access_Hold := new Interrupt_Server_Task + (Interrupt, Binary_Semaphore_Create); + Server_ID (Interrupt) := + To_System (Interrupt_Access_Hold.all'Identity); + end if; + + Bind_Handler (Interrupt); + end Bind_Interrupt_To_Entry; + + or + accept Detach_Interrupt_Entries (T : Task_Id) do + for Int in Interrupt_ID'Range loop + if not Is_Reserved (Int) then + if User_Entry (Int).T = T then + User_Entry (Int) := + Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (Int); + end if; + end if; + end loop; + + -- Indicate in ATCB that no interrupt entries are attached + + T.Interrupt_Entry := False; + end Detach_Interrupt_Entries; + end select; + + exception + -- If there is a Program_Error we just want to propagate it to + -- the caller and do not want to stop this task. + + when Program_Error => + null; + + when others => + pragma Assert (False); + null; + end; + end loop; + + exception + when Standard'Abort_Signal => + -- Flush interrupt server semaphores, so they can terminate + Finalize_Interrupt_Servers; + raise; + end Interrupt_Manager; + + --------------------------- + -- Interrupt_Server_Task -- + --------------------------- + + -- Server task for vectored hardware interrupt handling + + task body Interrupt_Server_Task is + Self_Id : constant Task_Id := Self; + Tmp_Handler : Parameterless_Handler; + Tmp_ID : Task_Id; + Tmp_Entry_Index : Task_Entry_Index; + Status : int; + + begin + System.Tasking.Utilities.Make_Independent; + Semaphore_ID_Map (Interrupt) := Int_Sema; + + loop + -- Pend on semaphore that will be triggered by the + -- umbrella handler when the associated interrupt comes in + + Status := Binary_Semaphore_Obtain (Int_Sema); + pragma Assert (Status = 0); + + if User_Handler (Interrupt).H /= null then + + -- Protected procedure handler + + Tmp_Handler := User_Handler (Interrupt).H; + Tmp_Handler.all; + + elsif User_Entry (Interrupt).T /= Null_Task then + + -- Interrupt entry handler + + Tmp_ID := User_Entry (Interrupt).T; + Tmp_Entry_Index := User_Entry (Interrupt).E; + System.Tasking.Rendezvous.Call_Simple + (Tmp_ID, Tmp_Entry_Index, System.Null_Address); + + else + -- Semaphore has been flushed by an unbind operation in + -- the Interrupt_Manager. Terminate the server task. + + -- Wait for the Interrupt_Manager to complete its work + + POP.Write_Lock (Self_Id); + + -- Unassociate the interrupt handler. + + Semaphore_ID_Map (Interrupt) := 0; + + -- Delete the associated semaphore + + Status := Binary_Semaphore_Delete (Int_Sema); + + pragma Assert (Status = 0); + + -- Set status for the Interrupt_Manager + + Server_ID (Interrupt) := Null_Task; + POP.Unlock (Self_Id); + + exit; + end if; + end loop; + end Interrupt_Server_Task; + + begin + -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent + + Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); + end System.Interrupts; diff -Nrcpad gcc-4.3.3/gcc/ada/s-interr-sigaction.adb gcc-4.4.0/gcc/ada/s-interr-sigaction.adb *** gcc-4.3.3/gcc/ada/s-interr-sigaction.adb Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-interr-sigaction.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 34,80 **** -- This is the IRIX & NT version of this package with Ada.Task_Identification; ! -- used for Task_Id ! with Ada.Exceptions; ! -- used for Raise_Exception with System.Storage_Elements; - -- used for To_Address - -- To_Integer - with System.Task_Primitives.Operations; - -- used for Self - -- Sleep - -- Wakeup - -- Write_Lock - -- Unlock - with System.Tasking.Utilities; - -- used for Make_Independent - with System.Tasking.Rendezvous; - -- used for Call_Simple - with System.Tasking.Initialization; - -- used for Defer_Abort - -- Undefer_Abort - with System.Interrupt_Management; - with System.Parameters; - -- used for Single_Lock - - with Interfaces.C; - -- used for int - - with Ada.Unchecked_Conversion; package body System.Interrupts is use Parameters; use Tasking; - use Ada.Exceptions; use System.OS_Interface; use Interfaces.C; --- 32,53 ---- -- This is the IRIX & NT version of this package with Ada.Task_Identification; ! with Ada.Unchecked_Conversion; ! with Interfaces.C; with System.Storage_Elements; with System.Task_Primitives.Operations; with System.Tasking.Utilities; with System.Tasking.Rendezvous; with System.Tasking.Initialization; with System.Interrupt_Management; with System.Parameters; package body System.Interrupts is use Parameters; use Tasking; use System.OS_Interface; use Interfaces.C; *************** package body System.Interrupts is *** 183,190 **** function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; return Descriptors (Interrupt).T /= Null_Task; --- 156,163 ---- function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; return Descriptors (Interrupt).T /= Null_Task; *************** package body System.Interrupts is *** 197,207 **** function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; - - return Descriptors (Interrupt).Kind /= Unknown; end Is_Handler_Attached; ---------------- --- 170,180 ---- function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; ! else ! return Descriptors (Interrupt).Kind /= Unknown; end if; end Is_Handler_Attached; ---------------- *************** package body System.Interrupts is *** 315,320 **** --- 288,304 ---- end loop; end Install_Handlers; + --------------------------------- + -- Install_Restricted_Handlers -- + --------------------------------- + + procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + begin + for N in Handlers'Range loop + Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); + end loop; + end Install_Restricted_Handlers; + --------------------- -- Current_Handler -- --------------------- *************** package body System.Interrupts is *** 370,378 **** or else not Is_Registered (New_Handler)) then ! Raise_Exception (Program_Error'Identity, "Trying to overwrite a static Interrupt Handler with a " & ! "dynamic Handler"); end if; if Handlers (Interrupt) = null then --- 354,362 ---- or else not Is_Registered (New_Handler)) then ! raise Program_Error with "Trying to overwrite a static Interrupt Handler with a " & ! "dynamic Handler"; end if; if Handlers (Interrupt) = null then *************** package body System.Interrupts is *** 420,431 **** -- In case we have an Interrupt Entry already installed. -- raise a program error. (propagate it to the caller). ! Raise_Exception (Program_Error'Identity, ! "An interrupt is already installed"); ! end if; ! Old_Handler := Current_Handler (Interrupt); ! Attach_Handler (New_Handler, Interrupt, Static); end Exchange_Handler; -------------------- --- 404,415 ---- -- In case we have an Interrupt Entry already installed. -- raise a program error. (propagate it to the caller). ! raise Program_Error with "An interrupt is already installed"; ! else ! Old_Handler := Current_Handler (Interrupt); ! Attach_Handler (New_Handler, Interrupt, Static); ! end if; end Exchange_Handler; -------------------- *************** package body System.Interrupts is *** 442,454 **** end if; if Descriptors (Interrupt).Kind = Task_Entry then ! Raise_Exception (Program_Error'Identity, ! "Trying to detach an Interrupt Entry"); end if; if not Static and then Descriptors (Interrupt).Static then ! Raise_Exception (Program_Error'Identity, ! "Trying to detach a static Interrupt Handler"); end if; Descriptors (Interrupt) := --- 426,437 ---- end if; if Descriptors (Interrupt).Kind = Task_Entry then ! raise Program_Error with "Trying to detach an Interrupt Entry"; end if; if not Static and then Descriptors (Interrupt).Static then ! raise Program_Error with ! "Trying to detach a static Interrupt Handler"; end if; Descriptors (Interrupt) := *************** package body System.Interrupts is *** 548,555 **** end if; if Descriptors (Interrupt).Kind /= Unknown then ! Raise_Exception (Program_Error'Identity, ! "A binding for this interrupt is already present"); end if; if Handlers (Interrupt) = null then --- 531,538 ---- end if; if Descriptors (Interrupt).Kind /= Unknown then ! raise Program_Error with ! "A binding for this interrupt is already present"; end if; if Handlers (Interrupt) = null then diff -Nrcpad gcc-4.3.3/gcc/ada/s-interr-vms.adb gcc-4.4.0/gcc/ada/s-interr-vms.adb *** gcc-4.3.3/gcc/ada/s-interr-vms.adb Tue Aug 14 09:05:23 2007 --- gcc-4.4.0/gcc/ada/s-interr-vms.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 49,125 **** -- rendezvous. with Ada.Task_Identification; ! -- used for Task_Id type ! ! with Ada.Exceptions; ! -- used for Raise_Exception with System.Task_Primitives; - -- used for RTS_Lock - -- Self - with System.Interrupt_Management; - -- used for Reserve - -- Interrupt_ID - -- Interrupt_Mask - -- Abort_Task_Interrupt with System.Interrupt_Management.Operations; - -- used for Thread_Block_Interrupt - -- Thread_Unblock_Interrupt - -- Install_Default_Action - -- Install_Ignore_Action - -- Copy_Interrupt_Mask - -- Set_Interrupt_Mask - -- Empty_Interrupt_Mask - -- Fill_Interrupt_Mask - -- Add_To_Interrupt_Mask - -- Delete_From_Interrupt_Mask - -- Interrupt_Wait - -- Interrupt_Self_Process - -- Get_Interrupt_Mask - -- Set_Interrupt_Mask - -- IS_Member - -- Environment_Mask pragma Elaborate_All (System.Interrupt_Management.Operations); with System.Task_Primitives.Operations; - -- used for Write_Lock - -- Unlock - -- Abort - -- Wakeup_Task - -- Sleep - -- Initialize_Lock - with System.Task_Primitives.Interrupt_Operations; - -- used for Set_Interrupt_ID - with System.Storage_Elements; - -- used for To_Address - -- To_Integer - -- Integer_Address - with System.Tasking.Utilities; - -- used for Make_Independent with System.Tasking.Rendezvous; - -- used for Call_Simple pragma Elaborate_All (System.Tasking.Rendezvous); with System.Tasking.Initialization; - -- used for Defer_Abort - -- Undefer_Abort - with System.Parameters; - -- used for Single_Lock - - with Ada.Unchecked_Conversion; package body System.Interrupts is use Tasking; use System.Parameters; - use Ada.Exceptions; package POP renames System.Task_Primitives.Operations; package PIO renames System.Task_Primitives.Interrupt_Operations; --- 47,75 ---- -- rendezvous. with Ada.Task_Identification; ! with Ada.Unchecked_Conversion; with System.Task_Primitives; with System.Interrupt_Management; with System.Interrupt_Management.Operations; pragma Elaborate_All (System.Interrupt_Management.Operations); with System.Task_Primitives.Operations; with System.Task_Primitives.Interrupt_Operations; with System.Storage_Elements; with System.Tasking.Utilities; with System.Tasking.Rendezvous; pragma Elaborate_All (System.Tasking.Rendezvous); with System.Tasking.Initialization; with System.Parameters; package body System.Interrupts is use Tasking; use System.Parameters; package POP renames System.Task_Primitives.Operations; package PIO renames System.Task_Primitives.Interrupt_Operations; *************** package body System.Interrupts is *** 270,276 **** begin -- This routine registers the Handler as usable for Dynamic -- Interrupt Handler. Routines attaching and detaching Handler ! -- dynamically should first consult if the Handler is rgistered. -- A Program Error should be raised if it is not registered. -- The pragma Interrupt_Handler can only appear in the library --- 220,226 ---- begin -- This routine registers the Handler as usable for Dynamic -- Interrupt Handler. Routines attaching and detaching Handler ! -- dynamically should first consult if the Handler is registered. -- A Program Error should be raised if it is not registered. -- The pragma Interrupt_Handler can only appear in the library *************** package body System.Interrupts is *** 345,352 **** function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; return User_Entry (Interrupt).T /= Null_Task; --- 295,302 ---- function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; return User_Entry (Interrupt).T /= Null_Task; *************** package body System.Interrupts is *** 359,366 **** function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; return User_Handler (Interrupt).H /= null; --- 309,316 ---- function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; return User_Handler (Interrupt).H /= null; *************** package body System.Interrupts is *** 373,380 **** function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; return Blocked (Interrupt); --- 323,330 ---- function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; return Blocked (Interrupt); *************** package body System.Interrupts is *** 387,394 **** function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; return Ignored (Interrupt); --- 337,344 ---- function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; return Ignored (Interrupt); *************** package body System.Interrupts is *** 403,410 **** is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; -- ??? Since Parameterless_Handler is not Atomic, the current --- 353,360 ---- is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; -- ??? Since Parameterless_Handler is not Atomic, the current *************** package body System.Interrupts is *** 420,426 **** -- Calling this procedure with New_Handler = null and Static = True -- means we want to detach the current handler regardless of the ! -- previous handler's binding status (ie. do not care if it is a -- dynamic or static handler). -- This option is needed so that during the finalization of a PO, we --- 370,376 ---- -- Calling this procedure with New_Handler = null and Static = True -- means we want to detach the current handler regardless of the ! -- previous handler's binding status (i.e. do not care if it is a -- dynamic or static handler). -- This option is needed so that during the finalization of a PO, we *************** package body System.Interrupts is *** 432,439 **** Static : Boolean := False) is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); --- 382,389 ---- Static : Boolean := False) is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); *************** package body System.Interrupts is *** 446,452 **** -- Calling this procedure with New_Handler = null and Static = True means -- we want to detach the current handler regardless of the previous ! -- handler's binding status (ie. do not care if it is dynamic or static -- handler). -- This option is needed so that during the finalization of a PO, we can --- 396,402 ---- -- Calling this procedure with New_Handler = null and Static = True means -- we want to detach the current handler regardless of the previous ! -- handler's binding status (i.e. do not care if it is dynamic or static -- handler). -- This option is needed so that during the finalization of a PO, we can *************** package body System.Interrupts is *** 460,467 **** is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Exchange_Handler --- 410,417 ---- is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Exchange_Handler *************** package body System.Interrupts is *** 486,493 **** is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Detach_Handler (Interrupt, Static); --- 436,443 ---- is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Detach_Handler (Interrupt, Static); *************** package body System.Interrupts is *** 500,507 **** function Reference (Interrupt : Interrupt_ID) return System.Address is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; return Storage_Elements.To_Address --- 450,457 ---- function Reference (Interrupt : Interrupt_ID) return System.Address is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; return Storage_Elements.To_Address *************** package body System.Interrupts is *** 526,533 **** begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); --- 476,483 ---- begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); *************** package body System.Interrupts is *** 550,557 **** procedure Block_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Block_Interrupt (Interrupt); --- 500,507 ---- procedure Block_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Block_Interrupt (Interrupt); *************** package body System.Interrupts is *** 564,571 **** procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Unblock_Interrupt (Interrupt); --- 514,521 ---- procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Unblock_Interrupt (Interrupt); *************** package body System.Interrupts is *** 579,586 **** (Interrupt : Interrupt_ID) return System.Tasking.Task_Id is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; return Last_Unblocker (Interrupt); --- 529,536 ---- (Interrupt : Interrupt_ID) return System.Tasking.Task_Id is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; return Last_Unblocker (Interrupt); *************** package body System.Interrupts is *** 593,600 **** procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Ignore_Interrupt (Interrupt); --- 543,550 ---- procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Ignore_Interrupt (Interrupt); *************** package body System.Interrupts is *** 607,614 **** procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Unignore_Interrupt (Interrupt); --- 557,564 ---- procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Unignore_Interrupt (Interrupt); *************** package body System.Interrupts is *** 648,668 **** is begin if User_Entry (Interrupt).T /= Null_Task then -- In case we have an Interrupt Entry already installed. -- raise a program error. (propagate it to the caller). ! Raise_Exception (Program_Error'Identity, ! "An interrupt is already installed"); end if; ! -- Note : A null handler with Static = True will ! -- pass the following check. That is the case when we want to ! -- Detach a handler regardless of the Static status ! -- of the current_Handler. ! -- We don't check anything if Restoration is True, since we ! -- may be detaching a static handler to restore a dynamic one. if not Restoration and then not Static -- Tries to overwrite a static Interrupt Handler with a -- dynamic Handler --- 598,618 ---- is begin if User_Entry (Interrupt).T /= Null_Task then + -- In case we have an Interrupt Entry already installed. -- raise a program error. (propagate it to the caller). ! raise Program_Error with "An interrupt is already installed"; end if; ! -- Note: A null handler with Static=True will pass the following ! -- check. That is the case when we want to Detach a handler ! -- regardless of the Static status of the current_Handler. We don't ! -- check anything if Restoration is True, since we may be detaching ! -- a static handler to restore a dynamic one. if not Restoration and then not Static + -- Tries to overwrite a static Interrupt Handler with a -- dynamic Handler *************** package body System.Interrupts is *** 673,684 **** or else not Is_Registered (New_Handler)) then ! Raise_Exception (Program_Error'Identity, "Trying to overwrite a static Interrupt Handler with a " & ! "dynamic Handler"); end if; ! -- The interrupt should no longer be ingnored if it was ever ignored Ignored (Interrupt) := False; --- 623,634 ---- or else not Is_Registered (New_Handler)) then ! raise Program_Error with "Trying to overwrite a static Interrupt Handler with a " & ! "dynamic Handler"; end if; ! -- The interrupt should no longer be ignored if it was ever ignored Ignored (Interrupt) := False; *************** package body System.Interrupts is *** 722,732 **** is begin if User_Entry (Interrupt).T /= Null_Task then -- In case we have an Interrupt Entry installed. -- raise a program error. (propagate it to the caller). ! Raise_Exception (Program_Error'Identity, ! "An interrupt entry is already installed"); end if; -- Note : Static = True will pass the following check. That is the --- 672,683 ---- is begin if User_Entry (Interrupt).T /= Null_Task then + -- In case we have an Interrupt Entry installed. -- raise a program error. (propagate it to the caller). ! raise Program_Error with ! "An interrupt entry is already installed"; end if; -- Note : Static = True will pass the following check. That is the *************** package body System.Interrupts is *** 737,744 **** -- Tries to detach a static Interrupt Handler. -- raise a program error. ! Raise_Exception (Program_Error'Identity, ! "Trying to detach a static Interrupt Handler"); end if; -- The interrupt should no longer be ignored if --- 688,695 ---- -- Tries to detach a static Interrupt Handler. -- raise a program error. ! raise Program_Error with ! "Trying to detach a static Interrupt Handler"; end if; -- The interrupt should no longer be ignored if *************** package body System.Interrupts is *** 762,768 **** System.Tasking.Utilities.Make_Independent; ! -- Environmen task gets its own interrupt mask, saves it, -- and then masks all interrupts except the Keep_Unmasked set. -- During rendezvous, the Interrupt_Manager receives the old --- 713,719 ---- System.Tasking.Utilities.Make_Independent; ! -- Environment task gets its own interrupt mask, saves it, -- and then masks all interrupts except the Keep_Unmasked set. -- During rendezvous, the Interrupt_Manager receives the old *************** package body System.Interrupts is *** 783,804 **** -- Abort_Task_Interrupt is one of the Interrupt unmasked -- in all tasks. We mask the Interrupt in this particular task ! -- so that "sigwait" is possible to catch an explicitely sent -- Abort_Task_Interrupt from the Server_Tasks. -- This sigwaiting is needed so that we make sure a Server_Task is -- out of its own sigwait state. This extra synchronization is ! -- necessary to prevent following senarios. -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the -- Server_Task then changes its own interrupt mask (OS level). -- If an interrupt (corresponding to the Server_Task) arrives ! -- in the nean time we have the Interrupt_Manager umnasked and -- the Server_Task waiting on sigwait. -- 2) For unbinding handler, we install a default action in the -- Interrupt_Manager. POSIX.1c states that the result of using ! -- "sigwait" and "sigaction" simaltaneously on the same interrupt -- is undefined. Therefore, we need to be informed from the -- Server_Task of the fact that the Server_Task is out of its -- sigwait stage. --- 734,755 ---- -- Abort_Task_Interrupt is one of the Interrupt unmasked -- in all tasks. We mask the Interrupt in this particular task ! -- so that "sigwait" is possible to catch an explicitly sent -- Abort_Task_Interrupt from the Server_Tasks. -- This sigwaiting is needed so that we make sure a Server_Task is -- out of its own sigwait state. This extra synchronization is ! -- necessary to prevent following scenarios. -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the -- Server_Task then changes its own interrupt mask (OS level). -- If an interrupt (corresponding to the Server_Task) arrives ! -- in the mean time we have the Interrupt_Manager unmasked and -- the Server_Task waiting on sigwait. -- 2) For unbinding handler, we install a default action in the -- Interrupt_Manager. POSIX.1c states that the result of using ! -- "sigwait" and "sigaction" simultaneously on the same interrupt -- is undefined. Therefore, we need to be informed from the -- Server_Task of the fact that the Server_Task is out of its -- sigwait stage. *************** package body System.Interrupts is *** 849,859 **** if User_Handler (Interrupt).H /= null or else User_Entry (Interrupt).T /= Null_Task then ! Raise_Exception (Program_Error'Identity, ! "A binding for this interrupt is already present"); end if; ! -- The interrupt should no longer be ingnored if -- it was ever ignored. Ignored (Interrupt) := False; --- 800,810 ---- if User_Handler (Interrupt).H /= null or else User_Entry (Interrupt).T /= Null_Task then ! raise Program_Error with ! "A binding for this interrupt is already present"; end if; ! -- The interrupt should no longer be ignored if -- it was ever ignored. Ignored (Interrupt) := False; *************** package body System.Interrupts is *** 985,991 **** -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding -- a Procedure Handler or an Entry. Or it could be a wake up -- from status change (Unblocked -> Blocked). If that is not ! -- the case, we should exceute the attached Procedure or Entry. if Single_Lock then POP.Lock_RTS; --- 936,942 ---- -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding -- a Procedure Handler or an Entry. Or it could be a wake up -- from status change (Unblocked -> Blocked). If that is not ! -- the case, we should execute the attached Procedure or Entry. if Single_Lock then POP.Lock_RTS; *************** package body System.Interrupts is *** 1143,1148 **** --- 1094,1110 ---- end loop; end Install_Handlers; + --------------------------------- + -- Install_Restricted_Handlers -- + --------------------------------- + + procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + begin + for N in Handlers'Range loop + Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); + end loop; + end Install_Restricted_Handlers; + -- Elaboration code for package System.Interrupts begin diff -Nrcpad gcc-4.3.3/gcc/ada/s-interr-vxworks.adb gcc-4.4.0/gcc/ada/s-interr-vxworks.adb *** gcc-4.3.3/gcc/ada/s-interr-vxworks.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-interr-vxworks.adb Thu Jan 1 00:00:00 1970 *************** *** 1,1147 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- S Y S T E M . I N T E R R U P T S -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- - -- -- - -- GNARL 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. -- - -- Extensive contributions were provided by Ada Core Technologies, Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- Invariants: - - -- All user-handleable signals are masked at all times in all tasks/threads - -- except possibly for the Interrupt_Manager task. - - -- When a user task wants to have the effect of masking/unmasking an signal, - -- it must call Block_Interrupt/Unblock_Interrupt, which will have the effect - -- of unmasking/masking the signal in the Interrupt_Manager task. These - -- comments do not apply to vectored hardware interrupts, which may be masked - -- or unmasked using routined interfaced to the relevant VxWorks system - -- calls. - - -- Once we associate a Signal_Server_Task with an signal, the task never goes - -- away, and we never remove the association. On the other hand, it is more - -- convenient to terminate an associated Interrupt_Server_Task for a vectored - -- hardware interrupt (since we use a binary semaphore for synchronization - -- with the umbrella handler). - - -- There is no more than one signal per Signal_Server_Task and no more than - -- one Signal_Server_Task per signal. The same relation holds for hardware - -- interrupts and Interrupt_Server_Task's at any given time. That is, only - -- one non-terminated Interrupt_Server_Task exists for a give interrupt at - -- any time. - - -- Within this package, the lock L is used to protect the various status - -- tables. If there is a Server_Task associated with a signal or interrupt, - -- we use the per-task lock of the Server_Task instead so that we protect the - -- status between Interrupt_Manager and Server_Task. Protection among - -- service requests are ensured via user calls to the Interrupt_Manager - -- entries. - - -- This is the VxWorks version of this package, supporting vectored hardware - -- interrupts. - - with Ada.Unchecked_Conversion; - - with System.OS_Interface; use System.OS_Interface; - - with Interfaces.VxWorks; - - with Ada.Task_Identification; - -- used for Task_Id type - - with Ada.Exceptions; - -- used for Raise_Exception - - with System.Interrupt_Management; - -- used for Reserve - - with System.Task_Primitives.Operations; - -- used for Write_Lock - -- Unlock - -- Abort - -- Wakeup_Task - -- Sleep - -- Initialize_Lock - - with System.Storage_Elements; - -- used for To_Address - -- To_Integer - -- Integer_Address - - with System.Tasking.Utilities; - -- used for Make_Independent - - with System.Tasking.Rendezvous; - -- used for Call_Simple - pragma Elaborate_All (System.Tasking.Rendezvous); - - package body System.Interrupts is - - use Tasking; - use Ada.Exceptions; - - package POP renames System.Task_Primitives.Operations; - - function To_Ada is new Ada.Unchecked_Conversion - (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id); - - function To_System is new Ada.Unchecked_Conversion - (Ada.Task_Identification.Task_Id, Task_Id); - - ----------------- - -- Local Tasks -- - ----------------- - - -- WARNING: System.Tasking.Stages performs calls to this task with - -- low-level constructs. Do not change this spec without synchronizing it. - - task Interrupt_Manager is - entry Detach_Interrupt_Entries (T : Task_Id); - - entry Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False); - - entry Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean); - - entry Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean); - - entry Bind_Interrupt_To_Entry - (T : Task_Id; - E : Task_Entry_Index; - Interrupt : Interrupt_ID); - - pragma Interrupt_Priority (System.Interrupt_Priority'First); - end Interrupt_Manager; - - task type Interrupt_Server_Task - (Interrupt : Interrupt_ID; Int_Sema : SEM_ID) is - -- Server task for vectored hardware interrupt handling - pragma Interrupt_Priority (System.Interrupt_Priority'First + 2); - end Interrupt_Server_Task; - - type Interrupt_Task_Access is access Interrupt_Server_Task; - - ------------------------------- - -- Local Types and Variables -- - ------------------------------- - - type Entry_Assoc is record - T : Task_Id; - E : Task_Entry_Index; - end record; - - type Handler_Assoc is record - H : Parameterless_Handler; - Static : Boolean; -- Indicates static binding; - end record; - - User_Handler : array (Interrupt_ID) of Handler_Assoc := - (others => (null, Static => False)); - pragma Volatile_Components (User_Handler); - -- Holds the protected procedure handler (if any) and its Static - -- information for each interrupt or signal. A handler is static - -- iff it is specified through the pragma Attach_Handler. - - User_Entry : array (Interrupt_ID) of Entry_Assoc := - (others => (T => Null_Task, E => Null_Task_Entry)); - pragma Volatile_Components (User_Entry); - -- Holds the task and entry index (if any) for each interrupt / signal - - -- Type and Head, Tail of the list containing Registered Interrupt - -- Handlers. These definitions are used to register the handlers - -- specified by the pragma Interrupt_Handler. - - type Registered_Handler; - type R_Link is access all Registered_Handler; - - type Registered_Handler is record - H : System.Address := System.Null_Address; - Next : R_Link := null; - end record; - - Registered_Handler_Head : R_Link := null; - Registered_Handler_Tail : R_Link := null; - - Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id := - (others => System.Tasking.Null_Task); - pragma Atomic_Components (Server_ID); - -- Holds the Task_Id of the Server_Task for each interrupt / signal. - -- Task_Id is needed to accomplish locking per interrupt base. Also - -- is needed to determine whether to create a new Server_Task. - - Semaphore_ID_Map : array - (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) - of SEM_ID := (others => 0); - -- Array of binary semaphores associated with vectored interrupts - -- Note that the last bound should be Max_HW_Interrupt, but this will raise - -- Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes - -- instead. - - Interrupt_Access_Hold : Interrupt_Task_Access; - -- Variable for allocating an Interrupt_Server_Task - - Default_Handler : array (HW_Interrupt) of Interfaces.VxWorks.VOIDFUNCPTR; - -- Vectored interrupt handlers installed prior to program startup. - -- These are saved only when the umbrella handler is installed for - -- a given interrupt number. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID); - -- Check if Id is a reserved interrupt, and if so raise Program_Error - -- with an appropriate message, otherwise return. - - procedure Finalize_Interrupt_Servers; - -- Unbind the handlers for hardware interrupt server tasks at program - -- termination. - - function Is_Registered (Handler : Parameterless_Handler) return Boolean; - -- See if Handler has been "pragma"ed using Interrupt_Handler. - -- Always consider a null handler as registered. - - procedure Notify_Interrupt (Param : System.Address); - -- Umbrella handler for vectored interrupts (not signals) - - procedure Install_Default_Action (Interrupt : HW_Interrupt); - -- Restore a handler that was in place prior to program execution - - procedure Install_Umbrella_Handler - (Interrupt : HW_Interrupt; - Handler : Interfaces.VxWorks.VOIDFUNCPTR); - -- Install the runtime umbrella handler for a vectored hardware - -- interrupt - - procedure Unimplemented (Feature : String); - pragma No_Return (Unimplemented); - -- Used to mark a call to an unimplemented function. Raises Program_Error - -- with an appropriate message noting that Feature is unimplemented. - - -------------------- - -- Attach_Handler -- - -------------------- - - -- Calling this procedure with New_Handler = null and Static = True - -- means we want to detach the current handler regardless of the - -- previous handler's binding status (ie. do not care if it is a - -- dynamic or static handler). - - -- This option is needed so that during the finalization of a PO, we - -- can detach handlers attached through pragma Attach_Handler. - - procedure Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) is - begin - Check_Reserved_Interrupt (Interrupt); - Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); - end Attach_Handler; - - ----------------------------- - -- Bind_Interrupt_To_Entry -- - ----------------------------- - - -- This procedure raises a Program_Error if it tries to - -- bind an interrupt to which an Entry or a Procedure is - -- already bound. - - procedure Bind_Interrupt_To_Entry - (T : Task_Id; - E : Task_Entry_Index; - Int_Ref : System.Address) - is - Interrupt : constant Interrupt_ID := - Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); - - begin - Check_Reserved_Interrupt (Interrupt); - Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); - end Bind_Interrupt_To_Entry; - - --------------------- - -- Block_Interrupt -- - --------------------- - - procedure Block_Interrupt (Interrupt : Interrupt_ID) is - begin - Unimplemented ("Block_Interrupt"); - end Block_Interrupt; - - ------------------------------ - -- Check_Reserved_Interrupt -- - ------------------------------ - - procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - Raise_Exception - (Program_Error'Identity, - "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"); - else - return; - end if; - end Check_Reserved_Interrupt; - - --------------------- - -- Current_Handler -- - --------------------- - - function Current_Handler - (Interrupt : Interrupt_ID) return Parameterless_Handler - is - begin - Check_Reserved_Interrupt (Interrupt); - - -- ??? Since Parameterless_Handler is not Atomic, the - -- current implementation is wrong. We need a new service in - -- Interrupt_Manager to ensure atomicity. - - return User_Handler (Interrupt).H; - end Current_Handler; - - -------------------- - -- Detach_Handler -- - -------------------- - - -- Calling this procedure with Static = True means we want to Detach the - -- current handler regardless of the previous handler's binding status - -- (i.e. do not care if it is a dynamic or static handler). - - -- This option is needed so that during the finalization of a PO, we can - -- detach handlers attached through pragma Attach_Handler. - - procedure Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean := False) is - begin - Check_Reserved_Interrupt (Interrupt); - Interrupt_Manager.Detach_Handler (Interrupt, Static); - end Detach_Handler; - - ------------------------------ - -- Detach_Interrupt_Entries -- - ------------------------------ - - procedure Detach_Interrupt_Entries (T : Task_Id) is - begin - Interrupt_Manager.Detach_Interrupt_Entries (T); - end Detach_Interrupt_Entries; - - ---------------------- - -- Exchange_Handler -- - ---------------------- - - -- Calling this procedure with New_Handler = null and Static = True - -- means we want to detach the current handler regardless of the - -- previous handler's binding status (ie. do not care if it is a - -- dynamic or static handler). - - -- This option is needed so that during the finalization of a PO, we - -- can detach handlers attached through pragma Attach_Handler. - - procedure Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) - is - begin - Check_Reserved_Interrupt (Interrupt); - Interrupt_Manager.Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static); - end Exchange_Handler; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Static_Interrupt_Protection) is - begin - -- ??? loop to be executed only when we're not doing library level - -- finalization, since in this case all interrupt / signal tasks are - -- gone. - - if not Interrupt_Manager'Terminated then - for N in reverse Object.Previous_Handlers'Range loop - Interrupt_Manager.Attach_Handler - (New_Handler => Object.Previous_Handlers (N).Handler, - Interrupt => Object.Previous_Handlers (N).Interrupt, - Static => Object.Previous_Handlers (N).Static, - Restoration => True); - end loop; - end if; - - Tasking.Protected_Objects.Entries.Finalize - (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); - end Finalize; - - -------------------------------- - -- Finalize_Interrupt_Servers -- - -------------------------------- - - -- Restore default handlers for interrupt servers - - -- This is called by the Interrupt_Manager task when it receives the abort - -- signal during program finalization. - - procedure Finalize_Interrupt_Servers is - HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0; - - begin - if HW_Interrupts then - for Int in HW_Interrupt loop - if Server_ID (Interrupt_ID (Int)) /= null - and then - not Ada.Task_Identification.Is_Terminated - (To_Ada (Server_ID (Interrupt_ID (Int)))) - then - Interrupt_Manager.Attach_Handler - (New_Handler => null, - Interrupt => Interrupt_ID (Int), - Static => True, - Restoration => True); - end if; - end loop; - end if; - end Finalize_Interrupt_Servers; - - ------------------------------------- - -- Has_Interrupt_Or_Attach_Handler -- - ------------------------------------- - - function Has_Interrupt_Or_Attach_Handler - (Object : access Dynamic_Interrupt_Protection) - return Boolean - is - pragma Unreferenced (Object); - begin - return True; - end Has_Interrupt_Or_Attach_Handler; - - function Has_Interrupt_Or_Attach_Handler - (Object : access Static_Interrupt_Protection) - return Boolean - is - pragma Unreferenced (Object); - begin - return True; - end Has_Interrupt_Or_Attach_Handler; - - ---------------------- - -- Ignore_Interrupt -- - ---------------------- - - procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is - begin - Unimplemented ("Ignore_Interrupt"); - end Ignore_Interrupt; - - ---------------------------- - -- Install_Default_Action -- - ---------------------------- - - procedure Install_Default_Action (Interrupt : HW_Interrupt) is - begin - -- Restore original interrupt handler - - Interfaces.VxWorks.intVecSet - (Interfaces.VxWorks.INUM_TO_IVEC (Integer (Interrupt)), - Default_Handler (Interrupt)); - Default_Handler (Interrupt) := null; - end Install_Default_Action; - - ---------------------- - -- Install_Handlers -- - ---------------------- - - procedure Install_Handlers - (Object : access Static_Interrupt_Protection; - New_Handlers : New_Handler_Array) - is - begin - for N in New_Handlers'Range loop - - -- We need a lock around this ??? - - Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; - Object.Previous_Handlers (N).Static := User_Handler - (New_Handlers (N).Interrupt).Static; - - -- We call Exchange_Handler and not directly Interrupt_Manager. - -- Exchange_Handler so we get the Is_Reserved check. - - Exchange_Handler - (Old_Handler => Object.Previous_Handlers (N).Handler, - New_Handler => New_Handlers (N).Handler, - Interrupt => New_Handlers (N).Interrupt, - Static => True); - end loop; - end Install_Handlers; - - ------------------------------ - -- Install_Umbrella_Handler -- - ------------------------------ - - procedure Install_Umbrella_Handler - (Interrupt : HW_Interrupt; - Handler : Interfaces.VxWorks.VOIDFUNCPTR) - is - use Interfaces.VxWorks; - - Vec : constant Interrupt_Vector := - INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)); - - Old_Handler : constant VOIDFUNCPTR := - intVecGet - (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt))); - - Stat : Interfaces.VxWorks.STATUS; - pragma Unreferenced (Stat); - -- ??? shouldn't we test Stat at least in a pragma Assert? - - begin - -- Only install umbrella handler when no Ada handler has already been - -- installed. Note that the interrupt number is passed as a parameter - -- when an interrupt occurs, so the umbrella handler has a different - -- wrapper generated by intConnect for each interrupt number. - - if Default_Handler (Interrupt) = null then - Stat := - intConnect (Vec, Handler, System.Address (Interrupt)); - Default_Handler (Interrupt) := Old_Handler; - end if; - end Install_Umbrella_Handler; - - ---------------- - -- Is_Blocked -- - ---------------- - - function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is - begin - Unimplemented ("Is_Blocked"); - return False; - end Is_Blocked; - - ----------------------- - -- Is_Entry_Attached -- - ----------------------- - - function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - Check_Reserved_Interrupt (Interrupt); - return User_Entry (Interrupt).T /= Null_Task; - end Is_Entry_Attached; - - ------------------------- - -- Is_Handler_Attached -- - ------------------------- - - function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - Check_Reserved_Interrupt (Interrupt); - return User_Handler (Interrupt).H /= null; - end Is_Handler_Attached; - - ---------------- - -- Is_Ignored -- - ---------------- - - function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is - begin - Unimplemented ("Is_Ignored"); - return False; - end Is_Ignored; - - ------------------- - -- Is_Registered -- - ------------------- - - function Is_Registered (Handler : Parameterless_Handler) return Boolean is - type Fat_Ptr is record - Object_Addr : System.Address; - Handler_Addr : System.Address; - end record; - - function To_Fat_Ptr is new Ada.Unchecked_Conversion - (Parameterless_Handler, Fat_Ptr); - - Ptr : R_Link; - Fat : Fat_Ptr; - - begin - if Handler = null then - return True; - end if; - - Fat := To_Fat_Ptr (Handler); - - Ptr := Registered_Handler_Head; - - while Ptr /= null loop - if Ptr.H = Fat.Handler_Addr then - return True; - end if; - - Ptr := Ptr.Next; - end loop; - - return False; - end Is_Registered; - - ----------------- - -- Is_Reserved -- - ----------------- - - function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is - use System.Interrupt_Management; - begin - return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt)); - end Is_Reserved; - - ---------------------- - -- Notify_Interrupt -- - ---------------------- - - -- Umbrella handler for vectored hardware interrupts (as opposed to - -- signals and exceptions). As opposed to the signal implementation, - -- this handler is only installed in the vector table while there is - -- an active association of an Ada handler to the interrupt. - - -- Otherwise, the handler that existed prior to program startup is - -- in the vector table. This ensures that handlers installed by - -- the BSP are active unless explicitly replaced in the program text. - - -- Each Interrupt_Server_Task has an associated binary semaphore - -- on which it pends once it's been started. This routine determines - -- The appropriate semaphore and and issues a semGive call, waking - -- the server task. When a handler is unbound, - -- System.Interrupts.Unbind_Handler issues a semFlush, and the - -- server task deletes its semaphore and terminates. - - procedure Notify_Interrupt (Param : System.Address) is - Interrupt : constant Interrupt_ID := Interrupt_ID (Param); - - Discard_Result : STATUS; - pragma Unreferenced (Discard_Result); - - begin - Discard_Result := semGive (Semaphore_ID_Map (Interrupt)); - end Notify_Interrupt; - - --------------- - -- Reference -- - --------------- - - function Reference (Interrupt : Interrupt_ID) return System.Address is - begin - Check_Reserved_Interrupt (Interrupt); - return Storage_Elements.To_Address - (Storage_Elements.Integer_Address (Interrupt)); - end Reference; - - -------------------------------- - -- Register_Interrupt_Handler -- - -------------------------------- - - procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is - New_Node_Ptr : R_Link; - - begin - -- This routine registers a handler as usable for dynamic - -- interrupt handler association. Routines attaching and detaching - -- handlers dynamically should determine whether the handler is - -- registered. Program_Error should be raised if it is not registered. - - -- Pragma Interrupt_Handler can only appear in a library - -- level PO definition and instantiation. Therefore, we do not need - -- to implement an unregister operation. Nor do we need to - -- protect the queue structure with a lock. - - pragma Assert (Handler_Addr /= System.Null_Address); - - New_Node_Ptr := new Registered_Handler; - New_Node_Ptr.H := Handler_Addr; - - if Registered_Handler_Head = null then - Registered_Handler_Head := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - - else - Registered_Handler_Tail.Next := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - end if; - end Register_Interrupt_Handler; - - ----------------------- - -- Unblock_Interrupt -- - ----------------------- - - procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is - begin - Unimplemented ("Unblock_Interrupt"); - end Unblock_Interrupt; - - ------------------ - -- Unblocked_By -- - ------------------ - - function Unblocked_By - (Interrupt : Interrupt_ID) return System.Tasking.Task_Id - is - begin - Unimplemented ("Unblocked_By"); - return Null_Task; - end Unblocked_By; - - ------------------------ - -- Unignore_Interrupt -- - ------------------------ - - procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is - begin - Unimplemented ("Unignore_Interrupt"); - end Unignore_Interrupt; - - ------------------- - -- Unimplemented -- - ------------------- - - procedure Unimplemented (Feature : String) is - begin - Raise_Exception - (Program_Error'Identity, - Feature & " not implemented on VxWorks"); - end Unimplemented; - - ----------------------- - -- Interrupt_Manager -- - ----------------------- - - task body Interrupt_Manager is - - -------------------- - -- Local Routines -- - -------------------- - - procedure Bind_Handler (Interrupt : Interrupt_ID); - -- This procedure does not do anything if a signal is blocked. - -- Otherwise, we have to interrupt Server_Task for status change through - -- a wakeup signal. - - procedure Unbind_Handler (Interrupt : Interrupt_ID); - -- This procedure does not do anything if a signal is blocked. - -- Otherwise, we have to interrupt Server_Task for status change - -- through an abort signal. - - procedure Unprotected_Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False); - - procedure Unprotected_Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean); - - ------------------ - -- Bind_Handler -- - ------------------ - - procedure Bind_Handler (Interrupt : Interrupt_ID) is - begin - Install_Umbrella_Handler - (HW_Interrupt (Interrupt), Notify_Interrupt'Access); - end Bind_Handler; - - -------------------- - -- Unbind_Handler -- - -------------------- - - procedure Unbind_Handler (Interrupt : Interrupt_ID) is - S : STATUS; - use type STATUS; - - begin - -- Hardware interrupt - - Install_Default_Action (HW_Interrupt (Interrupt)); - - -- Flush server task off semaphore, allowing it to terminate - - S := semFlush (Semaphore_ID_Map (Interrupt)); - pragma Assert (S = 0); - end Unbind_Handler; - - -------------------------------- - -- Unprotected_Detach_Handler -- - -------------------------------- - - procedure Unprotected_Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean) - is - Old_Handler : Parameterless_Handler; - begin - if User_Entry (Interrupt).T /= Null_Task then - -- If an interrupt entry is installed raise - -- Program_Error. (propagate it to the caller). - - Raise_Exception (Program_Error'Identity, - "An interrupt entry is already installed"); - end if; - - -- Note : Static = True will pass the following check. This is the - -- case when we want to detach a handler regardless of the static - -- status of the Current_Handler. - - if not Static and then User_Handler (Interrupt).Static then - - -- Trying to detach a static Interrupt Handler. raise - -- Program_Error. - - Raise_Exception (Program_Error'Identity, - "Trying to detach a static Interrupt Handler"); - end if; - - Old_Handler := User_Handler (Interrupt).H; - - -- The new handler - - User_Handler (Interrupt).H := null; - User_Handler (Interrupt).Static := False; - - if Old_Handler /= null then - Unbind_Handler (Interrupt); - end if; - end Unprotected_Detach_Handler; - - ---------------------------------- - -- Unprotected_Exchange_Handler -- - ---------------------------------- - - procedure Unprotected_Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False) - is - begin - if User_Entry (Interrupt).T /= Null_Task then - - -- If an interrupt entry is already installed, raise - -- Program_Error. (propagate it to the caller). - - Raise_Exception - (Program_Error'Identity, - "An interrupt is already installed"); - end if; - - -- Note : A null handler with Static = True will - -- pass the following check. This is the case when we want to - -- detach a handler regardless of the Static status - -- of Current_Handler. - -- We don't check anything if Restoration is True, since we - -- may be detaching a static handler to restore a dynamic one. - - if not Restoration and then not Static - and then (User_Handler (Interrupt).Static - - -- Trying to overwrite a static Interrupt Handler with a - -- dynamic Handler - - -- The new handler is not specified as an - -- Interrupt Handler by a pragma. - - or else not Is_Registered (New_Handler)) - then - Raise_Exception - (Program_Error'Identity, - "Trying to overwrite a static Interrupt Handler with a " & - "dynamic Handler"); - end if; - - -- Save the old handler - - Old_Handler := User_Handler (Interrupt).H; - - -- The new handler - - User_Handler (Interrupt).H := New_Handler; - - if New_Handler = null then - - -- The null handler means we are detaching the handler - - User_Handler (Interrupt).Static := False; - - else - User_Handler (Interrupt).Static := Static; - end if; - - -- Invoke a corresponding Server_Task if not yet created. - -- Place Task_Id info in Server_ID array. - - if New_Handler /= null - and then - (Server_ID (Interrupt) = Null_Task - or else - Ada.Task_Identification.Is_Terminated - (To_Ada (Server_ID (Interrupt)))) - then - Interrupt_Access_Hold := - new Interrupt_Server_Task - (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); - Server_ID (Interrupt) := - To_System (Interrupt_Access_Hold.all'Identity); - end if; - - if (New_Handler = null) and then Old_Handler /= null then - - -- Restore default handler - - Unbind_Handler (Interrupt); - - elsif Old_Handler = null then - - -- Save default handler - - Bind_Handler (Interrupt); - end if; - end Unprotected_Exchange_Handler; - - -- Start of processing for Interrupt_Manager - - begin - -- By making this task independent of any master, when the process - -- goes away, the Interrupt_Manager will terminate gracefully. - - System.Tasking.Utilities.Make_Independent; - - loop - -- A block is needed to absorb Program_Error exception - - declare - Old_Handler : Parameterless_Handler; - - begin - select - accept Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False) - do - Unprotected_Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static, Restoration); - end Attach_Handler; - - or - accept Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean) - do - Unprotected_Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static); - end Exchange_Handler; - - or - accept Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean) - do - Unprotected_Detach_Handler (Interrupt, Static); - end Detach_Handler; - or - accept Bind_Interrupt_To_Entry - (T : Task_Id; - E : Task_Entry_Index; - Interrupt : Interrupt_ID) - do - -- If there is a binding already (either a procedure or an - -- entry), raise Program_Error (propagate it to the caller). - - if User_Handler (Interrupt).H /= null - or else User_Entry (Interrupt).T /= Null_Task - then - Raise_Exception - (Program_Error'Identity, - "A binding for this interrupt is already present"); - end if; - - User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); - - -- Indicate the attachment of interrupt entry in the ATCB. - -- This is needed so when an interrupt entry task terminates - -- the binding can be cleaned. The call to unbinding must be - -- make by the task before it terminates. - - T.Interrupt_Entry := True; - - -- Invoke a corresponding Server_Task if not yet created. - -- Place Task_Id info in Server_ID array. - - if Server_ID (Interrupt) = Null_Task - or else - Ada.Task_Identification.Is_Terminated - (To_Ada (Server_ID (Interrupt))) - then - Interrupt_Access_Hold := new Interrupt_Server_Task - (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); - Server_ID (Interrupt) := - To_System (Interrupt_Access_Hold.all'Identity); - end if; - - Bind_Handler (Interrupt); - end Bind_Interrupt_To_Entry; - - or - accept Detach_Interrupt_Entries (T : Task_Id) do - for Int in Interrupt_ID'Range loop - if not Is_Reserved (Int) then - if User_Entry (Int).T = T then - User_Entry (Int) := - Entry_Assoc' - (T => Null_Task, E => Null_Task_Entry); - Unbind_Handler (Int); - end if; - end if; - end loop; - - -- Indicate in ATCB that no interrupt entries are attached - - T.Interrupt_Entry := False; - end Detach_Interrupt_Entries; - end select; - - exception - -- If there is a Program_Error we just want to propagate it to - -- the caller and do not want to stop this task. - - when Program_Error => - null; - - when others => - pragma Assert (False); - null; - end; - end loop; - - exception - when Standard'Abort_Signal => - -- Flush interrupt server semaphores, so they can terminate - Finalize_Interrupt_Servers; - raise; - end Interrupt_Manager; - - --------------------------- - -- Interrupt_Server_Task -- - --------------------------- - - -- Server task for vectored hardware interrupt handling - - task body Interrupt_Server_Task is - Self_Id : constant Task_Id := Self; - Tmp_Handler : Parameterless_Handler; - Tmp_ID : Task_Id; - Tmp_Entry_Index : Task_Entry_Index; - S : STATUS; - - use type STATUS; - - begin - System.Tasking.Utilities.Make_Independent; - Semaphore_ID_Map (Interrupt) := Int_Sema; - - loop - -- Pend on semaphore that will be triggered by the - -- umbrella handler when the associated interrupt comes in - - S := semTake (Int_Sema, WAIT_FOREVER); - pragma Assert (S = 0); - - if User_Handler (Interrupt).H /= null then - - -- Protected procedure handler - - Tmp_Handler := User_Handler (Interrupt).H; - Tmp_Handler.all; - - elsif User_Entry (Interrupt).T /= Null_Task then - - -- Interrupt entry handler - - Tmp_ID := User_Entry (Interrupt).T; - Tmp_Entry_Index := User_Entry (Interrupt).E; - System.Tasking.Rendezvous.Call_Simple - (Tmp_ID, Tmp_Entry_Index, System.Null_Address); - - else - -- Semaphore has been flushed by an unbind operation in - -- the Interrupt_Manager. Terminate the server task. - - -- Wait for the Interrupt_Manager to complete its work - - POP.Write_Lock (Self_Id); - - -- Delete the associated semaphore - - S := semDelete (Int_Sema); - - pragma Assert (S = 0); - - -- Set status for the Interrupt_Manager - - Semaphore_ID_Map (Interrupt) := 0; - Server_ID (Interrupt) := Null_Task; - POP.Unlock (Self_Id); - - exit; - end if; - end loop; - end Interrupt_Server_Task; - - begin - -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent - - Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); - end System.Interrupts; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-interr.adb gcc-4.4.0/gcc/ada/s-interr.adb *** gcc-4.3.3/gcc/ada/s-interr.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/s-interr.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 44,50 **** -- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any -- other low-level interface that changes the interrupt action or -- interrupt mask needs a careful thought. ! -- One may acheive the effect of system calls first masking RTS blocked -- (by calling Block_Interrupt) for the interrupt under consideration. -- This will make all the tasks in RTS blocked for the Interrupt. --- 42,48 ---- -- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any -- other low-level interface that changes the interrupt action or -- interrupt mask needs a careful thought. ! -- One may achieve the effect of system calls first masking RTS blocked -- (by calling Block_Interrupt) for the interrupt under consideration. -- This will make all the tasks in RTS blocked for the Interrupt. *************** *** 55,124 **** -- one Server_Task per interrupt. with Ada.Task_Identification; - -- used for Task_Id type - - with Ada.Exceptions; - -- used for Raise_Exception with System.Task_Primitives; - -- used for RTS_Lock - -- Self - with System.Interrupt_Management; - -- used for Reserve - -- Interrupt_ID - -- Interrupt_Mask - -- Abort_Task_Interrupt with System.Interrupt_Management.Operations; - -- used for Thread_Block_Interrupt - -- Thread_Unblock_Interrupt - -- Install_Default_Action - -- Install_Ignore_Action - -- Copy_Interrupt_Mask - -- Set_Interrupt_Mask - -- Empty_Interrupt_Mask - -- Fill_Interrupt_Mask - -- Add_To_Interrupt_Mask - -- Delete_From_Interrupt_Mask - -- Interrupt_Wait - -- Interrupt_Self_Process - -- Get_Interrupt_Mask - -- Set_Interrupt_Mask - -- IS_Member - -- Environment_Mask - -- All_Tasks_Mask pragma Elaborate_All (System.Interrupt_Management.Operations); with System.Task_Primitives.Operations; - -- used for Write_Lock - -- Unlock - -- Abort - -- Wakeup_Task - -- Sleep - -- Initialize_Lock - with System.Task_Primitives.Interrupt_Operations; - -- used for Set_Interrupt_ID - with System.Storage_Elements; - -- used for To_Address - -- To_Integer - -- Integer_Address - with System.Tasking.Utilities; - -- used for Make_Independent with System.Tasking.Rendezvous; - -- used for Call_Simple pragma Elaborate_All (System.Tasking.Rendezvous); with System.Tasking.Initialization; - -- used for Defer_Abort - -- Undefer_Abort - with System.Parameters; - -- used for Single_Lock with Ada.Unchecked_Conversion; --- 53,75 ---- *************** package body System.Interrupts is *** 126,132 **** use Parameters; use Tasking; - use Ada.Exceptions; package POP renames System.Task_Primitives.Operations; package PIO renames System.Task_Primitives.Interrupt_Operations; --- 77,82 ---- *************** package body System.Interrupts is *** 272,278 **** -- Calling this procedure with New_Handler = null and Static = True means -- we want to detach the current handler regardless of the previous ! -- handler's binding status (ie. do not care if it is a dynamic or static -- handler). -- This option is needed so that during the finalization of a PO, we can --- 222,228 ---- -- Calling this procedure with New_Handler = null and Static = True means -- we want to detach the current handler regardless of the previous ! -- handler's binding status (i.e. do not care if it is a dynamic or static -- handler). -- This option is needed so that during the finalization of a PO, we can *************** package body System.Interrupts is *** 285,292 **** is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); --- 235,242 ---- is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); *************** package body System.Interrupts is *** 310,317 **** begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); --- 260,267 ---- begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); *************** package body System.Interrupts is *** 324,331 **** procedure Block_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Block_Interrupt (Interrupt); --- 274,281 ---- procedure Block_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Block_Interrupt (Interrupt); *************** package body System.Interrupts is *** 340,347 **** is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; -- ??? Since Parameterless_Handler is not Atomic, the current --- 290,297 ---- is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; -- ??? Since Parameterless_Handler is not Atomic, the current *************** package body System.Interrupts is *** 368,375 **** is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Detach_Handler (Interrupt, Static); --- 318,325 ---- is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Detach_Handler (Interrupt, Static); *************** package body System.Interrupts is *** 390,396 **** -- Calling this procedure with New_Handler = null and Static = True means -- we want to detach the current handler regardless of the previous ! -- handler's binding status (ie. do not care if it is a dynamic or static -- handler). -- This option is needed so that during the finalization of a PO, we can --- 340,346 ---- -- Calling this procedure with New_Handler = null and Static = True means -- we want to detach the current handler regardless of the previous ! -- handler's binding status (i.e. do not care if it is a dynamic or static -- handler). -- This option is needed so that during the finalization of a PO, we can *************** package body System.Interrupts is *** 404,411 **** is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Exchange_Handler --- 354,361 ---- is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Exchange_Handler *************** package body System.Interrupts is *** 464,471 **** procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Ignore_Interrupt (Interrupt); --- 414,421 ---- procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Ignore_Interrupt (Interrupt); *************** package body System.Interrupts is *** 499,504 **** --- 449,465 ---- end loop; end Install_Handlers; + --------------------------------- + -- Install_Restricted_Handlers -- + --------------------------------- + + procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + begin + for N in Handlers'Range loop + Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); + end loop; + end Install_Restricted_Handlers; + ---------------- -- Is_Blocked -- ---------------- *************** package body System.Interrupts is *** 506,513 **** function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; return Blocked (Interrupt); --- 467,474 ---- function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; return Blocked (Interrupt); *************** package body System.Interrupts is *** 520,527 **** function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; return User_Entry (Interrupt).T /= Null_Task; --- 481,488 ---- function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; return User_Entry (Interrupt).T /= Null_Task; *************** package body System.Interrupts is *** 534,541 **** function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; return User_Handler (Interrupt).H /= null; --- 495,502 ---- function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; return User_Handler (Interrupt).H /= null; *************** package body System.Interrupts is *** 548,555 **** function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; return Ignored (Interrupt); --- 509,516 ---- function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; return Ignored (Interrupt); *************** package body System.Interrupts is *** 608,615 **** function Reference (Interrupt : Interrupt_ID) return System.Address is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; return Storage_Elements.To_Address --- 569,576 ---- function Reference (Interrupt : Interrupt_ID) return System.Address is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; return Storage_Elements.To_Address *************** package body System.Interrupts is *** 656,663 **** procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Unblock_Interrupt (Interrupt); --- 617,624 ---- procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Unblock_Interrupt (Interrupt); *************** package body System.Interrupts is *** 672,679 **** is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; return Last_Unblocker (Interrupt); --- 633,640 ---- is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; return Last_Unblocker (Interrupt); *************** package body System.Interrupts is *** 686,693 **** procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! Raise_Exception (Program_Error'Identity, "Interrupt" & ! Interrupt_ID'Image (Interrupt) & " is reserved"); end if; Interrupt_Manager.Unignore_Interrupt (Interrupt); --- 647,654 ---- procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is begin if Is_Reserved (Interrupt) then ! raise Program_Error with ! "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; end if; Interrupt_Manager.Unignore_Interrupt (Interrupt); *************** package body System.Interrupts is *** 742,748 **** if not Blocked (Interrupt) then -- Mask this task for the given Interrupt so that all tasks ! -- are masked for the Interrupt and the actuall delivery of the -- Interrupt will be caught using "sigwait" by the -- corresponding Server_Task. --- 703,709 ---- if not Blocked (Interrupt) then -- Mask this task for the given Interrupt so that all tasks ! -- are masked for the Interrupt and the actual delivery of the -- Interrupt will be caught using "sigwait" by the -- corresponding Server_Task. *************** package body System.Interrupts is *** 825,832 **** -- In case we have an Interrupt Entry installed. -- raise a program error. (propagate it to the caller). ! Raise_Exception (Program_Error'Identity, ! "An interrupt entry is already installed"); end if; -- Note : Static = True will pass the following check. That is the --- 786,793 ---- -- In case we have an Interrupt Entry installed. -- raise a program error. (propagate it to the caller). ! raise Program_Error with ! "An interrupt entry is already installed"; end if; -- Note : Static = True will pass the following check. That is the *************** package body System.Interrupts is *** 838,845 **** -- Tries to detach a static Interrupt Handler. -- raise a program error. ! Raise_Exception (Program_Error'Identity, ! "Trying to detach a static Interrupt Handler"); end if; -- The interrupt should no longer be ignored if --- 799,806 ---- -- Tries to detach a static Interrupt Handler. -- raise a program error. ! raise Program_Error with ! "Trying to detach a static Interrupt Handler"; end if; -- The interrupt should no longer be ignored if *************** package body System.Interrupts is *** 876,883 **** -- In case we have an Interrupt Entry already installed. -- raise a program error. (propagate it to the caller). ! Raise_Exception (Program_Error'Identity, ! "An interrupt is already installed"); end if; -- Note : A null handler with Static = True will pass the --- 837,844 ---- -- In case we have an Interrupt Entry already installed. -- raise a program error. (propagate it to the caller). ! raise Program_Error with ! "An interrupt is already installed"; end if; -- Note : A null handler with Static = True will pass the *************** package body System.Interrupts is *** 899,910 **** or else not Is_Registered (New_Handler)) then ! Raise_Exception (Program_Error'Identity, "Trying to overwrite a static Interrupt Handler with a " & ! "dynamic Handler"); end if; ! -- The interrupt should no longer be ingnored if -- it was ever ignored. Ignored (Interrupt) := False; --- 860,871 ---- or else not Is_Registered (New_Handler)) then ! raise Program_Error with "Trying to overwrite a static Interrupt Handler with a " & ! "dynamic Handler"; end if; ! -- The interrupt should no longer be ignored if -- it was ever ignored. Ignored (Interrupt) := False; *************** package body System.Interrupts is *** 990,1011 **** -- Abort_Task_Interrupt is one of the Interrupt unmasked -- in all tasks. We mask the Interrupt in this particular task ! -- so that "sigwait" is possible to catch an explicitely sent -- Abort_Task_Interrupt from the Server_Tasks. -- This sigwaiting is needed so that we make sure a Server_Task is -- out of its own sigwait state. This extra synchronization is ! -- necessary to prevent following senarios. -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the -- Server_Task then changes its own interrupt mask (OS level). -- If an interrupt (corresponding to the Server_Task) arrives ! -- in the nean time we have the Interrupt_Manager umnasked and -- the Server_Task waiting on sigwait. -- 2) For unbinding handler, we install a default action in the -- Interrupt_Manager. POSIX.1c states that the result of using ! -- "sigwait" and "sigaction" simaltaneously on the same interrupt -- is undefined. Therefore, we need to be informed from the -- Server_Task of the fact that the Server_Task is out of its -- sigwait stage. --- 951,972 ---- -- Abort_Task_Interrupt is one of the Interrupt unmasked -- in all tasks. We mask the Interrupt in this particular task ! -- so that "sigwait" is possible to catch an explicitly sent -- Abort_Task_Interrupt from the Server_Tasks. -- This sigwaiting is needed so that we make sure a Server_Task is -- out of its own sigwait state. This extra synchronization is ! -- necessary to prevent following scenarios. -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the -- Server_Task then changes its own interrupt mask (OS level). -- If an interrupt (corresponding to the Server_Task) arrives ! -- in the mean time we have the Interrupt_Manager unmasked and -- the Server_Task waiting on sigwait. -- 2) For unbinding handler, we install a default action in the -- Interrupt_Manager. POSIX.1c states that the result of using ! -- "sigwait" and "sigaction" simultaneously on the same interrupt -- is undefined. Therefore, we need to be informed from the -- Server_Task of the fact that the Server_Task is out of its -- sigwait stage. *************** package body System.Interrupts is *** 1062,1072 **** if User_Handler (Interrupt).H /= null or else User_Entry (Interrupt).T /= Null_Task then ! Raise_Exception (Program_Error'Identity, ! "A binding for this interrupt is already present"); end if; ! -- The interrupt should no longer be ingnored if -- it was ever ignored. Ignored (Interrupt) := False; --- 1023,1033 ---- if User_Handler (Interrupt).H /= null or else User_Entry (Interrupt).T /= Null_Task then ! raise Program_Error with ! "A binding for this interrupt is already present"; end if; ! -- The interrupt should no longer be ignored if -- it was ever ignored. Ignored (Interrupt) := False; *************** package body System.Interrupts is *** 1104,1110 **** if not Is_Reserved (J) then if User_Entry (J).T = T then ! -- The interrupt should no longer be ingnored if -- it was ever ignored. Ignored (J) := False; --- 1065,1071 ---- if not Is_Reserved (J) then if User_Entry (J).T = T then ! -- The interrupt should no longer be ignored if -- it was ever ignored. Ignored (J) := False; *************** package body System.Interrupts is *** 1276,1287 **** -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks. -- We mask the Interrupt in this particular task so that "sigwait" is ! -- possible to catch an explicitely sent Abort_Task_Interrupt from the -- Interrupt_Manager. -- There are two Interrupt interrupts that this task catch through -- "sigwait." One is the Interrupt this task is designated to catch ! -- in order to execure user handler or entry. The other one is the -- Abort_Task_Interrupt. This interrupt is being sent from the -- Interrupt_Manager to inform status changes (e.g: become Blocked, -- Handler or Entry is to be detached). --- 1237,1248 ---- -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks. -- We mask the Interrupt in this particular task so that "sigwait" is ! -- possible to catch an explicitly sent Abort_Task_Interrupt from the -- Interrupt_Manager. -- There are two Interrupt interrupts that this task catch through -- "sigwait." One is the Interrupt this task is designated to catch ! -- in order to execute user handler or entry. The other one is the -- Abort_Task_Interrupt. This interrupt is being sent from the -- Interrupt_Manager to inform status changes (e.g: become Blocked, -- Handler or Entry is to be detached). *************** package body System.Interrupts is *** 1338,1344 **** -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding -- a Procedure Handler or an Entry. Or it could be a wake up -- from status change (Unblocked -> Blocked). If that is not ! -- the case, we should exceute the attached Procedure or Entry. Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; POP.Unlock (Self_ID); --- 1299,1305 ---- -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding -- a Procedure Handler or an Entry. Or it could be a wake up -- from status change (Unblocked -> Blocked). If that is not ! -- the case, we should execute the attached Procedure or Entry. Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; POP.Unlock (Self_ID); *************** package body System.Interrupts is *** 1460,1466 **** end if; -- Undefer abort here to allow a window for this task to be aborted ! -- at the time of system shutdown. We also explicitely test for -- Pending_Action in case System.Parameters.No_Abort is True. end loop; --- 1421,1427 ---- end if; -- Undefer abort here to allow a window for this task to be aborted ! -- at the time of system shutdown. We also explicitly test for -- Pending_Action in case System.Parameters.No_Abort is True. end loop; diff -Nrcpad gcc-4.3.3/gcc/ada/s-interr.ads gcc-4.4.0/gcc/ada/s-interr.ads *** gcc-4.3.3/gcc/ada/s-interr.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-interr.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 35,58 **** -- Any changes to this interface may require corresponding compiler changes. -- This package encapsulates the implementation of interrupt or signal ! -- handlers. It is logically an extension of the body of Ada.Interrupts. ! -- It is made a child of System to allow visibility of various ! -- runtime system internal data and operations. -- See System.Interrupt_Management for core interrupt/signal interfaces ! -- These two packages are separated in order to allow ! -- System.Interrupt_Management to be used without requiring the whole ! -- tasking implementation to be linked and elaborated. with System.Tasking; - -- used for Task_Id - with System.Tasking.Protected_Objects.Entries; - -- used for Protection_Entries - with System.OS_Interface; - -- used for Max_Interrupt package System.Interrupts is --- 33,51 ---- -- Any changes to this interface may require corresponding compiler changes. -- This package encapsulates the implementation of interrupt or signal ! -- handlers. It is logically an extension of the body of Ada.Interrupts. It ! -- is made a child of System to allow visibility of various runtime system ! -- internal data and operations. -- See System.Interrupt_Management for core interrupt/signal interfaces ! -- These two packages are separated to allow System.Interrupt_Management to be ! -- used without requiring the whole tasking implementation to be linked and ! -- elaborated. with System.Tasking; with System.Tasking.Protected_Objects.Entries; with System.OS_Interface; package System.Interrupts is *************** package System.Interrupts is *** 73,83 **** type Interrupt_ID is range 0 .. System.OS_Interface.Max_Interrupt; - -- The following renaming is introduced so that the type is accessible - -- through rtsfind, otherwise the name clashes with its homonym in - -- ada.interrupts. - subtype System_Interrupt_Id is Interrupt_ID; type Parameterless_Handler is access protected procedure; --- 66,74 ---- type Interrupt_ID is range 0 .. System.OS_Interface.Max_Interrupt; subtype System_Interrupt_Id is Interrupt_ID; + -- This synonym is introduced so that the type is accessible through + -- rtsfind, otherwise the name clashes with its homonym in Ada.Interrupts. type Parameterless_Handler is access protected procedure; *************** package System.Interrupts is *** 97,106 **** function Current_Handler (Interrupt : Interrupt_ID) return Parameterless_Handler; ! -- Calling the following procedures with New_Handler = null ! -- and Static = true means that we want to modify the current handler ! -- regardless of the previous handler's binding status. ! -- (i.e. we do not care whether it is a dynamic or static handler) procedure Attach_Handler (New_Handler : Parameterless_Handler; --- 88,97 ---- function Current_Handler (Interrupt : Interrupt_ID) return Parameterless_Handler; ! -- Calling the following procedures with New_Handler = null and Static = ! -- true means that we want to modify the current handler regardless of the ! -- previous handler's binding status. (i.e. we do not care whether it is a ! -- dynamic or static handler) procedure Attach_Handler (New_Handler : Parameterless_Handler; *************** package System.Interrupts is *** 150,163 **** function Unblocked_By (Interrupt : Interrupt_ID) return System.Tasking.Task_Id; -- It returns the ID of the last Task which Unblocked this Interrupt. ! -- It returns Null_Task if no tasks have ever requested the ! -- Unblocking operation or the Interrupt is currently Blocked. function Is_Blocked (Interrupt : Interrupt_ID) return Boolean; -- Comment needed ??? procedure Ignore_Interrupt (Interrupt : Interrupt_ID); ! -- Set the sigacion for the interrupt to SIG_IGN procedure Unignore_Interrupt (Interrupt : Interrupt_ID); -- Comment needed ??? --- 141,154 ---- function Unblocked_By (Interrupt : Interrupt_ID) return System.Tasking.Task_Id; -- It returns the ID of the last Task which Unblocked this Interrupt. ! -- It returns Null_Task if no tasks have ever requested the Unblocking ! -- operation or the Interrupt is currently Blocked. function Is_Blocked (Interrupt : Interrupt_ID) return Boolean; -- Comment needed ??? procedure Ignore_Interrupt (Interrupt : Interrupt_ID); ! -- Set the sigaction for the interrupt to SIG_IGN procedure Unignore_Interrupt (Interrupt : Interrupt_ID); -- Comment needed ??? *************** package System.Interrupts is *** 169,177 **** -- other low-level interface that changes the signal action or signal mask -- needs a careful thought. ! -- One may acheive the effect of system calls first making RTS blocked ! -- (by calling Block_Interrupt) for the signal under consideration. ! -- This will make all the tasks in RTS blocked for the Interrupt. ---------------------- -- Protection Types -- --- 160,168 ---- -- other low-level interface that changes the signal action or signal mask -- needs a careful thought. ! -- One may achieve the effect of system calls first making RTS blocked (by ! -- calling Block_Interrupt) for the signal under consideration. This will ! -- make all the tasks in RTS blocked for the Interrupt. ---------------------- -- Protection Types -- *************** package System.Interrupts is *** 195,201 **** -- (2) Attach_Handler pragmas are used, and possibly Interrupt_Handler -- pragma. We need to attach the handlers to the given interrupts when the ! -- objet is elaborated. This should be done by constructing an array of -- pairs (interrupt, handler) from the pragmas and calling Install_Handlers -- with it (types to be used are New_Handler_Item and New_Handler_Array). -- On finalization, we need to restore the handlers that were installed --- 186,192 ---- -- (2) Attach_Handler pragmas are used, and possibly Interrupt_Handler -- pragma. We need to attach the handlers to the given interrupts when the ! -- object is elaborated. This should be done by constructing an array of -- pairs (interrupt, handler) from the pragmas and calling Install_Handlers -- with it (types to be used are New_Handler_Item and New_Handler_Array). -- On finalization, we need to restore the handlers that were installed *************** package System.Interrupts is *** 275,278 **** --- 266,276 ---- -- Store the old handlers in Object.Previous_Handlers and install -- the new static handlers. + procedure Install_Restricted_Handlers (Handlers : New_Handler_Array); + -- Install the static Handlers for the given interrupts and do not store + -- previously installed handlers. This procedure is used when the Ravenscar + -- restrictions are in place since in that case there are only + -- library-level protected handlers that will be installed at + -- initialization and never be replaced. + end System.Interrupts; diff -Nrcpad gcc-4.3.3/gcc/ada/s-intman-dummy.adb gcc-4.4.0/gcc/ada/s-intman-dummy.adb *** gcc-4.3.3/gcc/ada/s-intman-dummy.adb Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-intman-dummy.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-intman-mingw.adb gcc-4.4.0/gcc/ada/s-intman-mingw.adb *** gcc-4.3.3/gcc/ada/s-intman-mingw.adb Mon Sep 5 07:46:06 2005 --- gcc-4.4.0/gcc/ada/s-intman-mingw.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1991-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package body System.Interrupt_Management *** 43,49 **** procedure Initialize is begin ! -- "Reserve" all the interrupts, except those that are explicitely -- defined. for J in Interrupt_ID'Range loop --- 41,47 ---- procedure Initialize is begin ! -- "Reserve" all the interrupts, except those that are explicitly -- defined. for J in Interrupt_ID'Range loop diff -Nrcpad gcc-4.3.3/gcc/ada/s-intman-posix.adb gcc-4.4.0/gcc/ada/s-intman-posix.adb *** gcc-4.3.3/gcc/ada/s-intman-posix.adb Tue Aug 14 08:43:46 2007 --- gcc-4.4.0/gcc/ada/s-intman-posix.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 59,64 **** --- 57,64 ---- -- default -- Reserved: the OS specific set of signals that are reserved. + with System.Task_Primitives; + package body System.Interrupt_Management is use Interfaces.C; *************** package body System.Interrupt_Management *** 117,123 **** begin -- With the __builtin_longjmp, the signal mask is not restored, so we ! -- need to restore it explicitely. Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null); pragma Assert (Result = 0); --- 117,123 ---- begin -- With the __builtin_longjmp, the signal mask is not restored, so we ! -- need to restore it explicitly. Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null); pragma Assert (Result = 0); *************** package body System.Interrupt_Management *** 155,160 **** --- 155,164 ---- old_act : aliased struct_sigaction; Result : System.OS_Interface.int; + Use_Alternate_Stack : constant Boolean := + System.Task_Primitives.Alternate_Stack_Size /= 0; + -- Whether to use an alternate signal stack for stack overflows + begin if Initialized then return; *************** package body System.Interrupt_Management *** 171,178 **** act.sa_handler := Notify_Exception'Address; - act.sa_flags := SA_SIGINFO; - -- Setting SA_SIGINFO asks the kernel to pass more than just the signal -- number argument to the handler when it is called. The set of extra -- parameters includes a pointer to the interrupted context, which the --- 175,180 ---- *************** package body System.Interrupt_Management *** 191,197 **** -- fix should be made in sigsetjmp so that we save the Signal_Set and -- restore it after a longjmp. ! -- Since SA_NODEFER is obsolete, instead we reset explicitely the mask -- in the exception handler. Result := sigemptyset (Signal_Mask'Access); --- 193,199 ---- -- fix should be made in sigsetjmp so that we save the Signal_Set and -- restore it after a longjmp. ! -- Since SA_NODEFER is obsolete, instead we reset explicitly the mask -- in the exception handler. Result := sigemptyset (Signal_Mask'Access); *************** package body System.Interrupt_Management *** 220,229 **** Reserve (Exception_Interrupts (J)) := True; if State (Exception_Interrupts (J)) /= Default then Result := sigaction ! (Signal (Exception_Interrupts (J)), act'Unchecked_Access, ! old_act'Unchecked_Access); pragma Assert (Result = 0); end if; end if; --- 222,239 ---- Reserve (Exception_Interrupts (J)) := True; if State (Exception_Interrupts (J)) /= Default then + act.sa_flags := SA_SIGINFO; + + if Use_Alternate_Stack + and then Exception_Interrupts (J) = SIGSEGV + then + act.sa_flags := act.sa_flags + SA_ONSTACK; + end if; + Result := sigaction ! (Signal (Exception_Interrupts (J)), act'Unchecked_Access, ! old_act'Unchecked_Access); pragma Assert (Result = 0); end if; end if; *************** package body System.Interrupt_Management *** 235,241 **** end if; -- Set SIGINT to unmasked state as long as it is not in "User" state. ! -- Check for Unreserve_All_Interrupts last if State (SIGINT) /= User then Keep_Unmasked (SIGINT) := True; --- 245,251 ---- end if; -- Set SIGINT to unmasked state as long as it is not in "User" state. ! -- Check for Unreserve_All_Interrupts last. if State (SIGINT) /= User then Keep_Unmasked (SIGINT) := True; *************** package body System.Interrupt_Management *** 243,249 **** end if; -- Check all signals for state that requires keeping them unmasked and ! -- reserved for J in Interrupt_ID'Range loop if State (J) = Default or else State (J) = Runtime then --- 253,259 ---- end if; -- Check all signals for state that requires keeping them unmasked and ! -- reserved. for J in Interrupt_ID'Range loop if State (J) = Default or else State (J) = Runtime then diff -Nrcpad gcc-4.3.3/gcc/ada/s-intman-solaris.adb gcc-4.4.0/gcc/ada/s-intman-solaris.adb *** gcc-4.3.3/gcc/ada/s-intman-solaris.adb Tue Aug 14 08:43:46 2007 --- gcc-4.4.0/gcc/ada/s-intman-solaris.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-intman-vms.adb gcc-4.4.0/gcc/ada/s-intman-vms.adb *** gcc-4.3.3/gcc/ada/s-intman-vms.adb Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-intman-vms.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-intman-vms.ads gcc-4.4.0/gcc/ada/s-intman-vms.ads *** gcc-4.3.3/gcc/ada/s-intman-vms.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-intman-vms.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 48,55 **** -- implemented as visible arrays rather than functions.) with System.OS_Interface; - -- used for Signal - -- sigset_t package System.Interrupt_Management is pragma Preelaborate; --- 46,51 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-intman-vxworks.adb gcc-4.4.0/gcc/ada/s-intman-vxworks.adb *** gcc-4.3.3/gcc/ada/s-intman-vxworks.adb Fri Nov 23 13:16:54 2007 --- gcc-4.4.0/gcc/ada/s-intman-vxworks.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package body System.Interrupt_Management *** 49,56 **** Exception_Action : aliased struct_sigaction; -- Keep this variable global so that it is initialized only once ! procedure Map_And_Raise_Exception (signo : Signal); ! pragma Import (C, Map_And_Raise_Exception, "__gnat_map_signal"); -- Map signal to Ada exception and raise it. Different versions -- of VxWorks need different mappings. --- 47,57 ---- Exception_Action : aliased struct_sigaction; -- Keep this variable global so that it is initialized only once ! procedure Notify_Exception ! (signo : Signal; ! siginfo : System.Address; ! sigcontext : System.Address); ! pragma Import (C, Notify_Exception, "__gnat_error_handler"); -- Map signal to Ada exception and raise it. Different versions -- of VxWorks need different mappings. *************** package body System.Interrupt_Management *** 71,98 **** -- 's' Interrupt_State pragma set state to System (use "default" -- system handler) - procedure Notify_Exception (signo : Signal); - -- Identify the Ada exception to be raised using - -- the information when the system received a synchronous signal. - - ---------------------- - -- Notify_Exception -- - ---------------------- - - procedure Notify_Exception (signo : Signal) is - Mask : aliased sigset_t; - - Result : int; - pragma Unreferenced (Result); - - begin - Result := pthread_sigmask (SIG_SETMASK, null, Mask'Access); - Result := sigdelset (Mask'Access, signo); - Result := pthread_sigmask (SIG_SETMASK, Mask'Access, null); - - Map_And_Raise_Exception (signo); - end Notify_Exception; - --------------------------- -- Initialize_Interrupts -- --------------------------- --- 72,77 ---- *************** package body System.Interrupt_Management *** 118,127 **** --- 97,108 ---- ---------------- Initialized : Boolean := False; + -- Set to True once Initialize is called, further calls have no effect procedure Initialize is mask : aliased sigset_t; Result : int; + begin if Initialized then return; *************** package body System.Interrupt_Management *** 135,141 **** Abort_Task_Interrupt := SIGABRT; Exception_Action.sa_handler := Notify_Exception'Address; ! Exception_Action.sa_flags := SA_ONSTACK; Result := sigemptyset (mask'Access); pragma Assert (Result = 0); --- 116,122 ---- Abort_Task_Interrupt := SIGABRT; Exception_Action.sa_handler := Notify_Exception'Address; ! Exception_Action.sa_flags := SA_ONSTACK + SA_SIGINFO; Result := sigemptyset (mask'Access); pragma Assert (Result = 0); diff -Nrcpad gcc-4.3.3/gcc/ada/s-intman-vxworks.ads gcc-4.4.0/gcc/ada/s-intman-vxworks.ads *** gcc-4.3.3/gcc/ada/s-intman-vxworks.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-intman-vxworks.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 45,57 **** -- Interrupt_ID is used to derive the type in Ada.Interrupts, and -- adding more operations to that type would be illegal according -- to the Ada Reference Manual. This is the reason why the signals ! -- sets are implemeneted using visible arrays rather than functions. with System.OS_Interface; - -- used for sigset_t with Interfaces.C; - -- used for int package System.Interrupt_Management is pragma Preelaborate; --- 43,53 ---- -- Interrupt_ID is used to derive the type in Ada.Interrupts, and -- adding more operations to that type would be illegal according -- to the Ada Reference Manual. This is the reason why the signals ! -- sets are implemented using visible arrays rather than functions. with System.OS_Interface; with Interfaces.C; package System.Interrupt_Management is pragma Preelaborate; *************** package System.Interrupt_Management is *** 105,113 **** -- each task. procedure Initialize; ! -- Initialize the various variables defined in this package. ! -- This procedure must be called before accessing any object from this ! -- package and can be called multiple times. private type Interrupt_Mask is new System.OS_Interface.sigset_t; --- 101,109 ---- -- each task. procedure Initialize; ! -- Initialize the various variables defined in this package. This procedure ! -- must be called before accessing any object from this package and can be ! -- called multiple times (only the first call has any effect). private type Interrupt_Mask is new System.OS_Interface.sigset_t; diff -Nrcpad gcc-4.3.3/gcc/ada/s-intman.ads gcc-4.4.0/gcc/ada/s-intman.ads *** gcc-4.3.3/gcc/ada/s-intman.ads Tue Aug 14 08:43:46 2007 --- gcc-4.4.0/gcc/ada/s-intman.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 42,55 **** -- Interrupt_ID into the visible part of this package. The type Interrupt_ID -- is used to derive the type in Ada.Interrupts, and adding more operations -- to that type would be illegal according to the Ada Reference Manual. This ! -- is the reason why the signals sets are implemeneted using visible arrays -- rather than functions. with System.OS_Interface; - -- used for sigset_t with Interfaces.C; - -- used for int package System.Interrupt_Management is pragma Preelaborate; --- 40,51 ---- -- Interrupt_ID into the visible part of this package. The type Interrupt_ID -- is used to derive the type in Ada.Interrupts, and adding more operations -- to that type would be illegal according to the Ada Reference Manual. This ! -- is the reason why the signals sets are implemented using visible arrays -- rather than functions. with System.OS_Interface; with Interfaces.C; package System.Interrupt_Management is pragma Preelaborate; diff -Nrcpad gcc-4.3.3/gcc/ada/s-io.adb gcc-4.4.0/gcc/ada/s-io.adb *** gcc-4.3.3/gcc/ada/s-io.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-io.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-io.ads gcc-4.4.0/gcc/ada/s-io.ads *** gcc-4.3.3/gcc/ada/s-io.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-io.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-linux-alpha.ads gcc-4.4.0/gcc/ada/s-linux-alpha.ads *** gcc-4.3.3/gcc/ada/s-linux-alpha.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-linux-alpha.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,118 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . L I N U X -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2009, Free Software Foundation, Inc. -- + -- -- + -- GNARL 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the alpha version of this package + + -- This package encapsulates cpu specific differences between implementations + -- of GNU/Linux, in order to share s-osinte-linux.ads. + + -- PLEASE DO NOT add any with-clauses to this package or remove the pragma + -- Preelaborate. This package is designed to be a bottom-level (leaf) package. + + with Interfaces.C; + + package System.Linux is + pragma Preelaborate; + + ----------- + -- Errno -- + ----------- + + EAGAIN : constant := 35; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + EPERM : constant := 1; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O now possible (4.2 BSD) + SIGPOLL : constant := 23; -- pollable event occurred + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGPWR : constant := 29; -- power-fail restart + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + + SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal + SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal + SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + SIGUNUSED : constant := 0; + SIGSTKFLT : constant := 0; + SIGLOST : constant := 0; + -- These don't exist for Linux/Alpha. The constants are present + -- so that we can continue to use a-intnam-linux.ads. + + -- struct_sigaction offsets + + sa_mask_pos : constant := Standard'Address_Size / 8; + sa_flags_pos : constant := 128 + sa_mask_pos; + + SA_SIGINFO : constant := 16#40#; + SA_ONSTACK : constant := 16#01#; + + type pthread_mutex_t is record + dum0, dum1, dum2, dum3, dum4 : Interfaces.C.unsigned_long; + end record; + pragma Convention (C, pthread_mutex_t); + + end System.Linux; diff -Nrcpad gcc-4.3.3/gcc/ada/s-linux-hppa.ads gcc-4.4.0/gcc/ada/s-linux-hppa.ads *** gcc-4.3.3/gcc/ada/s-linux-hppa.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-linux-hppa.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,127 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . L I N U X -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2009, Free Software Foundation, Inc. -- + -- -- + -- GNARL 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the hppa version of this package + + -- This package encapsulates cpu specific differences between implementations + -- of GNU/Linux, in order to share s-osinte-linux.ads. + + -- PLEASE DO NOT add any with-clauses to this package or remove the pragma + -- Preelaborate. This package is designed to be a bottom-level (leaf) package. + + package System.Linux is + pragma Preelaborate; + + ----------- + -- Errno -- + ----------- + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + EPERM : constant := 1; + ETIMEDOUT : constant := 238; + + ------------- + -- Signals -- + ------------- + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGVTALRM : constant := 20; -- virtual timer expired + SIGPROF : constant := 21; -- profiling timer expired + SIGPOLL : constant := 22; -- pollable event occurred + SIGIO : constant := 22; -- I/O now possible (4.2 BSD) + SIGWINCH : constant := 23; -- window size change + SIGSTOP : constant := 24; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 25; -- user stop requested from tty + SIGCONT : constant := 26; -- stopped process has been continued + SIGTTIN : constant := 27; -- background tty read attempted + SIGTTOU : constant := 28; -- background tty write attempted + SIGURG : constant := 29; -- urgent condition on IO channel + SIGLOST : constant := 30; -- File lock lost + SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) + SIGXCPU : constant := 33; -- CPU time limit exceeded + SIGXFSZ : constant := 34; -- filesize limit exceeded + SIGSTKFLT : constant := 36; -- coprocessor stack fault (Linux) + SIGLTHRRES : constant := 37; -- GNU/LinuxThreads restart signal + SIGLTHRCAN : constant := 38; -- GNU/LinuxThreads cancel signal + SIGLTHRDBG : constant := 39; -- GNU/LinuxThreads debugger signal + + -- struct_sigaction offsets + + sa_flags_pos : constant := Standard'Address_Size / 8; + sa_mask_pos : constant := sa_flags_pos * 2; + + SA_SIGINFO : constant := 16#10#; + SA_ONSTACK : constant := 16#01#; + + type lock_array is array (1 .. 4) of Integer; + type atomic_lock_t is record + lock : lock_array; + end record; + pragma Convention (C, atomic_lock_t); + for atomic_lock_t'Alignment use 16; + + type struct_pthread_fast_lock is record + spinlock : atomic_lock_t; + status : Long_Integer; + end record; + pragma Convention (C, struct_pthread_fast_lock); + + type pthread_mutex_t is record + m_reserved : Integer; + m_count : Integer; + m_owner : System.Address; + m_kind : Integer; + m_lock : struct_pthread_fast_lock; + end record; + pragma Convention (C, pthread_mutex_t); + + end System.Linux; diff -Nrcpad gcc-4.3.3/gcc/ada/s-linux.ads gcc-4.4.0/gcc/ada/s-linux.ads *** gcc-4.3.3/gcc/ada/s-linux.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-linux.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,118 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . L I N U X -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2009, Free Software Foundation, Inc. -- + -- -- + -- GNARL 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the default version of this package + + -- This package encapsulates cpu specific differences between implementations + -- of GNU/Linux, in order to share s-osinte-linux.ads. + + -- PLEASE DO NOT add any with-clauses to this package or remove the pragma + -- Preelaborate. This package is designed to be a bottom-level (leaf) package + + package System.Linux is + pragma Preelaborate; + + ----------- + -- Errno -- + ----------- + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + EPERM : constant := 1; + ETIMEDOUT : constant := 110; + + ------------- + -- Signals -- + ------------- + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 7; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 10; -- user defined signal 1 + SIGUSR2 : constant := 12; -- user defined signal 2 + SIGCLD : constant := 17; -- alias for SIGCHLD + SIGCHLD : constant := 17; -- child status change + SIGPWR : constant := 30; -- power-fail restart + SIGWINCH : constant := 28; -- window size change + SIGURG : constant := 23; -- urgent condition on IO channel + SIGPOLL : constant := 29; -- pollable event occurred + SIGIO : constant := 29; -- I/O now possible (4.2 BSD) + SIGLOST : constant := 29; -- File lock lost + SIGSTOP : constant := 19; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 20; -- user stop requested from tty + SIGCONT : constant := 18; -- stopped process has been continued + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) + SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux) + SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal + SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal + SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal + + -- struct_sigaction offsets + + sa_mask_pos : constant := Standard'Address_Size / 8; + sa_flags_pos : constant := 128 + sa_mask_pos; + + SA_SIGINFO : constant := 16#04#; + SA_ONSTACK : constant := 16#08000000#; + + type struct_pthread_fast_lock is record + status : Long_Integer; + spinlock : Integer; + end record; + pragma Convention (C, struct_pthread_fast_lock); + + type pthread_mutex_t is record + m_reserved : Integer; + m_count : Integer; + m_owner : System.Address; + m_kind : Integer; + m_lock : struct_pthread_fast_lock; + end record; + pragma Convention (C, pthread_mutex_t); + + end System.Linux; diff -Nrcpad gcc-4.3.3/gcc/ada/s-maccod.ads gcc-4.4.0/gcc/ada/s-maccod.ads *** gcc-4.3.3/gcc/ada/s-maccod.ads Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/s-maccod.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-mantis.adb gcc-4.4.0/gcc/ada/s-mantis.adb *** gcc-4.3.3/gcc/ada/s-mantis.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-mantis.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-mantis.ads gcc-4.4.0/gcc/ada/s-mantis.ads *** gcc-4.3.3/gcc/ada/s-mantis.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-mantis.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-mastop-irix.adb gcc-4.4.0/gcc/ada/s-mastop-irix.adb *** gcc-4.3.3/gcc/ada/s-mastop-irix.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-mastop-irix.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (Version for IRIX/MIPS) -- -- -- ! -- Copyright (C) 1999-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- B o d y -- -- (Version for IRIX/MIPS) -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Machine_State_Operat *** 45,51 **** use System.Storage_Elements; ! -- The exc_unwind function in libexc operats on a Sigcontext -- Type sigcontext_t is defined in /usr/include/sys/signal.h. -- We define an equivalent Ada type here. From the comments in --- 43,49 ---- use System.Storage_Elements; ! -- The exc_unwind function in libexc operates on a Sigcontext -- Type sigcontext_t is defined in /usr/include/sys/signal.h. -- We define an equivalent Ada type here. From the comments in *************** package body System.Machine_State_Operat *** 115,121 **** o32n : constant Natural := Boolean'Pos (o32); n32n : constant Natural := Boolean'Pos (n32); -- Flags to indicate which ABI is in effect for this compilation. For the ! -- purposes of this unit, the n32 and n64 ABI's are identical. LSC : constant Character := Character'Val (o32n * Character'Pos ('w') + n32n * Character'Pos ('d')); --- 113,119 ---- o32n : constant Natural := Boolean'Pos (o32); n32n : constant Natural := Boolean'Pos (n32); -- Flags to indicate which ABI is in effect for this compilation. For the ! -- purposes of this unit, the n32 and n64 ABIs are identical. LSC : constant Character := Character'Val (o32n * Character'Pos ('w') + n32n * Character'Pos ('d')); diff -Nrcpad gcc-4.3.3/gcc/ada/s-mastop.adb gcc-4.4.0/gcc/ada/s-mastop.adb *** gcc-4.3.3/gcc/ada/s-mastop.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-mastop.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (Dummy version) -- -- -- ! -- Copyright (C) 1999-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- B o d y -- -- (Dummy version) -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-mastop.ads gcc-4.4.0/gcc/ada/s-mastop.ads *** gcc-4.3.3/gcc/ada/s-mastop.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-mastop.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-memcop.ads gcc-4.4.0/gcc/ada/s-memcop.ads *** gcc-4.3.3/gcc/ada/s-memcop.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-memcop.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-memory-mingw.adb gcc-4.4.0/gcc/ada/s-memory-mingw.adb *** gcc-4.3.3/gcc/ada/s-memory-mingw.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-memory-mingw.adb Thu Apr 9 23:23:07 2009 *************** *** 4,30 **** -- -- -- S Y S T E M . M E M O R Y -- -- -- ! -- B o d y -- -- -- ! -- Copyright (C) 2001-2003 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 4,28 ---- -- -- -- S Y S T E M . M E M O R Y -- -- -- ! -- B o d y -- -- -- ! -- Copyright (C) 2001-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-memory.adb gcc-4.4.0/gcc/ada/s-memory.adb *** gcc-4.3.3/gcc/ada/s-memory.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-memory.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-memory.ads gcc-4.4.0/gcc/ada/s-memory.ads *** gcc-4.3.3/gcc/ada/s-memory.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-memory.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-os_lib.adb gcc-4.4.0/gcc/ada/s-os_lib.adb *** gcc-4.3.3/gcc/ada/s-os_lib.adb Thu Dec 13 10:43:51 2007 --- gcc-4.4.0/gcc/ada/s-os_lib.adb Tue Aug 5 13:42:47 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- 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- -- *************** package body System.OS_Lib is *** 293,299 **** -- Internal exception raised to signal error in copy function Build_Path (Dir : String; File : String) return String; ! -- Returns pathname Dir catenated with File adding the directory -- separator only if needed. procedure Copy (From, To : File_Descriptor); --- 293,299 ---- -- Internal exception raised to signal error in copy function Build_Path (Dir : String; File : String) return String; ! -- Returns pathname Dir concatenated with File adding the directory -- separator only if needed. procedure Copy (From, To : File_Descriptor); *************** package body System.OS_Lib is *** 452,467 **** begin From := Open_Read (Name, Binary); ! To := Create_File (To_Name, Binary); Copy (From, To); -- Copy attributes C_From (1 .. Name'Length) := Name; ! C_From (C_From'Last) := ASCII.Nul; C_To (1 .. To_Name'Length) := To_Name; ! C_To (C_To'Last) := ASCII.Nul; case Preserve is --- 452,473 ---- begin From := Open_Read (Name, Binary); ! ! -- Do not clobber destination file if source file could not be opened ! ! if From /= Invalid_FD then ! To := Create_File (To_Name, Binary); ! end if; ! Copy (From, To); -- Copy attributes C_From (1 .. Name'Length) := Name; ! C_From (C_From'Last) := ASCII.NUL; C_To (1 .. To_Name'Length) := To_Name; ! C_To (C_To'Last) := ASCII.NUL; case Preserve is *************** package body System.OS_Lib is *** 545,554 **** if Is_Regular_File (Pathname) then -- Append mode and destination file exists, append data at the ! -- end of Pathname. From := Open_Read (Name, Binary); ! To := Open_Read_Write (Pathname, Binary); Lseek (To, 0, Seek_End); Copy (From, To); --- 551,564 ---- if Is_Regular_File (Pathname) then -- Append mode and destination file exists, append data at the ! -- end of Pathname. But if we fail to open source file, do not ! -- touch destination file at all. From := Open_Read (Name, Binary); ! if From /= Invalid_FD then ! To := Open_Read_Write (Pathname, Binary); ! end if; ! Lseek (To, 0, Seek_End); Copy (From, To); *************** package body System.OS_Lib is *** 579,592 **** Mode : Copy_Mode := Copy; Preserve : Attribute := Time_Stamps) is ! Ada_Name : String_Access := ! To_Path_String_Access ! (Name, C_String_Length (Name)); ! Ada_Pathname : String_Access := To_Path_String_Access (Pathname, C_String_Length (Pathname)); - begin Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve); Free (Ada_Name); --- 589,600 ---- Mode : Copy_Mode := Copy; Preserve : Attribute := Time_Stamps) is ! Ada_Name : String_Access := ! To_Path_String_Access ! (Name, C_String_Length (Name)); Ada_Pathname : String_Access := To_Path_String_Access (Pathname, C_String_Length (Pathname)); begin Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve); Free (Ada_Name); *************** package body System.OS_Lib is *** 611,616 **** --- 619,625 ---- declare C_Source : String (1 .. Source'Length + 1); C_Dest : String (1 .. Dest'Length + 1); + begin C_Source (1 .. Source'Length) := Source; C_Source (C_Source'Last) := ASCII.NUL; *************** package body System.OS_Lib is *** 637,646 **** Ada_Source : String_Access := To_Path_String_Access (Source, C_String_Length (Source)); ! ! Ada_Dest : String_Access := ! To_Path_String_Access ! (Dest, C_String_Length (Dest)); begin Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success); Free (Ada_Source); --- 646,654 ---- Ada_Source : String_Access := To_Path_String_Access (Source, C_String_Length (Source)); ! Ada_Dest : String_Access := ! To_Path_String_Access ! (Dest, C_String_Length (Dest)); begin Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success); Free (Ada_Source); *************** package body System.OS_Lib is *** 782,790 **** -- If it is not a digit, then there are no available -- temp file names. Return Invalid_FD. There is almost ! -- no that this code will be ever be executed, since ! -- it would mean that there are one million temp files ! -- in the same directory! SSL.Unlock_Task.all; FD := Invalid_FD; --- 790,798 ---- -- If it is not a digit, then there are no available -- temp file names. Return Invalid_FD. There is almost ! -- no chance that this code will be ever be executed, ! -- since it would mean that there are one million temp ! -- files in the same directory! SSL.Unlock_Task.all; FD := Invalid_FD; *************** package body System.OS_Lib is *** 862,868 **** --------------------- function File_Time_Stamp (FD : File_Descriptor) return OS_Time is ! function File_Time (FD : File_Descriptor) return OS_Time; pragma Import (C, File_Time, "__gnat_file_time_fd"); begin return File_Time (FD); --- 870,876 ---- --------------------- function File_Time_Stamp (FD : File_Descriptor) return OS_Time is ! function File_Time (FD : File_Descriptor) return OS_Time; pragma Import (C, File_Time, "__gnat_file_time_fd"); begin return File_Time (FD); *************** package body System.OS_Lib is *** 1306,1311 **** --- 1314,1338 ---- return Is_Readable_File (F_Name'Address); end Is_Readable_File; + ------------------------ + -- Is_Executable_File -- + ------------------------ + + function Is_Executable_File (Name : C_File_Name) return Boolean is + function Is_Executable_File (Name : Address) return Integer; + pragma Import (C, Is_Executable_File, "__gnat_is_executable_file"); + begin + return Is_Executable_File (Name) /= 0; + end Is_Executable_File; + + function Is_Executable_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Executable_File (F_Name'Address); + end Is_Executable_File; + --------------------- -- Is_Regular_File -- --------------------- *************** package body System.OS_Lib is *** 1436,1441 **** --- 1463,1469 ---- if Path_Len = 0 then return null; + else Result := To_Path_String_Access (Path_Addr, Path_Len); Free (Path_Addr); *************** package body System.OS_Lib is *** 1622,1631 **** -- If null terminated string, put the quote before ! if Res (J) = ASCII.Nul then Res (J) := '"'; J := J + 1; ! Res (J) := ASCII.Nul; -- If argument is terminated by '\', then double it. Otherwise -- the ending quote will be taken as-is. This is quite strange --- 1650,1659 ---- -- If null terminated string, put the quote before ! if Res (J) = ASCII.NUL then Res (J) := '"'; J := J + 1; ! Res (J) := ASCII.NUL; -- If argument is terminated by '\', then double it. Otherwise -- the ending quote will be taken as-is. This is quite strange *************** package body System.OS_Lib is *** 1833,1839 **** -- First, convert VMS file spec to Unix file spec. -- If Name is not in VMS syntax, then this is equivalent ! -- to put Name at the begining of Path_Buffer. VMS_Conversion : begin The_Name (1 .. Name'Length) := Name; --- 1861,1867 ---- -- First, convert VMS file spec to Unix file spec. -- If Name is not in VMS syntax, then this is equivalent ! -- to put Name at the beginning of Path_Buffer. VMS_Conversion : begin The_Name (1 .. Name'Length) := Name; *************** package body System.OS_Lib is *** 1896,1902 **** and then Path_Buffer (2) /= Directory_Separator then declare ! Cur_Dir : String := Get_Directory (""); -- Get the current directory to get the drive letter begin --- 1924,1930 ---- and then Path_Buffer (2) /= Directory_Separator then declare ! Cur_Dir : constant String := Get_Directory (""); -- Get the current directory to get the drive letter begin *************** package body System.OS_Lib is *** 1911,1916 **** --- 1939,1964 ---- end; end if; + -- On Windows, remove all double-quotes that are possibly part of the + -- path but can cause problems with other methods. + + if On_Windows then + declare + Index : Natural; + + begin + Index := Path_Buffer'First; + for Current in Path_Buffer'First .. End_Path loop + if Path_Buffer (Current) /= '"' then + Path_Buffer (Index) := Path_Buffer (Current); + Index := Index + 1; + end if; + end loop; + + End_Path := Index - 1; + end; + end if; + -- Start the conversions -- If this is not finished after Max_Iterations, give up and return an *************** package body System.OS_Lib is *** 2251,2269 **** C_Set_Executable (C_Name (C_Name'First)'Address); end Set_Executable; ! -------------------- ! -- Set_Read_Only -- ! -------------------- ! procedure Set_Read_Only (Name : String) is ! procedure C_Set_Read_Only (Name : C_File_Name); ! pragma Import (C, C_Set_Read_Only, "__gnat_set_readonly"); C_Name : aliased String (Name'First .. Name'Last + 1); begin C_Name (Name'Range) := Name; C_Name (C_Name'Last) := ASCII.NUL; ! C_Set_Read_Only (C_Name (C_Name'First)'Address); ! end Set_Read_Only; -------------------- -- Set_Writable -- --- 2299,2345 ---- C_Set_Executable (C_Name (C_Name'First)'Address); end Set_Executable; ! ---------------------- ! -- Set_Non_Readable -- ! ---------------------- ! procedure Set_Non_Readable (Name : String) is ! procedure C_Set_Non_Readable (Name : C_File_Name); ! pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable"); C_Name : aliased String (Name'First .. Name'Last + 1); begin C_Name (Name'Range) := Name; C_Name (C_Name'Last) := ASCII.NUL; ! C_Set_Non_Readable (C_Name (C_Name'First)'Address); ! end Set_Non_Readable; ! ! ---------------------- ! -- Set_Non_Writable -- ! ---------------------- ! ! procedure Set_Non_Writable (Name : String) is ! procedure C_Set_Non_Writable (Name : C_File_Name); ! pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable"); ! C_Name : aliased String (Name'First .. Name'Last + 1); ! begin ! C_Name (Name'Range) := Name; ! C_Name (C_Name'Last) := ASCII.NUL; ! C_Set_Non_Writable (C_Name (C_Name'First)'Address); ! end Set_Non_Writable; ! ! ------------------ ! -- Set_Readable -- ! ------------------ ! ! procedure Set_Readable (Name : String) is ! procedure C_Set_Readable (Name : C_File_Name); ! pragma Import (C, C_Set_Readable, "__gnat_set_readable"); ! C_Name : aliased String (Name'First .. Name'Last + 1); ! begin ! C_Name (Name'Range) := Name; ! C_Name (C_Name'Last) := ASCII.NUL; ! C_Set_Readable (C_Name (C_Name'First)'Address); ! end Set_Readable; -------------------- -- Set_Writable -- *************** package body System.OS_Lib is *** 2368,2379 **** end Spawn; procedure Spawn ! (Program_Name : String; ! Args : Argument_List; ! Output_File : String; ! Success : out Boolean; ! Return_Code : out Integer; ! Err_To_Out : Boolean := True) is FD : File_Descriptor; --- 2444,2455 ---- end Spawn; procedure Spawn ! (Program_Name : String; ! Args : Argument_List; ! Output_File : String; ! Success : out Boolean; ! Return_Code : out Integer; ! Err_To_Out : Boolean := True) is FD : File_Descriptor; *************** package body System.OS_Lib is *** 2419,2434 **** type Chars is array (Positive range <>) of aliased Character; type Char_Ptr is access constant Character; ! Command_Len : constant Positive := Program_Name'Length + 1 ! + Args_Length (Args); Command_Last : Natural := 0; ! Command : aliased Chars (1 .. Command_Len); -- Command contains all characters of the Program_Name and Args, all ! -- terminated by ASCII.NUL characters ! Arg_List_Len : constant Positive := Args'Length + 2; Arg_List_Last : Natural := 0; ! Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr; -- List with pointers to NUL-terminated strings of the Program_Name -- and the Args and terminated with a null pointer. We rely on the -- default initialization for the last null pointer. --- 2495,2510 ---- type Chars is array (Positive range <>) of aliased Character; type Char_Ptr is access constant Character; ! Command_Len : constant Positive := Program_Name'Length + 1 ! + Args_Length (Args); Command_Last : Natural := 0; ! Command : aliased Chars (1 .. Command_Len); -- Command contains all characters of the Program_Name and Args, all ! -- terminated by ASCII.NUL characters. ! Arg_List_Len : constant Positive := Args'Length + 2; Arg_List_Last : Natural := 0; ! Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr; -- List with pointers to NUL-terminated strings of the Program_Name -- and the Args and terminated with a null pointer. We rely on the -- default initialization for the last null pointer. *************** package body System.OS_Lib is *** 2522,2530 **** subtype Path_String is String (1 .. Path_Len); type Path_String_Access is access Path_String; ! function Address_To_Access is new ! Ada.Unchecked_Conversion (Source => Address, ! Target => Path_String_Access); Path_Access : constant Path_String_Access := Address_To_Access (Path_Addr); --- 2598,2605 ---- subtype Path_String is String (1 .. Path_Len); type Path_String_Access is access Path_String; ! function Address_To_Access is new Ada.Unchecked_Conversion ! (Source => Address, Target => Path_String_Access); Path_Access : constant Path_String_Access := Address_To_Access (Path_Addr); diff -Nrcpad gcc-4.3.3/gcc/ada/s-os_lib.ads gcc-4.4.0/gcc/ada/s-os_lib.ads *** gcc-4.3.3/gcc/ada/s-os_lib.ads Thu Dec 13 10:43:51 2007 --- gcc-4.4.0/gcc/ada/s-os_lib.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.OS_Lib is *** 65,71 **** ----------------------- -- These are reexported from package Strings (which was introduced to ! -- avoid different packages declarting different types unnecessarily). -- See package System.Strings for details. subtype String_Access is Strings.String_Access; --- 63,69 ---- ----------------------- -- These are reexported from package Strings (which was introduced to ! -- avoid different packages declaring different types unnecessarily). -- See package System.Strings for details. subtype String_Access is Strings.String_Access; *************** package System.OS_Lib is *** 149,157 **** Hour : out Hour_Type; Minute : out Minute_Type; Second : out Second_Type); ! -- Analogous to the Split routine in Ada.Calendar, takes an OS_Time ! -- and provides a representation of it as a set of component parts, ! -- to be interpreted as a date point in UTC. ---------------- -- File Stuff -- --- 147,155 ---- Hour : out Hour_Type; Minute : out Minute_Type; Second : out Second_Type); ! -- Analogous to the Split routine in Ada.Calendar, takes an OS_Time and ! -- provides a representation of it as a set of component parts, to be ! -- interpreted as a date point in UTC. ---------------- -- File Stuff -- *************** package System.OS_Lib is *** 238,248 **** -- mode parameter is provided. Since this is a temporary file, there is no -- point in doing text translation on it. -- ! -- On some OSes, the maximum number of temp files that can be created with ! -- this procedure may be limited. When the maximum is reached, this ! -- procedure returns Invalid_FD. On some OSes, there may be a race ! -- condition between processes trying to create temp files at the same ! -- time in the same directory using this procedure. procedure Create_Temp_File (FD : out File_Descriptor; --- 236,246 ---- -- mode parameter is provided. Since this is a temporary file, there is no -- point in doing text translation on it. -- ! -- On some operating systems, the maximum number of temp files that can be ! -- created with this procedure may be limited. When the maximum is reached, ! -- this procedure returns Invalid_FD. On some operating systems, there may ! -- be a race condition between processes trying to create temp files at the ! -- same time in the same directory using this procedure. procedure Create_Temp_File (FD : out File_Descriptor; *************** package System.OS_Lib is *** 307,313 **** Append); -- If the target file exists, the contents of the source file is -- appended at the end. Otherwise the source file is just copied. The ! -- time stamps and other file attributes are are preserved if the -- destination file does not exist. type Attribute is --- 305,311 ---- Append); -- If the target file exists, the contents of the source file is -- appended at the end. Otherwise the source file is just copied. The ! -- time stamps and other file attributes are preserved if the -- destination file does not exist. type Attribute is *************** package System.OS_Lib is *** 472,477 **** --- 470,483 ---- -- not actually be readable due to some other process having exclusive -- access. + function Is_Executable_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is executable. Returns True if so, False otherwise. Note that this + -- function simply interrogates the file attributes (e.g. using the C + -- function stat), so it does not indicate a situation in which a file may + -- not actually be readable due to some other process having exclusive + -- access. + function Is_Writable_File (Name : String) return Boolean; -- Determines if the given string, Name, is the name of an existing file -- that is writable. Returns True if so, False otherwise. Note that this *************** package System.OS_Lib is *** 490,516 **** -- span file systems and may refer to directories. procedure Set_Writable (Name : String); ! -- Change the permissions on the named file to make it writable ! -- for its owner. ! procedure Set_Read_Only (Name : String); ! -- Change the permissions on the named file to make it non-writable ! -- for its owner. procedure Set_Executable (Name : String); ! -- Change the permissions on the named file to make it executable ! -- for its owner. function Locate_Exec_On_Path (Exec_Name : String) return String_Access; -- Try to locate an executable whose name is given by Exec_Name in the ! -- directories listed in the environment Path. If the Exec_Name doesn't -- have the executable suffix, it will be appended before the search. ! -- Otherwise works like Locate_Regular_File below. ! -- If the executable is not found, null is returned. -- ! -- Note that this function allocates some memory for the returned value. ! -- This memory needs to be deallocated after use. function Locate_Regular_File (File_Name : String; --- 496,533 ---- -- span file systems and may refer to directories. procedure Set_Writable (Name : String); ! -- Change permissions on the named file to make it writable for its owner ! procedure Set_Non_Writable (Name : String); ! -- Change permissions on the named file to make it non-writable for its ! -- owner. The readable and executable permissions are not modified. ! ! procedure Set_Read_Only (Name : String) renames Set_Non_Writable; ! -- This renaming is provided for backwards compatibility with previous ! -- versions. The use of Set_Non_Writable is preferred (clearer name). procedure Set_Executable (Name : String); ! -- Change permissions on the named file to make it executable for its owner ! ! procedure Set_Readable (Name : String); ! -- Change permissions on the named file to make it readable for its ! -- owner. ! ! procedure Set_Non_Readable (Name : String); ! -- Change permissions on the named file to make it non-readable for ! -- its owner. The writable and executable permissions are not ! -- modified. function Locate_Exec_On_Path (Exec_Name : String) return String_Access; -- Try to locate an executable whose name is given by Exec_Name in the ! -- directories listed in the environment Path. If the Exec_Name does not -- have the executable suffix, it will be appended before the search. ! -- Otherwise works like Locate_Regular_File below. If the executable is ! -- not found, null is returned. -- ! -- Note that this function allocates memory for the returned value. This ! -- memory needs to be deallocated after use. function Locate_Regular_File (File_Name : String; *************** package System.OS_Lib is *** 536,545 **** -- the heap and should be freed after use to avoid storage leaks. function Get_Target_Debuggable_Suffix return String_Access; ! -- Return the target debuggable suffix convention. Usually this is the ! -- same as the convention for Get_Executable_Suffix. The result is ! -- allocated on the heap and should be freed after use to avoid storage ! -- leaks. function Get_Executable_Suffix return String_Access; -- Return the executable suffix convention. The result is allocated on the --- 553,561 ---- -- the heap and should be freed after use to avoid storage leaks. function Get_Target_Debuggable_Suffix return String_Access; ! -- Return the target debuggable suffix convention. Usually this is the same ! -- as the convention for Get_Executable_Suffix. The result is allocated on ! -- the heap and should be freed after use to avoid storage leaks. function Get_Executable_Suffix return String_Access; -- Return the executable suffix convention. The result is allocated on the *************** package System.OS_Lib is *** 608,613 **** --- 624,630 ---- function Is_Regular_File (Name : C_File_Name) return Boolean; function Is_Directory (Name : C_File_Name) return Boolean; function Is_Readable_File (Name : C_File_Name) return Boolean; + function Is_Executable_File (Name : C_File_Name) return Boolean; function Is_Writable_File (Name : C_File_Name) return Boolean; function Is_Symbolic_Link (Name : C_File_Name) return Boolean; *************** package System.OS_Lib is *** 700,711 **** -- "Spawn" should not be used in tasking applications. procedure Spawn ! (Program_Name : String; ! Args : Argument_List; ! Output_File : String; ! Success : out Boolean; ! Return_Code : out Integer; ! Err_To_Out : Boolean := True); -- Similar to the procedure above, but saves the output of the command to -- a file with the name Output_File. -- --- 717,728 ---- -- "Spawn" should not be used in tasking applications. procedure Spawn ! (Program_Name : String; ! Args : Argument_List; ! Output_File : String; ! Success : out Boolean; ! Return_Code : out Integer; ! Err_To_Out : Boolean := True); -- Similar to the procedure above, but saves the output of the command to -- a file with the name Output_File. -- *************** private *** 875,881 **** -- bootstrap path problems. To be changed later ??? Invalid_Time : constant OS_Time := -1; ! -- This value should match the return valud by __gnat_file_time_* pragma Inline ("<"); pragma Inline (">"); --- 892,898 ---- -- bootstrap path problems. To be changed later ??? Invalid_Time : constant OS_Time := -1; ! -- This value should match the return value from __gnat_file_time_* pragma Inline ("<"); pragma Inline (">"); diff -Nrcpad gcc-4.3.3/gcc/ada/s-oscons-tmplt.c gcc-4.4.0/gcc/ada/s-oscons-tmplt.c *** gcc-4.3.3/gcc/ada/s-oscons-tmplt.c Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-oscons-tmplt.c Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,1210 ---- + /* + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S Y S T E M . O S _ C O N S T A N T S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2000-2009, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + */ + + /** + ** This template file is used while building the GNAT runtime library to + ** generate package System.OS_Constants (s-oscons.ads). + ** + ** The generation process is: + ** 1. the platform-independent extraction tool xoscons is built with the + ** base native compiler + ** 2. this template is processed by the cross C compiler to produce + ** a list of constant values + ** 3. the comments in this template and the list of values are processed + ** by xoscons to generate s-oscons.ads. + ** + ** Any comment occurring in this file whose start and end markers are on + ** a line by themselves (see above) is copied verbatim to s-oscons.ads. + ** All other comments are ignored. Note that the build process first passes + ** this file through the C preprocessor, so comments that occur in a section + ** that is conditioned by a #if directive will be copied to the output only + ** when it applies. + ** + ** Two methods are supported to generate the list of constant values, + ** s-oscons-tmpl.s. + ** + ** The default one assumes that the template can be compiled by the newly- + ** build cross compiler. It uses markup produced in the (pseudo-)assembly + ** listing: + ** + ** xgcc -DTARGET=\"$target\" -C -E s-oscons-tmplt.c > s-oscons-tmplt.i + ** xgcc -S s-oscons-tmplt.i + ** xoscons + ** + ** Alternatively, if s-oscons-tmplt.c must be compiled with a proprietary + ** compiler (e.g. the native DEC CC on OpenVMS), the NATIVE macro should + ** be defined, and the resulting program executed: + ** + ** $ CC/DEFINE=("TARGET=""OpenVMS""",NATIVE) + ** /PREPROCESS_ONLY /COMMENTS=AS_IS s-oscons-tmplt + ** $ CC/DEFINE=("TARGET=""OpenVMS""",NATIVE) s-oscons-tmplt + ** $ LINK s-oscons-tmplt + ** $ DEFINE/USER SYS$OUTPUT s-oscons-tmplt.s + ** $ RUN s-oscons-tmplt + ** $ RUN xoscons + ** + **/ + + #ifndef TARGET + # error Please define TARGET + #endif + + #include + #include + #include + #include + + #if ! (defined (__vxworks) || defined (__VMS) || defined (__MINGW32__) || \ + defined (__nucleus__)) + # define HAVE_TERMIOS + #endif + + #include "gsocket.h" + + #ifndef HAVE_SOCKETS + # include + #endif + + #ifdef HAVE_TERMIOS + # include + #endif + + #ifdef NATIVE + #include + #define CND(name,comment) \ + printf ("\n->CND:$%d:" #name ":$%d:" comment, __LINE__, ((int) name)); + + #define CNS(name,comment) \ + printf ("\n->CNS:$%d:" #name ":" name ":" comment, __LINE__); + + #define TXT(text) \ + printf ("\n->TXT:$%d:" text, __LINE__); + + #else + + #define CND(name, comment) \ + asm volatile("\n->CND:%0:" #name ":%1:" comment \ + : : "i" (__LINE__), "i" ((int) name)); + /* Decimal constant in the range of type "int" */ + + #define CNS(name, comment) \ + asm volatile("\n->CNS:%0:" #name ":" name ":" comment \ + : : "i" (__LINE__)); + /* General expression constant */ + + #define TXT(text) \ + asm volatile("\n->TXT:%0:" text \ + : : "i" (__LINE__)); + /* Freeform text */ + + #endif + + #ifdef __MINGW32__ + unsigned int _CRT_fmode = _O_BINARY; + #endif + + int + main (void) { + + /* + -- This package provides target dependent definitions of constant for use + -- by the GNAT runtime library. This package should not be directly with'd + -- by an application program. + + -- This file is generated automatically, do not modify it by hand! Instead, + -- make changes to s-oscons-tmplt.c and rebuild the GNAT runtime library. + */ + + /** + ** Do not change the format of the line below without also updating the + ** MaRTE Makefile. + **/ + TXT("-- This is the version for " TARGET) + TXT("") + + #ifdef HAVE_SOCKETS + /** + ** The type definitions for struct hostent components uses Interfaces.C + **/ + + TXT("with Interfaces.C;") + #endif + + /* + package System.OS_Constants is + + pragma Pure; + */ + + /** + ** General constants (all platforms) + **/ + + /* + + ------------------- + -- System limits -- + ------------------- + + */ + + #ifndef IOV_MAX + # define IOV_MAX INT_MAX + #endif + CND(IOV_MAX, "Maximum writev iovcnt") + + /* + + --------------------- + -- File open modes -- + --------------------- + + */ + + #ifndef O_RDWR + # define O_RDWR -1 + #endif + CND(O_RDWR, "Read/write") + + #ifndef O_NOCTTY + # define O_NOCTTY -1 + #endif + CND(O_NOCTTY, "Don't change ctrl tty") + + #ifndef O_NDELAY + # define O_NDELAY -1 + #endif + CND(O_NDELAY, "Nonblocking") + + /* + + ---------------------- + -- Fcntl operations -- + ---------------------- + + */ + + #ifndef F_GETFL + # define F_GETFL -1 + #endif + CND(F_GETFL, "Get flags") + + #ifndef F_SETFL + # define F_SETFL -1 + #endif + CND(F_SETFL, "Set flags") + + /* + + ----------------- + -- Fcntl flags -- + ----------------- + + */ + + #ifndef FNDELAY + # define FNDELAY -1 + #endif + CND(FNDELAY, "Nonblocking") + + /* + + ---------------------- + -- Ioctl operations -- + ---------------------- + + */ + + #ifndef FIONBIO + # define FIONBIO -1 + #endif + CND(FIONBIO, "Set/clear non-blocking io") + + #ifndef FIONREAD + # define FIONREAD -1 + #endif + CND(FIONREAD, "How many bytes to read") + + /* + + ------------------ + -- Errno values -- + ------------------ + + -- The following constants are defined from + + */ + #ifndef EAGAIN + # define EAGAIN -1 + #endif + CND(EAGAIN, "Try again") + + #ifndef ENOENT + # define ENOENT -1 + #endif + CND(ENOENT, "File not found") + + #ifndef ENOMEM + # define ENOMEM -1 + #endif + CND(ENOMEM, "Out of memory") + + #ifdef __MINGW32__ + /* + + -- The following constants are defined from (WSA*) + + */ + + /** + ** For sockets-related errno values on Windows, gsocket.h redefines + ** Exxx as WSAExxx. + **/ + + #endif + + #ifndef EACCES + # define EACCES -1 + #endif + CND(EACCES, "Permission denied") + + #ifndef EADDRINUSE + # define EADDRINUSE -1 + #endif + CND(EADDRINUSE, "Address already in use") + + #ifndef EADDRNOTAVAIL + # define EADDRNOTAVAIL -1 + #endif + CND(EADDRNOTAVAIL, "Cannot assign address") + + #ifndef EAFNOSUPPORT + # define EAFNOSUPPORT -1 + #endif + CND(EAFNOSUPPORT, "Addr family not supported") + + #ifndef EALREADY + # define EALREADY -1 + #endif + CND(EALREADY, "Operation in progress") + + #ifndef EBADF + # define EBADF -1 + #endif + CND(EBADF, "Bad file descriptor") + + #ifndef ECONNABORTED + # define ECONNABORTED -1 + #endif + CND(ECONNABORTED, "Connection aborted") + + #ifndef ECONNREFUSED + # define ECONNREFUSED -1 + #endif + CND(ECONNREFUSED, "Connection refused") + + #ifndef ECONNRESET + # define ECONNRESET -1 + #endif + CND(ECONNRESET, "Connection reset by peer") + + #ifndef EDESTADDRREQ + # define EDESTADDRREQ -1 + #endif + CND(EDESTADDRREQ, "Destination addr required") + + #ifndef EFAULT + # define EFAULT -1 + #endif + CND(EFAULT, "Bad address") + + #ifndef EHOSTDOWN + # define EHOSTDOWN -1 + #endif + CND(EHOSTDOWN, "Host is down") + + #ifndef EHOSTUNREACH + # define EHOSTUNREACH -1 + #endif + CND(EHOSTUNREACH, "No route to host") + + #ifndef EINPROGRESS + # define EINPROGRESS -1 + #endif + CND(EINPROGRESS, "Operation now in progress") + + #ifndef EINTR + # define EINTR -1 + #endif + CND(EINTR, "Interrupted system call") + + #ifndef EINVAL + # define EINVAL -1 + #endif + CND(EINVAL, "Invalid argument") + + #ifndef EIO + # define EIO -1 + #endif + CND(EIO, "Input output error") + + #ifndef EISCONN + # define EISCONN -1 + #endif + CND(EISCONN, "Socket already connected") + + #ifndef ELOOP + # define ELOOP -1 + #endif + CND(ELOOP, "Too many symbolic links") + + #ifndef EMFILE + # define EMFILE -1 + #endif + CND(EMFILE, "Too many open files") + + #ifndef EMSGSIZE + # define EMSGSIZE -1 + #endif + CND(EMSGSIZE, "Message too long") + + #ifndef ENAMETOOLONG + # define ENAMETOOLONG -1 + #endif + CND(ENAMETOOLONG, "Name too long") + + #ifndef ENETDOWN + # define ENETDOWN -1 + #endif + CND(ENETDOWN, "Network is down") + + #ifndef ENETRESET + # define ENETRESET -1 + #endif + CND(ENETRESET, "Disconn. on network reset") + + #ifndef ENETUNREACH + # define ENETUNREACH -1 + #endif + CND(ENETUNREACH, "Network is unreachable") + + #ifndef ENOBUFS + # define ENOBUFS -1 + #endif + CND(ENOBUFS, "No buffer space available") + + #ifndef ENOPROTOOPT + # define ENOPROTOOPT -1 + #endif + CND(ENOPROTOOPT, "Protocol not available") + + #ifndef ENOTCONN + # define ENOTCONN -1 + #endif + CND(ENOTCONN, "Socket not connected") + + #ifndef ENOTSOCK + # define ENOTSOCK -1 + #endif + CND(ENOTSOCK, "Operation on non socket") + + #ifndef EOPNOTSUPP + # define EOPNOTSUPP -1 + #endif + CND(EOPNOTSUPP, "Operation not supported") + + #ifndef EPFNOSUPPORT + # define EPFNOSUPPORT -1 + #endif + CND(EPFNOSUPPORT, "Unknown protocol family") + + #ifndef EPROTONOSUPPORT + # define EPROTONOSUPPORT -1 + #endif + CND(EPROTONOSUPPORT, "Unknown protocol") + + #ifndef EPROTOTYPE + # define EPROTOTYPE -1 + #endif + CND(EPROTOTYPE, "Unknown protocol type") + + #ifndef ESHUTDOWN + # define ESHUTDOWN -1 + #endif + CND(ESHUTDOWN, "Cannot send once shutdown") + + #ifndef ESOCKTNOSUPPORT + # define ESOCKTNOSUPPORT -1 + #endif + CND(ESOCKTNOSUPPORT, "Socket type not supported") + + #ifndef ETIMEDOUT + # define ETIMEDOUT -1 + #endif + CND(ETIMEDOUT, "Connection timed out") + + #ifndef ETOOMANYREFS + # define ETOOMANYREFS -1 + #endif + CND(ETOOMANYREFS, "Too many references") + + #ifndef EWOULDBLOCK + # define EWOULDBLOCK -1 + #endif + CND(EWOULDBLOCK, "Operation would block") + + /** + ** Terminal I/O constants + **/ + + #ifdef HAVE_TERMIOS + + /* + + ---------------------- + -- Terminal control -- + ---------------------- + + */ + + #ifndef TCSANOW + # define TCSANOW -1 + #endif + CND(TCSANOW, "Immediate") + + #ifndef TCIFLUSH + # define TCIFLUSH -1 + #endif + CND(TCIFLUSH, "Flush input") + + #ifndef CLOCAL + # define CLOCAL -1 + #endif + CND(CLOCAL, "Local") + + #ifndef CRTSCTS + # define CRTSCTS -1 + #endif + CND(CRTSCTS, "Hardware flow control") + + #ifndef CREAD + # define CREAD -1 + #endif + CND(CREAD, "Read") + + #ifndef CS5 + # define CS5 -1 + #endif + CND(CS5, "5 data bits") + + #ifndef CS6 + # define CS6 -1 + #endif + CND(CS6, "6 data bits") + + #ifndef CS7 + # define CS7 -1 + #endif + CND(CS7, "7 data bits") + + #ifndef CS8 + # define CS8 -1 + #endif + CND(CS8, "8 data bits") + + #ifndef CSTOPB + # define CSTOPB -1 + #endif + CND(CSTOPB, "2 stop bits") + + #ifndef PARENB + # define PARENB -1 + #endif + CND(PARENB, "Parity enable") + + #ifndef PARODD + # define PARODD -1 + #endif + CND(PARODD, "Parity odd") + + #ifndef B0 + # define B0 -1 + #endif + CND(B0, "0 bps") + + #ifndef B50 + # define B50 -1 + #endif + CND(B50, "50 bps") + + #ifndef B75 + # define B75 -1 + #endif + CND(B75, "75 bps") + + #ifndef B110 + # define B110 -1 + #endif + CND(B110, "110 bps") + + #ifndef B134 + # define B134 -1 + #endif + CND(B134, "134 bps") + + #ifndef B150 + # define B150 -1 + #endif + CND(B150, "150 bps") + + #ifndef B200 + # define B200 -1 + #endif + CND(B200, "200 bps") + + #ifndef B300 + # define B300 -1 + #endif + CND(B300, "300 bps") + + #ifndef B600 + # define B600 -1 + #endif + CND(B600, "600 bps") + + #ifndef B1200 + # define B1200 -1 + #endif + CND(B1200, "1200 bps") + + #ifndef B1800 + # define B1800 -1 + #endif + CND(B1800, "1800 bps") + + #ifndef B2400 + # define B2400 -1 + #endif + CND(B2400, "2400 bps") + + #ifndef B4800 + # define B4800 -1 + #endif + CND(B4800, "4800 bps") + + #ifndef B9600 + # define B9600 -1 + #endif + CND(B9600, "9600 bps") + + #ifndef B19200 + # define B19200 -1 + #endif + CND(B19200, "19200 bps") + + #ifndef B38400 + # define B38400 -1 + #endif + CND(B38400, "38400 bps") + + #ifndef B57600 + # define B57600 -1 + #endif + CND(B57600, "57600 bps") + + #ifndef B115200 + # define B115200 -1 + #endif + CND(B115200, "115200 bps") + + #ifndef B230400 + # define B230400 -1 + #endif + CND(B230400, "230400 bps") + + #ifndef B460800 + # define B460800 -1 + #endif + CND(B460800, "460800 bps") + + #ifndef B500000 + # define B500000 -1 + #endif + CND(B500000, "500000 bps") + + #ifndef B576000 + # define B576000 -1 + #endif + CND(B576000, "576000 bps") + + #ifndef B921600 + # define B921600 -1 + #endif + CND(B921600, "921600 bps") + + #ifndef B1000000 + # define B1000000 -1 + #endif + CND(B1000000, "1000000 bps") + + #ifndef B1152000 + # define B1152000 -1 + #endif + CND(B1152000, "1152000 bps") + + #ifndef B1500000 + # define B1500000 -1 + #endif + CND(B1500000, "1500000 bps") + + #ifndef B2000000 + # define B2000000 -1 + #endif + CND(B2000000, "2000000 bps") + + #ifndef B2500000 + # define B2500000 -1 + #endif + CND(B2500000, "2500000 bps") + + #ifndef B3000000 + # define B3000000 -1 + #endif + CND(B3000000, "3000000 bps") + + #ifndef B3500000 + # define B3500000 -1 + #endif + CND(B3500000, "3500000 bps") + + #ifndef B4000000 + # define B4000000 -1 + #endif + CND(B4000000, "4000000 bps") + + /* + + --------------------------------- + -- Terminal control characters -- + --------------------------------- + + */ + + #ifndef VINTR + # define VINTR -1 + #endif + CND(VINTR, "Interrupt") + + #ifndef VQUIT + # define VQUIT -1 + #endif + CND(VQUIT, "Quit") + + #ifndef VERASE + # define VERASE -1 + #endif + CND(VERASE, "Erase") + + #ifndef VKILL + # define VKILL -1 + #endif + CND(VKILL, "Kill") + + #ifndef VEOF + # define VEOF -1 + #endif + CND(VEOF, "EOF") + + #ifndef VTIME + # define VTIME -1 + #endif + CND(VTIME, "Read timeout") + + #ifndef VMIN + # define VMIN -1 + #endif + CND(VMIN, "Read min chars") + + #ifndef VSWTC + # define VSWTC -1 + #endif + CND(VSWTC, "Switch") + + #ifndef VSTART + # define VSTART -1 + #endif + CND(VSTART, "Flow control start") + + #ifndef VSTOP + # define VSTOP -1 + #endif + CND(VSTOP, "Flow control stop") + + #ifndef VSUSP + # define VSUSP -1 + #endif + CND(VSUSP, "Suspend") + + #ifndef VEOL + # define VEOL -1 + #endif + CND(VEOL, "EOL") + + #ifndef VREPRINT + # define VREPRINT -1 + #endif + CND(VREPRINT, "Reprint unread") + + #ifndef VDISCARD + # define VDISCARD -1 + #endif + CND(VDISCARD, "Discard pending") + + #ifndef VWERASE + # define VWERASE -1 + #endif + CND(VWERASE, "Word erase") + + #ifndef VLNEXT + # define VLNEXT -1 + #endif + CND(VLNEXT, "Literal next") + + #ifndef VEOL2 + # define VEOL2 -1 + #endif + CND(VEOL2, "Alternative EOL") + + #endif /* HAVE_TERMIOS */ + + /** + ** Sockets constants + **/ + + #ifdef HAVE_SOCKETS + + /* + + -------------- + -- Families -- + -------------- + + */ + + #ifndef AF_INET + # define AF_INET -1 + #endif + CND(AF_INET, "IPv4 address family") + + /** + ** RTEMS lies and defines AF_INET6 even though there is no IPV6 support. + ** Its TCP/IP stack is in transition. It has newer .h files but no IPV6 yet. + **/ + #if defined(__rtems__) + # undef AF_INET6 + #endif + + /** + ** Tru64 UNIX V4.0F defines AF_INET6 without IPv6 support, specificially + ** without struct sockaddr_in6. We use _SS_MAXSIZE (used for the definition + ** of struct sockaddr_storage on Tru64 UNIX V5.1) to detect this. + **/ + #if defined(__osf__) && !defined(_SS_MAXSIZE) + # undef AF_INET6 + #endif + + #ifndef AF_INET6 + # define AF_INET6 -1 + #else + # define HAVE_AF_INET6 1 + #endif + CND(AF_INET6, "IPv6 address family") + + /* + + ------------------ + -- Socket modes -- + ------------------ + + */ + + #ifndef SOCK_STREAM + # define SOCK_STREAM -1 + #endif + CND(SOCK_STREAM, "Stream socket") + + #ifndef SOCK_DGRAM + # define SOCK_DGRAM -1 + #endif + CND(SOCK_DGRAM, "Datagram socket") + + /* + + ----------------- + -- Host errors -- + ----------------- + + */ + + #ifndef HOST_NOT_FOUND + # define HOST_NOT_FOUND -1 + #endif + CND(HOST_NOT_FOUND, "Unknown host") + + #ifndef TRY_AGAIN + # define TRY_AGAIN -1 + #endif + CND(TRY_AGAIN, "Host name lookup failure") + + #ifndef NO_DATA + # define NO_DATA -1 + #endif + CND(NO_DATA, "No data record for name") + + #ifndef NO_RECOVERY + # define NO_RECOVERY -1 + #endif + CND(NO_RECOVERY, "Non recoverable errors") + + /* + + -------------------- + -- Shutdown modes -- + -------------------- + + */ + + #ifndef SHUT_RD + # define SHUT_RD -1 + #endif + CND(SHUT_RD, "No more recv") + + #ifndef SHUT_WR + # define SHUT_WR -1 + #endif + CND(SHUT_WR, "No more send") + + #ifndef SHUT_RDWR + # define SHUT_RDWR -1 + #endif + CND(SHUT_RDWR, "No more recv/send") + + /* + + --------------------- + -- Protocol levels -- + --------------------- + + */ + + #ifndef SOL_SOCKET + # define SOL_SOCKET -1 + #endif + CND(SOL_SOCKET, "Options for socket level") + + #ifndef IPPROTO_IP + # define IPPROTO_IP -1 + #endif + CND(IPPROTO_IP, "Dummy protocol for IP") + + #ifndef IPPROTO_UDP + # define IPPROTO_UDP -1 + #endif + CND(IPPROTO_UDP, "UDP") + + #ifndef IPPROTO_TCP + # define IPPROTO_TCP -1 + #endif + CND(IPPROTO_TCP, "TCP") + + /* + + ------------------- + -- Request flags -- + ------------------- + + */ + + #ifndef MSG_OOB + # define MSG_OOB -1 + #endif + CND(MSG_OOB, "Process out-of-band data") + + #ifndef MSG_PEEK + # define MSG_PEEK -1 + #endif + CND(MSG_PEEK, "Peek at incoming data") + + #ifndef MSG_EOR + # define MSG_EOR -1 + #endif + CND(MSG_EOR, "Send end of record") + + #ifndef MSG_WAITALL + # define MSG_WAITALL -1 + #endif + CND(MSG_WAITALL, "Wait for full reception") + + #ifndef MSG_NOSIGNAL + # define MSG_NOSIGNAL -1 + #endif + CND(MSG_NOSIGNAL, "No SIGPIPE on send") + + #ifdef __linux__ + # define MSG_Forced_Flags "MSG_NOSIGNAL" + #else + # define MSG_Forced_Flags "0" + #endif + CNS(MSG_Forced_Flags, "") + /* + -- Flags set on all send(2) calls + */ + + /* + + -------------------- + -- Socket options -- + -------------------- + + */ + + #ifndef TCP_NODELAY + # define TCP_NODELAY -1 + #endif + CND(TCP_NODELAY, "Do not coalesce packets") + + #ifndef SO_REUSEADDR + # define SO_REUSEADDR -1 + #endif + CND(SO_REUSEADDR, "Bind reuse local address") + + #ifndef SO_REUSEPORT + # define SO_REUSEPORT -1 + #endif + CND(SO_REUSEPORT, "Bind reuse port number") + + #ifndef SO_KEEPALIVE + # define SO_KEEPALIVE -1 + #endif + CND(SO_KEEPALIVE, "Enable keep-alive msgs") + + #ifndef SO_LINGER + # define SO_LINGER -1 + #endif + CND(SO_LINGER, "Defer close to flush data") + + #ifndef SO_BROADCAST + # define SO_BROADCAST -1 + #endif + CND(SO_BROADCAST, "Can send broadcast msgs") + + #ifndef SO_SNDBUF + # define SO_SNDBUF -1 + #endif + CND(SO_SNDBUF, "Set/get send buffer size") + + #ifndef SO_RCVBUF + # define SO_RCVBUF -1 + #endif + CND(SO_RCVBUF, "Set/get recv buffer size") + + #ifndef SO_SNDTIMEO + # define SO_SNDTIMEO -1 + #endif + CND(SO_SNDTIMEO, "Emission timeout") + + #ifndef SO_RCVTIMEO + # define SO_RCVTIMEO -1 + #endif + CND(SO_RCVTIMEO, "Reception timeout") + + #ifndef SO_ERROR + # define SO_ERROR -1 + #endif + CND(SO_ERROR, "Get/clear error status") + + #ifndef IP_MULTICAST_IF + # define IP_MULTICAST_IF -1 + #endif + CND(IP_MULTICAST_IF, "Set/get mcast interface") + + #ifndef IP_MULTICAST_TTL + # define IP_MULTICAST_TTL -1 + #endif + CND(IP_MULTICAST_TTL, "Set/get multicast TTL") + + #ifndef IP_MULTICAST_LOOP + # define IP_MULTICAST_LOOP -1 + #endif + CND(IP_MULTICAST_LOOP, "Set/get mcast loopback") + + #ifndef IP_ADD_MEMBERSHIP + # define IP_ADD_MEMBERSHIP -1 + #endif + CND(IP_ADD_MEMBERSHIP, "Join a multicast group") + + #ifndef IP_DROP_MEMBERSHIP + # define IP_DROP_MEMBERSHIP -1 + #endif + CND(IP_DROP_MEMBERSHIP, "Leave a multicast group") + + #ifndef IP_PKTINFO + # define IP_PKTINFO -1 + #endif + CND(IP_PKTINFO, "Get datagram info") + + /* + + ---------------------- + -- Type definitions -- + ---------------------- + + */ + + { + struct timeval tv; + /* + -- Sizes (in bytes) of the components of struct timeval + */ + #define SIZEOF_tv_sec (sizeof tv.tv_sec) + CND(SIZEOF_tv_sec, "tv_sec") + #define SIZEOF_tv_usec (sizeof tv.tv_usec) + CND(SIZEOF_tv_usec, "tv_usec") + } + /* + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + */ + + #define SIZEOF_sockaddr_in (sizeof (struct sockaddr_in)) + CND(SIZEOF_sockaddr_in, "struct sockaddr_in") + #ifdef HAVE_AF_INET6 + # define SIZEOF_sockaddr_in6 (sizeof (struct sockaddr_in6)) + #else + # define SIZEOF_sockaddr_in6 0 + #endif + CND(SIZEOF_sockaddr_in6, "struct sockaddr_in6") + + /* + + -- Size of file descriptor sets + */ + #define SIZEOF_fd_set (sizeof (fd_set)) + CND(SIZEOF_fd_set, "fd_set"); + /* + + -- Fields of struct hostent + */ + + #ifdef __MINGW32__ + # define h_addrtype_t "short" + # define h_length_t "short" + #else + # define h_addrtype_t "int" + # define h_length_t "int" + #endif + + TXT(" subtype H_Addrtype_T is Interfaces.C." h_addrtype_t ";") + TXT(" subtype H_Length_T is Interfaces.C." h_length_t ";") + + /* + + ---------------------------------------- + -- Properties of supported interfaces -- + ---------------------------------------- + + */ + + CND(Need_Netdb_Buffer, "Need buffer for Netdb ops") + CND(Has_Sockaddr_Len, "Sockaddr has sa_len field") + + /** + ** Do not change the format of the line below without also updating the + ** MaRTE Makefile. + **/ + TXT(" Thread_Blocking_IO : constant Boolean := True;") + /* + -- Set False for contexts where socket i/o are process blocking + */ + + #endif /* HAVE_SOCKETS */ + + /** + ** System-specific constants follow + **/ + + #ifdef __vxworks + + /* + + -------------------------------- + -- VxWorks-specific constants -- + -------------------------------- + + -- These constants may be used only within the VxWorks version of + -- GNAT.Sockets.Thin. + */ + + CND(OK, "VxWorks generic success") + CND(ERROR, "VxWorks generic error") + + #endif + + #ifdef __MINGW32__ + /* + + ------------------------------ + -- MinGW-specific constants -- + ------------------------------ + + -- These constants may be used only within the MinGW version of + -- GNAT.Sockets.Thin. + */ + + CND(WSASYSNOTREADY, "System not ready") + CND(WSAVERNOTSUPPORTED, "Version not supported") + CND(WSANOTINITIALISED, "Winsock not initialized") + CND(WSAEDISCON, "Disconnected") + + #endif + + #ifdef NATIVE + putchar ('\n'); + #endif + + /* + + end System.OS_Constants; + */ + } diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-aix.adb gcc-4.4.0/gcc/ada/s-osinte-aix.adb *** gcc-4.3.3/gcc/ada/s-osinte-aix.adb Wed Jun 6 10:15:34 2007 --- gcc-4.4.0/gcc/ada/s-osinte-aix.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package body System.OS_Interface is *** 65,77 **** Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); begin -- For the case SCHED_OTHER the only valid priority across all supported ! -- versions of AIX is 1. Otherwise, for SCHED_RR and SCHED_FIFO, the ! -- system defines priorities in the range 1 .. 127. This means that we ! -- must map System.Any_Priority in the range 0 .. 126 to 1 .. 127. ! if Dispatching_Policy = ' ' then return 1; else return Interfaces.C.int (Prio) + 1; --- 63,80 ---- Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + begin -- For the case SCHED_OTHER the only valid priority across all supported ! -- versions of AIX is 1 (note that the scheduling policy can be set ! -- with the pragma Task_Dispatching_Policy or setting the time slice ! -- value). Otherwise, for SCHED_RR and SCHED_FIFO, the system defines ! -- priorities in the range 1 .. 127. This means that we must map ! -- System.Any_Priority in the range 0 .. 126 to 1 .. 127. ! if Dispatching_Policy = ' ' and then Time_Slice_Val < 0 then return 1; else return Interfaces.C.int (Prio) + 1; diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-aix.ads gcc-4.4.0/gcc/ada/s-osinte-aix.ads *** gcc-4.3.3/gcc/ada/s-osinte-aix.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-aix.ads Thu Apr 10 21:44:46 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 35,48 **** -- This is a AIX (Native THREADS) version of this package -- This package encapsulates all direct interfaces to OS services that are ! -- needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. - with Interfaces.C; with Ada.Unchecked_Conversion; package System.OS_Interface is pragma Preelaborate; --- 35,49 ---- -- This is a AIX (Native THREADS) version of this package -- This package encapsulates all direct interfaces to OS services that are ! -- needed by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Ada.Unchecked_Conversion; + with Interfaces.C; + package System.OS_Interface is pragma Preelaborate; *************** package System.OS_Interface is *** 131,137 **** SIGCPUFAIL : constant := 59; -- Predictive De-configuration of Processors SIGKAP : constant := 60; -- keep alive poll from native keyboard SIGGRANT : constant := SIGKAP; -- monitor mode granted ! SIGRETRACT : constant := 61; -- monitor mode should be relinguished SIGSOUND : constant := 62; -- sound control has completed SIGSAK : constant := 63; -- secure attention key --- 132,138 ---- SIGCPUFAIL : constant := 59; -- Predictive De-configuration of Processors SIGKAP : constant := 60; -- keep alive poll from native keyboard SIGGRANT : constant := SIGKAP; -- monitor mode granted ! SIGRETRACT : constant := 61; -- monitor mode should be relinquished SIGSOUND : constant := 62; -- sound control has completed SIGSAK : constant := 63; -- secure attention key *************** package System.OS_Interface is *** 173,179 **** pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; ! SA_SIGINFO : constant := 16#0100#; SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; --- 174,181 ---- pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; ! SA_SIGINFO : constant := 16#0100#; ! SA_ONSTACK : constant := 16#0001#; SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; *************** package System.OS_Interface is *** 290,297 **** -- Stack -- ----------- Stack_Base_Available : constant Boolean := False; ! -- Indicates wether the stack base is available on this target function Get_Stack_Base (thread : pthread_t) return Address; pragma Inline (Get_Stack_Base); --- 292,317 ---- -- Stack -- ----------- + type stack_t is record + ss_sp : System.Address; + ss_size : size_t; + ss_flags : int; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + -- This is a dummy definition, never used (Alternate_Stack_Size is null) + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + Stack_Base_Available : constant Boolean := False; ! -- Indicates whether the stack base is available on this target function Get_Stack_Base (thread : pthread_t) return Address; pragma Inline (Get_Stack_Base); *************** package System.OS_Interface is *** 308,314 **** PROT_WRITE : constant := 2; PROT_EXEC : constant := 4; PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - PROT_ON : constant := PROT_READ; PROT_OFF : constant := PROT_ALL; --- 328,333 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-darwin.adb gcc-4.4.0/gcc/ada/s-osinte-darwin.adb *** gcc-4.3.3/gcc/ada/s-osinte-darwin.adb Tue Oct 31 17:45:11 2006 --- gcc-4.4.0/gcc/ada/s-osinte-darwin.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2006 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-darwin.ads gcc-4.4.0/gcc/ada/s-osinte-darwin.ads *** gcc-4.3.3/gcc/ada/s-osinte-darwin.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-darwin.ads Thu Apr 10 21:44:46 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 35,46 **** -- This is Darwin pthreads version of this package -- This package includes all direct interfaces to OS services that are needed ! -- by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Elaborate_Body. It is designed to be a bottom-level (leaf) package. with Interfaces.C; package System.OS_Interface is pragma Preelaborate; --- 35,47 ---- -- This is Darwin pthreads version of this package -- This package includes all direct interfaces to OS services that are needed ! -- by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Elaborate_Body. It is designed to be a bottom-level (leaf) package. with Interfaces.C; + package System.OS_Interface is pragma Preelaborate; *************** package System.OS_Interface is *** 161,166 **** --- 162,168 ---- SIG_IGN : constant := 1; SA_SIGINFO : constant := 16#0040#; + SA_ONSTACK : constant := 16#0001#; function sigaction (sig : Signal; *************** package System.OS_Interface is *** 173,179 **** ---------- Time_Slice_Supported : constant Boolean := True; ! -- Indicates wether time slicing is supported type timespec is private; --- 175,181 ---- ---------- Time_Slice_Supported : constant Boolean := True; ! -- Indicates whether time slicing is supported type timespec is private; *************** package System.OS_Interface is *** 228,237 **** --------- function lwp_self return System.Address; -- lwp_self does not exist on this thread library, revert to pthread_self -- which is the closest approximation (with getpid). This function is -- needed to share 7staprop.adb across POSIX-like targets. - pragma Import (C, lwp_self, "pthread_self"); ------------- -- Threads -- --- 230,239 ---- --------- function lwp_self return System.Address; + pragma Import (C, lwp_self, "pthread_self"); -- lwp_self does not exist on this thread library, revert to pthread_self -- which is the closest approximation (with getpid). This function is -- needed to share 7staprop.adb across POSIX-like targets. ------------- -- Threads -- *************** package System.OS_Interface is *** 263,284 **** -- Stack -- ----------- Stack_Base_Available : constant Boolean := False; ! -- Indicates wether the stack base is available on this target. ! -- This allows us to share s-osinte.adb between all the FSU run time. ! -- Note that this value can only be true if pthread_t has a complete ! -- definition that corresponds exactly to the C header files. function Get_Stack_Base (thread : pthread_t) return System.Address; pragma Inline (Get_Stack_Base); ! -- returns the stack base of the specified thread. ! -- Only call this function when Stack_Base_Available is True. function Get_Page_Size return size_t; function Get_Page_Size return System.Address; pragma Import (C, Get_Page_Size, "getpagesize"); ! -- returns the size of a page, or 0 if this is not relevant on this ! -- target PROT_NONE : constant := 0; PROT_READ : constant := 1; --- 265,303 ---- -- Stack -- ----------- + type stack_t is record + ss_sp : System.Address; + ss_size : size_t; + ss_flags : int; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + -- This is a dummy definition, never used (Alternate_Stack_Size is null) + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + Stack_Base_Available : constant Boolean := False; ! -- Indicates whether the stack base is available on this target. This ! -- allows us to share s-osinte.adb between all the FSU run time. Note that ! -- this value can only be true if pthread_t has a complete definition that ! -- corresponds exactly to the C header files. function Get_Stack_Base (thread : pthread_t) return System.Address; pragma Inline (Get_Stack_Base); ! -- returns the stack base of the specified thread. Only call this function ! -- when Stack_Base_Available is True. function Get_Page_Size return size_t; function Get_Page_Size return System.Address; pragma Import (C, Get_Page_Size, "getpagesize"); ! -- Returns the size of a page, or 0 if this is not relevant on this target PROT_NONE : constant := 0; PROT_READ : constant := 1; *************** package System.OS_Interface is *** 289,297 **** PROT_ON : constant := PROT_NONE; PROT_OFF : constant := PROT_ALL; ! function mprotect (addr : System.Address; ! len : size_t; ! prot : int) return int; pragma Import (C, mprotect); --------------------------------------- --- 308,317 ---- PROT_ON : constant := PROT_NONE; PROT_OFF : constant := PROT_ALL; ! function mprotect ! (addr : System.Address; ! len : size_t; ! prot : int) return int; pragma Import (C, mprotect); --------------------------------------- *************** private *** 527,539 **** end record; pragma Convention (C, siginfo_t); - type stack_t is record - ss_sp : System.Address; - ss_size : int; - ss_flags : int; - end record; - pragma Convention (C, stack_t); - type mcontext_t is new System.Address; type ucontext_t is record --- 547,552 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-dummy.ads gcc-4.4.0/gcc/ada/s-osinte-dummy.ads *** gcc-4.3.3/gcc/ada/s-osinte-dummy.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-osinte-dummy.ads Wed Mar 26 07:35:19 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-freebsd.adb gcc-4.4.0/gcc/ada/s-osinte-freebsd.adb *** gcc-4.3.3/gcc/ada/s-osinte-freebsd.adb Tue Aug 14 08:36:48 2007 --- gcc-4.4.0/gcc/ada/s-osinte-freebsd.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1991-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. It is -- -- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. It is -- -- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-freebsd.ads gcc-4.4.0/gcc/ada/s-osinte-freebsd.ads *** gcc-4.3.3/gcc/ada/s-osinte-freebsd.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-freebsd.ads Fri Aug 8 12:58:46 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 36,49 **** -- This is the FreeBSD PTHREADS version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. - with Interfaces.C; with Ada.Unchecked_Conversion; package System.OS_Interface is pragma Preelaborate; --- 36,50 ---- -- This is the FreeBSD PTHREADS version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Ada.Unchecked_Conversion; + with Interfaces.C; + package System.OS_Interface is pragma Preelaborate; *************** package System.OS_Interface is *** 66,76 **** function Errno return int; pragma Inline (Errno); ! EAGAIN : constant := 35; ! EINTR : constant := 4; ! EINVAL : constant := 22; ! ENOMEM : constant := 12; ! ETIMEDOUT : constant := 60; ------------- -- Signals -- --- 67,77 ---- function Errno return int; pragma Inline (Errno); ! EAGAIN : constant := 35; ! EINTR : constant := 4; ! EINVAL : constant := 22; ! ENOMEM : constant := 12; ! ETIMEDOUT : constant := 60; ------------- -- Signals -- *************** package System.OS_Interface is *** 181,186 **** --- 182,188 ---- SIG_IGN : constant := 1; SA_SIGINFO : constant := 16#0040#; + SA_ONSTACK : constant := 16#0001#; function sigaction (sig : Signal; *************** package System.OS_Interface is *** 193,199 **** ---------- Time_Slice_Supported : constant Boolean := True; ! -- Indicates wether time slicing is supported (i.e SCHED_RR is supported) type timespec is private; --- 195,201 ---- ---------- Time_Slice_Supported : constant Boolean := True; ! -- Indicates whether time slicing is supported (i.e SCHED_RR is supported) type timespec is private; *************** package System.OS_Interface is *** 292,333 **** -- Stack -- ----------- Stack_Base_Available : constant Boolean := False; ! -- Indicates wether the stack base is available on this target. ! -- This allows us to share s-osinte.adb between all the FSU run time. ! -- Note that this value can only be true if pthread_t has a complete ! -- definition that corresponds exactly to the C header files. function Get_Stack_Base (thread : pthread_t) return Address; pragma Inline (Get_Stack_Base); ! -- returns the stack base of the specified thread. ! -- Only call this function when Stack_Base_Available is True. function Get_Page_Size return size_t; function Get_Page_Size return Address; pragma Import (C, Get_Page_Size, "getpagesize"); ! -- returns the size of a page, or 0 if this is not relevant on this ! -- target PROT_NONE : constant := 0; PROT_READ : constant := 1; PROT_WRITE : constant := 2; PROT_EXEC : constant := 4; PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - PROT_ON : constant := PROT_NONE; PROT_OFF : constant := PROT_ALL; ! function mprotect ! (addr : Address; len : size_t; prot : int) return int; pragma Import (C, mprotect); --------------------------------------- -- Nonstandard Thread Initialization -- --------------------------------------- ! -- FSU_THREADS requires pthread_init, which is nonstandard and ! -- this should be invoked during the elaboration of s-taprop.adb -- FreeBSD does not require this so we provide an empty Ada body --- 294,350 ---- -- Stack -- ----------- + type stack_t is record + ss_sp : System.Address; + ss_size : size_t; + ss_flags : int; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + -- This is a dummy definition, never used (Alternate_Stack_Size is null) + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + Stack_Base_Available : constant Boolean := False; ! -- Indicates whether the stack base is available on this target. This ! -- allows us to share s-osinte.adb between all the FSU run time. Note that ! -- this value can only be true if pthread_t has a complete definition that ! -- corresponds exactly to the C header files. function Get_Stack_Base (thread : pthread_t) return Address; pragma Inline (Get_Stack_Base); ! -- returns the stack base of the specified thread. Only call this function ! -- when Stack_Base_Available is True. function Get_Page_Size return size_t; function Get_Page_Size return Address; pragma Import (C, Get_Page_Size, "getpagesize"); ! -- returns the size of a page, or 0 if this is not relevant on this target PROT_NONE : constant := 0; PROT_READ : constant := 1; PROT_WRITE : constant := 2; PROT_EXEC : constant := 4; PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; PROT_ON : constant := PROT_NONE; PROT_OFF : constant := PROT_ALL; ! function mprotect (addr : Address; len : size_t; prot : int) return int; pragma Import (C, mprotect); --------------------------------------- -- Nonstandard Thread Initialization -- --------------------------------------- ! -- FSU_THREADS requires pthread_init, which is nonstandard and this should ! -- be invoked during the elaboration of s-taprop.adb. -- FreeBSD does not require this so we provide an empty Ada body diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-hpux-dce.ads gcc-4.4.0/gcc/ada/s-osinte-hpux-dce.ads *** gcc-4.3.3/gcc/ada/s-osinte-hpux-dce.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-hpux-dce.ads Fri Jun 20 05:06:24 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 35,48 **** -- This is the HP-UX version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. - with Interfaces.C; with Ada.Unchecked_Conversion; package System.OS_Interface is pragma Preelaborate; --- 35,49 ---- -- This is the HP-UX version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Ada.Unchecked_Conversion; + with Interfaces.C; + package System.OS_Interface is pragma Preelaborate; *************** package System.OS_Interface is *** 167,172 **** --- 168,174 ---- SA_RESTART : constant := 16#40#; SA_SIGINFO : constant := 16#10#; + SA_ONSTACK : constant := 16#01#; SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-hpux.ads gcc-4.4.0/gcc/ada/s-osinte-hpux.ads *** gcc-4.3.3/gcc/ada/s-osinte-hpux.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-hpux.ads Fri Aug 8 12:59:14 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 34,51 **** -- This is a HPUX 11.0 (Native THREADS) version of this package ! -- This package encapsulates all direct interfaces to OS services ! -- that are needed by children of System. ! ! -- This package encapsulates all direct interfaces to OS services ! -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. - with Interfaces.C; with Ada.Unchecked_Conversion; package System.OS_Interface is pragma Preelaborate; --- 34,49 ---- -- This is a HPUX 11.0 (Native THREADS) version of this package ! -- This package encapsulates all direct interfaces to OS services that are ! -- needed by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Ada.Unchecked_Conversion; + with Interfaces.C; + package System.OS_Interface is pragma Preelaborate; *************** package System.OS_Interface is *** 88,94 **** SIGILL : constant := 4; -- illegal instruction (not reset) SIGTRAP : constant := 5; -- trace trap (not reset) SIGIOT : constant := 6; -- IOT instruction ! SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future SIGEMT : constant := 7; -- EMT instruction SIGFPE : constant := 8; -- floating point exception SIGKILL : constant := 9; -- kill (cannot be caught or ignored) --- 86,92 ---- SIGILL : constant := 4; -- illegal instruction (not reset) SIGTRAP : constant := 5; -- trace trap (not reset) SIGIOT : constant := 6; -- IOT instruction ! SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future SIGEMT : constant := 7; -- EMT instruction SIGFPE : constant := 8; -- floating point exception SIGKILL : constant := 9; -- kill (cannot be caught or ignored) *************** package System.OS_Interface is *** 124,129 **** --- 122,128 ---- SIGADAABORT : constant := SIGABRT; -- Note: on other targets, we usually use SIGABRT, but on HPUX, it -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM. + -- Do we use SIGTERM or SIGABRT??? type Signal_Set is array (Natural range <>) of Signal; *************** package System.OS_Interface is *** 158,164 **** pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; ! SA_SIGINFO : constant := 16#10#; SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; --- 157,164 ---- pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; ! SA_SIGINFO : constant := 16#10#; ! SA_ONSTACK : constant := 16#01#; SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; *************** package System.OS_Interface is *** 178,184 **** ---------- Time_Slice_Supported : constant Boolean := True; ! -- Indicates wether time slicing is supported type timespec is private; --- 178,184 ---- ---------- Time_Slice_Supported : constant Boolean := True; ! -- Indicates whether time slicing is supported type timespec is private; *************** package System.OS_Interface is *** 280,305 **** -- Stack -- ----------- Stack_Base_Available : constant Boolean := False; ! -- Indicates wether the stack base is available on this target function Get_Stack_Base (thread : pthread_t) return Address; pragma Inline (Get_Stack_Base); ! -- returns the stack base of the specified thread. ! -- Only call this function when Stack_Base_Available is True. function Get_Page_Size return size_t; function Get_Page_Size return Address; pragma Import (C, Get_Page_Size, "getpagesize"); ! -- returns the size of a page, or 0 if this is not relevant on this ! -- target PROT_NONE : constant := 0; PROT_READ : constant := 1; PROT_WRITE : constant := 2; PROT_EXEC : constant := 4; PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - PROT_ON : constant := PROT_READ; PROT_OFF : constant := PROT_ALL; --- 280,322 ---- -- Stack -- ----------- + type stack_t is record + ss_sp : System.Address; + ss_flags : int; + ss_size : size_t; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + pragma Import (C, Alternate_Stack, "__gnat_alternate_stack"); + -- The alternate signal stack for stack overflows + + Alternate_Stack_Size : constant := 16 * 1024; + -- This must be in keeping with init.c:__gnat_alternate_stack + Stack_Base_Available : constant Boolean := False; ! -- Indicates whether the stack base is available on this target function Get_Stack_Base (thread : pthread_t) return Address; pragma Inline (Get_Stack_Base); ! -- Returns the stack base of the specified thread. Only call this function ! -- when Stack_Base_Available is True. function Get_Page_Size return size_t; function Get_Page_Size return Address; pragma Import (C, Get_Page_Size, "getpagesize"); ! -- Returns the size of a page, or 0 if this is not relevant on this target PROT_NONE : constant := 0; PROT_READ : constant := 1; PROT_WRITE : constant := 2; PROT_EXEC : constant := 4; PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; PROT_ON : constant := PROT_READ; PROT_OFF : constant := PROT_ALL; diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-irix.adb gcc-4.4.0/gcc/ada/s-osinte-irix.adb *** gcc-4.3.3/gcc/ada/s-osinte-irix.adb Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-osinte-irix.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-irix.ads gcc-4.4.0/gcc/ada/s-osinte-irix.ads *** gcc-4.3.3/gcc/ada/s-osinte-irix.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-irix.ads Fri Aug 8 12:59:14 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 34,48 **** -- This is the SGI Pthreads version of this package ! -- This package encapsulates all direct interfaces to OS services ! -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. - with Interfaces.C; with Ada.Unchecked_Conversion; package System.OS_Interface is pragma Preelaborate; --- 34,49 ---- -- This is the SGI Pthreads version of this package ! -- This package encapsulates all direct interfaces to OS services that are ! -- needed by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Ada.Unchecked_Conversion; + with Interfaces.C; + package System.OS_Interface is pragma Preelaborate; *************** package System.OS_Interface is *** 86,93 **** SIGILL : constant := 4; -- illegal instruction (not reset) SIGTRAP : constant := 5; -- trace trap (not reset) SIGIOT : constant := 6; -- IOT instruction ! SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the ! -- future SIGEMT : constant := 7; -- EMT instruction SIGFPE : constant := 8; -- floating point exception SIGKILL : constant := 9; -- kill (cannot be caught or ignored) --- 87,93 ---- SIGILL : constant := 4; -- illegal instruction (not reset) SIGTRAP : constant := 5; -- trace trap (not reset) SIGIOT : constant := 6; -- IOT instruction ! SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future SIGEMT : constant := 7; -- EMT instruction SIGFPE : constant := 8; -- floating point exception SIGKILL : constant := 9; -- kill (cannot be caught or ignored) *************** package System.OS_Interface is *** 260,265 **** --- 260,272 ---- PTHREAD_CREATE_DETACHED : constant := 1; + ----------- + -- Stack -- + ----------- + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + --------------------------------------- -- Nonstandard Thread Initialization -- --------------------------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-kfreebsd-gnu.ads gcc-4.4.0/gcc/ada/s-osinte-kfreebsd-gnu.ads *** gcc-4.3.3/gcc/ada/s-osinte-kfreebsd-gnu.ads Wed Nov 21 12:16:51 2007 --- gcc-4.4.0/gcc/ada/s-osinte-kfreebsd-gnu.ads Fri Feb 20 15:20:38 2009 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2005,2008 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package System.OS_Interface is *** 223,229 **** function sysconf (name : int) return long; pragma Import (C, sysconf); ! SC_CLK_TCK : constant := 2; ------------------------- -- Priority Scheduling -- --- 223,230 ---- function sysconf (name : int) return long; pragma Import (C, sysconf); ! SC_CLK_TCK : constant := 2; ! SC_NPROCESSORS_ONLN : constant := 84; ------------------------- -- Priority Scheduling -- *************** package System.OS_Interface is *** 255,260 **** --- 256,262 ---- type Thread_Body is access function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); function Thread_Body_Access is new Unchecked_Conversion (System.Address, Thread_Body); *************** package System.OS_Interface is *** 438,449 **** --- 440,470 ---- pragma Import (C, pthread_getspecific, "pthread_getspecific"); type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); function pthread_key_create (key : access pthread_key_t; destructor : destructor_pointer) return int; pragma Import (C, pthread_key_create, "pthread_key_create"); + CPU_SETSIZE : constant := 1_024; + + type bit_field is array (1 .. CPU_SETSIZE) of Boolean; + for bit_field'Size use CPU_SETSIZE; + pragma Pack (bit_field); + pragma Convention (C, bit_field); + + type cpu_set_t is record + bits : bit_field; + end record; + pragma Convention (C, cpu_set_t); + + function pthread_setaffinity_np + (thread : pthread_t; + cpusetsize : size_t; + cpuset : access cpu_set_t) return int; + pragma Import (C, pthread_setaffinity_np, "__gnat_pthread_setaffinity_np"); + private type sigset_t is array (1 .. 4) of unsigned; diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-linux-alpha.ads gcc-4.4.0/gcc/ada/s-osinte-linux-alpha.ads *** gcc-4.3.3/gcc/ada/s-osinte-linux-alpha.ads Fri Jun 6 20:48:48 2008 --- gcc-4.4.0/gcc/ada/s-osinte-linux-alpha.ads Thu Jan 1 00:00:00 1970 *************** *** 1,529 **** - ------------------------------------------------------------------------------ - -- -- - -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- S Y S T E M . O S _ I N T E R F A C E -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 1991-1994, Florida State University -- - -- Copyright (C) 1995-2006, Free Software Foundation, Inc. -- - -- -- - -- GNARL 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. -- - -- Extensive contributions were provided by Ada Core Technologies, Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is a GNU/Linux (GNU/LinuxThreads) version of this package - - -- This package encapsulates all direct interfaces to OS services - -- that are needed by children of System. - - -- PLEASE DO NOT add any with-clauses to this package or remove the pragma - -- Preelaborate. This package is designed to be a bottom-level (leaf) package. - - with Interfaces.C; - with Unchecked_Conversion; - - package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lpthread"); - - subtype int is Interfaces.C.int; - subtype char is Interfaces.C.char; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 35; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - EPERM : constant := 1; - ETIMEDOUT : constant := 60; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 63; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGURG : constant := 16; -- urgent condition on IO channel - SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 18; -- user stop requested from tty - SIGCONT : constant := 19; -- stopped process has been continued - SIGCLD : constant := 20; -- alias for SIGCHLD - SIGCHLD : constant := 20; -- child status change - SIGTTIN : constant := 21; -- background tty read attempted - SIGTTOU : constant := 22; -- background tty write attempted - SIGIO : constant := 23; -- I/O now possible (4.2 BSD) - SIGPOLL : constant := 23; -- pollable event occurred - SIGXCPU : constant := 24; -- CPU time limit exceeded - SIGXFSZ : constant := 25; -- filesize limit exceeded - SIGVTALRM : constant := 26; -- virtual timer expired - SIGPROF : constant := 27; -- profiling timer expired - SIGWINCH : constant := 28; -- window size change - SIGPWR : constant := 29; -- power-fail restart - SIGUSR1 : constant := 30; -- user defined signal 1 - SIGUSR2 : constant := 31; -- user defined signal 2 - - SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal - SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal - SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal - - SIGADAABORT : constant := SIGABRT; - -- Change this if you want to use another signal for task abort. - -- SIGTERM might be a good one. - - SIGUNUSED : constant := 0; - SIGSTKFLT : constant := 0; - SIGLOST : constant := 0; - -- These don't exist for Linux/Alpha. The constants are present - -- so that we can continue to use a-intnam-linux.ads. - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := ( - SIGTRAP, - -- To enable debugging on multithreaded applications, mark SIGTRAP to - -- be kept unmasked. - - SIGBUS, - - SIGTTIN, SIGTTOU, SIGTSTP, - -- Keep these three signals unmasked so that background processes - -- and IO behaves as normal "C" applications - - SIGPROF, - -- To avoid confusing the profiler - - SIGKILL, SIGSTOP, - -- These two signals actually cannot be masked; - -- POSIX simply won't allow it. - - SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG); - -- These three signals are used by GNU/LinuxThreads starting from - -- glibc 2.1 (future 2.2). - - Reserved : constant Signal_Set := (SIGKILL, SIGSTOP); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type union_type_3 is new String (1 .. 116); - type siginfo_t is record - si_signo : int; - si_code : int; - si_errno : int; - X_data : union_type_3; - end record; - pragma Convention (C, siginfo_t); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : unsigned_long; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - type Machine_State is record - dummy : unsigned_long; - end record; - type Machine_State_Ptr is access all Machine_State; - - SA_SIGINFO : constant := 16#40#; - - SIG_BLOCK : constant := 0; - SIG_UNBLOCK : constant := 1; - SIG_SETMASK : constant := 2; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - type timespec is private; - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timeval is private; - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - function gettimeofday - (tv : access struct_timeval; - tz : System.Address := System.Null_Address) return int; - pragma Import (C, gettimeofday, "gettimeofday"); - - function sysconf (name : int) return long; - pragma Import (C, sysconf); - - SC_CLK_TCK : constant := 2; - SC_NPROCESSORS_ONLN : constant := 84; - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_OTHER : constant := 0; - SCHED_FIFO : constant := 1; - SCHED_RR : constant := 2; - - function To_Target_Priority - (Prio : System.Any_Priority) return Interfaces.C.int; - -- Maps System.Any_Priority to a POSIX priority. - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - pragma Convention (C, Thread_Body); - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is new unsigned_long; - subtype Thread_Id is pthread_t; - - function To_pthread_t is new Unchecked_Conversion - (unsigned_long, pthread_t); - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - ----------- - -- Stack -- - ----------- - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- This is a dummy procedure to share some GNULLI files - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - pragma Inline (pthread_init); - -- This is a dummy procedure to share some GNULLI files - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait (set : access sigset_t; sig : access Signal) return int; - pragma Import (C, sigwait, "sigwait"); - - function pthread_kill (thread : pthread_t; sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - function pthread_sigmask - (how : int; - set : access sigset_t; - oset : access sigset_t) return int; - pragma Import (C, pthread_sigmask, "pthread_sigmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - pragma Convention (C, struct_sched_param); - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import - (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy"); - - function sched_yield return int; - pragma Import (C, sched_yield, "sched_yield"); - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import - (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "pthread_getspecific"); - - type destructor_pointer is access procedure (arg : System.Address); - pragma Convention (C, destructor_pointer); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - - CPU_SETSIZE : constant := 1_024; - - type bit_field is array (1 .. CPU_SETSIZE) of Boolean; - for bit_field'Size use CPU_SETSIZE; - pragma Pack (bit_field); - pragma Convention (C, bit_field); - - type cpu_set_t is record - bits : bit_field; - end record; - pragma Convention (C, cpu_set_t); - - function pthread_setaffinity_np - (thread : pthread_t; - cpusetsize : size_t; - cpuset : access cpu_set_t) return int; - pragma Import (C, pthread_setaffinity_np, "__gnat_pthread_setaffinity_np"); - - private - - type sigset_t is record - dum0, dum1, dum2, dum3, dum4, dum5, dum6, dum7 : unsigned_long; - dum8, dum9, dum10, dum11, dum12, dum13, dum14, dum15 : unsigned_long; - end record; - pragma Convention (C, sigset_t); - - type pid_t is new int; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - - type pthread_attr_t is record - dum0, dum1, dum2, dum3, dum4, dum5, dum6 : unsigned_long; - end record; - pragma Convention (C, pthread_attr_t); - - type pthread_condattr_t is record - dummy : int; - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_mutexattr_t is record - mutexkind : int; - end record; - pragma Convention (C, pthread_mutexattr_t); - - type pthread_mutex_t is record - dum0, dum1, dum2, dum3, dum4 : unsigned_long; - end record; - pragma Convention (C, pthread_mutex_t); - - type pthread_cond_t is record - dum0, dum1, dum2, dum3, dum4, dum5 : unsigned_long; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new unsigned; - - end System.OS_Interface; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-linux-hppa.ads gcc-4.4.0/gcc/ada/s-osinte-linux-hppa.ads *** gcc-4.3.3/gcc/ada/s-osinte-linux-hppa.ads Fri Jan 11 01:00:48 2008 --- gcc-4.4.0/gcc/ada/s-osinte-linux-hppa.ads Thu Jan 1 00:00:00 1970 *************** *** 1,559 **** - ------------------------------------------------------------------------------ - -- -- - -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- S Y S T E M . O S _ I N T E R F A C E -- - -- -- - -- S p e c -- - -- (GNU/Linux-HPPA Version) -- - -- -- - -- Copyright (C) 1991-1994, Florida State University -- - -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- - -- -- - -- GNARL 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. -- - -- Extensive contributions were provided by Ada Core Technologies, Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is a GNU/Linux (GNU/LinuxThreads) version of this package - - -- This package encapsulates all direct interfaces to OS services - -- that are needed by children of System. - - -- PLEASE DO NOT add any with-clauses to this package or remove the pragma - -- Preelaborate. This package is designed to be a bottom-level (leaf) package. - - with Interfaces.C; - with Ada.Unchecked_Conversion; - - package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lpthread"); - - subtype int is Interfaces.C.int; - subtype char is Interfaces.C.char; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - EPERM : constant := 1; - ETIMEDOUT : constant := 238; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 63; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 7; -- EMT - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 16; -- user defined signal 1 - SIGUSR2 : constant := 17; -- user defined signal 2 - SIGCLD : constant := 18; -- alias for SIGCHLD - SIGCHLD : constant := 18; -- child status change - SIGPWR : constant := 19; -- power-fail restart - SIGVTALRM : constant := 20; -- virtual timer expired - SIGPROF : constant := 21; -- profiling timer expired - SIGPOLL : constant := 22; -- pollable event occurred - SIGIO : constant := 22; -- I/O now possible (4.2 BSD) - SIGWINCH : constant := 23; -- window size change - SIGSTOP : constant := 24; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 25; -- user stop requested from tty - SIGCONT : constant := 26; -- stopped process has been continued - SIGTTIN : constant := 27; -- background tty read attempted - SIGTTOU : constant := 28; -- background tty write attempted - SIGURG : constant := 29; -- urgent condition on IO channel - SIGLOST : constant := 30; -- File lock lost - SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) - SIGXCPU : constant := 33; -- CPU time limit exceeded - SIGXFSZ : constant := 34; -- filesize limit exceeded - SIGSTKFLT : constant := 36; -- coprocessor stack fault (Linux) - SIGLTHRRES : constant := 37; -- GNU/LinuxThreads restart signal - SIGLTHRCAN : constant := 38; -- GNU/LinuxThreads cancel signal - SIGLTHRDBG : constant := 39; -- GNU/LinuxThreads debugger signal - - SIGADAABORT : constant := SIGABRT; - -- Change this if you want to use another signal for task abort. - -- SIGTERM might be a good one. - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := ( - SIGTRAP, - -- To enable debugging on multithreaded applications, mark SIGTRAP to - -- be kept unmasked. - - SIGBUS, - - SIGTTIN, SIGTTOU, SIGTSTP, - -- Keep these three signals unmasked so that background processes - -- and IO behaves as normal "C" applications - - SIGPROF, - -- To avoid confusing the profiler - - SIGKILL, SIGSTOP, - -- These two signals actually cannot be masked; - -- POSIX simply won't allow it. - - SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG); - -- These three signals are used by GNU/LinuxThreads starting from - -- glibc 2.1 (future 2.2). - - Reserved : constant Signal_Set := - -- I am not sure why the following two signals are reserved. - -- I guess they are not supported by this version of GNU/Linux. - (SIGVTALRM, SIGUNUSED); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type union_type_3 is new String (1 .. 116); - type siginfo_t is record - si_signo : int; - si_code : int; - si_errno : int; - X_data : union_type_3; - end record; - pragma Convention (C, siginfo_t); - - type struct_sigaction is record - sa_handler : System.Address; - sa_flags : unsigned_long; - sa_mask : sigset_t; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - type Machine_State is record - eip : unsigned_long; - ebx : unsigned_long; - esp : unsigned_long; - ebp : unsigned_long; - esi : unsigned_long; - edi : unsigned_long; - end record; - type Machine_State_Ptr is access all Machine_State; - - SA_SIGINFO : constant := 16; - - SIG_BLOCK : constant := 0; - SIG_UNBLOCK : constant := 1; - SIG_SETMASK : constant := 2; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - type timespec is private; - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timeval is private; - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - function gettimeofday - (tv : access struct_timeval; - tz : System.Address := System.Null_Address) return int; - pragma Import (C, gettimeofday, "gettimeofday"); - - function sysconf (name : int) return long; - pragma Import (C, sysconf); - - SC_CLK_TCK : constant := 2; - SC_NPROCESSORS_ONLN : constant := 84; - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_OTHER : constant := 0; - SCHED_FIFO : constant := 1; - SCHED_RR : constant := 2; - - function To_Target_Priority - (Prio : System.Any_Priority) return Interfaces.C.int; - -- Maps System.Any_Priority to a POSIX priority - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - pragma Convention (C, Thread_Body); - - function Thread_Body_Access is new - Ada.Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is new unsigned_long; - subtype Thread_Id is pthread_t; - - function To_pthread_t is new Ada.Unchecked_Conversion - (unsigned_long, pthread_t); - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - ----------- - -- Stack -- - ----------- - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- This is a dummy procedure to share some GNULLI files - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - pragma Inline (pthread_init); - -- This is a dummy procedure to share some GNULLI files - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait (set : access sigset_t; sig : access Signal) return int; - pragma Import (C, sigwait, "sigwait"); - - function pthread_kill (thread : pthread_t; sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - function pthread_sigmask - (how : int; - set : access sigset_t; - oset : access sigset_t) return int; - pragma Import (C, pthread_sigmask, "pthread_sigmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - pragma Convention (C, struct_sched_param); - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import - (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy"); - - function sched_yield return int; - pragma Import (C, sched_yield, "sched_yield"); - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import - (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "pthread_getspecific"); - - type destructor_pointer is access procedure (arg : System.Address); - pragma Convention (C, destructor_pointer); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - - CPU_SETSIZE : constant := 1_024; - - type bit_field is array (1 .. CPU_SETSIZE) of Boolean; - for bit_field'Size use CPU_SETSIZE; - pragma Pack (bit_field); - pragma Convention (C, bit_field); - - type cpu_set_t is record - bits : bit_field; - end record; - pragma Convention (C, cpu_set_t); - - function pthread_setaffinity_np - (thread : pthread_t; - cpusetsize : size_t; - cpuset : access cpu_set_t) return int; - pragma Import (C, pthread_setaffinity_np, "__gnat_pthread_setaffinity_np"); - - private - - type sigset_t is array (0 .. 31) of unsigned_long; - pragma Convention (C, sigset_t); - - type pid_t is new int; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - - type pthread_attr_t is record - detachstate : int; - schedpolicy : int; - schedparam : struct_sched_param; - inheritsched : int; - scope : int; - guardsize : size_t; - stackaddr_set : int; - stackaddr : System.Address; - stacksize : size_t; - end record; - pragma Convention (C, pthread_attr_t); - - type pthread_condattr_t is record - dummy : int; - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_mutexattr_t is record - mutexkind : int; - end record; - pragma Convention (C, pthread_mutexattr_t); - - type lock_array is array (1 .. 4) of int; - type atomic_lock_t is record - lock : lock_array; - end record; - pragma Convention (C, atomic_lock_t); - -- ??? Alignment should be 16 but this is larger than BIGGEST_ALIGNMENT. - -- This causes an erroneous pointer value to sometimes be passed to free - -- during deallocation. See PR ada/24533 for more details. - for atomic_lock_t'Alignment use 8; - - type struct_pthread_fast_lock is record - spinlock : atomic_lock_t; - status : long; - end record; - pragma Convention (C, struct_pthread_fast_lock); - - type pthread_mutex_t is record - m_reserved : int; - m_count : int; - m_owner : System.Address; - m_kind : int; - m_lock : struct_pthread_fast_lock; - end record; - pragma Convention (C, pthread_mutex_t); - - type pthread_cond_t is array (0 .. 47) of unsigned_char; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new unsigned; - - end System.OS_Interface; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-linux.ads gcc-4.4.0/gcc/ada/s-osinte-linux.ads *** gcc-4.3.3/gcc/ada/s-osinte-linux.ads Thu Dec 13 10:18:44 2007 --- gcc-4.4.0/gcc/ada/s-osinte-linux.ads Tue Apr 8 06:43:15 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 35,47 **** -- This is a GNU/Linux (GNU/LinuxThreads) version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. - with Interfaces.C; with Ada.Unchecked_Conversion; package System.OS_Interface is pragma Preelaborate; --- 35,48 ---- -- This is a GNU/Linux (GNU/LinuxThreads) version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Ada.Unchecked_Conversion; + with Interfaces.C; + with System.Linux; package System.OS_Interface is pragma Preelaborate; *************** package System.OS_Interface is *** 66,77 **** function errno return int; pragma Import (C, errno, "__get_errno"); ! EAGAIN : constant := 11; ! EINTR : constant := 4; ! EINVAL : constant := 22; ! ENOMEM : constant := 12; ! EPERM : constant := 1; ! ETIMEDOUT : constant := 110; ------------- -- Signals -- --- 67,78 ---- function errno return int; pragma Import (C, errno, "__get_errno"); ! EAGAIN : constant := System.Linux.EAGAIN; ! EINTR : constant := System.Linux.EINTR; ! EINVAL : constant := System.Linux.EINVAL; ! ENOMEM : constant := System.Linux.ENOMEM; ! EPERM : constant := System.Linux.EPERM; ! ETIMEDOUT : constant := System.Linux.ETIMEDOUT; ------------- -- Signals -- *************** package System.OS_Interface is *** 81,124 **** type Signal is new int range 0 .. Max_Interrupt; for Signal'Size use int'Size; ! SIGHUP : constant := 1; -- hangup ! SIGINT : constant := 2; -- interrupt (rubout) ! SIGQUIT : constant := 3; -- quit (ASCD FS) ! SIGILL : constant := 4; -- illegal instruction (not reset) ! SIGTRAP : constant := 5; -- trace trap (not reset) ! SIGIOT : constant := 6; -- IOT instruction ! SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future ! SIGFPE : constant := 8; -- floating point exception ! SIGKILL : constant := 9; -- kill (cannot be caught or ignored) ! SIGBUS : constant := 7; -- bus error ! SIGSEGV : constant := 11; -- segmentation violation ! SIGPIPE : constant := 13; -- write on a pipe with no one to read it ! SIGALRM : constant := 14; -- alarm clock ! SIGTERM : constant := 15; -- software termination signal from kill ! SIGUSR1 : constant := 10; -- user defined signal 1 ! SIGUSR2 : constant := 12; -- user defined signal 2 ! SIGCLD : constant := 17; -- alias for SIGCHLD ! SIGCHLD : constant := 17; -- child status change ! SIGPWR : constant := 30; -- power-fail restart ! SIGWINCH : constant := 28; -- window size change ! SIGURG : constant := 23; -- urgent condition on IO channel ! SIGPOLL : constant := 29; -- pollable event occurred ! SIGIO : constant := 29; -- I/O now possible (4.2 BSD) ! SIGLOST : constant := 29; -- File lock lost ! SIGSTOP : constant := 19; -- stop (cannot be caught or ignored) ! SIGTSTP : constant := 20; -- user stop requested from tty ! SIGCONT : constant := 18; -- stopped process has been continued ! SIGTTIN : constant := 21; -- background tty read attempted ! SIGTTOU : constant := 22; -- background tty write attempted ! SIGVTALRM : constant := 26; -- virtual timer expired ! SIGPROF : constant := 27; -- profiling timer expired ! SIGXCPU : constant := 24; -- CPU time limit exceeded ! SIGXFSZ : constant := 25; -- filesize limit exceeded ! SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) ! SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux) ! SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal ! SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal ! SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal SIGADAABORT : constant := SIGABRT; -- Change this if you want to use another signal for task abort. --- 82,125 ---- type Signal is new int range 0 .. Max_Interrupt; for Signal'Size use int'Size; ! SIGHUP : constant := System.Linux.SIGHUP; ! SIGINT : constant := System.Linux.SIGINT; ! SIGQUIT : constant := System.Linux.SIGQUIT; ! SIGILL : constant := System.Linux.SIGILL; ! SIGTRAP : constant := System.Linux.SIGTRAP; ! SIGIOT : constant := System.Linux.SIGIOT; ! SIGABRT : constant := System.Linux.SIGABRT; ! SIGFPE : constant := System.Linux.SIGFPE; ! SIGKILL : constant := System.Linux.SIGKILL; ! SIGBUS : constant := System.Linux.SIGBUS; ! SIGSEGV : constant := System.Linux.SIGSEGV; ! SIGPIPE : constant := System.Linux.SIGPIPE; ! SIGALRM : constant := System.Linux.SIGALRM; ! SIGTERM : constant := System.Linux.SIGTERM; ! SIGUSR1 : constant := System.Linux.SIGUSR1; ! SIGUSR2 : constant := System.Linux.SIGUSR2; ! SIGCLD : constant := System.Linux.SIGCLD; ! SIGCHLD : constant := System.Linux.SIGCHLD; ! SIGPWR : constant := System.Linux.SIGPWR; ! SIGWINCH : constant := System.Linux.SIGWINCH; ! SIGURG : constant := System.Linux.SIGURG; ! SIGPOLL : constant := System.Linux.SIGPOLL; ! SIGIO : constant := System.Linux.SIGIO; ! SIGLOST : constant := System.Linux.SIGLOST; ! SIGSTOP : constant := System.Linux.SIGSTOP; ! SIGTSTP : constant := System.Linux.SIGTSTP; ! SIGCONT : constant := System.Linux.SIGCONT; ! SIGTTIN : constant := System.Linux.SIGTTIN; ! SIGTTOU : constant := System.Linux.SIGTTOU; ! SIGVTALRM : constant := System.Linux.SIGVTALRM; ! SIGPROF : constant := System.Linux.SIGPROF; ! SIGXCPU : constant := System.Linux.SIGXCPU; ! SIGXFSZ : constant := System.Linux.SIGXFSZ; ! SIGUNUSED : constant := System.Linux.SIGUNUSED; ! SIGSTKFLT : constant := System.Linux.SIGSTKFLT; ! SIGLTHRRES : constant := System.Linux.SIGLTHRRES; ! SIGLTHRCAN : constant := System.Linux.SIGLTHRCAN; ! SIGLTHRDBG : constant := System.Linux.SIGLTHRDBG; SIGADAABORT : constant := SIGABRT; -- Change this if you want to use another signal for task abort. *************** package System.OS_Interface is *** 180,191 **** pragma Convention (C, siginfo_t); type struct_sigaction is record ! sa_handler : System.Address; ! sa_mask : sigset_t; ! sa_flags : unsigned_long; ! sa_restorer : System.Address; end record; pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; type Machine_State is record --- 181,193 ---- pragma Convention (C, siginfo_t); type struct_sigaction is record ! sa_handler : System.Address; ! sa_mask : sigset_t; ! sa_flags : Interfaces.C.unsigned_long; ! sa_restorer : System.Address; end record; pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; type Machine_State is record *************** package System.OS_Interface is *** 198,204 **** end record; type Machine_State_Ptr is access all Machine_State; ! SA_SIGINFO : constant := 16#04#; SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; --- 200,207 ---- end record; type Machine_State_Ptr is access all Machine_State; ! SA_SIGINFO : constant := System.Linux.SA_SIGINFO; ! SA_ONSTACK : constant := System.Linux.SA_ONSTACK; SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; *************** package System.OS_Interface is *** 298,303 **** --- 301,325 ---- -- Stack -- ----------- + type stack_t is record + ss_sp : System.Address; + ss_flags : int; + ss_size : size_t; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + pragma Import (C, Alternate_Stack, "__gnat_alternate_stack"); + -- The alternate signal stack for stack overflows + + Alternate_Stack_Size : constant := 16 * 1024; + -- This must be in keeping with init.c:__gnat_alternate_stack + function Get_Stack_Base (thread : pthread_t) return Address; pragma Inline (Get_Stack_Base); -- This is a dummy procedure to share some GNULLI files *************** package System.OS_Interface is *** 482,490 **** private ! type sigset_t is array (0 .. 127) of unsigned_char; pragma Convention (C, sigset_t); ! for sigset_t'Alignment use unsigned_long'Alignment; type pid_t is new int; --- 504,522 ---- private ! type sigset_t is array (0 .. 127) of Interfaces.C.unsigned_char; pragma Convention (C, sigset_t); ! for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment; ! ! pragma Warnings (Off); ! for struct_sigaction use record ! sa_handler at 0 range 0 .. Standard'Address_Size - 1; ! sa_mask at Linux.sa_mask_pos range 0 .. 1023; ! sa_flags at Linux.sa_flags_pos range 0 .. Standard'Address_Size - 1; ! end record; ! -- We intentionally leave sa_restorer unspecified and let the compiler ! -- append it after the last field, so disable corresponding warning. ! pragma Warnings (On); type pid_t is new int; *************** private *** 525,544 **** end record; pragma Convention (C, pthread_mutexattr_t); ! type struct_pthread_fast_lock is record ! status : long; ! spinlock : int; ! end record; ! pragma Convention (C, struct_pthread_fast_lock); ! ! type pthread_mutex_t is record ! m_reserved : int; ! m_count : int; ! m_owner : System.Address; ! m_kind : int; ! m_lock : struct_pthread_fast_lock; ! end record; ! pragma Convention (C, pthread_mutex_t); type pthread_cond_t is array (0 .. 47) of unsigned_char; pragma Convention (C, pthread_cond_t); --- 557,563 ---- end record; pragma Convention (C, pthread_mutexattr_t); ! type pthread_mutex_t is new System.Linux.pthread_mutex_t; type pthread_cond_t is array (0 .. 47) of unsigned_char; pragma Convention (C, pthread_cond_t); diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-lynxos-3.adb gcc-4.4.0/gcc/ada/s-osinte-lynxos-3.adb *** gcc-4.3.3/gcc/ada/s-osinte-lynxos-3.adb Wed Jun 6 10:14:59 2007 --- gcc-4.4.0/gcc/ada/s-osinte-lynxos-3.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package body System.OS_Interface is *** 138,144 **** -------------------------- -- For all the following functions, LynxOS threads has the POSIX Draft 4 ! -- begavior; it sets errno but the standard Posix requires it to be -- returned. function pthread_mutexattr_init --- 136,142 ---- -------------------------- -- For all the following functions, LynxOS threads has the POSIX Draft 4 ! -- behavior; it sets errno but the standard Posix requires it to be -- returned. function pthread_mutexattr_init diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-lynxos-3.ads gcc-4.4.0/gcc/ada/s-osinte-lynxos-3.ads *** gcc-4.3.3/gcc/ada/s-osinte-lynxos-3.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-lynxos-3.ads Thu Apr 10 21:44:46 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 35,48 **** -- This is a LynxOS (Native) version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. - with Interfaces.C; with Ada.Unchecked_Conversion; package System.OS_Interface is pragma Preelaborate; --- 35,49 ---- -- This is a LynxOS (Native) version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Ada.Unchecked_Conversion; + with Interfaces.C; + package System.OS_Interface is pragma Preelaborate; *************** package System.OS_Interface is *** 174,180 **** ---------- Time_Slice_Supported : constant Boolean := True; ! -- Indicates wether time slicing is supported type timespec is private; --- 175,181 ---- ---------- Time_Slice_Supported : constant Boolean := True; ! -- Indicates whether time slicing is supported type timespec is private; *************** package System.OS_Interface is *** 266,273 **** -- Stack -- ----------- Stack_Base_Available : constant Boolean := False; ! -- Indicates wether the stack base is available on this target function Get_Stack_Base (thread : pthread_t) return Address; pragma Inline (Get_Stack_Base); --- 267,277 ---- -- Stack -- ----------- + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + Stack_Base_Available : constant Boolean := False; ! -- Indicates whether the stack base is available on this target function Get_Stack_Base (thread : pthread_t) return Address; pragma Inline (Get_Stack_Base); *************** package System.OS_Interface is *** 379,385 **** mutex : access pthread_mutex_t; reltime : access timespec) return int; pragma Inline (pthread_cond_timedwait); ! -- LynxOS has a nonstandard pthrad_cond_timedwait Relative_Timed_Wait : constant Boolean := True; -- pthread_cond_timedwait requires a relative delay time --- 383,389 ---- mutex : access pthread_mutex_t; reltime : access timespec) return int; pragma Inline (pthread_cond_timedwait); ! -- LynxOS has a nonstandard pthread_cond_timedwait Relative_Timed_Wait : constant Boolean := True; -- pthread_cond_timedwait requires a relative delay time diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-lynxos.ads gcc-4.4.0/gcc/ada/s-osinte-lynxos.ads *** gcc-4.3.3/gcc/ada/s-osinte-lynxos.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-lynxos.ads Mon Apr 14 21:07:59 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 35,48 **** -- This is a LynxOS (POSIX Threads) version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. - with Interfaces.C; with Ada.Unchecked_Conversion; package System.OS_Interface is pragma Preelaborate; --- 35,49 ---- -- This is a LynxOS (POSIX Threads) version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Ada.Unchecked_Conversion; + with Interfaces.C; + package System.OS_Interface is pragma Preelaborate; *************** package System.OS_Interface is *** 86,92 **** -- -- -- The lowest numbered signal is 1, but 0 is a valid argument to some ! -- library functions, eg. kill(2). However, 0 is not just another -- signal: For instance 'I in Signal' and similar should be used with -- caution. --- 87,93 ---- -- -- -- The lowest numbered signal is 1, but 0 is a valid argument to some ! -- library functions, e.g. kill(2). However, 0 is not just another -- signal: For instance 'I in Signal' and similar should be used with -- caution. *************** package System.OS_Interface is *** 169,175 **** pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; ! SA_SIGINFO : constant := 16#80#; SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; --- 170,181 ---- pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; ! SA_SIGINFO : constant := 16#80#; ! ! SA_ONSTACK : constant := 16#00#; ! -- SA_ONSTACK is not defined on LynxOS, but it is referred to in the POSIX ! -- implementation of System.Interrupt_Management. Therefore we define a ! -- dummy value of zero here so that setting this flag is a nop. SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; *************** package System.OS_Interface is *** 275,280 **** --- 281,289 ---- -- Stack -- ----------- + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + Stack_Base_Available : constant Boolean := False; -- Indicates whether the stack base is available on this target diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-mingw.ads gcc-4.4.0/gcc/ada/s-osinte-mingw.ads *** gcc-4.3.3/gcc/ada/s-osinte-mingw.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-mingw.ads Tue Apr 8 06:43:15 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 35,48 **** -- This is a NT (native) version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; with Interfaces.C.Strings; ! with Ada.Unchecked_Conversion; package System.OS_Interface is pragma Preelaborate; --- 35,51 ---- -- This is a NT (native) version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by the tasking run-time (libgnarl). For non tasking ! -- oriented services consider declaring them into system-win32. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. + with Ada.Unchecked_Conversion; + with Interfaces.C; with Interfaces.C.Strings; ! with System.Win32; package System.OS_Interface is pragma Preelaborate; *************** package System.OS_Interface is *** 56,92 **** -- General Types -- ------------------- - type DWORD is new Interfaces.C.unsigned_long; - type WORD is new Interfaces.C.unsigned_short; - - -- The LARGE_INTEGER type is actually a fixed point type - -- that only can represent integers. The reason for this is - -- easier conversion to Duration or other fixed point types. - -- (See Operations.Clock) - - type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0; - subtype PSZ is Interfaces.C.Strings.chars_ptr; - subtype PCHAR is Interfaces.C.Strings.chars_ptr; - - subtype PVOID is System.Address; - - Null_Void : constant PVOID := System.Null_Address; ! type PLONG is access all Interfaces.C.long; ! type PDWORD is access all DWORD; ! ! type BOOL is new Boolean; ! for BOOL'Size use Interfaces.C.unsigned_long'Size; ------------------------- -- Handles for objects -- ------------------------- ! type HANDLE is new Interfaces.C.long; ! type PHANDLE is access all HANDLE; ! ! subtype Thread_Id is HANDLE; ----------- -- Errno -- --- 59,73 ---- -- General Types -- ------------------- subtype PSZ is Interfaces.C.Strings.chars_ptr; ! Null_Void : constant Win32.PVOID := System.Null_Address; ------------------------- -- Handles for objects -- ------------------------- ! subtype Thread_Id is Win32.HANDLE; ----------- -- Errno -- *************** package System.OS_Interface is *** 95,119 **** NO_ERROR : constant := 0; FUNC_ERR : constant := -1; - ------------------------ - -- System Information -- - ------------------------ - - type SYSTEM_INFO is record - dwOemId : DWORD; - dwPageSize : DWORD; - lpMinimumApplicationAddress : PVOID; - lpMaximumApplicationAddress : PVOID; - dwActiveProcessorMask : DWORD; - dwNumberOfProcessors : DWORD; - dwProcessorType : DWORD; - dwAllocationGranularity : DWORD; - dwReserved : DWORD; - end record; - - procedure GetSystemInfo (SI : access SYSTEM_INFO); - pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo"); - ------------- -- Signals -- ------------- --- 76,81 ---- *************** package System.OS_Interface is *** 144,206 **** procedure kill (sig : Signal); pragma Import (C, kill, "raise"); - --------------------- - -- Time Management -- - --------------------- - - procedure Sleep (dwMilliseconds : DWORD); - pragma Import (Stdcall, Sleep, External_Name => "Sleep"); - - type SYSTEMTIME is record - wYear : WORD; - wMonth : WORD; - wDayOfWeek : WORD; - wDay : WORD; - wHour : WORD; - wMinute : WORD; - wSecond : WORD; - wMilliseconds : WORD; - end record; - - procedure GetSystemTime (pSystemTime : access SYSTEMTIME); - pragma Import (Stdcall, GetSystemTime, "GetSystemTime"); - - procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer); - pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime"); - - function SetSystemTime (pSystemTime : access SYSTEMTIME) return BOOL; - pragma Import (Stdcall, SetSystemTime, "SetSystemTime"); - - function FileTimeToSystemTime - (lpFileTime : access Long_Long_Integer; - lpSystemTime : access SYSTEMTIME) return BOOL; - pragma Import (Stdcall, FileTimeToSystemTime, "FileTimeToSystemTime"); - - function SystemTimeToFileTime - (lpSystemTime : access SYSTEMTIME; - lpFileTime : access Long_Long_Integer) return BOOL; - pragma Import (Stdcall, SystemTimeToFileTime, "SystemTimeToFileTime"); - - function FileTimeToLocalFileTime - (lpFileTime : access Long_Long_Integer; - lpLocalFileTime : access Long_Long_Integer) return BOOL; - pragma Import (Stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime"); - - function LocalFileTimeToFileTime - (lpFileTime : access Long_Long_Integer; - lpLocalFileTime : access Long_Long_Integer) return BOOL; - pragma Import (Stdcall, LocalFileTimeToFileTime, "LocalFileTimeToFileTime"); - - function QueryPerformanceCounter - (lpPerformanceCount : access LARGE_INTEGER) return BOOL; - pragma Import - (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter"); - - function QueryPerformanceFrequency - (lpFrequency : access LARGE_INTEGER) return BOOL; - pragma Import - (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency"); - ------------- -- Threads -- ------------- --- 106,111 ---- *************** package System.OS_Interface is *** 216,226 **** pragma Import (Stdcall, SwitchToThread, "SwitchToThread"); function GetThreadTimes ! (hThread : HANDLE; lpCreationTime : access Long_Long_Integer; lpExitTime : access Long_Long_Integer; lpKernelTime : access Long_Long_Integer; ! lpUserTime : access Long_Long_Integer) return BOOL; pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes"); ----------------------- --- 121,131 ---- pragma Import (Stdcall, SwitchToThread, "SwitchToThread"); function GetThreadTimes ! (hThread : Win32.HANDLE; lpCreationTime : access Long_Long_Integer; lpExitTime : access Long_Long_Integer; lpKernelTime : access Long_Long_Integer; ! lpUserTime : access Long_Long_Integer) return Win32.BOOL; pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes"); ----------------------- *************** package System.OS_Interface is *** 229,288 **** type CRITICAL_SECTION is private; - procedure InitializeCriticalSection - (pCriticalSection : access CRITICAL_SECTION); - pragma Import - (Stdcall, InitializeCriticalSection, "InitializeCriticalSection"); - - procedure EnterCriticalSection - (pCriticalSection : access CRITICAL_SECTION); - pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection"); - - procedure LeaveCriticalSection - (pCriticalSection : access CRITICAL_SECTION); - pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection"); - - procedure DeleteCriticalSection - (pCriticalSection : access CRITICAL_SECTION); - pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection"); - ------------------------------------------------------------- -- Thread Creation, Activation, Suspension And Termination -- ------------------------------------------------------------- - subtype ProcessorId is DWORD; - type PTHREAD_START_ROUTINE is access function ! (pThreadParameter : PVOID) return DWORD; pragma Convention (Stdcall, PTHREAD_START_ROUTINE); function To_PTHREAD_START_ROUTINE is new Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE); - type SECURITY_ATTRIBUTES is record - nLength : DWORD; - pSecurityDescriptor : PVOID; - bInheritHandle : BOOL; - end record; - - type PSECURITY_ATTRIBUTES is access all SECURITY_ATTRIBUTES; - function CreateThread ! (pThreadAttributes : PSECURITY_ATTRIBUTES; ! dwStackSize : DWORD; ! pStartAddress : PTHREAD_START_ROUTINE; ! pParameter : PVOID; ! dwCreationFlags : DWORD; ! pThreadId : PDWORD) return HANDLE; pragma Import (Stdcall, CreateThread, "CreateThread"); function BeginThreadEx ! (pThreadAttributes : PSECURITY_ATTRIBUTES; ! dwStackSize : DWORD; ! pStartAddress : PTHREAD_START_ROUTINE; ! pParameter : PVOID; ! dwCreationFlags : DWORD; ! pThreadId : PDWORD) return HANDLE; pragma Import (C, BeginThreadEx, "_beginthreadex"); Debug_Process : constant := 16#00000001#; --- 134,166 ---- type CRITICAL_SECTION is private; ------------------------------------------------------------- -- Thread Creation, Activation, Suspension And Termination -- ------------------------------------------------------------- type PTHREAD_START_ROUTINE is access function ! (pThreadParameter : Win32.PVOID) return Win32.DWORD; pragma Convention (Stdcall, PTHREAD_START_ROUTINE); function To_PTHREAD_START_ROUTINE is new Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE); function CreateThread ! (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES; ! dwStackSize : Win32.DWORD; ! pStartAddress : PTHREAD_START_ROUTINE; ! pParameter : Win32.PVOID; ! dwCreationFlags : Win32.DWORD; ! pThreadId : access Win32.DWORD) return Win32.HANDLE; pragma Import (Stdcall, CreateThread, "CreateThread"); function BeginThreadEx ! (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES; ! dwStackSize : Win32.DWORD; ! pStartAddress : PTHREAD_START_ROUTINE; ! pParameter : Win32.PVOID; ! dwCreationFlags : Win32.DWORD; ! pThreadId : not null access Win32.DWORD) return Win32.HANDLE; pragma Import (C, BeginThreadEx, "_beginthreadex"); Debug_Process : constant := 16#00000001#; *************** package System.OS_Interface is *** 302,371 **** Stack_Size_Param_Is_A_Reservation : constant := 16#00010000#; function GetExitCodeThread ! (hThread : HANDLE; ! pExitCode : PDWORD) return BOOL; pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread"); ! function ResumeThread (hThread : HANDLE) return DWORD; pragma Import (Stdcall, ResumeThread, "ResumeThread"); ! function SuspendThread (hThread : HANDLE) return DWORD; pragma Import (Stdcall, SuspendThread, "SuspendThread"); ! procedure ExitThread (dwExitCode : DWORD); pragma Import (Stdcall, ExitThread, "ExitThread"); ! procedure EndThreadEx (dwExitCode : DWORD); pragma Import (C, EndThreadEx, "_endthreadex"); function TerminateThread ! (hThread : HANDLE; ! dwExitCode : DWORD) return BOOL; pragma Import (Stdcall, TerminateThread, "TerminateThread"); ! function GetCurrentThread return HANDLE; pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread"); ! function GetCurrentProcess return HANDLE; pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess"); ! function GetCurrentThreadId return DWORD; pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId"); ! function TlsAlloc return DWORD; pragma Import (Stdcall, TlsAlloc, "TlsAlloc"); ! function TlsGetValue (dwTlsIndex : DWORD) return PVOID; pragma Import (Stdcall, TlsGetValue, "TlsGetValue"); ! function TlsSetValue (dwTlsIndex : DWORD; pTlsValue : PVOID) return BOOL; pragma Import (Stdcall, TlsSetValue, "TlsSetValue"); ! function TlsFree (dwTlsIndex : DWORD) return BOOL; pragma Import (Stdcall, TlsFree, "TlsFree"); ! TLS_Nothing : constant := DWORD'Last; procedure ExitProcess (uExitCode : Interfaces.C.unsigned); pragma Import (Stdcall, ExitProcess, "ExitProcess"); function WaitForSingleObject ! (hHandle : HANDLE; ! dwMilliseconds : DWORD) return DWORD; pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject"); function WaitForSingleObjectEx ! (hHandle : HANDLE; ! dwMilliseconds : DWORD; ! fAlertable : BOOL) return DWORD; pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx"); ! function SetThreadIdealProcessor ! (hThread : HANDLE; ! dwIdealProcessor : ProcessorId) return DWORD; ! pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor"); ! ! Wait_Infinite : constant := DWORD'Last; WAIT_TIMEOUT : constant := 16#0000_0102#; WAIT_FAILED : constant := 16#FFFF_FFFF#; --- 180,245 ---- Stack_Size_Param_Is_A_Reservation : constant := 16#00010000#; function GetExitCodeThread ! (hThread : Win32.HANDLE; ! pExitCode : not null access Win32.DWORD) return Win32.BOOL; pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread"); ! function ResumeThread (hThread : Win32.HANDLE) return Win32.DWORD; pragma Import (Stdcall, ResumeThread, "ResumeThread"); ! function SuspendThread (hThread : Win32.HANDLE) return Win32.DWORD; pragma Import (Stdcall, SuspendThread, "SuspendThread"); ! procedure ExitThread (dwExitCode : Win32.DWORD); pragma Import (Stdcall, ExitThread, "ExitThread"); ! procedure EndThreadEx (dwExitCode : Win32.DWORD); pragma Import (C, EndThreadEx, "_endthreadex"); function TerminateThread ! (hThread : Win32.HANDLE; ! dwExitCode : Win32.DWORD) return Win32.BOOL; pragma Import (Stdcall, TerminateThread, "TerminateThread"); ! function GetCurrentThread return Win32.HANDLE; pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread"); ! function GetCurrentProcess return Win32.HANDLE; pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess"); ! function GetCurrentThreadId return Win32.DWORD; pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId"); ! function TlsAlloc return Win32.DWORD; pragma Import (Stdcall, TlsAlloc, "TlsAlloc"); ! function TlsGetValue (dwTlsIndex : Win32.DWORD) return Win32.PVOID; pragma Import (Stdcall, TlsGetValue, "TlsGetValue"); ! function TlsSetValue ! (dwTlsIndex : Win32.DWORD; pTlsValue : Win32.PVOID) return Win32.BOOL; pragma Import (Stdcall, TlsSetValue, "TlsSetValue"); ! function TlsFree (dwTlsIndex : Win32.DWORD) return Win32.BOOL; pragma Import (Stdcall, TlsFree, "TlsFree"); ! TLS_Nothing : constant := Win32.DWORD'Last; procedure ExitProcess (uExitCode : Interfaces.C.unsigned); pragma Import (Stdcall, ExitProcess, "ExitProcess"); function WaitForSingleObject ! (hHandle : Win32.HANDLE; ! dwMilliseconds : Win32.DWORD) return Win32.DWORD; pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject"); function WaitForSingleObjectEx ! (hHandle : Win32.HANDLE; ! dwMilliseconds : Win32.DWORD; ! fAlertable : Win32.BOOL) return Win32.DWORD; pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx"); ! Wait_Infinite : constant := Win32.DWORD'Last; WAIT_TIMEOUT : constant := 16#0000_0102#; WAIT_FAILED : constant := 16#FFFF_FFFF#; *************** package System.OS_Interface is *** 373,435 **** -- Semaphores, Events and Mutexes -- ------------------------------------ - function CloseHandle (hObject : HANDLE) return BOOL; - pragma Import (Stdcall, CloseHandle, "CloseHandle"); - function CreateSemaphore ! (pSemaphoreAttributes : PSECURITY_ATTRIBUTES; lInitialCount : Interfaces.C.long; lMaximumCount : Interfaces.C.long; ! pName : PSZ) return HANDLE; pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA"); function OpenSemaphore ! (dwDesiredAccess : DWORD; ! bInheritHandle : BOOL; ! pName : PSZ) return HANDLE; pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA"); function ReleaseSemaphore ! (hSemaphore : HANDLE; lReleaseCount : Interfaces.C.long; ! pPreviousCount : PLONG) return BOOL; pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore"); function CreateEvent ! (pEventAttributes : PSECURITY_ATTRIBUTES; ! bManualReset : BOOL; ! bInitialState : BOOL; ! pName : PSZ) return HANDLE; pragma Import (Stdcall, CreateEvent, "CreateEventA"); function OpenEvent ! (dwDesiredAccess : DWORD; ! bInheritHandle : BOOL; ! pName : PSZ) return HANDLE; pragma Import (Stdcall, OpenEvent, "OpenEventA"); ! function SetEvent (hEvent : HANDLE) return BOOL; pragma Import (Stdcall, SetEvent, "SetEvent"); ! function ResetEvent (hEvent : HANDLE) return BOOL; pragma Import (Stdcall, ResetEvent, "ResetEvent"); ! function PulseEvent (hEvent : HANDLE) return BOOL; pragma Import (Stdcall, PulseEvent, "PulseEvent"); function CreateMutex ! (pMutexAttributes : PSECURITY_ATTRIBUTES; ! bInitialOwner : BOOL; ! pName : PSZ) return HANDLE; pragma Import (Stdcall, CreateMutex, "CreateMutexA"); function OpenMutex ! (dwDesiredAccess : DWORD; ! bInheritHandle : BOOL; ! pName : PSZ) return HANDLE; pragma Import (Stdcall, OpenMutex, "OpenMutexA"); ! function ReleaseMutex (hMutex : HANDLE) return BOOL; pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex"); --------------------------------------------------- --- 247,306 ---- -- Semaphores, Events and Mutexes -- ------------------------------------ function CreateSemaphore ! (pSemaphoreAttributes : access Win32.SECURITY_ATTRIBUTES; lInitialCount : Interfaces.C.long; lMaximumCount : Interfaces.C.long; ! pName : PSZ) return Win32.HANDLE; pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA"); function OpenSemaphore ! (dwDesiredAccess : Win32.DWORD; ! bInheritHandle : Win32.BOOL; ! pName : PSZ) return Win32.HANDLE; pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA"); function ReleaseSemaphore ! (hSemaphore : Win32.HANDLE; lReleaseCount : Interfaces.C.long; ! pPreviousCount : access Win32.LONG) return Win32.BOOL; pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore"); function CreateEvent ! (pEventAttributes : access Win32.SECURITY_ATTRIBUTES; ! bManualReset : Win32.BOOL; ! bInitialState : Win32.BOOL; ! pName : PSZ) return Win32.HANDLE; pragma Import (Stdcall, CreateEvent, "CreateEventA"); function OpenEvent ! (dwDesiredAccess : Win32.DWORD; ! bInheritHandle : Win32.BOOL; ! pName : PSZ) return Win32.HANDLE; pragma Import (Stdcall, OpenEvent, "OpenEventA"); ! function SetEvent (hEvent : Win32.HANDLE) return Win32.BOOL; pragma Import (Stdcall, SetEvent, "SetEvent"); ! function ResetEvent (hEvent : Win32.HANDLE) return Win32.BOOL; pragma Import (Stdcall, ResetEvent, "ResetEvent"); ! function PulseEvent (hEvent : Win32.HANDLE) return Win32.BOOL; pragma Import (Stdcall, PulseEvent, "PulseEvent"); function CreateMutex ! (pMutexAttributes : access Win32.SECURITY_ATTRIBUTES; ! bInitialOwner : Win32.BOOL; ! pName : PSZ) return Win32.HANDLE; pragma Import (Stdcall, CreateMutex, "CreateMutexA"); function OpenMutex ! (dwDesiredAccess : Win32.DWORD; ! bInheritHandle : Win32.BOOL; ! pName : PSZ) return Win32.HANDLE; pragma Import (Stdcall, OpenMutex, "OpenMutexA"); ! function ReleaseMutex (hMutex : Win32.HANDLE) return Win32.BOOL; pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex"); --------------------------------------------------- *************** package System.OS_Interface is *** 441,461 **** ----------------- function SetThreadPriority ! (hThread : HANDLE; ! nPriority : Interfaces.C.int) return BOOL; pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority"); ! function GetThreadPriority (hThread : HANDLE) return Interfaces.C.int; pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority"); function SetPriorityClass ! (hProcess : HANDLE; ! dwPriorityClass : DWORD) return BOOL; pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass"); procedure SetThreadPriorityBoost ! (hThread : HANDLE; ! DisablePriorityBoost : BOOL); pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost"); Normal_Priority_Class : constant := 16#00000020#; --- 312,332 ---- ----------------- function SetThreadPriority ! (hThread : Win32.HANDLE; ! nPriority : Interfaces.C.int) return Win32.BOOL; pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority"); ! function GetThreadPriority (hThread : Win32.HANDLE) return Interfaces.C.int; pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority"); function SetPriorityClass ! (hProcess : Win32.HANDLE; ! dwPriorityClass : Win32.DWORD) return Win32.BOOL; pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass"); procedure SetThreadPriorityBoost ! (hThread : Win32.HANDLE; ! DisablePriorityBoost : Win32.BOOL); pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost"); Normal_Priority_Class : constant := 16#00000020#; *************** package System.OS_Interface is *** 472,493 **** Thread_Priority_Time_Critical : constant := 15; Thread_Priority_Error_Return : constant := Interfaces.C.long'Last; - function GetLastError return DWORD; - pragma Import (Stdcall, GetLastError, "GetLastError"); - private type sigset_t is new Interfaces.C.unsigned_long; type CRITICAL_SECTION is record ! DebugInfo : System.Address; ! -- The following three fields control entering and ! -- exiting the critical section for the resource LockCount : Long_Integer; RecursionCount : Long_Integer; ! OwningThread : HANDLE; ! LockSemaphore : HANDLE; ! Reserved : DWORD; end record; end System.OS_Interface; --- 343,363 ---- Thread_Priority_Time_Critical : constant := 15; Thread_Priority_Error_Return : constant := Interfaces.C.long'Last; private type sigset_t is new Interfaces.C.unsigned_long; type CRITICAL_SECTION is record ! DebugInfo : System.Address; ! LockCount : Long_Integer; RecursionCount : Long_Integer; ! OwningThread : Win32.HANDLE; ! -- The above three fields control entering and exiting the critical ! -- section for the resource. ! ! LockSemaphore : Win32.HANDLE; ! Reserved : Win32.DWORD; end record; end System.OS_Interface; diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-rtems.adb gcc-4.4.0/gcc/ada/s-osinte-rtems.adb *** gcc-4.3.3/gcc/ada/s-osinte-rtems.adb Wed Feb 13 19:04:53 2008 --- gcc-4.4.0/gcc/ada/s-osinte-rtems.adb Tue Apr 22 14:15:04 2008 *************** package body System.OS_Interface is *** 135,138 **** --- 135,147 ---- return 0; end Get_Page_Size; + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int is + pragma Unreferenced (ss); + pragma Unreferenced (oss); + begin + return 0; + end sigaltstack; + end System.OS_Interface; diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-rtems.ads gcc-4.4.0/gcc/ada/s-osinte-rtems.ads *** gcc-4.3.3/gcc/ada/s-osinte-rtems.ads Wed Feb 13 19:04:53 2008 --- gcc-4.4.0/gcc/ada/s-osinte-rtems.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2008 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2009 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 35,51 **** -- -- ------------------------------------------------------------------------------ ! -- This is the RTEMS version of this package ! ! -- These are guesses based on what I think the GNARL team will want to ! -- call the rtems configurations. We use CPU-rtems for the rtems ! -- configurations. -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package ! -- or remove the pragma Elaborate_Body. -- It is designed to be a bottom-level (leaf) package. with Interfaces.C; --- 33,53 ---- -- -- ------------------------------------------------------------------------------ ! -- This is the RTEMS version of this package. ! -- ! -- RTEMS target names are of the form CPU-rtems. ! -- This implementation is designed to work on ALL RTEMS targets. ! -- The RTEMS implementation is primarily based upon the POSIX threads ! -- API but there are also bindings to GNAT/RTEMS support routines ! -- to insulate this code from C API specific details and, in some ! -- cases, obtain target architecture and BSP specific information ! -- that is unavailable at the time this package is built. -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package ! -- or remove the pragma Preelaborate. -- It is designed to be a bottom-level (leaf) package. with Interfaces.C; *************** package System.OS_Interface is *** 84,90 **** -- Signals -- ------------- ! Max_Interrupt : constant := 31; type Signal is new int range 0 .. Max_Interrupt; SIGXCPU : constant := 0; -- XCPU --- 86,98 ---- -- Signals -- ------------- ! Num_HW_Interrupts : constant := 256; ! ! Max_HW_Interrupt : constant := Num_HW_Interrupts - 1; ! type HW_Interrupt is new int range 0 .. Max_HW_Interrupt; ! ! Max_Interrupt : constant := Max_HW_Interrupt; ! type Signal is new int range 0 .. Max_Interrupt; SIGXCPU : constant := 0; -- XCPU *************** package System.OS_Interface is *** 141,146 **** --- 149,159 ---- SA_SIGINFO : constant := 16#02#; + SA_ONSTACK : constant := 16#00#; + -- SA_ONSTACK is not defined on RTEMS, but it is referred to in the POSIX + -- implementation of System.Interrupt_Management. Therefore we define a + -- dummy value of zero here so that setting this flag is a nop. + SIG_BLOCK : constant := 1; SIG_UNBLOCK : constant := 2; SIG_SETMASK : constant := 3; *************** package System.OS_Interface is *** 159,165 **** ---------- Time_Slice_Supported : constant Boolean := True; ! -- Indicates wether time slicing is supported (i.e SCHED_RR is supported) type timespec is private; --- 172,178 ---- ---------- Time_Slice_Supported : constant Boolean := True; ! -- Indicates whether time slicing is supported (i.e SCHED_RR is supported) type timespec is private; *************** package System.OS_Interface is *** 249,256 **** -- Stack -- ----------- Stack_Base_Available : constant Boolean := False; ! -- Indicates wether the stack base is available on this target. -- This allows us to share s-osinte.adb between all the FSU/RTEMS -- run time. -- Note that this value can only be true if pthread_t has a complete --- 262,286 ---- -- Stack -- ----------- + type stack_t is record + ss_sp : System.Address; + ss_flags : int; + ss_size : size_t; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + + Alternate_Stack : aliased System.Address; + -- This is a dummy definition, never used (Alternate_Stack_Size is null) + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + Stack_Base_Available : constant Boolean := False; ! -- Indicates whether the stack base is available on this target. -- This allows us to share s-osinte.adb between all the FSU/RTEMS -- run time. -- Note that this value can only be true if pthread_t has a complete *************** package System.OS_Interface is *** 386,392 **** type struct_sched_param is record sched_priority : int; ! ss_low_priority : timespec; ss_replenish_period : timespec; ss_initial_budget : timespec; end record; --- 416,422 ---- type struct_sched_param is record sched_priority : int; ! ss_low_priority : int; ss_replenish_period : timespec; ss_initial_budget : timespec; end record; *************** package System.OS_Interface is *** 475,480 **** --- 505,583 ---- destructor : destructor_pointer) return int; pragma Import (C, pthread_key_create, "pthread_key_create"); + ------------------------------------------------------------ + -- Binary Semaphore Wrapper to Support Interrupt Tasks -- + ------------------------------------------------------------ + + type Binary_Semaphore_Id is new rtems_id; + + function Binary_Semaphore_Create return Binary_Semaphore_Id; + pragma Import ( + C, + Binary_Semaphore_Create, + "__gnat_binary_semaphore_create"); + + function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int; + pragma Import ( + C, + Binary_Semaphore_Delete, + "__gnat_binary_semaphore_delete"); + + function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int; + pragma Import ( + C, + Binary_Semaphore_Obtain, + "__gnat_binary_semaphore_obtain"); + + function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int; + pragma Import ( + C, + Binary_Semaphore_Release, + "__gnat_binary_semaphore_release"); + + function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int; + pragma Import ( + C, + Binary_Semaphore_Flush, + "__gnat_binary_semaphore_flush"); + + ------------------------------------------------------------ + -- Hardware Interrupt Wrappers to Support Interrupt Tasks -- + ------------------------------------------------------------ + + type Interrupt_Handler is access procedure (parameter : System.Address); + pragma Convention (C, Interrupt_Handler); + type Interrupt_Vector is new System.Address; + + function Interrupt_Connect + (vector : Interrupt_Vector; + handler : Interrupt_Handler; + parameter : System.Address := System.Null_Address) return int; + pragma Import (C, Interrupt_Connect, "__gnat_interrupt_connect"); + -- Use this to set up an user handler. The routine installs a + -- a user handler which is invoked after RTEMS has saved enough + -- context for a high-level language routine to be safely invoked. + + function Interrupt_Vector_Get + (Vector : Interrupt_Vector) return Interrupt_Handler; + pragma Import (C, Interrupt_Vector_Get, "__gnat_interrupt_get"); + -- Use this to get the existing handler for later restoral. + + procedure Interrupt_Vector_Set + (Vector : Interrupt_Vector; + Handler : Interrupt_Handler); + pragma Import (C, Interrupt_Vector_Set, "__gnat_interrupt_set"); + -- Use this to restore a handler obtained using Interrupt_Vector_Get. + + function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; + -- Convert a logical interrupt number to the hardware interrupt vector + -- number used to connect the interrupt. + pragma Import ( + C, + Interrupt_Number_To_Vector, + "__gnat_interrupt_number_to_vector" + ); + private type sigset_t is new int; *************** private *** 507,518 **** schedpolicy : int; schedparam : struct_sched_param; cputime_clocked_allowed : int; ! deatchstate : int; end record; pragma Convention (C, pthread_attr_t); type pthread_condattr_t is record ! flags : int; end record; pragma Convention (C, pthread_condattr_t); --- 610,622 ---- schedpolicy : int; schedparam : struct_sched_param; cputime_clocked_allowed : int; ! detatchstate : int; end record; pragma Convention (C, pthread_attr_t); type pthread_condattr_t is record ! flags : int; ! process_shared : int; end record; pragma Convention (C, pthread_condattr_t); diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-solaris-posix.ads gcc-4.4.0/gcc/ada/s-osinte-solaris-posix.ads *** gcc-4.3.3/gcc/ada/s-osinte-solaris-posix.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-solaris-posix.ads Thu Apr 10 21:44:46 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 35,46 **** -- This is a Solaris (POSIX Threads) version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; with Ada.Unchecked_Conversion; package System.OS_Interface is --- 35,47 ---- -- This is a Solaris (POSIX Threads) version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; + with Ada.Unchecked_Conversion; package System.OS_Interface is *************** package System.OS_Interface is *** 164,169 **** --- 165,171 ---- type struct_sigaction_ptr is access all struct_sigaction; SA_SIGINFO : constant := 16#0008#; + SA_ONSTACK : constant := 16#0001#; SIG_BLOCK : constant := 1; SIG_UNBLOCK : constant := 2; *************** package System.OS_Interface is *** 183,189 **** ---------- Time_Slice_Supported : constant Boolean := True; ! -- Indicates wether time slicing is supported type timespec is private; --- 185,191 ---- ---------- Time_Slice_Supported : constant Boolean := True; ! -- Indicates whether time slicing is supported type timespec is private; *************** package System.OS_Interface is *** 271,296 **** -- Stack -- ----------- Stack_Base_Available : constant Boolean := False; -- Indicates whether the stack base is available on this target function Get_Stack_Base (thread : pthread_t) return Address; pragma Inline (Get_Stack_Base); ! -- returns the stack base of the specified thread. ! -- Only call this function when Stack_Base_Available is True. function Get_Page_Size return size_t; function Get_Page_Size return Address; pragma Import (C, Get_Page_Size, "getpagesize"); ! -- returns the size of a page, or 0 if this is not relevant on this ! -- target PROT_NONE : constant := 0; PROT_READ : constant := 1; PROT_WRITE : constant := 2; PROT_EXEC : constant := 4; PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - PROT_ON : constant := PROT_READ; PROT_OFF : constant := PROT_ALL; --- 273,314 ---- -- Stack -- ----------- + type stack_t is record + ss_sp : System.Address; + ss_size : size_t; + ss_flags : int; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + -- This is a dummy definition, never used (Alternate_Stack_Size is null) + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + Stack_Base_Available : constant Boolean := False; -- Indicates whether the stack base is available on this target function Get_Stack_Base (thread : pthread_t) return Address; pragma Inline (Get_Stack_Base); ! -- Returns the stack base of the specified thread. Only call this function ! -- when Stack_Base_Available is True. function Get_Page_Size return size_t; function Get_Page_Size return Address; pragma Import (C, Get_Page_Size, "getpagesize"); ! -- Returns the size of a page, or 0 if this is not relevant on this target PROT_NONE : constant := 0; PROT_READ : constant := 1; PROT_WRITE : constant := 2; PROT_EXEC : constant := 4; PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; PROT_ON : constant := PROT_READ; PROT_OFF : constant := PROT_ALL; diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-solaris.ads gcc-4.4.0/gcc/ada/s-osinte-solaris.ads *** gcc-4.3.3/gcc/ada/s-osinte-solaris.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-solaris.ads Wed Mar 26 07:35:19 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 35,46 **** -- This is a Solaris (native) version of this package -- This package includes all direct interfaces to OS services ! -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; with Ada.Unchecked_Conversion; package System.OS_Interface is --- 35,47 ---- -- This is a Solaris (native) version of this package -- This package includes all direct interfaces to OS services ! -- that are needed by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; + with Ada.Unchecked_Conversion; package System.OS_Interface is diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-tru64.adb gcc-4.4.0/gcc/ada/s-osinte-tru64.adb *** gcc-4.3.3/gcc/ada/s-osinte-tru64.adb Mon Oct 15 13:53:30 2007 --- gcc-4.4.0/gcc/ada/s-osinte-tru64.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-tru64.ads gcc-4.4.0/gcc/ada/s-osinte-tru64.ads *** gcc-4.3.3/gcc/ada/s-osinte-tru64.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-tru64.ads Tue Apr 8 06:43:15 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 32,46 **** -- -- ------------------------------------------------------------------------------ ! -- This is the DEC Unix 4.0/5.1 version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; with Ada.Unchecked_Conversion; package System.OS_Interface is --- 32,47 ---- -- -- ------------------------------------------------------------------------------ ! -- This is the Tru64 version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; + with Ada.Unchecked_Conversion; package System.OS_Interface is *************** package System.OS_Interface is *** 175,180 **** --- 176,182 ---- SA_NODEFER : constant := 8; SA_SIGINFO : constant := 16#40#; + SA_ONSTACK : constant := 16#01#; function sigaction (sig : Signal; diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-vms.ads gcc-4.4.0/gcc/ada/s-osinte-vms.ads *** gcc-4.3.3/gcc/ada/s-osinte-vms.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-vms.ads Wed Mar 26 07:35:19 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 35,47 **** -- This is a OpenVMS/Alpha version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; with Ada.Unchecked_Conversion; with System.Aux_DEC; package System.OS_Interface is --- 35,49 ---- -- This is a OpenVMS/Alpha version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; + with Ada.Unchecked_Conversion; + with System.Aux_DEC; package System.OS_Interface is diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-vxworks-kernel.adb gcc-4.4.0/gcc/ada/s-osinte-vxworks-kernel.adb *** gcc-4.3.3/gcc/ada/s-osinte-vxworks-kernel.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-osinte-vxworks-kernel.adb Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,249 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . O S _ I N T E R F A C E -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- + -- -- + -- GNARL 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNARL was developed by the GNARL team at Florida State University. -- + -- Extensive contributions were provided by Ada Core Technologies, Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the VxWorks version + + -- This package encapsulates all direct interfaces to OS services that are + -- needed by children of System. + + pragma Polling (Off); + -- Turn off polling, we do not want ATC polling to take place during tasking + -- operations. It causes infinite loops and other problems. + + package body System.OS_Interface is + + use type Interfaces.C.int; + + Low_Priority : constant := 255; + -- VxWorks native (default) lowest scheduling priority + + ---------- + -- kill -- + ---------- + + function kill (pid : t_id; sig : Signal) return int is + begin + return System.VxWorks.Ext.kill (pid, int (sig)); + end kill; + + ------------- + -- sigwait -- + ------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int + is + Result : int; + + function sigwaitinfo + (set : access sigset_t; sigvalue : System.Address) return int; + pragma Import (C, sigwaitinfo, "sigwaitinfo"); + + begin + Result := sigwaitinfo (set, System.Null_Address); + + if Result /= -1 then + sig.all := Signal (Result); + return 0; + else + sig.all := 0; + return errno; + end if; + end sigwait; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F is negative due to a round-up, adjust for positive F value + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(ts_sec => S, + ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ------------------------- + -- To_VxWorks_Priority -- + ------------------------- + + function To_VxWorks_Priority (Priority : int) return int is + begin + return Low_Priority - Priority; + end To_VxWorks_Priority; + + -------------------- + -- To_Clock_Ticks -- + -------------------- + + -- ??? - For now, we'll always get the system clock rate since it is + -- allowed to be changed during run-time in VxWorks. A better method would + -- be to provide an operation to set it that so we can always know its + -- value. + + -- Another thing we should probably allow for is a resultant tick count + -- greater than int'Last. This should probably be a procedure with two + -- output parameters, one in the range 0 .. int'Last, and another + -- representing the overflow count. + + function To_Clock_Ticks (D : Duration) return int is + Ticks : Long_Long_Integer; + Rate_Duration : Duration; + Ticks_Duration : Duration; + + begin + if D < 0.0 then + return -1; + end if; + + -- Ensure that the duration can be converted to ticks + -- at the current clock tick rate without overflowing. + + Rate_Duration := Duration (sysClkRateGet); + + if D > (Duration'Last / Rate_Duration) then + Ticks := Long_Long_Integer (int'Last); + else + Ticks_Duration := D * Rate_Duration; + Ticks := Long_Long_Integer (Ticks_Duration); + + if Ticks_Duration > Duration (Ticks) then + Ticks := Ticks + 1; + end if; + + if Ticks > Long_Long_Integer (int'Last) then + Ticks := Long_Long_Integer (int'Last); + end if; + end if; + + return int (Ticks); + end To_Clock_Ticks; + + ----------------------------- + -- Binary_Semaphore_Create -- + ----------------------------- + + function Binary_Semaphore_Create return Binary_Semaphore_Id is + begin + return Binary_Semaphore_Id (semBCreate (SEM_Q_FIFO, SEM_EMPTY)); + end Binary_Semaphore_Create; + + ----------------------------- + -- Binary_Semaphore_Delete -- + ----------------------------- + + function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int is + begin + return semDelete (SEM_ID (ID)); + end Binary_Semaphore_Delete; + + ----------------------------- + -- Binary_Semaphore_Obtain -- + ----------------------------- + + function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int is + begin + return semTake (SEM_ID (ID), WAIT_FOREVER); + end Binary_Semaphore_Obtain; + + ------------------------------ + -- Binary_Semaphore_Release -- + ------------------------------ + + function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int is + begin + return semGive (SEM_ID (ID)); + end Binary_Semaphore_Release; + + ---------------------------- + -- Binary_Semaphore_Flush -- + ---------------------------- + + function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int is + begin + return semFlush (SEM_ID (ID)); + end Binary_Semaphore_Flush; + + ----------------------- + -- Interrupt_Connect -- + ----------------------- + + function Interrupt_Connect + (Vector : Interrupt_Vector; + Handler : Interrupt_Handler; + Parameter : System.Address := System.Null_Address) return int + is + function intConnect + (vector : Interrupt_Vector; + handler : Interrupt_Handler; + parameter : System.Address) return int; + pragma Import (C, intConnect, "intConnect"); + + begin + return intConnect (Vector, Handler, Parameter); + end Interrupt_Connect; + + -------------------------------- + -- Interrupt_Number_To_Vector -- + -------------------------------- + + function Interrupt_Number_To_Vector + (intNum : int) return Interrupt_Vector + is + function INUM_TO_IVEC (intNum : int) return Interrupt_Vector; + pragma Import (C, INUM_TO_IVEC, "__gnat_inum_to_ivec"); + + begin + return INUM_TO_IVEC (intNum); + end Interrupt_Number_To_Vector; + + end System.OS_Interface; diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-vxworks.adb gcc-4.4.0/gcc/ada/s-osinte-vxworks.adb *** gcc-4.3.3/gcc/ada/s-osinte-vxworks.adb Tue Aug 14 08:42:09 2007 --- gcc-4.4.0/gcc/ada/s-osinte-vxworks.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package body System.OS_Interface is *** 47,108 **** Low_Priority : constant := 255; -- VxWorks native (default) lowest scheduling priority - ------------ - -- getpid -- - ------------ - - function getpid return t_id is - begin - -- VxWorks 5 (and VxWorks 6 in kernel mode) does not have a getpid - -- function. taskIdSelf is the equivalent routine. - - return taskIdSelf; - end getpid; - - -------------- - -- Int_Lock -- - -------------- - - function Int_Lock return int is - function intLock return int; - pragma Import (C, intLock, "intLock"); - begin - return intLock; - end Int_Lock; - - ---------------- - -- Int_Unlock -- - ---------------- - - function Int_Unlock return int is - function intUnlock return int; - pragma Import (C, intUnlock, "intUnlock"); - begin - return intUnlock; - end Int_Unlock; - ---------- -- kill -- ---------- function kill (pid : t_id; sig : Signal) return int is - function c_kill (pid : t_id; sig : Signal) return int; - pragma Import (C, c_kill, "kill"); begin ! return c_kill (pid, sig); end kill; - -------------------- - -- Set_Time_Slice -- - -------------------- - - function Set_Time_Slice (ticks : int) return int is - function kernelTimeSlice (ticks : int) return int; - pragma Import (C, kernelTimeSlice, "kernelTimeSlice"); - begin - return kernelTimeSlice (ticks); - end Set_Time_Slice; - ------------- -- sigwait -- ------------- --- 45,59 ---- Low_Priority : constant := 255; -- VxWorks native (default) lowest scheduling priority ---------- -- kill -- ---------- function kill (pid : t_id; sig : Signal) return int is begin ! return System.VxWorks.Ext.kill (pid, int (sig)); end kill; ------------- -- sigwait -- ------------- *************** package body System.OS_Interface is *** 129,156 **** end if; end sigwait; - --------------- - -- Task_Cont -- - --------------- - - function Task_Cont (tid : t_id) return int is - function taskResume (tid : t_id) return int; - pragma Import (C, taskResume, "taskResume"); - begin - return taskResume (tid); - end Task_Cont; - - --------------- - -- Task_Stop -- - --------------- - - function Task_Stop (tid : t_id) return int is - function taskSuspend (tid : t_id) return int; - pragma Import (C, taskSuspend, "taskSuspend"); - begin - return taskSuspend (tid); - end Task_Stop; - ----------------- -- To_Duration -- ----------------- --- 80,85 ---- *************** package body System.OS_Interface is *** 239,242 **** --- 168,240 ---- return int (Ticks); end To_Clock_Ticks; + ----------------------------- + -- Binary_Semaphore_Create -- + ----------------------------- + + function Binary_Semaphore_Create return Binary_Semaphore_Id is + begin + return Binary_Semaphore_Id (semBCreate (SEM_Q_FIFO, SEM_EMPTY)); + end Binary_Semaphore_Create; + + ----------------------------- + -- Binary_Semaphore_Delete -- + ----------------------------- + + function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int is + begin + return semDelete (SEM_ID (ID)); + end Binary_Semaphore_Delete; + + ----------------------------- + -- Binary_Semaphore_Obtain -- + ----------------------------- + + function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int is + begin + return semTake (SEM_ID (ID), WAIT_FOREVER); + end Binary_Semaphore_Obtain; + + ------------------------------ + -- Binary_Semaphore_Release -- + ------------------------------ + + function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int is + begin + return semGive (SEM_ID (ID)); + end Binary_Semaphore_Release; + + ---------------------------- + -- Binary_Semaphore_Flush -- + ---------------------------- + + function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int is + begin + return semFlush (SEM_ID (ID)); + end Binary_Semaphore_Flush; + + ----------------------- + -- Interrupt_Connect -- + ----------------------- + + function Interrupt_Connect + (Vector : Interrupt_Vector; + Handler : Interrupt_Handler; + Parameter : System.Address := System.Null_Address) return int + is + pragma Unreferenced (Vector, Handler, Parameter); + begin + return 0; + end Interrupt_Connect; + + -------------------------------- + -- Interrupt_Number_To_Vector -- + -------------------------------- + + function Interrupt_Number_To_Vector + (intNum : int) return Interrupt_Vector is + begin + return Interrupt_Vector (intNum); + end Interrupt_Number_To_Vector; + end System.OS_Interface; diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-vxworks.ads gcc-4.4.0/gcc/ada/s-osinte-vxworks.ads *** gcc-4.3.3/gcc/ada/s-osinte-vxworks.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-vxworks.ads Tue Sep 9 13:01:51 2008 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,13 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 32,57 **** -- -- ------------------------------------------------------------------------------ ! -- This is the VxWorks version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by children of System. -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; with System.VxWorks; package System.OS_Interface is pragma Preelaborate; ! subtype int is Interfaces.C.int; ! subtype short is Short_Integer; ! type unsigned_int is mod 2 ** int'Size; ! type long is new Long_Integer; ! type unsigned_long is mod 2 ** long'Size; ! type size_t is mod 2 ** Standard'Address_Size; ----------- -- Errno -- --- 32,60 ---- -- -- ------------------------------------------------------------------------------ ! -- This is the VxWorks 5.x and 6.x version of this package -- This package encapsulates all direct interfaces to OS services ! -- that are needed by the tasking run-time (libgnarl). -- PLEASE DO NOT add any with-clauses to this package or remove the pragma -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; with System.VxWorks; + with System.VxWorks.Ext; package System.OS_Interface is pragma Preelaborate; ! subtype int is Interfaces.C.int; ! subtype short is Short_Integer; ! type unsigned_int is mod 2 ** int'Size; ! type long is new Long_Integer; ! type unsigned_long is mod 2 ** long'Size; ! type long_long is new Long_Long_Integer; ! type unsigned_long_long is mod 2 ** long_long'Size; ! type size_t is mod 2 ** Standard'Address_Size; ----------- -- Errno -- *************** package System.OS_Interface is *** 72,78 **** -- Signals and Interrupts -- ---------------------------- ! NSIG : constant := 32; -- Number of signals on the target OS type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1); --- 75,81 ---- -- Signals and Interrupts -- ---------------------------- ! NSIG : constant := 64; -- Number of signals on the target OS type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1); *************** package System.OS_Interface is *** 81,91 **** Max_Interrupt : constant := Max_HW_Interrupt; ! SIGILL : constant := 4; -- illegal instruction (not reset) ! SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future ! SIGFPE : constant := 8; -- floating point exception ! SIGBUS : constant := 10; -- bus error ! SIGSEGV : constant := 11; -- segmentation violation ----------------------------------- -- Signal processing definitions -- --- 84,141 ---- Max_Interrupt : constant := Max_HW_Interrupt; ! -- Signals common to Vxworks 5.x and 6.x ! ! SIGILL : constant := 4; -- illegal instruction (not reset when caught) ! SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future ! SIGFPE : constant := 8; -- floating point exception ! SIGBUS : constant := 10; -- bus error ! SIGSEGV : constant := 11; -- segmentation violation ! ! -- Signals specific to VxWorks 6.x ! ! SIGHUP : constant := 1; -- hangup ! SIGINT : constant := 2; -- interrupt ! SIGQUIT : constant := 3; -- quit ! SIGTRAP : constant := 5; -- trace trap (not reset when caught) ! SIGEMT : constant := 7; -- EMT instruction ! SIGKILL : constant := 9; -- kill ! SIGFMT : constant := 12; -- STACK FORMAT ERROR (not posix) ! SIGPIPE : constant := 13; -- write on a pipe with no one to read it ! SIGALRM : constant := 14; -- alarm clock ! SIGTERM : constant := 15; -- software termination signal from kill ! SIGCNCL : constant := 16; -- pthreads cancellation signal ! SIGSTOP : constant := 17; -- sendable stop signal not from tty ! SIGTSTP : constant := 18; -- stop signal from tty ! SIGCONT : constant := 19; -- continue a stopped process ! SIGCHLD : constant := 20; -- to parent on child stop or exit ! SIGTTIN : constant := 21; -- to readers pgrp upon background tty read ! SIGTTOU : constant := 22; -- like TTIN for output ! ! SIGRES1 : constant := 23; -- reserved signal number (Not POSIX) ! SIGRES2 : constant := 24; -- reserved signal number (Not POSIX) ! SIGRES3 : constant := 25; -- reserved signal number (Not POSIX) ! SIGRES4 : constant := 26; -- reserved signal number (Not POSIX) ! SIGRES5 : constant := 27; -- reserved signal number (Not POSIX) ! SIGRES6 : constant := 28; -- reserved signal number (Not POSIX) ! SIGRES7 : constant := 29; -- reserved signal number (Not POSIX) ! ! SIGUSR1 : constant := 30; -- user defined signal 1 ! SIGUSR2 : constant := 31; -- user defined signal 2 ! ! SIGPOLL : constant := 32; -- pollable event ! SIGPROF : constant := 33; -- profiling timer expired ! SIGSYS : constant := 34; -- bad system call ! SIGURG : constant := 35; -- high bandwidth data is available at socket ! SIGVTALRM : constant := 36; -- virtual timer expired ! SIGXCPU : constant := 37; -- CPU time limit exceeded ! SIGXFSZ : constant := 38; -- file size time limit exceeded ! ! SIGEVTS : constant := 39; -- signal event thread send ! SIGEVTD : constant := 40; -- signal event thread delete ! ! SIGRTMIN : constant := 48; -- Realtime signal min ! SIGRTMAX : constant := 63; -- Realtime signal max ----------------------------------- -- Signal processing definitions -- *************** package System.OS_Interface is *** 99,106 **** -- The sa_flags in struct sigaction ! SA_SIGINFO : constant := 16#0002#; ! SA_ONSTACK : constant := 16#0004#; SIG_DFL : constant := 0; SIG_IGN : constant := 1; --- 149,156 ---- -- The sa_flags in struct sigaction ! SA_SIGINFO : constant := 16#0002#; ! SA_ONSTACK : constant := 16#0004#; SIG_DFL : constant := 0; SIG_IGN : constant := 1; *************** package System.OS_Interface is *** 151,186 **** oset : access sigset_t) return int; pragma Import (C, pthread_sigmask, "sigprocmask"); ! type t_id is new long; subtype Thread_Id is t_id; function kill (pid : t_id; sig : Signal) return int; pragma Inline (kill); ! function getpid return t_id; ! pragma Inline (getpid); ! function Task_Stop (tid : t_id) return int; ! pragma Inline (Task_Stop); -- If we are in the kernel space, stop the task whose t_id is -- given in parameter in such a way that it can be examined by the -- debugger. This typically maps to taskSuspend on VxWorks 5 and -- to taskStop on VxWorks 6. ! function Task_Cont (tid : t_id) return int; ! pragma Inline (Task_Cont); -- If we are in the kernel space, continue the task whose t_id is -- given in parameter if it has been stopped previously to be examined -- by the debugger (e.g. by taskStop). It typically maps to taskResume -- on VxWorks 5 and to taskCont on VxWorks 6. ! function Int_Lock return int; ! pragma Inline (Int_Lock); -- If we are in the kernel space, lock interrupts. It typically maps to -- intLock. ! function Int_Unlock return int; ! pragma Inline (Int_Unlock); -- If we are in the kernel space, unlock interrupts. It typically maps to -- intUnlock. --- 201,233 ---- oset : access sigset_t) return int; pragma Import (C, pthread_sigmask, "sigprocmask"); ! subtype t_id is System.VxWorks.Ext.t_id; subtype Thread_Id is t_id; function kill (pid : t_id; sig : Signal) return int; pragma Inline (kill); ! function getpid return t_id renames System.VxWorks.Ext.getpid; ! function Task_Stop (tid : t_id) return int ! renames System.VxWorks.Ext.Task_Stop; -- If we are in the kernel space, stop the task whose t_id is -- given in parameter in such a way that it can be examined by the -- debugger. This typically maps to taskSuspend on VxWorks 5 and -- to taskStop on VxWorks 6. ! function Task_Cont (tid : t_id) return int ! renames System.VxWorks.Ext.Task_Cont; -- If we are in the kernel space, continue the task whose t_id is -- given in parameter if it has been stopped previously to be examined -- by the debugger (e.g. by taskStop). It typically maps to taskResume -- on VxWorks 5 and to taskCont on VxWorks 6. ! function Int_Lock return int renames System.VxWorks.Ext.Int_Lock; -- If we are in the kernel space, lock interrupts. It typically maps to -- intLock. ! function Int_Unlock return int renames System.VxWorks.Ext.Int_Unlock; -- If we are in the kernel space, unlock interrupts. It typically maps to -- intUnlock. *************** package System.OS_Interface is *** 213,226 **** (clock_id : clockid_t; tp : access timespec) return int; pragma Import (C, clock_gettime, "clock_gettime"); - type ULONG is new unsigned_long; - - procedure tickSet (ticks : ULONG); - pragma Import (C, tickSet, "tickSet"); - - function tickGet return ULONG; - pragma Import (C, tickGet, "tickGet"); - ---------------------- -- Utility Routines -- ---------------------- --- 260,265 ---- *************** package System.OS_Interface is *** 323,330 **** procedure taskDelete (tid : t_id); pragma Import (C, taskDelete, "taskDelete"); ! function Set_Time_Slice (ticks : int) return int; ! pragma Inline (Set_Time_Slice); -- Calls kernelTimeSlice under VxWorks 5.x -- Do nothing under VxWorks 6.x --- 362,369 ---- procedure taskDelete (tid : t_id); pragma Import (C, taskDelete, "taskDelete"); ! function Set_Time_Slice (ticks : int) return int ! renames System.VxWorks.Ext.Set_Time_Slice; -- Calls kernelTimeSlice under VxWorks 5.x -- Do nothing under VxWorks 6.x *************** package System.OS_Interface is *** 393,400 **** pragma Import (C, semFlush, "semFlush"); -- Release all threads blocked on the semaphore private ! type sigset_t is new long; type pid_t is new int; --- 432,483 ---- pragma Import (C, semFlush, "semFlush"); -- Release all threads blocked on the semaphore + ------------------------------------------------------------ + -- Binary Semaphore Wrapper to Support Interrupt Tasks -- + ------------------------------------------------------------ + + type Binary_Semaphore_Id is new Long_Integer; + + function Binary_Semaphore_Create return Binary_Semaphore_Id; + pragma Inline (Binary_Semaphore_Create); + + function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int; + pragma Inline (Binary_Semaphore_Delete); + + function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int; + pragma Inline (Binary_Semaphore_Obtain); + + function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int; + pragma Inline (Binary_Semaphore_Release); + + function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int; + pragma Inline (Binary_Semaphore_Flush); + + ------------------------------------------------------------ + -- Hardware Interrupt Wrappers to Support Interrupt Tasks -- + ------------------------------------------------------------ + + type Interrupt_Handler is access procedure (parameter : System.Address); + pragma Convention (C, Interrupt_Handler); + + type Interrupt_Vector is new System.Address; + + function Interrupt_Connect + (Vector : Interrupt_Vector; + Handler : Interrupt_Handler; + Parameter : System.Address := System.Null_Address) return int; + pragma Inline (Interrupt_Connect); + -- Use this to set up an user handler. The routine installs a + -- a user handler which is invoked after RTEMS has saved enough + -- context for a high-level language routine to be safely invoked. + + function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; + pragma Inline (Interrupt_Number_To_Vector); + -- Convert a logical interrupt number to the hardware interrupt vector + -- number used to connect the interrupt. + private ! type sigset_t is new unsigned_long_long; type pid_t is new int; diff -Nrcpad gcc-4.3.3/gcc/ada/s-osinte-vxworks6.ads gcc-4.4.0/gcc/ada/s-osinte-vxworks6.ads *** gcc-4.3.3/gcc/ada/s-osinte-vxworks6.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-osinte-vxworks6.ads Thu Jan 1 00:00:00 1970 *************** *** 1,446 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- S Y S T E M . O S _ I N T E R F A C E -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 1991-1994, Florida State University -- - -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- - -- -- - -- GNARL 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- - -- Boston, MA 02110-1301, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. -- - -- Extensive contributions were provided by Ada Core Technologies, Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the VxWorks 6.x version of this package - - -- This package encapsulates all direct interfaces to OS services - -- that are needed by children of System. - - -- PLEASE DO NOT add any with-clauses to this package or remove the pragma - -- Preelaborate. This package is designed to be a bottom-level (leaf) package. - - with Interfaces.C; - with System.VxWorks; - - package System.OS_Interface is - pragma Preelaborate; - - subtype int is Interfaces.C.int; - subtype short is Short_Integer; - type unsigned_int is mod 2 ** int'Size; - type long is new Long_Integer; - type unsigned_long is mod 2 ** long'Size; - type long_long is new Long_Long_Integer; - type unsigned_long_long is mod 2 ** long_long'Size; - type size_t is mod 2 ** Standard'Address_Size; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "errnoGet"); - - EINTR : constant := 4; - EAGAIN : constant := 35; - ENOMEM : constant := 12; - EINVAL : constant := 22; - ETIMEDOUT : constant := 60; - - FUNC_ERR : constant := -1; - - ---------------------------- - -- Signals and Interrupts -- - ---------------------------- - - NSIG : constant := 64; - -- Number of signals on the target OS - type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1); - - Max_HW_Interrupt : constant := System.VxWorks.Num_HW_Interrupts - 1; - type HW_Interrupt is new int range 0 .. Max_HW_Interrupt; - - Max_Interrupt : constant := Max_HW_Interrupt; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt - SIGQUIT : constant := 3; -- quit - SIGILL : constant := 4; -- illegal instruction (not reset when caught) - SIGTRAP : constant := 5; -- trace trap (not reset when caught) - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGFMT : constant := 12; -- STACK FORMAT ERROR (not posix) - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGCNCL : constant := 16; -- pthreads cancellation signal - SIGSTOP : constant := 17; -- sendable stop signal not from tty - SIGTSTP : constant := 18; -- stop signal from tty - SIGCONT : constant := 19; -- continue a stopped process - SIGCHLD : constant := 20; -- to parent on child stop or exit - SIGTTIN : constant := 21; -- to readers pgrp upon background tty read - SIGTTOU : constant := 22; -- like TTIN for output - - SIGRES1 : constant := 23; -- reserved signal number (Not POSIX) - SIGRES2 : constant := 24; -- reserved signal number (Not POSIX) - SIGRES3 : constant := 25; -- reserved signal number (Not POSIX) - SIGRES4 : constant := 26; -- reserved signal number (Not POSIX) - SIGRES5 : constant := 27; -- reserved signal number (Not POSIX) - SIGRES6 : constant := 28; -- reserved signal number (Not POSIX) - SIGRES7 : constant := 29; -- reserved signal number (Not POSIX) - - SIGUSR1 : constant := 30; -- user defined signal 1 - SIGUSR2 : constant := 31; -- user defined signal 2 - - SIGPOLL : constant := 32; -- pollable event - SIGPROF : constant := 33; -- profiling timer expired - SIGSYS : constant := 34; -- bad system call - SIGURG : constant := 35; -- high bandwidth data is available at socket - SIGVTALRM : constant := 36; -- virtual timer expired - SIGXCPU : constant := 37; -- CPU time limit exceeded - SIGXFSZ : constant := 38; -- file size time limit exceeded - - SIGEVTS : constant := 39; -- signal event thread send - SIGEVTD : constant := 40; -- signal event thread delete - - SIGRTMIN : constant := 48; -- Realtime signal min - SIGRTMAX : constant := 63; -- Realtime signal max - - ----------------------------------- - -- Signal processing definitions -- - ----------------------------------- - - -- The how in sigprocmask(). - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 2; - SIG_SETMASK : constant := 3; - - -- The sa_flags in struct sigaction. - SA_SIGINFO : constant := 16#0002#; - SA_ONSTACK : constant := 16#0004#; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - type sigset_t is private; - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - type isr_address is access procedure (sig : int); - pragma Convention (C, isr_address); - - function c_signal (sig : Signal; handler : isr_address) return isr_address; - pragma Import (C, c_signal, "signal"); - - function sigwait (set : access sigset_t; sig : access Signal) return int; - pragma Inline (sigwait); - - function pthread_sigmask - (how : int; - set : access sigset_t; - oset : access sigset_t) return int; - pragma Import (C, pthread_sigmask, "sigprocmask"); - - type t_id is new long; - subtype Thread_Id is t_id; - - function kill (pid : t_id; sig : Signal) return int; - pragma Inline (kill); - - function getpid return t_id; - pragma Inline (getpid); - - function Task_Stop (tid : t_id) return int; - pragma Inline (Task_Stop); - -- If we are in the kernel space, continue the task whose t_id is - -- given in parameter if it has been stopped previously to be examined - -- by the debugger (e.g. by taskStop). It typically maps to taskResume - -- on VxWorks 5 and to taskCont on VxWorks 6. - - function Task_Cont (tid : t_id) return int; - pragma Inline (Task_Cont); - -- If we are in the kernel space, lock interrupts. It typically maps to - -- intLock. - - function Int_Lock return int; - pragma Inline (Int_Lock); - -- If we are in the kernel space, lock interrupts. It typically maps to - -- intLock. - - function Int_Unlock return int; - pragma Inline (Int_Unlock); - -- If we are in the kernel space, unlock interrupts. It typically maps to - -- intUnlock. - - ---------- - -- Time -- - ---------- - - type time_t is new unsigned_long; - - type timespec is record - ts_sec : time_t; - ts_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; -- System wide realtime clock - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - function To_Clock_Ticks (D : Duration) return int; - -- Convert a duration value (in seconds) into clock ticks - - function clock_gettime - (clock_id : clockid_t; tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - type ULONG is new unsigned_long; - - procedure tickSet (ticks : ULONG); - pragma Import (C, tickSet, "tickSet"); - - function tickGet return ULONG; - pragma Import (C, tickGet, "tickGet"); - - ---------------------- - -- Utility Routines -- - ---------------------- - - function To_VxWorks_Priority (Priority : int) return int; - pragma Inline (To_VxWorks_Priority); - -- Convenience routine to convert between VxWorks priority and Ada priority - - -------------------------- - -- VxWorks specific API -- - -------------------------- - - subtype STATUS is int; - -- Equivalent of the C type STATUS - - OK : constant STATUS := 0; - ERROR : constant STATUS := Interfaces.C.int (-1); - - function taskIdVerify (tid : t_id) return STATUS; - pragma Import (C, taskIdVerify, "taskIdVerify"); - - function taskIdSelf return t_id; - pragma Import (C, taskIdSelf, "taskIdSelf"); - - function taskOptionsGet (tid : t_id; pOptions : access int) return int; - pragma Import (C, taskOptionsGet, "taskOptionsGet"); - - function taskSuspend (tid : t_id) return int; - pragma Import (C, taskSuspend, "taskSuspend"); - - function taskResume (tid : t_id) return int; - pragma Import (C, taskResume, "taskResume"); - - function taskIsSuspended (tid : t_id) return int; - pragma Import (C, taskIsSuspended, "taskIsSuspended"); - - function taskDelay (ticks : int) return int; - procedure taskDelay (ticks : int); - pragma Import (C, taskDelay, "taskDelay"); - - function sysClkRateGet return int; - pragma Import (C, sysClkRateGet, "sysClkRateGet"); - - -- VxWorks 5.x specific functions - - function taskVarAdd - (tid : t_id; pVar : access System.Address) return int; - pragma Import (C, taskVarAdd, "taskVarAdd"); - - function taskVarDelete - (tid : t_id; pVar : access System.Address) return int; - pragma Import (C, taskVarDelete, "taskVarDelete"); - - function taskVarSet - (tid : t_id; - pVar : access System.Address; - value : System.Address) return int; - pragma Import (C, taskVarSet, "taskVarSet"); - - function taskVarGet - (tid : t_id; - pVar : access System.Address) return int; - pragma Import (C, taskVarGet, "taskVarGet"); - - -- VxWorks 6.x specific functions - - function tlsKeyCreate return int; - pragma Import (C, tlsKeyCreate, "tlsKeyCreate"); - - function tlsValueGet (key : int) return System.Address; - pragma Import (C, tlsValueGet, "tlsValueGet"); - - function tlsValueSet (key : int; value : System.Address) return STATUS; - pragma Import (C, tlsValueSet, "tlsValueSet"); - - -- Option flags for taskSpawn - - VX_UNBREAKABLE : constant := 16#0002#; - VX_FP_PRIVATE_ENV : constant := 16#0080#; - VX_NO_STACK_FILL : constant := 16#0100#; - - function taskSpawn - (name : System.Address; -- Pointer to task name - priority : int; - options : int; - stacksize : size_t; - start_routine : System.Address; - arg1 : System.Address; - arg2 : int := 0; - arg3 : int := 0; - arg4 : int := 0; - arg5 : int := 0; - arg6 : int := 0; - arg7 : int := 0; - arg8 : int := 0; - arg9 : int := 0; - arg10 : int := 0) return t_id; - pragma Import (C, taskSpawn, "taskSpawn"); - - procedure taskDelete (tid : t_id); - pragma Import (C, taskDelete, "taskDelete"); - - function Set_Time_Slice (ticks : int) return int; - pragma Inline (Set_Time_Slice); - -- Calls kernelTimeSlice under VxWorks 5.x - -- Do nothing under VxWorks 6.x - - function taskPriorityGet (tid : t_id; pPriority : access int) return int; - pragma Import (C, taskPriorityGet, "taskPriorityGet"); - - function taskPrioritySet (tid : t_id; newPriority : int) return int; - pragma Import (C, taskPrioritySet, "taskPrioritySet"); - - -- Semaphore creation flags - - SEM_Q_FIFO : constant := 0; - SEM_Q_PRIORITY : constant := 1; - SEM_DELETE_SAFE : constant := 4; -- only valid for binary semaphore - SEM_INVERSION_SAFE : constant := 8; -- only valid for binary semaphore - - -- Semaphore initial state flags - - SEM_EMPTY : constant := 0; - SEM_FULL : constant := 1; - - -- Semaphore take (semTake) time constants - - WAIT_FOREVER : constant := -1; - NO_WAIT : constant := 0; - - -- Error codes (errno). The lower level 16 bits are the error code, with - -- the upper 16 bits representing the module number in which the error - -- occurred. By convention, the module number is 0 for UNIX errors. VxWorks - -- reserves module numbers 1-500, with the remaining module numbers being - -- available for user applications. - - M_objLib : constant := 61 * 2**16; - -- semTake() failure with ticks = NO_WAIT - S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2; - -- semTake() timeout with ticks > NO_WAIT - S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4; - - type SEM_ID is new System.Address; - -- typedef struct semaphore *SEM_ID; - - -- We use two different kinds of VxWorks semaphores: mutex and binary - -- semaphores. A null ID is returned when a semaphore cannot be created. - - function semBCreate (options : int; initial_state : int) return SEM_ID; - pragma Import (C, semBCreate, "semBCreate"); - -- Create a binary semaphore. Return ID, or 0 if memory could not - -- be allocated. - - function semMCreate (options : int) return SEM_ID; - pragma Import (C, semMCreate, "semMCreate"); - - function semDelete (Sem : SEM_ID) return int; - pragma Import (C, semDelete, "semDelete"); - -- Delete a semaphore - - function semGive (Sem : SEM_ID) return int; - pragma Import (C, semGive, "semGive"); - - function semTake (Sem : SEM_ID; timeout : int) return int; - pragma Import (C, semTake, "semTake"); - -- Attempt to take binary semaphore. Error is returned if operation - -- times out - - function semFlush (SemID : SEM_ID) return STATUS; - pragma Import (C, semFlush, "semFlush"); - -- Release all threads blocked on the semaphore - - private - type sigset_t is new unsigned_long_long; - - type pid_t is new int; - - ERROR_PID : constant pid_t := -1; - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - - end System.OS_Interface; --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osprim-mingw.adb gcc-4.4.0/gcc/ada/s-osprim-mingw.adb *** gcc-4.3.3/gcc/ada/s-osprim-mingw.adb Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-osprim-mingw.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 33,72 **** -- This is the NT version of this package ! with Interfaces.C; package body System.OS_Primitives is ! --------------------------- ! -- Win32 API Definitions -- ! --------------------------- ! ! -- These definitions are copied from System.OS_Interface because we do not ! -- want to depend on gnarl here. ! ! type DWORD is new Interfaces.C.unsigned_long; ! ! type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0; ! ! type BOOL is new Boolean; ! for BOOL'Size use Interfaces.C.unsigned_long'Size; ! ! procedure GetSystemTimeAsFileTime ! (lpFileTime : not null access Long_Long_Integer); ! pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime"); ! ! function QueryPerformanceCounter ! (lpPerformanceCount : not null access LARGE_INTEGER) return BOOL; ! pragma Import ! (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter"); ! ! function QueryPerformanceFrequency ! (lpFrequency : not null access LARGE_INTEGER) return BOOL; ! pragma Import ! (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency"); ! ! procedure Sleep (dwMilliseconds : DWORD); ! pragma Import (Stdcall, Sleep, External_Name => "Sleep"); ---------------------------------------- -- Data for the high resolution clock -- --- 31,42 ---- -- This is the NT version of this package ! with System.Win32.Ext; package body System.OS_Primitives is ! use System.Win32; ! use System.Win32.Ext; ---------------------------------------- -- Data for the high resolution clock -- *************** package body System.OS_Primitives is *** 144,150 **** Now : aliased Long_Long_Integer; begin ! if not QueryPerformanceCounter (Current_Ticks'Access) then return 0.0; end if; --- 114,120 ---- Now : aliased Long_Long_Integer; begin ! if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then return 0.0; end if; *************** package body System.OS_Primitives is *** 158,167 **** Duration (Long_Long_Float (Current_Ticks - BTA.all) / Long_Long_Float (TFA.all)); ! -- If we have a shift of more than Max_Shift seconds we resynchonize the ! -- Clock. This is probably due to a manual Clock adjustment, an DST ! -- adjustment or an NTP synchronisation. And we want to adjust the time ! -- for this system (non-monotonic) clock. if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then Get_Base_Time; --- 128,137 ---- Duration (Long_Long_Float (Current_Ticks - BTA.all) / Long_Long_Float (TFA.all)); ! -- If we have a shift of more than Max_Shift seconds we resynchronize ! -- the Clock. This is probably due to a manual Clock adjustment, an ! -- DST adjustment or an NTP synchronisation. And we want to adjust the ! -- time for this system (non-monotonic) clock. if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then Get_Base_Time; *************** package body System.OS_Primitives is *** 202,208 **** loop GetSystemTimeAsFileTime (Base_Time'Access); ! if not QueryPerformanceCounter (Base_Ticks'Access) then pragma Assert (Standard.False, "Could not query high performance counter in Clock"); --- 172,178 ---- loop GetSystemTimeAsFileTime (Base_Time'Access); ! if QueryPerformanceCounter (Base_Ticks'Access) = Win32.FALSE then pragma Assert (Standard.False, "Could not query high performance counter in Clock"); *************** package body System.OS_Primitives is *** 228,234 **** Elap_Secs_Tick : Duration; begin ! if not QueryPerformanceCounter (Current_Ticks'Access) then return 0.0; end if; --- 198,204 ---- Elap_Secs_Tick : Duration; begin ! if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then return 0.0; end if; *************** package body System.OS_Primitives is *** 313,321 **** -- Get starting time as base ! if not QueryPerformanceFrequency (Tick_Frequency'Access) then ! raise Program_Error ! with "cannot get high performance counter frequency"; end if; Get_Base_Time; --- 283,291 ---- -- Get starting time as base ! if QueryPerformanceFrequency (Tick_Frequency'Access) = Win32.FALSE then ! raise Program_Error with ! "cannot get high performance counter frequency"; end if; Get_Base_Time; diff -Nrcpad gcc-4.3.3/gcc/ada/s-osprim-posix.adb gcc-4.4.0/gcc/ada/s-osprim-posix.adb *** gcc-4.3.3/gcc/ada/s-osprim-posix.adb Wed Jun 6 10:14:59 2007 --- gcc-4.4.0/gcc/ada/s-osprim-posix.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osprim-solaris.adb gcc-4.4.0/gcc/ada/s-osprim-solaris.adb *** gcc-4.3.3/gcc/ada/s-osprim-solaris.adb Wed Jun 6 10:14:59 2007 --- gcc-4.4.0/gcc/ada/s-osprim-solaris.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osprim-unix.adb gcc-4.4.0/gcc/ada/s-osprim-unix.adb *** gcc-4.3.3/gcc/ada/s-osprim-unix.adb Wed Jun 6 10:14:59 2007 --- gcc-4.4.0/gcc/ada/s-osprim-unix.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osprim-vms.adb gcc-4.4.0/gcc/ada/s-osprim-vms.adb *** gcc-4.3.3/gcc/ada/s-osprim-vms.adb Thu Dec 13 10:44:32 2007 --- gcc-4.4.0/gcc/ada/s-osprim-vms.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package body System.OS_Primitives is *** 71,77 **** -- pidadr = address of process id to be woken up -- prcnam = name of process to be woken up -- daytim = time to wake up ! -- reptim = repitition interval of wakeup calls -- procedure Sys_Schdwk --- 69,75 ---- -- pidadr = address of process id to be woken up -- prcnam = name of process to be woken up -- daytim = time to wake up ! -- reptim = repetition interval of wakeup calls -- procedure Sys_Schdwk diff -Nrcpad gcc-4.3.3/gcc/ada/s-osprim-vms.ads gcc-4.4.0/gcc/ada/s-osprim-vms.ads *** gcc-4.3.3/gcc/ada/s-osprim-vms.ads Wed Jun 6 10:15:55 2007 --- gcc-4.4.0/gcc/ada/s-osprim-vms.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osprim-vxworks.adb gcc-4.4.0/gcc/ada/s-osprim-vxworks.adb *** gcc-4.3.3/gcc/ada/s-osprim-vxworks.adb Wed Sep 26 10:41:24 2007 --- gcc-4.4.0/gcc/ada/s-osprim-vxworks.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** with System.OS_Interface; *** 40,46 **** -- create a dependency on libgnarl in libgnat, which is not desirable. with Interfaces.C; - -- used for type int package body System.OS_Primitives is --- 38,43 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-osprim.ads gcc-4.4.0/gcc/ada/s-osprim.ads *** gcc-4.3.3/gcc/ada/s-osprim.ads Wed Jun 6 10:52:32 2007 --- gcc-4.4.0/gcc/ada/s-osprim.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack03.adb gcc-4.4.0/gcc/ada/s-pack03.adb *** gcc-4.3.3/gcc/ada/s-pack03.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack03.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack03.ads gcc-4.4.0/gcc/ada/s-pack03.ads *** gcc-4.3.3/gcc/ada/s-pack03.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack03.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack05.adb gcc-4.4.0/gcc/ada/s-pack05.adb *** gcc-4.3.3/gcc/ada/s-pack05.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack05.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack05.ads gcc-4.4.0/gcc/ada/s-pack05.ads *** gcc-4.3.3/gcc/ada/s-pack05.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack05.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack06.adb gcc-4.4.0/gcc/ada/s-pack06.adb *** gcc-4.3.3/gcc/ada/s-pack06.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack06.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack06.ads gcc-4.4.0/gcc/ada/s-pack06.ads *** gcc-4.3.3/gcc/ada/s-pack06.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack06.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack07.adb gcc-4.4.0/gcc/ada/s-pack07.adb *** gcc-4.3.3/gcc/ada/s-pack07.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack07.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack07.ads gcc-4.4.0/gcc/ada/s-pack07.ads *** gcc-4.3.3/gcc/ada/s-pack07.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack07.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack09.adb gcc-4.4.0/gcc/ada/s-pack09.adb *** gcc-4.3.3/gcc/ada/s-pack09.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack09.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack09.ads gcc-4.4.0/gcc/ada/s-pack09.ads *** gcc-4.3.3/gcc/ada/s-pack09.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack09.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack10.adb gcc-4.4.0/gcc/ada/s-pack10.adb *** gcc-4.3.3/gcc/ada/s-pack10.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack10.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack10.ads gcc-4.4.0/gcc/ada/s-pack10.ads *** gcc-4.3.3/gcc/ada/s-pack10.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack10.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack11.adb gcc-4.4.0/gcc/ada/s-pack11.adb *** gcc-4.3.3/gcc/ada/s-pack11.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack11.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack11.ads gcc-4.4.0/gcc/ada/s-pack11.ads *** gcc-4.3.3/gcc/ada/s-pack11.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack11.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack12.adb gcc-4.4.0/gcc/ada/s-pack12.adb *** gcc-4.3.3/gcc/ada/s-pack12.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack12.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack12.ads gcc-4.4.0/gcc/ada/s-pack12.ads *** gcc-4.3.3/gcc/ada/s-pack12.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack12.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack13.adb gcc-4.4.0/gcc/ada/s-pack13.adb *** gcc-4.3.3/gcc/ada/s-pack13.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack13.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack13.ads gcc-4.4.0/gcc/ada/s-pack13.ads *** gcc-4.3.3/gcc/ada/s-pack13.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack13.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack14.adb gcc-4.4.0/gcc/ada/s-pack14.adb *** gcc-4.3.3/gcc/ada/s-pack14.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack14.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack14.ads gcc-4.4.0/gcc/ada/s-pack14.ads *** gcc-4.3.3/gcc/ada/s-pack14.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack14.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack15.adb gcc-4.4.0/gcc/ada/s-pack15.adb *** gcc-4.3.3/gcc/ada/s-pack15.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack15.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack15.ads gcc-4.4.0/gcc/ada/s-pack15.ads *** gcc-4.3.3/gcc/ada/s-pack15.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack15.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack17.adb gcc-4.4.0/gcc/ada/s-pack17.adb *** gcc-4.3.3/gcc/ada/s-pack17.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack17.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack17.ads gcc-4.4.0/gcc/ada/s-pack17.ads *** gcc-4.3.3/gcc/ada/s-pack17.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack17.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack18.adb gcc-4.4.0/gcc/ada/s-pack18.adb *** gcc-4.3.3/gcc/ada/s-pack18.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack18.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack18.ads gcc-4.4.0/gcc/ada/s-pack18.ads *** gcc-4.3.3/gcc/ada/s-pack18.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack18.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack19.adb gcc-4.4.0/gcc/ada/s-pack19.adb *** gcc-4.3.3/gcc/ada/s-pack19.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack19.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack19.ads gcc-4.4.0/gcc/ada/s-pack19.ads *** gcc-4.3.3/gcc/ada/s-pack19.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack19.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack20.adb gcc-4.4.0/gcc/ada/s-pack20.adb *** gcc-4.3.3/gcc/ada/s-pack20.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack20.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack20.ads gcc-4.4.0/gcc/ada/s-pack20.ads *** gcc-4.3.3/gcc/ada/s-pack20.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack20.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack21.adb gcc-4.4.0/gcc/ada/s-pack21.adb *** gcc-4.3.3/gcc/ada/s-pack21.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack21.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack21.ads gcc-4.4.0/gcc/ada/s-pack21.ads *** gcc-4.3.3/gcc/ada/s-pack21.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack21.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack22.adb gcc-4.4.0/gcc/ada/s-pack22.adb *** gcc-4.3.3/gcc/ada/s-pack22.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack22.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack22.ads gcc-4.4.0/gcc/ada/s-pack22.ads *** gcc-4.3.3/gcc/ada/s-pack22.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack22.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack23.adb gcc-4.4.0/gcc/ada/s-pack23.adb *** gcc-4.3.3/gcc/ada/s-pack23.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack23.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack23.ads gcc-4.4.0/gcc/ada/s-pack23.ads *** gcc-4.3.3/gcc/ada/s-pack23.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack23.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack24.adb gcc-4.4.0/gcc/ada/s-pack24.adb *** gcc-4.3.3/gcc/ada/s-pack24.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack24.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack24.ads gcc-4.4.0/gcc/ada/s-pack24.ads *** gcc-4.3.3/gcc/ada/s-pack24.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack24.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack25.adb gcc-4.4.0/gcc/ada/s-pack25.adb *** gcc-4.3.3/gcc/ada/s-pack25.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack25.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack25.ads gcc-4.4.0/gcc/ada/s-pack25.ads *** gcc-4.3.3/gcc/ada/s-pack25.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack25.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack26.adb gcc-4.4.0/gcc/ada/s-pack26.adb *** gcc-4.3.3/gcc/ada/s-pack26.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack26.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack26.ads gcc-4.4.0/gcc/ada/s-pack26.ads *** gcc-4.3.3/gcc/ada/s-pack26.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack26.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack27.adb gcc-4.4.0/gcc/ada/s-pack27.adb *** gcc-4.3.3/gcc/ada/s-pack27.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack27.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack27.ads gcc-4.4.0/gcc/ada/s-pack27.ads *** gcc-4.3.3/gcc/ada/s-pack27.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack27.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack28.adb gcc-4.4.0/gcc/ada/s-pack28.adb *** gcc-4.3.3/gcc/ada/s-pack28.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack28.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack28.ads gcc-4.4.0/gcc/ada/s-pack28.ads *** gcc-4.3.3/gcc/ada/s-pack28.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack28.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack29.adb gcc-4.4.0/gcc/ada/s-pack29.adb *** gcc-4.3.3/gcc/ada/s-pack29.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack29.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack29.ads gcc-4.4.0/gcc/ada/s-pack29.ads *** gcc-4.3.3/gcc/ada/s-pack29.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack29.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack30.adb gcc-4.4.0/gcc/ada/s-pack30.adb *** gcc-4.3.3/gcc/ada/s-pack30.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack30.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack30.ads gcc-4.4.0/gcc/ada/s-pack30.ads *** gcc-4.3.3/gcc/ada/s-pack30.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack30.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack31.adb gcc-4.4.0/gcc/ada/s-pack31.adb *** gcc-4.3.3/gcc/ada/s-pack31.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack31.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack31.ads gcc-4.4.0/gcc/ada/s-pack31.ads *** gcc-4.3.3/gcc/ada/s-pack31.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack31.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack33.adb gcc-4.4.0/gcc/ada/s-pack33.adb *** gcc-4.3.3/gcc/ada/s-pack33.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack33.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack33.ads gcc-4.4.0/gcc/ada/s-pack33.ads *** gcc-4.3.3/gcc/ada/s-pack33.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack33.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack34.adb gcc-4.4.0/gcc/ada/s-pack34.adb *** gcc-4.3.3/gcc/ada/s-pack34.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack34.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack34.ads gcc-4.4.0/gcc/ada/s-pack34.ads *** gcc-4.3.3/gcc/ada/s-pack34.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack34.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack35.adb gcc-4.4.0/gcc/ada/s-pack35.adb *** gcc-4.3.3/gcc/ada/s-pack35.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack35.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack35.ads gcc-4.4.0/gcc/ada/s-pack35.ads *** gcc-4.3.3/gcc/ada/s-pack35.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack35.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack36.adb gcc-4.4.0/gcc/ada/s-pack36.adb *** gcc-4.3.3/gcc/ada/s-pack36.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack36.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack36.ads gcc-4.4.0/gcc/ada/s-pack36.ads *** gcc-4.3.3/gcc/ada/s-pack36.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack36.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack37.adb gcc-4.4.0/gcc/ada/s-pack37.adb *** gcc-4.3.3/gcc/ada/s-pack37.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack37.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack37.ads gcc-4.4.0/gcc/ada/s-pack37.ads *** gcc-4.3.3/gcc/ada/s-pack37.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack37.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack38.adb gcc-4.4.0/gcc/ada/s-pack38.adb *** gcc-4.3.3/gcc/ada/s-pack38.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack38.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack38.ads gcc-4.4.0/gcc/ada/s-pack38.ads *** gcc-4.3.3/gcc/ada/s-pack38.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack38.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack39.adb gcc-4.4.0/gcc/ada/s-pack39.adb *** gcc-4.3.3/gcc/ada/s-pack39.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack39.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack39.ads gcc-4.4.0/gcc/ada/s-pack39.ads *** gcc-4.3.3/gcc/ada/s-pack39.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack39.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack40.adb gcc-4.4.0/gcc/ada/s-pack40.adb *** gcc-4.3.3/gcc/ada/s-pack40.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack40.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack40.ads gcc-4.4.0/gcc/ada/s-pack40.ads *** gcc-4.3.3/gcc/ada/s-pack40.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack40.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack41.adb gcc-4.4.0/gcc/ada/s-pack41.adb *** gcc-4.3.3/gcc/ada/s-pack41.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack41.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack41.ads gcc-4.4.0/gcc/ada/s-pack41.ads *** gcc-4.3.3/gcc/ada/s-pack41.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack41.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack42.adb gcc-4.4.0/gcc/ada/s-pack42.adb *** gcc-4.3.3/gcc/ada/s-pack42.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack42.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack42.ads gcc-4.4.0/gcc/ada/s-pack42.ads *** gcc-4.3.3/gcc/ada/s-pack42.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack42.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack43.adb gcc-4.4.0/gcc/ada/s-pack43.adb *** gcc-4.3.3/gcc/ada/s-pack43.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack43.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack43.ads gcc-4.4.0/gcc/ada/s-pack43.ads *** gcc-4.3.3/gcc/ada/s-pack43.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack43.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack44.adb gcc-4.4.0/gcc/ada/s-pack44.adb *** gcc-4.3.3/gcc/ada/s-pack44.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack44.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack44.ads gcc-4.4.0/gcc/ada/s-pack44.ads *** gcc-4.3.3/gcc/ada/s-pack44.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack44.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack45.adb gcc-4.4.0/gcc/ada/s-pack45.adb *** gcc-4.3.3/gcc/ada/s-pack45.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack45.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack45.ads gcc-4.4.0/gcc/ada/s-pack45.ads *** gcc-4.3.3/gcc/ada/s-pack45.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack45.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack46.adb gcc-4.4.0/gcc/ada/s-pack46.adb *** gcc-4.3.3/gcc/ada/s-pack46.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack46.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack46.ads gcc-4.4.0/gcc/ada/s-pack46.ads *** gcc-4.3.3/gcc/ada/s-pack46.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack46.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack47.adb gcc-4.4.0/gcc/ada/s-pack47.adb *** gcc-4.3.3/gcc/ada/s-pack47.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack47.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack47.ads gcc-4.4.0/gcc/ada/s-pack47.ads *** gcc-4.3.3/gcc/ada/s-pack47.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack47.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack48.adb gcc-4.4.0/gcc/ada/s-pack48.adb *** gcc-4.3.3/gcc/ada/s-pack48.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack48.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack48.ads gcc-4.4.0/gcc/ada/s-pack48.ads *** gcc-4.3.3/gcc/ada/s-pack48.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack48.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack49.adb gcc-4.4.0/gcc/ada/s-pack49.adb *** gcc-4.3.3/gcc/ada/s-pack49.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack49.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack49.ads gcc-4.4.0/gcc/ada/s-pack49.ads *** gcc-4.3.3/gcc/ada/s-pack49.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack49.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack50.adb gcc-4.4.0/gcc/ada/s-pack50.adb *** gcc-4.3.3/gcc/ada/s-pack50.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack50.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack50.ads gcc-4.4.0/gcc/ada/s-pack50.ads *** gcc-4.3.3/gcc/ada/s-pack50.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack50.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack51.adb gcc-4.4.0/gcc/ada/s-pack51.adb *** gcc-4.3.3/gcc/ada/s-pack51.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack51.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack51.ads gcc-4.4.0/gcc/ada/s-pack51.ads *** gcc-4.3.3/gcc/ada/s-pack51.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack51.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack52.adb gcc-4.4.0/gcc/ada/s-pack52.adb *** gcc-4.3.3/gcc/ada/s-pack52.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack52.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack52.ads gcc-4.4.0/gcc/ada/s-pack52.ads *** gcc-4.3.3/gcc/ada/s-pack52.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack52.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack53.adb gcc-4.4.0/gcc/ada/s-pack53.adb *** gcc-4.3.3/gcc/ada/s-pack53.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack53.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack53.ads gcc-4.4.0/gcc/ada/s-pack53.ads *** gcc-4.3.3/gcc/ada/s-pack53.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack53.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack54.adb gcc-4.4.0/gcc/ada/s-pack54.adb *** gcc-4.3.3/gcc/ada/s-pack54.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack54.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack54.ads gcc-4.4.0/gcc/ada/s-pack54.ads *** gcc-4.3.3/gcc/ada/s-pack54.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack54.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack55.adb gcc-4.4.0/gcc/ada/s-pack55.adb *** gcc-4.3.3/gcc/ada/s-pack55.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack55.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack55.ads gcc-4.4.0/gcc/ada/s-pack55.ads *** gcc-4.3.3/gcc/ada/s-pack55.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack55.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack56.adb gcc-4.4.0/gcc/ada/s-pack56.adb *** gcc-4.3.3/gcc/ada/s-pack56.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack56.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack56.ads gcc-4.4.0/gcc/ada/s-pack56.ads *** gcc-4.3.3/gcc/ada/s-pack56.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack56.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack57.adb gcc-4.4.0/gcc/ada/s-pack57.adb *** gcc-4.3.3/gcc/ada/s-pack57.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack57.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack57.ads gcc-4.4.0/gcc/ada/s-pack57.ads *** gcc-4.3.3/gcc/ada/s-pack57.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack57.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack58.adb gcc-4.4.0/gcc/ada/s-pack58.adb *** gcc-4.3.3/gcc/ada/s-pack58.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack58.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack58.ads gcc-4.4.0/gcc/ada/s-pack58.ads *** gcc-4.3.3/gcc/ada/s-pack58.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack58.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack59.adb gcc-4.4.0/gcc/ada/s-pack59.adb *** gcc-4.3.3/gcc/ada/s-pack59.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack59.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack59.ads gcc-4.4.0/gcc/ada/s-pack59.ads *** gcc-4.3.3/gcc/ada/s-pack59.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack59.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack60.adb gcc-4.4.0/gcc/ada/s-pack60.adb *** gcc-4.3.3/gcc/ada/s-pack60.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack60.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack60.ads gcc-4.4.0/gcc/ada/s-pack60.ads *** gcc-4.3.3/gcc/ada/s-pack60.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack60.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack61.adb gcc-4.4.0/gcc/ada/s-pack61.adb *** gcc-4.3.3/gcc/ada/s-pack61.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack61.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack61.ads gcc-4.4.0/gcc/ada/s-pack61.ads *** gcc-4.3.3/gcc/ada/s-pack61.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack61.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack62.adb gcc-4.4.0/gcc/ada/s-pack62.adb *** gcc-4.3.3/gcc/ada/s-pack62.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack62.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack62.ads gcc-4.4.0/gcc/ada/s-pack62.ads *** gcc-4.3.3/gcc/ada/s-pack62.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack62.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack63.adb gcc-4.4.0/gcc/ada/s-pack63.adb *** gcc-4.3.3/gcc/ada/s-pack63.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pack63.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pack63.ads gcc-4.4.0/gcc/ada/s-pack63.ads *** gcc-4.3.3/gcc/ada/s-pack63.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-pack63.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-parame-ae653.ads gcc-4.4.0/gcc/ada/s-parame-ae653.ads *** gcc-4.3.3/gcc/ada/s-parame-ae653.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-parame-ae653.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Parameters is *** 125,131 **** -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are ommitted only for outer level onjects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True --- 123,129 ---- -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are omitted only for outer level objects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True diff -Nrcpad gcc-4.3.3/gcc/ada/s-parame-hpux.ads gcc-4.4.0/gcc/ada/s-parame-hpux.ads *** gcc-4.3.3/gcc/ada/s-parame-hpux.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-parame-hpux.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Parameters is *** 123,129 **** -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are ommitted only for outer level onjects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True --- 121,127 ---- -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are omitted only for outer level objects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True diff -Nrcpad gcc-4.3.3/gcc/ada/s-parame-rtems.adb gcc-4.4.0/gcc/ada/s-parame-rtems.adb *** gcc-4.3.3/gcc/ada/s-parame-rtems.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-parame-rtems.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-1998 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-parame-vms-alpha.ads gcc-4.4.0/gcc/ada/s-parame-vms-alpha.ads *** gcc-4.3.3/gcc/ada/s-parame-vms-alpha.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-parame-vms-alpha.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Parameters is *** 123,129 **** -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are ommitted only for outer level onjects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True --- 121,127 ---- -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are omitted only for outer level objects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True diff -Nrcpad gcc-4.3.3/gcc/ada/s-parame-vms-ia64.ads gcc-4.4.0/gcc/ada/s-parame-vms-ia64.ads *** gcc-4.3.3/gcc/ada/s-parame-vms-ia64.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-parame-vms-ia64.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Parameters is *** 123,129 **** -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are ommitted only for outer level onjects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True --- 121,127 ---- -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are omitted only for outer level objects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True diff -Nrcpad gcc-4.3.3/gcc/ada/s-parame-vms-restrict.ads gcc-4.4.0/gcc/ada/s-parame-vms-restrict.ads *** gcc-4.3.3/gcc/ada/s-parame-vms-restrict.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-parame-vms-restrict.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Parameters is *** 123,129 **** -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are ommitted only for outer level onjects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True --- 121,127 ---- -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are omitted only for outer level objects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True diff -Nrcpad gcc-4.3.3/gcc/ada/s-parame-vxworks.adb gcc-4.4.0/gcc/ada/s-parame-vxworks.adb *** gcc-4.3.3/gcc/ada/s-parame-vxworks.adb Thu Dec 13 10:46:20 2007 --- gcc-4.4.0/gcc/ada/s-parame-vxworks.adb Thu Apr 9 23:23:07 2009 *************** *** 6,37 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- Version used on all VxWorks and Nucleus targets package body System.Parameters is --- 6,35 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- Version used on all VxWorks, Nucleus, and RTX RTSS targets package body System.Parameters is diff -Nrcpad gcc-4.3.3/gcc/ada/s-parame-vxworks.ads gcc-4.4.0/gcc/ada/s-parame-vxworks.ads *** gcc-4.3.3/gcc/ada/s-parame-vxworks.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-parame-vxworks.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Parameters is *** 125,131 **** -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are ommitted only for outer level onjects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True --- 123,129 ---- -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are omitted only for outer level objects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True diff -Nrcpad gcc-4.3.3/gcc/ada/s-parame.adb gcc-4.4.0/gcc/ada/s-parame.adb *** gcc-4.3.3/gcc/ada/s-parame.adb Wed Feb 15 09:32:35 2006 --- gcc-4.4.0/gcc/ada/s-parame.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Parameters is *** 73,80 **** begin -- 12K is required for stack-checking to work reliably on most platforms -- when using the GCC scheme to propagate an exception in the ZCX case. ! return 12 * 1024; end Minimum_Stack_Size; end System.Parameters; --- 71,80 ---- begin -- 12K is required for stack-checking to work reliably on most platforms -- when using the GCC scheme to propagate an exception in the ZCX case. + -- 16K is the value of PTHREAD_STACK_MIN under Linux, so is a reasonable + -- default. ! return 16 * 1024; end Minimum_Stack_Size; end System.Parameters; diff -Nrcpad gcc-4.3.3/gcc/ada/s-parame.ads gcc-4.4.0/gcc/ada/s-parame.ads *** gcc-4.3.3/gcc/ada/s-parame.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-parame.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Parameters is *** 123,129 **** -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are ommitted only for outer level onjects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True --- 121,127 ---- -- The system releases all storage on program termination only, -- but not other garbage collection occurs, so finalization calls ! -- are omitted only for outer level objects can be omitted if -- pragma Finalize_Storage_Only is used. -- Garbage_Collected = True diff -Nrcpad gcc-4.3.3/gcc/ada/s-parint.adb gcc-4.4.0/gcc/ada/s-parint.adb *** gcc-4.3.3/gcc/ada/s-parint.adb Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-parint.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (Dummy body for non-distributed case) -- -- -- ! -- Copyright (C) 1995-2006, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- B o d y -- -- (Dummy body for non-distributed case) -- -- -- ! -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 34,40 **** package body System.Partition_Interface is ! pragma Warnings (Off); -- supress warnings for unreferenced formals M : constant := 7; --- 32,38 ---- package body System.Partition_Interface is ! pragma Warnings (Off); -- suppress warnings for unreferenced formals M : constant := 7; *************** package body System.Partition_Interface *** 215,222 **** (E : Ada.Exceptions.Exception_Occurrence) is begin ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, Ada.Exceptions.Exception_Message (E)); end Raise_Program_Error_Unknown_Tag; ----------------- --- 213,219 ---- (E : Ada.Exceptions.Exception_Occurrence) is begin ! raise Program_Error with Ada.Exceptions.Exception_Message (E); end Raise_Program_Error_Unknown_Tag; ----------------- diff -Nrcpad gcc-4.3.3/gcc/ada/s-parint.ads gcc-4.4.0/gcc/ada/s-parint.ads *** gcc-4.3.3/gcc/ada/s-parint.ads Tue Aug 14 08:50:51 2007 --- gcc-4.4.0/gcc/ada/s-parint.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Partition_Interface is *** 94,100 **** pragma No_Strict_Aliasing (RAS_Proxy_Type_Access); -- This type is used by the expansion to implement distributed objects. -- Do not change its definition or its layout without updating ! -- Exp_Dist.Build_Remote_Supbrogram_Proxy_Type. -- The Request_Access type is used for communication between the PCS -- and the RPC receiver generated by the compiler: it contains all the --- 92,98 ---- pragma No_Strict_Aliasing (RAS_Proxy_Type_Access); -- This type is used by the expansion to implement distributed objects. -- Do not change its definition or its layout without updating ! -- Exp_Dist.Build_Remote_Subprogram_Proxy_Type. -- The Request_Access type is used for communication between the PCS -- and the RPC receiver generated by the compiler: it contains all the *************** package System.Partition_Interface is *** 115,121 **** Version : String; RCI : Boolean := True); -- Use by the main subprogram to check that a remote receiver ! -- unit has has the same version than the caller's one. function Same_Partition (Left : not null access RACW_Stub_Type; --- 113,119 ---- Version : String; RCI : Boolean := True); -- Use by the main subprogram to check that a remote receiver ! -- unit has the same version than the caller's one. function Same_Partition (Left : not null access RACW_Stub_Type; diff -Nrcpad gcc-4.3.3/gcc/ada/s-pooglo.adb gcc-4.4.0/gcc/ada/s-pooglo.adb *** gcc-4.3.3/gcc/ada/s-pooglo.adb Wed Feb 15 09:29:17 2006 --- gcc-4.4.0/gcc/ada/s-pooglo.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pooglo.ads gcc-4.4.0/gcc/ada/s-pooglo.ads *** gcc-4.3.3/gcc/ada/s-pooglo.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-pooglo.ads Thu Apr 9 23:23:07 2009 *************** *** 6,36 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with System; with System.Storage_Pools; with System.Storage_Elements; --- 6,37 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ + -- Storage pool corresponding to default global storage pool used for + -- types for which no storage pool is specified. + with System; with System.Storage_Pools; with System.Storage_Elements; diff -Nrcpad gcc-4.3.3/gcc/ada/s-pooloc.adb gcc-4.4.0/gcc/ada/s-pooloc.adb *** gcc-4.3.3/gcc/ada/s-pooloc.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-pooloc.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-pooloc.ads gcc-4.4.0/gcc/ada/s-pooloc.ads *** gcc-4.3.3/gcc/ada/s-pooloc.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-pooloc.ads Thu Apr 9 23:23:07 2009 *************** *** 6,36 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with System.Storage_Elements; with System.Pool_Global; --- 6,36 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ + -- Storage pool for use with local objects with automatic reclaim + with System.Storage_Elements; with System.Pool_Global; diff -Nrcpad gcc-4.3.3/gcc/ada/s-poosiz.adb gcc-4.4.0/gcc/ada/s-poosiz.adb *** gcc-4.3.3/gcc/ada/s-poosiz.adb Wed Dec 19 16:22:02 2007 --- gcc-4.4.0/gcc/ada/s-poosiz.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Pool_Size is *** 59,65 **** -- Embedded pool that manages allocation of variable-size data ! -- This pool is used as soon as the Elmt_sizS of the pool object is 0 -- Allocation is done on the first chunk long enough for the request. -- Deallocation just puts the freed chunk at the beginning of the list. --- 57,63 ---- -- Embedded pool that manages allocation of variable-size data ! -- This pool is used as soon as the Elmt_Size of the pool object is 0 -- Allocation is done on the first chunk long enough for the request. -- Deallocation just puts the freed chunk at the beginning of the list. *************** package body System.Pool_Size is *** 261,267 **** raise Storage_Error; end if; ! -- When the chunk is bigger than what is needed, take appropraite -- amount and build a new shrinked chunk with the remainder. if Size (Pool, Chunk) - Align_Size > Minimum_Size then --- 259,265 ---- raise Storage_Error; end if; ! -- When the chunk is bigger than what is needed, take appropriate -- amount and build a new shrinked chunk with the remainder. if Size (Pool, Chunk) - Align_Size > Minimum_Size then diff -Nrcpad gcc-4.3.3/gcc/ada/s-poosiz.ads gcc-4.4.0/gcc/ada/s-poosiz.ads *** gcc-4.3.3/gcc/ada/s-poosiz.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-poosiz.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-powtab.ads gcc-4.4.0/gcc/ada/s-powtab.ads *** gcc-4.3.3/gcc/ada/s-powtab.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-powtab.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-proinf-irix-athread.adb gcc-4.4.0/gcc/ada/s-proinf-irix-athread.adb *** gcc-4.3.3/gcc/ada/s-proinf-irix-athread.adb Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/s-proinf-irix-athread.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-proinf-irix-athread.ads gcc-4.4.0/gcc/ada/s-proinf-irix-athread.ads *** gcc-4.3.3/gcc/ada/s-proinf-irix-athread.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-proinf-irix-athread.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Program_Info is *** 46,52 **** -- those explicitly created under program control. function Sproc_Stack_Size return Integer; ! -- The size, in bytes, of the sproc's initial stack. function Default_Time_Slice return Duration; -- The default time quanta for round-robin scheduling of threads of --- 44,50 ---- -- those explicitly created under program control. function Sproc_Stack_Size return Integer; ! -- The size, in bytes, of the sproc's initial stack function Default_Time_Slice return Duration; -- The default time quanta for round-robin scheduling of threads of *************** package System.Program_Info is *** 56,62 **** function Default_Task_Stack return Integer; -- The default stack size for each created thread. This default value can ! -- be overriden on a per-task basis by the language-defined Storage_Size -- pragma. function Stack_Guard_Pages return Integer; --- 54,60 ---- function Default_Task_Stack return Integer; -- The default stack size for each created thread. This default value can ! -- be overridden on a per-task basis by the language-defined Storage_Size -- pragma. function Stack_Guard_Pages return Integer; diff -Nrcpad gcc-4.3.3/gcc/ada/s-proinf.adb gcc-4.4.0/gcc/ada/s-proinf.adb *** gcc-4.3.3/gcc/ada/s-proinf.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-proinf.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-proinf.ads gcc-4.4.0/gcc/ada/s-proinf.ads *** gcc-4.3.3/gcc/ada/s-proinf.ads Mon Sep 5 07:46:06 2005 --- gcc-4.4.0/gcc/ada/s-proinf.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Program_Info is *** 39,45 **** function Default_Task_Stack return Integer; -- The default stack size for each created thread. This default value ! -- can be overriden on a per-task basis by the language-defined -- Storage_Size pragma. end System.Program_Info; --- 37,43 ---- function Default_Task_Stack return Integer; -- The default stack size for each created thread. This default value ! -- can be overridden on a per-task basis by the language-defined -- Storage_Size pragma. end System.Program_Info; diff -Nrcpad gcc-4.3.3/gcc/ada/s-purexc.ads gcc-4.4.0/gcc/ada/s-purexc.ads *** gcc-4.3.3/gcc/ada/s-purexc.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-purexc.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-rannum.adb gcc-4.4.0/gcc/ada/s-rannum.adb *** gcc-4.3.3/gcc/ada/s-rannum.adb Tue Aug 14 08:48:27 2007 --- gcc-4.4.0/gcc/ada/s-rannum.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007,2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-rannum.ads gcc-4.4.0/gcc/ada/s-rannum.ads *** gcc-4.3.3/gcc/ada/s-rannum.ads Tue Aug 14 08:48:27 2007 --- gcc-4.4.0/gcc/ada/s-rannum.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007,2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-regexp.adb gcc-4.4.0/gcc/ada/s-regexp.adb *** gcc-4.3.3/gcc/ada/s-regexp.adb Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/s-regexp.adb Wed Aug 20 13:55:20 2008 *************** *** 2,12 **** -- -- -- GNAT COMPILER COMPONENTS -- -- -- ! -- G N A T . R E G E X P -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- 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- -- --- 2,12 ---- -- -- -- GNAT COMPILER COMPONENTS -- -- -- ! -- S Y S T E M . R E G E X P -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- 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- -- *************** *** 32,38 **** ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; ! with Ada.Exceptions; with System.Case_Util; --- 32,38 ---- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; ! -- with Ada.Exceptions; with System.Case_Util; *************** package body System.Regexp is *** 140,146 **** Num_States : out State_Index; Start_State : out State_Index; End_State : out State_Index); ! -- Creates the first version of the regexp (this is a non determinist -- finite state machine, which is unadapted for a fast pattern -- matching algorithm). We use a recursive algorithm to process the -- parenthesis sub-expressions. --- 140,146 ---- Num_States : out State_Index; Start_State : out State_Index; End_State : out State_Index); ! -- Creates the first version of the regexp (this is a non deterministic -- finite state machine, which is unadapted for a fast pattern -- matching algorithm). We use a recursive algorithm to process the -- parenthesis sub-expressions. *************** package body System.Regexp is *** 177,185 **** -- add a third pass to reduce the number of states in the machine, with -- no speed improvement... ! procedure Raise_Exception ! (M : String; ! Index : Integer); pragma No_Return (Raise_Exception); -- Raise an exception, indicating an error at character Index in S --- 177,183 ---- -- add a third pass to reduce the number of states in the machine, with -- no speed improvement... ! procedure Raise_Exception (M : String; Index : Integer); pragma No_Return (Raise_Exception); -- Raise an exception, indicating an error at character Index in S *************** package body System.Regexp is *** 1139,1145 **** end loop; end Closure; ! -- Start of procesing for Create_Secondary_Table begin -- Create a new state --- 1137,1143 ---- end loop; end Closure; ! -- Start of processing for Create_Secondary_Table begin -- Create a new state *************** package body System.Regexp is *** 1223,1235 **** -- Raise_Exception -- --------------------- ! procedure Raise_Exception ! (M : String; ! Index : Integer) ! is begin ! Ada.Exceptions.Raise_Exception ! (Error_In_Regexp'Identity, M & " at offset " & Index'Img); end Raise_Exception; -- Start of processing for Compile --- 1221,1229 ---- -- Raise_Exception -- --------------------- ! procedure Raise_Exception (M : String; Index : Integer) is begin ! raise Error_In_Regexp with M & " at offset " & Index'Img; end Raise_Exception; -- Start of processing for Compile diff -Nrcpad gcc-4.3.3/gcc/ada/s-regexp.ads gcc-4.4.0/gcc/ada/s-regexp.ads *** gcc-4.3.3/gcc/ada/s-regexp.ads Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/s-regexp.ads Thu Jul 31 10:26:12 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2008, AdaCore -- -- -- -- 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- -- *************** package System.Regexp is *** 109,115 **** Glob : Boolean := False; Case_Sensitive : Boolean := True) return Regexp; -- Compiles a regular expression S. If the syntax of the given ! -- expression is invalid (does not match above grammar, Error_In_Regexp -- is raised. If Glob is True, the pattern is considered as a 'globbing -- pattern', that is a pattern as given by the second grammar above. -- As a special case, if Pattern is the empty string it will always --- 109,115 ---- Glob : Boolean := False; Case_Sensitive : Boolean := True) return Regexp; -- Compiles a regular expression S. If the syntax of the given ! -- expression is invalid (does not match above grammar), Error_In_Regexp -- is raised. If Glob is True, the pattern is considered as a 'globbing -- pattern', that is a pattern as given by the second grammar above. -- As a special case, if Pattern is the empty string it will always diff -Nrcpad gcc-4.3.3/gcc/ada/s-regpat.adb gcc-4.4.0/gcc/ada/s-regpat.adb *** gcc-4.3.3/gcc/ada/s-regpat.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/s-regpat.adb Thu Apr 10 21:44:46 2008 *************** *** 7,13 **** -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- ! -- Copyright (C) 1999-2007, AdaCore -- -- -- -- 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- -- --- 7,13 ---- -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- ! -- Copyright (C) 1999-2008, AdaCore -- -- -- -- 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- -- *************** package body System.Regpat is *** 136,145 **** -- Matches after or before a word BOL, -- no Match "" at beginning of line ! MBOL, -- no Same, assuming mutiline (match after \n) SBOL, -- no Same, assuming single line (don't match at \n) EOL, -- no Match "" at end of line ! MEOL, -- no Same, assuming mutiline (match before \n) SEOL, -- no Same, assuming single line (don't match at \n) BOUND, -- no Match "" at any word boundary --- 136,145 ---- -- Matches after or before a word BOL, -- no Match "" at beginning of line ! MBOL, -- no Same, assuming multiline (match after \n) SBOL, -- no Same, assuming single line (don't match at \n) EOL, -- no Match "" at end of line ! MEOL, -- no Same, assuming multiline (match before \n) SEOL, -- no Same, assuming single line (don't match at \n) BOUND, -- no Match "" at any word boundary *************** package body System.Regpat is *** 386,392 **** function Emit_Node (Op : Opcode) return Pointer; -- If code-generation is enabled, Emit_Node outputs the -- opcode Op and reserves space for a pointer to the next node. ! -- Return value is the location of new opcode, ie old Emit_Ptr. procedure Emit_Natural (IP : Pointer; N : Natural); -- Split N on two characters at position IP --- 386,392 ---- function Emit_Node (Op : Opcode) return Pointer; -- If code-generation is enabled, Emit_Node outputs the -- opcode Op and reserves space for a pointer to the next node. ! -- Return value is the location of new opcode, i.e. old Emit_Ptr. procedure Emit_Natural (IP : Pointer; N : Natural); -- Split N on two characters at position IP *************** package body System.Regpat is *** 449,455 **** -- Link_Tail sets the next-pointer at the end of a node chain procedure Link_Operand_Tail (P, Val : Pointer); ! -- Link_Tail on operand of first argument; nop if operandless function Next_Instruction (P : Pointer) return Pointer; -- Dig the "next" pointer out of a node --- 449,455 ---- -- Link_Tail sets the next-pointer at the end of a node chain procedure Link_Operand_Tail (P, Val : Pointer); ! -- Link_Tail on operand of first argument; noop if operand-less function Next_Instruction (P : Pointer) return Pointer; -- Dig the "next" pointer out of a node *************** package body System.Regpat is *** 460,466 **** function Is_Curly_Operator (IP : Natural) return Boolean; -- Return True if IP is looking at a '{' that is the beginning ! -- of a curly operator, ie it matches {\d+,?\d*} function Is_Mult (IP : Natural) return Boolean; -- Return True if C is a regexp multiplier: '+', '*' or '?' --- 460,466 ---- function Is_Curly_Operator (IP : Natural) return Boolean; -- Return True if IP is looking at a '{' that is the beginning ! -- of a curly operator, i.e. it matches {\d+,?\d*} function Is_Mult (IP : Natural) return Boolean; -- Return True if C is a regexp multiplier: '+', '*' or '?' *************** package body System.Regpat is *** 484,491 **** -- Parse_Literal encodes a string of characters to be matched exactly function Parse_Posix_Character_Class return Std_Class; ! -- Parse a posic character class, like [:alpha:] or [:^alpha:]. ! -- The called is suppoed to absorbe the opening [. pragma Inline (Is_Mult); pragma Inline (Emit_Natural); --- 484,491 ---- -- Parse_Literal encodes a string of characters to be matched exactly function Parse_Posix_Character_Class return Std_Class; ! -- Parse a posix character class, like [:alpha:] or [:^alpha:]. ! -- The caller is supposed to absorb the opening [. pragma Inline (Is_Mult); pragma Inline (Emit_Natural); *************** package body System.Regpat is *** 1195,1201 **** In_Range : Boolean := False; Named_Class : Std_Class := ANYOF_NONE; Value : Character; ! Last_Value : Character := ASCII.Nul; begin Reset_Class (Bitmap); --- 1195,1201 ---- In_Range : Boolean := False; Named_Class : Std_Class := ANYOF_NONE; Value : Character; ! Last_Value : Character := ASCII.NUL; begin Reset_Class (Bitmap); *************** package body System.Regpat is *** 2192,2198 **** when ANYOF => null; declare Bitmap : Character_Class; ! Last : Character := ASCII.Nul; Current : Natural := 0; Current_Char : Character; --- 2192,2198 ---- when ANYOF => null; declare Bitmap : Character_Class; ! Last : Character := ASCII.NUL; Current : Natural := 0; Current_Char : Character; *************** package body System.Regpat is *** 2858,2864 **** Next : Pointer; Greedy : Boolean) return Boolean is ! Next_Char : Character := ASCII.Nul; Next_Char_Known : Boolean := False; No : Integer; -- Can be negative Min : Natural; --- 2858,2864 ---- Next : Pointer; Greedy : Boolean) return Boolean is ! Next_Char : Character := ASCII.NUL; Next_Char_Known : Boolean := False; No : Integer; -- Can be negative Min : Natural; diff -Nrcpad gcc-4.3.3/gcc/ada/s-regpat.ads gcc-4.4.0/gcc/ada/s-regpat.ads *** gcc-4.3.3/gcc/ada/s-regpat.ads Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/s-regpat.ads Sun Sep 14 06:21:12 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1986 by University of Toronto. -- ! -- Copyright (C) 1996-2007, AdaCore -- -- -- -- 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1986 by University of Toronto. -- ! -- Copyright (C) 1996-2008, AdaCore -- -- -- -- 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- -- *************** package System.Regpat is *** 404,410 **** Expression : String; Final_Code_Size : out Program_Size; Flags : Regexp_Flags := No_Flags); ! -- Compile a regular expression into into internal code -- This procedure is significantly faster than the Compile function since -- it avoids the extra step of precomputing the required size. --- 404,410 ---- Expression : String; Final_Code_Size : out Program_Size; Flags : Regexp_Flags := No_Flags); ! -- Compile a regular expression into internal code -- This procedure is significantly faster than the Compile function since -- it avoids the extra step of precomputing the required size. *************** package System.Regpat is *** 414,420 **** -- approach, in addition to the improved efficiency, is that the same -- Pattern_Matcher variable can be used to hold the compiled code for -- several different regular expressions by setting a size that is large ! -- enough to accomodate all possibilities. -- -- In this version of the procedure call, the actual required code size is -- returned. Also if Matcher.Size is zero on entry, then the resulting code --- 414,420 ---- -- approach, in addition to the improved efficiency, is that the same -- Pattern_Matcher variable can be used to hold the compiled code for -- several different regular expressions by setting a size that is large ! -- enough to accommodate all possibilities. -- -- In this version of the procedure call, the actual required code size is -- returned. Also if Matcher.Size is zero on entry, then the resulting code *************** private *** 604,610 **** -- compile to execute that permits the execute phase to run lots faster on -- simple cases. They are: ! -- First character that must begin a match or ASCII.Nul -- Anchored true iff match must start at beginning of line -- Must_Have pointer to string that match must include or null -- Must_Have_Length length of Must_Have string --- 604,610 ---- -- compile to execute that permits the execute phase to run lots faster on -- simple cases. They are: ! -- First character that must begin a match or ASCII.NUL -- Anchored true iff match must start at beginning of line -- Must_Have pointer to string that match must include or null -- Must_Have_Length length of Must_Have string *************** private *** 621,627 **** -- The initialization is meant to fail-safe in case the user of this -- package tries to use an uninitialized matcher. This takes advantage ! -- of the knowledge that ASCII.Nul translates to the end-of-program (EOP) -- instruction code of the state machine. No_Flags : constant Regexp_Flags := 0; --- 621,627 ---- -- The initialization is meant to fail-safe in case the user of this -- package tries to use an uninitialized matcher. This takes advantage ! -- of the knowledge that ASCII.NUL translates to the end-of-program (EOP) -- instruction code of the state machine. No_Flags : constant Regexp_Flags := 0; diff -Nrcpad gcc-4.3.3/gcc/ada/s-restri.adb gcc-4.4.0/gcc/ada/s-restri.adb *** gcc-4.3.3/gcc/ada/s-restri.adb Tue Oct 31 18:11:19 2006 --- gcc-4.4.0/gcc/ada/s-restri.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-restri.ads gcc-4.4.0/gcc/ada/s-restri.ads *** gcc-4.3.3/gcc/ada/s-restri.ads Wed Jun 6 10:52:32 2007 --- gcc-4.4.0/gcc/ada/s-restri.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-rident.ads gcc-4.4.0/gcc/ada/s-rident.ads *** gcc-4.3.3/gcc/ada/s-rident.ads Fri Apr 6 09:14:55 2007 --- gcc-4.4.0/gcc/ada/s-rident.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Rident is *** 50,62 **** -- The following enumeration type defines the set of restriction -- identifiers that are implemented in GNAT. ! -- To add a new restriction identifier, add an entry with the name ! -- to be used in the pragma, and add appropriate calls to the ! -- Restrict.Check_Restriction routine. type Restriction_Id is ! -- The following cases are checked for consistency in the binder (Simple_Barriers, -- GNAT (Ravenscar) No_Abort_Statements, -- (RM D.7(5), H.4(3)) --- 48,62 ---- -- The following enumeration type defines the set of restriction -- identifiers that are implemented in GNAT. ! -- To add a new restriction identifier, add an entry with the name to be ! -- used in the pragma, and add calls to the Restrict.Check_Restriction ! -- routine as appropriate. type Restriction_Id is ! -- The following cases are checked for consistency in the binder. The ! -- binder will check that every unit either has the restriction set, or ! -- does not violate the restriction. (Simple_Barriers, -- GNAT (Ravenscar) No_Abort_Statements, -- (RM D.7(5), H.4(3)) *************** package System.Rident is *** 87,92 **** --- 87,93 ---- No_Implicit_Loops, -- GNAT No_Initialize_Scalars, -- GNAT No_Local_Allocators, -- (RM H.4(8)) + No_Local_Timing_Events, -- (RM D.7(10.2/2)) No_Local_Protected_Objects, -- GNAT No_Nested_Finalization, -- (RM D.7(4)) No_Protected_Type_Allocators, -- GNAT *************** package System.Rident is *** 97,103 **** --- 98,106 ---- No_Requeue_Statements, -- GNAT No_Secondary_Stack, -- GNAT No_Select_Statements, -- GNAT (Ravenscar) + No_Specific_Termination_Handlers, -- (RM D.7(10.7/2)) No_Standard_Storage_Pools, -- GNAT + No_Stream_Optimizations, -- GNAT No_Streams, -- GNAT No_Task_Allocators, -- (RM D.7(7)) No_Task_Attributes_Package, -- GNAT *************** package System.Rident is *** 111,117 **** Static_Priorities, -- GNAT Static_Storage_Size, -- GNAT ! -- The following cases do not require partition-wide checks Immediate_Reclamation, -- (RM H.4(10)) No_Implementation_Attributes, -- Ada 2005 AI-257 --- 114,125 ---- Static_Priorities, -- GNAT Static_Storage_Size, -- GNAT ! -- The following require consistency checking with special rules. See ! -- individual routines in unit Bcheck for details of what is required. ! ! No_Default_Initialization, -- GNAT ! ! -- The following cases do not require consistency checking Immediate_Reclamation, -- (RM H.4(10)) No_Implementation_Attributes, -- Ada 2005 AI-257 *************** package System.Rident is *** 123,151 **** -- The following cases require a parameter value ! -- The following entries are fully checked at compile/bind time, ! -- which means that the compiler can in general tell the minimum ! -- value which could be used with a restrictions pragma. The binder ! -- can deduce the appropriate minimum value for the partition by ! -- taking the maximum value required by any unit. Max_Protected_Entries, -- (RM D.7(14)) Max_Select_Alternatives, -- (RM D.7(12)) Max_Task_Entries, -- (RM D.7(13), H.4(3)) ! -- The following entries are also fully checked at compile/bind ! -- time, and the compiler can also at least in some cases tell ! -- the minimum value which could be used with a restriction pragma. ! -- The difference is that the contributions are additive, so the ! -- binder deduces this value by adding the unit contributions. Max_Tasks, -- (RM D.7(19), H.4(3)) ! -- The following entries are checked at compile time only for ! -- zero/nonzero entries. This means that the compiler can tell ! -- at compile time if a restriction value of zero is (would be) ! -- violated, but that is all. The compiler cannot distinguish ! -- between different non-zero values. Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3)) Max_Entry_Queue_Length, -- GNAT --- 131,158 ---- -- The following cases require a parameter value ! -- The following entries are fully checked at compile/bind time, which ! -- means that the compiler can in general tell the minimum value which ! -- could be used with a restrictions pragma. The binder can deduce the ! -- appropriate minimum value for the partition by taking the maximum ! -- value required by any unit. Max_Protected_Entries, -- (RM D.7(14)) Max_Select_Alternatives, -- (RM D.7(12)) Max_Task_Entries, -- (RM D.7(13), H.4(3)) ! -- The following entries are also fully checked at compile/bind time, ! -- and the compiler can also at least in some cases tell the minimum ! -- value which could be used with a restriction pragma. The difference ! -- is that the contributions are additive, so the binder deduces this ! -- value by adding the unit contributions. Max_Tasks, -- (RM D.7(19), H.4(3)) ! -- The following entries are checked at compile time only for zero/ ! -- nonzero entries. This means that the compiler can tell at compile ! -- time if a restriction value of zero is (would be) violated, but that ! -- the compiler cannot distinguish between different non-zero values. Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3)) Max_Entry_Queue_Length, -- GNAT *************** package System.Rident is *** 185,196 **** -- Boolean restrictions that are not checked for partition consistency -- and that thus apply only to the current unit. Note that for these -- restrictions, the compiler does not apply restrictions found in ! -- with'ed units, parent specs etc to the main unit. subtype All_Parameter_Restrictions is Restriction_Id range Max_Protected_Entries .. Max_Storage_At_Blocking; ! -- All restrictions that are take a parameter subtype Checked_Parameter_Restrictions is All_Parameter_Restrictions range --- 192,203 ---- -- Boolean restrictions that are not checked for partition consistency -- and that thus apply only to the current unit. Note that for these -- restrictions, the compiler does not apply restrictions found in ! -- with'ed units, parent specs etc. to the main unit. subtype All_Parameter_Restrictions is Restriction_Id range Max_Protected_Entries .. Max_Storage_At_Blocking; ! -- All restrictions that take a parameter subtype Checked_Parameter_Restrictions is All_Parameter_Restrictions range *************** package System.Rident is *** 216,223 **** subtype Checked_Val_Parameter_Restrictions is Checked_Parameter_Restrictions range Max_Protected_Entries .. Max_Tasks; ! -- Restrictions with parameter where the count is known at least in ! -- some cases by the compiler/binder. subtype Checked_Zero_Parameter_Restrictions is Checked_Parameter_Restrictions range --- 223,230 ---- subtype Checked_Val_Parameter_Restrictions is Checked_Parameter_Restrictions range Max_Protected_Entries .. Max_Tasks; ! -- Restrictions with parameter where the count is known at least in some ! -- cases by the compiler/binder. subtype Checked_Zero_Parameter_Restrictions is Checked_Parameter_Restrictions range *************** package System.Rident is *** 237,245 **** -- Restriction Status Declarations -- ------------------------------------- ! -- The following declarations are used to record the current status ! -- or restrictions (for the current unit, or related units, at compile ! -- time, and for all units in a partition at bind time or run time). type Restriction_Flags is array (All_Restrictions) of Boolean; type Restriction_Values is array (All_Parameter_Restrictions) of Natural; --- 244,252 ---- -- Restriction Status Declarations -- ------------------------------------- ! -- The following declarations are used to record the current status or ! -- restrictions (for the current unit, or related units, at compile time, ! -- and for all units in a partition at bind time or run time). type Restriction_Flags is array (All_Restrictions) of Boolean; type Restriction_Values is array (All_Parameter_Restrictions) of Natural; *************** package System.Rident is *** 247,257 **** type Restrictions_Info is record Set : Restriction_Flags; ! -- An entry is True in the Set array if a restrictions pragma has ! -- been encountered for the given restriction. If the value is ! -- True for a parameter restriction, then the corresponding entry ! -- in the Value array gives the minimum value encountered for any ! -- such restriction. Value : Restriction_Values; -- If the entry for a parameter restriction in Set is True (i.e. a --- 254,263 ---- type Restrictions_Info is record Set : Restriction_Flags; ! -- An entry is True in the Set array if a restrictions pragma has been ! -- encountered for the given restriction. If the value is True for a ! -- parameter restriction, then the corresponding entry in the Value ! -- array gives the minimum value encountered for any such restriction. Value : Restriction_Values; -- If the entry for a parameter restriction in Set is True (i.e. a *************** package System.Rident is *** 261,281 **** -- pragma specifying a value greater than Int'Last is simply ignored. Violated : Restriction_Flags; ! -- An entry is True in the violations array if the compiler has ! -- detected a violation of the restriction. For a parameter ! -- restriction, the Count and Unknown arrays have additional ! -- information. Count : Restriction_Values; ! -- If an entry for a parameter restriction is True in Violated, ! -- the corresponding entry in the Count array may record additional -- information. If the actual minimum count is known (by taking -- maximums, or sums, depending on the restriction), it will be -- recorded in this array. If not, then the value will remain zero. Unknown : Parameter_Flags; ! -- If an entry for a parameter restriction is True in Violated, ! -- the corresponding entry in the Unknown array may record additional -- information. If the actual count is not known by the compiler (but -- is known to be non-zero), then the entry in Unknown will be True. -- This indicates that the value in Count is not known to be exact, --- 267,287 ---- -- pragma specifying a value greater than Int'Last is simply ignored. Violated : Restriction_Flags; ! -- An entry is True in the violations array if the compiler has detected ! -- a violation of the restriction. For a parameter restriction, the ! -- Count and Unknown arrays have additional information. Count : Restriction_Values; ! -- If an entry for a parameter restriction is True in Violated, the ! -- corresponding entry in the Count array may record additional -- information. If the actual minimum count is known (by taking -- maximums, or sums, depending on the restriction), it will be -- recorded in this array. If not, then the value will remain zero. + -- The value is also zero for a non-violated restriction. Unknown : Parameter_Flags; ! -- If an entry for a parameter restriction is True in Violated, the ! -- corresponding entry in the Unknown array may record additional -- information. If the actual count is not known by the compiler (but -- is known to be non-zero), then the entry in Unknown will be True. -- This indicates that the value in Count is not known to be exact, *************** package System.Rident is *** 299,322 **** -- Profile Definitions and Data -- ---------------------------------- ! type Profile_Name is (Ravenscar, Restricted); ! -- Names of recognized pfofiles type Profile_Data is record Set : Restriction_Flags; ! -- Set to True if given restriction must be set for the profile, ! -- and False if it need not be set (False does not mean that it ! -- must not be set, just that it need not be set). If the flag ! -- is True for a parameter restriction, then the Value array ! -- gives the maximum value permitted by the profile. Value : Restriction_Values; ! -- An entry in this array is meaningful only if the corresponding ! -- flag in Set is True. In that case, the value in this array is ! -- the maximum value of the parameter permitted by the profile. end record; ! Profile_Info : array (Profile_Name) of Profile_Data := -- Restricted Profile --- 305,333 ---- -- Profile Definitions and Data -- ---------------------------------- ! type Profile_Name is (No_Profile, Ravenscar, Restricted); ! -- Names of recognized profiles. No_Profile is used to indicate that a ! -- restriction came from pragma Restrictions[_Warning], as opposed to ! -- pragma Profile[_Warning]. ! ! subtype Profile_Name_Actual is Profile_Name range Ravenscar .. Restricted; ! -- Actual used profile names type Profile_Data is record Set : Restriction_Flags; ! -- Set to True if given restriction must be set for the profile, and ! -- False if it need not be set (False does not mean that it must not be ! -- set, just that it need not be set). If the flag is True for a ! -- parameter restriction, then the Value array gives the maximum value ! -- permitted by the profile. Value : Restriction_Values; ! -- An entry in this array is meaningful only if the corresponding flag ! -- in Set is True. In that case, the value in this array is the maximum ! -- value of the parameter permitted by the profile. end record; ! Profile_Info : array (Profile_Name_Actual) of Profile_Data := -- Restricted Profile diff -Nrcpad gcc-4.3.3/gcc/ada/s-rpc.adb gcc-4.4.0/gcc/ada/s-rpc.adb *** gcc-4.3.3/gcc/ada/s-rpc.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-rpc.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 39,46 **** -- The GLADE distribution package includes a replacement for this file - with Ada.Exceptions; use Ada.Exceptions; - package body System.RPC is CRLF : constant String := ASCII.CR & ASCII.LF; --- 37,42 ---- *************** package body System.RPC is *** 49,57 **** CRLF & "Distribution support not installed in your environment" & CRLF & "For information on GLADE, contact Ada Core Technologies"; - pragma Warnings (Off); - -- Kill messages about out parameters not set - ---------- -- Read -- ---------- --- 45,50 ---- *************** package body System.RPC is *** 62,68 **** Last : out Ada.Streams.Stream_Element_Offset) is begin ! Raise_Exception (Program_Error'Identity, Msg); end Read; ----------- --- 55,61 ---- Last : out Ada.Streams.Stream_Element_Offset) is begin ! raise Program_Error with Msg; end Read; ----------- *************** package body System.RPC is *** 74,80 **** Item : Ada.Streams.Stream_Element_Array) is begin ! Raise_Exception (Program_Error'Identity, Msg); end Write; ------------ --- 67,73 ---- Item : Ada.Streams.Stream_Element_Array) is begin ! raise Program_Error with Msg; end Write; ------------ *************** package body System.RPC is *** 87,93 **** Result : access Params_Stream_Type) is begin ! Raise_Exception (Program_Error'Identity, Msg); end Do_RPC; ------------ --- 80,86 ---- Result : access Params_Stream_Type) is begin ! raise Program_Error with Msg; end Do_RPC; ------------ *************** package body System.RPC is *** 99,105 **** Params : access Params_Stream_Type) is begin ! Raise_Exception (Program_Error'Identity, Msg); end Do_APC; ---------------------------- --- 92,98 ---- Params : access Params_Stream_Type) is begin ! raise Program_Error with Msg; end Do_APC; ---------------------------- *************** package body System.RPC is *** 110,115 **** --- 103,109 ---- (Partition : Partition_ID; Receiver : RPC_Receiver) is + pragma Unreferenced (Partition, Receiver); begin null; end Establish_RPC_Receiver; diff -Nrcpad gcc-4.3.3/gcc/ada/s-rpc.ads gcc-4.4.0/gcc/ada/s-rpc.ads *** gcc-4.3.3/gcc/ada/s-rpc.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-rpc.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-scaval.adb gcc-4.4.0/gcc/ada/s-scaval.adb *** gcc-4.3.3/gcc/ada/s-scaval.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-scaval.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-scaval.ads gcc-4.4.0/gcc/ada/s-scaval.ads *** gcc-4.3.3/gcc/ada/s-scaval.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-scaval.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-secsta.adb gcc-4.4.0/gcc/ada/s-secsta.adb *** gcc-4.3.3/gcc/ada/s-secsta.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-secsta.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Secondary_Stack is *** 135,141 **** -- For the static case, the secondary stack is a single contiguous -- chunk of storage, carved out of the primary stack, and represented ! -- by the following data strcuture type Fixed_Stack_Id is record Top : SS_Ptr; --- 133,139 ---- -- For the static case, the secondary stack is a single contiguous -- chunk of storage, carved out of the primary stack, and represented ! -- by the following data structure type Fixed_Stack_Id is record Top : SS_Ptr; *************** package body System.Secondary_Stack is *** 237,243 **** end loop; -- Find out if the available memory in the current chunk is ! -- sufficient, if not, go to the next one and eventally create -- the necessary room. while Chunk.Last - Stack.Top + 1 < Max_Size loop --- 235,241 ---- end loop; -- Find out if the available memory in the current chunk is ! -- sufficient, if not, go to the next one and eventually create -- the necessary room. while Chunk.Last - Stack.Top + 1 < Max_Size loop diff -Nrcpad gcc-4.3.3/gcc/ada/s-secsta.ads gcc-4.4.0/gcc/ada/s-secsta.ads *** gcc-4.3.3/gcc/ada/s-secsta.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-secsta.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-sequio.adb gcc-4.4.0/gcc/ada/s-sequio.adb *** gcc-4.3.3/gcc/ada/s-sequio.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-sequio.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-sequio.ads gcc-4.4.0/gcc/ada/s-sequio.ads *** gcc-4.3.3/gcc/ada/s-sequio.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-sequio.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 32,38 **** ------------------------------------------------------------------------------ -- This package contains the declaration of the control block used for ! -- Seqential_IO. This must be declared at the outer library level. It also -- contains code that is shared between instances of Sequential_IO. with System.File_Control_Block; --- 30,36 ---- ------------------------------------------------------------------------------ -- This package contains the declaration of the control block used for ! -- Sequential_IO. This must be declared at the outer library level. It also -- contains code that is shared between instances of Sequential_IO. with System.File_Control_Block; diff -Nrcpad gcc-4.3.3/gcc/ada/s-shasto.adb gcc-4.4.0/gcc/ada/s-shasto.adb *** gcc-4.3.3/gcc/ada/s-shasto.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-shasto.adb Thu Apr 9 23:23:07 2009 *************** *** 6,39 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ - with Ada.Exceptions; with Ada.IO_Exceptions; with Ada.Streams; with System.Global_Locks; with System.Soft_Links; --- 6,37 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Ada.IO_Exceptions; with Ada.Streams; + with Ada.Streams.Stream_IO; with System.Global_Locks; with System.Soft_Links; *************** package body System.Shared_Storage is *** 56,61 **** --- 54,61 ---- package SFI renames System.File_IO; + package SIO renames Ada.Streams.Stream_IO; + type String_Access is access String; procedure Free is new Ada.Unchecked_Deallocation (Object => String, Name => String_Access); *************** package body System.Shared_Storage is *** 169,174 **** --- 169,194 ---- -- created entry is returned, after first moving it to the head of -- the LRU chain. If not, then null is returned. + function Shared_Var_ROpen (Var : String) return SIO.Stream_Access; + -- As described above, this routine returns null if the + -- corresponding shared storage does not exist, and otherwise, if + -- the storage does exist, a Stream_Access value that references + -- the shared storage, ready to read the current value. + + function Shared_Var_WOpen (Var : String) return SIO.Stream_Access; + -- As described above, this routine returns a Stream_Access value + -- that references the shared storage, ready to write the new + -- value. The storage is created by this call if it does not + -- already exist. + + procedure Shared_Var_Close (Var : SIO.Stream_Access); + -- This routine signals the end of a read/assign operation. It can + -- be useful to embrace a read/write operation between a call to + -- open and a call to close which protect the whole operation. + -- Otherwise, two simultaneous operations can result in the + -- raising of exception Data_Error by setting the access mode of + -- the variable in an incorrect mode. + --------------- -- Enter_SFE -- --------------- *************** package body System.Shared_Storage is *** 365,370 **** --- 385,427 ---- end Shared_Var_Lock; ---------------------- + -- Shared_Var_Procs -- + ---------------------- + + package body Shared_Var_Procs is + + use type SIO.Stream_Access; + + ---------- + -- Read -- + ---------- + + procedure Read is + S : SIO.Stream_Access := null; + begin + S := Shared_Var_ROpen (Full_Name); + if S /= null then + Typ'Read (S, V); + Shared_Var_Close (S); + end if; + end Read; + + ------------ + -- Write -- + ------------ + + procedure Write is + S : SIO.Stream_Access := null; + begin + S := Shared_Var_WOpen (Full_Name); + Typ'Write (S, V); + Shared_Var_Close (S); + return; + end Write; + + end Shared_Var_Procs; + + ---------------------- -- Shared_Var_ROpen -- ---------------------- *************** package body System.Shared_Storage is *** 483,492 **** -- Error if we cannot create the file when others => ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, ! "Cannot create shared variable file for """ & ! S & '"'); -- " end; end; --- 540,547 ---- -- Error if we cannot create the file when others => ! raise Program_Error with ! "Cannot create shared variable file for """ & S & '"'; end; end; diff -Nrcpad gcc-4.3.3/gcc/ada/s-shasto.ads gcc-4.4.0/gcc/ada/s-shasto.ads *** gcc-4.3.3/gcc/ada/s-shasto.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-shasto.ads Thu Apr 9 23:23:07 2009 *************** *** 6,37 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package manages the shared/persistant storage required for -- full implementation of variables in Shared_Passive packages, more -- precisely variables whose enclosing dynamic scope is a shared -- passive package. This implementation is specific to GNAT and GLADE --- 6,35 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package manages the shared/persistent storage required for -- full implementation of variables in Shared_Passive packages, more -- precisely variables whose enclosing dynamic scope is a shared -- passive package. This implementation is specific to GNAT and GLADE *************** *** 79,141 **** -- The approach is as follows: ! -- For each shared variable, var, an access routine varR is created whose ! -- body has the following form (this example is for Pkg.Var): ! ! -- procedure varR is ! -- S : Ada.Streams.Stream_IO.Stream_Access; ! -- begin ! -- S := Shared_Var_ROpen ("pkg.var"); ! -- if S /= null then ! -- typ'Read (S); ! -- Shared_Var_Close (S); ! -- end if; ! -- end varR; ! ! -- The routine Shared_Var_ROpen in package System.Shared_Storage ! -- either returns null if the storage does not exist, or otherwise a ! -- Stream_Access value that references the corresponding shared ! -- storage, ready to read the current value. ! ! -- Each reference to the shared variable, var, is preceded by a ! -- call to the corresponding varR procedure, which either leaves the ! -- initial value unchanged if the storage does not exist, or reads ! -- the current value from the shared storage. ! ! -- In addition, for each shared variable, var, an assignment routine ! -- is created whose body has the following form (again for Pkg.Var) ! ! -- procedure VarA is ! -- S : Ada.Streams.Stream_IO.Stream_Access; ! -- begin ! -- S := Shared_Var_WOpen ("pkg.var"); ! -- typ'Write (S, var); ! -- Shared_Var_Close (S); ! -- end VarA; ! ! -- The routine Shared_Var_WOpen in package System.Shared_Storage ! -- returns a Stream_Access value that references the corresponding ! -- shared storage, ready to write the new value. ! ! -- Each assignment to the shared variable, var, is followed by a call ! -- to the corresponding varA procedure, which writes the new value to ! -- the shared storage. ! -- Note that there is no general synchronization for these storage ! -- read and write operations, since it is assumed that a correctly ! -- operating programs will provide appropriate synchronization. In ! -- particular, variables can be protected using protected types with ! -- no entries. ! -- The routine Shared_Var_Close is called to indicate the end of a ! -- read/write operations. This can be useful even in the context of ! -- the GNAT implementation. For instance, when a read operation and a ! -- write operation occur at the same time on the same partition, as ! -- the same stream is used simultaneously, both operations can ! -- terminate abruptly by raising exception Mode_Error because the ! -- stream has been opened in read mode and then in write mode and at ! -- least used by the read opartion. To avoid this unexpected ! -- behaviour, we introduce a synchronization at the partition level. -- Note: a special circuit allows the use of stream attributes Read and -- Write for limited types (using the corresponding attribute for the --- 77,95 ---- -- The approach is as follows: ! -- For each shared variable, var, an instantiation of the below generic ! -- package is created which provides Read and Write supporting procedures. ! -- The routine Read in package System.Shared_Storage.Shared_Var_Procs ! -- ensures to assign variable V to the last written value among processes ! -- referencing it. A call to this procedure is generated by the expander ! -- before each read access to the shared variable. ! -- The routine Write in package System.Shared_Storage.Shared_Var_Proc ! -- set a new value to the shared variable and, according to the used ! -- implementation, propagate this value among processes referencing it. ! -- A call to this procedure is generated by the expander after each ! -- assignment of the shared variable. -- Note: a special circuit allows the use of stream attributes Read and -- Write for limited types (using the corresponding attribute for the *************** *** 180,211 **** -- These calls to the read and assign routines, as well as the lock -- and unlock routines, are inserted by the expander (see exp_smem.adb). - with Ada.Streams.Stream_IO; - package System.Shared_Storage is - package SIO renames Ada.Streams.Stream_IO; - - function Shared_Var_ROpen (Var : String) return SIO.Stream_Access; - -- As described above, this routine returns null if the - -- corresponding shared storage does not exist, and otherwise, if - -- the storage does exist, a Stream_Access value that references - -- the shared storage, ready to read the current value. - - function Shared_Var_WOpen (Var : String) return SIO.Stream_Access; - -- As described above, this routine returns a Stream_Access value - -- that references the shared storage, ready to write the new - -- value. The storage is created by this call if it does not - -- already exist. - - procedure Shared_Var_Close (Var : SIO.Stream_Access); - -- This routine signals the end of a read/assign operation. It can - -- be useful to embrace a read/write operation between a call to - -- open and a call to close which protect the whole operation. - -- Otherwise, two simultaneous operations can result in the - -- raising of exception Data_Error by setting the access mode of - -- the variable in an incorrect mode. - procedure Shared_Var_Lock (Var : String); -- This procedure claims the shared storage lock. It is used for -- protected types in shared passive packages. A call to this --- 134,141 ---- *************** package System.Shared_Storage is *** 214,222 **** -- the lock is busy. procedure Shared_Var_Unlock (Var : String); ! -- This procedure releases the shared storage lock obtaind by a ! -- prior call to the Shared_Mem_Lock procedure, and is to be -- generated as the last operation in the body of a protected -- subprogram. end System.Shared_Storage; --- 144,183 ---- -- the lock is busy. procedure Shared_Var_Unlock (Var : String); ! -- This procedure releases the shared storage lock obtained by a ! -- prior call to the Shared_Var_Lock procedure, and is to be -- generated as the last operation in the body of a protected -- subprogram. + -- This generic package is instantiated for each shared passive + -- variable. It provides supporting procedures called upon each + -- read or write access by the expanded code. + + generic + + type Typ is limited private; + -- Shared passive variable type + + V : in out Typ; + -- Shared passive variable + + Full_Name : String; + -- Shared passive variable storage name + + package Shared_Var_Procs is + + procedure Read; + -- Shared passive variable access routine. Each reference to the + -- shared variable, V, is preceded by a call to the corresponding + -- Read procedure, which either leaves the initial value unchanged + -- if the storage does not exist, or reads the current value from + -- the shared storage. + + procedure Write; + -- Shared passive variable assignment routine. Each assignment to + -- the shared variable, V, is followed by a call to the corresponding + -- Write procedure, which writes the new value to the shared storage. + + end Shared_Var_Procs; + end System.Shared_Storage; diff -Nrcpad gcc-4.3.3/gcc/ada/s-soflin.adb gcc-4.4.0/gcc/ada/s-soflin.adb *** gcc-4.3.3/gcc/ada/s-soflin.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-soflin.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** pragma Compiler_Unit; *** 36,50 **** pragma Warnings (On); pragma Polling (Off); ! -- We must turn polling off for this unit, because otherwise we get ! -- an infinite loop from the code within the Poll routine itself. with System.Parameters; - -- Used for Sec_Stack_Ratio pragma Warnings (Off); ! -- Disable warnings since System.Secondary_Stack is currently not ! -- Preelaborate with System.Secondary_Stack; pragma Warnings (On); --- 34,46 ---- pragma Warnings (On); pragma Polling (Off); ! -- We must turn polling off for this unit, because otherwise we get an ! -- infinite loop from the code within the Poll routine itself. with System.Parameters; pragma Warnings (Off); ! -- Disable warnings since System.Secondary_Stack is currently not Preelaborate with System.Secondary_Stack; pragma Warnings (On); diff -Nrcpad gcc-4.3.3/gcc/ada/s-soflin.ads gcc-4.4.0/gcc/ada/s-soflin.ads *** gcc-4.3.3/gcc/ada/s-soflin.ads Thu Dec 13 10:34:11 2007 --- gcc-4.4.0/gcc/ada/s-soflin.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Soft_Links is *** 107,113 **** function return String; pragma Favor_Top_Level (Task_Name_Call); ! -- Suppress checks on all these types, since we know the corrresponding -- values can never be null (the soft links are always initialized). pragma Suppress (Access_Check, No_Param_Proc); --- 105,111 ---- function return String; pragma Favor_Top_Level (Task_Name_Call); ! -- Suppress checks on all these types, since we know the corresponding -- values can never be null (the soft links are always initialized). pragma Suppress (Access_Check, No_Param_Proc); *************** package System.Soft_Links is *** 381,384 **** --- 379,403 ---- function Get_Exc_Stack_Addr_Soft return Address; + -- The following is a dummy record designed to mimic Communication_Block as + -- defined in s-tpobop.ads: + + -- type Communication_Block is record + -- Self : Task_Id; -- An access type + -- Enqueued : Boolean := True; + -- Cancelled : Boolean := False; + -- end record; + + -- The record is used in the construction of the predefined dispatching + -- primitive _disp_asynchronous_select in order to avoid the import of + -- System.Tasking.Protected_Objects.Operations. Note that this package + -- is always imported in the presence of interfaces since the dispatch + -- table uses entities from here. + + type Dummy_Communication_Block is record + Comp_1 : Address; -- Address and access have the same size + Comp_2 : Boolean; + Comp_3 : Boolean; + end record; + end System.Soft_Links; diff -Nrcpad gcc-4.3.3/gcc/ada/s-solita.adb gcc-4.4.0/gcc/ada/s-solita.adb *** gcc-4.3.3/gcc/ada/s-solita.adb Tue Aug 14 08:49:56 2007 --- gcc-4.4.0/gcc/ada/s-solita.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 32,62 **** ------------------------------------------------------------------------------ pragma Style_Checks (All_Checks); ! -- Turn off subprogram alpha ordering check, since we group soft link ! -- bodies and dummy soft link bodies together separately in this unit. pragma Polling (Off); ! -- Turn polling off for this package. We don't need polling during any ! -- of the routines in this package, and more to the point, if we try ! -- to poll it can cause infinite loops. ! with System.Task_Primitives.Operations; ! -- Used for Self ! -- Timed_Delay with System.Tasking; - -- Used for Task_Id - -- Cause_Of_Termination - with System.Stack_Checking; - -- Used for Stack_Access - - with Ada.Exceptions; - -- Used for Exception_Id - -- Exception_Occurrence - -- Save_Occurrence - - with Ada.Exceptions.Is_Null_Occurrence; package body System.Soft_Links.Tasking is --- 30,49 ---- ------------------------------------------------------------------------------ pragma Style_Checks (All_Checks); ! -- Turn off subprogram alpha ordering check, since we group soft link bodies ! -- and dummy soft link bodies together separately in this unit. pragma Polling (Off); ! -- Turn polling off for this package. We don't need polling during any of the ! -- routines in this package, and more to the point, if we try to poll it can ! -- cause infinite loops. ! with Ada.Exceptions; ! with Ada.Exceptions.Is_Null_Occurrence; + with System.Task_Primitives.Operations; with System.Tasking; with System.Stack_Checking; package body System.Soft_Links.Tasking is diff -Nrcpad gcc-4.3.3/gcc/ada/s-solita.ads gcc-4.4.0/gcc/ada/s-solita.ads *** gcc-4.3.3/gcc/ada/s-solita.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-solita.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-sopco3.adb gcc-4.4.0/gcc/ada/s-sopco3.adb *** gcc-4.3.3/gcc/ada/s-sopco3.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-sopco3.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.String_Ops_Concat_3 *** 43,49 **** function Str_Concat_3 (S1, S2, S3 : String) return String is begin ! if S1'Length <= 0 then return S2 & S3; else --- 41,47 ---- function Str_Concat_3 (S1, S2, S3 : String) return String is begin ! if S1'Length = 0 then return S2 & S3; else diff -Nrcpad gcc-4.3.3/gcc/ada/s-sopco3.ads gcc-4.4.0/gcc/ada/s-sopco3.ads *** gcc-4.3.3/gcc/ada/s-sopco3.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-sopco3.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-sopco4.adb gcc-4.4.0/gcc/ada/s-sopco4.adb *** gcc-4.3.3/gcc/ada/s-sopco4.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-sopco4.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.String_Ops_Concat_4 *** 43,49 **** function Str_Concat_4 (S1, S2, S3, S4 : String) return String is begin ! if S1'Length <= 0 then return S2 & S3 & S4; else --- 41,47 ---- function Str_Concat_4 (S1, S2, S3, S4 : String) return String is begin ! if S1'Length = 0 then return S2 & S3 & S4; else diff -Nrcpad gcc-4.3.3/gcc/ada/s-sopco4.ads gcc-4.4.0/gcc/ada/s-sopco4.ads *** gcc-4.3.3/gcc/ada/s-sopco4.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-sopco4.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-sopco5.adb gcc-4.4.0/gcc/ada/s-sopco5.adb *** gcc-4.3.3/gcc/ada/s-sopco5.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-sopco5.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.String_Ops_Concat_5 *** 43,49 **** function Str_Concat_5 (S1, S2, S3, S4, S5 : String) return String is begin ! if S1'Length <= 0 then return S2 & S3 & S4 & S5; else --- 41,47 ---- function Str_Concat_5 (S1, S2, S3, S4, S5 : String) return String is begin ! if S1'Length = 0 then return S2 & S3 & S4 & S5; else diff -Nrcpad gcc-4.3.3/gcc/ada/s-sopco5.ads gcc-4.4.0/gcc/ada/s-sopco5.ads *** gcc-4.3.3/gcc/ada/s-sopco5.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-sopco5.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-stache.adb gcc-4.4.0/gcc/ada/s-stache.adb *** gcc-4.3.3/gcc/ada/s-stache.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-stache.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-stache.ads gcc-4.4.0/gcc/ada/s-stache.ads *** gcc-4.3.3/gcc/ada/s-stache.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-stache.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-stalib.adb gcc-4.4.0/gcc/ada/s-stalib.adb *** gcc-4.3.3/gcc/ada/s-stalib.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-stalib.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** with System.Soft_Links; *** 51,57 **** -- Referenced directly from generated code using external symbols so it -- must always be present in a build, even if no unit has a direct with -- of this unit. Also referenced from exception handling routines. ! -- This is needed for programs that don't use exceptions explicitely but -- direct calls to Ada.Exceptions are generated by gigi (for example, -- by calling __gnat_raise_constraint_error directly). --- 49,55 ---- -- Referenced directly from generated code using external symbols so it -- must always be present in a build, even if no unit has a direct with -- of this unit. Also referenced from exception handling routines. ! -- This is needed for programs that don't use exceptions explicitly but -- direct calls to Ada.Exceptions are generated by gigi (for example, -- by calling __gnat_raise_constraint_error directly). diff -Nrcpad gcc-4.3.3/gcc/ada/s-stalib.ads gcc-4.4.0/gcc/ada/s-stalib.ads *** gcc-4.3.3/gcc/ada/s-stalib.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-stalib.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Standard_Library is *** 63,68 **** --- 61,67 ---- pragma Warnings (On); type Big_String_Ptr is access all String (Positive); + for Big_String_Ptr'Storage_Size use 0; -- A non-fat pointer type for null terminated strings function To_Ptr is *************** package System.Standard_Library is *** 115,121 **** -- The following record defines the underlying representation of exceptions ! -- WARNING! Any changes to this may need to be reflectd in the following -- locations in the compiler and runtime code: -- 1. The Internal_Exception routine in s-exctab.adb --- 114,120 ---- -- The following record defines the underlying representation of exceptions ! -- WARNING! Any changes to this may need to be reflected in the following -- locations in the compiler and runtime code: -- 1. The Internal_Exception routine in s-exctab.adb *************** package System.Standard_Library is *** 164,170 **** -- Definitions for standard predefined exceptions defined in Standard, ! -- Why are the Nul's necessary here, seems like they should not be -- required, since Gigi is supposed to add a Nul to each name ??? Constraint_Error_Name : constant String := "CONSTRAINT_ERROR" & ASCII.NUL; --- 163,169 ---- -- Definitions for standard predefined exceptions defined in Standard, ! -- Why are the NULs necessary here, seems like they should not be -- required, since Gigi is supposed to add a Nul to each name ??? Constraint_Error_Name : constant String := "CONSTRAINT_ERROR" & ASCII.NUL; diff -Nrcpad gcc-4.3.3/gcc/ada/s-stausa.adb gcc-4.4.0/gcc/ada/s-stausa.adb *** gcc-4.3.3/gcc/ada/s-stausa.adb Thu Dec 13 10:34:35 2007 --- gcc-4.4.0/gcc/ada/s-stausa.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package body System.Stack_Usage is *** 205,214 **** Result_Array := new Result_Array_Type (1 .. Buffer_Size); Result_Array.all := (others => ! (Task_Name => (others => ASCII.NUL), ! Measure => 0, ! Max_Size => 0, ! Overflow_Guard => 0)); -- Set the Is_Enabled flag to true, so that the task wrapper knows that -- it has to handle dynamic stack analysis --- 203,212 ---- Result_Array := new Result_Array_Type (1 .. Buffer_Size); Result_Array.all := (others => ! (Task_Name => (others => ASCII.NUL), ! Min_Measure => 0, ! Max_Measure => 0, ! Max_Size => 0)); -- Set the Is_Enabled flag to true, so that the task wrapper knows that -- it has to handle dynamic stack analysis *************** package body System.Stack_Usage is *** 219,225 **** -- If variable GNAT_STACK_LIMIT is set, then we will take care of the -- environment task, using GNAT_STASK_LIMIT as the size of the stack. ! -- It doens't make sens to process the stack when no bound is set (e.g. -- limit is typically up to 4 GB). if Stack_Size_Chars /= Null_Address then --- 217,223 ---- -- If variable GNAT_STACK_LIMIT is set, then we will take care of the -- environment task, using GNAT_STASK_LIMIT as the size of the stack. ! -- It doesn't make sens to process the stack when no bound is set (e.g. -- limit is typically up to 4 GB). if Stack_Size_Chars /= Null_Address then *************** package body System.Stack_Usage is *** 233,239 **** (Environment_Task_Analyzer, "ENVIRONMENT TASK", Stack_Size, ! 0, System.Storage_Elements.To_Integer (Bottom_Of_Stack'Address)); Fill_Stack (Environment_Task_Analyzer); --- 231,237 ---- (Environment_Task_Analyzer, "ENVIRONMENT TASK", Stack_Size, ! Stack_Size, System.Storage_Elements.To_Integer (Bottom_Of_Stack'Address)); Fill_Stack (Environment_Task_Analyzer); *************** package body System.Stack_Usage is *** 253,284 **** ---------------- procedure Fill_Stack (Analyzer : in out Stack_Analyzer) is - -- Change the local variables and parameters of this function with -- super-extra care. The more the stack frame size of this function is -- big, the more an "instrumentation threshold at writing" error is -- likely to happen. ! Stack : aliased Stack_Slots (1 .. Analyzer.Size / Bytes_Per_Pattern); begin ! Stack := (others => Analyzer.Pattern); ! Analyzer.Stack_Overlay_Address := Stack'Address; ! Analyzer.Bottom_Pattern_Mark := ! To_Stack_Address (Stack (Bottom_Slot_Index_In (Stack))'Address); ! Analyzer.Top_Pattern_Mark := ! To_Stack_Address (Stack (Top_Slot_Index_In (Stack))'Address); ! -- If Arr has been packed, the following assertion must be true (we add ! -- the size of the element whose address is: ! -- Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)): ! pragma Assert ! (Analyzer.Size = ! Stack_Size ! (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Pattern_Mark)); end Fill_Stack; ------------------------- --- 251,314 ---- ---------------- procedure Fill_Stack (Analyzer : in out Stack_Analyzer) is -- Change the local variables and parameters of this function with -- super-extra care. The more the stack frame size of this function is -- big, the more an "instrumentation threshold at writing" error is -- likely to happen. ! Stack_Used_When_Filling : Integer; ! Current_Stack_Level : aliased Integer; begin ! -- Readjust the pattern size. When we arrive in this function, there is ! -- already a given amount of stack used, that we won't analyze. ! Stack_Used_When_Filling := ! Stack_Size ! (Analyzer.Bottom_Of_Stack, ! To_Stack_Address (Current_Stack_Level'Address)) ! + Natural (Current_Stack_Level'Size); ! if Stack_Used_When_Filling > Analyzer.Pattern_Size then ! -- In this case, the known size of the stack is too small, we've ! -- already taken more than expected, so there's no possible ! -- computation ! Analyzer.Pattern_Size := 0; ! else ! Analyzer.Pattern_Size := ! Analyzer.Pattern_Size - Stack_Used_When_Filling; ! end if; ! declare ! Stack : aliased Stack_Slots ! (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); ! ! begin ! Stack := (others => Analyzer.Pattern); ! ! Analyzer.Stack_Overlay_Address := Stack'Address; ! ! if Analyzer.Pattern_Size /= 0 then ! Analyzer.Bottom_Pattern_Mark := ! To_Stack_Address (Stack (Bottom_Slot_Index_In (Stack))'Address); ! Analyzer.Top_Pattern_Mark := ! To_Stack_Address (Stack (Top_Slot_Index_In (Stack))'Address); ! else ! Analyzer.Bottom_Pattern_Mark := To_Stack_Address (Stack'Address); ! Analyzer.Top_Pattern_Mark := To_Stack_Address (Stack'Address); ! end if; ! ! -- If Arr has been packed, the following assertion must be true (we ! -- add the size of the element whose address is: ! -- Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)): ! ! pragma Assert ! (Analyzer.Pattern_Size = 0 or else ! Analyzer.Pattern_Size = ! Stack_Size ! (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Pattern_Mark)); ! end; end Fill_Stack; ------------------------- *************** package body System.Stack_Usage is *** 286,310 **** ------------------------- procedure Initialize_Analyzer ! (Analyzer : in out Stack_Analyzer; ! Task_Name : String; ! Size : Natural; ! Overflow_Guard : Natural; ! Bottom : Stack_Address; ! Pattern : Unsigned_32 := 16#DEAD_BEEF#) is begin -- Initialize the analyzer fields Analyzer.Bottom_Of_Stack := Bottom; ! Analyzer.Size := Size; Analyzer.Pattern := Pattern; Analyzer.Result_Id := Next_Id; Analyzer.Task_Name := (others => ' '); ! -- Compute the task name, and truncate it if it's bigger than ! -- Task_Name_Length if Task_Name'Length <= Task_Name_Length then Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name; --- 316,340 ---- ------------------------- procedure Initialize_Analyzer ! (Analyzer : in out Stack_Analyzer; ! Task_Name : String; ! Stack_Size : Natural; ! Max_Pattern_Size : Natural; ! Bottom : Stack_Address; ! Pattern : Unsigned_32 := 16#DEAD_BEEF#) is begin -- Initialize the analyzer fields Analyzer.Bottom_Of_Stack := Bottom; ! Analyzer.Stack_Size := Stack_Size; ! Analyzer.Pattern_Size := Max_Pattern_Size; Analyzer.Pattern := Pattern; Analyzer.Result_Id := Next_Id; Analyzer.Task_Name := (others => ' '); ! -- Compute the task name, and truncate if bigger than Task_Name_Length if Task_Name'Length <= Task_Name_Length then Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name; *************** package body System.Stack_Usage is *** 314,321 **** Task_Name'First + Task_Name_Length - 1); end if; - Analyzer.Overflow_Guard := Overflow_Guard; - Next_Id := Next_Id + 1; end Initialize_Analyzer; --- 344,349 ---- *************** package body System.Stack_Usage is *** 346,357 **** -- is, the more an "instrumentation threshold at reading" error is -- likely to happen. ! Stack : Stack_Slots (1 .. Analyzer.Size / Bytes_Per_Pattern); for Stack'Address use Analyzer.Stack_Overlay_Address; begin Analyzer.Topmost_Touched_Mark := Analyzer.Bottom_Pattern_Mark; -- Look backward from the topmost possible end of the marked stack to -- the bottom of it. The first index not equals to the patterns marks -- the beginning of the used stack. --- 374,389 ---- -- is, the more an "instrumentation threshold at reading" error is -- likely to happen. ! Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); for Stack'Address use Analyzer.Stack_Overlay_Address; begin Analyzer.Topmost_Touched_Mark := Analyzer.Bottom_Pattern_Mark; + if Analyzer.Pattern_Size = 0 then + return; + end if; + -- Look backward from the topmost possible end of the marked stack to -- the bottom of it. The first index not equals to the patterns marks -- the beginning of the used stack. *************** package body System.Stack_Usage is *** 382,391 **** --------------------- function Get_Usage_Range (Result : Task_Result) return String is ! Min_Used_Str : constant String := ! Natural'Image (Result.Measure); ! Max_Used_Str : constant String := ! Natural'Image (Result.Measure + Result.Overflow_Guard); begin return "[" & Min_Used_Str (2 .. Min_Used_Str'Last) & " -" & Max_Used_Str & "]"; --- 414,421 ---- --------------------- function Get_Usage_Range (Result : Task_Result) return String is ! Min_Used_Str : constant String := Natural'Image (Result.Min_Measure); ! Max_Used_Str : constant String := Natural'Image (Result.Max_Measure); begin return "[" & Min_Used_Str (2 .. Min_Used_Str'Last) & " -" & Max_Used_Str & "]"; *************** package body System.Stack_Usage is *** 458,465 **** for J in Result_Array'Range loop exit when J >= Next_Id; ! if Result_Array (J).Measure ! > Result_Array (Max_Actual_Use_Result_Id).Measure then Max_Actual_Use_Result_Id := J; end if; --- 488,495 ---- for J in Result_Array'Range loop exit when J >= Next_Id; ! if Result_Array (J).Max_Measure ! > Result_Array (Max_Actual_Use_Result_Id).Max_Measure then Max_Actual_Use_Result_Id := J; end if; *************** package body System.Stack_Usage is *** 526,542 **** ------------------- procedure Report_Result (Analyzer : Stack_Analyzer) is ! Result : constant Task_Result := ! (Task_Name => Analyzer.Task_Name, ! Max_Size => Analyzer.Size + Analyzer.Overflow_Guard, ! Measure => Stack_Size ! (Analyzer.Topmost_Touched_Mark, ! Analyzer.Bottom_Of_Stack), ! Overflow_Guard => Analyzer.Overflow_Guard - ! Natural (Analyzer.Bottom_Of_Stack - ! Analyzer.Bottom_Pattern_Mark)); begin if Analyzer.Result_Id in Result_Array'Range then -- If the result can be stored, then store it in Result_Array --- 556,586 ---- ------------------- procedure Report_Result (Analyzer : Stack_Analyzer) is ! Result : Task_Result := ! (Task_Name => Analyzer.Task_Name, ! Max_Size => Analyzer.Stack_Size, ! Min_Measure => 0, ! Max_Measure => 0); ! ! Overflow_Guard : constant Integer := ! Analyzer.Stack_Size ! - Stack_Size (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Of_Stack); begin + if Analyzer.Pattern_Size = 0 then + -- If we have that result, it means that we didn't do any computation + -- at all. In other words, we used at least everything (and possibly + -- more). + + Result.Min_Measure := Analyzer.Stack_Size - Overflow_Guard; + Result.Max_Measure := Analyzer.Stack_Size; + else + Result.Min_Measure := Stack_Size + (Analyzer.Topmost_Touched_Mark, + Analyzer.Bottom_Of_Stack); + Result.Max_Measure := Result.Min_Measure + Overflow_Guard; + end if; + if Analyzer.Result_Id in Result_Array'Range then -- If the result can be stored, then store it in Result_Array *************** package body System.Stack_Usage is *** 550,556 **** Result_Str_Len : constant Natural := Get_Usage_Range (Result)'Length; Size_Str_Len : constant Natural := ! Natural'Image (Analyzer.Size)'Length; Max_Stack_Size_Len : Natural; Max_Actual_Use_Len : Natural; --- 594,600 ---- Result_Str_Len : constant Natural := Get_Usage_Range (Result)'Length; Size_Str_Len : constant Natural := ! Natural'Image (Analyzer.Stack_Size)'Length; Max_Stack_Size_Len : Natural; Max_Actual_Use_Len : Natural; diff -Nrcpad gcc-4.3.3/gcc/ada/s-stausa.ads gcc-4.4.0/gcc/ada/s-stausa.ads *** gcc-4.3.3/gcc/ada/s-stausa.ads Thu Dec 13 10:34:35 2007 --- gcc-4.4.0/gcc/ada/s-stausa.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package System.Stack_Usage is *** 41,50 **** package SSE renames System.Storage_Elements; - -- The alignment clause seems dubious, what about architectures where - -- the maximum alignment is less than 4??? - -- Anyway, why not use Interfaces.Unsigned_32??? - subtype Stack_Address is SSE.Integer_Address; -- Address on the stack --- 39,44 ---- *************** package System.Stack_Usage is *** 53,61 **** renames System.Storage_Elements.To_Integer; type Stack_Analyzer is private; ! -- Type of the stack analyzer tool. It is used to fill a portion of ! -- the stack with Pattern, and to compute the stack used after some ! -- execution. -- Usage: --- 47,54 ---- renames System.Storage_Elements.To_Integer; type Stack_Analyzer is private; ! -- Type of the stack analyzer tool. It is used to fill a portion of the ! -- stack with Pattern, and to compute the stack used after some execution. -- Usage: *************** package System.Stack_Usage is *** 90,98 **** -- Errors: -- -- We are instrumenting the code to measure the stack used by the user ! -- code. This method has a number of systematic errors, but several ! -- methods can be used to evaluate or reduce those errors. Here are ! -- those errors and the strategy that we use to deal with them: -- Bottom offset: --- 83,91 ---- -- Errors: -- -- We are instrumenting the code to measure the stack used by the user ! -- code. This method has a number of systematic errors, but several methods ! -- can be used to evaluate or reduce those errors. Here are those errors ! -- and the strategy that we use to deal with them: -- Bottom offset: *************** package System.Stack_Usage is *** 112,118 **** -- appear as used in the final measure. -- Strategy: As the user passes the value of the bottom of stack to ! -- the instrumentation to deal with the bottom offset error, and as as -- the instrumentation procedure knows where the pattern filling start -- on the stack, the difference between the two values is the minimum -- stack usage that the method can measure. If, when the results are --- 105,111 ---- -- appear as used in the final measure. -- Strategy: As the user passes the value of the bottom of stack to ! -- the instrumentation to deal with the bottom offset error, and as -- the instrumentation procedure knows where the pattern filling start -- on the stack, the difference between the two values is the minimum -- stack usage that the method can measure. If, when the results are *************** package System.Stack_Usage is *** 127,133 **** -- this point, it will increase the measured stack size. -- Strategy: We could augment this stack frame and see if it changes the ! -- measure. However, this error should be negligeable. -- Pattern zone overflow: --- 120,126 ---- -- this point, it will increase the measured stack size. -- Strategy: We could augment this stack frame and see if it changes the ! -- measure. However, this error should be negligible. -- Pattern zone overflow: *************** package System.Stack_Usage is *** 164,171 **** -- Description: The pattern zone does not fit on the stack. This may -- lead to an erroneous execution. ! -- Strategy: Specify a storage size that is bigger than the size of the ! -- pattern. 2 times bigger should be enough. -- Augmentation of the user stack frames: --- 157,164 ---- -- Description: The pattern zone does not fit on the stack. This may -- lead to an erroneous execution. ! -- Strategy: Specify a storage size that is bigger than the size of the ! -- pattern. 2 times bigger should be enough. -- Augmentation of the user stack frames: *************** package System.Stack_Usage is *** 211,231 **** -- Analyzer.Top_Pattern_Mark procedure Initialize_Analyzer ! (Analyzer : in out Stack_Analyzer; ! Task_Name : String; ! Size : Natural; ! Overflow_Guard : Natural; ! Bottom : Stack_Address; ! Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#); -- Should be called before any use of a Stack_Analyzer, to initialize it. ! -- Size is the size of the pattern zone. Bottom should be a close ! -- approximation of the caller base frame address. Is_Enabled : Boolean := False; -- When this flag is true, then stack analysis is enabled procedure Compute_Result (Analyzer : in out Stack_Analyzer); ! -- Read the patern zone and deduce the stack usage. It should be called -- from the same frame as Fill_Stack. If Analyzer.Probe is not null, an -- array of Unsigned_32 with Analyzer.Probe elements is allocated on -- Compute_Result's stack frame. Probe can be used to detect the error: --- 204,227 ---- -- Analyzer.Top_Pattern_Mark procedure Initialize_Analyzer ! (Analyzer : in out Stack_Analyzer; ! Task_Name : String; ! Stack_Size : Natural; ! Max_Pattern_Size : Natural; ! Bottom : Stack_Address; ! Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#); -- Should be called before any use of a Stack_Analyzer, to initialize it. ! -- Max_Pattern_Size is the size of the pattern zone, might be smaller than ! -- the full stack size in order to take into account e.g. the secondary ! -- stack and a guard against overflow. The actual size taken will be ! -- readjusted with data already used at the time the stack is actually ! -- filled. Is_Enabled : Boolean := False; -- When this flag is true, then stack analysis is enabled procedure Compute_Result (Analyzer : in out Stack_Analyzer); ! -- Read the pattern zone and deduce the stack usage. It should be called -- from the same frame as Fill_Stack. If Analyzer.Probe is not null, an -- array of Unsigned_32 with Analyzer.Probe elements is allocated on -- Compute_Result's stack frame. Probe can be used to detect the error: *************** package System.Stack_Usage is *** 249,255 **** procedure Report_Result (Analyzer : Stack_Analyzer); -- Store the results of the computation in memory, at the address -- corresponding to the symbol __gnat_stack_usage_results. This is not ! -- done inside Compute_Resuls in order to use as less stack as possible -- within a task. procedure Output_Results; --- 245,251 ---- procedure Report_Result (Analyzer : Stack_Analyzer); -- Store the results of the computation in memory, at the address -- corresponding to the symbol __gnat_stack_usage_results. This is not ! -- done inside Compute_Result in order to use as less stack as possible -- within a task. procedure Output_Results; *************** private *** 274,287 **** Task_Name : String (1 .. Task_Name_Length); -- Name of the task ! Size : Natural; -- Size of the pattern zone Pattern : Pattern_Type; -- Pattern used to recognize untouched memory Bottom_Pattern_Mark : Stack_Address; ! -- Bound of the pattern area on the stack clostest to the bottom Top_Pattern_Mark : Stack_Address; -- Topmost bound of the pattern area on the stack --- 270,286 ---- Task_Name : String (1 .. Task_Name_Length); -- Name of the task ! Stack_Size : Natural; ! -- Entire size of the analyzed stack ! ! Pattern_Size : Natural; -- Size of the pattern zone Pattern : Pattern_Type; -- Pattern used to recognize untouched memory Bottom_Pattern_Mark : Stack_Address; ! -- Bound of the pattern area on the stack closest to the bottom Top_Pattern_Mark : Stack_Address; -- Topmost bound of the pattern area on the stack *************** private *** 303,312 **** Result_Id : Positive; -- Id of the result. If less than value given to gnatbind -u corresponds -- to the location in the result array of result for the current task. - - Overflow_Guard : Natural; - -- The amount of bytes that won't be analyzed in order to prevent - -- writing out of the stack end record; Environment_Task_Analyzer : Stack_Analyzer; --- 302,307 ---- *************** private *** 314,323 **** Compute_Environment_Task : Boolean; type Task_Result is record ! Task_Name : String (1 .. Task_Name_Length); ! Measure : Natural; ! Max_Size : Natural; ! Overflow_Guard : Natural; end record; type Result_Array_Type is array (Positive range <>) of Task_Result; --- 309,324 ---- Compute_Environment_Task : Boolean; type Task_Result is record ! Task_Name : String (1 .. Task_Name_Length); ! ! Min_Measure : Natural; ! -- Minimum value for the measure ! ! Max_Measure : Natural; ! -- Maximum value for the measure, taking into account the actual size ! -- of the pattern filled. ! ! Max_Size : Natural; end record; type Result_Array_Type is array (Positive range <>) of Task_Result; *************** private *** 334,340 **** (SP_Low : Stack_Address; SP_High : Stack_Address) return Natural; pragma Inline (Stack_Size); ! -- Return the size of a portion of stack delimeted by SP_High and SP_Low -- (), i.e. the difference between SP_High and SP_Low. The storage element -- pointed by SP_Low is not included in the size. Inlined to reduce the -- size of the stack used by the instrumentation code. --- 335,341 ---- (SP_Low : Stack_Address; SP_High : Stack_Address) return Natural; pragma Inline (Stack_Size); ! -- Return the size of a portion of stack delimited by SP_High and SP_Low -- (), i.e. the difference between SP_High and SP_Low. The storage element -- pointed by SP_Low is not included in the size. Inlined to reduce the -- size of the stack used by the instrumentation code. diff -Nrcpad gcc-4.3.3/gcc/ada/s-stchop-limit.ads gcc-4.4.0/gcc/ada/s-stchop-limit.ads *** gcc-4.3.3/gcc/ada/s-stchop-limit.ads Thu Dec 13 10:19:19 2007 --- gcc-4.4.0/gcc/ada/s-stchop-limit.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-stchop-rtems.adb gcc-4.4.0/gcc/ada/s-stchop-rtems.adb *** gcc-4.3.3/gcc/ada/s-stchop-rtems.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-stchop-rtems.adb Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,112 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- + -- -- + -- GNARL 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNARL was developed by the GNARL team at Florida State University. -- + -- Extensive contributions were provided by Ada Core Technologies, Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the RTEMS version of this package. + -- This file should be kept synchronized with the general implementation + -- provided by s-stchop.adb. + + pragma Restrictions (No_Elaboration_Code); + -- We want to guarantee the absence of elaboration code because the + -- binder does not handle references to this package. + + with Ada.Exceptions; + + with Interfaces.C; use Interfaces.C; + + package body System.Stack_Checking.Operations is + + ---------------------------- + -- Invalidate_Stack_Cache -- + ---------------------------- + + procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is + pragma Warnings (Off, Any_Stack); + begin + Cache := Null_Stack; + end Invalidate_Stack_Cache; + + ----------------------------- + -- Notify_Stack_Attributes -- + ----------------------------- + + procedure Notify_Stack_Attributes + (Initial_SP : System.Address; + Size : System.Storage_Elements.Storage_Offset) + is + + -- RTEMS keeps all the information we need. + + pragma Unreferenced (Size); + pragma Unreferenced (Initial_SP); + + begin + null; + end Notify_Stack_Attributes; + + ----------------- + -- Stack_Check -- + ----------------- + + function Stack_Check + (Stack_Address : System.Address) return Stack_Access + is + pragma Unreferenced (Stack_Address); + + -- RTEMS has a routine to check this. So use it. + function rtems_stack_checker_is_blown return Interfaces.C.int; + pragma Import (C, + rtems_stack_checker_is_blown, "rtems_stack_checker_is_blown"); + + begin + -- RTEMS has a routine to check this. So use it. + + if rtems_stack_checker_is_blown /= 0 then + Ada.Exceptions.Raise_Exception + (E => Storage_Error'Identity, + Message => "stack overflow detected"); + end if; + + return null; + + end Stack_Check; + + ------------------------ + -- Update_Stack_Cache -- + ------------------------ + + procedure Update_Stack_Cache (Stack : Stack_Access) is + begin + if not Multi_Processor then + Cache := Stack; + end if; + end Update_Stack_Cache; + + end System.Stack_Checking.Operations; diff -Nrcpad gcc-4.3.3/gcc/ada/s-stchop-vxworks.adb gcc-4.4.0/gcc/ada/s-stchop-vxworks.adb *** gcc-4.3.3/gcc/ada/s-stchop-vxworks.adb Thu Dec 13 10:19:19 2007 --- gcc-4.4.0/gcc/ada/s-stchop-vxworks.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-stchop.adb gcc-4.4.0/gcc/ada/s-stchop.adb *** gcc-4.3.3/gcc/ada/s-stchop.adb Tue Aug 14 08:44:14 2007 --- gcc-4.4.0/gcc/ada/s-stchop.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** pragma Restrictions (No_Elaboration_Code *** 39,46 **** -- We want to guarantee the absence of elaboration code because the -- binder does not handle references to this package. - with Ada.Exceptions; - with System.Storage_Elements; use System.Storage_Elements; with System.Parameters; use System.Parameters; with System.Soft_Links; --- 37,42 ---- *************** package body System.Stack_Checking.Opera *** 216,224 **** (not Stack_Grows_Down and then Stack_Address < Frame_Address) then ! Ada.Exceptions.Raise_Exception ! (E => Storage_Error'Identity, ! Message => "stack overflow detected"); end if; -- This function first does a "cheap" check which is correct --- 212,218 ---- (not Stack_Grows_Down and then Stack_Address < Frame_Address) then ! raise Storage_Error with "stack overflow detected"; end if; -- This function first does a "cheap" check which is correct *************** package body System.Stack_Checking.Opera *** 270,278 **** (not Stack_Grows_Down and then Stack_Address > My_Stack.Limit) then ! Ada.Exceptions.Raise_Exception ! (E => Storage_Error'Identity, ! Message => "stack overflow detected"); end if; return My_Stack; --- 264,270 ---- (not Stack_Grows_Down and then Stack_Address > My_Stack.Limit) then ! raise Storage_Error with "stack overflow detected"; end if; return My_Stack; diff -Nrcpad gcc-4.3.3/gcc/ada/s-stchop.ads gcc-4.4.0/gcc/ada/s-stchop.ads *** gcc-4.3.3/gcc/ada/s-stchop.ads Thu Dec 13 10:19:19 2007 --- gcc-4.4.0/gcc/ada/s-stchop.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-stoele.adb gcc-4.4.0/gcc/ada/s-stoele.adb *** gcc-4.3.3/gcc/ada/s-stoele.adb Thu Dec 13 10:35:02 2007 --- gcc-4.4.0/gcc/ada/s-stoele.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-stoele.ads gcc-4.4.0/gcc/ada/s-stoele.ads *** gcc-4.3.3/gcc/ada/s-stoele.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-stoele.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Storage_Elements is *** 122,146 **** pragma Inline_Always (To_Integer); pragma Pure_Function (To_Integer); - -- The following is a dummy record designed to mimic Communication_Block as - -- defined in s-tpobop.ads: - - -- type Communication_Block is record - -- Self : Task_Id; -- An access type - -- Enqueued : Boolean := True; - -- Cancelled : Boolean := False; - -- end record; - - -- The record is used in the construction of the predefined dispatching - -- primitive _disp_asynchronous_select in order to avoid the import of - -- System.Tasking.Protected_Objects.Operations. Note that this package - -- is always imported in the presence of interfaces since the dispatch - -- table uses entities from here. - - type Dummy_Communication_Block is record - Comp_1 : Address; -- Address and access have the same size - Comp_2 : Boolean; - Comp_3 : Boolean; - end record; - end System.Storage_Elements; --- 120,123 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-stopoo.adb gcc-4.4.0/gcc/ada/s-stopoo.adb *** gcc-4.3.3/gcc/ada/s-stopoo.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-stopoo.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-stopoo.ads gcc-4.4.0/gcc/ada/s-stopoo.ads *** gcc-4.3.3/gcc/ada/s-stopoo.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-stopoo.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-stratt.adb gcc-4.4.0/gcc/ada/s-stratt.adb *** gcc-4.3.3/gcc/ada/s-stratt.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-stratt.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Stream_Attributes is *** 74,79 **** --- 72,78 ---- subtype S_SU is SEA (1 .. (UST.Short_Unsigned'Size + SU - 1) / SU); subtype S_U is SEA (1 .. (UST.Unsigned'Size + SU - 1) / SU); subtype S_WC is SEA (1 .. (Wide_Character'Size + SU - 1) / SU); + subtype S_WWC is SEA (1 .. (Wide_Wide_Character'Size + SU - 1) / SU); -- Unchecked conversions from the elementary type to the stream type *************** package body System.Stream_Attributes is *** 94,99 **** --- 93,99 ---- function From_SU is new UC (UST.Short_Unsigned, S_SU); function From_U is new UC (UST.Unsigned, S_U); function From_WC is new UC (Wide_Character, S_WC); + function From_WWC is new UC (Wide_Wide_Character, S_WWC); -- Unchecked conversions from the stream type to elementary type *************** package body System.Stream_Attributes is *** 114,119 **** --- 114,129 ---- function To_SU is new UC (S_SU, UST.Short_Unsigned); function To_U is new UC (S_U, UST.Unsigned); function To_WC is new UC (S_WC, Wide_Character); + function To_WWC is new UC (S_WWC, Wide_Wide_Character); + + ----------------- + -- Block_IO_OK -- + ----------------- + + function Block_IO_OK return Boolean is + begin + return True; + end Block_IO_OK; ---------- -- I_AD -- *************** package body System.Stream_Attributes is *** 461,466 **** --- 471,494 ---- end if; end I_WC; + ----------- + -- I_WWC -- + ----------- + + function I_WWC (Stream : not null access RST) return Wide_Wide_Character is + T : S_WWC; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_WWC (T); + end if; + end I_WWC; + ---------- -- W_AD -- ---------- *************** package body System.Stream_Attributes is *** 665,668 **** --- 693,708 ---- Ada.Streams.Write (Stream.all, T); end W_WC; + ----------- + -- W_WWC -- + ----------- + + procedure W_WWC + (Stream : not null access RST; Item : Wide_Wide_Character) + is + T : constant S_WWC := From_WWC (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_WWC; + end System.Stream_Attributes; diff -Nrcpad gcc-4.3.3/gcc/ada/s-stratt.ads gcc-4.4.0/gcc/ada/s-stratt.ads *** gcc-4.3.3/gcc/ada/s-stratt.ads Fri Apr 6 09:29:20 2007 --- gcc-4.4.0/gcc/ada/s-stratt.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Stream_Attributes is *** 121,126 **** --- 119,125 ---- function I_SU (Stream : not null access RST) return UST.Short_Unsigned; function I_U (Stream : not null access RST) return UST.Unsigned; function I_WC (Stream : not null access RST) return Wide_Character; + function I_WWC (Stream : not null access RST) return Wide_Wide_Character; ----------------------- -- Output Procedures -- *************** package System.Stream_Attributes is *** 154,159 **** --- 153,166 ---- Item : UST.Short_Unsigned); procedure W_U (Stream : not null access RST; Item : UST.Unsigned); procedure W_WC (Stream : not null access RST; Item : Wide_Character); + procedure W_WWC (Stream : not null access RST; Item : Wide_Wide_Character); + + function Block_IO_OK return Boolean; + -- Package System.Stream_Attributes has several bodies - the default one + -- distributed with GNAT, s-strxdr.adb which is based on the XDR standard + -- and s-stratt.adb for Garlic. All three bodies share the same spec. The + -- role of this function is to determine whether the current version of + -- System.Stream_Attributes is able to support block IO. private pragma Inline (I_AD); *************** private *** 175,180 **** --- 182,188 ---- pragma Inline (I_SU); pragma Inline (I_U); pragma Inline (I_WC); + pragma Inline (I_WWC); pragma Inline (W_AD); pragma Inline (W_AS); *************** private *** 195,199 **** --- 203,210 ---- pragma Inline (W_SU); pragma Inline (W_U); pragma Inline (W_WC); + pragma Inline (W_WWC); + + pragma Inline (Block_IO_OK); end System.Stream_Attributes; diff -Nrcpad gcc-4.3.3/gcc/ada/s-strcom.adb gcc-4.4.0/gcc/ada/s-strcom.adb *** gcc-4.3.3/gcc/ada/s-strcom.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-strcom.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.String_Compare is *** 44,49 **** --- 42,48 ---- type Big_Words is array (Natural) of Word; type Big_Words_Ptr is access Big_Words; + for Big_Words_Ptr'Storage_Size use 0; -- Array type used to access by words type Byte is mod 2 ** 8; *************** package body System.String_Compare is *** 51,56 **** --- 50,56 ---- type Big_Bytes is array (Natural) of Byte; type Big_Bytes_Ptr is access Big_Bytes; + for Big_Bytes_Ptr'Storage_Size use 0; -- Array type used to access by bytes function To_Big_Words is new diff -Nrcpad gcc-4.3.3/gcc/ada/s-strcom.ads gcc-4.4.0/gcc/ada/s-strcom.ads *** gcc-4.3.3/gcc/ada/s-strcom.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-strcom.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-string.adb gcc-4.4.0/gcc/ada/s-string.adb *** gcc-4.3.3/gcc/ada/s-string.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-string.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-string.ads gcc-4.4.0/gcc/ada/s-string.ads *** gcc-4.3.3/gcc/ada/s-string.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-string.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-strops.adb gcc-4.4.0/gcc/ada/s-strops.adb *** gcc-4.3.3/gcc/ada/s-strops.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-strops.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.String_Ops is *** 43,49 **** function Str_Concat (X, Y : String) return String is begin ! if X'Length <= 0 then return Y; else --- 41,47 ---- function Str_Concat (X, Y : String) return String is begin ! if X'Length = 0 then return Y; else *************** package body System.String_Ops is *** 91,97 **** function Str_Concat_SC (X : String; Y : Character) return String is begin ! if X'Length <= 0 then return (1 => Y); else --- 89,95 ---- function Str_Concat_SC (X : String; Y : Character) return String is begin ! if X'Length = 0 then return (1 => Y); else diff -Nrcpad gcc-4.3.3/gcc/ada/s-strops.ads gcc-4.4.0/gcc/ada/s-strops.ads *** gcc-4.3.3/gcc/ada/s-strops.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-strops.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-strxdr.adb gcc-4.4.0/gcc/ada/s-strxdr.adb *** gcc-4.3.3/gcc/ada/s-strxdr.adb Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/s-strxdr.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2006, Free Software Foundation, Inc. -- -- -- -- GARLIC 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GARLIC is distributed in the hope that it will be useful, but -- ! -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABI- -- ! -- LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- ! -- License for more details. You should have received a copy of the GNU -- ! -- General Public License distributed with GARLIC; see file COPYING. If -- ! -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- ! -- Floor, Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- -- -- -- GARLIC 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- ! -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 33,39 **** -- This file is an alternate version of s-stratt.adb based on the XDR -- standard. It is especially useful for exchanging streams between two ! -- different systems with different basic type representations and endianess. with Ada.IO_Exceptions; with Ada.Streams; use Ada.Streams; --- 31,37 ---- -- This file is an alternate version of s-stratt.adb based on the XDR -- standard. It is especially useful for exchanging streams between two ! -- different systems with different basic type representations and endianness. with Ada.IO_Exceptions; with Ada.Streams; use Ada.Streams; *************** package body System.Stream_Attributes is *** 47,57 **** use UST; Data_Error : exception renames Ada.IO_Exceptions.End_Error; ! -- Exception raised if insufficient data read (End_Error is ! -- mandated by AI95-00132). SU : constant := System.Storage_Unit; ! -- XXXXX pragma Assert (SU = 8); BB : constant := 2 ** SU; -- Byte base BL : constant := 2 ** SU - 1; -- Byte last --- 45,55 ---- use UST; Data_Error : exception renames Ada.IO_Exceptions.End_Error; ! -- Exception raised if insufficient data read (End_Error is mandated by ! -- AI95-00132). SU : constant := System.Storage_Unit; ! -- The code in this body assumes that SU = 8 BB : constant := 2 ** SU; -- Byte base BL : constant := 2 ** SU - 1; -- Byte last *************** package body System.Stream_Attributes is *** 74,81 **** F_Size : Integer; -- Fraction bit size E_Last : Integer; -- Max exponent value F_Mask : SE; -- Mask to apply on first fraction byte ! E_Bytes : SEO; -- N. of exponent bytes completly used ! F_Bytes : SEO; -- N. of fraction bytes completly used F_Bits : Integer; -- N. of bits used on first fraction word end record; --- 72,79 ---- F_Size : Integer; -- Fraction bit size E_Last : Integer; -- Max exponent value F_Mask : SE; -- Mask to apply on first fraction byte ! E_Bytes : SEO; -- N. of exponent bytes completely used ! F_Bytes : SEO; -- N. of fraction bytes completely used F_Bits : Integer; -- N. of bits used on first fraction word end record; *************** package body System.Stream_Attributes is *** 127,133 **** -- in the range [-2147483648,2147483647]. The integer is represented -- in two's complement notation. The most and least significant bytes -- are 0 and 3, respectively. Integers are declared as follows: ! -- -- (MSB) (LSB) -- +-------+-------+-------+-------+ -- |byte 0 |byte 1 |byte 2 |byte 3 | --- 125,131 ---- -- in the range [-2147483648,2147483647]. The integer is represented -- in two's complement notation. The most and least significant bytes -- are 0 and 3, respectively. Integers are declared as follows: ! -- (MSB) (LSB) -- +-------+-------+-------+-------+ -- |byte 0 |byte 1 |byte 2 |byte 3 | *************** package body System.Stream_Attributes is *** 175,181 **** -- integer in the range [0,4294967295]. It is represented by an unsigned -- binary number whose most and least significant bytes are 0 and 3, -- respectively. An unsigned integer is declared as follows: ! -- -- (MSB) (LSB) -- +-------+-------+-------+-------+ -- |byte 0 |byte 1 |byte 2 |byte 3 | --- 173,179 ---- -- integer in the range [0,4294967295]. It is represented by an unsigned -- binary number whose most and least significant bytes are 0 and 3, -- respectively. An unsigned integer is declared as follows: ! -- (MSB) (LSB) -- +-------+-------+-------+-------+ -- |byte 0 |byte 1 |byte 2 |byte 3 | *************** package body System.Stream_Attributes is *** 222,231 **** -- or 4 bytes). The encoding used is the IEEE standard for normalized -- single-precision floating-point numbers. ! -- The standard defines the encoding for the double-precision ! -- floating-point data type "double" (64 bits or 8 bytes). The ! -- encoding used is the IEEE standard for normalized double-precision ! -- floating-point numbers. SF_L : constant := 4; -- Single precision F_L : constant := 4; -- Single precision --- 220,229 ---- -- or 4 bytes). The encoding used is the IEEE standard for normalized -- single-precision floating-point numbers. ! -- The standard defines the encoding used for the double-precision ! -- floating-point data type "double" (64 bits or 8 bytes). The encoding ! -- used is the IEEE standard for normalized double-precision floating-point ! -- numbers. SF_L : constant := 4; -- Single precision F_L : constant := 4; -- Single precision *************** package body System.Stream_Attributes is *** 267,272 **** --- 265,276 ---- subtype XDR_S_WC is SEA (1 .. WC_L); type XDR_WC is mod BB ** WC_L; + -- Consider Wide_Wide_Character as an enumeration type + + WWC_L : constant := 8; + subtype XDR_S_WWC is SEA (1 .. WWC_L); + type XDR_WWC is mod BB ** WWC_L; + -- Optimization: if we already have the correct Bit_Order, then some -- computations can be avoided since the source and the target will be -- identical anyway. They will be replaced by direct unchecked *************** package body System.Stream_Attributes is *** 275,280 **** --- 279,293 ---- Optimize_Integers : constant Boolean := Default_Bit_Order = High_Order_First; + ----------------- + -- Block_IO_OK -- + ----------------- + + function Block_IO_OK return Boolean is + begin + return False; + end Block_IO_OK; + ---------- -- I_AD -- ---------- *************** package body System.Stream_Attributes is *** 303,308 **** --- 316,322 ---- if L /= S'Last then raise Data_Error; + else for N in S'Range loop U := U * BB + XDR_TM (S (N)); *************** package body System.Stream_Attributes is *** 338,345 **** if L /= S'Last then raise Data_Error; - else -- Use Ada requirements on Character representation clause return Character'Val (S (1)); --- 352,359 ---- if L /= S'Last then raise Data_Error; + else -- Use Ada requirements on Character representation clause return Character'Val (S (1)); *************** package body System.Stream_Attributes is *** 694,703 **** if L /= S'Last then raise Data_Error; elsif Optimize_Integers then return XDR_S_LLI_To_Long_Long_Integer (S); - else -- Compute using machine unsigned for computing -- rather than long_long_unsigned. --- 708,718 ---- if L /= S'Last then raise Data_Error; + elsif Optimize_Integers then return XDR_S_LLI_To_Long_Long_Integer (S); + else -- Compute using machine unsigned for computing -- rather than long_long_unsigned. *************** package body System.Stream_Attributes is *** 737,746 **** if L /= S'Last then raise Data_Error; elsif Optimize_Integers then return XDR_S_LLU_To_Long_Long_Unsigned (S); - else -- Compute using machine unsigned -- rather than long_long_unsigned. --- 752,762 ---- if L /= S'Last then raise Data_Error; + elsif Optimize_Integers then return XDR_S_LLU_To_Long_Long_Unsigned (S); + else -- Compute using machine unsigned -- rather than long_long_unsigned. *************** package body System.Stream_Attributes is *** 774,783 **** if L /= S'Last then raise Data_Error; elsif Optimize_Integers then return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S)); - else -- Compute using machine unsigned -- rather than long_unsigned. --- 790,800 ---- if L /= S'Last then raise Data_Error; + elsif Optimize_Integers then return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S)); + else -- Compute using machine unsigned -- rather than long_unsigned. *************** package body System.Stream_Attributes is *** 924,931 **** --- 941,950 ---- if L /= S'Last then raise Data_Error; + elsif Optimize_Integers then return XDR_S_SSI_To_Short_Short_Integer (S); + else U := XDR_SSU (S (1)); *************** package body System.Stream_Attributes is *** 953,961 **** if L /= S'Last then raise Data_Error; else U := XDR_SSU (S (1)); - return Short_Short_Unsigned (U); end if; end I_SSU; --- 972,980 ---- if L /= S'Last then raise Data_Error; + else U := XDR_SSU (S (1)); return Short_Short_Unsigned (U); end if; end I_SSU; *************** package body System.Stream_Attributes is *** 974,981 **** --- 993,1002 ---- if L /= S'Last then raise Data_Error; + elsif Optimize_Integers then return XDR_S_SU_To_Short_Unsigned (S); + else for N in S'Range loop U := U * BB + XDR_SU (S (N)); *************** package body System.Stream_Attributes is *** 1026,1031 **** --- 1047,1053 ---- if L /= S'Last then raise Data_Error; + else for N in S'Range loop U := U * BB + XDR_WC (S (N)); *************** package body System.Stream_Attributes is *** 1037,1042 **** --- 1059,1090 ---- end if; end I_WC; + ----------- + -- I_WWC -- + ----------- + + function I_WWC (Stream : not null access RST) return Wide_Wide_Character is + S : XDR_S_WWC; + L : SEO; + U : XDR_WWC := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + for N in S'Range loop + U := U * BB + XDR_WWC (S (N)); + end loop; + + -- Use Ada requirements on Wide_Wide_Character representation clause + + return Wide_Wide_Character'Val (U); + end if; + end I_WWC; + ---------- -- W_AD -- ---------- *************** package body System.Stream_Attributes is *** 1111,1117 **** pragma Assert (C_L = 1); begin - -- Use Ada requirements on Character representation clause S (1) := SE (Character'Pos (Item)); --- 1159,1164 ---- *************** package body System.Stream_Attributes is *** 1212,1219 **** begin if Optimize_Integers then S := Integer_To_XDR_S_I (Item); - else -- Test sign and apply two complement notation if Item < 0 then --- 1259,1266 ---- begin if Optimize_Integers then S := Integer_To_XDR_S_I (Item); + else -- Test sign and apply two complement notation if Item < 0 then *************** package body System.Stream_Attributes is *** 1329,1336 **** begin if Optimize_Integers then S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item)); - else -- Test sign and apply two complement notation if Item < 0 then --- 1376,1383 ---- begin if Optimize_Integers then S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item)); + else -- Test sign and apply two complement notation if Item < 0 then *************** package body System.Stream_Attributes is *** 1462,1469 **** -- W_LLI -- ----------- ! procedure W_LLI (Stream : not null access RST; ! Item : Long_Long_Integer) is S : XDR_S_LLI; U : Unsigned; --- 1509,1517 ---- -- W_LLI -- ----------- ! procedure W_LLI ! (Stream : not null access RST; ! Item : Long_Long_Integer) is S : XDR_S_LLI; U : Unsigned; *************** package body System.Stream_Attributes is *** 1472,1479 **** begin if Optimize_Integers then S := Long_Long_Integer_To_XDR_S_LLI (Item); - else -- Test sign and apply two complement notation if Item < 0 then --- 1520,1527 ---- begin if Optimize_Integers then S := Long_Long_Integer_To_XDR_S_LLI (Item); + else -- Test sign and apply two complement notation if Item < 0 then *************** package body System.Stream_Attributes is *** 1510,1517 **** -- W_LLU -- ----------- ! procedure W_LLU (Stream : not null access RST; ! Item : Long_Long_Unsigned) is S : XDR_S_LLU; U : Unsigned; X : Long_Long_Unsigned := Item; --- 1558,1567 ---- -- W_LLU -- ----------- ! procedure W_LLU ! (Stream : not null access RST; ! Item : Long_Long_Unsigned) ! is S : XDR_S_LLU; U : Unsigned; X : Long_Long_Unsigned := Item; *************** package body System.Stream_Attributes is *** 1519,1524 **** --- 1569,1575 ---- begin if Optimize_Integers then S := Long_Long_Unsigned_To_XDR_S_LLU (Item); + else -- Compute using machine unsigned -- rather than long_long_unsigned. *************** package body System.Stream_Attributes is *** 1556,1561 **** --- 1607,1613 ---- begin if Optimize_Integers then S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item)); + else -- Compute using machine unsigned -- rather than long_unsigned. *************** package body System.Stream_Attributes is *** 1673,1680 **** begin if Optimize_Integers then S := Short_Integer_To_XDR_S_SI (Item); - else -- Test sign and apply two complement's notation if Item < 0 then --- 1725,1732 ---- begin if Optimize_Integers then S := Short_Integer_To_XDR_S_SI (Item); + else -- Test sign and apply two complement's notation if Item < 0 then *************** package body System.Stream_Attributes is *** 1710,1717 **** begin if Optimize_Integers then S := Short_Short_Integer_To_XDR_S_SSI (Item); - else -- Test sign and apply two complement's notation if Item < 0 then --- 1762,1769 ---- begin if Optimize_Integers then S := Short_Short_Integer_To_XDR_S_SSI (Item); + else -- Test sign and apply two complement's notation if Item < 0 then *************** package body System.Stream_Attributes is *** 1739,1745 **** begin S (1) := SE (U); - Ada.Streams.Write (Stream.all, S); end W_SSU; --- 1791,1796 ---- *************** package body System.Stream_Attributes is *** 1754,1759 **** --- 1805,1811 ---- begin if Optimize_Integers then S := Short_Unsigned_To_XDR_S_SU (Item); + else for N in reverse S'Range loop S (N) := SE (U mod BB); *************** package body System.Stream_Attributes is *** 1779,1784 **** --- 1831,1837 ---- begin if Optimize_Integers then S := Unsigned_To_XDR_S_U (Item); + else for N in reverse S'Range loop S (N) := SE (U mod BB); *************** package body System.Stream_Attributes is *** 1802,1808 **** U : XDR_WC; begin - -- Use Ada requirements on Wide_Character representation clause U := XDR_WC (Wide_Character'Pos (Item)); --- 1855,1860 ---- *************** package body System.Stream_Attributes is *** 1819,1822 **** --- 1871,1901 ---- end if; end W_WC; + ----------- + -- W_WWC -- + ----------- + + procedure W_WWC + (Stream : not null access RST; Item : Wide_Wide_Character) + is + S : XDR_S_WWC; + U : XDR_WWC; + + begin + -- Use Ada requirements on Wide_Wide_Character representation clause + + U := XDR_WWC (Wide_Wide_Character'Pos (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_WWC; + end System.Stream_Attributes; diff -Nrcpad gcc-4.3.3/gcc/ada/s-ststop.adb gcc-4.4.0/gcc/ada/s-ststop.adb *** gcc-4.3.3/gcc/ada/s-ststop.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-ststop.adb Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,687 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . S T R I N G S . S T R E A M _ O P S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2009, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + pragma Warnings (Off); + pragma Compiler_Unit; + pragma Warnings (On); + + with Ada.Streams; use Ada.Streams; + with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; + with Ada.Unchecked_Conversion; + + with System.Stream_Attributes; use System; + + package body System.Strings.Stream_Ops is + + -- The following type describes the low-level IO mechanism used in package + -- Stream_Ops_Internal. + + type IO_Kind is (Byte_IO, Block_IO); + + -- The following package provides an IO framework for strings. Depending + -- on the version of System.Stream_Attributes as well as the size of + -- formal parameter Character_Type, the package will either utilize block + -- IO or character-by-character IO. + + generic + type Character_Type is private; + type String_Type is array (Positive range <>) of Character_Type; + + package Stream_Ops_Internal is + function Input + (Strm : access Root_Stream_Type'Class; + IO : IO_Kind) return String_Type; + + procedure Output + (Strm : access Root_Stream_Type'Class; + Item : String_Type; + IO : IO_Kind); + + procedure Read + (Strm : access Root_Stream_Type'Class; + Item : out String_Type; + IO : IO_Kind); + + procedure Write + (Strm : access Root_Stream_Type'Class; + Item : String_Type; + IO : IO_Kind); + end Stream_Ops_Internal; + + ------------------------- + -- Stream_Ops_Internal -- + ------------------------- + + package body Stream_Ops_Internal is + + -- The following value represents the number of BITS allocated for the + -- default block used in string IO. The sizes of all other types are + -- calculated relative to this value. + + Default_Block_Size : constant := 512 * 8; + + -- Shorthand notation for stream element and character sizes + + C_Size : constant Integer := Character_Type'Size; + SE_Size : constant Integer := Stream_Element'Size; + + -- The following constants describe the number of stream elements or + -- characters that can fit into a default block. + + C_In_Default_Block : constant Integer := Default_Block_Size / C_Size; + SE_In_Default_Block : constant Integer := Default_Block_Size / SE_Size; + + -- Buffer types + + subtype Default_Block is Stream_Element_Array + (1 .. Stream_Element_Offset (SE_In_Default_Block)); + + subtype String_Block is String_Type (1 .. C_In_Default_Block); + + -- Conversions to and from Default_Block + + function To_Default_Block is + new Ada.Unchecked_Conversion (String_Block, Default_Block); + + function To_String_Block is + new Ada.Unchecked_Conversion (Default_Block, String_Block); + + ----------- + -- Input -- + ----------- + + function Input + (Strm : access Root_Stream_Type'Class; + IO : IO_Kind) return String_Type + is + begin + if Strm = null then + raise Constraint_Error; + end if; + + declare + Low : Positive; + High : Positive; + + begin + -- Read the bounds of the string + + Positive'Read (Strm, Low); + Positive'Read (Strm, High); + + declare + Item : String_Type (Low .. High); + + begin + -- Read the character content of the string + + Read (Strm, Item, IO); + + return Item; + end; + end; + end Input; + + ------------ + -- Output -- + ------------ + + procedure Output + (Strm : access Root_Stream_Type'Class; + Item : String_Type; + IO : IO_Kind) + is + begin + if Strm = null then + raise Constraint_Error; + end if; + + -- Write the bounds of the string + + Positive'Write (Strm, Item'First); + Positive'Write (Strm, Item'Last); + + -- Write the character content of the string + + Write (Strm, Item, IO); + end Output; + + ---------- + -- Read -- + ---------- + + procedure Read + (Strm : access Root_Stream_Type'Class; + Item : out String_Type; + IO : IO_Kind) + is + begin + if Strm = null then + raise Constraint_Error; + end if; + + -- Nothing to do if the desired string is empty + + if Item'Length = 0 then + return; + end if; + + -- Block IO + + if IO = Block_IO + and then Stream_Attributes.Block_IO_OK + then + declare + -- Determine the size in BITS of the block necessary to contain + -- the whole string. + + Block_Size : constant Natural := + (Item'Last - Item'First + 1) * C_Size; + + -- Item can be larger than what the default block can store, + -- determine the number of whole reads necessary to read the + -- string. + + Blocks : constant Natural := Block_Size / Default_Block_Size; + + -- The size of Item may not be a multiple of the default block + -- size, determine the size of the remaining chunk in BITS. + + Rem_Size : constant Natural := + Block_Size mod Default_Block_Size; + + -- String indices + + Low : Positive := Item'First; + High : Positive := Low + C_In_Default_Block - 1; + + -- End of stream error detection + + Last : Stream_Element_Offset := 0; + Sum : Stream_Element_Offset := 0; + + begin + -- Step 1: If the string is too large, read in individual + -- chunks the size of the default block. + + if Blocks > 0 then + declare + Block : Default_Block; + + begin + for Counter in 1 .. Blocks loop + Read (Strm.all, Block, Last); + Item (Low .. High) := To_String_Block (Block); + + Low := High + 1; + High := Low + C_In_Default_Block - 1; + Sum := Sum + Last; + Last := 0; + end loop; + end; + end if; + + -- Step 2: Read in any remaining elements + + if Rem_Size > 0 then + declare + subtype Rem_Block is Stream_Element_Array + (1 .. Stream_Element_Offset (Rem_Size / SE_Size)); + + subtype Rem_String_Block is + String_Type (1 .. Rem_Size / C_Size); + + function To_Rem_String_Block is new + Ada.Unchecked_Conversion (Rem_Block, Rem_String_Block); + + Block : Rem_Block; + + begin + Read (Strm.all, Block, Last); + Item (Low .. Item'Last) := To_Rem_String_Block (Block); + + Sum := Sum + Last; + end; + end if; + + -- Step 3: Potential error detection. The sum of all the + -- chunks is less than we initially wanted to read. In other + -- words, the stream does not contain enough elements to fully + -- populate Item. + + if (Integer (Sum) * SE_Size) / C_Size < Item'Length then + raise End_Error; + end if; + end; + + -- Byte IO + + else + declare + C : Character_Type; + + begin + for Index in Item'First .. Item'Last loop + Character_Type'Read (Strm, C); + Item (Index) := C; + end loop; + end; + end if; + end Read; + + ----------- + -- Write -- + ----------- + + procedure Write + (Strm : access Root_Stream_Type'Class; + Item : String_Type; + IO : IO_Kind) + is + begin + if Strm = null then + raise Constraint_Error; + end if; + + -- Nothing to do if the input string is empty + + if Item'Length = 0 then + return; + end if; + + -- Block IO + + if IO = Block_IO + and then Stream_Attributes.Block_IO_OK + then + declare + -- Determine the size in BITS of the block necessary to contain + -- the whole string. + + Block_Size : constant Natural := Item'Length * C_Size; + + -- Item can be larger than what the default block can store, + -- determine the number of whole writes necessary to output the + -- string. + + Blocks : constant Natural := Block_Size / Default_Block_Size; + + -- The size of Item may not be a multiple of the default block + -- size, determine the size of the remaining chunk. + + Rem_Size : constant Natural := + Block_Size mod Default_Block_Size; + + -- String indices + + Low : Positive := Item'First; + High : Positive := Low + C_In_Default_Block - 1; + + begin + -- Step 1: If the string is too large, write out individual + -- chunks the size of the default block. + + for Counter in 1 .. Blocks loop + Write (Strm.all, To_Default_Block (Item (Low .. High))); + + Low := High + 1; + High := Low + C_In_Default_Block - 1; + end loop; + + -- Step 2: Write out any remaining elements + + if Rem_Size > 0 then + declare + subtype Rem_Block is Stream_Element_Array + (1 .. Stream_Element_Offset (Rem_Size / SE_Size)); + + subtype Rem_String_Block is + String_Type (1 .. Rem_Size / C_Size); + + function To_Rem_Block is new + Ada.Unchecked_Conversion (Rem_String_Block, Rem_Block); + + begin + Write (Strm.all, To_Rem_Block (Item (Low .. Item'Last))); + end; + end if; + end; + + -- Byte IO + + else + for Index in Item'First .. Item'Last loop + Character_Type'Write (Strm, Item (Index)); + end loop; + end if; + end Write; + end Stream_Ops_Internal; + + -- Specific instantiations for all Ada string types + + package String_Ops is + new Stream_Ops_Internal + (Character_Type => Character, + String_Type => String); + + package Wide_String_Ops is + new Stream_Ops_Internal + (Character_Type => Wide_Character, + String_Type => Wide_String); + + package Wide_Wide_String_Ops is + new Stream_Ops_Internal + (Character_Type => Wide_Wide_Character, + String_Type => Wide_Wide_String); + + ------------------ + -- String_Input -- + ------------------ + + function String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) return String + is + begin + return String_Ops.Input (Strm, Byte_IO); + end String_Input; + + ------------------------- + -- String_Input_Blk_IO -- + ------------------------- + + function String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return String + is + begin + return String_Ops.Input (Strm, Block_IO); + end String_Input_Blk_IO; + + ------------------- + -- String_Output -- + ------------------- + + procedure String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Output (Strm, Item, Byte_IO); + end String_Output; + + -------------------------- + -- String_Output_Blk_IO -- + -------------------------- + + procedure String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Output (Strm, Item, Block_IO); + end String_Output_Blk_IO; + + ----------------- + -- String_Read -- + ----------------- + + procedure String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String) + is + begin + String_Ops.Read (Strm, Item, Byte_IO); + end String_Read; + + ------------------------ + -- String_Read_Blk_IO -- + ------------------------ + + procedure String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String) + is + begin + String_Ops.Read (Strm, Item, Block_IO); + end String_Read_Blk_IO; + + ------------------ + -- String_Write -- + ------------------ + + procedure String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Write (Strm, Item, Byte_IO); + end String_Write; + + ------------------------- + -- String_Write_Blk_IO -- + ------------------------- + + procedure String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Write (Strm, Item, Block_IO); + end String_Write_Blk_IO; + + ----------------------- + -- Wide_String_Input -- + ----------------------- + + function Wide_String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String + is + begin + return Wide_String_Ops.Input (Strm, Byte_IO); + end Wide_String_Input; + + ------------------------------ + -- Wide_String_Input_Blk_IO -- + ------------------------------ + + function Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String + is + begin + return Wide_String_Ops.Input (Strm, Block_IO); + end Wide_String_Input_Blk_IO; + + ------------------------ + -- Wide_String_Output -- + ------------------------ + + procedure Wide_String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Output (Strm, Item, Byte_IO); + end Wide_String_Output; + + ------------------------------- + -- Wide_String_Output_Blk_IO -- + ------------------------------- + + procedure Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Output (Strm, Item, Block_IO); + end Wide_String_Output_Blk_IO; + + ---------------------- + -- Wide_String_Read -- + ---------------------- + + procedure Wide_String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String) + is + begin + Wide_String_Ops.Read (Strm, Item, Byte_IO); + end Wide_String_Read; + + ----------------------------- + -- Wide_String_Read_Blk_IO -- + ----------------------------- + + procedure Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String) + is + begin + Wide_String_Ops.Read (Strm, Item, Block_IO); + end Wide_String_Read_Blk_IO; + + ----------------------- + -- Wide_String_Write -- + ----------------------- + + procedure Wide_String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Write (Strm, Item, Byte_IO); + end Wide_String_Write; + + ------------------------------ + -- Wide_String_Write_Blk_IO -- + ------------------------------ + + procedure Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Write (Strm, Item, Block_IO); + end Wide_String_Write_Blk_IO; + + ---------------------------- + -- Wide_Wide_String_Input -- + ---------------------------- + + function Wide_Wide_String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String + is + begin + return Wide_Wide_String_Ops.Input (Strm, Byte_IO); + end Wide_Wide_String_Input; + + ----------------------------------- + -- Wide_Wide_String_Input_Blk_IO -- + ----------------------------------- + + function Wide_Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String + is + begin + return Wide_Wide_String_Ops.Input (Strm, Block_IO); + end Wide_Wide_String_Input_Blk_IO; + + ----------------------------- + -- Wide_Wide_String_Output -- + ----------------------------- + + procedure Wide_Wide_String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Output (Strm, Item, Byte_IO); + end Wide_Wide_String_Output; + + ------------------------------------ + -- Wide_Wide_String_Output_Blk_IO -- + ------------------------------------ + + procedure Wide_Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Output (Strm, Item, Block_IO); + end Wide_Wide_String_Output_Blk_IO; + + --------------------------- + -- Wide_Wide_String_Read -- + --------------------------- + + procedure Wide_Wide_String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Read (Strm, Item, Byte_IO); + end Wide_Wide_String_Read; + + ---------------------------------- + -- Wide_Wide_String_Read_Blk_IO -- + ---------------------------------- + + procedure Wide_Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Read (Strm, Item, Block_IO); + end Wide_Wide_String_Read_Blk_IO; + + ---------------------------- + -- Wide_Wide_String_Write -- + ---------------------------- + + procedure Wide_Wide_String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Write (Strm, Item, Byte_IO); + end Wide_Wide_String_Write; + + ----------------------------------- + -- Wide_Wide_String_Write_Blk_IO -- + ----------------------------------- + + procedure Wide_Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Write (Strm, Item, Block_IO); + end Wide_Wide_String_Write_Blk_IO; + + end System.Strings.Stream_Ops; diff -Nrcpad gcc-4.3.3/gcc/ada/s-ststop.ads gcc-4.4.0/gcc/ada/s-ststop.ads *** gcc-4.3.3/gcc/ada/s-ststop.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-ststop.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,165 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . S T R I N G S . S T R E A M _ O P S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2009, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides subprogram implementations of stream attributes for + -- the following types: + -- Ada.String + -- Ada.Wide_String + -- Ada.Wide_Wide_String + -- + -- The compiler will generate references to the subprograms in this package + -- when expanding stream attributes for the above mentioned types. Example: + -- + -- String'Output (Some_Stream, Some_String); + -- + -- will be expanded into: + -- + -- String_Output (Some_Stream, Some_String); + -- or + -- String_Output_Blk_IO (Some_Stream, Some_String); + + pragma Warnings (Off); + pragma Compiler_Unit; + pragma Warnings (On); + + with Ada.Streams; + + package System.Strings.Stream_Ops is + + ------------------------------ + -- String stream operations -- + ------------------------------ + + function String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return String; + + function String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return String; + + procedure String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + + procedure String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + + procedure String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String); + + procedure String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String); + + procedure String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + + procedure String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + + ----------------------------------- + -- Wide_String stream operations -- + ----------------------------------- + + function Wide_String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_String; + + function Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_String; + + procedure Wide_String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + + procedure Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + + procedure Wide_String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String); + + procedure Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String); + + procedure Wide_String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + + procedure Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + + ---------------------------------------- + -- Wide_Wide_String stream operations -- + ---------------------------------------- + + function Wide_Wide_String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_Wide_String; + + function Wide_Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_Wide_String; + + procedure Wide_Wide_String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + + procedure Wide_Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + + procedure Wide_Wide_String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String); + + procedure Wide_Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String); + + procedure Wide_Wide_String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + + procedure Wide_Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + + end System.Strings.Stream_Ops; diff -Nrcpad gcc-4.3.3/gcc/ada/s-taasde.adb gcc-4.4.0/gcc/ada/s-taasde.adb *** gcc-4.3.3/gcc/ada/s-taasde.adb Wed Nov 7 14:49:46 2007 --- gcc-4.4.0/gcc/ada/s-taasde.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** pragma Polling (Off); *** 35,80 **** -- Turn off polling, we do not want ATC polling to take place during -- tasking operations. It causes infinite loops and other problems. ! with Ada.Exceptions; ! -- Used for Raise_Exception with System.Task_Primitives.Operations; - -- Used for Write_Lock, - -- Unlock, - -- Self, - -- Monotonic_Clock, - -- Self, - -- Timed_Sleep, - -- Wakeup, - -- Yield - with System.Tasking.Utilities; - -- Used for Make_Independent - with System.Tasking.Initialization; - -- Used for Defer_Abort - -- Undefer_Abort - with System.Tasking.Debug; - -- Used for Trace - with System.OS_Primitives; - -- used for Max_Sensible_Delay - - with Ada.Task_Identification; - -- used for Task_Id type - with System.Interrupt_Management.Operations; - -- used for Setup_Interrupt_Mask - with System.Parameters; - -- used for Single_Lock - -- Runtime_Traces - with System.Traces.Tasking; - -- used for Send_Trace_Info - - with Ada.Unchecked_Conversion; package body System.Tasking.Async_Delays is --- 33,49 ---- -- Turn off polling, we do not want ATC polling to take place during -- tasking operations. It causes infinite loops and other problems. ! with Ada.Unchecked_Conversion; ! with Ada.Task_Identification; with System.Task_Primitives.Operations; with System.Tasking.Utilities; with System.Tasking.Initialization; with System.Tasking.Debug; with System.OS_Primitives; with System.Interrupt_Management.Operations; with System.Parameters; with System.Traces.Tasking; package body System.Tasking.Async_Delays is *************** package body System.Tasking.Async_Delays *** 228,235 **** "async delay from within abort-deferred region"); if Self_Id.ATC_Nesting_Level = ATC_Level'Last then ! Ada.Exceptions.Raise_Exception (Storage_Error'Identity, ! "not enough ATC nesting levels"); end if; Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; --- 197,203 ---- "async delay from within abort-deferred region"); if Self_Id.ATC_Nesting_Level = ATC_Level'Last then ! raise Storage_Error with "not enough ATC nesting levels"; end if; Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; diff -Nrcpad gcc-4.3.3/gcc/ada/s-taasde.ads gcc-4.4.0/gcc/ada/s-taasde.ads *** gcc-4.3.3/gcc/ada/s-taasde.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-taasde.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2006, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tadeca.adb gcc-4.4.0/gcc/ada/s-tadeca.adb *** gcc-4.3.3/gcc/ada/s-tadeca.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-tadeca.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S . -- ! -- E N Q U E U E _ C A L E N D A R -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_CALENDAR -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tadeca.ads gcc-4.4.0/gcc/ada/s-tadeca.ads *** gcc-4.3.3/gcc/ada/s-tadeca.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-tadeca.ads Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S . -- ! -- E N Q U E U E _ C A L E N D A R -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_CALENDAR -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tadert.adb gcc-4.4.0/gcc/ada/s-tadert.adb *** gcc-4.3.3/gcc/ada/s-tadert.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-tadert.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S . -- ! -- E N Q U E U E _ R T -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2006, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_RT -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tadert.ads gcc-4.4.0/gcc/ada/s-tadert.ads *** gcc-4.3.3/gcc/ada/s-tadert.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-tadert.ads Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S . -- ! -- E N Q U E U E _ R T -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_RT -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-taenca.adb gcc-4.4.0/gcc/ada/s-taenca.adb *** gcc-4.3.3/gcc/ada/s-taenca.adb Wed Jun 6 10:14:59 2007 --- gcc-4.4.0/gcc/ada/s-taenca.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 32,67 **** ------------------------------------------------------------------------------ with System.Task_Primitives.Operations; - -- used for STPO.Write_Lock - -- Unlock - -- STPO.Get_Priority - -- Sleep - -- Timed_Sleep - with System.Tasking.Initialization; - -- used for Change_Base_Priority - -- Defer_Abort/Undefer_Abort - with System.Tasking.Protected_Objects.Entries; - -- used for To_Protection - with System.Tasking.Protected_Objects.Operations; - -- used for PO_Service_Entries - with System.Tasking.Queuing; - -- used for Requeue_Call_With_New_Prio - -- Onqueue - -- Dequeue_Call - with System.Tasking.Utilities; - -- used for Exit_One_ATC_Level - with System.Parameters; - -- used for Single_Lock - -- Runtime_Traces - with System.Traces; - -- used for Send_Trace_Info package body System.Tasking.Entry_Calls is --- 30,42 ---- *************** package body System.Tasking.Entry_Calls *** 136,142 **** pragma Inline (Poll_Base_Priority_Change_At_Entry_Call); -- A specialized version of Poll_Base_Priority_Change, that does the -- optional entry queue reordering. Has to be called with the Self_ID's ! -- ATCB write-locked. May temporariliy release the lock. --------------------- -- Check_Exception -- --- 111,117 ---- pragma Inline (Poll_Base_Priority_Change_At_Entry_Call); -- A specialized version of Poll_Base_Priority_Change, that does the -- optional entry queue reordering. Has to be called with the Self_ID's ! -- ATCB write-locked. May temporarily release the lock. --------------------- -- Check_Exception -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-taenca.ads gcc-4.4.0/gcc/ada/s-taenca.ads *** gcc-4.3.3/gcc/ada/s-taenca.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-taenca.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package System.Tasking.Entry_Calls is *** 70,76 **** pragma Inline (Try_To_Cancel_Entry_Call); -- Try to cancel async. entry call. -- Effect includes Abort_To_Level and Wait_For_Completion. ! -- Cancelled = True iff the cancelation was successful, i.e., -- the call was not Done before this call. -- On return, the call is off-queue and the ATC level is reduced by one. --- 68,74 ---- pragma Inline (Try_To_Cancel_Entry_Call); -- Try to cancel async. entry call. -- Effect includes Abort_To_Level and Wait_For_Completion. ! -- Cancelled = True iff the cancellation was successful, i.e., -- the call was not Done before this call. -- On return, the call is off-queue and the ATC level is reduced by one. diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprob.adb gcc-4.4.0/gcc/ada/s-taprob.adb *** gcc-4.3.3/gcc/ada/s-taprob.adb Wed Jun 6 10:46:22 2007 --- gcc-4.4.0/gcc/ada/s-taprob.adb Sun Apr 13 17:25:22 2008 *************** *** 7,13 **** -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2006, AdaCore -- -- -- -- GNARL 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- -- --- 7,13 ---- -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNARL 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- -- *************** pragma Polling (Off); *** 37,55 **** -- tasking operations. It causes infinite loops and other problems. with System.Task_Primitives.Operations; - -- used for Write_Lock - -- Unlock - -- Self - -- Set_Ceiling - with System.Parameters; - -- used for Runtime_Traces - with System.Traces; - -- used for Send_Trace_Info - with System.Soft_Links.Tasking; - -- Used for Init_Tasking_Soft_Links package body System.Tasking.Protected_Objects is --- 37,45 ---- *************** package body System.Tasking.Protected_Ob *** 111,117 **** Ceiling_Violation : Boolean; begin ! -- The lock is made without defering abort -- Therefore the abort has to be deferred before calling this routine. -- This means that the compiler has to generate a Defer_Abort call --- 101,107 ---- Ceiling_Violation : Boolean; begin ! -- The lock is made without deferring abort -- Therefore the abort has to be deferred before calling this routine. -- This means that the compiler has to generate a Defer_Abort call *************** package body System.Tasking.Protected_Ob *** 181,187 **** -- read ownership of the protected object, so that this method of -- storing the (single) protected object's owner does not work reliably -- for read locks. However, this is the approach taken for two major ! -- reasosn: first, this function is not currently being used (it is -- provided for possible future use), and second, it largely simplifies -- the implementation. --- 171,177 ---- -- read ownership of the protected object, so that this method of -- storing the (single) protected object's owner does not work reliably -- for read locks. However, this is the approach taken for two major ! -- reasons: first, this function is not currently being used (it is -- provided for possible future use), and second, it largely simplifies -- the implementation. diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprob.ads gcc-4.4.0/gcc/ada/s-taprob.ads *** gcc-4.3.3/gcc/ada/s-taprob.ads Tue Oct 31 18:11:44 2006 --- gcc-4.4.0/gcc/ada/s-taprob.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprop-dummy.adb gcc-4.4.0/gcc/ada/s-taprop-dummy.adb *** gcc-4.3.3/gcc/ada/s-taprop-dummy.adb Wed Sep 26 10:41:47 2007 --- gcc-4.4.0/gcc/ada/s-taprop-dummy.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 33,47 **** -- This is a no tasking version of this package ! -- This package contains all the GNULL primitives that interface directly ! -- with the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. with System.Error_Reporting; - -- used for Shutdown package body System.Task_Primitives.Operations is --- 31,44 ---- -- This is a no tasking version of this package ! -- This package contains all the GNULL primitives that interface directly with ! -- the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. with System.Error_Reporting; package body System.Task_Primitives.Operations is diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprop-hpux-dce.adb gcc-4.4.0/gcc/ada/s-taprop-hpux-dce.adb *** gcc-4.3.3/gcc/ada/s-taprop-hpux-dce.adb Fri Nov 23 13:16:54 2007 --- gcc-4.4.0/gcc/ada/s-taprop-hpux-dce.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 33,82 **** -- This is a HP-UX DCE threads (HPUX 10) version of this package ! -- This package contains all the GNULL primitives that interface directly ! -- with the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. ! with System.Tasking.Debug; ! -- used for Known_Tasks with System.Interrupt_Management; ! -- used for Keep_Unmasked ! -- Abort_Task_Interrupt ! -- Interrupt_ID pragma Warnings (Off); with System.Interrupt_Management.Operations; - -- used for Set_Interrupt_Mask - -- All_Tasks_Mask pragma Elaborate_All (System.Interrupt_Management.Operations); - pragma Warnings (On); - with System.OS_Primitives; - -- used for Delay_Modes - - with Interfaces.C; - -- used for int - -- size_t - - with System.Task_Primitives.Interrupt_Operations; - -- used for Get_Interrupt_ID - with System.Soft_Links; - -- used for Defer/Undefer_Abort - -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. - with Ada.Unchecked_Conversion; - with Ada.Unchecked_Deallocation; - package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; --- 31,64 ---- -- This is a HP-UX DCE threads (HPUX 10) version of this package ! -- This package contains all the GNULL primitives that interface directly with ! -- the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. ! with Ada.Unchecked_Conversion; ! with Ada.Unchecked_Deallocation; + with Interfaces.C; + + with System.Tasking.Debug; with System.Interrupt_Management; ! with System.OS_Primitives; ! with System.Task_Primitives.Interrupt_Operations; pragma Warnings (Off); with System.Interrupt_Management.Operations; pragma Elaborate_All (System.Interrupt_Management.Operations); pragma Warnings (On); with System.Soft_Links; -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; *************** package body System.Task_Primitives.Oper *** 237,243 **** -- Note: mutexes and cond_variables needed per-task basis are initialized -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any ! -- status change of RTS. Therefore rasing Storage_Error in the following -- routines should be able to be handled safely. procedure Initialize_Lock --- 219,225 ---- -- Note: mutexes and cond_variables needed per-task basis are initialized -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any ! -- status change of RTS. Therefore raising Storage_Error in the following -- routines should be able to be handled safely. procedure Initialize_Lock *************** package body System.Task_Primitives.Oper *** 875,881 **** Succeeded := Result = 0; pthread_detach (T.Common.LL.Thread'Access); ! -- Detach the thread using pthread_detach, sinc DCE threads do not have -- pthread_attr_set_detachstate. Result := pthread_attr_destroy (Attributes'Access); --- 857,863 ---- Succeeded := Result = 0; pthread_detach (T.Common.LL.Thread'Access); ! -- Detach the thread using pthread_detach, since DCE threads do not have -- pthread_attr_set_detachstate. Result := pthread_attr_destroy (Attributes'Access); diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprop-irix.adb gcc-4.4.0/gcc/ada/s-taprop-irix.adb *** gcc-4.3.3/gcc/ada/s-taprop-irix.adb Fri Nov 23 13:16:54 2007 --- gcc-4.4.0/gcc/ada/s-taprop-irix.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 33,76 **** -- This is a IRIX (pthread library) version of this package ! -- This package contains all the GNULL primitives that interface directly ! -- with the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. with Interfaces.C; - -- used for int - -- size_t with System.Task_Info; - with System.Tasking.Debug; - -- used for Known_Tasks - with System.Interrupt_Management; - -- used for Keep_Unmasked - -- Abort_Task_Interrupt - -- Interrupt_ID - with System.OS_Primitives; - -- used for Delay_Modes - with System.IO; - -- used for Put_Line with System.Soft_Links; - -- used for Abort_Defer/Undefer - -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. - with Ada.Unchecked_Conversion; - with Ada.Unchecked_Deallocation; - package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; --- 31,60 ---- -- This is a IRIX (pthread library) version of this package ! -- This package contains all the GNULL primitives that interface directly with ! -- the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. ! ! with Ada.Unchecked_Conversion; ! with Ada.Unchecked_Deallocation; with Interfaces.C; with System.Task_Info; with System.Tasking.Debug; with System.Interrupt_Management; with System.OS_Primitives; with System.IO; with System.Soft_Links; -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; *************** package body System.Task_Primitives.Oper *** 233,239 **** -- Note: mutexes and cond_variables needed per-task basis are initialized -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any ! -- status change of RTS. Therefore rasing Storage_Error in the following -- routines should be able to be handled safely. procedure Initialize_Lock --- 217,223 ---- -- Note: mutexes and cond_variables needed per-task basis are initialized -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any ! -- status change of RTS. Therefore raising Storage_Error in the following -- routines should be able to be handled safely. procedure Initialize_Lock *************** package body System.Task_Primitives.Oper *** 920,932 **** Succeeded := Result = 0; ! -- The following needs significant commenting ??? ! if T.Common.Task_Info /= null then ! T.Common.Base_Priority := T.Common.Task_Info.Priority; ! Set_Priority (T, T.Common.Task_Info.Priority); ! else ! Set_Priority (T, Priority); end if; Result := pthread_attr_destroy (Attributes'Access); --- 904,919 ---- Succeeded := Result = 0; ! if Succeeded then ! -- The following needs significant commenting ??? ! ! if T.Common.Task_Info /= null then ! T.Common.Base_Priority := T.Common.Task_Info.Priority; ! Set_Priority (T, T.Common.Task_Info.Priority); ! else ! Set_Priority (T, Priority); ! end if; end if; Result := pthread_attr_destroy (Attributes'Access); diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprop-linux.adb gcc-4.4.0/gcc/ada/s-taprop-linux.adb *** gcc-4.3.3/gcc/ada/s-taprop-linux.adb Thu Dec 13 10:18:44 2007 --- gcc-4.4.0/gcc/ada/s-taprop-linux.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 33,83 **** -- This is a GNU/Linux (GNU/LinuxThreads) version of this package ! -- This package contains all the GNULL primitives that interface directly ! -- with the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. with Interfaces.C; - -- used for int - -- size_t with System.Task_Info; - -- used for Unspecified_Task_Info - with System.Tasking.Debug; - -- used for Known_Tasks - with System.Interrupt_Management; - -- used for Keep_Unmasked - -- Abort_Task_Interrupt - -- Interrupt_ID - with System.OS_Primitives; ! -- used for Delay_Modes with System.Soft_Links; - -- used for Abort_Defer/Undefer - -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. - with System.Storage_Elements; - with System.Stack_Checking.Operations; - -- Used for Invalidate_Stack_Cache and Notify_Stack_Attributes; - - with Ada.Exceptions; - -- used for Raise_Exception - -- Raise_From_Signal_Handler - -- Exception_Id - - with Ada.Unchecked_Conversion; - with Ada.Unchecked_Deallocation; - package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; --- 31,60 ---- -- This is a GNU/Linux (GNU/LinuxThreads) version of this package ! -- This package contains all the GNULL primitives that interface directly with ! -- the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. ! ! with Ada.Unchecked_Conversion; ! with Ada.Unchecked_Deallocation; with Interfaces.C; with System.Task_Info; with System.Tasking.Debug; with System.Interrupt_Management; with System.OS_Primitives; ! with System.Stack_Checking.Operations; with System.Soft_Links; -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; *************** package body System.Task_Primitives.Oper *** 89,97 **** use System.OS_Interface; use System.Parameters; use System.OS_Primitives; - use System.Storage_Elements; use System.Task_Info; ---------------- -- Local Data -- ---------------- --- 66,76 ---- use System.OS_Interface; use System.Parameters; use System.OS_Primitives; use System.Task_Info; + Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; + -- Whether to use an alternate signal stack for stack overflows + ---------------- -- Local Data -- ---------------- *************** package body System.Task_Primitives.Oper *** 181,193 **** function To_pthread_t is new Ada.Unchecked_Conversion (unsigned_long, System.OS_Interface.pthread_t); - procedure Get_Stack_Attributes - (T : Task_Id; - ISP : out System.Address; - Size : out Storage_Offset); - -- Fill ISP and Size with the Initial Stack Pointer value and the - -- thread stack size for task T. - ------------------- -- Abort_Handler -- ------------------- --- 160,165 ---- *************** package body System.Task_Primitives.Oper *** 273,284 **** -- Initialize_Lock -- --------------------- ! -- Note: mutexes and cond_variables needed per-task basis are ! -- initialized in Initialize_TCB and the Storage_Error is ! -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) ! -- used in RTS is initialized before any status change of RTS. ! -- Therefore rasing Storage_Error in the following routines ! -- should be able to be handled safely. procedure Initialize_Lock (Prio : System.Any_Priority; --- 245,255 ---- -- Initialize_Lock -- --------------------- ! -- Note: mutexes and cond_variables needed per-task basis are initialized ! -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such ! -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any ! -- status change of RTS. Therefore raising Storage_Error in the following ! -- routines should be able to be handled safely. procedure Initialize_Lock (Prio : System.Any_Priority; *************** package body System.Task_Primitives.Oper *** 294,301 **** pragma Assert (Result = 0 or else Result = ENOMEM); if Result = ENOMEM then ! Ada.Exceptions.Raise_Exception (Storage_Error'Identity, ! "Failed to allocate a lock"); end if; end Initialize_Lock; --- 265,271 ---- pragma Assert (Result = 0 or else Result = ENOMEM); if Result = ENOMEM then ! raise Storage_Error with "Failed to allocate a lock"; end if; end Initialize_Lock; *************** package body System.Task_Primitives.Oper *** 718,767 **** return T.Common.Current_Priority; end Get_Priority; - -------------------------- - -- Get_Stack_Attributes -- - -------------------------- - - procedure Get_Stack_Attributes - (T : Task_Id; - ISP : out System.Address; - Size : out Storage_Offset) - is - function pthread_getattr_np - (thread : pthread_t; - attr : System.Address) return Interfaces.C.int; - pragma Import (C, pthread_getattr_np, "pthread_getattr_np"); - - function pthread_attr_getstack - (attr : System.Address; - base : System.Address; - size : System.Address) return Interfaces.C.int; - pragma Import (C, pthread_attr_getstack, "pthread_attr_getstack"); - - Result : Interfaces.C.int; - - Attributes : aliased pthread_attr_t; - Stack_Base : aliased System.Address; - Stack_Size : aliased Storage_Offset; - - begin - Result := - pthread_getattr_np - (T.Common.LL.Thread, Attributes'Address); - pragma Assert (Result = 0); - - Result := - pthread_attr_getstack - (Attributes'Address, Stack_Base'Address, Stack_Size'Address); - pragma Assert (Result = 0); - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); - - ISP := Stack_Base + Stack_Size; - Size := Stack_Size; - end Get_Stack_Attributes; - ---------------- -- Enter_Task -- ---------------- --- 688,693 ---- *************** package body System.Task_Primitives.Oper *** 769,776 **** procedure Enter_Task (Self_ID : Task_Id) is begin if Self_ID.Common.Task_Info /= null ! and then ! Self_ID.Common.Task_Info.CPU_Affinity = No_CPU then raise Invalid_CPU_Number; end if; --- 695,701 ---- procedure Enter_Task (Self_ID : Task_Id) is begin if Self_ID.Common.Task_Info /= null ! and then Self_ID.Common.Task_Info.CPU_Affinity = No_CPU then raise Invalid_CPU_Number; end if; *************** package body System.Task_Primitives.Oper *** 791,807 **** Unlock_RTS; ! -- Determine where the task stack starts, how large it is, and let the ! -- stack checking engine know about it. ! ! declare ! Initial_SP : System.Address; ! Stack_Size : Storage_Offset; ! begin ! Get_Stack_Attributes (Self_ID, Initial_SP, Stack_Size); ! System.Stack_Checking.Operations.Notify_Stack_Attributes ! (Initial_SP, Stack_Size); ! end; end Enter_Task; -------------- --- 716,733 ---- Unlock_RTS; ! if Use_Alternate_Stack then ! declare ! Stack : aliased stack_t; ! Result : Interfaces.C.int; ! begin ! Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack; ! Stack.ss_size := Alternate_Stack_Size; ! Stack.ss_flags := 0; ! Result := sigaltstack (Stack'Access, null); ! pragma Assert (Result = 0); ! end; ! end if; end Enter_Task; -------------- *************** package body System.Task_Primitives.Oper *** 886,895 **** Priority : System.Any_Priority; Succeeded : out Boolean) is ! Attributes : aliased pthread_attr_t; ! Result : Interfaces.C.int; begin Result := pthread_attr_init (Attributes'Access); pragma Assert (Result = 0 or else Result = ENOMEM); --- 812,825 ---- Priority : System.Any_Priority; Succeeded : out Boolean) is ! Attributes : aliased pthread_attr_t; ! Adjusted_Stack_Size : Interfaces.C.size_t; ! Result : Interfaces.C.int; begin + Adjusted_Stack_Size := + Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); + Result := pthread_attr_init (Attributes'Access); pragma Assert (Result = 0 or else Result = ENOMEM); *************** package body System.Task_Primitives.Oper *** 900,906 **** Result := pthread_attr_setstacksize ! (Attributes'Access, Interfaces.C.size_t (Stack_Size)); pragma Assert (Result = 0); Result := --- 830,836 ---- Result := pthread_attr_setstacksize ! (Attributes'Access, Adjusted_Stack_Size); pragma Assert (Result = 0); Result := *************** package body System.Task_Primitives.Oper *** 918,926 **** Attributes'Access, Thread_Body_Access (Wrapper), To_Address (T)); ! pragma Assert (Result = 0 or else Result = EAGAIN); ! Succeeded := Result = 0; -- Handle Task_Info --- 848,864 ---- Attributes'Access, Thread_Body_Access (Wrapper), To_Address (T)); ! pragma Assert ! (Result = 0 or else Result = EAGAIN or else Result = ENOMEM); ! if Result /= 0 then ! Succeeded := False; ! Result := pthread_attr_destroy (Attributes'Access); ! pragma Assert (Result = 0); ! return; ! end if; ! ! Succeeded := True; -- Handle Task_Info *************** package body System.Task_Primitives.Oper *** 1163,1170 **** pragma Assert (Result = 0); SSL.Abort_Undefer.all; ! end ! if; end Suspend_Until_True; ---------------- --- 1101,1107 ---- pragma Assert (Result = 0); SSL.Abort_Undefer.all; ! end if; end Suspend_Until_True; ---------------- *************** package body System.Task_Primitives.Oper *** 1268,1273 **** --- 1205,1211 ---- old_act : aliased struct_sigaction; Tmp_Set : aliased sigset_t; Result : Interfaces.C.int; + -- Whether to use an alternate signal stack for stack overflows function State (Int : System.Interrupt_Management.Interrupt_ID) return Character; *************** package body System.Task_Primitives.Oper *** 1312,1317 **** --- 1250,1260 ---- Specific.Initialize (Environment_Task); + if Use_Alternate_Stack then + Environment_Task.Common.Task_Alternate_Stack := + Alternate_Stack'Address; + end if; + Enter_Task (Environment_Task); -- Install the abort-signal handler diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprop-lynxos.adb gcc-4.4.0/gcc/ada/s-taprop-lynxos.adb *** gcc-4.3.3/gcc/ada/s-taprop-lynxos.adb Fri Nov 23 13:16:54 2007 --- gcc-4.4.0/gcc/ada/s-taprop-lynxos.adb Thu Apr 9 23:23:07 2009 *************** *** 6,74 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is a LynxOS version of this file, adapted to make ! -- SCHED_FIFO and ceiling locking (Annex D compliance) work properly ! -- This package contains all the GNULL primitives that interface directly ! -- with the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. ! with System.Tasking.Debug; ! -- used for Known_Tasks ! with System.Interrupt_Management; ! -- used for Keep_Unmasked ! -- Abort_Task_Interrupt ! -- Interrupt_ID with System.OS_Primitives; - -- used for Delay_Modes - with System.Task_Info; - -- used for Task_Info_Type - - with Interfaces.C; - -- used for int - -- size_t with System.Soft_Links; - -- used for Abort_Defer/Undefer - -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. - with Ada.Unchecked_Deallocation; - package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; --- 6,59 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is a LynxOS version of this file, adapted to make SCHED_FIFO and ! -- ceiling locking (Annex D compliance) work properly. ! -- This package contains all the GNULL primitives that interface directly with ! -- the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. ! with Ada.Unchecked_Deallocation; ! with Interfaces.C; + with System.Tasking.Debug; + with System.Interrupt_Management; with System.OS_Primitives; with System.Task_Info; with System.Soft_Links; -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; *************** package body System.Task_Primitives.Oper *** 681,687 **** begin Result := clock_getres ! (clock_id => CLOCK_REALTIME, Res => Res'Unchecked_Access); pragma Assert (Result = 0); return To_Duration (Res); end RT_Resolution; --- 666,672 ---- begin Result := clock_getres ! (clock_id => CLOCK_REALTIME, res => Res'Unchecked_Access); pragma Assert (Result = 0); return To_Duration (Res); end RT_Resolution; *************** package body System.Task_Primitives.Oper *** 996,1002 **** Result := pthread_attr_destroy (Attributes'Access); pragma Assert (Result = 0); ! Set_Priority (T, Priority); end Create_Task; ------------------ --- 981,989 ---- Result := pthread_attr_destroy (Attributes'Access); pragma Assert (Result = 0); ! if Succeeded then ! Set_Priority (T, Priority); ! end if; end Create_Task; ------------------ diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprop-mingw.adb gcc-4.4.0/gcc/ada/s-taprop-mingw.adb *** gcc-4.3.3/gcc/ada/s-taprop-mingw.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/s-taprop-mingw.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 33,74 **** -- This is a NT (native) version of this package ! -- This package contains all the GNULL primitives that interface directly ! -- with the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. ! ! with System.Tasking.Debug; ! -- used for Known_Tasks ! with System.OS_Primitives; ! -- used for Delay_Modes with Interfaces.C; - -- used for int - -- size_t - with Interfaces.C.Strings; - -- used for Null_Ptr with System.Task_Info; - -- used for Unspecified_Task_Info - with System.Interrupt_Management; ! -- used for Initialize with System.Soft_Links; - -- used for Abort_Defer/Undefer - -- We use System.Soft_Links instead of System.Tasking.Initialization because -- the later is a higher level package that we shouldn't depend on. For -- example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. - with Ada.Unchecked_Deallocation; - package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; --- 31,60 ---- -- This is a NT (native) version of this package ! -- This package contains all the GNULL primitives that interface directly with ! -- the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. ! with Ada.Unchecked_Deallocation; with Interfaces.C; with Interfaces.C.Strings; + with System.Tasking.Debug; + with System.OS_Primitives; with System.Task_Info; with System.Interrupt_Management; ! with System.Win32.Ext; with System.Soft_Links; -- We use System.Soft_Links instead of System.Tasking.Initialization because -- the later is a higher level package that we shouldn't depend on. For -- example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; *************** package body System.Task_Primitives.Oper *** 81,86 **** --- 67,74 ---- use System.Parameters; use System.OS_Primitives; use System.Task_Info; + use System.Win32; + use System.Win32.Ext; pragma Link_With ("-Xlinker --stack=0x200000,0x1000"); -- Change the default stack size (2 MB) for tasking programs on Windows. *************** package body System.Task_Primitives.Oper *** 89,94 **** --- 77,106 ---- -- Also note that under Windows XP, we use a Windows XP extension to -- specify the stack size on a per task basis, as done under other OSes. + --------------------- + -- Local Functions -- + --------------------- + + procedure InitializeCriticalSection (pCriticalSection : access RTS_Lock); + procedure InitializeCriticalSection + (pCriticalSection : access CRITICAL_SECTION); + pragma Import + (Stdcall, InitializeCriticalSection, "InitializeCriticalSection"); + + procedure EnterCriticalSection (pCriticalSection : access RTS_Lock); + procedure EnterCriticalSection + (pCriticalSection : access CRITICAL_SECTION); + pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection"); + + procedure LeaveCriticalSection (pCriticalSection : access RTS_Lock); + procedure LeaveCriticalSection (pCriticalSection : access CRITICAL_SECTION); + pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection"); + + procedure DeleteCriticalSection (pCriticalSection : access RTS_Lock); + procedure DeleteCriticalSection + (pCriticalSection : access CRITICAL_SECTION); + pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection"); + ---------------- -- Local Data -- ---------------- *************** package body System.Task_Primitives.Oper *** 153,159 **** Succeeded : BOOL; begin Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id)); ! pragma Assert (Succeeded = True); end Set; end Specific; --- 165,171 ---- Succeeded : BOOL; begin Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id)); ! pragma Assert (Succeeded = Win32.TRUE); end Set; end Specific; *************** package body System.Task_Primitives.Oper *** 205,211 **** procedure Initialize_Cond (Cond : not null access Condition_Variable) is hEvent : HANDLE; begin ! hEvent := CreateEvent (null, True, False, Null_Ptr); pragma Assert (hEvent /= 0); Cond.all := Condition_Variable (hEvent); end Initialize_Cond; --- 217,223 ---- procedure Initialize_Cond (Cond : not null access Condition_Variable) is hEvent : HANDLE; begin ! hEvent := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr); pragma Assert (hEvent /= 0); Cond.all := Condition_Variable (hEvent); end Initialize_Cond; *************** package body System.Task_Primitives.Oper *** 221,227 **** Result : BOOL; begin Result := CloseHandle (HANDLE (Cond.all)); ! pragma Assert (Result = True); end Finalize_Cond; ----------------- --- 233,239 ---- Result : BOOL; begin Result := CloseHandle (HANDLE (Cond.all)); ! pragma Assert (Result = Win32.TRUE); end Finalize_Cond; ----------------- *************** package body System.Task_Primitives.Oper *** 232,238 **** Result : BOOL; begin Result := SetEvent (HANDLE (Cond.all)); ! pragma Assert (Result = True); end Cond_Signal; --------------- --- 244,250 ---- Result : BOOL; begin Result := SetEvent (HANDLE (Cond.all)); ! pragma Assert (Result = Win32.TRUE); end Cond_Signal; --------------- *************** package body System.Task_Primitives.Oper *** 256,262 **** -- Must reset Cond BEFORE L is unlocked Result_Bool := ResetEvent (HANDLE (Cond.all)); ! pragma Assert (Result_Bool = True); Unlock (L, Global_Lock => True); -- No problem if we are interrupted here: if the condition is signaled, --- 268,274 ---- -- Must reset Cond BEFORE L is unlocked Result_Bool := ResetEvent (HANDLE (Cond.all)); ! pragma Assert (Result_Bool = Win32.TRUE); Unlock (L, Global_Lock => True); -- No problem if we are interrupted here: if the condition is signaled, *************** package body System.Task_Primitives.Oper *** 296,302 **** -- Must reset Cond BEFORE L is unlocked Result := ResetEvent (HANDLE (Cond.all)); ! pragma Assert (Result = True); Unlock (L, Global_Lock => True); -- No problem if we are interrupted here: if the condition is signaled, --- 308,314 ---- -- Must reset Cond BEFORE L is unlocked Result := ResetEvent (HANDLE (Cond.all)); ! pragma Assert (Result = Win32.TRUE); Unlock (L, Global_Lock => True); -- No problem if we are interrupted here: if the condition is signaled, *************** package body System.Task_Primitives.Oper *** 329,335 **** if Timed_Out then Result := SetEvent (HANDLE (Cond.all)); ! pragma Assert (Result = True); end if; Status := Integer (Wait_Result); --- 341,347 ---- if Timed_Out then Result := SetEvent (HANDLE (Cond.all)); ! pragma Assert (Result = Win32.TRUE); end if; Status := Integer (Wait_Result); *************** package body System.Task_Primitives.Oper *** 377,383 **** --------------------- -- Note: mutexes and cond_variables needed per-task basis are initialized ! -- in Intialize_TCB and the Storage_Error is handled. Other mutexes (such -- as RTS_Lock, Memory_Lock...) used in the RTS is initialized before any -- status change of RTS. Therefore raising Storage_Error in the following -- routines should be able to be handled safely. --- 389,395 ---- --------------------- -- Note: mutexes and cond_variables needed per-task basis are initialized ! -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such -- as RTS_Lock, Memory_Lock...) used in the RTS is initialized before any -- status change of RTS. Therefore raising Storage_Error in the following -- routines should be able to be handled safely. *************** package body System.Task_Primitives.Oper *** 397,403 **** is pragma Unreferenced (Level); begin ! InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); end Initialize_Lock; ------------------- --- 409,415 ---- is pragma Unreferenced (Level); begin ! InitializeCriticalSection (L); end Initialize_Lock; ------------------- *************** package body System.Task_Primitives.Oper *** 411,417 **** procedure Finalize_Lock (L : not null access RTS_Lock) is begin ! DeleteCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); end Finalize_Lock; ---------------- --- 423,429 ---- procedure Finalize_Lock (L : not null access RTS_Lock) is begin ! DeleteCriticalSection (L); end Finalize_Lock; ---------------- *************** package body System.Task_Primitives.Oper *** 439,453 **** is begin if not Single_Lock or else Global_Lock then ! EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); end if; end Write_Lock; procedure Write_Lock (T : Task_Id) is begin if not Single_Lock then ! EnterCriticalSection ! (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access); end if; end Write_Lock; --- 451,464 ---- is begin if not Single_Lock or else Global_Lock then ! EnterCriticalSection (L); end if; end Write_Lock; procedure Write_Lock (T : Task_Id) is begin if not Single_Lock then ! EnterCriticalSection (T.Common.LL.L'Access); end if; end Write_Lock; *************** package body System.Task_Primitives.Oper *** 474,488 **** (L : not null access RTS_Lock; Global_Lock : Boolean := False) is begin if not Single_Lock or else Global_Lock then ! LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); end if; end Unlock; procedure Unlock (T : Task_Id) is begin if not Single_Lock then ! LeaveCriticalSection ! (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access); end if; end Unlock; --- 485,498 ---- (L : not null access RTS_Lock; Global_Lock : Boolean := False) is begin if not Single_Lock or else Global_Lock then ! LeaveCriticalSection (L); end if; end Unlock; procedure Unlock (T : Task_Id) is begin if not Single_Lock then ! LeaveCriticalSection (T.Common.LL.L'Access); end if; end Unlock; *************** package body System.Task_Primitives.Oper *** 721,727 **** begin Res := SetThreadPriority (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio))); ! pragma Assert (Res = True); if Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F' then --- 731,737 ---- begin Res := SetThreadPriority (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio))); ! pragma Assert (Res = Win32.TRUE); if Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F' then *************** package body System.Task_Primitives.Oper *** 776,782 **** -- This is because the GetCurrentThread NT call does not return the real -- thread handler but only a "pseudo" one. It is not possible to release ! -- the thread handle and free the system ressources from this "pseudo" -- handle. So we really want to keep the real thread handle set in -- System.Task_Primitives.Operations.Create_Task during thread creation. --- 786,792 ---- -- This is because the GetCurrentThread NT call does not return the real -- thread handler but only a "pseudo" one. It is not possible to release ! -- the thread handle and free the system resources from this "pseudo" -- handle. So we really want to keep the real thread handle set in -- System.Task_Primitives.Operations.Create_Task during thread creation. *************** package body System.Task_Primitives.Oper *** 882,888 **** hTask : HANDLE; TaskId : aliased DWORD; ! pTaskParameter : System.OS_Interface.PVOID; Result : DWORD; Entry_Point : PTHREAD_START_ROUTINE; --- 892,898 ---- hTask : HANDLE; TaskId : aliased DWORD; ! pTaskParameter : Win32.PVOID; Result : DWORD; Entry_Point : PTHREAD_START_ROUTINE; *************** package body System.Task_Primitives.Oper *** 913,919 **** -- Step 1: Create the thread in blocked mode if hTask = 0 then ! raise Storage_Error; end if; -- Step 2: set its TCB --- 923,930 ---- -- Step 1: Create the thread in blocked mode if hTask = 0 then ! Succeeded := False; ! return; end if; -- Step 2: set its TCB *************** package body System.Task_Primitives.Oper *** 932,938 **** -- boost. A priority boost is temporarily given by the system to a -- thread when it is taken out of a wait state. ! SetThreadPriorityBoost (hTask, DisablePriorityBoost => True); end if; -- Step 4: Handle Task_Info --- 943,949 ---- -- boost. A priority boost is temporarily given by the system to a -- thread when it is taken out of a wait state. ! SetThreadPriorityBoost (hTask, DisablePriorityBoost => Win32.TRUE); end if; -- Step 4: Handle Task_Info *************** package body System.Task_Primitives.Oper *** 979,990 **** if Self_ID.Common.LL.Thread /= 0 then -- This task has been activated. Wait for the thread to terminate ! -- then close it. this is needed to release system ressources. Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite); pragma Assert (Result /= WAIT_FAILED); Succeeded := CloseHandle (T.Common.LL.Thread); ! pragma Assert (Succeeded = True); end if; Free (Self_ID); --- 990,1001 ---- if Self_ID.Common.LL.Thread /= 0 then -- This task has been activated. Wait for the thread to terminate ! -- then close it. This is needed to release system resources. Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite); pragma Assert (Result /= WAIT_FAILED); Succeeded := CloseHandle (T.Common.LL.Thread); ! pragma Assert (Succeeded = Win32.TRUE); end if; Free (Self_ID); *************** package body System.Task_Primitives.Oper *** 1107,1113 **** -- Initialize internal condition variable ! S.CV := CreateEvent (null, True, False, Null_Ptr); pragma Assert (S.CV /= 0); end Initialize; --- 1118,1124 ---- -- Initialize internal condition variable ! S.CV := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr); pragma Assert (S.CV /= 0); end Initialize; *************** package body System.Task_Primitives.Oper *** 1125,1131 **** -- Destroy internal condition variable Result := CloseHandle (S.CV); ! pragma Assert (Result = True); end Finalize; ------------------- --- 1136,1142 ---- -- Destroy internal condition variable Result := CloseHandle (S.CV); ! pragma Assert (Result = Win32.TRUE); end Finalize; ------------------- *************** package body System.Task_Primitives.Oper *** 1178,1184 **** S.State := False; Result := SetEvent (S.CV); ! pragma Assert (Result = True); else S.State := True; end if; --- 1189,1195 ---- S.State := False; Result := SetEvent (S.CV); ! pragma Assert (Result = Win32.TRUE); else S.State := True; end if; *************** package body System.Task_Primitives.Oper *** 1227,1233 **** -- Must reset CV BEFORE L is unlocked Result_Bool := ResetEvent (S.CV); ! pragma Assert (Result_Bool = True); LeaveCriticalSection (S.L'Access); --- 1238,1244 ---- -- Must reset CV BEFORE L is unlocked Result_Bool := ResetEvent (S.CV); ! pragma Assert (Result_Bool = Win32.TRUE); LeaveCriticalSection (S.L'Access); diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprop-posix.adb gcc-4.4.0/gcc/ada/s-taprop-posix.adb *** gcc-4.3.3/gcc/ada/s-taprop-posix.adb Fri Nov 23 13:16:54 2007 --- gcc-4.4.0/gcc/ada/s-taprop-posix.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 33,80 **** -- This is a POSIX-like version of this package ! -- This package contains all the GNULL primitives that interface directly ! -- with the underlying OS. ! -- Note: this file can only be used for POSIX compliant systems that ! -- implement SCHED_FIFO and Ceiling Locking correctly. -- For configurations where SCHED_FIFO and priority ceiling are not a -- requirement, this file can also be used (e.g AiX threads) pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. ! with System.Tasking.Debug; ! -- used for Known_Tasks ! with System.Interrupt_Management; ! -- used for Keep_Unmasked ! -- Abort_Task_Interrupt ! -- Interrupt_ID with System.OS_Primitives; - -- used for Delay_Modes - with System.Task_Info; - -- used for Task_Info_Type - - with Interfaces.C; - -- used for int - -- size_t with System.Soft_Links; - -- used for Abort_Defer/Undefer - -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. - with Ada.Unchecked_Conversion; - with Ada.Unchecked_Deallocation; - package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; --- 31,65 ---- -- This is a POSIX-like version of this package ! -- This package contains all the GNULL primitives that interface directly with ! -- the underlying OS. ! -- Note: this file can only be used for POSIX compliant systems that implement ! -- SCHED_FIFO and Ceiling Locking correctly. -- For configurations where SCHED_FIFO and priority ceiling are not a -- requirement, this file can also be used (e.g AiX threads) pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. ! with Ada.Unchecked_Conversion; ! with Ada.Unchecked_Deallocation; ! with Interfaces.C; + with System.Tasking.Debug; + with System.Interrupt_Management; with System.OS_Primitives; with System.Task_Info; with System.Soft_Links; -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; *************** package body System.Task_Primitives.Oper *** 86,91 **** --- 71,79 ---- use System.Parameters; use System.OS_Primitives; + Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; + -- Whether to use an alternate signal stack for stack overflows + ---------------- -- Local Data -- ---------------- *************** package body System.Task_Primitives.Oper *** 281,290 **** --------------------- -- Note: mutexes and cond_variables needed per-task basis are ! -- initialized in Intialize_TCB and the Storage_Error is -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) -- used in RTS is initialized before any status change of RTS. ! -- Therefore rasing Storage_Error in the following routines -- should be able to be handled safely. procedure Initialize_Lock --- 269,278 ---- --------------------- -- Note: mutexes and cond_variables needed per-task basis are ! -- initialized in Initialize_TCB and the Storage_Error is -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) -- used in RTS is initialized before any status change of RTS. ! -- Therefore raising Storage_Error in the following routines -- should be able to be handled safely. procedure Initialize_Lock *************** package body System.Task_Primitives.Oper *** 811,816 **** --- 799,817 ---- end loop; Unlock_RTS; + + if Use_Alternate_Stack then + declare + Stack : aliased stack_t; + Result : Interfaces.C.int; + begin + Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack; + Stack.ss_size := Alternate_Stack_Size; + Stack.ss_flags := 0; + Result := sigaltstack (Stack'Access, null); + pragma Assert (Result = 0); + end; + end if; end Enter_Task; -------------- *************** package body System.Task_Primitives.Oper *** 945,951 **** use System.Task_Info; begin ! Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); if Stack_Base_Available then --- 946,953 ---- use System.Task_Info; begin ! Adjusted_Stack_Size := ! Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); if Stack_Base_Available then *************** package body System.Task_Primitives.Oper *** 1013,1019 **** Result := pthread_attr_destroy (Attributes'Access); pragma Assert (Result = 0); ! Set_Priority (T, Priority); end Create_Task; ------------------ --- 1015,1023 ---- Result := pthread_attr_destroy (Attributes'Access); pragma Assert (Result = 0); ! if Succeeded then ! Set_Priority (T, Priority); ! end if; end Create_Task; ------------------ *************** package body System.Task_Primitives.Oper *** 1426,1431 **** --- 1430,1440 ---- Specific.Initialize (Environment_Task); + if Use_Alternate_Stack then + Environment_Task.Common.Task_Alternate_Stack := + Alternate_Stack'Address; + end if; + Enter_Task (Environment_Task); -- Install the abort-signal handler diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprop-solaris.adb gcc-4.4.0/gcc/ada/s-taprop-solaris.adb *** gcc-4.3.3/gcc/ada/s-taprop-solaris.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/s-taprop-solaris.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 33,79 **** -- This is a Solaris (native) version of this package ! -- This package contains all the GNULL primitives that interface directly ! -- with the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. ! with System.Tasking.Debug; ! -- used for Known_Tasks ! with System.Interrupt_Management; ! -- used for Keep_Unmasked ! -- Abort_Task_Interrupt ! -- Interrupt_ID with System.OS_Primitives; ! -- used for Delay_Modes pragma Warnings (Off); with System.OS_Lib; - -- used for String_Access, Getenv - pragma Warnings (On); - with Interfaces.C; - -- used for int - -- size_t - - with System.Task_Info; - -- to initialize Task_Info for a C thread, in function Self - with System.Soft_Links; - -- used for Defer/Undefer_Abort - -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. - with Ada.Unchecked_Deallocation; - package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; --- 31,62 ---- -- This is a Solaris (native) version of this package ! -- This package contains all the GNULL primitives that interface directly with ! -- the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. ! with Ada.Unchecked_Deallocation; ! with Interfaces.C; + with System.Tasking.Debug; + with System.Interrupt_Management; with System.OS_Primitives; ! with System.Task_Info; pragma Warnings (Off); with System.OS_Lib; pragma Warnings (On); with System.Soft_Links; -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; *************** package body System.Task_Primitives.Oper *** 122,137 **** -- controls whether we emulate priority ceiling locking -- To get a scheduling close to annex D requirements, we use the real-time ! -- class provided for LWP's and map each task/thread to a specific and -- unique LWP (there is 1 thread per LWP, and 1 LWP per thread). -- The real time class can only be set when the process has root ! -- priviledges, so in the other cases, we use the normal thread scheduling -- and priority handling. Using_Real_Time_Class : Boolean := False; ! -- indicates wether the real time class is being used (i.e the process ! -- has root priviledges). Prio_Param : aliased struct_pcparms; -- Hold priority info (Real_Time) initialized during the package --- 105,120 ---- -- controls whether we emulate priority ceiling locking -- To get a scheduling close to annex D requirements, we use the real-time ! -- class provided for LWPs and map each task/thread to a specific and -- unique LWP (there is 1 thread per LWP, and 1 LWP per thread). -- The real time class can only be set when the process has root ! -- privileges, so in the other cases, we use the normal thread scheduling -- and priority handling. Using_Real_Time_Class : Boolean := False; ! -- indicates whether the real time class is being used (i.e. the process ! -- has root privileges). Prio_Param : aliased struct_pcparms; -- Hold priority info (Real_Time) initialized during the package *************** package body System.Task_Primitives.Oper *** 536,542 **** -- Note: mutexes and cond_variables needed per-task basis are initialized -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any ! -- status change of RTS. Therefore rasing Storage_Error in the following -- routines should be able to be handled safely. procedure Initialize_Lock --- 519,525 ---- -- Note: mutexes and cond_variables needed per-task basis are initialized -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any ! -- status change of RTS. Therefore raising Storage_Error in the following -- routines should be able to be handled safely. procedure Initialize_Lock *************** package body System.Task_Primitives.Oper *** 1154,1164 **** pragma Assert (Result = 0 or else Result = EINTR); end Sleep; ! -- Note that we are relying heaviliy here on GNAT represting Calendar.Time, ! -- System.Real_Time.Time, Duration, System.Real_Time.Time_Span in the same ! -- way, i.e., as a 64-bit count of nanoseconds. ! -- This allows us to always pass the timeout value as a Duration -- ??? -- We are taking liberties here with the semantics of the delays. That is, --- 1137,1148 ---- pragma Assert (Result = 0 or else Result = EINTR); end Sleep; ! -- Note that we are relying heavily here on GNAT representing ! -- Calendar.Time, System.Real_Time.Time, Duration, ! -- System.Real_Time.Time_Span in the same way, i.e., as a 64-bit count of ! -- nanoseconds. ! -- This allows us to always pass the timeout value as a Duration. -- ??? -- We are taking liberties here with the semantics of the delays. That is, diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprop-tru64.adb gcc-4.4.0/gcc/ada/s-taprop-tru64.adb *** gcc-4.3.3/gcc/ada/s-taprop-tru64.adb Fri Nov 23 13:16:54 2007 --- gcc-4.4.0/gcc/ada/s-taprop-tru64.adb Thu Apr 9 23:23:07 2009 *************** *** 6,76 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is a DEC Unix 4.0d version of this package ! -- This package contains all the GNULL primitives that interface directly ! -- with the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. ! with System.Tasking.Debug; ! -- used for Known_Tasks ! with System.Interrupt_Management; ! -- used for Keep_Unmasked ! -- Abort_Task_Interrupt ! -- Interrupt_ID with System.OS_Primitives; - -- used for Delay_Modes - with System.Task_Info; - -- used for Task_Info_Type - - with Interfaces; - -- used for Shift_Left - - with Interfaces.C; - -- used for int - -- size_t with System.Soft_Links; - -- used for Abort_Defer/Undefer - -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. - with Ada.Unchecked_Deallocation; - package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; --- 6,59 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is a Tru64 version of this package ! -- This package contains all the GNULL primitives that interface directly with ! -- the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. ! with Ada.Unchecked_Deallocation; ! with Interfaces; ! with Interfaces.C; + with System.Tasking.Debug; + with System.Interrupt_Management; with System.OS_Primitives; with System.Task_Info; with System.Soft_Links; -- We use System.Soft_Links instead of System.Tasking.Initialization -- because the later is a higher level package that we shouldn't depend on. -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; *************** package body System.Task_Primitives.Oper *** 241,247 **** -- Note: mutexes and cond_variables needed per-task basis are initialized -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any ! -- status change of RTS. Therefore rasing Storage_Error in the following -- routines should be able to be handled safely. procedure Initialize_Lock --- 224,230 ---- -- Note: mutexes and cond_variables needed per-task basis are initialized -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any ! -- status change of RTS. Therefore raising Storage_Error in the following -- routines should be able to be handled safely. procedure Initialize_Lock *************** package body System.Task_Primitives.Oper *** 948,954 **** Result := pthread_attr_destroy (Attributes'Access); pragma Assert (Result = 0); ! if T.Common.Task_Info /= null then -- ??? We're using a process-wide function to implement a task -- specific characteristic. --- 931,937 ---- Result := pthread_attr_destroy (Attributes'Access); pragma Assert (Result = 0); ! if Succeeded and then T.Common.Task_Info /= null then -- ??? We're using a process-wide function to implement a task -- specific characteristic. diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprop-vms.adb gcc-4.4.0/gcc/ada/s-taprop-vms.adb *** gcc-4.3.3/gcc/ada/s-taprop-vms.adb Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-taprop-vms.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 33,64 **** -- This is a OpenVMS/Alpha version of this package ! -- This package contains all the GNULL primitives that interface directly ! -- with the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. ! ! with System.Tasking.Debug; ! -- used for Known_Tasks ! with System.OS_Primitives; ! -- used for Delay_Modes with Interfaces.C; - -- used for int - -- size_t with System.Soft_Links; - -- used for Get_Exc_Stack_Addr - -- Abort_Defer/Undefer - with System.Aux_DEC; - -- used for Short_Address - - with Ada.Unchecked_Conversion; - with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is --- 31,52 ---- -- This is a OpenVMS/Alpha version of this package ! -- This package contains all the GNULL primitives that interface directly with ! -- the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. ! with Ada.Unchecked_Conversion; ! with Ada.Unchecked_Deallocation; with Interfaces.C; + with System.Tasking.Debug; + with System.OS_Primitives; with System.Soft_Links; with System.Aux_DEC; package body System.Task_Primitives.Operations is *************** package body System.Task_Primitives.Oper *** 141,150 **** ----------------------- function To_Task_Id is ! new Ada.Unchecked_Conversion (System.Address, Task_Id); function To_Address is ! new Ada.Unchecked_Conversion (Task_Id, System.Address); function Get_Exc_Stack_Addr return Address; -- Replace System.Soft_Links.Get_Exc_Stack_Addr_NT --- 129,140 ---- ----------------------- function To_Task_Id is ! new Ada.Unchecked_Conversion ! (System.Task_Primitives.Task_Address, Task_Id); function To_Address is ! new Ada.Unchecked_Conversion ! (Task_Id, System.Task_Primitives.Task_Address); function Get_Exc_Stack_Addr return Address; -- Replace System.Soft_Links.Get_Exc_Stack_Addr_NT *************** package body System.Task_Primitives.Oper *** 200,206 **** -- Note: mutexes and cond_variables needed per-task basis are initialized -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any ! -- status change of RTS. Therefore rasing Storage_Error in the following -- routines should be able to be handled safely. procedure Initialize_Lock --- 190,196 ---- -- Note: mutexes and cond_variables needed per-task basis are initialized -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any ! -- status change of RTS. Therefore raising Storage_Error in the following -- routines should be able to be handled safely. procedure Initialize_Lock *************** package body System.Task_Primitives.Oper *** 529,535 **** if Time /= 0.0 or else Mode /= Relative then Sleep_Time := To_OS_Time (Time, Mode); ! if Mode = Relative or else OS_Clock < Sleep_Time then Self_ID.Common.State := Delay_Sleep; Self_ID.Common.LL.AST_Pending := True; --- 519,525 ---- if Time /= 0.0 or else Mode /= Relative then Sleep_Time := To_OS_Time (Time, Mode); ! if Mode = Relative or else OS_Clock <= Sleep_Time then Self_ID.Common.State := Delay_Sleep; Self_ID.Common.LL.AST_Pending := True; *************** package body System.Task_Primitives.Oper *** 830,836 **** begin -- Since the initial signal mask of a thread is inherited from the ! -- creator, we need to set our local signal mask mask all signals -- during the creation operation, to make sure the new thread is -- not disturbed by signals before it has set its own Task_Id. --- 820,826 ---- begin -- Since the initial signal mask of a thread is inherited from the ! -- creator, we need to set our local signal mask to mask all signals -- during the creation operation, to make sure the new thread is -- not disturbed by signals before it has set its own Task_Id. diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprop-vxworks.adb gcc-4.4.0/gcc/ada/s-taprop-vxworks.adb *** gcc-4.3.3/gcc/ada/s-taprop-vxworks.adb Thu Dec 13 10:19:19 2007 --- gcc-4.4.0/gcc/ada/s-taprop-vxworks.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 33,66 **** -- This is the VxWorks version of this package ! -- This package contains all the GNULL primitives that interface directly ! -- with the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. ! ! with System.Tasking.Debug; ! -- used for Known_Tasks ! with System.Interrupt_Management; ! -- used for Keep_Unmasked ! -- Abort_Task_Interrupt ! -- Signal_ID ! -- Initialize_Interrupts with Interfaces.C; ! with System.Soft_Links; ! -- used for Abort_Defer/Undefer -- We use System.Soft_Links instead of System.Tasking.Initialization ! -- because the later is a higher level package that we shouldn't depend on. ! -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. ! with Ada.Unchecked_Conversion; ! with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is --- 31,58 ---- -- This is the VxWorks version of this package ! -- This package contains all the GNULL primitives that interface directly with ! -- the underlying OS. pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. ! with Ada.Unchecked_Conversion; ! with Ada.Unchecked_Deallocation; with Interfaces.C; ! with System.Tasking.Debug; ! with System.Interrupt_Management; + with System.Soft_Links; -- We use System.Soft_Links instead of System.Tasking.Initialization ! -- because the later is a higher level package that we shouldn't depend ! -- on. For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. ! with System.VxWorks.Ext; package body System.Task_Primitives.Operations is *************** package body System.Task_Primitives.Oper *** 70,75 **** --- 62,68 ---- use System.Tasking; use System.OS_Interface; use System.Parameters; + use type System.VxWorks.Ext.t_id; use type Interfaces.C.int; subtype int is System.OS_Interface.int; *************** package body System.Task_Primitives.Oper *** 540,546 **** else -- If Ticks = int'last, it was most probably truncated so -- let's make another round after recomputing Ticks from ! -- the the absolute time. if Ticks /= int'Last then Timedout := True; --- 533,539 ---- else -- If Ticks = int'last, it was most probably truncated so -- let's make another round after recomputing Ticks from ! -- the absolute time. if Ticks /= int'Last then Timedout := True; *************** package body System.Task_Primitives.Oper *** 660,666 **** -- If Ticks = int'last, it was most probably truncated -- so let's make another round after recomputing Ticks ! -- from the the absolute time. if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then Timedout := True; --- 653,659 ---- -- If Ticks = int'last, it was most probably truncated -- so let's make another round after recomputing Ticks ! -- from the absolute time. if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then Timedout := True; *************** package body System.Task_Primitives.Oper *** 754,762 **** pragma Atomic_Components (Prio_Array_Type); Prio_Array : Prio_Array_Type; ! -- Global array containing the id of the currently running task for ! -- each priority. Note that we assume that we are on a single processor ! -- with run-till-blocked scheduling. procedure Set_Priority (T : Task_Id; --- 747,755 ---- pragma Atomic_Components (Prio_Array_Type); Prio_Array : Prio_Array_Type; ! -- Global array containing the id of the currently running task for each ! -- priority. Note that we assume that we are on a single processor with ! -- run-till-blocked scheduling. procedure Set_Priority (T : Task_Id; *************** package body System.Task_Primitives.Oper *** 776,782 **** and then Loss_Of_Inheritance and then Prio < T.Common.Current_Priority then ! -- Annex D requirement (RM D.2.2(9)) -- If the task drops its priority due to the loss of inherited -- priority, it is added at the head of the ready queue for its --- 769,775 ---- and then Loss_Of_Inheritance and then Prio < T.Common.Current_Priority then ! -- Annex D requirement (RM D.2.2(9)): -- If the task drops its priority due to the loss of inherited -- priority, it is added at the head of the ready queue for its *************** package body System.Task_Primitives.Oper *** 852,858 **** Unlock_RTS; ! -- If stack checking is enabled set the stack limit for this task. if Set_Stack_Limit_Hook /= null then Set_Stack_Limit_Hook.all; end if; --- 845,852 ---- Unlock_RTS; ! -- If stack checking is enabled, set the stack limit for this task ! if Set_Stack_Limit_Hook /= null then Set_Stack_Limit_Hook.all; end if; *************** package body System.Task_Primitives.Oper *** 985,994 **** Succeeded := False; else Succeeded := True; end if; - - Task_Creation_Hook (T.Common.LL.Thread); - Set_Priority (T, Priority); end Create_Task; ------------------ --- 979,987 ---- Succeeded := False; else Succeeded := True; + Task_Creation_Hook (T.Common.LL.Thread); + Set_Priority (T, Priority); end if; end Create_Task; ------------------ *************** package body System.Task_Primitives.Oper *** 1077,1082 **** --- 1070,1078 ---- -------------- procedure Finalize (S : in out Suspension_Object) is + pragma Unmodified (S); + -- S may be modified on other targets, but not on VxWorks + Result : STATUS; begin diff -Nrcpad gcc-4.3.3/gcc/ada/s-taprop.ads gcc-4.4.0/gcc/ada/s-taprop.ads *** gcc-4.3.3/gcc/ada/s-taprop.ads Wed Sep 26 10:41:47 2007 --- gcc-4.4.0/gcc/ada/s-taprop.ads Thu Apr 9 23:23:07 2009 *************** *** 6,47 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package contains all the GNULL primitives that interface directly ! -- with the underlying OS. with System.Parameters; - -- used for Size_Type - with System.Tasking; - -- used for Task_Id - with System.OS_Interface; - -- used for Thread_Id package System.Task_Primitives.Operations is pragma Preelaborate; --- 6,40 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package contains all the GNULL primitives that interface directly with ! -- the underlying OS. with System.Parameters; with System.Tasking; with System.OS_Interface; package System.Task_Primitives.Operations is pragma Preelaborate; *************** package System.Task_Primitives.Operation *** 255,261 **** -- It is not clear what to do about ceiling violations due to RTS calls -- done at interrupt priority. In general, it is not acceptable to give ! -- all RTS locks interrupt priority, since that whould give terrible -- performance on systems where this has the effect of masking hardware -- interrupts, though we could get away allowing Interrupt_Priority'last -- where we are layered on an OS that does not allow us to mask interrupts. --- 248,254 ---- -- It is not clear what to do about ceiling violations due to RTS calls -- done at interrupt priority. In general, it is not acceptable to give ! -- all RTS locks interrupt priority, since that would give terrible -- performance on systems where this has the effect of masking hardware -- interrupts, though we could get away allowing Interrupt_Priority'last -- where we are layered on an OS that does not allow us to mask interrupts. *************** package System.Task_Primitives.Operation *** 418,424 **** -- thread of control in the RTS. Since we intend these routines to be used -- for implementing the Single_Lock RTS, Lock_RTS should follow the first -- Defer_Abort operation entering RTS. In the same fashion Unlock_RTS ! -- should preceed the last Undefer_Abort exiting RTS. -- -- These routines also replace the functions Lock/Unlock_All_Tasks_List --- 411,417 ---- -- thread of control in the RTS. Since we intend these routines to be used -- for implementing the Single_Lock RTS, Lock_RTS should follow the first -- Defer_Abort operation entering RTS. In the same fashion Unlock_RTS ! -- should precede the last Undefer_Abort exiting RTS. -- -- These routines also replace the functions Lock/Unlock_All_Tasks_List diff -Nrcpad gcc-4.3.3/gcc/ada/s-tarest.adb gcc-4.4.0/gcc/ada/s-tarest.adb *** gcc-4.3.3/gcc/ada/s-tarest.adb Wed Sep 26 10:41:24 2007 --- gcc-4.4.0/gcc/ada/s-tarest.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** pragma Polling (Off); *** 46,76 **** -- tasking operations. It causes infinite loops and other problems. with Ada.Exceptions; - -- used for Exception_Occurrence with System.Task_Primitives.Operations; - -- used for Enter_Task - -- Write_Lock - -- Unlock - -- Wakeup - -- Get_Priority - - with System.Soft_Links; - -- used for the non-tasking routines (*_NT) that refer to global data. - -- They are needed here before the tasking run time has been elaborated. - -- used for Create_TSD - -- This package also provides initialization routines for task specific data. - -- The GNARL must call these to be sure that all non-tasking - -- Ada constructs will work. - with System.Soft_Links.Tasking; - -- Used for Init_Tasking_Soft_Links - with System.Secondary_Stack; - -- used for SS_Init; - with System.Storage_Elements; ! -- used for Storage_Array; package body System.Tasking.Restricted.Stages is --- 44,61 ---- -- tasking operations. It causes infinite loops and other problems. with Ada.Exceptions; with System.Task_Primitives.Operations; with System.Soft_Links.Tasking; with System.Secondary_Stack; with System.Storage_Elements; ! ! with System.Soft_Links; ! -- Used for the non-tasking routines (*_NT) that refer to global data. They ! -- are needed here before the tasking run time has been elaborated. used for ! -- Create_TSD This package also provides initialization routines for task ! -- specific data. The GNARL must call these to be sure that all non-tasking ! -- Ada constructs will work. package body System.Tasking.Restricted.Stages is *************** package body System.Tasking.Restricted.S *** 213,219 **** -- a task terminating due to completing the last statement of its body. -- If the task terminates because of an exception raised by the -- execution of its task body, then Cause is set to Unhandled_Exception. ! -- Aborts are not allowed in the restriced profile to which this file -- belongs. EO : Exception_Occurrence; --- 198,204 ---- -- a task terminating due to completing the last statement of its body. -- If the task terminates because of an exception raised by the -- execution of its task body, then Cause is set to Unhandled_Exception. ! -- Aborts are not allowed in the restricted profile to which this file -- belongs. EO : Exception_Occurrence; diff -Nrcpad gcc-4.3.3/gcc/ada/s-tarest.ads gcc-4.4.0/gcc/ada/s-tarest.ads *** gcc-4.3.3/gcc/ada/s-tarest.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-tarest.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 46,55 **** -- System.Protected_Objects.Single_Entry with System.Task_Info; - -- used for Task_Info_Type - with System.Parameters; - -- used for Size_Type package System.Tasking.Restricted.Stages is pragma Elaborate_Body; --- 44,50 ---- *************** package System.Tasking.Restricted.Stages *** 161,167 **** -- single argument to State. -- -- Elaborated is a pointer to a Boolean that must be set to true on exit ! -- if the task could be sucessfully elaborated. -- -- Chain is a linked list of task that needs to be created. On exit, -- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID will be --- 156,162 ---- -- single argument to State. -- -- Elaborated is a pointer to a Boolean that must be set to true on exit ! -- if the task could be successfully elaborated. -- -- Chain is a linked list of task that needs to be created. On exit, -- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID will be diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasdeb.adb gcc-4.4.0/gcc/ada/s-tasdeb.adb *** gcc-4.3.3/gcc/ada/s-tasdeb.adb Wed Sep 26 10:41:47 2007 --- gcc-4.4.0/gcc/ada/s-tasdeb.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 40,45 **** --- 38,44 ---- -- in both normal and restricted (ravenscar) environments. with System.CRTL; + with System.Task_Primitives; with System.Task_Primitives.Operations; with Ada.Unchecked_Conversion; *************** package body System.Tasking.Debug is *** 48,54 **** package STPO renames System.Task_Primitives.Operations; function To_Integer is new ! Ada.Unchecked_Conversion (Task_Id, System.Address); type Trace_Flag_Set is array (Character) of Boolean; --- 47,53 ---- package STPO renames System.Task_Primitives.Operations; function To_Integer is new ! Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address); type Trace_Flag_Set is array (Character) of Boolean; diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasdeb.ads gcc-4.4.0/gcc/ada/s-tasdeb.ads *** gcc-4.3.3/gcc/ada/s-tasdeb.ads Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/s-tasdeb.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package System.Tasking.Debug is *** 61,67 **** -- task specific state. function Get_User_State return Long_Integer; ! -- Return the user state for the current task. ------------------------- -- General GDB support -- --- 59,65 ---- -- task specific state. function Get_User_State return Long_Integer; ! -- Return the user state for the current task ------------------------- -- General GDB support -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasinf-irix.ads gcc-4.4.0/gcc/ada/s-tasinf-irix.ads *** gcc-4.3.3/gcc/ada/s-tasinf-irix.ads Mon Sep 5 07:46:06 2005 --- gcc-4.4.0/gcc/ada/s-tasinf-irix.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasinf-linux.adb gcc-4.4.0/gcc/ada/s-tasinf-linux.adb *** gcc-4.3.3/gcc/ada/s-tasinf-linux.adb Thu Dec 13 10:18:44 2007 --- gcc-4.4.0/gcc/ada/s-tasinf-linux.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasinf-linux.ads gcc-4.4.0/gcc/ada/s-tasinf-linux.ads *** gcc-4.3.3/gcc/ada/s-tasinf-linux.ads Thu Dec 13 10:18:44 2007 --- gcc-4.4.0/gcc/ada/s-tasinf-linux.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 41,47 **** -- This unit may be used directly from an application program by providing -- an appropriate WITH, and the interface can be expected to remain stable. ! -- This is the GNU/Linux version of this module. with System.OS_Interface; --- 39,45 ---- -- This unit may be used directly from an application program by providing -- an appropriate WITH, and the interface can be expected to remain stable. ! -- This is the GNU/Linux version of this module with System.OS_Interface; diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasinf-mingw.adb gcc-4.4.0/gcc/ada/s-tasinf-mingw.adb *** gcc-4.3.3/gcc/ada/s-tasinf-mingw.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/s-tasinf-mingw.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 33,38 **** --- 31,42 ---- -- This is the Windows (native) version of this module + with System.OS_Interface; + pragma Unreferenced (System.OS_Interface); + -- System.OS_Interface is not used today, but the protocol between the + -- run-time and the binder is that any tasking application uses + -- System.OS_Interface, so notify the binder with this "with" clause. + package body System.Task_Info is N_CPU : Natural := 0; *************** package body System.Task_Info is *** 48,56 **** begin if N_CPU = 0 then declare ! SI : aliased System.OS_Interface.SYSTEM_INFO; begin ! System.OS_Interface.GetSystemInfo (SI'Access); N_CPU := Positive (SI.dwNumberOfProcessors); end; end if; --- 52,60 ---- begin if N_CPU = 0 then declare ! SI : aliased Win32.SYSTEM_INFO; begin ! Win32.GetSystemInfo (SI'Access); N_CPU := Positive (SI.dwNumberOfProcessors); end; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasinf-mingw.ads gcc-4.4.0/gcc/ada/s-tasinf-mingw.ads *** gcc-4.3.3/gcc/ada/s-tasinf-mingw.ads Tue Aug 14 08:44:02 2007 --- gcc-4.4.0/gcc/ada/s-tasinf-mingw.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 41,56 **** -- This unit may be used directly from an application program by providing -- an appropriate WITH, and the interface can be expected to remain stable. ! -- This is the Windows (native) version of this module. ! with System.OS_Interface; package System.Task_Info is pragma Preelaborate; pragma Elaborate_Body; -- To ensure that a body is allowed ! use type System.OS_Interface.ProcessorId; -- Windows provides a way to define the ideal processor to use for a given -- thread. The ideal processor is not necessarily the one that will be used --- 39,54 ---- -- This unit may be used directly from an application program by providing -- an appropriate WITH, and the interface can be expected to remain stable. ! -- This is the Windows (native) version of this module ! with System.Win32; package System.Task_Info is pragma Preelaborate; pragma Elaborate_Body; -- To ensure that a body is allowed ! use type System.Win32.ProcessorId; -- Windows provides a way to define the ideal processor to use for a given -- thread. The ideal processor is not necessarily the one that will be used *************** package System.Task_Info is *** 80,86 **** -- Thread Attributes -- ----------------------- ! subtype CPU_Number is System.OS_Interface.ProcessorId; Any_CPU : constant CPU_Number := -1; --- 78,84 ---- -- Thread Attributes -- ----------------------- ! subtype CPU_Number is System.Win32.ProcessorId; Any_CPU : constant CPU_Number := -1; diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasinf-solaris.adb gcc-4.4.0/gcc/ada/s-tasinf-solaris.adb *** gcc-4.3.3/gcc/ada/s-tasinf-solaris.adb Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-tasinf-solaris.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasinf-solaris.ads gcc-4.4.0/gcc/ada/s-tasinf-solaris.ads *** gcc-4.3.3/gcc/ada/s-tasinf-solaris.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-tasinf-solaris.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasinf-tru64.ads gcc-4.4.0/gcc/ada/s-tasinf-tru64.ads *** gcc-4.3.3/gcc/ada/s-tasinf-tru64.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-tasinf-tru64.ads Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- S p e c -- -- (Compiler Interface) -- -- -- ! -- Copyright (C) 1998-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- S p e c -- -- (Compiler Interface) -- -- -- ! -- Copyright (C) 1998-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasinf.adb gcc-4.4.0/gcc/ada/s-tasinf.adb *** gcc-4.3.3/gcc/ada/s-tasinf.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-tasinf.adb Thu Apr 9 23:23:07 2009 *************** *** 7,31 **** -- B o d y -- -- (Compiler Interface) -- -- -- ! -- Copyright (C) 1998-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 7,29 ---- -- B o d y -- -- (Compiler Interface) -- -- -- ! -- Copyright (C) 1998-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasinf.ads gcc-4.4.0/gcc/ada/s-tasinf.ads *** gcc-4.3.3/gcc/ada/s-tasinf.ads Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-tasinf.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasini.adb gcc-4.4.0/gcc/ada/s-tasini.adb *** gcc-4.3.3/gcc/ada/s-tasini.adb Tue Aug 14 08:49:56 2007 --- gcc-4.4.0/gcc/ada/s-tasini.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 32,69 **** ------------------------------------------------------------------------------ pragma Style_Checks (All_Checks); ! -- Turn off subprogram alpha ordering check, since we group soft link ! -- bodies and dummy soft link bodies together separately in this unit. pragma Polling (Off); ! -- Turn polling off for this package. We don't need polling during any ! -- of the routines in this package, and more to the point, if we try ! -- to poll it can cause infinite loops. with Ada.Exceptions; - -- Used for Exception_Occurrence_Access with System.Task_Primitives; - -- Used for Lock - with System.Task_Primitives.Operations; - -- Used for Set_Priority - -- Write_Lock - -- Unlock - -- Initialize_Lock - with System.Soft_Links; - -- Used for the non-tasking routines (*_NT) that refer to global data. - -- They are needed here before the tasking run time has been elaborated. - with System.Soft_Links.Tasking; - -- Used for Init_Tasking_Soft_Links - with System.Tasking.Debug; - -- Used for Trace - with System.Parameters; - -- used for Single_Lock package body System.Tasking.Initialization is --- 30,51 ---- ------------------------------------------------------------------------------ pragma Style_Checks (All_Checks); ! -- Turn off subprogram alpha ordering check, since we group soft link bodies ! -- and dummy soft link bodies together separately in this unit. pragma Polling (Off); ! -- Turn polling off for this package. We don't need polling during any of the ! -- routines in this package, and more to the point, if we try to poll it can ! -- cause infinite loops. with Ada.Exceptions; with System.Task_Primitives; with System.Task_Primitives.Operations; with System.Soft_Links; with System.Soft_Links.Tasking; with System.Tasking.Debug; with System.Parameters; package body System.Tasking.Initialization is *************** package body System.Tasking.Initializati *** 403,409 **** -- should not be necessary here, if Abort_Task is implemented correctly, -- since Abort_Task should include the effect of Wakeup. However, the -- above call was in earlier versions of this file, and at least for ! -- some targets Abort_Task has not beek doing Wakeup. It should not -- hurt to uncomment the above call, until the error is corrected for -- all targets. --- 385,391 ---- -- should not be necessary here, if Abort_Task is implemented correctly, -- since Abort_Task should include the effect of Wakeup. However, the -- above call was in earlier versions of this file, and at least for ! -- some targets Abort_Task has not been doing Wakeup. It should not -- hurt to uncomment the above call, until the error is corrected for -- all targets. *************** package body System.Tasking.Initializati *** 418,424 **** -- and let it decide if it wants to complete the aborted construct -- immediately. ! -- Note that the effect of the lowl-level Abort_Task is not persistent. -- If the target task is not blocked, this wakeup will be missed. -- We don't bother calling Abort_Task if this task is aborting itself, --- 400,406 ---- -- and let it decide if it wants to complete the aborted construct -- immediately. ! -- Note that the effect of the low-level Abort_Task is not persistent. -- If the target task is not blocked, this wakeup will be missed. -- We don't bother calling Abort_Task if this task is aborting itself, *************** package body System.Tasking.Initializati *** 429,435 **** -- Note that an earlier version of this code had some false reasoning -- about being able to reliably wake up a task that had suspended on ! -- a blocking system call that does not atomically relase the task's -- lock (e.g., UNIX nanosleep, which we once thought could be used to -- implement delays). That still left the possibility of missed -- wakeups. --- 411,417 ---- -- Note that an earlier version of this code had some false reasoning -- about being able to reliably wake up a task that had suspended on ! -- a blocking system call that does not atomically release the task's -- lock (e.g., UNIX nanosleep, which we once thought could be used to -- implement delays). That still left the possibility of missed -- wakeups. diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasini.ads gcc-4.4.0/gcc/ada/s-tasini.ads *** gcc-4.3.3/gcc/ada/s-tasini.ads Wed Jun 6 10:14:59 2007 --- gcc-4.4.0/gcc/ada/s-tasini.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package System.Tasking.Initialization is *** 80,86 **** -- nested. The symptom of over-deferring abort is that an exception may -- fail to be raised, or an abort may fail to take place. ! -- Therefore, there are two sets of the inlinable defer/undefer routines, -- which are the ones to be used inside GNARL. One set allows nesting. The -- other does not. People who maintain the GNARL should try to avoid using -- the nested versions, or at least look very critically at the places --- 78,84 ---- -- nested. The symptom of over-deferring abort is that an exception may -- fail to be raised, or an abort may fail to take place. ! -- Therefore, there are two sets of the inlineable defer/undefer routines, -- which are the ones to be used inside GNARL. One set allows nesting. The -- other does not. People who maintain the GNARL should try to avoid using -- the nested versions, or at least look very critically at the places *************** package System.Tasking.Initialization is *** 98,105 **** -- internal calls to the tasking runtime system assume abort is already -- deferred, and do not modify the deferral level. ! -- There is also a set of non-linable defer/undefer routines, for direct ! -- call from the compiler. These are not in-lineable because they may need -- to be called via pointers ("soft links"). For the sake of efficiency, -- the version with Self_ID as parameter should used wherever possible. -- These are all nestable. --- 96,103 ---- -- internal calls to the tasking runtime system assume abort is already -- deferred, and do not modify the deferral level. ! -- There is also a set of non-inlineable defer/undefer routines, for direct ! -- call from the compiler. These are not inlineable because they may need -- to be called via pointers ("soft links"). For the sake of efficiency, -- the version with Self_ID as parameter should used wherever possible. -- These are all nestable. *************** package System.Tasking.Initialization is *** 137,143 **** procedure Change_Base_Priority (T : Task_Id); -- Change the base priority of T. Has to be called with the affected ! -- task's ATCB write-locked. May temporariliy release the lock. ---------------------- -- Task Lock/Unlock -- --- 135,141 ---- procedure Change_Base_Priority (T : Task_Id); -- Change the base priority of T. Has to be called with the affected ! -- task's ATCB write-locked. May temporarily release the lock. ---------------------- -- Task Lock/Unlock -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-taskin.adb gcc-4.4.0/gcc/ada/s-taskin.adb *** gcc-4.3.3/gcc/ada/s-taskin.adb Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/s-taskin.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 32,50 **** ------------------------------------------------------------------------------ pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. ! with System.Task_Primitives.Operations; ! -- used for Self with System.Storage_Elements; - -- Needed for initializing Stack_Info.Size package body System.Tasking is package STPO renames System.Task_Primitives.Operations; --------------------- -- Detect_Blocking -- --------------------- --- 30,60 ---- ------------------------------------------------------------------------------ pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. ! with Ada.Unchecked_Deallocation; + with System.Task_Primitives.Operations; with System.Storage_Elements; package body System.Tasking is package STPO renames System.Task_Primitives.Operations; + ---------------------------- + -- Free_Entry_Names_Array -- + ---------------------------- + + procedure Free_Entry_Names_Array (Obj : in out Entry_Names_Array) is + procedure Free_String is new + Ada.Unchecked_Deallocation (String, String_Access); + begin + for Index in Obj'Range loop + Free_String (Obj (Index)); + end loop; + end Free_Entry_Names_Array; + --------------------- -- Detect_Blocking -- --------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/s-taskin.ads gcc-4.4.0/gcc/ada/s-taskin.ads *** gcc-4.3.3/gcc/ada/s-taskin.ads Tue Aug 14 08:50:09 2007 --- gcc-4.4.0/gcc/ada/s-taskin.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 37,61 **** -- Any changes to this interface may require corresponding compiler changes. with Ada.Exceptions; ! -- Used for Exception_Id ! -- Exception_Occurrence with System.Parameters; - -- used for Size_Type - with System.Task_Info; - -- used for Task_Info_Type - with System.Soft_Links; - -- used for TSD - with System.Task_Primitives; - -- used for Private_Data - with System.Stack_Usage; - -- used for Stack_Analyzer - - with Ada.Unchecked_Conversion; package System.Tasking is pragma Preelaborate; --- 35,47 ---- -- Any changes to this interface may require corresponding compiler changes. with Ada.Exceptions; ! with Ada.Unchecked_Conversion; with System.Parameters; with System.Task_Info; with System.Soft_Links; with System.Task_Primitives; with System.Stack_Usage; package System.Tasking is pragma Preelaborate; *************** package System.Tasking is *** 72,78 **** -- Never undefer abort while holding a lock -- Overlapping critical sections must be properly nested, and locks must ! -- be released in LIFO order. e.g., the following is not allowed: -- Lock (X); -- ... --- 58,64 ---- -- Never undefer abort while holding a lock -- Overlapping critical sections must be properly nested, and locks must ! -- be released in LIFO order. E.g., the following is not allowed: -- Lock (X); -- ... *************** package System.Tasking is *** 118,123 **** --- 104,110 ---- type Ada_Task_Control_Block; type Task_Id is access all Ada_Task_Control_Block; + for Task_Id'Size use System.Task_Primitives.Task_Address_Size; Null_Task : constant Task_Id; *************** package System.Tasking is *** 129,137 **** -- from the run-time system. function To_Task_Id is ! new Ada.Unchecked_Conversion (System.Address, Task_Id); function To_Address is ! new Ada.Unchecked_Conversion (Task_Id, System.Address); ----------------------- -- Enumeration types -- --- 116,126 ---- -- from the run-time system. function To_Task_Id is ! new Ada.Unchecked_Conversion ! (System.Task_Primitives.Task_Address, Task_Id); function To_Address is ! new Ada.Unchecked_Conversion ! (Task_Id, System.Task_Primitives.Task_Address); ----------------------- -- Enumeration types -- *************** package System.Tasking is *** 246,251 **** --- 235,253 ---- type Task_Entry_Queue_Array is array (Task_Entry_Index range <>) of Entry_Queue; + -- A data structure which contains the string names of entries and entry + -- family members. + + type String_Access is access all String; + + type Entry_Names_Array is + array (Entry_Index range <>) of String_Access; + + type Entry_Names_Array_Access is access all Entry_Names_Array; + + procedure Free_Entry_Names_Array (Obj : in out Entry_Names_Array); + -- Deallocate all string names contained in an entry names array + ---------------------------------- -- Entry_Call_Record definition -- ---------------------------------- *************** package System.Tasking is *** 352,358 **** -- Abnormal means that the task terminates because it is being aborted -- handled_Exception means that the task terminates because of exception ! -- raised by by the execution of its task_body. type Termination_Handler is access protected procedure (Cause : Cause_Of_Termination; --- 354,360 ---- -- Abnormal means that the task terminates because it is being aborted -- handled_Exception means that the task terminates because of exception ! -- raised by the execution of its task_body. type Termination_Handler is access protected procedure (Cause : Cause_Of_Termination; *************** package System.Tasking is *** 450,468 **** -- and rendezvous. -- -- Ada 95 notes: In Ada 95, this field will be transferred to the ! -- Priority field of an Entry_Calls component when an entry call ! -- is initiated. The Priority of the Entry_Calls component will not ! -- change for the duration of the call. The accepting task can ! -- use it to boost its own priority without fear of its changing in ! -- the meantime. -- ! -- This can safely be used in the priority ordering ! -- of entry queues. Once a call is queued, its priority does not ! -- change. -- ! -- Since an entry call cannot be made while executing ! -- a protected action, the priority of a task will never reflect a ! -- priority ceiling change at the point of an entry call. -- -- Protection: Only written by Self, and only accessed when Acceptor -- accepts an entry or when Created activates, at which points Self is --- 452,468 ---- -- and rendezvous. -- -- Ada 95 notes: In Ada 95, this field will be transferred to the ! -- Priority field of an Entry_Calls component when an entry call is ! -- initiated. The Priority of the Entry_Calls component will not change ! -- for the duration of the call. The accepting task can use it to boost ! -- its own priority without fear of its changing in the meantime. -- ! -- This can safely be used in the priority ordering of entry queues. ! -- Once a call is queued, its priority does not change. -- ! -- Since an entry call cannot be made while executing a protected ! -- action, the priority of a task will never reflect a priority ceiling ! -- change at the point of an entry call. -- -- Protection: Only written by Self, and only accessed when Acceptor -- accepts an entry or when Created activates, at which points Self is *************** package System.Tasking is *** 476,483 **** -- can be read/written from protected interrupt handlers. Task_Image : String (1 .. System.Parameters.Max_Task_Image_Length); ! -- Hold a string that provides a readable id for task, ! -- built from the variable of which it is a value or component. Task_Image_Len : Natural; -- Actual length of Task_Image --- 476,483 ---- -- can be read/written from protected interrupt handlers. Task_Image : String (1 .. System.Parameters.Max_Task_Image_Length); ! -- Hold a string that provides a readable id for task, built from the ! -- variable of which it is a value or component. Task_Image_Len : Natural; -- Actual length of Task_Image *************** package System.Tasking is *** 498,509 **** Task_Arg : System.Address; -- The argument to task procedure. Provide a handle for discriminant ! -- information -- -- Protection: Part of the synchronization between Self and Activator. -- Activator writes it, once, before Self starts executing. Thereafter, -- Self only reads it. Task_Entry_Point : Task_Procedure_Access; -- Information needed to call the procedure containing the code for -- the body of this task. --- 498,514 ---- Task_Arg : System.Address; -- The argument to task procedure. Provide a handle for discriminant ! -- information. -- -- Protection: Part of the synchronization between Self and Activator. -- Activator writes it, once, before Self starts executing. Thereafter, -- Self only reads it. + Task_Alternate_Stack : System.Address; + -- The address of the alternate signal stack for this task, if any + -- + -- Protection: Only accessed by Self + Task_Entry_Point : Task_Procedure_Access; -- Information needed to call the procedure containing the code for -- the body of this task. *************** package System.Tasking is *** 609,618 **** -- Restricted_Ada_Task_Control_Block -- --------------------------------------- ! -- This type should only be used by the restricted GNARLI and by ! -- restricted GNULL implementations to allocate an ATCB (see ! -- System.Task_Primitives.Operations.New_ATCB) that will take ! -- significantly less memory. -- Note that the restricted GNARLI should only access fields that are -- present in the Restricted_Ada_Task_Control_Block structure. --- 614,622 ---- -- Restricted_Ada_Task_Control_Block -- --------------------------------------- ! -- This type should only be used by the restricted GNARLI and by restricted ! -- GNULL implementations to allocate an ATCB (see System.Task_Primitives. ! -- Operations.New_ATCB) that will take significantly less memory. -- Note that the restricted GNARLI should only access fields that are -- present in the Restricted_Ada_Task_Control_Block structure. *************** package System.Tasking is *** 813,819 **** ------------------------------------ type Access_Address is access all System.Address; ! -- Comment on what this is used for ??? pragma No_Strict_Aliasing (Access_Address); -- This type is used in contexts where aliasing may be an issue (see --- 817,824 ---- ------------------------------------ type Access_Address is access all System.Address; ! -- Anonymous pointer used to implement task attributes (see s-tataat.adb ! -- and a-tasatt.adb) pragma No_Strict_Aliasing (Access_Address); -- This type is used in contexts where aliasing may be an issue (see *************** package System.Tasking is *** 858,863 **** --- 863,873 ---- -- associated with protected objects or task entries, and are protected -- by the protected object lock or Acceptor.L, respectively. + Entry_Names : Entry_Names_Array_Access := null; + -- An array of string names which denotes entry [family member] names. + -- The structure is indexed by task entry index and contains Entry_Num + -- components. + New_Base_Priority : System.Any_Priority; -- New value for Base_Priority (for dynamic priorities package) -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasloc.adb gcc-4.4.0/gcc/ada/s-tasloc.adb *** gcc-4.3.3/gcc/ada/s-tasloc.adb Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/s-tasloc.adb Wed Mar 26 07:35:19 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2008, AdaCore -- -- -- -- 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- -- *************** *** 32,38 **** ------------------------------------------------------------------------------ with System.Soft_Links; - -- used for Lock_Task, Unlock_Task package body System.Task_Lock is --- 32,37 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-taspri-dummy.ads gcc-4.4.0/gcc/ada/s-taspri-dummy.ads *** gcc-4.3.3/gcc/ada/s-taspri-dummy.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-taspri-dummy.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 34,41 **** -- This is a no tasking version of this package pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. package System.Task_Primitives is pragma Preelaborate; --- 32,39 ---- -- This is a no tasking version of this package pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. package System.Task_Primitives is pragma Preelaborate; *************** package System.Task_Primitives is *** 54,57 **** --- 52,67 ---- L : aliased RTS_Lock; end record; + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + end System.Task_Primitives; diff -Nrcpad gcc-4.3.3/gcc/ada/s-taspri-hpux-dce.ads gcc-4.4.0/gcc/ada/s-taspri-hpux-dce.ads *** gcc-4.3.3/gcc/ada/s-taspri-hpux-dce.ads Mon Sep 5 07:46:06 2005 --- gcc-4.4.0/gcc/ada/s-taspri-hpux-dce.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 36,48 **** -- This package provides low-level support for most tasking features pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. with System.OS_Interface; - -- used for pthread_mutex_t - -- pthread_cond_t - -- pthread_t package System.Task_Primitives is pragma Preelaborate; --- 34,43 ---- -- This package provides low-level support for most tasking features pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. with System.OS_Interface; package System.Task_Primitives is pragma Preelaborate; *************** package System.Task_Primitives is *** 67,72 **** --- 62,79 ---- -- A component of this type is guaranteed to be included in the -- Ada_Task_Control_Block. + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + private type Lock is record L : aliased System.OS_Interface.pthread_mutex_t; diff -Nrcpad gcc-4.3.3/gcc/ada/s-taspri-lynxos.ads gcc-4.4.0/gcc/ada/s-taspri-lynxos.ads *** gcc-4.3.3/gcc/ada/s-taspri-lynxos.ads Mon Sep 5 07:46:06 2005 --- gcc-4.4.0/gcc/ada/s-taspri-lynxos.ads Tue Apr 8 06:43:15 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2005, AdaCore -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNARL 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- -- *************** *** 35,47 **** -- This is a LynxOS version of this package, derived from s-taspri-posix.ads pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. with System.OS_Interface; - -- used for pthread_mutex_t - -- pthread_cond_t - -- pthread_t package System.Task_Primitives is pragma Preelaborate; --- 35,44 ---- -- This is a LynxOS version of this package, derived from s-taspri-posix.ads pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. with System.OS_Interface; package System.Task_Primitives is pragma Preelaborate; *************** package System.Task_Primitives is *** 66,71 **** --- 63,80 ---- -- A component of this type is guaranteed to be included in the -- Ada_Task_Control_Block. + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + private type Lock is record diff -Nrcpad gcc-4.3.3/gcc/ada/s-taspri-mingw.ads gcc-4.4.0/gcc/ada/s-taspri-mingw.ads *** gcc-4.3.3/gcc/ada/s-taspri-mingw.ads Mon Sep 5 07:46:06 2005 --- gcc-4.4.0/gcc/ada/s-taspri-mingw.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 34,46 **** -- This is a NT (native) version of this package pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. with System.OS_Interface; ! -- used for pthread_mutex_t ! -- pthread_cond_t ! -- pthread_t package System.Task_Primitives is pragma Preelaborate; --- 32,42 ---- -- This is a NT (native) version of this package pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. with System.OS_Interface; ! with System.Win32; package System.Task_Primitives is pragma Preelaborate; *************** package System.Task_Primitives is *** 65,70 **** --- 61,78 ---- -- A component of this type is guaranteed to be included in the -- Ada_Task_Control_Block. + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + private type Lock is record *************** private *** 73,79 **** Owner_Priority : Integer; end record; ! type Condition_Variable is new System.OS_Interface.HANDLE; type RTS_Lock is new System.OS_Interface.CRITICAL_SECTION; --- 81,87 ---- Owner_Priority : Integer; end record; ! type Condition_Variable is new System.Win32.HANDLE; type RTS_Lock is new System.OS_Interface.CRITICAL_SECTION; *************** private *** 90,101 **** L : aliased System.OS_Interface.CRITICAL_SECTION; -- Protection for ensuring mutual exclusion on the Suspension_Object ! CV : aliased System.OS_Interface.HANDLE; -- Condition variable used to queue threads until condition is signaled end record; type Private_Data is record ! Thread : aliased System.OS_Interface.HANDLE; pragma Atomic (Thread); -- Thread field may be updated by two different threads of control. -- (See, Enter_Task and Create_Task in s-taprop.adb). --- 98,109 ---- L : aliased System.OS_Interface.CRITICAL_SECTION; -- Protection for ensuring mutual exclusion on the Suspension_Object ! CV : aliased Win32.HANDLE; -- Condition variable used to queue threads until condition is signaled end record; type Private_Data is record ! Thread : aliased Win32.HANDLE; pragma Atomic (Thread); -- Thread field may be updated by two different threads of control. -- (See, Enter_Task and Create_Task in s-taprop.adb). *************** private *** 103,109 **** -- use lock on those operations and the only thing we have to -- make sure is that they are updated in atomic fashion. ! Thread_Id : aliased System.OS_Interface.DWORD; -- Used to provide a better tasking support in gdb CV : aliased Condition_Variable; --- 111,117 ---- -- use lock on those operations and the only thing we have to -- make sure is that they are updated in atomic fashion. ! Thread_Id : aliased Win32.DWORD; -- Used to provide a better tasking support in gdb CV : aliased Condition_Variable; diff -Nrcpad gcc-4.3.3/gcc/ada/s-taspri-posix-noaltstack.ads gcc-4.4.0/gcc/ada/s-taspri-posix-noaltstack.ads *** gcc-4.3.3/gcc/ada/s-taspri-posix-noaltstack.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-taspri-posix-noaltstack.ads Tue Apr 8 06:43:15 2008 *************** *** 0 **** --- 1,124 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . T A S K _ P R I M I T I V E S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 1991-1994, Florida State University -- + -- Copyright (C) 1995-2008, AdaCore -- + -- -- + -- GNARL 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNARL; see file COPYING. If not, write -- + -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- + -- Boston, MA 02110-1301, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNARL was developed by the GNARL team at Florida State University. -- + -- Extensive contributions were provided by Ada Core Technologies, Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is a POSIX-like version of this package where no alternate stack + -- is needed for stack checking. + + -- Note: this file can only be used for POSIX compliant systems + + pragma Polling (Off); + -- Turn off polling, we do not want ATC polling to take place during tasking + -- operations. It causes infinite loops and other problems. + + with System.OS_Interface; + + package System.Task_Primitives is + pragma Preelaborate; + + type Lock is limited private; + -- Should be used for implementation of protected objects + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + type Suspension_Object is limited private; + -- Should be used for the implementation of Ada.Synchronous_Task_Control + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper declared + -- local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. + + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + + private + + type Lock is new System.OS_Interface.pthread_mutex_t; + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + type Suspension_Object is record + State : Boolean; + pragma Atomic (State); + -- Boolean that indicates whether the object is open. This field is + -- marked Atomic to ensure that we can read its value without locking + -- the access to the Suspension_Object. + + Waiting : Boolean; + -- Flag showing if there is a task already suspended on this object + + L : aliased System.OS_Interface.pthread_mutex_t; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased System.OS_Interface.pthread_cond_t; + -- Condition variable used to queue threads until condition is signaled + end record; + + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same + -- value (thr_self value). We do not want to use lock on those + -- operations and the only thing we have to make sure is that they are + -- updated in atomic fashion. + + LWP : aliased System.Address; + -- The purpose of this field is to provide a better tasking support on + -- gdb. The order of the two first fields (Thread and LWP) is important. + -- On targets where lwp is not relevant, this is equivalent to Thread. + + CV : aliased System.OS_Interface.pthread_cond_t; + -- Should be commented ??? (in all versions of taspri) + + L : aliased RTS_Lock; + -- Protection for all components is lock L + end record; + + end System.Task_Primitives; diff -Nrcpad gcc-4.3.3/gcc/ada/s-taspri-posix.ads gcc-4.4.0/gcc/ada/s-taspri-posix.ads *** gcc-4.3.3/gcc/ada/s-taspri-posix.ads Mon Sep 5 07:46:06 2005 --- gcc-4.4.0/gcc/ada/s-taspri-posix.ads Tue Apr 8 07:13:49 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2005, AdaCore -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNARL 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,49 **** -- Note: this file can only be used for POSIX compliant systems pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. with System.OS_Interface; - -- used for pthread_mutex_t - -- pthread_cond_t - -- pthread_t package System.Task_Primitives is pragma Preelaborate; --- 37,46 ---- -- Note: this file can only be used for POSIX compliant systems pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. with System.OS_Interface; package System.Task_Primitives is pragma Preelaborate; *************** package System.Task_Primitives is *** 68,73 **** --- 65,82 ---- -- A component of this type is guaranteed to be included in the -- Ada_Task_Control_Block. + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := System.OS_Interface.Alternate_Stack_Size; + -- Import value from System.OS_Interface + private type Lock is new System.OS_Interface.pthread_mutex_t; diff -Nrcpad gcc-4.3.3/gcc/ada/s-taspri-solaris.ads gcc-4.4.0/gcc/ada/s-taspri-solaris.ads *** gcc-4.3.3/gcc/ada/s-taspri-solaris.ads Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-taspri-solaris.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 36,51 **** -- This package provides low-level support for most tasking features pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. ! ! with System.OS_Interface; ! -- used for mutex_t ! -- cond_t ! -- thread_t with Ada.Unchecked_Conversion; package System.Task_Primitives is pragma Preelaborate; --- 34,46 ---- -- This package provides low-level support for most tasking features pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; + with System.OS_Interface; + package System.Task_Primitives is pragma Preelaborate; *************** package System.Task_Primitives is *** 74,79 **** --- 69,86 ---- -- A component of this type is guaranteed to be included in the -- Ada_Task_Control_Block. + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + private type Private_Task_Serial_Number is mod 2 ** 64; diff -Nrcpad gcc-4.3.3/gcc/ada/s-taspri-tru64.ads gcc-4.4.0/gcc/ada/s-taspri-tru64.ads *** gcc-4.3.3/gcc/ada/s-taspri-tru64.ads Mon Sep 5 07:46:06 2005 --- gcc-4.4.0/gcc/ada/s-taspri-tru64.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 36,52 **** -- This package provides low-level support for most tasking features pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. with Interfaces.C; - -- used for int - -- size_t with System.OS_Interface; - -- used for pthread_mutex_t - -- pthread_cond_t - -- pthread_t package System.Task_Primitives is pragma Preelaborate; --- 34,45 ---- -- This package provides low-level support for most tasking features pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. with Interfaces.C; with System.OS_Interface; package System.Task_Primitives is pragma Preelaborate; *************** package System.Task_Primitives is *** 70,75 **** --- 63,80 ---- -- Any information that the GNULLI needs maintained on a per-task basis. -- A component of this type is guaranteed to be included + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + private type Lock is record diff -Nrcpad gcc-4.3.3/gcc/ada/s-taspri-vms.ads gcc-4.4.0/gcc/ada/s-taspri-vms.ads *** gcc-4.3.3/gcc/ada/s-taspri-vms.ads Mon Sep 5 07:46:06 2005 --- gcc-4.4.0/gcc/ada/s-taspri-vms.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 36,52 **** -- This package provides low-level support for most tasking features pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. with Interfaces.C; - -- used for int - -- size_t with System.OS_Interface; ! -- used for pthread_mutex_t ! -- pthread_cond_t ! -- pthread_t package System.Task_Primitives is pragma Preelaborate; --- 34,46 ---- -- This package provides low-level support for most tasking features pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. with Interfaces.C; with System.OS_Interface; ! with System.Aux_DEC; package System.Task_Primitives is pragma Preelaborate; *************** package System.Task_Primitives is *** 71,76 **** --- 65,81 ---- -- A component of this type is guaranteed to be included in the -- Ada_Task_Control_Block. + subtype Task_Address is System.Aux_DEC.Short_Address; + -- Task_Address is the short version of address defined in System.Aux_DEC. + -- To avoid dragging Aux_DEC into tasking packages a tasking specific + -- subtype is defined here. + + Task_Address_Size : constant := System.Aux_DEC.Short_Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + private type Exc_Stack_T is array (0 .. 8192) of aliased Character; diff -Nrcpad gcc-4.3.3/gcc/ada/s-taspri-vxworks.ads gcc-4.4.0/gcc/ada/s-taspri-vxworks.ads *** gcc-4.3.3/gcc/ada/s-taspri-vxworks.ads Tue Oct 31 17:47:01 2006 --- gcc-4.4.0/gcc/ada/s-taspri-vxworks.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2006 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 34,41 **** -- This is a VxWorks version of this package pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. with System.OS_Interface; --- 32,39 ---- -- This is a VxWorks version of this package pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. with System.OS_Interface; *************** package System.Task_Primitives is *** 62,67 **** --- 60,77 ---- -- A component of this type is guaranteed to be included in the -- Ada_Task_Control_Block. + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + private type Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit); diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasque.adb gcc-4.4.0/gcc/ada/s-tasque.adb *** gcc-4.3.3/gcc/ada/s-tasque.adb Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-tasque.adb Thu Apr 9 23:23:07 2009 *************** *** 6,49 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This version of the body implements queueing policy according to the ! -- policy specified by the pragma Queuing_Policy. When no such pragma ! -- is specified FIFO policy is used as default. with System.Task_Primitives.Operations; - -- used for Write_Lock - -- Unlock - with System.Tasking.Initialization; - -- used for Wakeup_Entry_Caller - with System.Parameters; - -- used for Single_Lock package body System.Tasking.Queuing is --- 6,41 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This version of the body implements queueing policy according to the policy ! -- specified by the pragma Queuing_Policy. When no such pragma is specified ! -- FIFO policy is used as default. with System.Task_Primitives.Operations; with System.Tasking.Initialization; with System.Parameters; package body System.Tasking.Queuing is diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasque.ads gcc-4.4.0/gcc/ada/s-tasque.ads *** gcc-4.3.3/gcc/ada/s-tasque.ads Wed Feb 15 09:28:43 2006 --- gcc-4.4.0/gcc/ada/s-tasque.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package System.Tasking.Queuing is *** 95,101 **** procedure Requeue_Call_With_New_Prio (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority); -- Change Priority of the call and re insert to the queue when priority ! -- queueing is in effect. When FIFO is inforced, this routine -- should not have any effect. end System.Tasking.Queuing; --- 93,99 ---- procedure Requeue_Call_With_New_Prio (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority); -- Change Priority of the call and re insert to the queue when priority ! -- queueing is in effect. When FIFO is enforced, this routine -- should not have any effect. end System.Tasking.Queuing; diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasren.adb gcc-4.4.0/gcc/ada/s-tasren.adb *** gcc-4.3.3/gcc/ada/s-tasren.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/s-tasren.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 32,84 **** ------------------------------------------------------------------------------ with System.Task_Primitives.Operations; - -- used for Get_Priority - -- Set_Priority - -- Write_Lock - -- Unlock - -- Sleep - -- Wakeup - -- Timed_Sleep - with System.Tasking.Entry_Calls; - -- Used for Wait_For_Completion - -- Wait_For_Completion_With_Timeout - -- Wait_Until_Abortable - with System.Tasking.Initialization; - -- used for Defer_Abort - -- Undefer_Abort - -- Do_Pending_Action - with System.Tasking.Queuing; - -- used for Enqueue - -- Dequeue_Head - -- Select_Task_Entry_Call - -- Count_Waiting - with System.Tasking.Utilities; - -- used for Check_Exception - -- Make_Passive - -- Wakeup_Entry_Caller - -- Exit_One_ATC_Level - with System.Tasking.Protected_Objects.Operations; - -- used for PO_Do_Or_Queue - -- PO_Service_Entries - -- Lock_Entries - with System.Tasking.Debug; - -- used for Trace - with System.Restrictions; - -- used for Abort_Allowed - with System.Parameters; - -- used for Single_Lock - -- Runtime_Traces - with System.Traces.Tasking; - -- used for Send_Trace_Info package body System.Tasking.Rendezvous is --- 30,44 ---- *************** package body System.Tasking.Rendezvous i *** 402,409 **** if System.Tasking.Detect_Blocking and then STPO.Self.Common.Protected_Action_Nesting > 0 then ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, "potentially blocking operation"); end if; Call_Synchronous --- 362,368 ---- if System.Tasking.Detect_Blocking and then STPO.Self.Common.Protected_Action_Nesting > 0 then ! raise Program_Error with "potentially blocking operation"; end if; Call_Synchronous *************** package body System.Tasking.Rendezvous i *** 1037,1044 **** end if; Initialization.Undefer_Abort (Self_Id); ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, "Entry call not a delay mode"); end if; end case; --- 996,1002 ---- end if; Initialization.Undefer_Abort (Self_Id); ! raise Program_Error with "Entry call not a delay mode"; end if; end case; *************** package body System.Tasking.Rendezvous i *** 1351,1358 **** if System.Tasking.Detect_Blocking and then Self_Id.Common.Protected_Action_Nesting > 0 then ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, "potentially blocking operation"); end if; if Parameters.Runtime_Traces then --- 1309,1315 ---- if System.Tasking.Detect_Blocking and then Self_Id.Common.Protected_Action_Nesting > 0 then ! raise Program_Error with "potentially blocking operation"; end if; if Parameters.Runtime_Traces then *************** package body System.Tasking.Rendezvous i *** 1719,1726 **** if System.Tasking.Detect_Blocking and then Self_Id.Common.Protected_Action_Nesting > 0 then ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, "potentially blocking operation"); end if; Initialization.Defer_Abort (Self_Id); --- 1676,1682 ---- if System.Tasking.Detect_Blocking and then Self_Id.Common.Protected_Action_Nesting > 0 then ! raise Program_Error with "potentially blocking operation"; end if; Initialization.Defer_Abort (Self_Id); diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasren.ads gcc-4.4.0/gcc/ada/s-tasren.ads *** gcc-4.3.3/gcc/ada/s-tasren.ads Tue Aug 14 08:50:09 2007 --- gcc-4.4.0/gcc/ada/s-tasren.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 35,44 **** -- Any changes to this interface may require corresponding compiler changes. with Ada.Exceptions; - -- Used for, Exception_Id with System.Tasking.Protected_Objects.Entries; - -- used for Protection_Entries package System.Tasking.Rendezvous is --- 33,40 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasres.ads gcc-4.4.0/gcc/ada/s-tasres.ads *** gcc-4.3.3/gcc/ada/s-tasres.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-tasres.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tassta.adb gcc-4.4.0/gcc/ada/s-tassta.adb *** gcc-4.3.3/gcc/ada/s-tassta.adb Thu Dec 13 10:35:41 2007 --- gcc-4.4.0/gcc/ada/s-tassta.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 32,110 **** ------------------------------------------------------------------------------ pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. with Ada.Exceptions; ! -- Used for Raise_Exception with System.Tasking.Debug; - -- Used for enabling tasking facilities with gdb - with System.Address_Image; ! -- Used for the function itself ! with System.Task_Primitives.Operations; - -- Used for Finalize_Lock - -- Enter_Task - -- Write_Lock - -- Unlock - -- Sleep - -- Wakeup - -- Get_Priority - -- Lock/Unlock_RTS - -- New_ATCB - - with System.Soft_Links; - -- These are procedure pointers to non-tasking routines that use task - -- specific data. In the absence of tasking, these routines refer to global - -- data. In the presense of tasking, they must be replaced with pointers to - -- task-specific versions. Also used for Create_TSD, Destroy_TSD, - -- Get_Current_Excep, Finalize_Global_List, Task_Termination, Handler. - - with System.Tasking.Initialization; - -- Used for Remove_From_All_Tasks_List - -- Defer_Abort - -- Undefer_Abort - -- Finalize_Attributes_Link - -- Initialize_Attributes_Link - - pragma Elaborate_All (System.Tasking.Initialization); - -- This insures that tasking is initialized if any tasks are created - with System.Tasking.Utilities; - -- Used for Make_Passive - -- Abort_One_Task - -- Abort_Tasks - with System.Tasking.Queuing; - -- Used for Dequeue_Head - with System.Tasking.Rendezvous; - -- Used for Call_Simple - with System.OS_Primitives; - -- Used for Delay_Modes - with System.Secondary_Stack; - -- Used for SS_Init - with System.Storage_Elements; - -- Used for Storage_Array - with System.Restrictions; - -- Used for Abort_Allowed - with System.Standard_Library; - -- Used for Exception_Trace - with System.Traces.Tasking; ! -- Used for Send_Trace_Info ! with Ada.Unchecked_Deallocation; ! -- To recover from failure of ATCB initialization ! with System.Stack_Usage; package body System.Tasking.Stages is --- 30,66 ---- ------------------------------------------------------------------------------ pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. with Ada.Exceptions; ! with Ada.Unchecked_Deallocation; with System.Tasking.Debug; with System.Address_Image; ! with System.Task_Primitives; with System.Task_Primitives.Operations; with System.Tasking.Utilities; with System.Tasking.Queuing; with System.Tasking.Rendezvous; with System.OS_Primitives; with System.Secondary_Stack; with System.Storage_Elements; with System.Restrictions; with System.Standard_Library; with System.Traces.Tasking; ! with System.Stack_Usage; ! with System.Soft_Links; ! -- These are procedure pointers to non-tasking routines that use task ! -- specific data. In the absence of tasking, these routines refer to global ! -- data. In the presence of tasking, they must be replaced with pointers to ! -- task-specific versions. Also used for Create_TSD, Destroy_TSD, ! -- Get_Current_Excep, Finalize_Global_List, Task_Termination, Handler. ! with System.Tasking.Initialization; ! pragma Elaborate_All (System.Tasking.Initialization); ! -- This insures that tasking is initialized if any tasks are created package body System.Tasking.Stages is *************** package body System.Tasking.Stages is *** 130,135 **** --- 86,94 ---- procedure Free is new Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + procedure Free_Entry_Names (T : Task_Id); + -- Deallocate all string names associated with task entries + procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id); -- This procedure outputs the task specific message for exception -- tracing purposes. *************** package body System.Tasking.Stages is *** 154,160 **** procedure Vulnerable_Complete_Task (Self_ID : Task_Id); -- Complete the calling task. This procedure must be called with -- abort deferred. It should only be called by Complete_Task and ! -- Finalizate_Global_Tasks (for the environment task). procedure Vulnerable_Complete_Master (Self_ID : Task_Id); -- Complete the current master of the calling task. This procedure --- 113,119 ---- procedure Vulnerable_Complete_Task (Self_ID : Task_Id); -- Complete the calling task. This procedure must be called with -- abort deferred. It should only be called by Complete_Task and ! -- Finalize_Global_Tasks (for the environment task). procedure Vulnerable_Complete_Master (Self_ID : Task_Id); -- Complete the current master of the calling task. This procedure *************** package body System.Tasking.Stages is *** 166,185 **** -- This procedure must be called with abort deferred. procedure Abort_Dependents (Self_ID : Task_Id); ! -- Abort all the direct dependents of Self at its current master ! -- nesting level, plus all of their dependents, transitively. ! -- RTS_Lock should be locked by the caller. procedure Vulnerable_Free_Task (T : Task_Id); ! -- Recover all runtime system storage associated with the task T. ! -- This should only be called after T has terminated and will no ! -- longer be referenced. ! -- ! -- For tasks created by an allocator that fails, due to an exception, ! -- it is called from Expunge_Unactivated_Tasks. -- ! -- It is also called from Ada.Unchecked_Deallocation, for objects that ! -- are or contain tasks. -- -- Different code is used at master completion, in Terminate_Dependents, -- due to a need for tighter synchronization with the master. --- 125,141 ---- -- This procedure must be called with abort deferred. procedure Abort_Dependents (Self_ID : Task_Id); ! -- Abort all the direct dependents of Self at its current master nesting ! -- level, plus all of their dependents, transitively. RTS_Lock should be ! -- locked by the caller. procedure Vulnerable_Free_Task (T : Task_Id); ! -- Recover all runtime system storage associated with the task T. This ! -- should only be called after T has terminated and will no longer be ! -- referenced. -- ! -- For tasks created by an allocator that fails, due to an exception, it is ! -- called from Expunge_Unactivated_Tasks. -- -- Different code is used at master completion, in Terminate_Dependents, -- due to a need for tighter synchronization with the master. *************** package body System.Tasking.Stages is *** 233,260 **** -- Activate_Tasks -- -------------------- ! -- Note that locks of activator and activated task are both locked ! -- here. This is necessary because C.Common.State and ! -- Self.Common.Wait_Count have to be synchronized. This is safe from ! -- deadlock because the activator is always created before the activated ! -- task. That satisfies our in-order-of-creation ATCB locking policy. ! -- At one point, we may also lock the parent, if the parent is ! -- different from the activator. That is also consistent with the ! -- lock ordering policy, since the activator cannot be created ! -- before the parent. ! -- Since we are holding both the activator's lock, and Task_Wrapper ! -- locks that before it does anything more than initialize the ! -- low-level ATCB components, it should be safe to wait to update ! -- the counts until we see that the thread creation is successful. ! -- If the thread creation fails, we do need to close the entries ! -- of the task. The first phase, of dequeuing calls, only requires ! -- locking the acceptor's ATCB, but the waking up of the callers ! -- requires locking the caller's ATCB. We cannot safely do this ! -- while we are holding other locks. Therefore, the queue-clearing ! -- operation is done in a separate pass over the activation chain. procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is Self_ID : constant Task_Id := STPO.Self; --- 189,215 ---- -- Activate_Tasks -- -------------------- ! -- Note that locks of activator and activated task are both locked here. ! -- This is necessary because C.Common.State and Self.Common.Wait_Count have ! -- to be synchronized. This is safe from deadlock because the activator is ! -- always created before the activated task. That satisfies our ! -- in-order-of-creation ATCB locking policy. ! -- At one point, we may also lock the parent, if the parent is different ! -- from the activator. That is also consistent with the lock ordering ! -- policy, since the activator cannot be created before the parent. ! -- Since we are holding both the activator's lock, and Task_Wrapper locks ! -- that before it does anything more than initialize the low-level ATCB ! -- components, it should be safe to wait to update the counts until we see ! -- that the thread creation is successful. ! -- If the thread creation fails, we do need to close the entries of the ! -- task. The first phase, of dequeuing calls, only requires locking the ! -- acceptor's ATCB, but the waking up of the callers requires locking the ! -- caller's ATCB. We cannot safely do this while we are holding other ! -- locks. Therefore, the queue-clearing operation is done in a separate ! -- pass over the activation chain. procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is Self_ID : constant Task_Id := STPO.Self; *************** package body System.Tasking.Stages is *** 272,279 **** if System.Tasking.Detect_Blocking and then Self_ID.Common.Protected_Action_Nesting > 0 then ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, "potentially blocking operation"); end if; pragma Debug --- 227,233 ---- if System.Tasking.Detect_Blocking and then Self_ID.Common.Protected_Action_Nesting > 0 then ! raise Program_Error with "potentially blocking operation"; end if; pragma Debug *************** package body System.Tasking.Stages is *** 299,306 **** All_Elaborated := False; end if; ! -- Reverse the activation chain so that tasks are ! -- activated in the same order they're declared. Next_C := C.Common.Activation_Link; C.Common.Activation_Link := Last_C; --- 253,260 ---- All_Elaborated := False; end if; ! -- Reverse the activation chain so that tasks are activated in the ! -- same order they're declared. Next_C := C.Common.Activation_Link; C.Common.Activation_Link := Last_C; *************** package body System.Tasking.Stages is *** 313,320 **** if not All_Elaborated then Unlock_RTS; Initialization.Undefer_Abort_Nestable (Self_ID); ! Raise_Exception ! (Program_Error'Identity, "Some tasks have not been elaborated"); end if; -- Activate all the tasks in the chain. Creation of the thread of --- 267,273 ---- if not All_Elaborated then Unlock_RTS; Initialization.Undefer_Abort_Nestable (Self_ID); ! raise Program_Error with "Some tasks have not been elaborated"; end if; -- Activate all the tasks in the chain. Creation of the thread of *************** package body System.Tasking.Stages is *** 341,350 **** (C.Common.Compiler_Data.Pri_Stack_Info.Size), Activate_Prio, Success); ! -- There would be a race between the created task and the ! -- creator to do the following initialization, if we did not ! -- have a Lock/Unlock_RTS pair in the task wrapper to prevent ! -- it from racing ahead. if Success then C.Common.State := Runnable; --- 294,303 ---- (C.Common.Compiler_Data.Pri_Stack_Info.Size), Activate_Prio, Success); ! -- There would be a race between the created task and the creator ! -- to do the following initialization, if we did not have a ! -- Lock/Unlock_RTS pair in the task wrapper to prevent it from ! -- racing ahead. if Success then C.Common.State := Runnable; *************** package body System.Tasking.Stages is *** 380,387 **** Unlock_RTS; end if; ! -- Close the entries of any tasks that failed thread creation, ! -- and count those that have not finished activation. Write_Lock (Self_ID); Self_ID.Common.State := Activator_Sleep; --- 333,340 ---- Unlock_RTS; end if; ! -- Close the entries of any tasks that failed thread creation, and count ! -- those that have not finished activation. Write_Lock (Self_ID); Self_ID.Common.State := Activator_Sleep; *************** package body System.Tasking.Stages is *** 428,435 **** if Self_ID.Common.Activation_Failed then Self_ID.Common.Activation_Failed := False; ! Raise_Exception (Tasking_Error'Identity, ! "Failure during activation"); end if; end Activate_Tasks; --- 381,387 ---- if Self_ID.Common.Activation_Failed then Self_ID.Common.Activation_Failed := False; ! raise Tasking_Error with "Failure during activation"; end if; end Activate_Tasks; *************** package body System.Tasking.Stages is *** 455,462 **** Initialization.Undefer_Abort_Nestable (Self_ID); ! -- ??? ! -- Why do we need to allow for nested deferral here? if Runtime_Traces then Send_Trace_Info (T_Activate); --- 407,413 ---- Initialization.Undefer_Abort_Nestable (Self_ID); ! -- ??? Why do we need to allow for nested deferral here? if Runtime_Traces then Send_Trace_Info (T_Activate); *************** package body System.Tasking.Stages is *** 500,520 **** -- Create_Task -- ----------------- ! -- Compiler interface only. Do not call from within the RTS. ! -- This must be called to create a new task. procedure Create_Task ! (Priority : Integer; ! Size : System.Parameters.Size_Type; ! Task_Info : System.Task_Info.Task_Info_Type; ! Num_Entries : Task_Entry_Index; ! Master : Master_Level; ! State : Task_Procedure_Access; ! Discriminants : System.Address; ! Elaborated : Access_Boolean; ! Chain : in out Activation_Chain; ! Task_Image : String; ! Created_Task : out Task_Id) is T, P : Task_Id; Self_ID : constant Task_Id := STPO.Self; --- 451,473 ---- -- Create_Task -- ----------------- ! -- Compiler interface only. Do not call from within the RTS. This must be ! -- called to create a new task. procedure Create_Task ! (Priority : Integer; ! Size : System.Parameters.Size_Type; ! Task_Info : System.Task_Info.Task_Info_Type; ! Relative_Deadline : Ada.Real_Time.Time_Span; ! Num_Entries : Task_Entry_Index; ! Master : Master_Level; ! State : Task_Procedure_Access; ! Discriminants : System.Address; ! Elaborated : Access_Boolean; ! Chain : in out Activation_Chain; ! Task_Image : String; ! Created_Task : out Task_Id; ! Build_Entry_Names : Boolean) is T, P : Task_Id; Self_ID : constant Task_Id := STPO.Self; *************** package body System.Tasking.Stages is *** 522,527 **** --- 475,484 ---- Base_Priority : System.Any_Priority; Len : Natural; + pragma Unreferenced (Relative_Deadline); + -- EDF scheduling is not supported by any of the target platforms so + -- this parameter is not passed any further. + begin -- If Master is greater than the current master, it means that Master -- has already awaited its dependent tasks. This raises Program_Error, *************** package body System.Tasking.Stages is *** 534,548 **** "create task after awaiting termination"; end if; ! -- If pragma Detect_Blocking is active must be checked whether ! -- this potentially blocking operation is called from a ! -- protected action. if System.Tasking.Detect_Blocking and then Self_ID.Common.Protected_Action_Nesting > 0 then ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, "potentially blocking operation"); end if; pragma Debug --- 491,503 ---- "create task after awaiting termination"; end if; ! -- If pragma Detect_Blocking is active must be checked whether this ! -- potentially blocking operation is called from a protected action. if System.Tasking.Detect_Blocking and then Self_ID.Common.Protected_Action_Nesting > 0 then ! raise Program_Error with "potentially blocking operation"; end if; pragma Debug *************** package body System.Tasking.Stages is *** 572,590 **** exception when others => Initialization.Undefer_Abort_Nestable (Self_ID); ! Raise_Exception (Storage_Error'Identity, "Cannot allocate task"); end; ! -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. ! -- Up to this point, it is possible that we may be part of ! -- a family of tasks that is being aborted. Lock_RTS; Write_Lock (Self_ID); ! -- Now, we must check that we have not been aborted. ! -- If so, we should give up on creating this task, ! -- and simply return. if not Self_ID.Callable then pragma Assert (Self_ID.Pending_ATC_Level = 0); --- 527,544 ---- exception when others => Initialization.Undefer_Abort_Nestable (Self_ID); ! raise Storage_Error with "Cannot allocate task"; end; ! -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. Up to this ! -- point, it is possible that we may be part of a family of tasks that ! -- is being aborted. Lock_RTS; Write_Lock (Self_ID); ! -- Now, we must check that we have not been aborted. If so, we should ! -- give up on creating this task, and simply return. if not Self_ID.Callable then pragma Assert (Self_ID.Pending_ATC_Level = 0); *************** package body System.Tasking.Stages is *** 610,617 **** Unlock (Self_ID); Unlock_RTS; Initialization.Undefer_Abort_Nestable (Self_ID); ! Raise_Exception ! (Storage_Error'Identity, "Failed to initialize task"); end if; if Master = Foreign_Task_Level + 2 then --- 564,570 ---- Unlock (Self_ID); Unlock_RTS; Initialization.Undefer_Abort_Nestable (Self_ID); ! raise Storage_Error with "Failed to initialize task"; end if; if Master = Foreign_Task_Level + 2 then *************** package body System.Tasking.Stages is *** 654,659 **** --- 607,617 ---- T.Common.Task_Image_Len := Len; end if; + if Build_Entry_Names then + T.Entry_Names := + new Entry_Names_Array (1 .. Entry_Index (Num_Entries)); + end if; + Unlock (Self_ID); Unlock_RTS; *************** package body System.Tasking.Stages is *** 710,717 **** Initialization.Defer_Abort_Nestable (Self_ID); -- ??? ! -- Experimentation has shown that abort is sometimes (but not ! -- always) already deferred when this is called. -- That may indicate an error. Find out what is going on --- 668,675 ---- Initialization.Defer_Abort_Nestable (Self_ID); -- ??? ! -- Experimentation has shown that abort is sometimes (but not always) ! -- already deferred when this is called. -- That may indicate an error. Find out what is going on *************** package body System.Tasking.Stages is *** 749,757 **** --------------------------- -- ??? ! -- We have a potential problem here if finalization of global ! -- objects does anything with signals or the timer server, since ! -- by that time those servers have terminated. -- It is hard to see how that would occur --- 707,715 ---- --------------------------- -- ??? ! -- We have a potential problem here if finalization of global objects does ! -- anything with signals or the timer server, since by that time those ! -- servers have terminated. -- It is hard to see how that would occur *************** package body System.Tasking.Stages is *** 767,777 **** begin if Self_ID.Deferral_Level = 0 then -- ??? ! -- In principle, we should be able to predict whether ! -- abort is already deferred here (and it should not be deferred ! -- yet but in practice it seems Finalize_Global_Tasks is being ! -- called sometimes, from RTS code for exceptions, with abort already ! -- deferred. Initialization.Defer_Abort_Nestable (Self_ID); --- 725,734 ---- begin if Self_ID.Deferral_Level = 0 then -- ??? ! -- In principle, we should be able to predict whether abort is ! -- already deferred here (and it should not be deferred yet but in ! -- practice it seems Finalize_Global_Tasks is being called sometimes, ! -- from RTS code for exceptions, with abort already deferred. Initialization.Defer_Abort_Nestable (Self_ID); *************** package body System.Tasking.Stages is *** 801,818 **** Unlock_RTS; end if; ! -- We need to explicitely wait for the task to be terminated here ! -- because on true concurrent system, we may end this procedure ! -- before the tasks are really terminated. Write_Lock (Self_ID); loop exit when Utilities.Independent_Task_Count = 0; ! -- We used to yield here, but this did not take into account ! -- low priority tasks that would cause dead lock in some cases ! -- (true FIFO scheduling). Timed_Sleep (Self_ID, 0.01, System.OS_Primitives.Relative, --- 758,775 ---- Unlock_RTS; end if; ! -- We need to explicitly wait for the task to be terminated here ! -- because on true concurrent system, we may end this procedure before ! -- the tasks are really terminated. Write_Lock (Self_ID); loop exit when Utilities.Independent_Task_Count = 0; ! -- We used to yield here, but this did not take into account low ! -- priority tasks that would cause dead lock in some cases (true ! -- FIFO scheduling). Timed_Sleep (Self_ID, 0.01, System.OS_Primitives.Relative, *************** package body System.Tasking.Stages is *** 866,871 **** --- 823,848 ---- end Finalize_Global_Tasks; + ---------------------- + -- Free_Entry_Names -- + ---------------------- + + procedure Free_Entry_Names (T : Task_Id) is + Names : Entry_Names_Array_Access := T.Entry_Names; + + procedure Free_Entry_Names_Array_Access is new + Ada.Unchecked_Deallocation + (Entry_Names_Array, Entry_Names_Array_Access); + + begin + if Names = null then + return; + end if; + + Free_Entry_Names_Array (Names.all); + Free_Entry_Names_Array_Access (Names); + end Free_Entry_Names; + --------------- -- Free_Task -- --------------- *************** package body System.Tasking.Stages is *** 881,891 **** --- 858,870 ---- Initialization.Task_Lock (Self_Id); Lock_RTS; + Initialization.Finalize_Attributes_Link.all (T); Initialization.Remove_From_All_Tasks_List (T); Unlock_RTS; Initialization.Task_Unlock (Self_Id); + Free_Entry_Names (T); System.Task_Primitives.Operations.Finalize_TCB (T); -- If the task is not terminated, then we simply ignore the call. This *************** package body System.Tasking.Stages is *** 944,959 **** Initialization.Undefer_Abort (Self_ID); end Move_Activation_Chain; ------------------ -- Task_Wrapper -- ------------------ ! -- The task wrapper is a procedure that is called first for each task ! -- task body, and which in turn calls the compiler-generated task body ! -- procedure. The wrapper's main job is to do initialization for the task. ! -- It also has some locally declared objects that server as per-task local ! -- data. Task finalization is done by Complete_Task, which is called from ! -- an at-end handler that the compiler generates. procedure Task_Wrapper (Self_ID : Task_Id) is use type SSE.Storage_Offset; --- 923,955 ---- Initialization.Undefer_Abort (Self_ID); end Move_Activation_Chain; + -- Compiler interface only. Do not call from within the RTS. + + -------------------- + -- Set_Entry_Name -- + -------------------- + + procedure Set_Entry_Name + (T : Task_Id; + Pos : Task_Entry_Index; + Val : String_Access) + is + begin + pragma Assert (T.Entry_Names /= null); + + T.Entry_Names (Entry_Index (Pos)) := Val; + end Set_Entry_Name; + ------------------ -- Task_Wrapper -- ------------------ ! -- The task wrapper is a procedure that is called first for each task body ! -- and which in turn calls the compiler-generated task body procedure. ! -- The wrapper's main job is to do initialization for the task. It also ! -- has some locally declared objects that serve as per-task local data. ! -- Task finalization is done by Complete_Task, which is called from an ! -- at-end handler that the compiler generates. procedure Task_Wrapper (Self_ID : Task_Id) is use type SSE.Storage_Offset; *************** package body System.Tasking.Stages is *** 962,967 **** --- 958,970 ---- Bottom_Of_Stack : aliased Integer; + Task_Alternate_Stack : + aliased SSE.Storage_Array (1 .. Alternate_Stack_Size); + -- The alternate signal stack for this task, if any + + Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; + -- Whether to use above alternate signal stack for stack overflows + Secondary_Stack_Size : constant SSE.Storage_Offset := Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size * *************** package body System.Tasking.Stages is *** 973,978 **** --- 976,984 ---- -- Why are warnings being turned off here??? Secondary_Stack_Address : System.Address := Secondary_Stack'Address; + -- Address of secondary stack. In the fixed secondary stack case, this + -- value is not modified, causing a warning, hence the bracketing with + -- Warnings (Off/On). But why is so much *more* bracketed??? Small_Overflow_Guard : constant := 12 * 1024; -- Note: this used to be 4K, but was changed to 12K, since smaller *************** package body System.Tasking.Stages is *** 991,999 **** -- Size of the overflow guard, used by dynamic stack usage analysis pragma Warnings (On); - -- Address of secondary stack. In the fixed secondary stack case, this - -- value is not modified, causing a warning, hence the bracketing with - -- Warnings (Off/On). But why is so much *more* bracketed ??? SEH_Table : aliased SSE.Storage_Array (1 .. 8); -- Structured Exception Registration table (2 words) --- 997,1002 ---- *************** package body System.Tasking.Stages is *** 1060,1067 **** Overflow_Guard := Big_Overflow_Guard; end if; - Size := Size - Overflow_Guard; - if not Parameters.Sec_Stack_Dynamic then Self_ID.Common.Compiler_Data.Sec_Stack_Addr := Secondary_Stack'Address; --- 1063,1068 ---- *************** package body System.Tasking.Stages is *** 1069,1082 **** Size := Size - Natural (Secondary_Stack_Size); end if; if System.Stack_Usage.Is_Enabled then STPO.Lock_RTS; ! Initialize_Analyzer (Self_ID.Common.Analyzer, ! Self_ID.Common.Task_Image ! (1 .. Self_ID.Common.Task_Image_Len), ! Size, ! Overflow_Guard, ! SSE.To_Integer (Bottom_Of_Stack'Address)); STPO.Unlock_RTS; Fill_Stack (Self_ID.Common.Analyzer); end if; --- 1070,1091 ---- Size := Size - Natural (Secondary_Stack_Size); end if; + if Use_Alternate_Stack then + Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address; + end if; + + Size := Size - Overflow_Guard; + if System.Stack_Usage.Is_Enabled then STPO.Lock_RTS; ! Initialize_Analyzer ! (Self_ID.Common.Analyzer, ! Self_ID.Common.Task_Image ! (1 .. Self_ID.Common.Task_Image_Len), ! Natural ! (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size), ! Size, ! SSE.To_Integer (Bottom_Of_Stack'Address)); STPO.Unlock_RTS; Fill_Stack (Self_ID.Common.Analyzer); end if; *************** package body System.Tasking.Stages is *** 1086,1094 **** Stack_Guard (Self_ID, True); ! -- Initialize low-level TCB components, that cannot be initialized ! -- by the creator. Enter_Task sets Self_ID.Known_Tasks_Index and ! -- also Self_ID.LL.Thread Enter_Task (Self_ID); --- 1095,1103 ---- Stack_Guard (Self_ID, True); ! -- Initialize low-level TCB components, that cannot be initialized by ! -- the creator. Enter_Task sets Self_ID.Known_Tasks_Index and also ! -- Self_ID.LL.Thread Enter_Task (Self_ID); *************** package body System.Tasking.Stages is *** 1163,1169 **** Cause := Abnormal; end if; when others => ! -- ??? Using an E : others here causes CD2C11A to fail on Tru64. Initialization.Defer_Abort_Nestable (Self_ID); --- 1172,1178 ---- Cause := Abnormal; end if; when others => ! -- ??? Using an E : others here causes CD2C11A to fail on Tru64 Initialization.Defer_Abort_Nestable (Self_ID); *************** package body System.Tasking.Stages is *** 1232,1240 **** -------------------- -- Before we allow the thread to exit, we must clean up. This is a ! -- a delicate job. We must wake up the task's master, who may immediately ! -- try to deallocate the ATCB out from under the current task WHILE IT IS ! -- STILL EXECUTING. -- To avoid this, the parent task must be blocked up to the latest -- statement executed. The trouble is that we have another step that we --- 1241,1249 ---- -------------------- -- Before we allow the thread to exit, we must clean up. This is a ! -- delicate job. We must wake up the task's master, who may immediately try ! -- to deallocate the ATCB out from under the current task WHILE IT IS STILL ! -- EXECUTING. -- To avoid this, the parent task must be blocked up to the latest -- statement executed. The trouble is that we have another step that we *************** package body System.Tasking.Stages is *** 1314,1321 **** SSL.Destroy_TSD (Self_ID.Common.Compiler_Data); Initialization.Final_Task_Unlock (Self_ID); ! -- WARNING: past this point, this thread must assume that the ATCB ! -- has been deallocated. It should not be accessed again. if Master_of_Task > 0 then STPO.Exit_Task; --- 1323,1330 ---- SSL.Destroy_TSD (Self_ID.Common.Compiler_Data); Initialization.Final_Task_Unlock (Self_ID); ! -- WARNING: past this point, this thread must assume that the ATCB has ! -- been deallocated. It should not be accessed again. if Master_of_Task > 0 then STPO.Exit_Task; *************** package body System.Tasking.Stages is *** 1361,1367 **** use System.Standard_Library; function To_Address is new ! Ada.Unchecked_Conversion (Task_Id, System.Address); function Tailored_Exception_Information (E : Exception_Occurrence) return String; --- 1370,1377 ---- use System.Standard_Library; function To_Address is new ! Ada.Unchecked_Conversion ! (Task_Id, System.Task_Primitives.Task_Address); function Tailored_Exception_Information (E : Exception_Occurrence) return String; *************** package body System.Tasking.Stages is *** 1440,1448 **** Unlock (Self_ID); Unlock (Activator); ! -- After the activation, active priority should be the same ! -- as base priority. We must unlock the Activator first, ! -- though, since it should not wait if we have lower priority. if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then Write_Lock (Self_ID); --- 1450,1458 ---- Unlock (Self_ID); Unlock (Activator); ! -- After the activation, active priority should be the same as base ! -- priority. We must unlock the Activator first, though, since it ! -- should not wait if we have lower priority. if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then Write_Lock (Self_ID); *************** package body System.Tasking.Stages is *** 1456,1470 **** -------------------------------- procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is ! C : Task_Id; ! P : Task_Id; ! CM : constant Master_Level := Self_ID.Master_Within; ! T : aliased Task_Id; To_Be_Freed : Task_Id; ! -- This is a list of ATCBs to be freed, after we have released ! -- all RTS locks. This is necessary because of the locking order ! -- rules, since the storage manager uses Global_Task_Lock. pragma Warnings (Off); function Check_Unactivated_Tasks return Boolean; --- 1466,1480 ---- -------------------------------- procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is ! C : Task_Id; ! P : Task_Id; ! CM : constant Master_Level := Self_ID.Master_Within; ! T : aliased Task_Id; To_Be_Freed : Task_Id; ! -- This is a list of ATCBs to be freed, after we have released all RTS ! -- locks. This is necessary because of the locking order rules, since ! -- the storage manager uses Global_Task_Lock. pragma Warnings (Off); function Check_Unactivated_Tasks return Boolean; *************** package body System.Tasking.Stages is *** 1523,1534 **** (Self_ID.Deferral_Level > 0 or else not System.Restrictions.Abort_Allowed); ! -- Count how many active dependent tasks this master currently ! -- has, and record this in Wait_Count. ! -- This count should start at zero, since it is initialized to ! -- zero for new tasks, and the task should not exit the ! -- sleep-loops that use this count until the count reaches zero. -- While we're counting, if we run across any unactivated tasks that -- belong to this master, we summarily terminate them as required by --- 1533,1544 ---- (Self_ID.Deferral_Level > 0 or else not System.Restrictions.Abort_Allowed); ! -- Count how many active dependent tasks this master currently has, and ! -- record this in Wait_Count. ! -- This count should start at zero, since it is initialized to zero for ! -- new tasks, and the task should not exit the sleep-loops that use this ! -- count until the count reaches zero. -- While we're counting, if we run across any unactivated tasks that -- belong to this master, we summarily terminate them as required by *************** package body System.Tasking.Stages is *** 1543,1548 **** --- 1553,1559 ---- -- Terminate unactivated (never-to-be activated) tasks if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then + pragma Assert (C.Common.State = Unactivated); -- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task -- = CM. The only case where C is pending activation by this *************** package body System.Tasking.Stages is *** 1581,1589 **** -- Wait until dependent tasks are all terminated or ready to terminate. -- While waiting, the task may be awakened if the task's priority needs ! -- changing, or this master is aborted. In the latter case, we want ! -- to abort the dependents, and resume waiting until Wait_Count goes ! -- to zero. Write_Lock (Self_ID); --- 1592,1599 ---- -- Wait until dependent tasks are all terminated or ready to terminate. -- While waiting, the task may be awakened if the task's priority needs ! -- changing, or this master is aborted. In the latter case, we abort the ! -- dependents, and resume waiting until Wait_Count goes to zero. Write_Lock (Self_ID); *************** package body System.Tasking.Stages is *** 1612,1620 **** Self_ID.Common.State := Runnable; Unlock (Self_ID); ! -- Dependents are all terminated or on terminate alternatives. ! -- Now, force those on terminate alternatives to terminate, by ! -- aborting them. pragma Assert (Check_Unactivated_Tasks); --- 1622,1629 ---- Self_ID.Common.State := Runnable; Unlock (Self_ID); ! -- Dependents are all terminated or on terminate alternatives. Now, ! -- force those on terminate alternatives to terminate, by aborting them. pragma Assert (Check_Unactivated_Tasks); *************** package body System.Tasking.Stages is *** 1644,1657 **** -- rules prevent us from doing that without releasing the locks on C -- and Self_ID. Releasing and retaking those locks would be wasteful -- at best, and should not be considered further without more ! -- detailed analysis of potential concurrent accesses to the ! -- ATCBs of C and Self_ID. ! -- Count how many "alive" dependent tasks this master currently ! -- has, and record this in Wait_Count. This count should start at ! -- zero, since it is initialized to zero for new tasks, and the ! -- task should not exit the sleep-loops that use this count until ! -- the count reaches zero. pragma Assert (Self_ID.Common.Wait_Count = 0); --- 1653,1666 ---- -- rules prevent us from doing that without releasing the locks on C -- and Self_ID. Releasing and retaking those locks would be wasteful -- at best, and should not be considered further without more ! -- detailed analysis of potential concurrent accesses to the ATCBs ! -- of C and Self_ID. ! -- Count how many "alive" dependent tasks this master currently has, ! -- and record this in Wait_Count. This count should start at zero, ! -- since it is initialized to zero for new tasks, and the task should ! -- not exit the sleep-loops that use this count until the count ! -- reaches zero. pragma Assert (Self_ID.Common.Wait_Count = 0); *************** package body System.Tasking.Stages is *** 1699,1708 **** -- fast as we can, so there is no point. -- Remove terminated tasks from the list of Self_ID's dependents, but ! -- don't free their ATCBs yet, because of lock order restrictions, ! -- which don't allow us to call "free" or "malloc" while holding any ! -- other locks. Instead, we put those ATCBs to be freed onto a ! -- temporary list, called To_Be_Freed. if not Single_Lock then Lock_RTS; --- 1708,1717 ---- -- fast as we can, so there is no point. -- Remove terminated tasks from the list of Self_ID's dependents, but ! -- don't free their ATCBs yet, because of lock order restrictions, which ! -- don't allow us to call "free" or "malloc" while holding any other ! -- locks. Instead, we put those ATCBs to be freed onto a temporary list, ! -- called To_Be_Freed. if not Single_Lock then Lock_RTS; *************** package body System.Tasking.Stages is *** 1747,1759 **** -- ??? -- The check "T.Common.Parent /= null ..." below is to prevent dangling ! -- references to terminated library-level tasks, which could ! -- otherwise occur during finalization of library-level objects. ! -- A better solution might be to hook task objects into the ! -- finalization chain and deallocate the ATCB when the task ! -- object is deallocated. However, this change is not likely ! -- to gain anything significant, since all this storage should ! -- be recovered en-masse when the process exits. while To_Be_Freed /= null loop T := To_Be_Freed; --- 1756,1767 ---- -- ??? -- The check "T.Common.Parent /= null ..." below is to prevent dangling ! -- references to terminated library-level tasks, which could otherwise ! -- occur during finalization of library-level objects. A better solution ! -- might be to hook task objects into the finalization chain and ! -- deallocate the ATCB when the task object is deallocated. However, ! -- this change is not likely to gain anything significant, since all ! -- this storage should be recovered en-masse when the process exits. while To_Be_Freed /= null loop T := To_Be_Freed; *************** package body System.Tasking.Stages is *** 1803,1808 **** --- 1811,1817 ---- -- ATCB. That would not cover the case of unactivated tasks. It also -- would force us to keep the underlying thread around past termination, -- since references to the ATCB are possible past termination. + -- Currently, we get rid of the thread as soon as the task terminates, -- and let the parent recover the ATCB later. *************** package body System.Tasking.Stages is *** 1812,1820 **** -- that no longer have ATCBs. It is not clear how much this would gain, -- since the user-level task object would still be occupying storage. ! -- Make next master level up active. ! -- We don't need to lock the ATCB, since the value is only updated by ! -- each task for itself. Self_ID.Master_Within := CM - 1; end Vulnerable_Complete_Master; --- 1821,1828 ---- -- that no longer have ATCBs. It is not clear how much this would gain, -- since the user-level task object would still be occupying storage. ! -- Make next master level up active. We don't need to lock the ATCB, ! -- since the value is only updated by each task for itself. Self_ID.Master_Within := CM - 1; end Vulnerable_Complete_Master; *************** package body System.Tasking.Stages is *** 1876,1884 **** Unlock_RTS; end if; ! -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 ! -- we may have dependent tasks for which we need to wait. ! -- Otherwise, we can just exit. if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then Vulnerable_Complete_Master (Self_ID); --- 1884,1891 ---- Unlock_RTS; end if; ! -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 we may have ! -- dependent tasks for which we need to wait. Otherwise we just exit. if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then Vulnerable_Complete_Master (Self_ID); *************** package body System.Tasking.Stages is *** 1889,1905 **** -- Vulnerable_Free_Task -- -------------------------- ! -- Recover all runtime system storage associated with the task T. ! -- This should only be called after T has terminated and will no ! -- longer be referenced. ! -- For tasks created by an allocator that fails, due to an exception, ! -- it is called from Expunge_Unactivated_Tasks. ! -- For tasks created by elaboration of task object declarations it ! -- is called from the finalization code of the Task_Wrapper procedure. ! -- It is also called from Ada.Unchecked_Deallocation, for objects that ! -- are or contain tasks. procedure Vulnerable_Free_Task (T : Task_Id) is begin --- 1896,1912 ---- -- Vulnerable_Free_Task -- -------------------------- ! -- Recover all runtime system storage associated with the task T. This ! -- should only be called after T has terminated and will no longer be ! -- referenced. ! -- For tasks created by an allocator that fails, due to an exception, it ! -- is called from Expunge_Unactivated_Tasks. ! -- For tasks created by elaboration of task object declarations it is ! -- called from the finalization code of the Task_Wrapper procedure. It is ! -- also called from Ada.Unchecked_Deallocation, for objects that are or ! -- contain tasks. procedure Vulnerable_Free_Task (T : Task_Id) is begin *************** package body System.Tasking.Stages is *** 1917,1929 **** Unlock_RTS; end if; System.Task_Primitives.Operations.Finalize_TCB (T); end Vulnerable_Free_Task; -- Package elaboration code begin ! -- Establish the Adafinal softlink -- This is not done inside the central RTS initialization routine -- to avoid with-ing this package from System.Tasking.Initialization. --- 1924,1937 ---- Unlock_RTS; end if; + Free_Entry_Names (T); System.Task_Primitives.Operations.Finalize_TCB (T); end Vulnerable_Free_Task; -- Package elaboration code begin ! -- Establish the Adafinal oftlink -- This is not done inside the central RTS initialization routine -- to avoid with-ing this package from System.Tasking.Initialization. diff -Nrcpad gcc-4.3.3/gcc/ada/s-tassta.ads gcc-4.4.0/gcc/ada/s-tassta.ads *** gcc-4.3.3/gcc/ada/s-tassta.ads Fri Apr 6 09:19:10 2007 --- gcc-4.4.0/gcc/ada/s-tassta.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 37,50 **** -- Note: Only the compiler is allowed to use this interface, by generating -- direct calls to it, via Rtsfind. -- Any changes to this interface may require corresponding compiler changes -- in exp_ch9.adb and possibly exp_ch7.adb with System.Task_Info; - -- used for Task_Info_Type - with System.Parameters; ! -- used for Size_Type package System.Tasking.Stages is pragma Elaborate_Body; --- 35,48 ---- -- Note: Only the compiler is allowed to use this interface, by generating -- direct calls to it, via Rtsfind. + -- Any changes to this interface may require corresponding compiler changes -- in exp_ch9.adb and possibly exp_ch7.adb with System.Task_Info; with System.Parameters; ! ! with Ada.Real_Time; package System.Tasking.Stages is pragma Elaborate_Body; *************** package System.Tasking.Stages is *** 83,90 **** -- _init.discr := discr; -- _init._task_id := null; -- create_task (unspecified_priority, tZ, ! -- unspecified_task_info, 0, _master, ! -- task_procedure_access!(tB'address), -- _init'address, tE'unchecked_access, _chain, _task_id, _init. -- _task_id); -- return; --- 81,88 ---- -- _init.discr := discr; -- _init._task_id := null; -- create_task (unspecified_priority, tZ, ! -- unspecified_task_info, ada__real_time__time_span_zero, 0, ! -- _master, task_procedure_access!(tB'address), -- _init'address, tE'unchecked_access, _chain, _task_id, _init. -- _task_id); -- return; *************** package System.Tasking.Stages is *** 169,185 **** -- now in order to wake up the activator (the environment task). procedure Create_Task ! (Priority : Integer; ! Size : System.Parameters.Size_Type; ! Task_Info : System.Task_Info.Task_Info_Type; ! Num_Entries : Task_Entry_Index; ! Master : Master_Level; ! State : Task_Procedure_Access; ! Discriminants : System.Address; ! Elaborated : Access_Boolean; ! Chain : in out Activation_Chain; ! Task_Image : String; ! Created_Task : out Task_Id); -- Compiler interface only. Do not call from within the RTS. -- This must be called to create a new task. -- --- 167,185 ---- -- now in order to wake up the activator (the environment task). procedure Create_Task ! (Priority : Integer; ! Size : System.Parameters.Size_Type; ! Task_Info : System.Task_Info.Task_Info_Type; ! Relative_Deadline : Ada.Real_Time.Time_Span; ! Num_Entries : Task_Entry_Index; ! Master : Master_Level; ! State : Task_Procedure_Access; ! Discriminants : System.Address; ! Elaborated : Access_Boolean; ! Chain : in out Activation_Chain; ! Task_Image : String; ! Created_Task : out Task_Id; ! Build_Entry_Names : Boolean); -- Compiler interface only. Do not call from within the RTS. -- This must be called to create a new task. -- *************** package System.Tasking.Stages is *** 188,199 **** -- Size is the stack size of the task to create -- Task_Info is the task info associated with the created task, or -- Unspecified_Task_Info if none. -- State is the compiler generated task's procedure body -- Discriminants is a pointer to a limited record whose discriminants -- are those of the task to create. This parameter should be passed as -- the single argument to State. -- Elaborated is a pointer to a Boolean that must be set to true on exit ! -- if the task could be sucessfully elaborated. -- Chain is a linked list of task that needs to be created. On exit, -- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID -- will be Created_Task (e.g the created task will be linked at the front --- 188,201 ---- -- Size is the stack size of the task to create -- Task_Info is the task info associated with the created task, or -- Unspecified_Task_Info if none. + -- Relative_Deadline is the relative deadline associated with the created + -- task by means of a pragma Relative_Deadline, or 0.0 if none. -- State is the compiler generated task's procedure body -- Discriminants is a pointer to a limited record whose discriminants -- are those of the task to create. This parameter should be passed as -- the single argument to State. -- Elaborated is a pointer to a Boolean that must be set to true on exit ! -- if the task could be successfully elaborated. -- Chain is a linked list of task that needs to be created. On exit, -- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID -- will be Created_Task (e.g the created task will be linked at the front *************** package System.Tasking.Stages is *** 202,207 **** --- 204,211 ---- -- run time can store to ease the debugging and the -- Ada.Task_Identification facility. -- Created_Task is the resulting task. + -- Build_Entry_Names is a flag which controls the allocation of the data + -- structure which stores all entry names. -- -- This procedure can raise Storage_Error if the task creation failed. *************** package System.Tasking.Stages is *** 273,278 **** --- 277,289 ---- -- that doesn't happen, they will never be activated, and will become -- terminated on leaving the return statement. + procedure Set_Entry_Name + (T : Task_Id; + Pos : Task_Entry_Index; + Val : String_Access); + -- This is called by the compiler to map a string which denotes an entry + -- name to a task entry index. + function Terminated (T : Task_Id) return Boolean; -- This is called by the compiler to implement the 'Terminated attribute. -- Though is not required to be so by the ARM, we choose to synchronize diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasuti.adb gcc-4.4.0/gcc/ada/s-tasuti.adb *** gcc-4.3.3/gcc/ada/s-tasuti.adb Wed Jun 6 10:14:59 2007 --- gcc-4.4.0/gcc/ada/s-tasuti.adb Thu Apr 9 23:23:07 2009 *************** *** 6,69 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package provides RTS Internal Declarations. -- These declarations are not part of the GNARLI pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during ! -- tasking operations. It causes infinite loops and other problems. with System.Tasking.Debug; - -- used for Known_Tasks - with System.Task_Primitives.Operations; - -- used for Write_Lock - -- Wakeup - -- Unlock - -- Sleep - -- Abort_Task - -- Lock/Unlock_RTS - with System.Tasking.Initialization; - -- Used for Defer_Abort - -- Undefer_Abort - -- Locked_Abort_To_Level - with System.Tasking.Queuing; - -- used for Dequeue_Call - -- Dequeue_Head - with System.Parameters; - -- used for Single_Lock - -- Runtime_Traces - with System.Traces.Tasking; - -- used for Send_Trace_Info package body System.Tasking.Utilities is --- 6,48 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package provides RTS Internal Declarations ! -- These declarations are not part of the GNARLI pragma Polling (Off); ! -- Turn off polling, we do not want ATC polling to take place during tasking ! -- operations. It causes infinite loops and other problems. with System.Tasking.Debug; with System.Task_Primitives.Operations; with System.Tasking.Initialization; with System.Tasking.Queuing; with System.Parameters; with System.Traces.Tasking; package body System.Tasking.Utilities is *************** package body System.Tasking.Utilities is *** 129,136 **** if System.Tasking.Detect_Blocking and then Self_Id.Common.Protected_Action_Nesting > 0 then ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, "potentially blocking operation"); end if; Initialization.Defer_Abort_Nestable (Self_Id); --- 108,114 ---- if System.Tasking.Detect_Blocking and then Self_Id.Common.Protected_Action_Nesting > 0 then ! raise Program_Error with "potentially blocking operation"; end if; Initialization.Defer_Abort_Nestable (Self_Id); diff -Nrcpad gcc-4.3.3/gcc/ada/s-tasuti.ads gcc-4.4.0/gcc/ada/s-tasuti.ads *** gcc-4.3.3/gcc/ada/s-tasuti.ads Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-tasuti.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 35,45 **** -- These declarations are not part of the GNARLI with Ada.Unchecked_Conversion; package System.Tasking.Utilities is function ATCB_To_Address is new ! Ada.Unchecked_Conversion (Task_Id, System.Address); --------------------------------- -- Task_Stage Related routines -- --- 33,44 ---- -- These declarations are not part of the GNARLI with Ada.Unchecked_Conversion; + with System.Task_Primitives; package System.Tasking.Utilities is function ATCB_To_Address is new ! Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address); --------------------------------- -- Task_Stage Related routines -- *************** package System.Tasking.Utilities is *** 94,100 **** procedure Abort_Tasks (Tasks : Task_List); -- Abort_Tasks is called to initiate abort, however, the actual ! -- aborti is done by aborted task by means of Abort_Handler procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean); -- Update counts to indicate current task is either terminated or --- 93,99 ---- procedure Abort_Tasks (Tasks : Task_List); -- Abort_Tasks is called to initiate abort, however, the actual ! -- aborting is done by aborted task by means of Abort_Handler procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean); -- Update counts to indicate current task is either terminated or diff -Nrcpad gcc-4.3.3/gcc/ada/s-tataat.adb gcc-4.4.0/gcc/ada/s-tataat.adb *** gcc-4.3.3/gcc/ada/s-tataat.adb Wed Jun 6 10:46:22 2007 --- gcc-4.4.0/gcc/ada/s-tataat.adb Wed Mar 26 07:35:19 2008 *************** *** 7,13 **** -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, AdaCore -- -- -- -- GNARL 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- -- --- 7,13 ---- -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNARL 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- -- *************** *** 32,47 **** -- -- ------------------------------------------------------------------------------ ! with System.Task_Primitives.Operations; ! -- used for Write_Lock ! -- Unlock ! -- Lock/Unlock_RTS with System.Tasking.Initialization; - -- used for Defer_Abort - -- Undefer_Abort - - with Ada.Unchecked_Conversion; package body System.Tasking.Task_Attributes is --- 32,41 ---- -- -- ------------------------------------------------------------------------------ ! with Ada.Unchecked_Conversion; + with System.Task_Primitives.Operations; with System.Tasking.Initialization; package body System.Tasking.Task_Attributes is diff -Nrcpad gcc-4.3.3/gcc/ada/s-tataat.ads gcc-4.4.0/gcc/ada/s-tataat.ads *** gcc-4.3.3/gcc/ada/s-tataat.ads Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-tataat.ads Wed Mar 26 07:35:19 2008 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2007, AdaCore -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNARL 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- -- *************** *** 35,44 **** -- This package provides support for the body of Ada.Task_Attributes with Ada.Finalization; - -- Used for Limited_Controlled with System.Storage_Elements; - -- Used for Integer_Address package System.Tasking.Task_Attributes is --- 35,42 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tfsetr-default.adb gcc-4.4.0/gcc/ada/s-tfsetr-default.adb *** gcc-4.3.3/gcc/ada/s-tfsetr-default.adb Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/s-tfsetr-default.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tfsetr-vxworks.adb gcc-4.4.0/gcc/ada/s-tfsetr-vxworks.adb *** gcc-4.3.3/gcc/ada/s-tfsetr-vxworks.adb Tue Aug 14 08:45:25 2007 --- gcc-4.4.0/gcc/ada/s-tfsetr-vxworks.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpinop.adb gcc-4.4.0/gcc/ada/s-tpinop.adb *** gcc-4.3.3/gcc/ada/s-tpinop.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-tpinop.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K _ P R I M I T I V E S . -- ! -- I N T E R R U P T _ O P E R A T I O N S -- -- -- ! -- B o d y -- -- -- ! -- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.INTERRUPT_OPERATIONS -- -- -- ! -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpinop.ads gcc-4.4.0/gcc/ada/s-tpinop.ads *** gcc-4.3.3/gcc/ada/s-tpinop.ads Thu Sep 22 10:28:14 2005 --- gcc-4.4.0/gcc/ada/s-tpinop.ads Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K _ P R I M I T I V E S . -- ! -- I N T E R R U P T _ O P E R A T I O N S -- -- -- ! -- S p e c -- -- -- ! -- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.INTERRUPT_OPERATIONS -- -- -- ! -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package System.Task_Primitives.Interrupt *** 42,53 **** package ST renames System.Tasking; procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_Id); ! -- Associate an Interrupt_ID with a task. function Get_Interrupt_ID (T : ST.Task_Id) return IM.Interrupt_ID; ! -- Return the Interrupt_ID associated with a task. function Get_Task_Id (Interrupt : IM.Interrupt_ID) return ST.Task_Id; ! -- Return the Task_Id associated with an Interrupt. end System.Task_Primitives.Interrupt_Operations; --- 39,50 ---- package ST renames System.Tasking; procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_Id); ! -- Associate an Interrupt_ID with a task function Get_Interrupt_ID (T : ST.Task_Id) return IM.Interrupt_ID; ! -- Return the Interrupt_ID associated with a task function Get_Task_Id (Interrupt : IM.Interrupt_ID) return ST.Task_Id; ! -- Return the Task_Id associated with an Interrupt end System.Task_Primitives.Interrupt_Operations; diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpoben.adb gcc-4.4.0/gcc/ada/s-tpoben.adb *** gcc-4.3.3/gcc/ada/s-tpoben.adb Wed Jun 6 10:46:22 2007 --- gcc-4.4.0/gcc/ada/s-tpoben.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- ! -- E N T R I E S -- -- -- ! -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES -- -- -- ! -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 44,75 **** -- Note: the compiler generates direct calls to this interface, via Rtsfind ! with Ada.Exceptions; ! -- Used for Exception_Occurrence_Access ! -- Raise_Exception with System.Task_Primitives.Operations; ! -- Used for Initialize_Lock ! -- Write_Lock ! -- Unlock ! -- Get_Priority ! -- Wakeup ! -- Set_Ceiling with System.Tasking.Initialization; - -- Used for Defer_Abort, - -- Undefer_Abort, - -- Change_Base_Priority - pragma Elaborate_All (System.Tasking.Initialization); ! -- This insures that tasking is initialized if any protected objects are ! -- created. ! ! with System.Restrictions; ! -- Used for Abort_Allowed ! ! with System.Parameters; ! -- Used for Single_Lock package body System.Tasking.Protected_Objects.Entries is --- 41,55 ---- -- Note: the compiler generates direct calls to this interface, via Rtsfind ! with Ada.Unchecked_Deallocation; with System.Task_Primitives.Operations; ! with System.Restrictions; ! with System.Parameters; with System.Tasking.Initialization; pragma Elaborate_All (System.Tasking.Initialization); ! -- To insure that tasking is initialized if any protected objects are created package body System.Tasking.Protected_Objects.Entries is *************** package body System.Tasking.Protected_Ob *** 77,83 **** use Parameters; use Task_Primitives.Operations; ! use Ada.Exceptions; ---------------- -- Local Data -- --- 57,69 ---- use Parameters; use Task_Primitives.Operations; ! ! ----------------------- ! -- Local Subprograms -- ! ----------------------- ! ! procedure Free_Entry_Names (Object : Protection_Entries); ! -- Deallocate all string names associated with protected entries ---------------- -- Local Data -- *************** package body System.Tasking.Protected_Ob *** 126,132 **** STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); if Ceiling_Violation then ! Raise_Exception (Program_Error'Identity, "Ceiling Violation"); end if; if Single_Lock then --- 112,118 ---- STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); if Ceiling_Violation then ! raise Program_Error with "Ceiling Violation"; end if; if Single_Lock then *************** package body System.Tasking.Protected_Ob *** 155,160 **** --- 141,148 ---- end loop; end loop; + Free_Entry_Names (Object); + Object.Finalized := True; if Single_Lock then *************** package body System.Tasking.Protected_Ob *** 166,171 **** --- 154,179 ---- STPO.Finalize_Lock (Object.L'Unrestricted_Access); end Finalize; + ---------------------- + -- Free_Entry_Names -- + ---------------------- + + procedure Free_Entry_Names (Object : Protection_Entries) is + Names : Entry_Names_Array_Access := Object.Entry_Names; + + procedure Free_Entry_Names_Array_Access is new + Ada.Unchecked_Deallocation + (Entry_Names_Array, Entry_Names_Array_Access); + + begin + if Names = null then + return; + end if; + + Free_Entry_Names_Array (Names.all); + Free_Entry_Names_Array_Access (Names); + end Free_Entry_Names; + ----------------- -- Get_Ceiling -- ----------------- *************** package body System.Tasking.Protected_Ob *** 198,211 **** Ceiling_Priority : Integer; Compiler_Info : System.Address; Entry_Bodies : Protected_Entry_Body_Access; ! Find_Body_Index : Find_Body_Index_Access) is Init_Priority : Integer := Ceiling_Priority; Self_ID : constant Task_Id := STPO.Self; begin if Init_Priority = Unspecified_Priority then ! Init_Priority := System.Priority'Last; end if; if Locking_Policy = 'C' --- 206,220 ---- Ceiling_Priority : Integer; Compiler_Info : System.Address; Entry_Bodies : Protected_Entry_Body_Access; ! Find_Body_Index : Find_Body_Index_Access; ! Build_Entry_Names : Boolean) is Init_Priority : Integer := Ceiling_Priority; Self_ID : constant Task_Id := STPO.Self; begin if Init_Priority = Unspecified_Priority then ! Init_Priority := System.Priority'Last; end if; if Locking_Policy = 'C' *************** package body System.Tasking.Protected_Ob *** 234,239 **** --- 243,253 ---- Object.Entry_Queues (E).Head := null; Object.Entry_Queues (E).Tail := null; end loop; + + if Build_Entry_Names then + Object.Entry_Names := + new Entry_Names_Array (1 .. Entry_Index (Object.Num_Entries)); + end if; end Initialize_Protection_Entries; ------------------ *************** package body System.Tasking.Protected_Ob *** 246,253 **** is begin if Object.Finalized then ! Raise_Exception ! (Program_Error'Identity, "Protected Object is finalized"); end if; -- If pragma Detect_Blocking is active then, as described in the ARM --- 260,266 ---- is begin if Object.Finalized then ! raise Program_Error with "Protected Object is finalized"; end if; -- If pragma Detect_Blocking is active then, as described in the ARM *************** package body System.Tasking.Protected_Ob *** 261,267 **** raise Program_Error; end if; ! -- The lock is made without defering abort -- Therefore the abort has to be deferred before calling this routine. -- This means that the compiler has to generate a Defer_Abort call --- 274,280 ---- raise Program_Error; end if; ! -- The lock is made without deferring abort -- Therefore the abort has to be deferred before calling this routine. -- This means that the compiler has to generate a Defer_Abort call *************** package body System.Tasking.Protected_Ob *** 306,312 **** Lock_Entries (Object, Ceiling_Violation); if Ceiling_Violation then ! Raise_Exception (Program_Error'Identity, "Ceiling Violation"); end if; end Lock_Entries; --- 319,325 ---- Lock_Entries (Object, Ceiling_Violation); if Ceiling_Violation then ! raise Program_Error with "Ceiling Violation"; end if; end Lock_Entries; *************** package body System.Tasking.Protected_Ob *** 319,326 **** begin if Object.Finalized then ! Raise_Exception ! (Program_Error'Identity, "Protected Object is finalized"); end if; -- If pragma Detect_Blocking is active then, as described in the ARM --- 332,338 ---- begin if Object.Finalized then ! raise Program_Error with "Protected Object is finalized"; end if; -- If pragma Detect_Blocking is active then, as described in the ARM *************** package body System.Tasking.Protected_Ob *** 334,340 **** -- have read ownership of the protected object, so that this method of -- storing the (single) protected object's owner does not work -- reliably for read locks. However, this is the approach taken for two ! -- major reasosn: first, this function is not currently being used (it -- is provided for possible future use), and second, it largely -- simplifies the implementation. --- 346,352 ---- -- have read ownership of the protected object, so that this method of -- storing the (single) protected object's owner does not work -- reliably for read locks. However, this is the approach taken for two ! -- major reasons: first, this function is not currently being used (it -- is provided for possible future use), and second, it largely -- simplifies the implementation. *************** package body System.Tasking.Protected_Ob *** 345,351 **** Read_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then ! Raise_Exception (Program_Error'Identity, "Ceiling Violation"); end if; -- We are entering in a protected action, so that we increase the --- 357,363 ---- Read_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then ! raise Program_Error with "Ceiling Violation"; end if; -- We are entering in a protected action, so that we increase the *************** package body System.Tasking.Protected_Ob *** 381,386 **** --- 393,413 ---- end Set_Ceiling; -------------------- + -- Set_Entry_Name -- + -------------------- + + procedure Set_Entry_Name + (Object : Protection_Entries'Class; + Pos : Protected_Entry_Index; + Val : String_Access) + is + begin + pragma Assert (Object.Entry_Names /= null); + + Object.Entry_Names (Entry_Index (Pos)) := Val; + end Set_Entry_Name; + + -------------------- -- Unlock_Entries -- -------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpoben.ads gcc-4.4.0/gcc/ada/s-tpoben.ads *** gcc-4.3.3/gcc/ada/s-tpoben.ads Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-tpoben.ads Thu Apr 9 23:23:07 2009 *************** *** 2,42 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- ! -- E N T R I E S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package contains all the simple primitives related to ! -- Protected_Objects with entries (i.e init, lock, unlock). -- The handling of protected objects with no entries is done in -- System.Tasking.Protected_Objects, the complex routines for protected -- objects with entries in System.Tasking.Protected_Objects.Operations. -- The split between Entries and Operations is needed to break circular -- dependencies inside the run time. --- 2,41 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package contains all simple primitives related to Protected_Objects ! -- with entries (i.e init, lock, unlock). ! -- The handling of protected objects with no entries is done in -- System.Tasking.Protected_Objects, the complex routines for protected -- objects with entries in System.Tasking.Protected_Objects.Operations. + -- The split between Entries and Operations is needed to break circular -- dependencies inside the run time. *************** *** 44,51 **** -- Any changes to this interface may require corresponding compiler changes. with Ada.Finalization; - -- used for Limited_Controlled - with Ada.Unchecked_Conversion; package System.Tasking.Protected_Objects.Entries is --- 43,48 ---- *************** package System.Tasking.Protected_Objects *** 114,120 **** Old_Base_Priority : System.Any_Priority; -- Task's base priority when the protected operation was called ! Pending_Action : Boolean; -- Flag indicating that priority has been dipped temporarily in order -- to avoid violating the priority ceiling of the lock associated with -- this protected object, in Lock_Server. The flag tells Unlock_Server --- 111,117 ---- Old_Base_Priority : System.Any_Priority; -- Task's base priority when the protected operation was called ! Pending_Action : Boolean; -- Flag indicating that priority has been dipped temporarily in order -- to avoid violating the priority ceiling of the lock associated with -- this protected object, in Lock_Server. The flag tells Unlock_Server *************** package System.Tasking.Protected_Objects *** 133,143 **** -- Pointer to an array containing the executable code for all entry -- bodies of a protected type. - -- The following function maps the entry index in a call (which denotes - -- the queue to the proper entry) into the body of the entry. - Find_Body_Index : Find_Body_Index_Access; ! Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries); end record; -- No default initial values for this type, since call records --- 130,145 ---- -- Pointer to an array containing the executable code for all entry -- bodies of a protected type. Find_Body_Index : Find_Body_Index_Access; ! -- A function which maps the entry index in a call (which denotes the ! -- queue of the proper entry) into the body of the entry. ! ! Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries); ! ! Entry_Names : Entry_Names_Array_Access := null; ! -- An array of string names which denotes entry [family member] names. ! -- The structure is indexed by protected entry index and contains Num_ ! -- Entries components. end record; -- No default initial values for this type, since call records *************** package System.Tasking.Protected_Objects *** 160,175 **** (Object : Protection_Entries_Access) return Boolean; -- Returns True if an Interrupt_Handler or Attach_Handler pragma applies -- to the protected object. That is to say this primitive returns False for ! -- Protection, but is overriden to return True when interrupt handlers are -- declared so the check required by C.3.1(11) can be implemented in -- System.Tasking.Protected_Objects.Initialize_Protection. procedure Initialize_Protection_Entries ! (Object : Protection_Entries_Access; ! Ceiling_Priority : Integer; ! Compiler_Info : System.Address; ! Entry_Bodies : Protected_Entry_Body_Access; ! Find_Body_Index : Find_Body_Index_Access); -- Initialize the Object parameter so that it can be used by the runtime -- to keep track of the runtime state of a protected object. --- 162,178 ---- (Object : Protection_Entries_Access) return Boolean; -- Returns True if an Interrupt_Handler or Attach_Handler pragma applies -- to the protected object. That is to say this primitive returns False for ! -- Protection, but is overridden to return True when interrupt handlers are -- declared so the check required by C.3.1(11) can be implemented in -- System.Tasking.Protected_Objects.Initialize_Protection. procedure Initialize_Protection_Entries ! (Object : Protection_Entries_Access; ! Ceiling_Priority : Integer; ! Compiler_Info : System.Address; ! Entry_Bodies : Protected_Entry_Body_Access; ! Find_Body_Index : Find_Body_Index_Access; ! Build_Entry_Names : Boolean); -- Initialize the Object parameter so that it can be used by the runtime -- to keep track of the runtime state of a protected object. *************** package System.Tasking.Protected_Objects *** 203,208 **** --- 206,218 ---- Prio : System.Any_Priority); -- Sets the new ceiling priority of the protected object + procedure Set_Entry_Name + (Object : Protection_Entries'Class; + Pos : Protected_Entry_Index; + Val : String_Access); + -- This is called by the compiler to map a string which denotes an entry + -- name to a protected entry index. + procedure Unlock_Entries (Object : Protection_Entries_Access); -- Relinquish ownership of the lock for the object represented by the -- Object parameter. If this ownership was for write access, or if it was diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpobop.adb gcc-4.4.0/gcc/ada/s-tpobop.adb *** gcc-4.3.3/gcc/ada/s-tpobop.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/s-tpobop.adb Thu Apr 9 23:23:07 2009 *************** *** 2,39 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- ! -- O P E R A T I O N S -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package contains all the extended primitives related to ! -- Protected_Objects with entries. -- The handling of protected objects with no entries is done in -- System.Tasking.Protected_Objects, the simple routines for protected --- 2,36 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package contains all extended primitives related to Protected_Objects ! -- with entries. -- The handling of protected objects with no entries is done in -- System.Tasking.Protected_Objects, the simple routines for protected *************** *** 46,96 **** -- Note: the compiler generates direct calls to this interface, via Rtsfind. with System.Task_Primitives.Operations; - -- used for Initialize_Lock - -- Write_Lock - -- Unlock - -- Get_Priority - -- Wakeup - with System.Tasking.Entry_Calls; - -- used for Wait_For_Completion - -- Wait_Until_Abortable - -- Wait_For_Completion_With_Timeout - - with System.Tasking.Initialization; - -- Used for Defer_Abort, - -- Undefer_Abort, - -- Change_Base_Priority - - pragma Elaborate_All (System.Tasking.Initialization); - -- This insures that tasking is initialized if any protected objects are - -- created. - with System.Tasking.Queuing; - -- used for Enqueue - -- Broadcast_Program_Error - -- Select_Protected_Entry_Call - -- Onqueue - -- Count_Waiting - with System.Tasking.Rendezvous; - -- used for Task_Do_Or_Queue - with System.Tasking.Utilities; - -- used for Exit_One_ATC_Level - with System.Tasking.Debug; - -- used for Trace - with System.Parameters; - -- used for Single_Lock - -- Runtime_Traces - with System.Traces.Tasking; - -- used for Send_Trace_Info - with System.Restrictions; ! -- used for Run_Time_Restrictions package body System.Tasking.Protected_Objects.Operations is --- 43,60 ---- -- Note: the compiler generates direct calls to this interface, via Rtsfind. with System.Task_Primitives.Operations; with System.Tasking.Entry_Calls; with System.Tasking.Queuing; with System.Tasking.Rendezvous; with System.Tasking.Utilities; with System.Tasking.Debug; with System.Parameters; with System.Traces.Tasking; with System.Restrictions; ! ! with System.Tasking.Initialization; ! pragma Elaborate_All (System.Tasking.Initialization); ! -- Insures that tasking is initialized if any protected objects are created package body System.Tasking.Protected_Objects.Operations is *************** package body System.Tasking.Protected_Ob *** 540,546 **** -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous -- entry call. ! -- The initial part of this procedure does not need to lock the the calling -- task's ATCB, up to the point where the call record first may be queued -- (PO_Do_Or_Queue), since before that no other task will have access to -- the record. --- 504,510 ---- -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous -- entry call. ! -- The initial part of this procedure does not need to lock the calling -- task's ATCB, up to the point where the call record first may be queued -- (PO_Do_Or_Queue), since before that no other task will have access to -- the record. *************** package body System.Tasking.Protected_Ob *** 554,560 **** -- There are some heuristics here, just to save time for frequently -- occurring cases. For example, we check Initially_Abortable to try to -- avoid calling the procedure Wait_Until_Abortable, since the normal case ! -- for async. entry calls is to be queued abortably. -- Another heuristic uses the Block.Enqueued to try to avoid calling -- Cancel_Protected_Entry_Call if the call can be served immediately. --- 518,524 ---- -- There are some heuristics here, just to save time for frequently -- occurring cases. For example, we check Initially_Abortable to try to -- avoid calling the procedure Wait_Until_Abortable, since the normal case ! -- for async. entry calls is to be queued abortably. -- Another heuristic uses the Block.Enqueued to try to avoid calling -- Cancel_Protected_Entry_Call if the call can be served immediately. *************** package body System.Tasking.Protected_Ob *** 580,587 **** end if; if Self_ID.ATC_Nesting_Level = ATC_Level'Last then ! Raise_Exception ! (Storage_Error'Identity, "not enough ATC nesting levels"); end if; -- If pragma Detect_Blocking is active then Program_Error must be --- 544,550 ---- end if; if Self_ID.ATC_Nesting_Level = ATC_Level'Last then ! raise Storage_Error with "not enough ATC nesting levels"; end if; -- If pragma Detect_Blocking is active then Program_Error must be *************** package body System.Tasking.Protected_Ob *** 591,598 **** if Detect_Blocking and then Self_ID.Common.Protected_Action_Nesting > 0 then ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, "potentially blocking operation"); end if; -- Self_ID.Deferral_Level should be 0, except when called from Finalize, --- 554,560 ---- if Detect_Blocking and then Self_ID.Common.Protected_Action_Nesting > 0 then ! raise Program_Error with "potentially blocking operation"; end if; -- Self_ID.Deferral_Level should be 0, except when called from Finalize, *************** package body System.Tasking.Protected_Ob *** 981,988 **** begin if Self_Id.ATC_Nesting_Level = ATC_Level'Last then ! Raise_Exception (Storage_Error'Identity, ! "not enough ATC nesting levels"); end if; -- If pragma Detect_Blocking is active then Program_Error must be --- 943,949 ---- begin if Self_Id.ATC_Nesting_Level = ATC_Level'Last then ! raise Storage_Error with "not enough ATC nesting levels"; end if; -- If pragma Detect_Blocking is active then Program_Error must be *************** package body System.Tasking.Protected_Ob *** 992,999 **** if Detect_Blocking and then Self_Id.Common.Protected_Action_Nesting > 0 then ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, "potentially blocking operation"); end if; if Runtime_Traces then --- 953,959 ---- if Detect_Blocking and then Self_Id.Common.Protected_Action_Nesting > 0 then ! raise Program_Error with "potentially blocking operation"; end if; if Runtime_Traces then diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpobop.ads gcc-4.4.0/gcc/ada/s-tpobop.ads *** gcc-4.3.3/gcc/ada/s-tpobop.ads Tue Aug 14 08:50:09 2007 --- gcc-4.4.0/gcc/ada/s-tpobop.ads Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- ! -- O P E R A T I O N S -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 45,51 **** -- Any changes to this interface may require corresponding compiler changes. with Ada.Exceptions; - -- Used for Exception_Id with System.Tasking.Protected_Objects.Entries; --- 42,47 ---- *************** private *** 200,205 **** --- 196,210 ---- end record; pragma Volatile (Communication_Block); + -- When a program contains limited interfaces, the compiler generates the + -- predefined primitives associated with dispatching selects. One of the + -- parameters of these routines is of type Communication_Block. Even if + -- the program lacks implementing concurrent types, the tasking runtime is + -- dragged in unconditionally because of Communication_Block. To avoid this + -- case, the compiler uses type Dummy_Communication_Block which defined in + -- System.Soft_Links. If the structure of Communication_Block is changed, + -- the corresponding dummy type must be changed as well. + -- The Communication_Block seems to be a relic. At the moment, the -- compiler seems to be generating unnecessary conditional code based on -- this block. See the code generated for async. select with task entry diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpopde-vms.adb gcc-4.4.0/gcc/ada/s-tpopde-vms.adb *** gcc-4.3.3/gcc/ada/s-tpopde-vms.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-tpopde-vms.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S . -- ! -- D E C -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package body System.Task_Primitives.Oper *** 70,86 **** -- Local Subprograms -- ----------------------- - pragma Warnings (Off); - -- Task_Id is 64 bits wide (but only 32 bits significant) on Integrity/VMS - function To_Unsigned_Longword is new Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword); function To_Task_Id is new Ada.Unchecked_Conversion (Unsigned_Longword, Task_Id); - pragma Warnings (On); - function To_FAB_RAB is new Ada.Unchecked_Conversion (Address, FAB_RAB_Access_Type); --- 67,78 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpopde-vms.ads gcc-4.4.0/gcc/ada/s-tpopde-vms.ads *** gcc-4.3.3/gcc/ada/s-tpopde-vms.ads Thu Dec 13 10:19:04 2007 --- gcc-4.4.0/gcc/ada/s-tpopde-vms.ads Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S . -- ! -- D E C -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** package System.Task_Primitives.Operation *** 39,56 **** procedure Interrupt_AST_Handler (ID : Address); pragma Convention (C, Interrupt_AST_Handler); ! -- Handles the AST for Ada95 Interrupts. procedure RMS_AST_Handler (ID : Address); ! -- Handles the AST for RMS_Asynch_Operations. function Self return System.Aux_DEC.Unsigned_Longword; ! -- Returns the task identification for the AST. procedure Starlet_AST_Handler (ID : Address); ! -- Handles the AST for Starlet Tasking_Services. procedure Task_Synch; ! -- Synchronizes the task after the system service completes. end System.Task_Primitives.Operations.DEC; --- 36,53 ---- procedure Interrupt_AST_Handler (ID : Address); pragma Convention (C, Interrupt_AST_Handler); ! -- Handles the AST for Ada95 Interrupts procedure RMS_AST_Handler (ID : Address); ! -- Handles the AST for RMS_Asynch_Operations function Self return System.Aux_DEC.Unsigned_Longword; ! -- Returns the task identification for the AST procedure Starlet_AST_Handler (ID : Address); ! -- Handles the AST for Starlet Tasking_Services procedure Task_Synch; ! -- Synchronizes the task after the system service completes end System.Task_Primitives.Operations.DEC; diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpopsp-lynxos.adb gcc-4.4.0/gcc/ada/s-tpopsp-lynxos.adb *** gcc-4.3.3/gcc/ada/s-tpopsp-lynxos.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-tpopsp-lynxos.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S . -- ! -- S P E C I F I C -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpopsp-posix-foreign.adb gcc-4.4.0/gcc/ada/s-tpopsp-posix-foreign.adb *** gcc-4.3.3/gcc/ada/s-tpopsp-posix-foreign.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-tpopsp-posix-foreign.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S . -- ! -- S P E C I F I C -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpopsp-posix.adb gcc-4.4.0/gcc/ada/s-tpopsp-posix.adb *** gcc-4.3.3/gcc/ada/s-tpopsp-posix.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-tpopsp-posix.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S . -- ! -- S P E C I F I C -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, Free Software Fundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpopsp-rtems.adb gcc-4.4.0/gcc/ada/s-tpopsp-rtems.adb *** gcc-4.3.3/gcc/ada/s-tpopsp-rtems.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-tpopsp-rtems.adb Sun Apr 13 17:25:22 2008 *************** *** 10,15 **** --- 10,16 ---- -- $Revision: 1.2 $ -- -- -- Copyright (C) 1991-2003, Florida State University -- + -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 36,42 **** ------------------------------------------------------------------------------ -- This is a RTEMS version of this package which uses a special ! -- variable for Ada self which is contexted switch implicitly by RTEMS. -- -- This is the same as the POSIX version except that an RTEMS variable -- is used instead of a POSIX key. --- 37,43 ---- ------------------------------------------------------------------------------ -- This is a RTEMS version of this package which uses a special ! -- variable for Ada self which is context switched implicitly by RTEMS. -- -- This is the same as the POSIX version except that an RTEMS variable -- is used instead of a POSIX key. diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpopsp-solaris.adb gcc-4.4.0/gcc/ada/s-tpopsp-solaris.adb *** gcc-4.3.3/gcc/ada/s-tpopsp-solaris.adb Mon Sep 5 07:46:06 2005 --- gcc-4.4.0/gcc/ada/s-tpopsp-solaris.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S . -- ! -- S P E C I F I C -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tpopsp-vxworks.adb gcc-4.4.0/gcc/ada/s-tpopsp-vxworks.adb *** gcc-4.3.3/gcc/ada/s-tpopsp-vxworks.adb Mon Sep 5 07:49:24 2005 --- gcc-4.4.0/gcc/ada/s-tpopsp-vxworks.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S . -- ! -- S P E C I F I C -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tporft.adb gcc-4.4.0/gcc/ada/s-tporft.adb *** gcc-4.3.3/gcc/ada/s-tporft.adb Wed Sep 26 10:41:24 2007 --- gcc-4.4.0/gcc/ada/s-tporft.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S . -- ! -- R E G I S T E R _ F O R E I G N _ T H R E A D -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.REGISTER_FOREIGN_THREAD -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tposen.adb gcc-4.4.0/gcc/ada/s-tposen.adb *** gcc-4.3.3/gcc/ada/s-tposen.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/s-tposen.adb Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- ! -- S I N G L E _ E N T R Y -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 33,40 **** ------------------------------------------------------------------------------ pragma Style_Checks (All_Checks); ! -- Turn off subprogram ordering check, since restricted GNARLI ! -- subprograms are gathered together at end. -- This package provides an optimized version of Protected_Objects.Operations -- and Protected_Objects.Entries making the following assumptions: --- 30,37 ---- ------------------------------------------------------------------------------ pragma Style_Checks (All_Checks); ! -- Turn off subprogram ordering check, since restricted GNARLI subprograms are ! -- gathered together at end. -- This package provides an optimized version of Protected_Objects.Operations -- and Protected_Objects.Entries making the following assumptions: *************** pragma Polling (Off); *** 60,78 **** -- operations. It can cause infinite loops and other problems. pragma Suppress (All_Checks); ! ! with System.Task_Primitives.Operations; ! -- used for Self ! -- Finalize_Lock ! -- Write_Lock ! -- Unlock with Ada.Exceptions; - -- used for Exception_Id - -- Raise_Exception with System.Parameters; - -- used for Single_Lock package body System.Tasking.Protected_Objects.Single_Entry is --- 57,68 ---- -- operations. It can cause infinite loops and other problems. pragma Suppress (All_Checks); ! -- Why is this required ??? with Ada.Exceptions; + with System.Task_Primitives.Operations; with System.Parameters; package body System.Tasking.Protected_Objects.Single_Entry is *************** package body System.Tasking.Protected_Ob *** 155,161 **** use type Ada.Exceptions.Exception_Id; E : constant Ada.Exceptions.Exception_Id := ! Entry_Call.Exception_To_Raise; begin if E /= Ada.Exceptions.Null_Id then --- 145,151 ---- use type Ada.Exceptions.Exception_Id; E : constant Ada.Exceptions.Exception_Id := ! Entry_Call.Exception_To_Raise; begin if E /= Ada.Exceptions.Null_Id then *************** package body System.Tasking.Protected_Ob *** 415,421 **** -- have read ownership of the protected object, so that this method of -- storing the (single) protected object's owner does not work -- reliably for read locks. However, this is the approach taken for two ! -- major reasosn: first, this function is not currently being used (it -- is provided for possible future use), and second, it largely -- simplifies the implementation. --- 405,411 ---- -- have read ownership of the protected object, so that this method of -- storing the (single) protected object's owner does not work -- reliably for read locks. However, this is the approach taken for two ! -- major reasons: first, this function is not currently being used (it -- is provided for possible future use), and second, it largely -- simplifies the implementation. *************** package body System.Tasking.Protected_Ob *** 560,567 **** if Detect_Blocking and then Self_Id.Common.Protected_Action_Nesting > 0 then ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, "potentially blocking operation"); end if; Lock_Entry (Object); --- 550,556 ---- if Detect_Blocking and then Self_Id.Common.Protected_Action_Nesting > 0 then ! raise Program_Error with "potentially blocking operation"; end if; Lock_Entry (Object); *************** package body System.Tasking.Protected_Ob *** 686,693 **** if Detect_Blocking and then Self_Id.Common.Protected_Action_Nesting > 0 then ! Ada.Exceptions.Raise_Exception ! (Program_Error'Identity, "potentially blocking operation"); end if; STPO.Write_Lock (Object.L'Access, Ceiling_Violation); --- 675,681 ---- if Detect_Blocking and then Self_Id.Common.Protected_Action_Nesting > 0 then ! raise Program_Error with "potentially blocking operation"; end if; STPO.Write_Lock (Object.L'Access, Ceiling_Violation); diff -Nrcpad gcc-4.3.3/gcc/ada/s-tposen.ads gcc-4.4.0/gcc/ada/s-tposen.ads *** gcc-4.3.3/gcc/ada/s-tposen.ads Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-tposen.ads Thu Apr 9 23:23:07 2009 *************** *** 2,31 **** -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- ! -- S I N G L E _ E N T R Y -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 2,28 ---- -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- *************** *** 35,47 **** -- This package provides an optimized version of Protected_Objects.Operations -- and Protected_Objects.Entries making the following assumptions: -- ! -- PO have only one entry ! -- There is only one caller at a time (No_Entry_Queue) ! -- There is no dynamic priority support (No_Dynamic_Priorities) ! -- No Abort Statements ! -- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) ! -- PO are at library level ! -- None of the tasks will terminate (no need for finalization) -- -- This interface is intended to be used in the ravenscar profile, the -- compiler is responsible for ensuring that the conditions mentioned above --- 32,44 ---- -- This package provides an optimized version of Protected_Objects.Operations -- and Protected_Objects.Entries making the following assumptions: -- ! -- PO have only one entry ! -- There is only one caller at a time (No_Entry_Queue) ! -- There is no dynamic priority support (No_Dynamic_Priorities) ! -- No Abort Statements ! -- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) ! -- PO are at library level ! -- None of the tasks will terminate (no need for finalization) -- -- This interface is intended to be used in the ravenscar profile, the -- compiler is responsible for ensuring that the conditions mentioned above *************** package System.Tasking.Protected_Objects *** 205,211 **** -- Lock a protected object for read access. Upon return, the caller -- owns the lock for read access, and no other calls to Lock -- with the same argument will return until the corresponding call ! -- to Unlock has been made by the caller. Other cals to Lock_Read_Only -- may (but need not) return before the call to Unlock, and the -- corresponding callers will also own the lock for read access. --- 202,208 ---- -- Lock a protected object for read access. Upon return, the caller -- owns the lock for read access, and no other calls to Lock -- with the same argument will return until the corresponding call ! -- to Unlock has been made by the caller. Other calls to Lock_Read_Only -- may (but need not) return before the call to Unlock, and the -- corresponding callers will also own the lock for read access. *************** package System.Tasking.Protected_Objects *** 268,274 **** function Protected_Count_Entry (Object : Protection_Entry) return Natural; ! -- Return the number of entry calls on Object (0 or 1). function Protected_Single_Entry_Caller (Object : Protection_Entry) return Task_Id; --- 265,271 ---- function Protected_Count_Entry (Object : Protection_Entry) return Natural; ! -- Return the number of entry calls on Object (0 or 1) function Protected_Single_Entry_Caller (Object : Protection_Entry) return Task_Id; diff -Nrcpad gcc-4.3.3/gcc/ada/s-traceb-hpux.adb gcc-4.4.0/gcc/ada/s-traceb-hpux.adb *** gcc-4.3.3/gcc/ada/s-traceb-hpux.adb Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-traceb-hpux.adb Sun Apr 13 17:25:22 2008 *************** *** 8,13 **** --- 8,14 ---- -- B o d y -- -- -- -- Copyright (C) 1999-2006, AdaCore -- + -- Copyright (C) 2008, 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- -- *************** package body System.Traceback is *** 86,92 **** -- Frames with dynamic stack allocation are handled using the associated -- frame pointer, but HP compilers and GCC setup this pointer differently. -- HP compilers set it to point at the top (highest address) of the static ! -- part of the frame, wheras GCC sets it to point at the bottom of this -- region. We have to fake the unwinder to compensate for this difference, -- for which we'll need to access some subprograms unwind descriptors. --- 87,93 ---- -- Frames with dynamic stack allocation are handled using the associated -- frame pointer, but HP compilers and GCC setup this pointer differently. -- HP compilers set it to point at the top (highest address) of the static ! -- part of the frame, whereas GCC sets it to point at the bottom of this -- region. We have to fake the unwinder to compensate for this difference, -- for which we'll need to access some subprograms unwind descriptors. diff -Nrcpad gcc-4.3.3/gcc/ada/s-traceb.adb gcc-4.4.0/gcc/ada/s-traceb.adb *** gcc-4.3.3/gcc/ada/s-traceb.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-traceb.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-traceb.ads gcc-4.4.0/gcc/ada/s-traceb.ads *** gcc-4.3.3/gcc/ada/s-traceb.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-traceb.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-traces-default.adb gcc-4.4.0/gcc/ada/s-traces-default.adb *** gcc-4.3.3/gcc/ada/s-traces-default.adb Tue Nov 15 13:52:10 2005 --- gcc-4.4.0/gcc/ada/s-traces-default.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-traces.adb gcc-4.4.0/gcc/ada/s-traces.adb *** gcc-4.3.3/gcc/ada/s-traces.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-traces.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-traces.ads gcc-4.4.0/gcc/ada/s-traces.ads *** gcc-4.3.3/gcc/ada/s-traces.ads Mon Sep 5 07:46:06 2005 --- gcc-4.4.0/gcc/ada/s-traces.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 40,68 **** -- A new primitive, Send_Trace_Info (Id : Trace_T; 'data') is introduced. -- Trace_T is an event identifier, 'data' are the informations to pass ! -- with the event. Thid procedure is used from within the Runtime to send -- debug informations. ! -- This primitive is overloaded in System.Traces.Tasking and this package. ! -- Send_Trace_Info calls Send_Trace, in System.Traces.Send, which is trarget -- dependent, to send the debug informations to a debugger, stream .. -- To add a new event, just add them to the Trace_T type, and write the -- corresponding Send_Trace_Info procedure. It may be required for some ! -- target to modify Send_Trace (eg. VxWorks). ! -- To add a new target, just adapt System.Traces.Send to your own purpose. package System.Traces is pragma Preelaborate; type Trace_T is ( ! -- Events handled. -- Messages ! -- M_Accept_Complete, M_Select_Else, M_RDV_Complete, --- 38,66 ---- -- A new primitive, Send_Trace_Info (Id : Trace_T; 'data') is introduced. -- Trace_T is an event identifier, 'data' are the informations to pass ! -- with the event. This procedure is used from within the Runtime to send -- debug informations. ! -- This primitive is overloaded in System.Traces.Tasking and this package ! -- Send_Trace_Info calls Send_Trace, in System.Traces.Send, which is target -- dependent, to send the debug informations to a debugger, stream .. -- To add a new event, just add them to the Trace_T type, and write the -- corresponding Send_Trace_Info procedure. It may be required for some ! -- target to modify Send_Trace (e.g. VxWorks). ! -- To add a new target, just adapt System.Traces.Send to your own purposes package System.Traces is pragma Preelaborate; type Trace_T is ( ! -- Events handled -- Messages ! M_Accept_Complete, M_Select_Else, M_RDV_Complete, *************** package System.Traces is *** 70,82 **** M_Delay, -- Errors ! -- E_Missed, E_Timeout, E_Kill, -- Waiting events ! -- W_Call, W_Accept, W_Select, --- 68,80 ---- M_Delay, -- Errors ! E_Missed, E_Timeout, E_Kill, -- Waiting events ! W_Call, W_Accept, W_Select, *************** package System.Traces is *** 89,95 **** WT_Completion, -- Protected objects events ! -- PO_Call, POT_Call, PO_Run, --- 87,93 ---- WT_Completion, -- Protected objects events ! PO_Call, POT_Call, PO_Run, *************** package System.Traces is *** 98,104 **** PO_Done, -- Task handling events ! -- T_Create, T_Activate, T_Abort, --- 96,102 ---- PO_Done, -- Task handling events ! T_Create, T_Activate, T_Abort, diff -Nrcpad gcc-4.3.3/gcc/ada/s-traent-vms.adb gcc-4.4.0/gcc/ada/s-traent-vms.adb *** gcc-4.3.3/gcc/ada/s-traent-vms.adb Thu Dec 13 10:36:42 2007 --- gcc-4.4.0/gcc/ada/s-traent-vms.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-traent-vms.ads gcc-4.4.0/gcc/ada/s-traent-vms.ads *** gcc-4.3.3/gcc/ada/s-traent-vms.ads Thu Dec 13 10:36:42 2007 --- gcc-4.4.0/gcc/ada/s-traent-vms.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-traent.adb gcc-4.4.0/gcc/ada/s-traent.adb *** gcc-4.3.3/gcc/ada/s-traent.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-traent.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-traent.ads gcc-4.4.0/gcc/ada/s-traent.ads *** gcc-4.3.3/gcc/ada/s-traent.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-traent.ads Thu Apr 9 23:23:07 2009 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 14,34 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 14,32 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-trafor-default.adb gcc-4.4.0/gcc/ada/s-trafor-default.adb *** gcc-4.3.3/gcc/ada/s-trafor-default.adb Tue Oct 31 18:16:03 2006 --- gcc-4.4.0/gcc/ada/s-trafor-default.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2006 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-trafor-default.ads gcc-4.4.0/gcc/ada/s-trafor-default.ads *** gcc-4.3.3/gcc/ada/s-trafor-default.ads Tue Nov 15 13:52:10 2005 --- gcc-4.4.0/gcc/ada/s-trafor-default.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Traces.Format is *** 37,48 **** pragma Preelaborate; Max_Size : constant Integer := 128; ! -- Event messages' maximum size. subtype String_Trace is String (1 .. Max_Size); -- Specific type in which trace information is stored. An ASCII.NUL -- character ends the string so that it is compatible with C strings ! -- which is useful on some targets (eg. VxWorks) -- These private functions handles String_Trace formatting --- 35,46 ---- pragma Preelaborate; Max_Size : constant Integer := 128; ! -- Maximum size if event messages subtype String_Trace is String (1 .. Max_Size); -- Specific type in which trace information is stored. An ASCII.NUL -- character ends the string so that it is compatible with C strings ! -- which is useful on some targets (e.g. VxWorks) -- These private functions handles String_Trace formatting diff -Nrcpad gcc-4.3.3/gcc/ada/s-tratas-default.adb gcc-4.4.0/gcc/ada/s-tratas-default.adb *** gcc-4.3.3/gcc/ada/s-tratas-default.adb Tue Nov 15 13:52:10 2005 --- gcc-4.4.0/gcc/ada/s-tratas-default.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tratas.adb gcc-4.4.0/gcc/ada/s-tratas.adb *** gcc-4.3.3/gcc/ada/s-tratas.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-tratas.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-tratas.ads gcc-4.4.0/gcc/ada/s-tratas.ads *** gcc-4.3.3/gcc/ada/s-tratas.ads Mon Sep 5 07:46:06 2005 --- gcc-4.4.0/gcc/ada/s-tratas.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-unstyp.ads gcc-4.4.0/gcc/ada/s-unstyp.ads *** gcc-4.3.3/gcc/ada/s-unstyp.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-unstyp.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 32,38 **** ------------------------------------------------------------------------------ -- This package contains definitions of standard unsigned types that ! -- correspond in size to the standard signed types declared in Standard. -- and (unlike the types in Interfaces) have corresponding names. It -- also contains some related definitions for other specialized types -- used by the compiler in connection with packed array types. --- 30,36 ---- ------------------------------------------------------------------------------ -- This package contains definitions of standard unsigned types that ! -- correspond in size to the standard signed types declared in Standard, -- and (unlike the types in Interfaces) have corresponding names. It -- also contains some related definitions for other specialized types -- used by the compiler in connection with packed array types. *************** package System.Unsigned_Types is *** 55,61 **** type Packed_Byte is mod 2 ** 8; for Packed_Byte'Size use 8; ! -- Component type for Packed_Butes array type Packed_Bytes1 is array (Natural range <>) of Packed_Byte; for Packed_Bytes1'Alignment use 1; --- 53,59 ---- type Packed_Byte is mod 2 ** 8; for Packed_Byte'Size use 8; ! -- Component type for Packed_Bytes array type Packed_Bytes1 is array (Natural range <>) of Packed_Byte; for Packed_Bytes1'Alignment use 1; *************** package System.Unsigned_Types is *** 200,206 **** pragma Import (Intrinsic, Rotate_Left); pragma Import (Intrinsic, Rotate_Right); ! -- The following definitions are obsolsecent. They were needed by the -- previous version of the compiler and runtime, but are not needed -- by the current version. We retain them to help with bootstrap path -- problems. Also they seem harmless, and if any user programs have --- 198,204 ---- pragma Import (Intrinsic, Rotate_Left); pragma Import (Intrinsic, Rotate_Right); ! -- The following definitions are obsolescent. They were needed by the -- previous version of the compiler and runtime, but are not needed -- by the current version. We retain them to help with bootstrap path -- problems. Also they seem harmless, and if any user programs have diff -Nrcpad gcc-4.3.3/gcc/ada/s-utf_32.adb gcc-4.4.0/gcc/ada/s-utf_32.adb *** gcc-4.3.3/gcc/ada/s-utf_32.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-utf_32.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.UTF_32 is *** 5103,5109 **** begin -- Deal with FFFE/FFFF cases ! if U mod 2#1_0000# >= 16#FFFE# then return Fe; -- Otherwise search table --- 5101,5107 ---- begin -- Deal with FFFE/FFFF cases ! if U mod 16#1_0000# >= 16#FFFE# then return Fe; -- Otherwise search table diff -Nrcpad gcc-4.3.3/gcc/ada/s-utf_32.ads gcc-4.4.0/gcc/ada/s-utf_32.ads *** gcc-4.3.3/gcc/ada/s-utf_32.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-utf_32.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.UTF_32 is *** 117,130 **** function Is_UTF_32_Digit (U : UTF_32) return Boolean; function Is_UTF_32_Digit (C : Category) return Boolean; pragma Inline (Is_UTF_32_Digit); ! -- Returns true iff U is a digit that can be used to extend an identifer, -- or if C is one of the corresponding categories, which are the following: -- Number, Decimal_Digit (Nd) function Is_UTF_32_Line_Terminator (U : UTF_32) return Boolean; pragma Inline (Is_UTF_32_Line_Terminator); -- Returns true iff U is an allowed line terminator for source programs, ! -- if U is in the category Zp (Separator, Paragaph), or Zs (Separator, -- Line), or if U is a conventional line terminator (CR, LF, VT, FF). -- There is no category version for this function, since the set of -- characters does not correspond to a set of Unicode categories. --- 115,128 ---- function Is_UTF_32_Digit (U : UTF_32) return Boolean; function Is_UTF_32_Digit (C : Category) return Boolean; pragma Inline (Is_UTF_32_Digit); ! -- Returns true iff U is a digit that can be used to extend an identifier, -- or if C is one of the corresponding categories, which are the following: -- Number, Decimal_Digit (Nd) function Is_UTF_32_Line_Terminator (U : UTF_32) return Boolean; pragma Inline (Is_UTF_32_Line_Terminator); -- Returns true iff U is an allowed line terminator for source programs, ! -- if U is in the category Zp (Separator, Paragraph), or Zs (Separator, -- Line), or if U is a conventional line terminator (CR, LF, VT, FF). -- There is no category version for this function, since the set of -- characters does not correspond to a set of Unicode categories. *************** package System.UTF_32 is *** 143,149 **** pragma Inline (Is_UTF_32_Other); -- Returns true iff U is an other format character, which means that it -- can be used to extend an identifier, but is ignored for the purposes of ! -- matching of identiers, or if C is one of the corresponding categories, -- which are the following: -- Other, Format (Cf) --- 141,147 ---- pragma Inline (Is_UTF_32_Other); -- Returns true iff U is an other format character, which means that it -- can be used to extend an identifier, but is ignored for the purposes of ! -- matching of identifiers, or if C is one of the corresponding categories, -- which are the following: -- Other, Format (Cf) *************** package System.UTF_32 is *** 151,157 **** function Is_UTF_32_Punctuation (C : Category) return Boolean; pragma Inline (Is_UTF_32_Punctuation); -- Returns true iff U is a punctuation character that can be used to ! -- separate pices of an identifier, or if C is one of the corresponding -- categories, which are the following: -- Punctuation, Connector (Pc) --- 149,155 ---- function Is_UTF_32_Punctuation (C : Category) return Boolean; pragma Inline (Is_UTF_32_Punctuation); -- Returns true iff U is a punctuation character that can be used to ! -- separate pieces of an identifier, or if C is one of the corresponding -- categories, which are the following: -- Punctuation, Connector (Pc) *************** package System.UTF_32 is *** 177,183 **** -- Note that the Ada category format effector is subsumed by the above -- list of Unicode categories. -- ! -- Note that Other, Unassiged (Cn) is quite deliberately not included -- in the list of categories above. This means that should any of these -- code positions be defined in future with graphic characters they will -- be allowed without a need to change implementations or the standard. --- 175,181 ---- -- Note that the Ada category format effector is subsumed by the above -- list of Unicode categories. -- ! -- Note that Other, Unassigned (Cn) is quite deliberately not included -- in the list of categories above. This means that should any of these -- code positions be defined in future with graphic characters they will -- be allowed without a need to change implementations or the standard. diff -Nrcpad gcc-4.3.3/gcc/ada/s-vaflop-vms-alpha.adb gcc-4.4.0/gcc/ada/s-vaflop-vms-alpha.adb *** gcc-4.3.3/gcc/ada/s-vaflop-vms-alpha.adb Tue Oct 31 18:15:40 2006 --- gcc-4.4.0/gcc/ada/s-vaflop-vms-alpha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,38 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2006, Free Software Foundation, Inc. -- -- (Version for Alpha OpenVMS) -- -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! with System.IO; use System.IO; with System.Machine_Code; use System.Machine_Code; package body System.Vax_Float_Operations is --- 6,36 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- -- (Version for Alpha OpenVMS) -- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! with System.IO; with System.Machine_Code; use System.Machine_Code; package body System.Vax_Float_Operations is *************** package body System.Vax_Float_Operations *** 328,334 **** procedure Debug_Output_D (Arg : D) is begin ! Put (D'Image (Arg)); end Debug_Output_D; -------------------- --- 326,332 ---- procedure Debug_Output_D (Arg : D) is begin ! System.IO.Put (D'Image (Arg)); end Debug_Output_D; -------------------- *************** package body System.Vax_Float_Operations *** 337,343 **** procedure Debug_Output_F (Arg : F) is begin ! Put (F'Image (Arg)); end Debug_Output_F; -------------------- --- 335,341 ---- procedure Debug_Output_F (Arg : F) is begin ! System.IO.Put (F'Image (Arg)); end Debug_Output_F; -------------------- *************** package body System.Vax_Float_Operations *** 346,352 **** procedure Debug_Output_G (Arg : G) is begin ! Put (G'Image (Arg)); end Debug_Output_G; -------------------- --- 344,350 ---- procedure Debug_Output_G (Arg : G) is begin ! System.IO.Put (G'Image (Arg)); end Debug_Output_G; -------------------- *************** package body System.Vax_Float_Operations *** 627,633 **** procedure pd (Arg : D) is begin ! Put_Line (D'Image (Arg)); end pd; -------- --- 625,631 ---- procedure pd (Arg : D) is begin ! System.IO.Put_Line (D'Image (Arg)); end pd; -------- *************** package body System.Vax_Float_Operations *** 636,642 **** procedure pf (Arg : F) is begin ! Put_Line (F'Image (Arg)); end pf; -------- --- 634,640 ---- procedure pf (Arg : F) is begin ! System.IO.Put_Line (F'Image (Arg)); end pf; -------- *************** package body System.Vax_Float_Operations *** 645,653 **** procedure pg (Arg : G) is begin ! Put_Line (G'Image (Arg)); end pg; ----------- -- Sub_F -- ----------- --- 643,700 ---- procedure pg (Arg : G) is begin ! System.IO.Put_Line (G'Image (Arg)); end pg; + -------------- + -- Return_D -- + -------------- + + function Return_D (X : D) return D is + R : D; + + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + + Asm ("cvtdg $f0,$f0", Inputs => D'Asm_Input ("g", X), Clobber => "$f0", + Volatile => True); + Asm ("stg $f0,%0", D'Asm_Output ("=m", R), Volatile => True); + return R; + end Return_D; + + -------------- + -- Return_F -- + -------------- + + function Return_F (X : F) return F is + R : F; + + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + + Asm ("stf $f0,%0", F'Asm_Output ("=m", R), F'Asm_Input ("g", X), + Clobber => "$f0", Volatile => True); + return R; + end Return_F; + + -------------- + -- Return_G -- + -------------- + + function Return_G (X : G) return G is + R : G; + + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + + Asm ("stg $f0,%0", G'Asm_Output ("=m", R), G'Asm_Input ("g", X), + Clobber => "$f0", Volatile => True); + return R; + end Return_G; + ----------- -- Sub_F -- ----------- diff -Nrcpad gcc-4.3.3/gcc/ada/s-vaflop.adb gcc-4.4.0/gcc/ada/s-vaflop.adb *** gcc-4.3.3/gcc/ada/s-vaflop.adb Tue Nov 15 13:51:27 2005 --- gcc-4.4.0/gcc/ada/s-vaflop.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 33,43 **** -- This is a dummy body for use on non-Alpha systems so that the library -- can compile. This dummy version uses ordinary conversions and other ! -- arithmetic operations. it is used only for testing purposes in the -- case where the -gnatdm switch is used to force testing of VMS features -- on non-VMS systems. ! with System.IO; use System.IO; package body System.Vax_Float_Operations is pragma Warnings (Off); --- 31,41 ---- -- This is a dummy body for use on non-Alpha systems so that the library -- can compile. This dummy version uses ordinary conversions and other ! -- arithmetic operations. It is used only for testing purposes in the -- case where the -gnatdm switch is used to force testing of VMS features -- on non-VMS systems. ! with System.IO; package body System.Vax_Float_Operations is pragma Warnings (Off); *************** package body System.Vax_Float_Operations *** 94,100 **** procedure Debug_Output_D (Arg : D) is begin ! Put (D'Image (Arg)); end Debug_Output_D; -------------------- --- 92,98 ---- procedure Debug_Output_D (Arg : D) is begin ! System.IO.Put (D'Image (Arg)); end Debug_Output_D; -------------------- *************** package body System.Vax_Float_Operations *** 103,109 **** procedure Debug_Output_F (Arg : F) is begin ! Put (F'Image (Arg)); end Debug_Output_F; -------------------- --- 101,107 ---- procedure Debug_Output_F (Arg : F) is begin ! System.IO.Put (F'Image (Arg)); end Debug_Output_F; -------------------- *************** package body System.Vax_Float_Operations *** 112,118 **** procedure Debug_Output_G (Arg : G) is begin ! Put (G'Image (Arg)); end Debug_Output_G; -------------------- --- 110,116 ---- procedure Debug_Output_G (Arg : G) is begin ! System.IO.Put (G'Image (Arg)); end Debug_Output_G; -------------------- *************** package body System.Vax_Float_Operations *** 352,358 **** procedure pd (Arg : D) is begin ! Put_Line (D'Image (Arg)); end pd; -------- --- 350,356 ---- procedure pd (Arg : D) is begin ! System.IO.Put_Line (D'Image (Arg)); end pd; -------- *************** package body System.Vax_Float_Operations *** 361,367 **** procedure pf (Arg : F) is begin ! Put_Line (F'Image (Arg)); end pf; -------- --- 359,365 ---- procedure pf (Arg : F) is begin ! System.IO.Put_Line (F'Image (Arg)); end pf; -------- *************** package body System.Vax_Float_Operations *** 370,376 **** procedure pg (Arg : G) is begin ! Put_Line (G'Image (Arg)); end pg; ------------ --- 368,374 ---- procedure pg (Arg : G) is begin ! System.IO.Put_Line (G'Image (Arg)); end pg; ------------ *************** package body System.Vax_Float_Operations *** 400,405 **** --- 398,430 ---- return F (X); end S_To_F; + -------------- + -- Return_D -- + -------------- + + function Return_D (X : D) return D is + begin + return X; + end Return_D; + + -------------- + -- Return_F -- + -------------- + + function Return_F (X : F) return F is + begin + return X; + end Return_F; + + -------------- + -- Return_G -- + -------------- + + function Return_G (X : G) return G is + begin + return X; + end Return_G; + ----------- -- Sub_F -- ----------- diff -Nrcpad gcc-4.3.3/gcc/ada/s-vaflop.ads gcc-4.4.0/gcc/ada/s-vaflop.ads *** gcc-4.3.3/gcc/ada/s-vaflop.ads Tue Nov 15 13:51:27 2005 --- gcc-4.4.0/gcc/ada/s-vaflop.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.Vax_Float_Operations is *** 143,148 **** --- 141,160 ---- function Ne_G (X, Y : G) return Boolean; -- Compares for X /= Y + ---------------------- + -- Return Functions -- + ---------------------- + + function Return_D (X : D) return D; + function Return_F (X : F) return F; + function Return_G (X : G) return G; + -- Deal with returned value for an imported function where the function + -- result is of VAX Float type. Usually nothing needs to be done, and these + -- functions return their argument unchanged. But for the case of VMS Alpha + -- the return value is already in $f0, so we need to trick the compiler + -- into thinking that we are moving X to $f0. See bodies for this case + -- for the Asm sequence generated to achieve this. + ---------------------------------- -- Routines for Valid Attribute -- ---------------------------------- *************** package System.Vax_Float_Operations is *** 175,181 **** -- These routines return a decimal C string image of their argument. -- They are provided for implicit use by the debugger, in response to -- the special encoding used for Vax floating-point types (see Exp_Dbug ! -- for details). They supercede the above Debug_Output_D/F/G routines -- which didn't work properly with GDBTK. procedure pd (Arg : D); --- 187,193 ---- -- These routines return a decimal C string image of their argument. -- They are provided for implicit use by the debugger, in response to -- the special encoding used for Vax floating-point types (see Exp_Dbug ! -- for details). They supersede the above Debug_Output_D/F/G routines -- which didn't work properly with GDBTK. procedure pd (Arg : D); *************** package System.Vax_Float_Operations is *** 190,232 **** -- types, and are retained for backwards compatibility. private ! pragma Inline (D_To_G); ! pragma Inline (F_To_G); ! pragma Inline (F_To_Q); ! pragma Inline (F_To_S); ! pragma Inline (G_To_D); ! pragma Inline (G_To_F); ! pragma Inline (G_To_Q); ! pragma Inline (G_To_T); ! pragma Inline (Q_To_F); ! pragma Inline (Q_To_G); ! pragma Inline (S_To_F); ! pragma Inline (T_To_G); ! pragma Inline (Abs_F); ! pragma Inline (Abs_G); ! pragma Inline (Add_F); ! pragma Inline (Add_G); ! pragma Inline (Div_G); ! pragma Inline (Div_F); ! pragma Inline (Mul_F); ! pragma Inline (Mul_G); ! pragma Inline (Neg_G); ! pragma Inline (Neg_F); ! pragma Inline (Sub_F); ! pragma Inline (Sub_G); ! pragma Inline (Eq_F); ! pragma Inline (Eq_G); ! pragma Inline (Le_F); ! pragma Inline (Le_G); ! pragma Inline (Lt_F); ! pragma Inline (Lt_G); ! pragma Inline (Ne_F); ! pragma Inline (Ne_G); ! pragma Inline (Valid_D); ! pragma Inline (Valid_F); ! pragma Inline (Valid_G); end System.Vax_Float_Operations; --- 202,247 ---- -- types, and are retained for backwards compatibility. private ! pragma Inline_Always (D_To_G); ! pragma Inline_Always (F_To_G); ! pragma Inline_Always (F_To_Q); ! pragma Inline_Always (F_To_S); ! pragma Inline_Always (G_To_D); ! pragma Inline_Always (G_To_F); ! pragma Inline_Always (G_To_Q); ! pragma Inline_Always (G_To_T); ! pragma Inline_Always (Q_To_F); ! pragma Inline_Always (Q_To_G); ! pragma Inline_Always (S_To_F); ! pragma Inline_Always (T_To_G); ! pragma Inline_Always (Abs_F); ! pragma Inline_Always (Abs_G); ! pragma Inline_Always (Add_F); ! pragma Inline_Always (Add_G); ! pragma Inline_Always (Div_G); ! pragma Inline_Always (Div_F); ! pragma Inline_Always (Mul_F); ! pragma Inline_Always (Mul_G); ! pragma Inline_Always (Neg_G); ! pragma Inline_Always (Neg_F); ! pragma Inline_Always (Return_D); ! pragma Inline_Always (Return_F); ! pragma Inline_Always (Return_G); ! pragma Inline_Always (Sub_F); ! pragma Inline_Always (Sub_G); ! pragma Inline_Always (Eq_F); ! pragma Inline_Always (Eq_G); ! pragma Inline_Always (Le_F); ! pragma Inline_Always (Le_G); ! pragma Inline_Always (Lt_F); ! pragma Inline_Always (Lt_G); ! pragma Inline_Always (Ne_F); ! pragma Inline_Always (Ne_G); ! pragma Inline_Always (Valid_D); ! pragma Inline_Always (Valid_F); ! pragma Inline_Always (Valid_G); end System.Vax_Float_Operations; diff -Nrcpad gcc-4.3.3/gcc/ada/s-valboo.adb gcc-4.4.0/gcc/ada/s-valboo.adb *** gcc-4.3.3/gcc/ada/s-valboo.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-valboo.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valboo.ads gcc-4.4.0/gcc/ada/s-valboo.ads *** gcc-4.3.3/gcc/ada/s-valboo.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-valboo.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valcha.adb gcc-4.4.0/gcc/ada/s-valcha.adb *** gcc-4.3.3/gcc/ada/s-valcha.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-valcha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valcha.ads gcc-4.4.0/gcc/ada/s-valcha.ads *** gcc-4.3.3/gcc/ada/s-valcha.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-valcha.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valdec.adb gcc-4.4.0/gcc/ada/s-valdec.adb *** gcc-4.3.3/gcc/ada/s-valdec.adb Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-valdec.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valdec.ads gcc-4.4.0/gcc/ada/s-valdec.ads *** gcc-4.3.3/gcc/ada/s-valdec.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-valdec.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valenu.adb gcc-4.4.0/gcc/ada/s-valenu.adb *** gcc-4.3.3/gcc/ada/s-valenu.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-valenu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valenu.ads gcc-4.4.0/gcc/ada/s-valenu.ads *** gcc-4.3.3/gcc/ada/s-valenu.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-valenu.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valint.adb gcc-4.4.0/gcc/ada/s-valint.adb *** gcc-4.3.3/gcc/ada/s-valint.adb Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-valint.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valint.ads gcc-4.4.0/gcc/ada/s-valint.ads *** gcc-4.3.3/gcc/ada/s-valint.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-valint.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-vallld.adb gcc-4.4.0/gcc/ada/s-vallld.adb *** gcc-4.3.3/gcc/ada/s-vallld.adb Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-vallld.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-vallld.ads gcc-4.4.0/gcc/ada/s-vallld.ads *** gcc-4.3.3/gcc/ada/s-vallld.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-vallld.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-vallli.adb gcc-4.4.0/gcc/ada/s-vallli.adb *** gcc-4.3.3/gcc/ada/s-vallli.adb Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-vallli.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-vallli.ads gcc-4.4.0/gcc/ada/s-vallli.ads *** gcc-4.3.3/gcc/ada/s-vallli.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-vallli.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valllu.adb gcc-4.4.0/gcc/ada/s-valllu.adb *** gcc-4.3.3/gcc/ada/s-valllu.adb Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-valllu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valllu.ads gcc-4.4.0/gcc/ada/s-valllu.ads *** gcc-4.3.3/gcc/ada/s-valllu.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-valllu.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valrea.adb gcc-4.4.0/gcc/ada/s-valrea.adb *** gcc-4.3.3/gcc/ada/s-valrea.adb Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-valrea.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Val_Real is *** 56,62 **** P : Integer; -- Local copy of string pointer ! Base : Long_Long_Float; -- Base value Uval : Long_Long_Float; --- 54,60 ---- P : Integer; -- Local copy of string pointer ! Base : Long_Long_Float; -- Base value Uval : Long_Long_Float; *************** package body System.Val_Real is *** 82,88 **** Num_Saved_Zeroes : Natural := 0; -- This counts zeroes after the decimal point. A non-zero value means ! -- that this number of previously scanned digits are zero. if the end -- of the number is reached, these zeroes are simply discarded, which -- ensures that trailing zeroes after the point never affect the value -- (which might otherwise happen as a result of rounding). With this --- 80,86 ---- Num_Saved_Zeroes : Natural := 0; -- This counts zeroes after the decimal point. A non-zero value means ! -- that this number of previously scanned digits are zero. If the end -- of the number is reached, these zeroes are simply discarded, which -- ensures that trailing zeroes after the point never affect the value -- (which might otherwise happen as a result of rounding). With this diff -Nrcpad gcc-4.3.3/gcc/ada/s-valrea.ads gcc-4.4.0/gcc/ada/s-valrea.ads *** gcc-4.3.3/gcc/ada/s-valrea.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-valrea.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valuns.adb gcc-4.4.0/gcc/ada/s-valuns.adb *** gcc-4.3.3/gcc/ada/s-valuns.adb Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-valuns.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valuns.ads gcc-4.4.0/gcc/ada/s-valuns.ads *** gcc-4.3.3/gcc/ada/s-valuns.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-valuns.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valuti.adb gcc-4.4.0/gcc/ada/s-valuti.adb *** gcc-4.3.3/gcc/ada/s-valuti.adb Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-valuti.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Val_Util is *** 72,78 **** S (J) := To_Upper (S (J)); end loop; end if; - end Normalize_String; ------------------- --- 70,75 ---- *************** package body System.Val_Util is *** 156,162 **** Ptr.all := P; return X; - end Scan_Exponent; -------------------- --- 153,158 ---- *************** package body System.Val_Util is *** 296,303 **** P := P + 1; -- If underscore is at the end of string, then this is an error and ! -- we raise Constraint_Error, leaving the pointer past the undescore. ! -- This seems a bit strange. It means e,g, that if the field is: -- 345_ --- 292,299 ---- P := P + 1; -- If underscore is at the end of string, then this is an error and ! -- we raise Constraint_Error, leaving the pointer past the underscore. ! -- This seems a bit strange. It means e.g. that if the field is: -- 345_ diff -Nrcpad gcc-4.3.3/gcc/ada/s-valuti.ads gcc-4.4.0/gcc/ada/s-valuti.ads *** gcc-4.3.3/gcc/ada/s-valuti.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/s-valuti.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-valwch.adb gcc-4.4.0/gcc/ada/s-valwch.adb *** gcc-4.3.3/gcc/ada/s-valwch.adb Tue Oct 31 17:56:24 2006 --- gcc-4.4.0/gcc/ada/s-valwch.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.Val_WChar is *** 50,57 **** WV : constant Unsigned_32 := Wide_Wide_Character'Pos (WC); begin if WV > 16#FFFF# then ! raise Constraint_Error ! with "out of range character for Value attribute"; else return Wide_Character'Val (WV); end if; --- 48,55 ---- WV : constant Unsigned_32 := Wide_Wide_Character'Pos (WC); begin if WV > 16#FFFF# then ! raise Constraint_Error with ! "out of range character for Value attribute"; else return Wide_Character'Val (WV); end if; diff -Nrcpad gcc-4.3.3/gcc/ada/s-valwch.ads gcc-4.4.0/gcc/ada/s-valwch.ads *** gcc-4.3.3/gcc/ada/s-valwch.ads Tue Oct 31 17:56:24 2006 --- gcc-4.4.0/gcc/ada/s-valwch.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-veboop.adb gcc-4.4.0/gcc/ada/s-veboop.adb *** gcc-4.3.3/gcc/ada/s-veboop.adb Tue Aug 14 08:50:18 2007 --- gcc-4.4.0/gcc/ada/s-veboop.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-veboop.ads gcc-4.4.0/gcc/ada/s-veboop.ads *** gcc-4.3.3/gcc/ada/s-veboop.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-veboop.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-vector.ads gcc-4.4.0/gcc/ada/s-vector.ads *** gcc-4.3.3/gcc/ada/s-vector.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-vector.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-vercon.adb gcc-4.4.0/gcc/ada/s-vercon.adb *** gcc-4.3.3/gcc/ada/s-vercon.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-vercon.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-vercon.ads gcc-4.4.0/gcc/ada/s-vercon.ads *** gcc-4.3.3/gcc/ada/s-vercon.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-vercon.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-vmexta.adb gcc-4.4.0/gcc/ada/s-vmexta.adb *** gcc-4.3.3/gcc/ada/s-vmexta.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-vmexta.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2004, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-vmexta.ads gcc-4.4.0/gcc/ada/s-vmexta.ads *** gcc-4.3.3/gcc/ada/s-vmexta.ads Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/s-vmexta.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.VMS_Exception_Table is *** 51,57 **** private function Base_Code_In (Code : SSL.Exception_Code) return SSL.Exception_Code; ! -- Value of Code with the severity bits masked off. function Coded_Exception (X : SSL.Exception_Code) return SSL.Exception_Data_Ptr; --- 49,55 ---- private function Base_Code_In (Code : SSL.Exception_Code) return SSL.Exception_Code; ! -- Value of Code with the severity bits masked off function Coded_Exception (X : SSL.Exception_Code) return SSL.Exception_Data_Ptr; diff -Nrcpad gcc-4.3.3/gcc/ada/s-vxwext-kernel.ads gcc-4.4.0/gcc/ada/s-vxwext-kernel.ads *** gcc-4.3.3/gcc/ada/s-vxwext-kernel.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-vxwext-kernel.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,63 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . V X W O R K S . E X T -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2009, Free Software Foundation, Inc. -- + -- -- + -- GNARL 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides vxworks specific support functions needed + -- by System.OS_Interface. + + -- This is the VxWorks 6 kernel version of this package + + with Interfaces.C; + + package System.VxWorks.Ext is + pragma Preelaborate; + + type t_id is new Long_Integer; + subtype int is Interfaces.C.int; + + function Task_Cont (tid : t_id) return int; + pragma Import (C, Task_Cont, "taskCont"); + + function Task_Stop (tid : t_id) return int; + pragma Import (C, Task_Stop, "taskStop"); + + function Int_Lock return int; + pragma Import (C, Int_Lock, "intLock"); + + function Int_Unlock return int; + pragma Import (C, Int_Unlock, "intUnlock"); + + function kill (pid : t_id; sig : int) return int; + pragma Import (C, kill, "kill"); + + function Set_Time_Slice (ticks : int) return int; + pragma Import (C, Set_Time_Slice, "kernelTimeSlice"); + + function getpid return t_id; + pragma Import (C, getpid, "taskIdSelf"); + + end System.VxWorks.Ext; diff -Nrcpad gcc-4.3.3/gcc/ada/s-vxwext-rtp.adb gcc-4.4.0/gcc/ada/s-vxwext-rtp.adb *** gcc-4.3.3/gcc/ada/s-vxwext-rtp.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-vxwext-rtp.adb Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,65 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . V X W O R K S . E X T -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2009, Free Software Foundation, Inc. -- + -- -- + -- GNARL 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the VxWorks 6 rtp version of this package + + package body System.VxWorks.Ext is + + function Task_Cont (tid : t_id) return int is + pragma Unreferenced (tid); + begin + -- Operation not allowed in an RTP + return 0; + end Task_Cont; + + function Task_Stop (tid : t_id) return int is + pragma Unreferenced (tid); + begin + -- Operation not allowed in an RTP + return 0; + end Task_Stop; + + function Int_Lock return int is + begin + -- Operation not allowed in an RTP + return 0; + end Int_Lock; + + function Int_Unlock return int is + begin + -- Operation not allowed in an RTP + return 0; + end Int_Unlock; + + function Set_Time_Slice (ticks : int) return int is + pragma Unreferenced (ticks); + begin + return 0; + end Set_Time_Slice; + + end System.VxWorks.Ext; diff -Nrcpad gcc-4.3.3/gcc/ada/s-vxwext-rtp.ads gcc-4.4.0/gcc/ada/s-vxwext-rtp.ads *** gcc-4.3.3/gcc/ada/s-vxwext-rtp.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-vxwext-rtp.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,63 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . V X W O R K S . E X T -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2009, Free Software Foundation, Inc. -- + -- -- + -- GNARL 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides vxworks specific support functions needed + -- by System.OS_Interface. + + -- This is the VxWorks 6 rtp version of this package + + with Interfaces.C; + + package System.VxWorks.Ext is + pragma Preelaborate; + + type t_id is new Long_Integer; + subtype int is Interfaces.C.int; + + function Task_Cont (tid : t_id) return int; + pragma Inline (Task_Cont); + + function Task_Stop (tid : t_id) return int; + pragma Inline (Task_Stop); + + function Int_Lock return int; + pragma Inline (Int_Lock); + + function Int_Unlock return int; + pragma Inline (Int_Unlock); + + function kill (pid : t_id; sig : int) return int; + pragma Import (C, kill, "taskKill"); + + function Set_Time_Slice (ticks : int) return int; + pragma Inline (Set_Time_Slice); + + function getpid return t_id; + pragma Import (C, getpid, "getpid"); + + end System.VxWorks.Ext; diff -Nrcpad gcc-4.3.3/gcc/ada/s-vxwext.ads gcc-4.4.0/gcc/ada/s-vxwext.ads *** gcc-4.3.3/gcc/ada/s-vxwext.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-vxwext.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,63 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . V X W O R K S . E X T -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2009, Free Software Foundation, Inc. -- + -- -- + -- GNARL 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides vxworks specific support functions needed + -- by System.OS_Interface. + + -- This is the VxWorks 5 version of this package + + with Interfaces.C; + + package System.VxWorks.Ext is + pragma Preelaborate; + + type t_id is new Long_Integer; + subtype int is Interfaces.C.int; + + function Task_Cont (tid : t_id) return int; + pragma Import (C, Task_Cont, "taskResume"); + + function Task_Stop (tid : t_id) return int; + pragma Import (C, Task_Stop, "taskSuspend"); + + function Int_Lock return int; + pragma Import (C, Int_Lock, "intLock"); + + function Int_Unlock return int; + pragma Import (C, Int_Unlock, "intUnlock"); + + function kill (pid : t_id; sig : int) return int; + pragma Import (C, kill, "kill"); + + function Set_Time_Slice (ticks : int) return int; + pragma Import (C, Set_Time_Slice, "kernelTimeSlice"); + + function getpid return t_id; + pragma Import (C, getpid, "taskIdSelf"); + + end System.VxWorks.Ext; diff -Nrcpad gcc-4.3.3/gcc/ada/s-vxwork-arm.ads gcc-4.4.0/gcc/ada/s-vxwork-arm.ads *** gcc-4.3.3/gcc/ada/s-vxwork-arm.ads Wed Jun 6 10:17:12 2007 --- gcc-4.4.0/gcc/ada/s-vxwork-arm.ads Thu Apr 9 23:23:07 2009 *************** *** 6,44 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is the ARM VxWorks version of this package. package System.VxWorks is pragma Preelaborate (System.VxWorks); -- Floating point context record. ARM version ! -- The record definition below matches what arch/arm/fppArmLib.h says. type FP_CONTEXT is record Dummy : Integer; --- 6,42 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is the ARM VxWorks version of this package package System.VxWorks is pragma Preelaborate (System.VxWorks); -- Floating point context record. ARM version ! -- The record definition below matches what arch/arm/fppArmLib.h says type FP_CONTEXT is record Dummy : Integer; *************** package System.VxWorks is *** 48,53 **** pragma Convention (C, FP_CONTEXT); Num_HW_Interrupts : constant := 256; ! -- Number of entries in hardware interrupt vector table. end System.VxWorks; --- 46,51 ---- pragma Convention (C, FP_CONTEXT); Num_HW_Interrupts : constant := 256; ! -- Number of entries in hardware interrupt vector table end System.VxWorks; diff -Nrcpad gcc-4.3.3/gcc/ada/s-vxwork-m68k.ads gcc-4.4.0/gcc/ada/s-vxwork-m68k.ads *** gcc-4.3.3/gcc/ada/s-vxwork-m68k.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-vxwork-m68k.ads Thu Apr 9 23:23:07 2009 *************** *** 6,37 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is the M68K VxWorks version of this package. with Interfaces.C; --- 6,35 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is the M68K VxWorks version of this package with Interfaces.C; diff -Nrcpad gcc-4.3.3/gcc/ada/s-vxwork-mips.ads gcc-4.4.0/gcc/ada/s-vxwork-mips.ads *** gcc-4.3.3/gcc/ada/s-vxwork-mips.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-vxwork-mips.ads Thu Apr 9 23:23:07 2009 *************** *** 6,37 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is the MIPS VxWorks version of this package. with Interfaces.C; --- 6,35 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is the MIPS VxWorks version of this package with Interfaces.C; *************** package System.VxWorks is *** 52,57 **** pragma Convention (C, FP_CONTEXT); Num_HW_Interrupts : constant := 256; ! -- Number of entries in hardware interrupt vector table. end System.VxWorks; --- 50,55 ---- pragma Convention (C, FP_CONTEXT); Num_HW_Interrupts : constant := 256; ! -- Number of entries in hardware interrupt vector table end System.VxWorks; diff -Nrcpad gcc-4.3.3/gcc/ada/s-vxwork-ppc.ads gcc-4.4.0/gcc/ada/s-vxwork-ppc.ads *** gcc-4.3.3/gcc/ada/s-vxwork-ppc.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-vxwork-ppc.ads Thu Apr 9 23:23:07 2009 *************** *** 6,37 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is the PPC VxWorks version of this package. with Interfaces.C; --- 6,35 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is the PPC VxWorks version of this package with Interfaces.C; diff -Nrcpad gcc-4.3.3/gcc/ada/s-vxwork-sparcv9.ads gcc-4.4.0/gcc/ada/s-vxwork-sparcv9.ads *** gcc-4.3.3/gcc/ada/s-vxwork-sparcv9.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-vxwork-sparcv9.ads Thu Apr 9 23:23:07 2009 *************** *** 6,37 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is the Sparc64 VxWorks version of this package. with Interfaces; --- 6,35 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is the Sparc64 VxWorks version of this package with Interfaces; *************** package System.VxWorks is *** 57,62 **** pragma Convention (C, FP_CONTEXT); Num_HW_Interrupts : constant := 256; ! -- Number of entries in hardware interrupt vector table. end System.VxWorks; --- 55,60 ---- pragma Convention (C, FP_CONTEXT); Num_HW_Interrupts : constant := 256; ! -- Number of entries in hardware interrupt vector table end System.VxWorks; diff -Nrcpad gcc-4.3.3/gcc/ada/s-vxwork-x86.ads gcc-4.4.0/gcc/ada/s-vxwork-x86.ads *** gcc-4.3.3/gcc/ada/s-vxwork-x86.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-vxwork-x86.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- ! -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNARL; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2009 Free Software Foundation, Inc. -- -- -- ! -- GNARL 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- ! -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-wchcnv.adb gcc-4.4.0/gcc/ada/s-wchcnv.adb *** gcc-4.3.3/gcc/ada/s-wchcnv.adb Thu Dec 13 10:27:58 2007 --- gcc-4.4.0/gcc/ada/s-wchcnv.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-wchcnv.ads gcc-4.4.0/gcc/ada/s-wchcnv.ads *** gcc-4.3.3/gcc/ada/s-wchcnv.ads Thu Dec 13 10:27:58 2007 --- gcc-4.4.0/gcc/ada/s-wchcnv.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-wchcon.adb gcc-4.4.0/gcc/ada/s-wchcon.adb *** gcc-4.3.3/gcc/ada/s-wchcon.adb Thu Dec 13 10:20:52 2007 --- gcc-4.4.0/gcc/ada/s-wchcon.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-wchcon.ads gcc-4.4.0/gcc/ada/s-wchcon.ads *** gcc-4.3.3/gcc/ada/s-wchcon.ads Thu Dec 13 10:20:52 2007 --- gcc-4.4.0/gcc/ada/s-wchcon.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-wchjis.adb gcc-4.4.0/gcc/ada/s-wchjis.adb *** gcc-4.3.3/gcc/ada/s-wchjis.adb Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-wchjis.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-wchjis.ads gcc-4.4.0/gcc/ada/s-wchjis.ads *** gcc-4.3.3/gcc/ada/s-wchjis.ads Wed Sep 12 11:58:21 2007 --- gcc-4.4.0/gcc/ada/s-wchjis.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-wchstw.adb gcc-4.4.0/gcc/ada/s-wchstw.adb *** gcc-4.3.3/gcc/ada/s-wchstw.adb Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/s-wchstw.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.WCh_StW is *** 74,81 **** function In_Char return Character is begin if P > S'Last then ! raise Constraint_Error ! with "badly formed wide character code"; else P := P + 1; return S (P - 1); --- 72,78 ---- function In_Char return Character is begin if P > S'Last then ! raise Constraint_Error with "badly formed wide character code"; else P := P + 1; return S (P - 1); *************** package body System.WCh_StW is *** 139,146 **** Get_Next_Code (S, SP, V, EM); if V > 16#FFFF# then ! raise Constraint_Error ! with "out of range value for wide character"; end if; L := L + 1; --- 136,143 ---- Get_Next_Code (S, SP, V, EM); if V > 16#FFFF# then ! raise Constraint_Error with ! "out of range value for wide character"; end if; L := L + 1; diff -Nrcpad gcc-4.3.3/gcc/ada/s-wchstw.ads gcc-4.4.0/gcc/ada/s-wchstw.ads *** gcc-4.3.3/gcc/ada/s-wchstw.ads Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/s-wchstw.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System.WCh_StW is *** 46,62 **** EM : System.WCh_Con.WC_Encoding_Method); -- This routine simply takes its argument and converts it to wide string -- format, storing the result in R (1 .. L), with L being set appropriately ! -- on return. The caller guarantees that R is long enough to accomodate the ! -- result. This is used in the context of the Wide_Image attribute, where ! -- the argument is the corresponding 'Image attribute. Any wide character ! -- escape sequences in the string are converted to the corresponding wide ! -- character value. No syntax checks are made, it is assumed that any such ! -- sequences are validly formed (this must be assured by the caller), and ! -- results from the fact that Wide_Image is only used on strings that have ! -- been built by the compiler, such as images of enumeration literals. If ! -- the method for encoding is a shift-in, shift-out convention, then it is ! -- assumed that normal (non-wide character) mode holds at the start and end ! -- of the argument string. EM indicates the wide character encoding method. -- Note: in the WCEM_Brackets case, the brackets escape sequence is used -- only for codes greater than 16#FF#. --- 44,61 ---- EM : System.WCh_Con.WC_Encoding_Method); -- This routine simply takes its argument and converts it to wide string -- format, storing the result in R (1 .. L), with L being set appropriately ! -- on return. The caller guarantees that R is long enough to accommodate ! -- the result. This is used in the context of the Wide_Image attribute, ! -- where the argument is the corresponding 'Image attribute. Any wide ! -- character escape sequences in the string are converted to the ! -- corresponding wide character value. No syntax checks are made, it is ! -- assumed that any such sequences are validly formed (this must be assured ! -- by the caller), and results from the fact that Wide_Image is only used ! -- on strings that have been built by the compiler, such as images of ! -- enumeration literals. If the method for encoding is a shift-in, ! -- shift-out convention, then it is assumed that normal (non-wide ! -- character) mode holds at the start and end of the argument string. EM ! -- indicates the wide character encoding method. -- Note: in the WCEM_Brackets case, the brackets escape sequence is used -- only for codes greater than 16#FF#. diff -Nrcpad gcc-4.3.3/gcc/ada/s-wchwts.adb gcc-4.4.0/gcc/ada/s-wchwts.adb *** gcc-4.3.3/gcc/ada/s-wchwts.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-wchwts.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.WCh_WtS is *** 88,124 **** (S : Wide_String; EM : WC_Encoding_Method) return String is ! R : String (1 .. 5 * S'Length); -- worst case length! RP : Natural; begin ! RP := 0; for SP in S'Range loop Store_UTF_32_Character (Wide_Character'Pos (S (SP)), R, RP, EM); end loop; ! return R (1 .. RP); end Wide_String_To_String; -------------------------------- ! -- Wide_Wide_Sring_To_String -- -------------------------------- function Wide_Wide_String_To_String (S : Wide_Wide_String; EM : WC_Encoding_Method) return String is ! R : String (1 .. 7 * S'Length); -- worst case length! RP : Natural; begin ! RP := 0; for SP in S'Range loop Store_UTF_32_Character (Wide_Wide_Character'Pos (S (SP)), R, RP, EM); end loop; ! return R (1 .. RP); end Wide_Wide_String_To_String; end System.WCh_WtS; --- 86,122 ---- (S : Wide_String; EM : WC_Encoding_Method) return String is ! R : String (S'First .. S'First + 5 * S'Length); -- worst case length! RP : Natural; begin ! RP := R'First - 1; for SP in S'Range loop Store_UTF_32_Character (Wide_Character'Pos (S (SP)), R, RP, EM); end loop; ! return R (R'First .. RP); end Wide_String_To_String; -------------------------------- ! -- Wide_Wide_String_To_String -- -------------------------------- function Wide_Wide_String_To_String (S : Wide_Wide_String; EM : WC_Encoding_Method) return String is ! R : String (S'First .. S'First + 7 * S'Length); -- worst case length! RP : Natural; begin ! RP := R'First - 1; for SP in S'Range loop Store_UTF_32_Character (Wide_Wide_Character'Pos (S (SP)), R, RP, EM); end loop; ! return R (R'First .. RP); end Wide_Wide_String_To_String; end System.WCh_WtS; diff -Nrcpad gcc-4.3.3/gcc/ada/s-wchwts.ads gcc-4.4.0/gcc/ada/s-wchwts.ads *** gcc-4.3.3/gcc/ada/s-wchwts.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-wchwts.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 32,38 **** ------------------------------------------------------------------------------ -- This package contains the routine used to convert wide strings and wide ! -- wide stringsto strings for use by wide and wide wide character attributes -- (value, image etc.) and also by the numeric IO subpackages of -- Ada.Text_IO.Wide_Text_IO and Ada.Text_IO.Wide_Wide_Text_IO. --- 30,36 ---- ------------------------------------------------------------------------------ -- This package contains the routine used to convert wide strings and wide ! -- wide strings to strings for use by wide and wide wide character attributes -- (value, image etc.) and also by the numeric IO subpackages of -- Ada.Text_IO.Wide_Text_IO and Ada.Text_IO.Wide_Wide_Text_IO. *************** package System.WCh_WtS is *** 54,60 **** -- that normal (non-wide character) mode holds at the start and end of -- the result string. EM indicates the wide character encoding method. -- Note: in the WCEM_Brackets case, we only use the brackets encoding ! -- for characters greater than 16#FF#. function Wide_Wide_String_To_String (S : Wide_Wide_String; --- 52,59 ---- -- that normal (non-wide character) mode holds at the start and end of -- the result string. EM indicates the wide character encoding method. -- Note: in the WCEM_Brackets case, we only use the brackets encoding ! -- for characters greater than 16#FF#. The lowest index of the returned ! -- String is equal to S'First. function Wide_Wide_String_To_String (S : Wide_Wide_String; diff -Nrcpad gcc-4.3.3/gcc/ada/s-widboo.adb gcc-4.4.0/gcc/ada/s-widboo.adb *** gcc-4.3.3/gcc/ada/s-widboo.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-widboo.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-widboo.ads gcc-4.4.0/gcc/ada/s-widboo.ads *** gcc-4.3.3/gcc/ada/s-widboo.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-widboo.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-widcha.adb gcc-4.4.0/gcc/ada/s-widcha.adb *** gcc-4.3.3/gcc/ada/s-widcha.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-widcha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-widcha.ads gcc-4.4.0/gcc/ada/s-widcha.ads *** gcc-4.3.3/gcc/ada/s-widcha.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-widcha.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-widenu.adb gcc-4.4.0/gcc/ada/s-widenu.adb *** gcc-4.3.3/gcc/ada/s-widenu.adb Wed Jun 6 10:13:44 2007 --- gcc-4.4.0/gcc/ada/s-widenu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-widenu.ads gcc-4.4.0/gcc/ada/s-widenu.ads *** gcc-4.3.3/gcc/ada/s-widenu.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-widenu.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-widlli.adb gcc-4.4.0/gcc/ada/s-widlli.adb *** gcc-4.3.3/gcc/ada/s-widlli.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-widlli.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-widlli.ads gcc-4.4.0/gcc/ada/s-widlli.ads *** gcc-4.3.3/gcc/ada/s-widlli.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-widlli.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-widllu.adb gcc-4.4.0/gcc/ada/s-widllu.adb *** gcc-4.3.3/gcc/ada/s-widllu.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-widllu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-widllu.ads gcc-4.4.0/gcc/ada/s-widllu.ads *** gcc-4.3.3/gcc/ada/s-widllu.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-widllu.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-widwch.adb gcc-4.4.0/gcc/ada/s-widwch.adb *** gcc-4.3.3/gcc/ada/s-widwch.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-widwch.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-widwch.ads gcc-4.4.0/gcc/ada/s-widwch.ads *** gcc-4.3.3/gcc/ada/s-widwch.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-widwch.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-win32.ads gcc-4.4.0/gcc/ada/s-win32.ads *** gcc-4.3.3/gcc/ada/s-win32.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-win32.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,293 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M . W I N 3 2 -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2009, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package plus its child provide the low level interface to the Win32 + -- API. The core part of the Win32 API (common to RTX and Win32) is in this + -- package, and an additional part of the Win32 API which is not supported by + -- RTX is in package System.Win33.Ext. + + with Interfaces.C; + + package System.Win32 is + pragma Pure; + + ------------------- + -- General Types -- + ------------------- + + -- The LARGE_INTEGER type is actually a fixed point type + -- that only can represent integers. The reason for this is + -- easier conversion to Duration or other fixed point types. + -- (See Operations.Clock) + + type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0; + + subtype PVOID is Address; + + type HANDLE is new Interfaces.C.long; + + INVALID_HANDLE_VALUE : constant HANDLE := -1; + + type DWORD is new Interfaces.C.unsigned_long; + type WORD is new Interfaces.C.unsigned_short; + type BYTE is new Interfaces.C.unsigned_char; + type LONG is new Interfaces.C.long; + type CHAR is new Interfaces.C.char; + + type BOOL is new Interfaces.C.int; + for BOOL'Size use Interfaces.C.int'Size; + + type Bits1 is range 0 .. 2 ** 1 - 1; + type Bits2 is range 0 .. 2 ** 2 - 1; + type Bits17 is range 0 .. 2 ** 17 - 1; + for Bits1'Size use 1; + for Bits2'Size use 2; + for Bits17'Size use 17; + + FALSE : constant := 0; + TRUE : constant := 1; + + function GetLastError return DWORD; + pragma Import (Stdcall, GetLastError, "GetLastError"); + + ----------- + -- Files -- + ----------- + + GENERIC_READ : constant := 16#80000000#; + GENERIC_WRITE : constant := 16#40000000#; + + CREATE_NEW : constant := 1; + CREATE_ALWAYS : constant := 2; + OPEN_EXISTING : constant := 3; + OPEN_ALWAYS : constant := 4; + TRUNCATE_EXISTING : constant := 5; + + FILE_SHARE_DELETE : constant := 16#00000004#; + FILE_SHARE_READ : constant := 16#00000001#; + FILE_SHARE_WRITE : constant := 16#00000002#; + + FILE_BEGIN : constant := 0; + FILE_CURRENT : constant := 1; + FILE_END : constant := 2; + + PAGE_NOACCESS : constant := 16#0001#; + PAGE_READONLY : constant := 16#0002#; + PAGE_READWRITE : constant := 16#0004#; + PAGE_WRITECOPY : constant := 16#0008#; + PAGE_EXECUTE : constant := 16#0010#; + + FILE_MAP_ALL_ACCESS : constant := 16#F001f#; + FILE_MAP_READ : constant := 4; + FILE_MAP_WRITE : constant := 2; + FILE_MAP_COPY : constant := 1; + + FILE_ADD_FILE : constant := 16#0002#; + FILE_ADD_SUBDIRECTORY : constant := 16#0004#; + FILE_APPEND_DATA : constant := 16#0004#; + FILE_CREATE_PIPE_INSTANCE : constant := 16#0004#; + FILE_DELETE_CHILD : constant := 16#0040#; + FILE_EXECUTE : constant := 16#0020#; + FILE_LIST_DIRECTORY : constant := 16#0001#; + FILE_READ_ATTRIBUTES : constant := 16#0080#; + FILE_READ_DATA : constant := 16#0001#; + FILE_READ_EA : constant := 16#0008#; + FILE_TRAVERSE : constant := 16#0020#; + FILE_WRITE_ATTRIBUTES : constant := 16#0100#; + FILE_WRITE_DATA : constant := 16#0002#; + FILE_WRITE_EA : constant := 16#0010#; + STANDARD_RIGHTS_READ : constant := 16#20000#; + STANDARD_RIGHTS_WRITE : constant := 16#20000#; + SYNCHRONIZE : constant := 16#100000#; + + FILE_ATTRIBUTE_READONLY : constant := 16#00000001#; + FILE_ATTRIBUTE_HIDDEN : constant := 16#00000002#; + FILE_ATTRIBUTE_SYSTEM : constant := 16#00000004#; + FILE_ATTRIBUTE_DIRECTORY : constant := 16#00000010#; + FILE_ATTRIBUTE_ARCHIVE : constant := 16#00000020#; + FILE_ATTRIBUTE_DEVICE : constant := 16#00000040#; + FILE_ATTRIBUTE_NORMAL : constant := 16#00000080#; + FILE_ATTRIBUTE_TEMPORARY : constant := 16#00000100#; + FILE_ATTRIBUTE_SPARSE_FILE : constant := 16#00000200#; + FILE_ATTRIBUTE_REPARSE_POINT : constant := 16#00000400#; + FILE_ATTRIBUTE_COMPRESSED : constant := 16#00000800#; + FILE_ATTRIBUTE_OFFLINE : constant := 16#00001000#; + FILE_ATTRIBUTE_NOT_CONTENT_INDEXED : constant := 16#00002000#; + FILE_ATTRIBUTE_ENCRYPTED : constant := 16#00004000#; + FILE_ATTRIBUTE_VALID_FLAGS : constant := 16#00007fb7#; + FILE_ATTRIBUTE_VALID_SET_FLAGS : constant := 16#000031a7#; + + type OVERLAPPED is record + Internal : DWORD; + InternalHigh : DWORD; + Offset : DWORD; + OffsetHigh : DWORD; + hEvent : HANDLE; + end record; + + type SECURITY_ATTRIBUTES is record + nLength : DWORD; + pSecurityDescriptor : PVOID; + bInheritHandle : BOOL; + end record; + + function CreateFile + (lpFileName : Address; + dwDesiredAccess : DWORD; + dwShareMode : DWORD; + lpSecurityAttributes : access SECURITY_ATTRIBUTES; + dwCreationDisposition : DWORD; + dwFlagsAndAttributes : DWORD; + hTemplateFile : HANDLE) return HANDLE; + pragma Import (Stdcall, CreateFile, "CreateFileA"); + + function GetFileSize + (hFile : HANDLE; + lpFileSizeHigh : access DWORD) return BOOL; + pragma Import (Stdcall, GetFileSize, "GetFileSize"); + + function SetFilePointer + (hFile : HANDLE; + lDistanceToMove : LONG; + lpDistanceToMoveHigh : access LONG; + dwMoveMethod : DWORD) return DWORD; + pragma Import (Stdcall, SetFilePointer, "SetFilePointer"); + + function WriteFile + (hFile : HANDLE; + lpBuffer : Address; + nNumberOfBytesToWrite : DWORD; + lpNumberOfBytesWritten : access DWORD; + lpOverlapped : access OVERLAPPED) return BOOL; + pragma Import (Stdcall, WriteFile, "WriteFile"); + + function ReadFile + (hFile : HANDLE; + lpBuffer : Address; + nNumberOfBytesToRead : DWORD; + lpNumberOfBytesRead : access DWORD; + lpOverlapped : access OVERLAPPED) return BOOL; + pragma Import (Stdcall, ReadFile, "ReadFile"); + + function CloseHandle (hObject : HANDLE) return BOOL; + pragma Import (Stdcall, CloseHandle, "CloseHandle"); + + function CreateFileMapping + (hFile : HANDLE; + lpSecurityAttributes : access SECURITY_ATTRIBUTES; + flProtect : DWORD; + dwMaximumSizeHigh : DWORD; + dwMaximumSizeLow : DWORD; + lpName : Address) return HANDLE; + pragma Import (Stdcall, CreateFileMapping, "CreateFileMappingA"); + + function MapViewOfFile + (hFileMappingObject : HANDLE; + dwDesiredAccess : DWORD; + dwFileOffsetHigh : DWORD; + dwFileOffsetLow : DWORD; + dwNumberOfBytesToMap : DWORD) return System.Address; + pragma Import (Stdcall, MapViewOfFile, "MapViewOfFile"); + + function UnmapViewOfFile (lpBaseAddress : System.Address) return BOOL; + pragma Import (Stdcall, UnmapViewOfFile, "UnmapViewOfFile"); + + ------------------------ + -- System Information -- + ------------------------ + + subtype ProcessorId is DWORD; + + type SYSTEM_INFO is record + dwOemId : DWORD; + dwPageSize : DWORD; + lpMinimumApplicationAddress : PVOID; + lpMaximumApplicationAddress : PVOID; + dwActiveProcessorMask : DWORD; + dwNumberOfProcessors : DWORD; + dwProcessorType : DWORD; + dwAllocationGranularity : DWORD; + dwReserved : DWORD; + end record; + + procedure GetSystemInfo (SI : access SYSTEM_INFO); + pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo"); + + --------------------- + -- Time Management -- + --------------------- + + type SYSTEMTIME is record + wYear : WORD; + wMonth : WORD; + wDayOfWeek : WORD; + wDay : WORD; + wHour : WORD; + wMinute : WORD; + wSecond : WORD; + wMilliseconds : WORD; + end record; + + procedure GetSystemTime (pSystemTime : access SYSTEMTIME); + pragma Import (Stdcall, GetSystemTime, "GetSystemTime"); + + procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer); + pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime"); + + function FileTimeToSystemTime + (lpFileTime : access Long_Long_Integer; + lpSystemTime : access SYSTEMTIME) return BOOL; + pragma Import (Stdcall, FileTimeToSystemTime, "FileTimeToSystemTime"); + + function SystemTimeToFileTime + (lpSystemTime : access SYSTEMTIME; + lpFileTime : access Long_Long_Integer) return BOOL; + pragma Import (Stdcall, SystemTimeToFileTime, "SystemTimeToFileTime"); + + function FileTimeToLocalFileTime + (lpFileTime : access Long_Long_Integer; + lpLocalFileTime : access Long_Long_Integer) return BOOL; + pragma Import (Stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime"); + + function LocalFileTimeToFileTime + (lpFileTime : access Long_Long_Integer; + lpLocalFileTime : access Long_Long_Integer) return BOOL; + pragma Import (Stdcall, LocalFileTimeToFileTime, "LocalFileTimeToFileTime"); + + procedure Sleep (dwMilliseconds : DWORD); + pragma Import (Stdcall, Sleep, External_Name => "Sleep"); + + function QueryPerformanceCounter + (lpPerformanceCount : access LARGE_INTEGER) return BOOL; + pragma Import + (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter"); + + end System.Win32; diff -Nrcpad gcc-4.3.3/gcc/ada/s-winext.ads gcc-4.4.0/gcc/ada/s-winext.ads *** gcc-4.3.3/gcc/ada/s-winext.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/s-winext.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,125 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M . W I N 3 2 . E X T -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2009, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides the part of the low level Win32 interface which is + -- not supported by RTX (but supported by regular Windows platforms). + + package System.Win32.Ext is + pragma Pure; + + --------------------- + -- Time Management -- + --------------------- + + function QueryPerformanceFrequency + (lpFrequency : access LARGE_INTEGER) return Win32.BOOL; + pragma Import + (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency"); + + --------------- + -- Processor -- + --------------- + + function SetThreadIdealProcessor + (hThread : HANDLE; + dwIdealProcessor : ProcessorId) return DWORD; + pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor"); + + -------------- + -- Com Port -- + -------------- + + DTR_CONTROL_DISABLE : constant := 16#0#; + RTS_CONTROL_DISABLE : constant := 16#0#; + NOPARITY : constant := 0; + ODDPARITY : constant := 1; + EVENPARITY : constant := 2; + ONESTOPBIT : constant := 0; + TWOSTOPBITS : constant := 2; + + type DCB is record + DCBLENGTH : DWORD; + BaudRate : DWORD; + fBinary : Bits1; + fParity : Bits1; + fOutxCtsFlow : Bits1; + fOutxDsrFlow : Bits1; + fDtrControl : Bits2; + fDsrSensitivity : Bits1; + fTXContinueOnXoff : Bits1; + fOutX : Bits1; + fInX : Bits1; + fErrorChar : Bits1; + fNull : Bits1; + fRtsControl : Bits2; + fAbortOnError : Bits1; + fDummy2 : Bits17; + wReserved : WORD; + XonLim : WORD; + XoffLim : WORD; + ByteSize : BYTE; + Parity : BYTE; + StopBits : BYTE; + XonChar : CHAR; + XoffChar : CHAR; + ErrorChar : CHAR; + EofChar : CHAR; + EvtChar : CHAR; + wReserved1 : WORD; + end record; + pragma Convention (C, DCB); + pragma Pack (DCB); + + type COMMTIMEOUTS is record + ReadIntervalTimeout : DWORD; + ReadTotalTimeoutMultiplier : DWORD; + ReadTotalTimeoutConstant : DWORD; + WriteTotalTimeoutMultiplier : DWORD; + WriteTotalTimeoutConstant : DWORD; + end record; + pragma Convention (C, COMMTIMEOUTS); + + function GetCommState + (hFile : HANDLE; + lpDCB : access DCB) return BOOL; + pragma Import (Stdcall, GetCommState, "GetCommState"); + + function SetCommState + (hFile : HANDLE; + lpDCB : access DCB) return BOOL; + pragma Import (Stdcall, SetCommState, "SetCommState"); + + function SetCommTimeouts + (hFile : HANDLE; + lpCommTimeouts : access COMMTIMEOUTS) return BOOL; + pragma Import (Stdcall, SetCommTimeouts, "SetCommTimeouts"); + + end System.Win32.Ext; diff -Nrcpad gcc-4.3.3/gcc/ada/s-wwdcha.adb gcc-4.4.0/gcc/ada/s-wwdcha.adb *** gcc-4.3.3/gcc/ada/s-wwdcha.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-wwdcha.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body System.WWd_Char is *** 43,62 **** begin W := 0; for C in Lo .. Hi loop ! -- For Character range, use length of image ! ! if Character'Pos (C) < 256 then ! declare ! S : constant Wide_String := Character'Wide_Image (C); ! begin ! W := Natural'Max (W, S'Length); ! end; ! ! -- For wide character, always max out at 12 (Hex_hhhhhhhh) ! ! else ! return 12; ! end if; end loop; return W; --- 41,51 ---- begin W := 0; for C in Lo .. Hi loop ! declare ! S : constant Wide_String := Character'Wide_Image (C); ! begin ! W := Natural'Max (W, S'Length); ! end; end loop; return W; *************** package body System.WWd_Char is *** 72,92 **** begin W := 0; for C in Lo .. Hi loop ! ! -- For Character range, use length of image ! ! if Character'Pos (C) < 256 then ! declare ! S : constant String := Character'Image (C); ! begin ! W := Natural'Max (W, S'Length); ! end; ! ! -- For wide character, always max out at 12 (Hex_hhhhhhhh) ! ! else ! return 12; ! end if; end loop; return W; --- 61,71 ---- begin W := 0; for C in Lo .. Hi loop ! declare ! S : constant String := Character'Image (C); ! begin ! W := Natural'Max (W, S'Length); ! end; end loop; return W; diff -Nrcpad gcc-4.3.3/gcc/ada/s-wwdcha.ads gcc-4.4.0/gcc/ada/s-wwdcha.ads *** gcc-4.3.3/gcc/ada/s-wwdcha.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-wwdcha.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-wwdenu.adb gcc-4.4.0/gcc/ada/s-wwdenu.adb *** gcc-4.3.3/gcc/ada/s-wwdenu.adb Thu Dec 13 10:21:30 2007 --- gcc-4.4.0/gcc/ada/s-wwdenu.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-wwdenu.ads gcc-4.4.0/gcc/ada/s-wwdenu.ads *** gcc-4.3.3/gcc/ada/s-wwdenu.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/s-wwdenu.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-wwdwch.adb gcc-4.4.0/gcc/ada/s-wwdwch.adb *** gcc-4.3.3/gcc/ada/s-wwdwch.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/s-wwdwch.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/s-wwdwch.ads gcc-4.4.0/gcc/ada/s-wwdwch.ads *** gcc-4.3.3/gcc/ada/s-wwdwch.ads Mon Sep 5 07:51:25 2005 --- gcc-4.4.0/gcc/ada/s-wwdwch.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/scans.adb gcc-4.4.0/gcc/ada/scans.adb *** gcc-4.3.3/gcc/ada/scans.adb Wed Jun 6 10:19:40 2007 --- gcc-4.4.0/gcc/ada/scans.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/scans.ads gcc-4.4.0/gcc/ada/scans.ads *** gcc-4.3.3/gcc/ada/scans.ads Wed Jun 6 10:19:40 2007 --- gcc-4.4.0/gcc/ada/scans.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Scans is *** 45,51 **** -- The following type is used to identify token types returned by Scan. -- The class column in this table indicates the token classes which ! -- apply to the token, as defined by subsquent subtype declarations. -- Note: Namet.Is_Keyword_Name depends on the fact that the first entry in -- this type declaration is *not* for a reserved word. For details on why --- 43,49 ---- -- The following type is used to identify token types returned by Scan. -- The class column in this table indicates the token classes which ! -- apply to the token, as defined by subsequent subtype declarations. -- Note: Namet.Is_Keyword_Name depends on the fact that the first entry in -- this type declaration is *not* for a reserved word. For details on why *************** package Scans is *** 65,71 **** Tok_Operator_Symbol, -- op symbol Name, Literal, Lit_Or_Name, Desig ! Tok_Identifier, -- identifer Name, Lit_Or_Name, Desig Tok_Double_Asterisk, -- ** --- 63,69 ---- Tok_Operator_Symbol, -- op symbol Name, Literal, Lit_Or_Name, Desig ! Tok_Identifier, -- identifier Name, Lit_Or_Name, Desig Tok_Double_Asterisk, -- ** *************** package Scans is *** 206,212 **** Tok_End_Of_Line, -- Represents an end of line. Not used during normal compilation scans -- where end of line is ignored. Active for preprocessor scanning and ! -- also when scanning project files (where it is neede because of ???) Tok_Special, -- Used only in preprocessor scanning (to represent one of the --- 204,210 ---- Tok_End_Of_Line, -- Represents an end of line. Not used during normal compilation scans -- where end of line is ignored. Active for preprocessor scanning and ! -- also when scanning project files (where it is needed because of ???) Tok_Special, -- Used only in preprocessor scanning (to represent one of the *************** package Scans is *** 338,345 **** -- Flag array used to test for reserved word procedure Initialize_Ada_Keywords; ! -- Set up Token_Type values in Names table entries for Ada reserved ! -- words. -------------------------- -- Scan State Variables -- --- 336,342 ---- -- Flag array used to test for reserved word procedure Initialize_Ada_Keywords; ! -- Set up Token_Type values in Names table entries for Ada reserved words -------------------------- -- Scan State Variables -- diff -Nrcpad gcc-4.3.3/gcc/ada/scn.adb gcc-4.4.0/gcc/ada/scn.adb *** gcc-4.3.3/gcc/ada/scn.adb Thu Dec 13 10:29:24 2007 --- gcc-4.4.0/gcc/ada/scn.adb Sun Apr 13 17:25:22 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Scn is *** 292,302 **** --- 292,306 ---- Upper_Half_Encoding := True; when UTF16_LE | UTF16_BE => + Set_Standard_Error; Write_Line ("UTF-16 encoding format not recognized"); + Set_Standard_Output; raise Unrecoverable_Error; when UTF32_LE | UTF32_BE => + Set_Standard_Error; Write_Line ("UTF-32 encoding format not recognized"); + Set_Standard_Output; raise Unrecoverable_Error; when Unknown => *************** package body Scn is *** 325,331 **** Scan; end if; ! -- Clear flags for reserved words used as indentifiers for J in Token_Type loop Used_As_Identifier (J) := False; --- 329,335 ---- Scan; end if; ! -- Clear flags for reserved words used as identifiers for J in Token_Type loop Used_As_Identifier (J) := False; diff -Nrcpad gcc-4.3.3/gcc/ada/scng.adb gcc-4.4.0/gcc/ada/scng.adb *** gcc-4.3.3/gcc/ada/scng.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/scng.adb Fri Aug 1 07:56:07 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Scng is *** 236,242 **** -- Scan_Ptr points to the opening string quote (the checksum for this -- character has not been accumulated yet). On return Scan_Ptr points -- past the closing quote of the string literal, Token and Token_Node ! -- are set appropriately, and the checksum is upated. ----------------------- -- Check_End_Of_Line -- --- 236,242 ---- -- Scan_Ptr points to the opening string quote (the checksum for this -- character has not been accumulated yet). On return Scan_Ptr points -- past the closing quote of the string literal, Token and Token_Node ! -- are set appropriately, and the checksum is updated. ----------------------- -- Check_End_Of_Line -- *************** package body Scng is *** 350,355 **** --- 350,356 ---- procedure Error_Illegal_Wide_Character is begin + Scan_Ptr := Scan_Ptr + 1; Error_Msg ("illegal wide character", Wptr); end Error_Illegal_Wide_Character; *************** package body Scng is *** 1651,1657 **** if Err then Error_Illegal_Wide_Character; ! Code := Character'Pos (' '); -- In Ada 95 mode we allow any wide character in a character -- literal, but in Ada 2005, the set of characters allowed --- 1652,1658 ---- if Err then Error_Illegal_Wide_Character; ! Code := Character'Pos (' '); -- In Ada 95 mode we allow any wide character in a character -- literal, but in Ada 2005, the set of characters allowed *************** package body Scng is *** 2066,2072 **** Underline_Found := False; goto Scan_Identifier; ! -- Mark character is an error (at start of identifer) elsif Is_UTF_32_Mark (Cat) then Error_Msg --- 2067,2073 ---- Underline_Found := False; goto Scan_Identifier; ! -- Mark character is an error (at start of identifier) elsif Is_UTF_32_Mark (Cat) then Error_Msg *************** package body Scng is *** 2076,2082 **** Underline_Found := False; goto Scan_Identifier; ! -- Other format character is an error (at start of identifer) elsif Is_UTF_32_Other (Cat) then Error_Msg --- 2077,2083 ---- Underline_Found := False; goto Scan_Identifier; ! -- Other format character is an error (at start of identifier) elsif Is_UTF_32_Other (Cat) then Error_Msg *************** package body Scng is *** 2108,2114 **** -- Routine to scan line terminator. On entry Scan_Ptr points to a -- character which is one of FF,LR,CR,VT, or one of the wide characters ! -- that is treated as a line termiantor. <> --- 2109,2115 ---- -- Routine to scan line terminator. On entry Scan_Ptr points to a -- character which is one of FF,LR,CR,VT, or one of the wide characters ! -- that is treated as a line terminator. <> *************** package body Scng is *** 2151,2157 **** -- Identifier scanning routine. On entry, some initial characters of -- the identifier may have already been stored in Name_Buffer. If so, ! -- Name_Len has the number of characters stored. otherwise Name_Len is -- set to zero on entry. Underline_Found is also set False on entry. <> --- 2152,2158 ---- -- Identifier scanning routine. On entry, some initial characters of -- the identifier may have already been stored in Name_Buffer. If so, ! -- Name_Len has the number of characters stored, otherwise Name_Len is -- set to zero on entry. Underline_Found is also set False on entry. <> *************** package body Scng is *** 2189,2196 **** -- is active, so if we find an ESC character we know that we have a -- wide character. ! if Identifier_Char (Source (Scan_Ptr)) then ! -- Case of underline if Source (Scan_Ptr) = '_' then --- 2190,2199 ---- -- is active, so if we find an ESC character we know that we have a -- wide character. ! if Identifier_Char (Source (Scan_Ptr)) ! or else (Source (Scan_Ptr) in Upper_Half_Character ! and then Upper_Half_Encoding) ! then -- Case of underline if Source (Scan_Ptr) = '_' then *************** package body Scng is *** 2322,2328 **** Underline_Found := True; end if; ! -- Wide character in Unicode cateogory "Other, Format" -- is accepted in an identifier, but is ignored and not -- stored. It seems reasonable to exclude it from the -- checksum. --- 2325,2331 ---- Underline_Found := True; end if; ! -- Wide character in Unicode category "Other, Format" -- is accepted in an identifier, but is ignored and not -- stored. It seems reasonable to exclude it from the -- checksum. diff -Nrcpad gcc-4.3.3/gcc/ada/seh_init.c gcc-4.4.0/gcc/ada/seh_init.c *** gcc-4.3.3/gcc/ada/seh_init.c Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/seh_init.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 2005, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 2005-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** *** 37,43 **** #include "tconfig.h" #include "tsystem.h" ! /* We don't have libiberty, so us malloc. */ #define xmalloc(S) malloc (S) #else --- 36,42 ---- #include "tconfig.h" #include "tsystem.h" ! /* We don't have libiberty, so use malloc. */ #define xmalloc(S) malloc (S) #else diff -Nrcpad gcc-4.3.3/gcc/ada/sem.adb gcc-4.4.0/gcc/ada/sem.adb *** gcc-4.3.3/gcc/ada/sem.adb Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/sem.adb Thu Apr 9 23:23:07 2009 *************** *** 6,23 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,23 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- ! -- -- ! -- You should have received a copy of the GNU General Public License along -- ! -- with this program; see file COPYING3. If not see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Sem is *** 547,554 **** -- been any other errors, we just ignore it, otherwise it is -- a real internal error which we complain about. when N_Empty => ! pragma Assert (Serious_Errors_Detected /= 0); null; -- A call to analyze the error node is simply ignored, to avoid --- 547,558 ---- -- been any other errors, we just ignore it, otherwise it is -- a real internal error which we complain about. + -- We must also consider the case of call to a runtime function + -- that is not available in the configurable runtime. + when N_Empty => ! pragma Assert (Serious_Errors_Detected /= 0 ! or else Configurable_Run_Time_Violations /= 0); null; -- A call to analyze the error node is simply ignored, to avoid *************** package body Sem is *** 1275,1288 **** -- values for these variables, and also that such calls do not -- disturb the settings for units being analyzed at a higher level. S_Full_Analysis : constant Boolean := Full_Analysis; ! S_In_Default_Expr : constant Boolean := In_Default_Expression; S_Inside_A_Generic : constant Boolean := Inside_A_Generic; S_New_Nodes_OK : constant Int := New_Nodes_OK; S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope; - S_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; - S_GNAT_Mode : constant Boolean := GNAT_Mode; - S_Discard_Names : constant Boolean := Global_Discard_Names; Generic_Main : constant Boolean := Nkind (Unit (Cunit (Main_Unit))) --- 1279,1292 ---- -- values for these variables, and also that such calls do not -- disturb the settings for units being analyzed at a higher level. + S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; S_Full_Analysis : constant Boolean := Full_Analysis; ! S_GNAT_Mode : constant Boolean := GNAT_Mode; ! S_Global_Dis_Names : constant Boolean := Global_Discard_Names; ! S_In_Spec_Expr : constant Boolean := In_Spec_Expression; S_Inside_A_Generic : constant Boolean := Inside_A_Generic; S_New_Nodes_OK : constant Int := New_Nodes_OK; S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope; Generic_Main : constant Boolean := Nkind (Unit (Cunit (Main_Unit))) *************** package body Sem is *** 1335,1343 **** Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit); -- Compile predefined units with GNAT_Mode set to True, to properly ! -- process the categorization stuff. However, do not set set GNAT_Mode -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO, ! -- Sequential_IO) as this would prevent pragma System_Extend to be -- taken into account, for example when Text_IO is renaming DEC.Text_IO. -- Cleaner might be to do the kludge at the point of excluding the --- 1339,1347 ---- Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit); -- Compile predefined units with GNAT_Mode set to True, to properly ! -- process the categorization stuff. However, do not set GNAT_Mode -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO, ! -- Sequential_IO) as this would prevent pragma Extend_System from being -- taken into account, for example when Text_IO is renaming DEC.Text_IO. -- Cleaner might be to do the kludge at the point of excluding the *************** package body Sem is *** 1356,1364 **** (Operating_Mode = Generate_Code or Debug_Flag_X); end if; ! Full_Analysis := True; ! Inside_A_Generic := False; ! In_Default_Expression := False; Set_Comes_From_Source_Default (False); Save_Opt_Config_Switches (Save_Config_Switches); --- 1360,1368 ---- (Operating_Mode = Generate_Code or Debug_Flag_X); end if; ! Full_Analysis := True; ! Inside_A_Generic := False; ! In_Spec_Expression := False; Set_Comes_From_Source_Default (False); Save_Opt_Config_Switches (Save_Config_Switches); *************** package body Sem is *** 1389,1405 **** -- Restore settings of saved switches to entry values ! Current_Sem_Unit := S_Sem_Unit; ! Full_Analysis := S_Full_Analysis; ! In_Default_Expression := S_In_Default_Expr; ! Inside_A_Generic := S_Inside_A_Generic; ! New_Nodes_OK := S_New_Nodes_OK; ! Outer_Generic_Scope := S_Outer_Gen_Scope; ! GNAT_Mode := S_GNAT_Mode; ! Global_Discard_Names := S_Discard_Names; Restore_Opt_Config_Switches (Save_Config_Switches); Expander_Mode_Restore; - end Semantics; end Sem; --- 1393,1408 ---- -- Restore settings of saved switches to entry values ! Current_Sem_Unit := S_Current_Sem_Unit; ! Full_Analysis := S_Full_Analysis; ! Global_Discard_Names := S_Global_Dis_Names; ! GNAT_Mode := S_GNAT_Mode; ! In_Spec_Expression := S_In_Spec_Expr; ! Inside_A_Generic := S_Inside_A_Generic; ! New_Nodes_OK := S_New_Nodes_OK; ! Outer_Generic_Scope := S_Outer_Gen_Scope; Restore_Opt_Config_Switches (Save_Config_Switches); Expander_Mode_Restore; end Semantics; end Sem; diff -Nrcpad gcc-4.3.3/gcc/ada/sem.ads gcc-4.4.0/gcc/ada/sem.ads *** gcc-4.3.3/gcc/ada/sem.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem.ads Sun Apr 13 17:25:22 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** *** 27,34 **** -- Semantic Analysis: General Model -- -------------------------------------- ! -- Semantic processing involves 3 phases which are highly interwined ! -- (ie mutually recursive): -- Analysis implements the bulk of semantic analysis such as -- name analysis and type resolution for declarations, --- 27,34 ---- -- Semantic Analysis: General Model -- -------------------------------------- ! -- Semantic processing involves 3 phases which are highly intertwined ! -- (i.e. mutually recursive): -- Analysis implements the bulk of semantic analysis such as -- name analysis and type resolution for declarations, *************** *** 51,57 **** -- recursive calls to itself to resolve operands. -- Expansion if we are not generating code this phase is a no-op. ! -- otherwise this phase expands, ie transforms, original -- declaration, expressions or instructions into simpler -- structures that can be handled by the back-end. This -- phase is also in charge of generating code which is --- 51,57 ---- -- recursive calls to itself to resolve operands. -- Expansion if we are not generating code this phase is a no-op. ! -- otherwise this phase expands, i.e. transforms, original -- declaration, expressions or instructions into simpler -- structures that can be handled by the back-end. This -- phase is also in charge of generating code which is *************** *** 84,114 **** -- Analysis-Resolution-Expansion model for expressions. The most prominent -- examples are the handling of default expressions and aggregates. ! ---------------------------------------------------- ! -- Handling of Default and Per-Object Expressions -- ! ---------------------------------------------------- -- The default expressions in component declarations and in procedure ! -- specifications (but not the ones in object declarations) are quite ! -- tricky to handle. The problem is that some processing is required ! -- at the point where the expression appears: -- visibility analysis (including user defined operators) -- freezing of static expressions ! -- but other processing must be deferred until the enclosing entity ! -- (record or procedure specification) is frozen: ! -- freezing of any other types in the expression ! -- expansion -- A similar situation occurs with the argument of priority and interrupt -- priority pragmas that appear in task and protected definition specs and -- other cases of per-object expressions (see RM 3.8(18)). ! -- Expansion has to be deferred since you can't generate code for ! -- expressions that refernce types that have not been frozen yet. As an ! -- example, consider the following: -- type x is delta 0.5 range -10.0 .. +10.0; -- ... --- 84,120 ---- -- Analysis-Resolution-Expansion model for expressions. The most prominent -- examples are the handling of default expressions and aggregates. ! ----------------------------------------------------------------------- ! -- Handling of Default and Per-Object Expressions (Spec-Expressions) -- ! ----------------------------------------------------------------------- -- The default expressions in component declarations and in procedure ! -- specifications (but not the ones in object declarations) are quite tricky ! -- to handle. The problem is that some processing is required at the point ! -- where the expression appears: -- visibility analysis (including user defined operators) -- freezing of static expressions ! -- but other processing must be deferred until the enclosing entity (record or ! -- procedure specification) is frozen: ! -- freezing of any other types in the expression expansion ! -- generation of code -- A similar situation occurs with the argument of priority and interrupt -- priority pragmas that appear in task and protected definition specs and -- other cases of per-object expressions (see RM 3.8(18)). ! -- Another similar case is the conditions in precondition and postcondition ! -- pragmas that appear with subprogram specifications rather than in the body. ! ! -- Collectively we call these Spec_Expressions. The routine that performs the ! -- special analysis is called Analyze_Spec_Expression. ! ! -- Expansion has to be deferred since you can't generate code for expressions ! -- that reference types that have not been frozen yet. As an example, consider ! -- the following: -- type x is delta 0.5 range -10.0 .. +10.0; -- ... *************** *** 118,126 **** -- for x'small use 0.25 ! -- The expander is in charge of dealing with fixed-point, and of course ! -- the small declaration, which is not too late, since the declaration of ! -- type q does *not* freeze type x, definitely affects the expanded code. -- Another reason that we cannot expand early is that expansion can generate -- range checks. These range checks need to be inserted not at the point of --- 124,132 ---- -- for x'small use 0.25 ! -- The expander is in charge of dealing with fixed-point, and of course the ! -- small declaration, which is not too late, since the declaration of type q ! -- does *not* freeze type x, definitely affects the expanded code. -- Another reason that we cannot expand early is that expansion can generate -- range checks. These range checks need to be inserted not at the point of *************** *** 132,157 **** -- this is the one case where this model falls down. Here is how we patch -- it up without causing too much distortion to our basic model. ! -- A switch (sede below) is set to indicate that we are in the initial ! -- occurence of a default expression. The analyzer is then called on this ! -- expression with the switch set true. Analysis and resolution proceed ! -- almost as usual, except that Freeze_Expression will not freeze ! -- non-static expressions if this switch is set, and the call to Expand at ! -- the end of resolution is skipped. This also skips the code that normally ! -- sets the Analyzed flag to True). The result is that when we are done the ! -- tree is still marked as unanalyzed, but all types for static expressions ! -- are frozen as required, and all entities of variables have been ! -- recorded. We then turn off the switch, and later on reanalyze the ! -- expression with the switch off. The effect is that this second analysis ! -- freezes the rest of the types as required, and generates code but ! -- visibility analysis is not repeated since all the entities are marked. -- The second analysis (the one that generates code) is in the context ! -- where the code is required. For a record field default, this is in ! -- the initialization procedure for the record and for a subprogram ! -- default parameter, it is at the point the subprogram is frozen. ! -- For a priority or storage size pragma it is in the context of the ! -- Init_Proc for the task or protected object. ------------------ -- Pre-Analysis -- --- 138,164 ---- -- this is the one case where this model falls down. Here is how we patch -- it up without causing too much distortion to our basic model. ! -- A switch (In_Spec_Expression) is set to show that we are in the initial ! -- occurrence of a default expression. The analyzer is then called on this ! -- expression with the switch set true. Analysis and resolution proceed almost ! -- as usual, except that Freeze_Expression will not freeze non-static ! -- expressions if this switch is set, and the call to Expand at the end of ! -- resolution is skipped. This also skips the code that normally sets the ! -- Analyzed flag to True. The result is that when we are done the tree is ! -- still marked as unanalyzed, but all types for static expressions are frozen ! -- as required, and all entities of variables have been recorded. We then turn ! -- off the switch, and later on reanalyze the expression with the switch off. ! -- The effect is that this second analysis freezes the rest of the types as ! -- required, and generates code but visibility analysis is not repeated since ! -- all the entities are marked. -- The second analysis (the one that generates code) is in the context ! -- where the code is required. For a record field default, this is in the ! -- initialization procedure for the record and for a subprogram default ! -- parameter, it is at the point the subprogram is frozen. For a priority or ! -- storage size pragma it is in the context of the Init_Proc for the task or ! -- protected object. For a pre/postcondition pragma it is in the body when ! -- code for the pragma is generated. ------------------ -- Pre-Analysis -- *************** *** 164,197 **** -- -- (1 .. 100 => new Thing (Function_Call)) -- ! -- The normal Analysis-Resolution-Expansion mechanism where expansion ! -- of the children is performed before expansion of the parent does not ! -- work if the code generated for the children by the expander needs ! -- to be evaluated repeatdly (for instance in the above aggregate ! -- "new Thing (Function_Call)" needs to be called 100 times.) ! -- The reason why this mecanism does not work is that, the expanded code ! -- for the children is typically inserted above the parent and thus ! -- when the father gets expanded no re-evaluation takes place. For instance ! -- in the case of aggregates if "new Thing (Function_Call)" is expanded ! -- before of the aggregate the expanded code will be placed outside ! -- of the aggregate and when expanding the aggregate the loop from 1 to 100 ! -- will not surround the expanded code for "new Thing (Function_Call)". ! -- ! -- To remedy this situation we introduce a new flag which signals whether ! -- we want a full analysis (ie expansion is enabled) or a pre-analysis ! -- which performs Analysis and Resolution but no expansion. ! -- ! -- After the complete pre-analysis of an expression has been carried out ! -- we can transform the expression and then carry out the full ! -- Analyze-Resolve-Expand cycle on the transformed expression top-down ! -- so that the expansion of inner expressions happens inside the newly ! -- generated node for the parent expression. ! -- -- Note that the difference between processing of default expressions and -- pre-analysis of other expressions is that we do carry out freezing in -- the latter but not in the former (except for static scalar expressions). ! -- The routine that performs pre-analysis is called Pre_Analyze_And_Resolve ! -- and is in Sem_Res. with Alloc; with Einfo; use Einfo; --- 171,205 ---- -- -- (1 .. 100 => new Thing (Function_Call)) -- ! -- The normal Analysis-Resolution-Expansion mechanism where expansion of the ! -- children is performed before expansion of the parent does not work if the ! -- code generated for the children by the expander needs to be evaluated ! -- repeatedly (for instance in the above aggregate "new Thing (Function_Call)" ! -- needs to be called 100 times.) ! ! -- The reason why this mechanism does not work is that, the expanded code for ! -- the children is typically inserted above the parent and thus when the ! -- father gets expanded no re-evaluation takes place. For instance in the case ! -- of aggregates if "new Thing (Function_Call)" is expanded before of the ! -- aggregate the expanded code will be placed outside of the aggregate and ! -- when expanding the aggregate the loop from 1 to 100 will not surround the ! -- expanded code for "new Thing (Function_Call)". ! ! -- To remedy this situation we introduce a new flag which signals whether we ! -- want a full analysis (i.e. expansion is enabled) or a pre-analysis which ! -- performs Analysis and Resolution but no expansion. ! ! -- After the complete pre-analysis of an expression has been carried out we ! -- can transform the expression and then carry out the full three stage ! -- (Analyze-Resolve-Expand) cycle on the transformed expression top-down so ! -- that the expansion of inner expressions happens inside the newly generated ! -- node for the parent expression. ! -- Note that the difference between processing of default expressions and -- pre-analysis of other expressions is that we do carry out freezing in -- the latter but not in the former (except for static scalar expressions). ! -- The routine that performs preanalysis and corresponding resolution is ! -- called Preanalyze_And_Resolve and is in Sem_Res. with Alloc; with Einfo; use Einfo; *************** package Sem is *** 219,230 **** -- expansion phase is skipped. -- -- When this flag is False the flag Expander_Active is also False (the ! -- Expander_Activer flag defined in the spec of package Expander tells you -- whether expansion is currently enabled). You should really regard this -- as a read only flag. ! In_Default_Expression : Boolean := False; ! -- Switch to indicate that we are in a default expression, as described -- above. Note that this must be recursively saved on a Semantics call -- since it is possible for the analysis of an expression to result in a -- recursive call (e.g. to get the entity for System.Address as part of the --- 227,238 ---- -- expansion phase is skipped. -- -- When this flag is False the flag Expander_Active is also False (the ! -- Expander_Active flag defined in the spec of package Expander tells you -- whether expansion is currently enabled). You should really regard this -- as a read only flag. ! In_Spec_Expression : Boolean := False; ! -- Switch to indicate that we are in a spec-expression, as described -- above. Note that this must be recursively saved on a Semantics call -- since it is possible for the analysis of an expression to result in a -- recursive call (e.g. to get the entity for System.Address as part of the *************** package Sem is *** 252,265 **** -- package Expander). Only the generic processing can modify the -- status of this flag, any other client should regard it as read-only. Unloaded_Subunits : Boolean := False; -- This flag is set True if we have subunits that are not loaded. This -- occurs when the main unit is a subunit, and contains lower level -- subunits that are not loaded. We use this flag to suppress warnings -- about unused variables, since these warnings are unreliable in this -- case. We could perhaps do a more accurate job and retain some of the ! -- warnings, but it is quite a tricky job. See test 4323-002. ! -- Should not reference TN's in the source comments ??? ----------------------------------- -- Handling of Check Suppression -- --- 260,281 ---- -- package Expander). Only the generic processing can modify the -- status of this flag, any other client should regard it as read-only. + Inside_Freezing_Actions : Nat := 0; + -- Flag indicating whether we are within a call to Expand_N_Freeze_Actions. + -- Non-zero means we are inside (it is actually a level counter to deal + -- with nested calls). Used to avoid traversing the tree each time a + -- subprogram call is processed to know if we must not clear all constant + -- indications from entities in the current scope. Only the expansion of + -- freezing nodes can modify the status of this flag, any other client + -- should regard it as read-only. + Unloaded_Subunits : Boolean := False; -- This flag is set True if we have subunits that are not loaded. This -- occurs when the main unit is a subunit, and contains lower level -- subunits that are not loaded. We use this flag to suppress warnings -- about unused variables, since these warnings are unreliable in this -- case. We could perhaps do a more accurate job and retain some of the ! -- warnings, but it is quite a tricky job. ----------------------------------- -- Handling of Check Suppression -- *************** package Sem is *** 270,276 **** -- Scope based suppress checks for the predefined checks (from initial -- command line arguments, or from Suppress pragmas not including an entity ! -- entity name) are recorded in the Sem.Supress variable, and all that is -- necessary is to save the state of this variable on scope entry, and -- restore it on scope exit. This mechanism allows for fast checking of -- the scope suppress state without needing complex data structures. --- 286,292 ---- -- Scope based suppress checks for the predefined checks (from initial -- command line arguments, or from Suppress pragmas not including an entity ! -- entity name) are recorded in the Sem.Suppress variable, and all that is -- necessary is to save the state of this variable on scope entry, and -- restore it on scope exit. This mechanism allows for fast checking of -- the scope suppress state without needing complex data structures. *************** package Sem is *** 425,431 **** -- It is clear in retrospect that all semantic processing and visibility -- structures should have been fully recursive. The rtsfind mechanism, -- and the complexities brought about by subunits and by generic child ! -- units and their instantitions, have led to a hybrid model that carries -- more state than one would wish. type Scope_Stack_Entry is record --- 441,447 ---- -- It is clear in retrospect that all semantic processing and visibility -- structures should have been fully recursive. The rtsfind mechanism, -- and the complexities brought about by subunits and by generic child ! -- units and their instantiations, have led to a hybrid model that carries -- more state than one would wish. type Scope_Stack_Entry is record *************** package Sem is *** 442,447 **** --- 458,466 ---- Save_Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; -- Save contents of Local_Suppress_Stack on entry to restore on exit + Save_Check_Policy_List : Node_Id; + -- Save contents of Check_Policy_List on entry to restore on exit + Is_Transient : Boolean; -- Marks Transient Scopes (See Exp_Ch7 body for details) diff -Nrcpad gcc-4.3.3/gcc/ada/sem_aggr.adb gcc-4.4.0/gcc/ada/sem_aggr.adb *** gcc-4.3.3/gcc/ada/sem_aggr.adb Thu Dec 13 10:27:58 2007 --- gcc-4.4.0/gcc/ada/sem_aggr.adb Wed Aug 20 11:02:51 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Sem_Aggr is *** 89,94 **** --- 89,99 ---- -- -- It would be better to pass the proper type for Typ ??? + procedure Check_Expr_OK_In_Limited_Aggregate (Expr : Node_Id); + -- Check that Expr is either not limited or else is one of the cases of + -- expressions allowed for a limited component association (namely, an + -- aggregate, function call, or <> notation). Report error for violations. + ------------------------------------------------------ -- Subprograms used for RECORD AGGREGATE Processing -- ------------------------------------------------------ *************** package body Sem_Aggr is *** 193,203 **** -- quadratic in the size of the association list. procedure Check_Misspelled_Component ! (Elements : Elist_Id; ! Component : Node_Id); -- Give possible misspelling diagnostic if Component is likely to be -- a misspelling of one of the components of the Assoc_List. ! -- This is called by Resolv_Aggr_Expr after producing -- an invalid component error message. procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id); --- 198,208 ---- -- quadratic in the size of the association list. procedure Check_Misspelled_Component ! (Elements : Elist_Id; ! Component : Node_Id); -- Give possible misspelling diagnostic if Component is likely to be -- a misspelling of one of the components of the Assoc_List. ! -- This is called by Resolve_Aggr_Expr after producing -- an invalid component error message. procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id); *************** package body Sem_Aggr is *** 215,224 **** Index : Node_Id; Index_Constr : Node_Id; Component_Typ : Entity_Id; ! Others_Allowed : Boolean) ! return Boolean; -- This procedure performs the semantic checks for an array aggregate. -- True is returned if the aggregate resolution succeeds. -- The procedure works by recursively checking each nested aggregate. -- Specifically, after checking a sub-aggregate nested at the i-th level -- we recursively check all the subaggregates at the i+1-st level (if any). --- 220,229 ---- Index : Node_Id; Index_Constr : Node_Id; Component_Typ : Entity_Id; ! Others_Allowed : Boolean) return Boolean; -- This procedure performs the semantic checks for an array aggregate. -- True is returned if the aggregate resolution succeeds. + -- -- The procedure works by recursively checking each nested aggregate. -- Specifically, after checking a sub-aggregate nested at the i-th level -- we recursively check all the subaggregates at the i+1-st level (if any). *************** package body Sem_Aggr is *** 249,255 **** -- appears last in the sub-aggregate. Check that we do not have -- positional and named components in the array sub-aggregate (unless -- the named association is an others choice). Finally if an others ! -- choice is present, make sure it is allowed in the aggregate contex. -- -- 2. If the array sub-aggregate contains discrete_choices: -- --- 254,260 ---- -- appears last in the sub-aggregate. Check that we do not have -- positional and named components in the array sub-aggregate (unless -- the named association is an others choice). Finally if an others ! -- choice is present, make sure it is allowed in the aggregate context. -- -- 2. If the array sub-aggregate contains discrete_choices: -- *************** package body Sem_Aggr is *** 409,418 **** return; end if; -- This is really expansion activity, so make sure that expansion -- is on and is allowed. ! if not Expander_Active or else In_Default_Expression then return; end if; --- 414,439 ---- return; end if; + -- Ada 2005 (AI-230): Generate a conversion to an anonymous access + -- component's type to force the appropriate accessibility checks. + + -- Ada 2005 (AI-231): Generate conversion to the null-excluding + -- type to force the corresponding run-time check + + if Is_Access_Type (Check_Typ) + and then ((Is_Local_Anonymous_Access (Check_Typ)) + or else (Can_Never_Be_Null (Check_Typ) + and then not Can_Never_Be_Null (Exp_Typ))) + then + Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp, Check_Typ); + Check_Unset_Reference (Exp); + end if; + -- This is really expansion activity, so make sure that expansion -- is on and is allowed. ! if not Expander_Active or else In_Spec_Expression then return; end if; *************** package body Sem_Aggr is *** 481,500 **** Check_Unset_Reference (Exp); end if; - -- Ada 2005 (AI-230): Generate a conversion to an anonymous access - -- component's type to force the appropriate accessibility checks. - - -- Ada 2005 (AI-231): Generate conversion to the null-excluding - -- type to force the corresponding run-time check - - elsif Is_Access_Type (Check_Typ) - and then ((Is_Local_Anonymous_Access (Check_Typ)) - or else (Can_Never_Be_Null (Check_Typ) - and then not Can_Never_Be_Null (Exp_Typ))) - then - Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); - Analyze_And_Resolve (Exp, Check_Typ); - Check_Unset_Reference (Exp); end if; end Aggregate_Constraint_Checks; --- 502,507 ---- *************** package body Sem_Aggr is *** 680,686 **** Set_First_Index (Itype, First (Index_Constraints)); Set_Is_Constrained (Itype, True); Set_Is_Internal (Itype, True); - Init_Size_Align (Itype); -- A simple optimization: purely positional aggregates of static -- components should be passed to gigi unexpanded whenever possible, --- 687,692 ---- *************** package body Sem_Aggr is *** 698,704 **** -- and we must not generate a freeze node for the type, or else it -- will appear incomplete to gigi. ! if Is_Packed (Itype) and then not In_Default_Expression and then Expander_Active then Freeze_Itype (Itype, N); --- 704,710 ---- -- and we must not generate a freeze node for the type, or else it -- will appear incomplete to gigi. ! if Is_Packed (Itype) and then not In_Spec_Expression and then Expander_Active then Freeze_Itype (Itype, N); *************** package body Sem_Aggr is *** 712,719 **** -------------------------------- procedure Check_Misspelled_Component ! (Elements : Elist_Id; ! Component : Node_Id) is Max_Suggestions : constant := 2; --- 718,725 ---- -------------------------------- procedure Check_Misspelled_Component ! (Elements : Elist_Id; ! Component : Node_Id) is Max_Suggestions : constant := 2; *************** package body Sem_Aggr is *** 763,768 **** --- 769,791 ---- end Check_Misspelled_Component; ---------------------------------------- + -- Check_Expr_OK_In_Limited_Aggregate -- + ---------------------------------------- + + procedure Check_Expr_OK_In_Limited_Aggregate (Expr : Node_Id) is + begin + if Is_Limited_Type (Etype (Expr)) + and then Comes_From_Source (Expr) + and then not In_Instance_Body + then + if not OK_For_Limited_Init (Expr) then + Error_Msg_N ("initialization not allowed for limited types", Expr); + Explain_Limited_Type (Etype (Expr), Expr); + end if; + end if; + end Check_Expr_OK_In_Limited_Aggregate; + + ---------------------------------------- -- Check_Static_Discriminated_Subtype -- ---------------------------------------- *************** package body Sem_Aggr is *** 909,926 **** -- First a special test, for the case of a positional aggregate -- of characters which can be replaced by a string literal. -- Do not perform this transformation if this was a string literal -- to start with, whose components needed constraint checks, or if -- the component type is non-static, because it will require those -- checks and be transformed back into an aggregate. if Number_Dimensions (Typ) = 1 ! and then ! (Root_Type (Component_Type (Typ)) = Standard_Character ! or else ! Root_Type (Component_Type (Typ)) = Standard_Wide_Character ! or else ! Root_Type (Component_Type (Typ)) = Standard_Wide_Wide_Character) and then No (Component_Associations (N)) and then not Is_Limited_Composite (Typ) and then not Is_Private_Composite (Typ) --- 932,945 ---- -- First a special test, for the case of a positional aggregate -- of characters which can be replaced by a string literal. + -- Do not perform this transformation if this was a string literal -- to start with, whose components needed constraint checks, or if -- the component type is non-static, because it will require those -- checks and be transformed back into an aggregate. if Number_Dimensions (Typ) = 1 ! and then Is_Standard_Character_Type (Component_Type (Typ)) and then No (Component_Associations (N)) and then not Is_Limited_Composite (Typ) and then not Is_Private_Composite (Typ) *************** package body Sem_Aggr is *** 1078,1085 **** Index : Node_Id; Index_Constr : Node_Id; Component_Typ : Entity_Id; ! Others_Allowed : Boolean) ! return Boolean is Loc : constant Source_Ptr := Sloc (N); --- 1097,1103 ---- Index : Node_Id; Index_Constr : Node_Id; Component_Typ : Entity_Id; ! Others_Allowed : Boolean) return Boolean is Loc : constant Source_Ptr := Sloc (N); *************** package body Sem_Aggr is *** 1126,1134 **** function Resolve_Aggr_Expr (Expr : Node_Id; ! Single_Elmt : Boolean) ! return Boolean; ! -- Resolves aggregate expression Expr. Returs False if resolution -- fails. If Single_Elmt is set to False, the expression Expr may be -- used to initialize several array aggregate elements (this can -- happen for discrete choices such as "L .. H => Expr" or the others --- 1144,1151 ---- function Resolve_Aggr_Expr (Expr : Node_Id; ! Single_Elmt : Boolean) return Boolean; ! -- Resolves aggregate expression Expr. Returns False if resolution -- fails. If Single_Elmt is set to False, the expression Expr may be -- used to initialize several array aggregate elements (this can -- happen for discrete choices such as "L .. H => Expr" or the others *************** package body Sem_Aggr is *** 1377,1388 **** function Resolve_Aggr_Expr (Expr : Node_Id; ! Single_Elmt : Boolean) ! return Boolean is Nxt_Ind : constant Node_Id := Next_Index (Index); Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr); ! -- Index is the current index corresponding to the expresion Resolution_OK : Boolean := True; -- Set to False if resolution of the expression failed --- 1394,1404 ---- function Resolve_Aggr_Expr (Expr : Node_Id; ! Single_Elmt : Boolean) return Boolean is Nxt_Ind : constant Node_Id := Next_Index (Index); Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr); ! -- Index is the current index corresponding to the expression Resolution_OK : Boolean := True; -- Set to False if resolution of the expression failed *************** package body Sem_Aggr is *** 1402,1409 **** if Is_Character_Type (Component_Typ) and then No (Next_Index (Nxt_Ind)) ! and then (Nkind (Expr) = N_String_Literal ! or else Nkind (Expr) = N_Operator_Symbol) then -- A string literal used in a multidimensional array -- aggregate in place of the final one-dimensional --- 1418,1424 ---- if Is_Character_Type (Component_Typ) and then No (Next_Index (Nxt_Ind)) ! and then Nkind_In (Expr, N_String_Literal, N_Operator_Symbol) then -- A string literal used in a multidimensional array -- aggregate in place of the final one-dimensional *************** package body Sem_Aggr is *** 1436,1444 **** elsif Single_Elmt or else not Expander_Active ! or else In_Default_Expression then Analyze_And_Resolve (Expr, Component_Typ); Check_Non_Static_Context (Expr); Aggregate_Constraint_Checks (Expr, Component_Typ); Check_Unset_Reference (Expr); --- 1451,1460 ---- elsif Single_Elmt or else not Expander_Active ! or else In_Spec_Expression then Analyze_And_Resolve (Expr, Component_Typ); + Check_Expr_OK_In_Limited_Aggregate (Expr); Check_Non_Static_Context (Expr); Aggregate_Constraint_Checks (Expr, Component_Typ); Check_Unset_Reference (Expr); *************** package body Sem_Aggr is *** 1513,1521 **** if Ada_Version = Ada_83 and then Assoc /= First (Component_Associations (N)) ! and then (Nkind (Parent (N)) = N_Assignment_Statement ! or else ! Nkind (Parent (N)) = N_Object_Declaration) then Error_Msg_N ("(Ada 83) illegal context for OTHERS choice", N); --- 1529,1536 ---- if Ada_Version = Ada_83 and then Assoc /= First (Component_Associations (N)) ! and then Nkind_In (Parent (N), N_Assignment_Statement, ! N_Object_Declaration) then Error_Msg_N ("(Ada 83) illegal context for OTHERS choice", N); *************** package body Sem_Aggr is *** 1562,1568 **** -- STEP 2: Process named components if No (Expressions (N)) then - if Others_Present then Case_Table_Size := Nb_Choices - 1; else --- 1577,1582 ---- *************** package body Sem_Aggr is *** 1624,1629 **** --- 1638,1645 ---- return Failure; end if; + -- Case of subtype indication + elsif Nkind (Choice) = N_Subtype_Indication then Resolve_Discrete_Subtype_Indication (Choice, Index_Base); *************** package body Sem_Aggr is *** 1633,1639 **** Get_Index_Bounds (Choice, Low, High); Check_Bounds (S_Low, S_High, Low, High); ! else -- Choice is a range or an expression Resolve (Choice, Index_Base); Check_Unset_Reference (Choice); Check_Non_Static_Context (Choice); --- 1649,1657 ---- Get_Index_Bounds (Choice, Low, High); Check_Bounds (S_Low, S_High, Low, High); ! -- Case of range or expression ! ! else Resolve (Choice, Index_Base); Check_Unset_Reference (Choice); Check_Non_Static_Context (Choice); *************** package body Sem_Aggr is *** 1739,1745 **** return Failure; elsif not Others_Present then - Hi_Val := Expr_Value (Table (J).Choice_Hi); Lo_Val := Expr_Value (Table (J + 1).Choice_Lo); --- 1757,1762 ---- *************** package body Sem_Aggr is *** 1807,1816 **** --- 1824,1946 ---- Choices_High := Table (Nb_Discrete_Choices).Choice_Hi; end if; + -- If Others is present, then bounds of aggregate come from the + -- index constraint (not the choices in the aggregate itself). + if Others_Present then Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High); + -- No others clause present + else + -- Special processing if others allowed and not present. This + -- means that the bounds of the aggregate come from the index + -- constraint (and the length must match). + + if Others_Allowed then + Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High); + + -- If others allowed, and no others present, then the array + -- should cover all index values. If it does not, we will + -- get a length check warning, but there is two cases where + -- an additional warning is useful: + + -- If we have no positional components, and the length is + -- wrong (which we can tell by others being allowed with + -- missing components), and the index type is an enumeration + -- type, then issue appropriate warnings about these missing + -- components. They are only warnings, since the aggregate + -- is fine, it's just the wrong length. We skip this check + -- for standard character types (since there are no literals + -- and it is too much trouble to concoct them), and also if + -- any of the bounds have not-known-at-compile-time values. + + -- Another case warranting a warning is when the length is + -- right, but as above we have an index type that is an + -- enumeration, and the bounds do not match. This is a + -- case where dubious sliding is allowed and we generate + -- a warning that the bounds do not match. + + if No (Expressions (N)) + and then Nkind (Index) = N_Range + and then Is_Enumeration_Type (Etype (Index)) + and then not Is_Standard_Character_Type (Etype (Index)) + and then Compile_Time_Known_Value (Aggr_Low) + and then Compile_Time_Known_Value (Aggr_High) + and then Compile_Time_Known_Value (Choices_Low) + and then Compile_Time_Known_Value (Choices_High) + then + declare + ALo : constant Node_Id := Expr_Value_E (Aggr_Low); + AHi : constant Node_Id := Expr_Value_E (Aggr_High); + CLo : constant Node_Id := Expr_Value_E (Choices_Low); + CHi : constant Node_Id := Expr_Value_E (Choices_High); + + Ent : Entity_Id; + + begin + -- Warning case one, missing values at start/end. Only + -- do the check if the number of entries is too small. + + if (Enumeration_Pos (CHi) - Enumeration_Pos (CLo)) + < + (Enumeration_Pos (AHi) - Enumeration_Pos (ALo)) + then + Error_Msg_N + ("missing index value(s) in array aggregate?", N); + + -- Output missing value(s) at start + + if Chars (ALo) /= Chars (CLo) then + Ent := Prev (CLo); + + if Chars (ALo) = Chars (Ent) then + Error_Msg_Name_1 := Chars (ALo); + Error_Msg_N ("\ %?", N); + else + Error_Msg_Name_1 := Chars (ALo); + Error_Msg_Name_2 := Chars (Ent); + Error_Msg_N ("\ % .. %?", N); + end if; + end if; + + -- Output missing value(s) at end + + if Chars (AHi) /= Chars (CHi) then + Ent := Next (CHi); + + if Chars (AHi) = Chars (Ent) then + Error_Msg_Name_1 := Chars (Ent); + Error_Msg_N ("\ %?", N); + else + Error_Msg_Name_1 := Chars (Ent); + Error_Msg_Name_2 := Chars (AHi); + Error_Msg_N ("\ % .. %?", N); + end if; + end if; + + -- Warning case 2, dubious sliding. The First_Subtype + -- test distinguishes between a constrained type where + -- sliding is not allowed (so we will get a warning + -- later that Constraint_Error will be raised), and + -- the unconstrained case where sliding is permitted. + + elsif (Enumeration_Pos (CHi) - Enumeration_Pos (CLo)) + = + (Enumeration_Pos (AHi) - Enumeration_Pos (ALo)) + and then Chars (ALo) /= Chars (CLo) + and then + not Is_Constrained (First_Subtype (Etype (N))) + then + Error_Msg_N + ("bounds of aggregate do not match target?", N); + end if; + end; + end if; + end if; + + -- If no others, aggregate bounds come from aggregate + Aggr_Low := Choices_Low; Aggr_High := Choices_High; end if; *************** package body Sem_Aggr is *** 1978,1986 **** I : Interp_Index; It : Interp; function Valid_Ancestor_Type return Boolean; -- Verify that the type of the ancestor part is a non-private ancestor ! -- of the expected type. ------------------------- -- Valid_Ancestor_Type -- --- 2108,2150 ---- I : Interp_Index; It : Interp; + function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean; + -- If the type is limited, verify that the ancestor part is a legal + -- expression (aggregate or function call, including 'Input)) that + -- does not require a copy, as specified in 7.5 (2). + function Valid_Ancestor_Type return Boolean; -- Verify that the type of the ancestor part is a non-private ancestor ! -- of the expected type, which must be a type extension. ! ! ---------------------------- ! -- Valid_Limited_Ancestor -- ! ---------------------------- ! ! function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean is ! begin ! if Is_Entity_Name (Anc) ! and then Is_Type (Entity (Anc)) ! then ! return True; ! ! elsif Nkind_In (Anc, N_Aggregate, N_Function_Call) then ! return True; ! ! elsif Nkind (Anc) = N_Attribute_Reference ! and then Attribute_Name (Anc) = Name_Input ! then ! return True; ! ! elsif ! Nkind (Anc) = N_Qualified_Expression ! then ! return Valid_Limited_Ancestor (Expression (Anc)); ! ! else ! return False; ! end if; ! end Valid_Limited_Ancestor; ------------------------- -- Valid_Ancestor_Type -- *************** package body Sem_Aggr is *** 1991,2008 **** begin Imm_Type := Base_Type (Typ); ! while Is_Derived_Type (Imm_Type) ! and then Etype (Imm_Type) /= Base_Type (A_Type) ! loop ! Imm_Type := Etype (Base_Type (Imm_Type)); end loop; ! if Etype (Imm_Type) /= Base_Type (A_Type) then ! Error_Msg_NE ("expect ancestor type of &", A, Typ); ! return False; ! else ! return True; ! end if; end Valid_Ancestor_Type; -- Start of processing for Resolve_Extension_Aggregate --- 2155,2185 ---- begin Imm_Type := Base_Type (Typ); ! while Is_Derived_Type (Imm_Type) loop ! if Etype (Imm_Type) = Base_Type (A_Type) then ! return True; ! ! -- The base type of the parent type may appear as a private ! -- extension if it is declared as such in a parent unit of ! -- the current one. For consistency of the subsequent analysis ! -- use the partial view for the ancestor part. ! ! elsif Is_Private_Type (Etype (Imm_Type)) ! and then Present (Full_View (Etype (Imm_Type))) ! and then Base_Type (A_Type) = Full_View (Etype (Imm_Type)) ! then ! A_Type := Etype (Imm_Type); ! return True; ! ! else ! Imm_Type := Etype (Base_Type (Imm_Type)); ! end if; end loop; ! -- If previous loop did not find a proper ancestor, report error. ! ! Error_Msg_NE ("expect ancestor type of &", A, Typ); ! return False; end Valid_Ancestor_Type; -- Start of processing for Resolve_Extension_Aggregate *************** package body Sem_Aggr is *** 2022,2027 **** --- 2199,2211 ---- Error_Msg_N ("aggregate type cannot be limited", N); Explain_Limited_Type (Typ, N); return; + + elsif Valid_Limited_Ancestor (A) then + null; + + else + Error_Msg_N + ("limited ancestor part must be aggregate or function call", A); end if; elsif Is_Class_Wide_Type (Typ) then *************** package body Sem_Aggr is *** 2431,2461 **** return Expr; end Get_Value; - procedure Check_Non_Limited_Type (Expr : Node_Id); - -- Relax check to allow the default initialization of limited types. - -- For example: - -- record - -- C : Lim := (..., others => <>); - -- end record; - - ---------------------------- - -- Check_Non_Limited_Type -- - ---------------------------- - - procedure Check_Non_Limited_Type (Expr : Node_Id) is - begin - if Is_Limited_Type (Etype (Expr)) - and then Comes_From_Source (Expr) - and then not In_Instance_Body - then - if not OK_For_Limited_Init (Expr) then - Error_Msg_N - ("initialization not allowed for limited types", N); - Explain_Limited_Type (Etype (Expr), Expr); - end if; - end if; - end Check_Non_Limited_Type; - ----------------------- -- Resolve_Aggr_Expr -- ----------------------- --- 2615,2620 ---- *************** package body Sem_Aggr is *** 2484,2497 **** function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is Kind : constant Node_Kind := Nkind (Expr); - begin ! return ((Kind = N_Aggregate ! or else Kind = N_Extension_Aggregate) and then Present (Etype (Expr)) and then Is_Record_Type (Etype (Expr)) and then Expansion_Delayed (Expr)) - or else (Kind = N_Qualified_Expression and then Has_Expansion_Delayed (Expression (Expr))); end Has_Expansion_Delayed; --- 2643,2653 ---- function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is Kind : constant Node_Kind := Nkind (Expr); begin ! return (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate) and then Present (Etype (Expr)) and then Is_Record_Type (Etype (Expr)) and then Expansion_Delayed (Expr)) or else (Kind = N_Qualified_Expression and then Has_Expansion_Delayed (Expression (Expr))); end Has_Expansion_Delayed; *************** package body Sem_Aggr is *** 2509,2515 **** Expr_Type := Etype (Component); -- Otherwise we have to pick up the new type of the component from ! -- the new costrained subtype of the aggregate. In fact components -- which are of a composite type might be constrained by a -- discriminant, and we want to resolve Expr against the subtype were -- all discriminant occurrences are replaced with their actual value. --- 2665,2671 ---- Expr_Type := Etype (Component); -- Otherwise we have to pick up the new type of the component from ! -- the new constrained subtype of the aggregate. In fact components -- which are of a composite type might be constrained by a -- discriminant, and we want to resolve Expr against the subtype were -- all discriminant occurrences are replaced with their actual value. *************** package body Sem_Aggr is *** 2579,2585 **** end if; Analyze_And_Resolve (Expr, Expr_Type); ! Check_Non_Limited_Type (Expr); Check_Non_Static_Context (Expr); Check_Unset_Reference (Expr); --- 2735,2741 ---- end if; Analyze_And_Resolve (Expr, Expr_Type); ! Check_Expr_OK_In_Limited_Aggregate (Expr); Check_Non_Static_Context (Expr); Check_Unset_Reference (Expr); *************** package body Sem_Aggr is *** 2625,2631 **** Error_Msg_N ("record aggregate cannot be null", N); return; ! elsif No (First_Entity (Typ)) then Error_Msg_N ("record aggregate must be null", N); return; end if; --- 2781,2797 ---- Error_Msg_N ("record aggregate cannot be null", N); return; ! -- If the type has no components, then the aggregate should either ! -- have "null record", or in Ada 2005 it could instead have a single ! -- component association given by "others => <>". For Ada 95 we flag ! -- an error at this point, but for Ada 2005 we proceed with checking ! -- the associations below, which will catch the case where it's not ! -- an aggregate with "others => <>". Note that the legality of a <> ! -- aggregate for a null record type was established by AI05-016. ! ! elsif No (First_Entity (Typ)) ! and then Ada_Version < Ada_05 ! then Error_Msg_N ("record aggregate must be null", N); return; end if; *************** package body Sem_Aggr is *** 2773,2783 **** -- in sem_ch3 and here rather than have a copy of the code which is a -- maintenance nightmare. ! -- ??? Performace WARNING. The current implementation creates a new -- itype for all aggregates whose base type is discriminated. -- This means that for record aggregates nested inside an array -- aggregate we will create a new itype for each record aggregate ! -- if the array cmponent type has discriminants. For large aggregates -- this may be a problem. What should be done in this case is -- to reuse itypes as much as possible. --- 2939,2949 ---- -- in sem_ch3 and here rather than have a copy of the code which is a -- maintenance nightmare. ! -- ??? Performance WARNING. The current implementation creates a new -- itype for all aggregates whose base type is discriminated. -- This means that for record aggregates nested inside an array -- aggregate we will create a new itype for each record aggregate ! -- if the array component type has discriminants. For large aggregates -- this may be a problem. What should be done in this case is -- to reuse itypes as much as possible. *************** package body Sem_Aggr is *** 2848,2855 **** else Root_Typ := Root_Type (Typ); ! if Nkind (Parent (Base_Type (Root_Typ))) ! = N_Private_Type_Declaration then Error_Msg_NE ("type of aggregate has private ancestor&!", --- 3014,3021 ---- else Root_Typ := Root_Type (Typ); ! if Nkind (Parent (Base_Type (Root_Typ))) = ! N_Private_Type_Declaration then Error_Msg_NE ("type of aggregate has private ancestor&!", *************** package body Sem_Aggr is *** 3251,3257 **** C := First_Component (Typ); while Present (C) loop if Chars (C) = Chars (Selectr) then ! exit; end if; Next_Component (C); --- 3417,3434 ---- C := First_Component (Typ); while Present (C) loop if Chars (C) = Chars (Selectr) then ! ! -- If the context is an extension aggregate, ! -- the component must not be inherited from ! -- the ancestor part of the aggregate. ! ! if Nkind (N) /= N_Extension_Aggregate ! or else ! Scope (Original_Record_Component (C)) /= ! Etype (Ancestor_Part (N)) ! then ! exit; ! end if; end if; Next_Component (C); diff -Nrcpad gcc-4.3.3/gcc/ada/sem_attr.adb gcc-4.4.0/gcc/ada/sem_attr.adb *** gcc-4.3.3/gcc/ada/sem_attr.adb Thu Dec 13 10:27:21 2007 --- gcc-4.4.0/gcc/ada/sem_attr.adb Wed Aug 13 10:57:43 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Exp_Dist; use Exp_Dist; *** 35,40 **** --- 35,41 ---- with Exp_Util; use Exp_Util; with Expander; use Expander; with Freeze; use Freeze; + with Itypes; use Itypes; with Lib; use Lib; with Lib.Xref; use Lib.Xref; with Nlists; use Nlists; *************** package body Sem_Attr is *** 249,255 **** procedure Check_Enum_Image; -- If the prefix type is an enumeration type, set all its literals -- as referenced, since the image function could possibly end up ! -- referencing any of the literals indirectly. procedure Check_Fixed_Point_Type; -- Verify that prefix of attribute N is a fixed type --- 250,256 ---- procedure Check_Enum_Image; -- If the prefix type is an enumeration type, set all its literals -- as referenced, since the image function could possibly end up ! -- referencing any of the literals indirectly. Same for Enum_Val. procedure Check_Fixed_Point_Type; -- Verify that prefix of attribute N is a fixed type *************** package body Sem_Attr is *** 274,281 **** -- two attribute expressions are present procedure Legal_Formal_Attribute; ! -- Common processing for attributes Definite, Has_Access_Values, ! -- and Has_Discriminants procedure Check_Integer_Type; -- Verify that prefix of attribute N is an integer type --- 275,282 ---- -- two attribute expressions are present procedure Legal_Formal_Attribute; ! -- Common processing for attributes Definite and Has_Discriminants. ! -- Checks that prefix is generic indefinite formal type. procedure Check_Integer_Type; -- Verify that prefix of attribute N is an integer type *************** package body Sem_Attr is *** 286,291 **** --- 287,296 ---- procedure Check_Modular_Integer_Type; -- Verify that prefix of attribute N is a modular integer type + procedure Check_Not_CPP_Type; + -- Check that P (the prefix of the attribute) is not an CPP type + -- for which no Ada predefined primitive is available. + procedure Check_Not_Incomplete_Type; -- Check that P (the prefix of the attribute) is not an incomplete -- type or a private type for which no full view has been given. *************** package body Sem_Attr is *** 310,315 **** --- 315,323 ---- -- corresponding possible defined attribute function (e.g. for the -- Read attribute, Nam will be TSS_Stream_Read). + procedure Check_PolyORB_Attribute; + -- Validity checking for PolyORB/DSA attribute + procedure Check_Task_Prefix; -- Verify that prefix of attribute N is a task or task type *************** package body Sem_Attr is *** 370,378 **** -- type that is constructed is returned as the result. procedure Build_Access_Subprogram_Type (P : Node_Id); ! -- Build an access to subprogram whose designated type is ! -- the type of the prefix. If prefix is overloaded, so it the ! -- node itself. The result is stored in Acc_Type. function OK_Self_Reference return Boolean; -- An access reference whose prefix is a type can legally appear --- 378,386 ---- -- type that is constructed is returned as the result. procedure Build_Access_Subprogram_Type (P : Node_Id); ! -- Build an access to subprogram whose designated type is the type of ! -- the prefix. If prefix is overloaded, so is the node itself. The ! -- result is stored in Acc_Type. function OK_Self_Reference return Boolean; -- An access reference whose prefix is a type can legally appear *************** package body Sem_Attr is *** 391,397 **** (E_Access_Attribute_Type, Current_Scope, Loc, 'A'); begin Set_Etype (Typ, Typ); - Init_Size_Align (Typ); Set_Is_Itype (Typ); Set_Associated_Node_For_Itype (Typ, N); Set_Directly_Designated_Type (Typ, DT); --- 399,404 ---- *************** package body Sem_Attr is *** 447,464 **** -- subprogram itself as the designated type. Type-checking in -- this case compares the signatures of the designated types. Set_Etype (N, Any_Type); if not Is_Overloaded (P) then Check_Local_Access (Entity (P)); if not Is_Intrinsic_Subprogram (Entity (P)) then ! Acc_Type := ! New_Internal_Entity ! (Get_Kind (Entity (P)), Current_Scope, Loc, 'A'); Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, Entity (P)); Set_Etype (N, Acc_Type); end if; else --- 454,494 ---- -- subprogram itself as the designated type. Type-checking in -- this case compares the signatures of the designated types. + -- Note: This fragment of the tree is temporarily malformed + -- because the correct tree requires an E_Subprogram_Type entity + -- as the designated type. In most cases this designated type is + -- later overridden by the semantics with the type imposed by the + -- context during the resolution phase. In the specific case of + -- the expression Address!(Prim'Unrestricted_Access), used to + -- initialize slots of dispatch tables, this work will be done by + -- the expander (see Exp_Aggr). + + -- The reason to temporarily add this kind of node to the tree + -- instead of a proper E_Subprogram_Type itype, is the following: + -- in case of errors found in the source file we report better + -- error messages. For example, instead of generating the + -- following error: + + -- "expected access to subprogram with profile + -- defined at line X" + + -- we currently generate: + + -- "expected access to function Z defined at line X" + Set_Etype (N, Any_Type); if not Is_Overloaded (P) then Check_Local_Access (Entity (P)); if not Is_Intrinsic_Subprogram (Entity (P)) then ! Acc_Type := Create_Itype (Get_Kind (Entity (P)), N); ! Set_Is_Public (Acc_Type, False); Set_Etype (Acc_Type, Acc_Type); + Set_Convention (Acc_Type, Convention (Entity (P))); Set_Directly_Designated_Type (Acc_Type, Entity (P)); Set_Etype (N, Acc_Type); + Freeze_Before (N, Acc_Type); end if; else *************** package body Sem_Attr is *** 467,478 **** Check_Local_Access (It.Nam); if not Is_Intrinsic_Subprogram (It.Nam) then ! Acc_Type := ! New_Internal_Entity ! (Get_Kind (It.Nam), Current_Scope, Loc, 'A'); Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, It.Nam); Add_One_Interp (N, Acc_Type, Acc_Type); end if; Get_Next_Interp (Index, It); --- 497,509 ---- Check_Local_Access (It.Nam); if not Is_Intrinsic_Subprogram (It.Nam) then ! Acc_Type := Create_Itype (Get_Kind (It.Nam), N); ! Set_Is_Public (Acc_Type, False); Set_Etype (Acc_Type, Acc_Type); + Set_Convention (Acc_Type, Convention (It.Nam)); Set_Directly_Designated_Type (Acc_Type, It.Nam); Add_One_Interp (N, Acc_Type, Acc_Type); + Freeze_Before (N, Acc_Type); end if; Get_Next_Interp (Index, It); *************** package body Sem_Attr is *** 502,510 **** (Nkind (Par) = N_Component_Association or else Nkind (Par) in N_Subexpr) loop ! if Nkind (Par) = N_Aggregate ! or else Nkind (Par) = N_Extension_Aggregate ! then if Etype (Par) = Typ then Set_Has_Self_Reference (Par); return True; --- 533,539 ---- (Nkind (Par) = N_Component_Association or else Nkind (Par) in N_Subexpr) loop ! if Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then if Etype (Par) = Typ then Set_Has_Self_Reference (Par); return True; *************** package body Sem_Attr is *** 552,558 **** -- could modify local variables to be passed out of scope if Aname = Name_Unrestricted_Access then ! Kill_Current_Values; end if; return; --- 581,605 ---- -- could modify local variables to be passed out of scope if Aname = Name_Unrestricted_Access then ! ! -- Do not kill values on nodes initializing dispatch tables ! -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access) ! -- is currently generated by the expander only for this ! -- purpose. Done to keep the quality of warnings currently ! -- generated by the compiler (otherwise any declaration of ! -- a tagged type cleans constant indications from its scope). ! ! if Nkind (Parent (N)) = N_Unchecked_Type_Conversion ! and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr) ! or else ! Etype (Parent (N)) = RTE (RE_Size_Ptr)) ! and then Is_Dispatching_Operation ! (Directly_Designated_Type (Etype (N))) ! then ! null; ! else ! Kill_Current_Values; ! end if; end if; return; *************** package body Sem_Attr is *** 619,635 **** ("current instance prefix must be a direct name", P); end if; ! -- If a current instance attribute appears within a ! -- a component constraint it must appear alone; other ! -- contexts (default expressions, within a task body) ! -- are not subject to this restriction. ! if not In_Default_Expression and then not Has_Completion (Scop) ! and then ! Nkind (Parent (N)) /= N_Discriminant_Association ! and then ! Nkind (Parent (N)) /= N_Index_Or_Discriminant_Constraint then Error_Msg_N ("current instance attribute must appear alone", N); --- 666,681 ---- ("current instance prefix must be a direct name", P); end if; ! -- If a current instance attribute appears in a component ! -- constraint it must appear alone; other contexts (spec- ! -- expressions, within a task body) are not subject to this ! -- restriction. ! if not In_Spec_Expression and then not Has_Completion (Scop) ! and then not ! Nkind_In (Parent (N), N_Discriminant_Association, ! N_Index_Or_Discriminant_Constraint) then Error_Msg_N ("current instance attribute must appear alone", N); *************** package body Sem_Attr is *** 667,672 **** --- 713,724 ---- then null; + -- OK if reference to the current instance of a protected + -- object. + + elsif Is_Protected_Self_Reference (P) then + null; + -- Otherwise we have an error case else *************** package body Sem_Attr is *** 726,733 **** Kill_Current_Values (Ent); exit; ! elsif Nkind (PP) = N_Selected_Component ! or else Nkind (PP) = N_Indexed_Component then PP := Prefix (PP); --- 778,785 ---- Kill_Current_Values (Ent); exit; ! elsif Nkind_In (PP, N_Selected_Component, ! N_Indexed_Component) then PP := Prefix (PP); *************** package body Sem_Attr is *** 1225,1230 **** --- 1277,1297 ---- end if; end Check_Modular_Integer_Type; + ------------------------ + -- Check_Not_CPP_Type -- + ------------------------ + + procedure Check_Not_CPP_Type is + begin + if Is_Tagged_Type (Etype (P)) + and then Convention (Etype (P)) = Convention_CPP + and then Is_CPP_Class (Root_Type (Etype (P))) + then + Error_Attr_P + ("invalid use of % attribute with 'C'P'P tagged type"); + end if; + end Check_Not_CPP_Type; + ------------------------------- -- Check_Not_Incomplete_Type -- ------------------------------- *************** package body Sem_Attr is *** 1285,1291 **** if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) ! or else In_Default_Expression then return; else --- 1352,1358 ---- if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) ! or else In_Spec_Expression then return; else *************** package body Sem_Attr is *** 1322,1327 **** --- 1389,1411 ---- end if; end Check_Object_Reference; + ---------------------------- + -- Check_PolyORB_Attribute -- + ---------------------------- + + procedure Check_PolyORB_Attribute is + begin + Validate_Non_Static_Attribute_Function_Call; + + Check_Type; + Check_Not_CPP_Type; + + if Get_PCS_Name /= Name_PolyORB_DSA then + Error_Attr + ("attribute% requires the 'Poly'O'R'B 'P'C'S", N); + end if; + end Check_PolyORB_Attribute; + ------------------------ -- Check_Program_Unit -- ------------------------ *************** package body Sem_Attr is *** 1402,1407 **** --- 1486,1499 ---- Etyp : Entity_Id; Btyp : Entity_Id; + In_Shared_Var_Procs : Boolean; + -- True when compiling the body of System.Shared_Storage. + -- Shared_Var_Procs. For this runtime package (always compiled in + -- GNAT mode), we allow stream attributes references for limited + -- types for the case where shared passive objects are implemented + -- using stream attributes, which is the default in GNAT's persistent + -- storage implementation. + begin Validate_Non_Static_Attribute_Function_Call; *************** package body Sem_Attr is *** 1414,1421 **** null; elsif Is_List_Member (N) ! and then Nkind (Parent (N)) /= N_Procedure_Call_Statement ! and then Nkind (Parent (N)) /= N_Aggregate then null; --- 1506,1513 ---- null; elsif Is_List_Member (N) ! and then not Nkind_In (Parent (N), N_Procedure_Call_Statement, ! N_Aggregate) then null; *************** package body Sem_Attr is *** 1435,1441 **** -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp -- (with no visibility restriction). ! if Comes_From_Source (N) and then not Stream_Attribute_Available (P_Type, Nam) and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert) then --- 1527,1545 ---- -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp -- (with no visibility restriction). ! declare ! Gen_Body : constant Node_Id := Enclosing_Generic_Body (N); ! begin ! if Present (Gen_Body) then ! In_Shared_Var_Procs := ! Is_RTE (Corresponding_Spec (Gen_Body), RE_Shared_Var_Procs); ! else ! In_Shared_Var_Procs := False; ! end if; ! end; ! ! if (Comes_From_Source (N) ! and then not (In_Shared_Var_Procs or In_Instance)) and then not Stream_Attribute_Available (P_Type, Nam) and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert) then *************** package body Sem_Attr is *** 1493,1498 **** --- 1597,1604 ---- Resolve (E2, P_Type); end if; + + Check_Not_CPP_Type; end Check_Stream_Attribute; ----------------------- *************** package body Sem_Attr is *** 1543,1548 **** --- 1649,1659 ---- then Error_Attr_P ("prefix of % attribute must be a type"); + elsif Is_Protected_Self_Reference (P) then + Error_Attr_P + ("prefix of % attribute denotes current instance " & + "(RM 9.4(21/2))"); + elsif Ekind (Entity (P)) = E_Incomplete_Type and then Present (Full_View (Entity (P))) then *************** package body Sem_Attr is *** 1818,1823 **** --- 1929,1935 ---- and then Aname /= Name_Address and then Aname /= Name_Code_Address and then Aname /= Name_Count + and then Aname /= Name_Result and then Aname /= Name_Unchecked_Access then Error_Attr ("ambiguous prefix for % attribute", P); *************** package body Sem_Attr is *** 1827,1832 **** --- 1939,1945 ---- and then Aname /= Name_Access and then Aname /= Name_Address and then Aname /= Name_Code_Address + and then Aname /= Name_Result and then Aname /= Name_Unchecked_Access then -- Ada 2005 (AI-345): Since protected and task types have primitive *************** package body Sem_Attr is *** 1907,1913 **** -- An Address attribute created by expansion is legal even when it -- applies to other entity-denoting expressions. ! if Is_Entity_Name (P) then declare Ent : constant Entity_Id := Entity (P); --- 2020,2032 ---- -- An Address attribute created by expansion is legal even when it -- applies to other entity-denoting expressions. ! if Is_Protected_Self_Reference (P) then ! -- An Address attribute on a protected object self reference ! -- is legal. ! ! null; ! ! elsif Is_Entity_Name (P) then declare Ent : constant Entity_Id := Entity (P); *************** package body Sem_Attr is *** 2017,2022 **** --- 2136,2142 ---- Check_E0; Check_Not_Incomplete_Type; + Check_Not_CPP_Type; Set_Etype (N, Universal_Integer); --------------- *************** package body Sem_Attr is *** 2044,2050 **** end if; end if; ! Note_Possible_Modification (E2); Set_Etype (N, RTE (RE_Asm_Output_Operand)); --------------- --- 2164,2170 ---- end if; end if; ! Note_Possible_Modification (E2, Sure => True); Set_Etype (N, RTE (RE_Asm_Output_Operand)); --------------- *************** package body Sem_Attr is *** 2071,2081 **** --- 2191,2209 ---- -- is set True for the entry family case). In the True case, -- makes sure that Is_AST_Entry is set on the entry. + ------------------- + -- Bad_AST_Entry -- + ------------------- + procedure Bad_AST_Entry is begin Error_Attr_P ("prefix for % attribute must be task entry"); end Bad_AST_Entry; + -------------- + -- OK_Entry -- + -------------- + function OK_Entry (E : Entity_Id) return Boolean is Result : Boolean; *************** package body Sem_Attr is *** 2145,2153 **** -- or of a variable of the enclosing task type. else ! if Nkind (Pref) = N_Identifier ! or else Nkind (Pref) = N_Expanded_Name ! then Ent := Entity (Pref); if not OK_Entry (Ent) --- 2273,2279 ---- -- or of a variable of the enclosing task type. else ! if Nkind_In (Pref, N_Identifier, N_Expanded_Name) then Ent := Entity (Pref); if not OK_Entry (Ent) *************** package body Sem_Attr is *** 2191,2197 **** and then Warn_On_Redundant_Constructs then Error_Msg_NE ! ("?redudant attribute, & is its own base type", N, Typ); end if; Set_Etype (N, Base_Type (Entity (P))); --- 2317,2323 ---- and then Warn_On_Redundant_Constructs then Error_Msg_NE ! ("?redundant attribute, & is its own base type", N, Typ); end if; Set_Etype (N, Base_Type (Entity (P))); *************** package body Sem_Attr is *** 2297,2305 **** begin Check_E0; ! if Nkind (P) = N_Identifier ! or else Nkind (P) = N_Expanded_Name ! then Ent := Entity (P); if not Is_Entry (Ent) then --- 2423,2429 ---- begin Check_E0; ! if Nkind_In (P, N_Identifier, N_Expanded_Name) then Ent := Entity (P); if not Is_Entry (Ent) then *************** package body Sem_Attr is *** 2500,2508 **** begin Check_E0; ! if Nkind (P) = N_Identifier ! or else Nkind (P) = N_Expanded_Name ! then Ent := Entity (P); if Ekind (Ent) /= E_Entry then --- 2624,2630 ---- begin Check_E0; ! if Nkind_In (P, N_Identifier, N_Expanded_Name) then Ent := Entity (P); if Ekind (Ent) /= E_Entry then *************** package body Sem_Attr is *** 2623,2629 **** when Attribute_Default_Bit_Order => Default_Bit_Order : begin Check_Standard_Prefix; - Check_E0; if Bytes_Big_Endian then Rewrite (N, --- 2745,2750 ---- *************** package body Sem_Attr is *** 2733,2739 **** if Nkind (P) /= N_Identifier then Error_Msg_N ("identifier expected (check name)", P); - elsif Get_Check_Id (Chars (P)) = No_Check_Id then Error_Msg_N ("& is not a recognized check name", P); end if; --- 2854,2859 ---- *************** package body Sem_Attr is *** 2766,2771 **** --- 2886,2923 ---- Set_Etype (N, Universal_Integer); end Enum_Rep; + -------------- + -- Enum_Val -- + -------------- + + when Attribute_Enum_Val => Enum_Val : begin + Check_E1; + Check_Type; + + if not Is_Enumeration_Type (P_Type) then + Error_Attr_P ("prefix of % attribute must be enumeration type"); + end if; + + -- If the enumeration type has a standard representation, the effect + -- is the same as 'Val, so rewrite the attribute as a 'Val. + + if not Has_Non_Standard_Rep (P_Base_Type) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Prefix (N)), + Attribute_Name => Name_Val, + Expressions => New_List (Relocate_Node (E1)))); + Analyze_And_Resolve (N, P_Base_Type); + + -- Non-standard representation case (enumeration with holes) + + else + Check_Enum_Image; + Resolve (E1, Any_Integer); + Set_Etype (N, P_Base_Type); + end if; + end Enum_Val; + ------------- -- Epsilon -- ------------- *************** package body Sem_Attr is *** 2802,2808 **** --------------- when Attribute_Fast_Math => - Check_E0; Check_Standard_Prefix; if Opt.Fast_Math then --- 2954,2959 ---- *************** package body Sem_Attr is *** 2862,2867 **** --- 3013,3027 ---- Set_Etype (N, P_Base_Type); Resolve (E1, P_Base_Type); + -------------- + -- From_Any -- + -------------- + + when Attribute_From_Any => + Check_E1; + Check_PolyORB_Attribute; + Set_Etype (N, P_Base_Type); + ----------------------- -- Has_Access_Values -- ----------------------- *************** package body Sem_Attr is *** 2872,2877 **** --- 3032,3046 ---- Set_Etype (N, Standard_Boolean); ----------------------- + -- Has_Tagged_Values -- + ----------------------- + + when Attribute_Has_Tagged_Values => + Check_Type; + Check_E0; + Set_Etype (N, Standard_Boolean); + + ----------------------- -- Has_Discriminants -- ----------------------- *************** package body Sem_Attr is *** 2988,2993 **** --- 3157,3172 ---- Set_Etype (N, P_Base_Type); + ------------------- + -- Invalid_Value -- + ------------------- + + when Attribute_Invalid_Value => + Check_E0; + Check_Scalar_Type; + Set_Etype (N, P_Base_Type); + Invalid_Value_Used := True; + ----------- -- Large -- ----------- *************** package body Sem_Attr is *** 3320,3328 **** -- Case of attribute used as actual for subprogram (positional) ! elsif (Nkind (Parnt) = N_Procedure_Call_Statement ! or else ! Nkind (Parnt) = N_Function_Call) and then Is_Entity_Name (Name (Parnt)) then Must_Be_Imported (Entity (Name (Parnt))); --- 3499,3506 ---- -- Case of attribute used as actual for subprogram (positional) ! elsif Nkind_In (Parnt, N_Procedure_Call_Statement, ! N_Function_Call) and then Is_Entity_Name (Name (Parnt)) then Must_Be_Imported (Entity (Name (Parnt))); *************** package body Sem_Attr is *** 3330,3338 **** -- Case of attribute used as actual for subprogram (named) elsif Nkind (Parnt) = N_Parameter_Association ! and then (Nkind (GParnt) = N_Procedure_Call_Statement ! or else ! Nkind (GParnt) = N_Function_Call) and then Is_Entity_Name (Name (GParnt)) then Must_Be_Imported (Entity (Name (GParnt))); --- 3508,3515 ---- -- Case of attribute used as actual for subprogram (named) elsif Nkind (Parnt) = N_Parameter_Association ! and then Nkind_In (GParnt, N_Procedure_Call_Statement, ! N_Function_Call) and then Is_Entity_Name (Name (GParnt)) then Must_Be_Imported (Entity (Name (GParnt))); *************** package body Sem_Attr is *** 3343,3349 **** Bad_Null_Parameter ("Null_Parameter must be actual or default parameter"); end if; - end Null_Parameter; ----------------- --- 3520,3525 ---- *************** package body Sem_Attr is *** 3356,3361 **** --- 3532,3622 ---- Check_Not_Incomplete_Type; Set_Etype (N, Universal_Integer); + --------- + -- Old -- + --------- + + when Attribute_Old => + Check_E0; + Set_Etype (N, P_Type); + + if No (Current_Subprogram) then + Error_Attr ("attribute % can only appear within subprogram", N); + end if; + + if Is_Limited_Type (P_Type) then + Error_Attr ("attribute % cannot apply to limited objects", P); + end if; + + if Is_Entity_Name (P) + and then Is_Constant_Object (Entity (P)) + then + Error_Msg_N + ("?attribute Old applied to constant has no effect", P); + end if; + + -- Check that the expression does not refer to local entities + + Check_Local : declare + Subp : Entity_Id := Current_Subprogram; + + function Process (N : Node_Id) return Traverse_Result; + -- Check that N does not contain references to local variables + -- or other local entities of Subp. + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + begin + if Is_Entity_Name (N) + and then not Is_Formal (Entity (N)) + and then Enclosing_Subprogram (Entity (N)) = Subp + then + Error_Msg_Node_1 := Entity (N); + Error_Attr + ("attribute % cannot refer to local variable&", N); + end if; + + return OK; + end Process; + + procedure Check_No_Local is new Traverse_Proc; + + -- Start of processing for Check_Local + + begin + Check_No_Local (P); + + if In_Parameter_Specification (P) then + + -- We have additional restrictions on using 'Old in parameter + -- specifications. + + if Present (Enclosing_Subprogram (Current_Subprogram)) then + + -- Check that there is no reference to the enclosing + -- subprogram local variables. Otherwise, we might end + -- up being called from the enclosing subprogram and thus + -- using 'Old on a local variable which is not defined + -- at entry time. + + Subp := Enclosing_Subprogram (Current_Subprogram); + Check_No_Local (P); + + else + -- We must prevent default expression of library-level + -- subprogram from using 'Old, as the subprogram may be + -- used in elaboration code for which there is no enclosing + -- subprogram. + + Error_Attr + ("attribute % can only appear within subprogram", N); + end if; + end if; + end Check_Local; + ------------ -- Output -- ------------ *************** package body Sem_Attr is *** 3370,3376 **** -- Partition_ID -- ------------------ ! when Attribute_Partition_ID => Check_E0; if P_Type /= Any_Type then --- 3631,3638 ---- -- Partition_ID -- ------------------ ! when Attribute_Partition_ID => Partition_Id : ! begin Check_E0; if P_Type /= Any_Type then *************** package body Sem_Attr is *** 3378,3386 **** Error_Attr_P ("prefix of % attribute must be library-level entity"); ! -- The defining entity of prefix should not be declared inside ! -- a Pure unit. RM E.1(8). ! -- The Is_Pure flag has been set during declaration. elsif Is_Entity_Name (P) and then Is_Pure (Entity (P)) --- 3640,3647 ---- Error_Attr_P ("prefix of % attribute must be library-level entity"); ! -- The defining entity of prefix should not be declared inside a ! -- Pure unit. RM E.1(8). Is_Pure was set during declaration. elsif Is_Entity_Name (P) and then Is_Pure (Entity (P)) *************** package body Sem_Attr is *** 3391,3396 **** --- 3652,3658 ---- end if; Set_Etype (N, Universal_Integer); + end Partition_Id; ------------------------- -- Passed_By_Reference -- *************** package body Sem_Attr is *** 3517,3527 **** --- 3779,3893 ---- ("(Ada 83) % attribute not allowed for scalar type", P); end if; + ------------ + -- Result -- + ------------ + + when Attribute_Result => Result : declare + CS : Entity_Id := Current_Scope; + PS : Entity_Id := Scope (CS); + + begin + -- If the enclosing subprogram is always inlined, the enclosing + -- postcondition will not be propagated to the expanded call. + + if Has_Pragma_Inline_Always (PS) + and then Warn_On_Redundant_Constructs + then + Error_Msg_N + ("postconditions on inlined functions not enforced?", N); + end if; + + -- If we are in the scope of a function and in Spec_Expression mode, + -- this is likely the prescan of the postcondition pragma, and we + -- just set the proper type. If there is an error it will be caught + -- when the real Analyze call is done. + + if Ekind (CS) = E_Function + and then In_Spec_Expression + then + -- Check OK prefix + + if Chars (CS) /= Chars (P) then + Error_Msg_NE + ("incorrect prefix for % attribute, expected &", P, CS); + Error_Attr; + end if; + + Set_Etype (N, Etype (CS)); + + -- If several functions with that name are visible, + -- the intended one is the current scope. + + if Is_Overloaded (P) then + Set_Entity (P, CS); + Set_Is_Overloaded (P, False); + end if; + + -- Body case, where we must be inside a generated _Postcondition + -- procedure, and the prefix must be on the scope stack, or else + -- the attribute use is definitely misplaced. The condition itself + -- may have generated transient scopes, and is not necessarily the + -- current one. + + else + while Present (CS) + and then CS /= Standard_Standard + loop + if Chars (CS) = Name_uPostconditions then + exit; + else + CS := Scope (CS); + end if; + end loop; + + PS := Scope (CS); + + if Chars (CS) = Name_uPostconditions + and then Ekind (PS) = E_Function + then + -- Check OK prefix + + if Nkind_In (P, N_Identifier, N_Operator_Symbol) + and then Chars (P) = Chars (PS) + then + null; + + -- Within an instance, the prefix designates the local renaming + -- of the original generic. + + elsif Is_Entity_Name (P) + and then Ekind (Entity (P)) = E_Function + and then Present (Alias (Entity (P))) + and then Chars (Alias (Entity (P))) = Chars (PS) + then + null; + + else + Error_Msg_NE + ("incorrect prefix for % attribute, expected &", P, PS); + Error_Attr; + end if; + + Rewrite (N, + Make_Identifier (Sloc (N), + Chars => Name_uResult)); + Analyze_And_Resolve (N, Etype (PS)); + + else + Error_Attr + ("% attribute can only appear" & + " in function Postcondition pragma", P); + end if; + end if; + end Result; + ------------------ -- Range_Length -- ------------------ when Attribute_Range_Length => + Check_E0; Check_Discrete_Type; Set_Etype (N, Universal_Integer); *************** package body Sem_Attr is *** 3534,3540 **** Check_Stream_Attribute (TSS_Stream_Read); Set_Etype (N, Standard_Void_Type); Resolve (N, Standard_Void_Type); ! Note_Possible_Modification (E2); --------------- -- Remainder -- --- 3900,3906 ---- Check_Stream_Attribute (TSS_Stream_Read); Set_Etype (N, Standard_Void_Type); Resolve (N, Standard_Void_Type); ! Note_Possible_Modification (E2, Sure => True); --------------- -- Remainder -- *************** package body Sem_Attr is *** 3654,3660 **** -- Size -- ---------- ! when Attribute_Size | Attribute_VADS_Size => Check_E0; -- If prefix is parameterless function call, rewrite and resolve --- 4020,4027 ---- -- Size -- ---------- ! when Attribute_Size | Attribute_VADS_Size => Size : ! begin Check_E0; -- If prefix is parameterless function call, rewrite and resolve *************** package body Sem_Attr is *** 3692,3698 **** --- 4059,4067 ---- end if; Check_Not_Incomplete_Type; + Check_Not_CPP_Type; Set_Etype (N, Universal_Integer); + end Size; ----------- -- Small -- *************** package body Sem_Attr is *** 3707,3716 **** -- Storage_Pool -- ------------------ ! when Attribute_Storage_Pool => ! if Is_Access_Type (P_Type) then ! Check_E0; if Ekind (P_Type) = E_Access_Subprogram_Type then Error_Attr_P ("cannot use % attribute for access-to-subprogram type"); --- 4076,4086 ---- -- Storage_Pool -- ------------------ ! when Attribute_Storage_Pool => Storage_Pool : ! begin ! Check_E0; + if Is_Access_Type (P_Type) then if Ekind (P_Type) = E_Access_Subprogram_Type then Error_Attr_P ("cannot use % attribute for access-to-subprogram type"); *************** package body Sem_Attr is *** 3735,3748 **** else Error_Attr_P ("prefix of % attribute must be access type"); end if; ------------------ -- Storage_Size -- ------------------ ! when Attribute_Storage_Size => if Is_Task_Type (P_Type) then - Check_E0; Set_Etype (N, Universal_Integer); elsif Is_Access_Type (P_Type) then --- 4105,4121 ---- else Error_Attr_P ("prefix of % attribute must be access type"); end if; + end Storage_Pool; ------------------ -- Storage_Size -- ------------------ ! when Attribute_Storage_Size => Storage_Size : ! begin ! Check_E0; ! if Is_Task_Type (P_Type) then Set_Etype (N, Universal_Integer); elsif Is_Access_Type (P_Type) then *************** package body Sem_Attr is *** 3754,3760 **** if Is_Entity_Name (P) and then Is_Type (Entity (P)) then - Check_E0; Check_Type; Set_Etype (N, Universal_Integer); --- 4127,4132 ---- *************** package body Sem_Attr is *** 3768,3774 **** -- of an access value designating a task. else - Check_E0; Check_Task_Prefix; Set_Etype (N, Universal_Integer); end if; --- 4140,4145 ---- *************** package body Sem_Attr is *** 3776,3781 **** --- 4147,4153 ---- else Error_Attr_P ("prefix of % attribute must be access or task type"); end if; + end Storage_Size; ------------------ -- Storage_Unit -- *************** package body Sem_Attr is *** 3845,3851 **** -- Tag -- --------- ! when Attribute_Tag => Check_E0; Check_Dereference; --- 4217,4224 ---- -- Tag -- --------- ! when Attribute_Tag => Tag : ! begin Check_E0; Check_Dereference; *************** package body Sem_Attr is *** 3875,3880 **** --- 4248,4254 ---- -- Set appropriate type Set_Etype (N, RTE (RE_Tag)); + end Tag; ----------------- -- Target_Name -- *************** package body Sem_Attr is *** 3886,3892 **** begin Check_Standard_Prefix; - Check_E0; TL := TN'Last; --- 4260,4265 ---- *************** package body Sem_Attr is *** 3927,3932 **** --- 4300,4314 ---- Analyze_And_Resolve (E1, Any_Integer); Set_Etype (N, RTE (RE_Address)); + ------------ + -- To_Any -- + ------------ + + when Attribute_To_Any => + Check_E1; + Check_PolyORB_Attribute; + Set_Etype (N, RTE (RE_Any)); + ---------------- -- Truncation -- ---------------- *************** package body Sem_Attr is *** 3946,3951 **** --- 4328,4342 ---- Check_Not_Incomplete_Type; Set_Etype (N, RTE (RE_Type_Class)); + ------------ + -- To_Any -- + ------------ + + when Attribute_TypeCode => + Check_E0; + Check_PolyORB_Attribute; + Set_Etype (N, RTE (RE_TypeCode)); + ----------------- -- UET_Address -- ----------------- *************** package body Sem_Attr is *** 4022,4030 **** Negative := False; end if; ! if Nkind (Expr) /= N_Integer_Literal ! and then Nkind (Expr) /= N_Real_Literal ! then Error_Attr ("named number for % attribute must be simple literal", N); end if; --- 4413,4419 ---- Negative := False; end if; ! if not Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then Error_Attr ("named number for % attribute must be simple literal", N); end if; *************** package body Sem_Attr is *** 4957,4962 **** --- 5346,5352 ---- -- subtype then get the type from the initial value. If the value has -- been expanded into assignments, there is no expression and the -- attribute reference remains dynamic. + -- We could do better here and retrieve the type ??? if Ekind (P_Entity) = E_Constant *************** package body Sem_Attr is *** 4972,4978 **** -- Definite must be folded if the prefix is not a generic type, -- that is to say if we are within an instantiation. Same processing -- applies to the GNAT attributes Has_Discriminants, Type_Class, ! -- and Unconstrained_Array. elsif (Id = Attribute_Definite or else --- 5362,5368 ---- -- Definite must be folded if the prefix is not a generic type, -- that is to say if we are within an instantiation. Same processing -- applies to the GNAT attributes Has_Discriminants, Type_Class, ! -- Has_Tagged_Value, and Unconstrained_Array. elsif (Id = Attribute_Definite or else *************** package body Sem_Attr is *** 4980,4985 **** --- 5370,5377 ---- or else Id = Attribute_Has_Discriminants or else + Id = Attribute_Has_Tagged_Values + or else Id = Attribute_Type_Class or else Id = Attribute_Unconstrained_Array) *************** package body Sem_Attr is *** 4987,4998 **** then P_Type := P_Entity; ! -- We can fold 'Size applied to a type if the size is known ! -- (as happens for a size from an attribute definition clause). ! -- At this stage, this can happen only for types (e.g. record ! -- types) for which the size is always non-static. We exclude ! -- generic types from consideration (since they have bogus ! -- sizes set within templates). elsif Id = Attribute_Size and then Is_Type (P_Entity) --- 5379,5389 ---- then P_Type := P_Entity; ! -- We can fold 'Size applied to a type if the size is known (as happens ! -- for a size from an attribute definition clause). At this stage, this ! -- can happen only for types (e.g. record types) for which the size is ! -- always non-static. We exclude generic types from consideration (since ! -- they have bogus sizes set within templates). elsif Id = Attribute_Size and then Is_Type (P_Entity) *************** package body Sem_Attr is *** 5083,5091 **** -- since we can't do anything with unconstrained arrays. In addition, -- only the First, Last and Length attributes are possibly static. ! -- Definite, Has_Access_Values, Has_Discriminants, Type_Class, and ! -- Unconstrained_Array are again exceptions, because they apply as ! -- well to unconstrained types. -- In addition Component_Size is an exception since it is possibly -- foldable, even though it is never static, and it does apply to --- 5474,5482 ---- -- since we can't do anything with unconstrained arrays. In addition, -- only the First, Last and Length attributes are possibly static. ! -- Definite, Has_Access_Values, Has_Discriminants, Has_Tagged_Values, ! -- Type_Class, and Unconstrained_Array are again exceptions, because ! -- they apply as well to unconstrained types. -- In addition Component_Size is an exception since it is possibly -- foldable, even though it is never static, and it does apply to *************** package body Sem_Attr is *** 5098,5103 **** --- 5489,5496 ---- or else Id = Attribute_Has_Discriminants or else + Id = Attribute_Has_Tagged_Values + or else Id = Attribute_Type_Class or else Id = Attribute_Unconstrained_Array *************** package body Sem_Attr is *** 5347,5353 **** ----------------- -- Constrained is never folded for now, there may be cases that ! -- could be handled at compile time. to be looked at later. when Attribute_Constrained => null; --- 5740,5746 ---- ----------------- -- Constrained is never folded for now, there may be cases that ! -- could be handled at compile time. To be looked at later. when Attribute_Constrained => null; *************** package body Sem_Attr is *** 5430,5435 **** --- 5823,5858 ---- Fold_Uint (N, Expr_Value (E1), Static); end if; + -------------- + -- Enum_Val -- + -------------- + + when Attribute_Enum_Val => Enum_Val : declare + Lit : Node_Id; + + begin + -- We have something like Enum_Type'Enum_Val (23), so search for a + -- corresponding value in the list of Enum_Rep values for the type. + + Lit := First_Literal (P_Base_Type); + loop + if Enumeration_Rep (Lit) = Expr_Value (E1) then + Fold_Uint (N, Enumeration_Pos (Lit), Static); + exit; + end if; + + Next_Literal (Lit); + + if No (Lit) then + Apply_Compile_Time_Constraint_Error + (N, "no representation value matches", + CE_Range_Check_Failed, + Warn => not Static); + exit; + end if; + end loop; + end Enum_Val; + ------------- -- Epsilon -- ------------- *************** package body Sem_Attr is *** 5517,5522 **** --- 5940,5954 ---- Boolean_Literals (Has_Discriminants (P_Entity)), Loc)); Analyze_And_Resolve (N, Standard_Boolean); + ----------------------- + -- Has_Tagged_Values -- + ----------------------- + + when Attribute_Has_Tagged_Values => + Rewrite (N, New_Occurrence_Of + (Boolean_Literals (Has_Tagged_Component (P_Root_Type)), Loc)); + Analyze_And_Resolve (N, Standard_Boolean); + -------------- -- Identity -- -------------- *************** package body Sem_Attr is *** 5568,5576 **** --- 6000,6020 ---- -- Integer_Value -- ------------------- + -- We never try to fold Integer_Value (though perhaps we could???) + when Attribute_Integer_Value => null; + ------------------- + -- Invalid_Value -- + ------------------- + + -- Invalid_Value is a scalar attribute that is never static, because + -- the value is by design out of range. + + when Attribute_Invalid_Value => + null; + ----------- -- Large -- ----------- *************** package body Sem_Attr is *** 6407,6413 **** when Attribute_Small => ! -- The floating-point case is present only for Ada 83 compatability. -- Note that strictly this is an illegal addition, since we are -- extending an Ada 95 defined attribute, but we anticipate an -- ARG ruling that will permit this. --- 6851,6857 ---- when Attribute_Small => ! -- The floating-point case is present only for Ada 83 compatibility. -- Note that strictly this is an illegal addition, since we are -- extending an Ada 95 defined attribute, but we anticipate an -- ARG ruling that will permit this. *************** package body Sem_Attr is *** 6533,6539 **** -- We treat protected types like task types. It would make more -- sense to have another enumeration value, but after all the -- whole point of this feature is to be exactly DEC compatible, ! -- and changing the type Type_Clas would not meet this requirement. elsif Is_Protected_Type (Typ) then Id := RE_Type_Class_Task; --- 6977,6983 ---- -- We treat protected types like task types. It would make more -- sense to have another enumeration value, but after all the -- whole point of this feature is to be exactly DEC compatible, ! -- and changing the type Type_Class would not meet this requirement. elsif Is_Protected_Type (Typ) then Id := RE_Type_Class_Task; *************** package body Sem_Attr is *** 6738,6747 **** else declare R : constant Entity_Id := Root_Type (P_Type); ! Lo : constant Uint := ! Expr_Value (Type_Low_Bound (P_Type)); ! Hi : constant Uint := ! Expr_Value (Type_High_Bound (P_Type)); W : Nat; Wt : Nat; T : Uint; --- 7182,7189 ---- else declare R : constant Entity_Id := Root_Type (P_Type); ! Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type)); ! Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type)); W : Nat; Wt : Nat; T : Uint; *************** package body Sem_Attr is *** 6757,6766 **** -- Width for types derived from Standard.Character -- and Standard.Wide_[Wide_]Character. ! elsif R = Standard_Character ! or else R = Standard_Wide_Character ! or else R = Standard_Wide_Wide_Character ! then W := 0; -- Set W larger if needed --- 7199,7205 ---- -- Width for types derived from Standard.Character -- and Standard.Wide_[Wide_]Character. ! elsif Is_Standard_Character_Type (P_Type) then W := 0; -- Set W larger if needed *************** package body Sem_Attr is *** 6894,6899 **** --- 7333,7345 ---- end if; end Width; + -- The following attributes denote function that cannot be folded + + when Attribute_From_Any | + Attribute_To_Any | + Attribute_TypeCode => + null; + -- The following attributes can never be folded, and furthermore we -- should not even have entered the case statement for any of these. -- Note that in some cases, the values have already been folded as *************** package body Sem_Attr is *** 6924,6935 **** --- 7370,7383 ---- Attribute_Input | Attribute_Last_Bit | Attribute_Maximum_Alignment | + Attribute_Old | Attribute_Output | Attribute_Partition_ID | Attribute_Pool_Address | Attribute_Position | Attribute_Priority | Attribute_Read | + Attribute_Result | Attribute_Storage_Pool | Attribute_Storage_Size | Attribute_Storage_Unit | *************** package body Sem_Attr is *** 6961,6970 **** -- An exception is the GNAT attribute Constrained_Array which is -- defined to be a static attribute in all cases. ! if Nkind (N) = N_Integer_Literal ! or else Nkind (N) = N_Real_Literal ! or else Nkind (N) = N_Character_Literal ! or else Nkind (N) = N_String_Literal or else (Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Enumeration_Literal) then --- 7409,7418 ---- -- An exception is the GNAT attribute Constrained_Array which is -- defined to be a static attribute in all cases. ! if Nkind_In (N, N_Integer_Literal, ! N_Real_Literal, ! N_Character_Literal, ! N_String_Literal) or else (Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Enumeration_Literal) then *************** package body Sem_Attr is *** 7060,7068 **** if Is_Record_Type (Current_Scope) and then ! (Nkind (Parent (N)) = N_Discriminant_Association ! or else ! Nkind (Parent (N)) = N_Index_Or_Discriminant_Constraint) then Indic := Parent (Parent (N)); while Present (Indic) --- 7508,7515 ---- if Is_Record_Type (Current_Scope) and then ! Nkind_In (Parent (N), N_Discriminant_Association, ! N_Index_Or_Discriminant_Constraint) then Indic := Parent (Parent (N)); while Present (Indic) *************** package body Sem_Attr is *** 7122,7130 **** | Attribute_Unchecked_Access | Attribute_Unrestricted_Access => ! Access_Attribute : begin if Is_Variable (P) then ! Note_Possible_Modification (P); end if; if Is_Entity_Name (P) then --- 7569,7591 ---- | Attribute_Unchecked_Access | Attribute_Unrestricted_Access => ! Access_Attribute : ! begin if Is_Variable (P) then ! Note_Possible_Modification (P, Sure => False); ! end if; ! ! -- The following comes from a query by Adam Beneschan, concerning ! -- improper use of universal_access in equality tests involving ! -- anonymous access types. Another good reason for 'Ref, but ! -- for now disable the test, which breaks several filed tests. ! ! if Ekind (Typ) = E_Anonymous_Access_Type ! and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne) ! and then False ! then ! Error_Msg_N ("need unique type to resolve 'Access", N); ! Error_Msg_N ("\qualify attribute with some access type", N); end if; if Is_Entity_Name (P) then *************** package body Sem_Attr is *** 7154,7160 **** -- If it is an object, complete its resolution. elsif Is_Overloadable (Entity (P)) then ! if not In_Default_Expression then Insert_Actions (N, Freeze_Entity (Entity (P), Loc)); end if; --- 7615,7624 ---- -- If it is an object, complete its resolution. elsif Is_Overloadable (Entity (P)) then ! ! -- Avoid insertion of freeze actions in spec expression mode ! ! if not In_Spec_Expression then Insert_Actions (N, Freeze_Entity (Entity (P), Loc)); end if; *************** package body Sem_Attr is *** 7255,7261 **** -- that generic unit. This includes any such attribute that -- occurs within the body of a generic unit that is a child -- of the generic unit where the subprogram is declared. ! -- The rule also prohibits applying the attibute when the -- access type is a generic formal access type (since the -- level of the actual type is not known). This restriction -- does not apply when the attribute type is an anonymous --- 7719,7725 ---- -- that generic unit. This includes any such attribute that -- occurs within the body of a generic unit that is a child -- of the generic unit where the subprogram is declared. ! -- The rule also prohibits applying the attribute when the -- access type is a generic formal access type (since the -- level of the actual type is not known). This restriction -- does not apply when the attribute type is an anonymous *************** package body Sem_Attr is *** 7712,7718 **** -- it may be modified via this address, so note modification. if Is_Variable (P) then ! Note_Possible_Modification (P); end if; if Nkind (P) in N_Subexpr --- 8176,8182 ---- -- it may be modified via this address, so note modification. if Is_Variable (P) then ! Note_Possible_Modification (P, Sure => False); end if; if Nkind (P) in N_Subexpr *************** package body Sem_Attr is *** 7752,7757 **** --- 8216,8285 ---- if Is_Entity_Name (P) then Set_Address_Taken (Entity (P)); end if; + + if Nkind (P) = N_Slice then + + -- Arr (X .. Y)'address is identical to Arr (X)'address, + -- even if the array is packed and the slice itself is not + -- addressable. Transform the prefix into an indexed component. + + -- Note that the transformation is safe only if we know that + -- the slice is non-null. That is because a null slice can have + -- an out of bounds index value. + + -- Right now, gigi blows up if given 'Address on a slice as a + -- result of some incorrect freeze nodes generated by the front + -- end, and this covers up that bug in one case, but the bug is + -- likely still there in the cases not handled by this code ??? + + -- It's not clear what 'Address *should* return for a null + -- slice with out of bounds indexes, this might be worth an ARG + -- discussion ??? + + -- One approach would be to do a length check unconditionally, + -- and then do the transformation below unconditionally, but + -- analyze with checks off, avoiding the problem of the out of + -- bounds index. This approach would interpret the address of + -- an out of bounds null slice as being the address where the + -- array element would be if there was one, which is probably + -- as reasonable an interpretation as any ??? + + declare + Loc : constant Source_Ptr := Sloc (P); + D : constant Node_Id := Discrete_Range (P); + Lo : Node_Id; + + begin + if Is_Entity_Name (D) + and then + Not_Null_Range + (Type_Low_Bound (Entity (D)), + Type_High_Bound (Entity (D))) + then + Lo := + Make_Attribute_Reference (Loc, + Prefix => (New_Occurrence_Of (Entity (D), Loc)), + Attribute_Name => Name_First); + + elsif Nkind (D) = N_Range + and then Not_Null_Range (Low_Bound (D), High_Bound (D)) + then + Lo := Low_Bound (D); + + else + Lo := Empty; + end if; + + if Present (Lo) then + Rewrite (P, + Make_Indexed_Component (Loc, + Prefix => Relocate_Node (Prefix (P)), + Expressions => New_List (Lo))); + + Analyze_And_Resolve (P); + end if; + end; + end if; end Address_Attribute; --------------- *************** package body Sem_Attr is *** 7879,7913 **** LB : Node_Id; HB : Node_Id; - function Check_Discriminated_Prival - (N : Node_Id) - return Node_Id; - -- The range of a private component constrained by a - -- discriminant is rewritten to make the discriminant - -- explicit. This solves some complex visibility problems - -- related to the use of privals. - - -------------------------------- - -- Check_Discriminated_Prival -- - -------------------------------- - - function Check_Discriminated_Prival - (N : Node_Id) - return Node_Id - is - begin - if Is_Entity_Name (N) - and then Ekind (Entity (N)) = E_In_Parameter - and then not Within_Init_Proc - then - return Make_Identifier (Sloc (N), Chars (Entity (N))); - else - return Duplicate_Subexpr (N); - end if; - end Check_Discriminated_Prival; - - -- Start of processing for Range_Attribute - begin if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) --- 8407,8412 ---- *************** package body Sem_Attr is *** 7915,7953 **** Resolve (P); end if; ! -- Check whether prefix is (renaming of) private component ! -- of protected type. ! ! if Is_Entity_Name (P) ! and then Comes_From_Source (N) ! and then Is_Array_Type (Etype (P)) ! and then Number_Dimensions (Etype (P)) = 1 ! and then (Ekind (Scope (Entity (P))) = E_Protected_Type ! or else ! Ekind (Scope (Scope (Entity (P)))) = ! E_Protected_Type) ! then ! LB := ! Check_Discriminated_Prival ! (Type_Low_Bound (Etype (First_Index (Etype (P))))); ! ! HB := ! Check_Discriminated_Prival ! (Type_High_Bound (Etype (First_Index (Etype (P))))); ! ! else ! HB := ! Make_Attribute_Reference (Loc, ! Prefix => Duplicate_Subexpr (P), ! Attribute_Name => Name_Last, ! Expressions => Expressions (N)); ! LB := ! Make_Attribute_Reference (Loc, ! Prefix => P, ! Attribute_Name => Name_First, ! Expressions => Expressions (N)); ! end if; -- If the original was marked as Must_Not_Freeze (see code -- in Sem_Ch3.Make_Index), then make sure the rewriting --- 8414,8431 ---- Resolve (P); end if; ! HB := ! Make_Attribute_Reference (Loc, ! Prefix => ! Duplicate_Subexpr (P, Name_Req => True), ! Attribute_Name => Name_Last, ! Expressions => Expressions (N)); ! LB := ! Make_Attribute_Reference (Loc, ! Prefix => P, ! Attribute_Name => Name_First, ! Expressions => Expressions (N)); -- If the original was marked as Must_Not_Freeze (see code -- in Sem_Ch3.Make_Index), then make sure the rewriting *************** package body Sem_Attr is *** 7983,7988 **** --- 8461,8477 ---- return; end Range_Attribute; + ------------ + -- Result -- + ------------ + + -- We will only come here during the prescan of a spec expression + -- containing a Result attribute. In that case the proper Etype has + -- already been set, and nothing more needs to be done here. + + when Attribute_Result => + null; + ----------------- -- UET_Address -- ----------------- diff -Nrcpad gcc-4.3.3/gcc/ada/sem_attr.ads gcc-4.4.0/gcc/ada/sem_attr.ads *** gcc-4.3.3/gcc/ada/sem_attr.ads Wed Nov 28 20:44:58 2007 --- gcc-4.4.0/gcc/ada/sem_attr.ads Thu Apr 9 23:23:07 2009 *************** *** 6,23 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,23 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- ! -- -- ! -- You should have received a copy of the GNU General Public License along -- ! -- with this program; see file COPYING3. If not see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Sem_Attr is *** 210,215 **** --- 210,230 ---- -- absence of an enumeration representation clause. This is a static -- attribute (i.e. the result is static if the argument is static). + -------------- + -- Enum_Val -- + -------------- + + Attribute_Enum_Val => True, + -- For every enumeration subtype S, S'Enum_Val denotes a function + -- with the following specification: + -- + -- function S'Enum_Val (Arg : universal_integer) return S'Base; + -- + -- This function performs the inverse transformation to Enum_Rep. Given + -- a representation value for the type, it returns the corresponding + -- enumeration value. Constraint_Error is raised if no value of the + -- enumeration type corresponds to the given integer value. + ----------------- -- Fixed_Value -- ----------------- *************** package Sem_Attr is *** 276,281 **** --- 291,306 ---- -- attribute is primarily intended for use in implementation of the -- standard input-output functions for fixed-point values. + Attribute_Invalid_Value => True, + -- For every scalar type, S'Invalid_Value designates an undefined value + -- of the type. If possible this value is an invalid value, and in fact + -- is identical to the value that would be set if Initialize_Scalars + -- mode were in effect (including the behavior of its value on + -- environment variables or binder switches). The intended use is + -- to set a value where initialization is required (e.g. as a result of + -- the coding standards in use), but logically no initialization is + -- needed, and the value should never be accessed. + ------------------ -- Machine_Size -- ------------------ *************** package Sem_Attr is *** 301,307 **** -------------------- Attribute_Mechanism_Code => True, ! -- function'Mechanism_Code yeilds an integer code for the mechanism -- used for the result of function, and subprogram'Mechanism_Code (n) -- yields the mechanism used for formal parameter number n (a static -- integer value, 1 = first parameter). The code returned is: --- 326,332 ---- -------------------- Attribute_Mechanism_Code => True, ! -- function'Mechanism_Code yields an integer code for the mechanism -- used for the result of function, and subprogram'Mechanism_Code (n) -- yields the mechanism used for formal parameter number n (a static -- integer value, 1 = first parameter). The code returned is: *************** package Sem_Attr is *** 325,331 **** -- A reference T'Null_Parameter denotes an (imaginary) object of type or -- subtype T allocated at (machine) address zero. The attribute is -- allowed only as the default expression of a formal parameter, or as ! -- an actual expression of a subporgram call. In either case, the -- subprogram must be imported. -- -- The identity of the object is represented by the address zero in the --- 350,356 ---- -- A reference T'Null_Parameter denotes an (imaginary) object of type or -- subtype T allocated at (machine) address zero. The attribute is -- allowed only as the default expression of a formal parameter, or as ! -- an actual expression of a subprogram call. In either case, the -- subprogram must be imported. -- -- The identity of the object is represented by the address zero in the *************** package Sem_Attr is *** 421,427 **** -- to convert this to an address using the same semantics as the -- System.Storage_Elements.To_Address function. The important difference -- is that this is a static attribute so it can be used in ! -- initializations in preealborate packages. ---------------- -- Type_Class -- --- 446,452 ---- -- to convert this to an address using the same semantics as the -- System.Storage_Elements.To_Address function. The important difference -- is that this is a static attribute so it can be used in ! -- initializations in preelaborate packages. ---------------- -- Type_Class -- diff -Nrcpad gcc-4.3.3/gcc/ada/sem_aux.adb gcc-4.4.0/gcc/ada/sem_aux.adb *** gcc-4.3.3/gcc/ada/sem_aux.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/sem_aux.adb Tue Apr 8 06:45:25 2008 *************** *** 0 **** --- 1,62 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S E M _ A U X -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1992-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package body Sem_Aux is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Obsolescent_Warnings.Init; + end Initialize; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Obsolescent_Warnings.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Obsolescent_Warnings.Tree_Write; + end Tree_Write; + + end Sem_Aux; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_aux.ads gcc-4.4.0/gcc/ada/sem_aux.ads *** gcc-4.3.3/gcc/ada/sem_aux.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/sem_aux.ads Tue Apr 8 06:45:25 2008 *************** *** 0 **** --- 1,86 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S E M _ A U X -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 1992-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- Package containing utility procedures used throughout the compiler, + -- and also by ASIS so dependencies are limited to ASIS included packages. + + -- Note: contents are minimal for now, the intent is to move stuff from + -- Sem_Util that meets the ASIS dependency requirements, and also stuff + -- from Einfo, where Einfo had excessive semantic knowledge of the tree. + + with Alloc; use Alloc; + with Table; + with Types; use Types; + + package Sem_Aux is + + -------------------------------- + -- Obsolescent Warnings Table -- + -------------------------------- + + -- This table records entities for which a pragma Obsolescent with a + -- message argument has been processed. + + type OWT_Record is record + Ent : Entity_Id; + -- The entity to which the pragma applies + + Msg : String_Id; + -- The string containing the message + end record; + + package Obsolescent_Warnings is new Table.Table ( + Table_Component_Type => OWT_Record, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Obsolescent_Warnings_Initial, + Table_Increment => Alloc.Obsolescent_Warnings_Increment, + Table_Name => "Obsolescent_Warnings"); + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Called at the start of compilation of each new main source file to + -- initialize the allocation of the Obsolescent_Warnings table. Note that + -- Initialize must not be called if Tree_Read is used. + + procedure Tree_Read; + -- Initializes internal tables from current tree file using the relevant + -- Table.Tree_Read routines. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using the relevant + -- Table.Tree_Write routines. + + end Sem_Aux; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_case.adb gcc-4.4.0/gcc/ada/sem_case.adb *** gcc-4.3.3/gcc/ada/sem_case.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/sem_case.adb Sun Apr 13 17:25:22 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2008, 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- -- *************** package body Sem_Case is *** 52,58 **** type Sort_Choice_Table_Type is array (Nat range <>) of Choice_Bounds; -- This new array type is used as the actual table type for sorting -- discrete choices. The reason for not using Choice_Table_Type, is that ! -- in Sort_Choice_Table_Type we reserve entry 0 for the sorting algortim -- (this is not absolutely necessary but it makes the code more -- efficient). --- 52,58 ---- type Sort_Choice_Table_Type is array (Nat range <>) of Choice_Bounds; -- This new array type is used as the actual table type for sorting -- discrete choices. The reason for not using Choice_Table_Type, is that ! -- in Sort_Choice_Table_Type we reserve entry 0 for the sorting algorithm -- (this is not absolutely necessary but it makes the code more -- efficient). *************** package body Sem_Case is *** 268,277 **** -- For character, or wide [wide] character. If 7-bit ASCII graphic -- range, then build and return appropriate character literal name ! if Rtp = Standard_Character ! or else Rtp = Standard_Wide_Character ! or else Rtp = Standard_Wide_Wide_Character ! then C := UI_To_Int (Value); if C in 16#20# .. 16#7E# then --- 268,274 ---- -- For character, or wide [wide] character. If 7-bit ASCII graphic -- range, then build and return appropriate character literal name ! if Is_Standard_Character_Type (Ctype) then C := UI_To_Int (Value); if C in 16#20# .. 16#7E# then *************** package body Sem_Case is *** 425,436 **** -- of literals to search. Instead, a N_Character_Literal node -- is created with the appropriate Char_Code and Chars fields. ! if Root_Type (Choice_Type) = Standard_Character ! or else ! Root_Type (Choice_Type) = Standard_Wide_Character ! or else ! Root_Type (Choice_Type) = Standard_Wide_Wide_Character ! then Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); Lit := New_Node (N_Character_Literal, Loc); Set_Chars (Lit, Name_Find); --- 422,428 ---- -- of literals to search. Instead, a N_Character_Literal node -- is created with the appropriate Char_Code and Chars fields. ! if Is_Standard_Character_Type (Choice_Type) then Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); Lit := New_Node (N_Character_Literal, Loc); Set_Chars (Lit, Name_Find); diff -Nrcpad gcc-4.3.3/gcc/ada/sem_case.ads gcc-4.4.0/gcc/ada/sem_case.ads *** gcc-4.3.3/gcc/ada/sem_case.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_case.ads Sun Apr 13 17:25:22 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2008, 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- -- *************** package Sem_Case is *** 46,52 **** procedure No_OP (C : Node_Id); -- The no-operation routine. Does absolutely nothing. Can be used ! -- in the following generic for the parameter Proces_Empty_Choice. generic with function Get_Alternatives (N : Node_Id) return List_Id; --- 46,52 ---- procedure No_OP (C : Node_Id); -- The no-operation routine. Does absolutely nothing. Can be used ! -- in the following generic for the parameter Process_Empty_Choice. generic with function Get_Alternatives (N : Node_Id) return List_Id; *************** package Sem_Case is *** 54,60 **** -- alternatives, or array aggregate component associations or -- record variants from which we can then access the actual lists -- of discrete choices. N is the node for the original construct ! -- ie a case statement, an array aggregate or a record variant. with function Get_Choices (A : Node_Id) return List_Id; -- Given a case statement alternative, array aggregate component --- 54,60 ---- -- alternatives, or array aggregate component associations or -- record variants from which we can then access the actual lists -- of discrete choices. N is the node for the original construct ! -- i.e. a case statement, an array aggregate or a record variant. with function Get_Choices (A : Node_Id) return List_Id; -- Given a case statement alternative, array aggregate component diff -Nrcpad gcc-4.3.3/gcc/ada/sem_cat.adb gcc-4.4.0/gcc/ada/sem_cat.adb *** gcc-4.3.3/gcc/ada/sem_cat.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_cat.adb Mon Aug 18 08:59:47 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Debug; use Debug; *** 28,33 **** --- 28,34 ---- with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; + with Exp_Disp; use Exp_Disp; with Fname; use Fname; with Lib; use Lib; with Namet; use Namet; *************** package body Sem_Cat is *** 75,81 **** -- at any place. function In_RCI_Declaration (N : Node_Id) return Boolean; ! -- Determines if a declaration is within the visible part of a Remote -- Call Interface compilation unit, for semantic checking purposes only, -- (returns false within an instance and within the package body). --- 76,82 ---- -- at any place. function In_RCI_Declaration (N : Node_Id) return Boolean; ! -- Determines if a declaration is within the visible part of a Remote -- Call Interface compilation unit, for semantic checking purposes only, -- (returns false within an instance and within the package body). *************** package body Sem_Cat is *** 97,111 **** procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id); -- Check validity of declaration if RCI or RT unit. It should not contain ! -- the declaration of an access-to-object type unless it is a ! -- general access type that designates a class-wide limited ! -- private type. There are also constraints about the primitive ! -- subprograms of the class-wide type. RM E.2 (9, 13, 14) ! ! function Is_Recursively_Limited_Private (E : Entity_Id) return Boolean; ! -- Return True if E is a limited private type, or if E is a private ! -- extension of a type whose parent verifies this property (hence the ! -- recursive keyword). --------------------------------------- -- Check_Categorization_Dependencies -- --- 98,107 ---- procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id); -- Check validity of declaration if RCI or RT unit. It should not contain ! -- the declaration of an access-to-object type unless it is a general ! -- access type that designates a class-wide limited private type. There are ! -- also constraints about the primitive subprograms of the class-wide type. ! -- RM E.2 (9, 13, 14) --------------------------------------- -- Check_Categorization_Dependencies -- *************** package body Sem_Cat is *** 150,156 **** -- to apply to the same library unit, in which case the unit has -- all associated categories, so we need to be careful here to -- check pragmas in proper Categorization order in order to ! -- return the lowest appplicable value. -- Ignore Pure specification if set by pragma Pure_Function --- 146,152 ---- -- to apply to the same library unit, in which case the unit has -- all associated categories, so we need to be careful here to -- check pragmas in proper Categorization order in order to ! -- return the lowest applicable value. -- Ignore Pure specification if set by pragma Pure_Function *************** package body Sem_Cat is *** 193,199 **** Unit_Category := Get_Categorization (Unit_Entity); With_Category := Get_Categorization (Depended_Entity); ! -- These messages are wanings in GNAT mode, to allow it to be -- judiciously turned off. Otherwise it is a real error. Error_Msg_Warn := GNAT_Mode; --- 189,195 ---- Unit_Category := Get_Categorization (Unit_Entity); With_Category := Get_Categorization (Depended_Entity); ! -- These messages are warnings in GNAT mode, to allow it to be -- judiciously turned off. Otherwise it is a real error. Error_Msg_Warn := GNAT_Mode; *************** package body Sem_Cat is *** 214,224 **** -- Here we have an error else ! if Is_Subunit then Error_Msg_NE ("> --- 1407,1428 ---- or else No (TSS (Param_Type, TSS_Stream_Write)) then ! Illegal_RACW ("limited formal must have Read and Write attributes", Param_Spec); Explain_Limited_Type (Param_Type, Param_Spec); end if; + + elsif Missing_Read_Write_Attributes (Param_Type) + and then not Error_Posted (Param_Type) + then + Illegal_RACW ("parameter containing non-remote access " + & "must have Read and Write attributes", Param_Spec); end if; -- Check next parameter in this subprogram ! Next_Formal (Param); end loop; <> *************** package body Sem_Cat is *** 1464,1475 **** Error_Node : Node_Id := N; begin ! -- There are two possible cases in which this procedure is called: ! -- 1. called from Analyze_Subprogram_Declaration. ! -- 2. called from Validate_Object_Declaration (access to subprogram). ! if not In_RCI_Declaration (N) then return; end if; --- 1499,1512 ---- Error_Node : Node_Id := N; begin ! -- This procedure enforces rules on subprogram and access to subprogram ! -- declarations in RCI units. These rules do not apply to expander ! -- generated routines, which are not remote subprograms. It is called: ! -- 1. from Analyze_Subprogram_Declaration. ! -- 2. from Validate_Object_Declaration (access to subprogram). ! if not (Comes_From_Source (N) and then In_RCI_Declaration (N)) then return; end if; *************** package body Sem_Cat is *** 1477,1482 **** --- 1514,1524 ---- Profile := Parameter_Specifications (Specification (N)); else pragma Assert (K = N_Object_Declaration); + + -- The above assertion is dubious, the visible declarations of an + -- RCI unit never contain an object declaration, this should be an + -- ACCESS-to-object declaration??? + Id := Defining_Identifier (N); if Nkind (Id) = N_Defining_Identifier *************** package body Sem_Cat is *** 1492,1498 **** -- Iterate through the parameter specification list, checking that -- no access parameter and no limited type parameter in the list. ! -- RM E.2.3 (14) if Present (Profile) then Param_Spec := First (Profile); --- 1534,1540 ---- -- Iterate through the parameter specification list, checking that -- no access parameter and no limited type parameter in the list. ! -- RM E.2.3(14). if Present (Profile) then Param_Spec := First (Profile); *************** package body Sem_Cat is *** 1512,1524 **** (Defining_Entity (Specification (N))) then Error_Msg_N ! ("subprogram in rci unit cannot have access parameter", Error_Node); end if; ! -- For limited private type parameter, we check only the private -- declaration and ignore full type declaration, unless this is ! -- the only declaration for the type, eg. as a limited record. elsif Is_Limited_Type (Param_Type) and then (Nkind (Type_Decl) = N_Private_Type_Declaration --- 1554,1566 ---- (Defining_Entity (Specification (N))) then Error_Msg_N ! ("subprogram in 'R'C'I unit cannot have access parameter", Error_Node); end if; ! -- For a limited private type parameter, we check only the private -- declaration and ignore full type declaration, unless this is ! -- the only declaration for the type, e.g., as a limited record. elsif Is_Limited_Type (Param_Type) and then (Nkind (Type_Decl) = N_Private_Type_Declaration *************** package body Sem_Cat is *** 1533,1539 **** if No (Full_View (Param_Type)) and then Ekind (Param_Type) /= E_Record_Type then ! -- Type does not have completion yet, so if declared in in -- the current RCI scope it is illegal, and will be flagged -- subsequently. --- 1575,1581 ---- if No (Full_View (Param_Type)) and then Ekind (Param_Type) /= E_Record_Type then ! -- Type does not have completion yet, so if declared in -- the current RCI scope it is illegal, and will be flagged -- subsequently. *************** package body Sem_Cat is *** 1549,1555 **** -- contract model for privacy, but we support both semantics -- for now for compatibility (note that ACATS test BXE2009 -- checks a case that conforms to the Ada 95 rules but is ! -- illegal in Ada 2005). Base_Param_Type := Base_Type (Param_Type); Base_Under_Type := Base_Type (Underlying_Type --- 1591,1601 ---- -- contract model for privacy, but we support both semantics -- for now for compatibility (note that ACATS test BXE2009 -- checks a case that conforms to the Ada 95 rules but is ! -- illegal in Ada 2005). In the Ada 2005 case we check for the ! -- possibilities of visible TSS stream subprograms or explicit ! -- stream attribute definitions because the TSS subprograms ! -- can be hidden in the private part while the attribute ! -- definitions are still be available from the visible part. Base_Param_Type := Base_Type (Param_Type); Base_Under_Type := Base_Type (Underlying_Type *************** package body Sem_Cat is *** 1573,1579 **** or else Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Read)) or else ! Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Write)))) then if K = N_Subprogram_Declaration then Error_Node := Param_Spec; --- 1619,1631 ---- or else Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Read)) or else ! Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Write))) ! and then ! (not Has_Stream_Attribute_Definition ! (Base_Param_Type, TSS_Stream_Read) ! or else ! not Has_Stream_Attribute_Definition ! (Base_Param_Type, TSS_Stream_Write))) then if K = N_Subprogram_Declaration then Error_Node := Param_Spec; *************** package body Sem_Cat is *** 1581,1601 **** if Ada_Version >= Ada_05 then Error_Msg_N ! ("limited parameter in rci unit " & "must have visible read/write attributes ", Error_Node); else Error_Msg_N ! ("limited parameter in rci unit " & "must have read/write attributes ", Error_Node); end if; Explain_Limited_Type (Param_Type, Error_Node); end if; - end if; Next (Param_Spec); end loop; end if; end Validate_RCI_Subprogram_Declaration; --- 1633,1680 ---- if Ada_Version >= Ada_05 then Error_Msg_N ! ("limited parameter in 'R'C'I unit " & "must have visible read/write attributes ", Error_Node); else Error_Msg_N ! ("limited parameter in 'R'C'I unit " & "must have read/write attributes ", Error_Node); end if; Explain_Limited_Type (Param_Type, Error_Node); end if; + -- In Ada 95, any non-remote access type (or any type with a + -- component of a non-remote access type) that is visible in an + -- RCI unit comes from a Remote_Types or Remote_Call_Interface + -- unit, and thus is already guaranteed to support external + -- streaming. However in Ada 2005 we have to account for the case + -- of named access types from declared pure units as well, which + -- may or may not support external streaming, and so we need to + -- perform a specific check for E.2.3(14/2) here. + + -- Note that if the declaration of the type itself is illegal, we + -- do not perform this check since it might be a cascaded error. + + else + if K = N_Subprogram_Declaration then + Error_Node := Param_Spec; + end if; + + if Missing_Read_Write_Attributes (Param_Type) + and then not Error_Posted (Param_Type) + then + Error_Msg_N + ("parameter containing non-remote access in 'R'C'I " + & "subprogram must have visible " + & "Read and Write attributes", Error_Node); + end if; + end if; Next (Param_Spec); end loop; + + -- No check on return type??? end if; end Validate_RCI_Subprogram_Declaration; *************** package body Sem_Cat is *** 1604,1612 **** --- 1683,1750 ---- ---------------------------------------------------- procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id) is + + function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean; + -- True if tagged type E is a valid candidate as the root type of the + -- designated type for a RACW, i.e. a tagged limited private type, or a + -- limited interface type, or a private extension of such a type. + + --------------------------------- + -- Is_Valid_Remote_Object_Type -- + --------------------------------- + + function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean is + P : constant Node_Id := Parent (E); + + begin + pragma Assert (Is_Tagged_Type (E)); + + -- Simple case: a limited private type + + if Nkind (P) = N_Private_Type_Declaration + and then Is_Limited_Record (E) + then + return True; + + -- A limited interface is not currently a legal ancestor for the + -- designated type of an RACW type, because a type that implements + -- such an interface need not be limited. However, the ARG seems to + -- incline towards allowing an access to classwide limited interface + -- type as a remote access type, as resolved in AI05-060. But note + -- that the expansion circuitry for RACWs that designate classwide + -- interfaces is not complete yet. + + elsif Is_Limited_Record (E) and then Is_Limited_Interface (E) then + return True; + + -- A generic tagged limited type is a valid candidate. Limitedness + -- will be checked again on the actual at instantiation point. + + elsif Nkind (P) = N_Formal_Type_Declaration + and then Ekind (E) = E_Record_Type_With_Private + and then Is_Generic_Type (E) + and then Is_Limited_Record (E) + then + return True; + + -- A private extension declaration is a valid candidate if its parent + -- type is. + + elsif Nkind (P) = N_Private_Extension_Declaration then + return Is_Valid_Remote_Object_Type (Etype (E)); + + else + return False; + end if; + end Is_Valid_Remote_Object_Type; + + -- Local variables + Direct_Designated_Type : Entity_Id; Desig_Type : Entity_Id; + -- Start of processing for Validate_Remote_Access_Object_Type_Declaration + begin -- We are called from Analyze_Type_Declaration, and the Nkind of the -- given node is N_Access_To_Object_Definition. *************** package body Sem_Cat is *** 1650,1669 **** Direct_Designated_Type := Designated_Type (T); Desig_Type := Etype (Direct_Designated_Type); ! if not Is_Recursively_Limited_Private (Desig_Type) then Error_Msg_N ("error in designated type of remote access to class-wide type", T); Error_Msg_N ! ("\must be tagged limited private or private extension of type", T); return; end if; - - -- Now this is an RCI unit access-to-class-wide-limited-private type - -- declaration. Set the type entity to be Is_Remote_Call_Interface to - -- optimize later checks by avoiding tree traversal to find out if this - -- entity is inside an RCI unit. - - Set_Is_Remote_Call_Interface (T); end Validate_Remote_Access_Object_Type_Declaration; ----------------------------------------------- --- 1788,1803 ---- Direct_Designated_Type := Designated_Type (T); Desig_Type := Etype (Direct_Designated_Type); ! -- Why is the check below not in ! -- Validate_Remote_Access_To_Class_Wide_Type??? ! ! if not Is_Valid_Remote_Object_Type (Desig_Type) then Error_Msg_N ("error in designated type of remote access to class-wide type", T); Error_Msg_N ! ("\must be tagged limited private or private extension", T); return; end if; end Validate_Remote_Access_Object_Type_Declaration; ----------------------------------------------- *************** package body Sem_Cat is *** 1681,1687 **** -- Storage_Pool and Storage_Size are not defined for such types -- ! -- The expected type of allocator must not not be such a type. -- The actual parameter of generic instantiation must not be such a -- type if the formal parameter is of an access type. --- 1815,1821 ---- -- Storage_Pool and Storage_Size are not defined for such types -- ! -- The expected type of allocator must not be such a type. -- The actual parameter of generic instantiation must not be such a -- type if the formal parameter is of an access type. *************** package body Sem_Cat is *** 1725,1736 **** -- This subprogram also enforces the checks in E.2.2(13). A value of -- such type must not be dereferenced unless as controlling operand of ! -- a dispatching call. elsif K = N_Explicit_Dereference ! and then (Comes_From_Source (N) ! or else (Nkind (Original_Node (N)) = N_Selected_Component ! and then Comes_From_Source (Original_Node (N)))) then E := Etype (Prefix (N)); --- 1859,1873 ---- -- This subprogram also enforces the checks in E.2.2(13). A value of -- such type must not be dereferenced unless as controlling operand of ! -- a dispatching call. Explicit dereferences not coming from source are ! -- exempted from this checking because the expander produces them in ! -- some cases (such as for tag checks on dispatching calls with multiple ! -- controlling operands). However we do check in the case of an implicit ! -- dereference that is expanded to an explicit dereference (hence the ! -- test of whether Original_Node (N) comes from source). elsif K = N_Explicit_Dereference ! and then Comes_From_Source (Original_Node (N)) then E := Etype (Prefix (N)); *************** package body Sem_Cat is *** 1752,1760 **** -- If we are just within a procedure or function call and the -- dereference has not been analyzed, return because this procedure ! -- will be called again from sem_res Resolve_Actuals. ! if Is_Actual_Parameter (N) and then not Analyzed (N) then return; --- 1889,1900 ---- -- If we are just within a procedure or function call and the -- dereference has not been analyzed, return because this procedure ! -- will be called again from sem_res Resolve_Actuals. The same can ! -- apply in the case of dereference that is the prefix of a selected ! -- component, which can be a call given in prefixed form. ! if (Is_Actual_Parameter (N) ! or else PK = N_Selected_Component) and then not Analyzed (N) then return; *************** package body Sem_Cat is *** 1770,1794 **** return; end if; ! -- The following code is needed for expansion of RACW Write ! -- attribute, since such expressions can appear in the expanded ! -- code. ! ! if not Comes_From_Source (N) ! and then ! (PK = N_In ! or else PK = N_Attribute_Reference ! or else ! (PK = N_Type_Conversion ! and then Present (Parent (N)) ! and then Present (Parent (Parent (N))) ! and then ! Nkind (Parent (Parent (N))) = N_Selected_Component)) ! then ! return; ! end if; ! ! Error_Msg_N ("incorrect remote type dereference", N); end if; end Validate_Remote_Access_To_Class_Wide_Type; --- 1910,1917 ---- return; end if; ! Error_Msg_N ! ("invalid dereference of a remote access-to-class-wide value", N); end if; end Validate_Remote_Access_To_Class_Wide_Type; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_cat.ads gcc-4.4.0/gcc/ada/sem_cat.ads *** gcc-4.3.3/gcc/ada/sem_cat.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_cat.ads Sun Apr 13 17:25:22 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Sem_Cat is *** 47,53 **** -- True when there is a attribute definition clause specifying attribute -- Nam for Typ. In Ada 2005 mode, returns True only when the attribute -- definition clause is visible, unless At_Any_Place is True (in which case ! -- no visiblity test is made, and True is returned as long as an attribute -- is visible at any place). Note that attribute definition clauses -- inherited from parent types are taken into account by this predicate -- (to test for presence of an attribute definition clause for one --- 47,53 ---- -- True when there is a attribute definition clause specifying attribute -- Nam for Typ. In Ada 2005 mode, returns True only when the attribute -- definition clause is visible, unless At_Any_Place is True (in which case ! -- no visibility test is made, and True is returned as long as an attribute -- is visible at any place). Note that attribute definition clauses -- inherited from parent types are taken into account by this predicate -- (to test for presence of an attribute definition clause for one diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch10.adb gcc-4.4.0/gcc/ada/sem_ch10.adb *** gcc-4.3.3/gcc/ada/sem_ch10.adb Thu Dec 13 10:29:38 2007 --- gcc-4.4.0/gcc/ada/sem_ch10.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Debug; use Debug; *** 28,33 **** --- 28,34 ---- with Einfo; use Einfo; with Errout; use Errout; with Exp_Util; use Exp_Util; + with Elists; use Elists; with Fname; use Fname; with Fname.UF; use Fname.UF; with Freeze; use Freeze; *************** package body Sem_Ch10 is *** 387,395 **** elsif Nkind (Cont_Item) = N_Pragma and then ! (Chars (Cont_Item) = Name_Elaborate or else ! Chars (Cont_Item) = Name_Elaborate_All) and then not Used_Type_Or_Elab then Prag_Unit := --- 388,396 ---- elsif Nkind (Cont_Item) = N_Pragma and then ! (Pragma_Name (Cont_Item) = Name_Elaborate or else ! Pragma_Name (Cont_Item) = Name_Elaborate_All) and then not Used_Type_Or_Elab then Prag_Unit := *************** package body Sem_Ch10 is *** 488,494 **** -- Avoid checking implicitly generated with clauses, limited -- with clauses or withs that have pragma Elaborate or ! -- Elaborate_All apllied. if Nkind (Clause) = N_With_Clause and then not Implicit_With (Clause) --- 489,495 ---- -- Avoid checking implicitly generated with clauses, limited -- with clauses or withs that have pragma Elaborate or ! -- Elaborate_All applied. if Nkind (Clause) = N_With_Clause and then not Implicit_With (Clause) *************** package body Sem_Ch10 is *** 632,638 **** -- level (i.e. this subunit will be handled on the way down from the -- parent), so at this level we immediately return. If the subunit -- ends up not analyzed, it means that the parent did not contain a ! -- stub for it, or that there errors were dectected in some ancestor. if Nkind (Unit_Node) = N_Subunit and then not Analyzed (Lib_Unit) --- 633,639 ---- -- level (i.e. this subunit will be handled on the way down from the -- parent), so at this level we immediately return. If the subunit -- ends up not analyzed, it means that the parent did not contain a ! -- stub for it, or that there errors were detected in some ancestor. if Nkind (Unit_Node) = N_Subunit and then not Analyzed (Lib_Unit) *************** package body Sem_Ch10 is *** 759,765 **** Set_Acts_As_Spec (N, False); Set_Is_Child_Unit (Defining_Entity (Unit_Node)); ! Set_Needs_Debug_Info (Defining_Entity (Unit (Lib_Unit))); Set_Comes_From_Source_Default (SCS); end; end if; --- 760,766 ---- Set_Acts_As_Spec (N, False); Set_Is_Child_Unit (Defining_Entity (Unit_Node)); ! Set_Debug_Info_Needed (Defining_Entity (Unit (Lib_Unit))); Set_Comes_From_Source_Default (SCS); end; end if; *************** package body Sem_Ch10 is *** 910,916 **** Add_Stub_Constructs (N); end if; - end if; -- Remove unit from visibility, so that environment is clean for --- 911,916 ---- *************** package body Sem_Ch10 is *** 928,934 **** Remove_Unit_From_Visibility (Defining_Entity (Unit_Node)); -- If the unit is an instantiation whose body will be elaborated for ! -- inlining purposes, use the the proper entity of the instance. The -- entity may be missing if the instantiation was illegal. elsif Nkind (Unit_Node) = N_Package_Instantiation --- 928,934 ---- Remove_Unit_From_Visibility (Defining_Entity (Unit_Node)); -- If the unit is an instantiation whose body will be elaborated for ! -- inlining purposes, use the proper entity of the instance. The -- entity may be missing if the instantiation was illegal. elsif Nkind (Unit_Node) = N_Package_Instantiation *************** package body Sem_Ch10 is *** 1005,1012 **** then Nam := Entity (Name (Item)); if (Is_Generic_Subprogram (Nam) ! and then not Is_Intrinsic_Subprogram (Nam)) or else (Ekind (Nam) = E_Generic_Package and then Unit_Requires_Body (Nam)) then --- 1005,1017 ---- then Nam := Entity (Name (Item)); + -- Compile generic subprogram, unless it is intrinsic or + -- imported so no body is required, or generic package body + -- if the package spec requires a body. + if (Is_Generic_Subprogram (Nam) ! and then not Is_Intrinsic_Subprogram (Nam) ! and then not Is_Imported (Nam)) or else (Ekind (Nam) = E_Generic_Package and then Unit_Requires_Body (Nam)) then *************** package body Sem_Ch10 is *** 1096,1102 **** or else Is_Preelaborated (Spec_Id) ! -- No checks needed if pagma Elaborate_Body present or else Has_Pragma_Elaborate_Body (Spec_Id) --- 1101,1107 ---- or else Is_Preelaborated (Spec_Id) ! -- No checks needed if pragma Elaborate_Body present or else Has_Pragma_Elaborate_Body (Spec_Id) *************** package body Sem_Ch10 is *** 1237,1248 **** Item := First (Context_Items (N)); while Present (Item) and then Nkind (Item) = N_Pragma ! and then Chars (Item) in Configuration_Pragma_Names loop Analyze (Item); Next (Item); end loop; -- Loop through actual context items. This is done in two passes: -- a) The first pass analyzes non-limited with-clauses and also any --- 1242,1263 ---- Item := First (Context_Items (N)); while Present (Item) and then Nkind (Item) = N_Pragma ! and then Pragma_Name (Item) in Configuration_Pragma_Names loop Analyze (Item); Next (Item); end loop; + -- This is the point at which we capture the configuration settings + -- for the unit. At the moment only the Optimize_Alignment setting + -- needs to be captured. Probably more later ??? + + if Optimize_Alignment_Local then + Set_OA_Setting (Current_Sem_Unit, 'L'); + else + Set_OA_Setting (Current_Sem_Unit, Optimize_Alignment); + end if; + -- Loop through actual context items. This is done in two passes: -- a) The first pass analyzes non-limited with-clauses and also any *************** package body Sem_Ch10 is *** 1260,1266 **** and then not Limited_Present (Item) then -- Skip analyzing with clause if no unit, nothing to do (this ! -- happens for a with that references a non-existant unit) if Present (Library_Unit (Item)) then Analyze (Item); --- 1275,1281 ---- and then not Limited_Present (Item) then -- Skip analyzing with clause if no unit, nothing to do (this ! -- happens for a with that references a non-existent unit) if Present (Library_Unit (Item)) then Analyze (Item); *************** package body Sem_Ch10 is *** 1277,1283 **** -- the implicit with's on parent units. -- Skip use clauses at this stage, since we don't want to do any ! -- installing of potentially use visible entities until we we -- actually install the complete context (in Install_Context). -- Otherwise things can get installed in the wrong context. --- 1292,1298 ---- -- the implicit with's on parent units. -- Skip use clauses at this stage, since we don't want to do any ! -- installing of potentially use visible entities until we -- actually install the complete context (in Install_Context). -- Otherwise things can get installed in the wrong context. *************** package body Sem_Ch10 is *** 1301,1314 **** if not Implicit_With (Item) then ! -- Check compilation unit containing the limited-with clause if not Nkind_In (Ukind, N_Package_Declaration, ! N_Subprogram_Declaration, ! N_Package_Renaming_Declaration, ! N_Subprogram_Renaming_Declaration) and then Ukind not in N_Generic_Declaration - and then Ukind not in N_Generic_Renaming_Declaration and then Ukind not in N_Generic_Instantiation then Error_Msg_N ("limited with_clause not allowed here", Item); --- 1316,1327 ---- if not Implicit_With (Item) then ! -- Verify that the illegal contexts given in 10.1.2 (18/2) ! -- are properly rejected, including renaming declarations. if not Nkind_In (Ukind, N_Package_Declaration, ! N_Subprogram_Declaration) and then Ukind not in N_Generic_Declaration and then Ukind not in N_Generic_Instantiation then Error_Msg_N ("limited with_clause not allowed here", Item); *************** package body Sem_Ch10 is *** 1732,1738 **** else Optional_Subunit; end if; - end Analyze_Proper_Body; ---------------------------------- --- 1745,1750 ---- *************** package body Sem_Ch10 is *** 1745,1751 **** begin Check_Stub_Level (N); ! -- First occurence of name may have been as an incomplete type if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then Nam := Full_View (Nam); --- 1757,1763 ---- begin Check_Stub_Level (N); ! -- First occurrence of name may have been as an incomplete type if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then Nam := Full_View (Nam); *************** package body Sem_Ch10 is *** 1995,2003 **** -- all the parents are bodies. Restore full visibility of their -- private entities. ! if Ekind (Scop) = E_Package ! or else Ekind (Scop) = E_Generic_Package ! then Set_In_Package_Body (Scop); Install_Private_Declarations (Scop); end if; --- 2007,2013 ---- -- all the parents are bodies. Restore full visibility of their -- private entities. ! if Is_Package_Or_Generic_Package (Scop) then Set_In_Package_Body (Scop); Install_Private_Declarations (Scop); end if; *************** package body Sem_Ch10 is *** 2087,2095 **** -- context includes another subunit of the same parent which in -- turn includes a child unit in its context. ! if Ekind (Par_Unit) = E_Package ! or else Ekind (Par_Unit) = E_Generic_Package ! then if not Is_Immediately_Visible (Par_Unit) or else (Present (First_Entity (Par_Unit)) and then not Is_Immediately_Visible --- 2097,2103 ---- -- context includes another subunit of the same parent which in -- turn includes a child unit in its context. ! if Is_Package_Or_Generic_Package (Par_Unit) then if not Is_Immediately_Visible (Par_Unit) or else (Present (First_Entity (Par_Unit)) and then not Is_Immediately_Visible *************** package body Sem_Ch10 is *** 2153,2159 **** begin Check_Stub_Level (N); ! -- First occurence of name may have been as an incomplete type if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then Nam := Full_View (Nam); --- 2161,2167 ---- begin Check_Stub_Level (N); ! -- First occurrence of name may have been as an incomplete type if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then Nam := Full_View (Nam); *************** package body Sem_Ch10 is *** 2218,2229 **** Cunit_Boolean_Restrictions_Save; begin if Limited_Present (N) then -- Ada 2005 (AI-50217): Build visibility structures but do not -- analyze the unit. ! Build_Limited_Views (N); return; end if; --- 2226,2246 ---- Cunit_Boolean_Restrictions_Save; begin + U := Unit (Library_Unit (N)); + + -- Several actions are skipped for dummy packages (those supplied for + -- with's where no matching file could be found). Such packages are + -- identified by the Sloc value being set to No_Location. + if Limited_Present (N) then -- Ada 2005 (AI-50217): Build visibility structures but do not -- analyze the unit. ! if Sloc (U) /= No_Location then ! Build_Limited_Views (N); ! end if; ! return; end if; *************** package body Sem_Ch10 is *** 2253,2265 **** Semantics (Library_Unit (N)); end if; - U := Unit (Library_Unit (N)); Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)); - -- Following checks are skipped for dummy packages (those supplied for - -- with's where no matching file could be found). Such packages are - -- identified by the Sloc value being set to No_Location - if Sloc (U) /= No_Location then -- Check restrictions, except that we skip the check if this is an --- 2270,2277 ---- *************** package body Sem_Ch10 is *** 2526,2531 **** --- 2538,2544 ---- if Nkind (Item) = N_With_Clause and then not Implicit_With (Item) + and then not Limited_Present (Item) and then Is_Private_Descendant (Entity (Name (Item))) then Priv_Child := Entity (Name (Item)); *************** package body Sem_Ch10 is *** 2643,2655 **** P : Node_Id; function Build_Unit_Name (Nam : Node_Id) return Node_Id; ! -- Comment requireed here ??? --------------------- -- Build_Unit_Name -- --------------------- function Build_Unit_Name (Nam : Node_Id) return Node_Id is Renaming : Entity_Id; Result : Node_Id; --- 2656,2673 ---- P : Node_Id; function Build_Unit_Name (Nam : Node_Id) return Node_Id; ! -- Build name to be used in implicit with_clause. In most cases this ! -- is the source name, but if renamings are present we must make the ! -- original unit visible, not the one it renames. The entity in the ! -- with clause is the renamed unit, but the identifier is the one from ! -- the source, which allows us to recover the unit renaming. --------------------- -- Build_Unit_Name -- --------------------- function Build_Unit_Name (Nam : Node_Id) return Node_Id is + Ent : Entity_Id; Renaming : Entity_Id; Result : Node_Id; *************** package body Sem_Ch10 is *** 2678,2689 **** end if; else Result := Make_Expanded_Name (Loc, Chars => Chars (Entity (Nam)), Prefix => Build_Unit_Name (Prefix (Nam)), ! Selector_Name => New_Occurrence_Of (Entity (Nam), Loc)); ! Set_Entity (Result, Entity (Nam)); return Result; end if; end Build_Unit_Name; --- 2696,2728 ---- end if; else + Ent := Entity (Nam); + + if Present (Entity (Selector_Name (Nam))) + and then Chars (Entity (Selector_Name (Nam))) /= Chars (Ent) + and then + Nkind (Unit_Declaration_Node (Entity (Selector_Name (Nam)))) + = N_Package_Renaming_Declaration + then + -- The name in the with_clause is of the form A.B.C, and B + -- is given by a renaming declaration. In that case we may + -- not have analyzed the unit for B, but replaced it directly + -- in lib-load with the unit it renames. We have to make A.B + -- visible, so analyze the declaration for B now, in case it + -- has not been done yet. + + Ent := Entity (Selector_Name (Nam)); + Analyze + (Parent + (Unit_Declaration_Node (Entity (Selector_Name (Nam))))); + end if; + Result := Make_Expanded_Name (Loc, Chars => Chars (Entity (Nam)), Prefix => Build_Unit_Name (Prefix (Nam)), ! Selector_Name => New_Occurrence_Of (Ent, Loc)); ! Set_Entity (Result, Ent); return Result; end if; end Build_Unit_Name; *************** package body Sem_Ch10 is *** 2693,2712 **** begin New_Nodes_OK := New_Nodes_OK + 1; Withn := ! Make_With_Clause (Loc, Name => Build_Unit_Name (Nam)); P := Parent (Unit_Declaration_Node (Ent)); ! Set_Library_Unit (Withn, P); ! Set_Corresponding_Spec (Withn, Ent); ! Set_First_Name (Withn, True); ! Set_Implicit_With (Withn, True); -- If the unit is a package declaration, a private_with_clause on a -- child unit implies that the implicit with on the parent is also -- private. if Nkind (Unit (N)) = N_Package_Declaration then ! Set_Private_Present (Withn, Private_Present (Item)); end if; Prepend (Withn, Context_Items (N)); --- 2732,2752 ---- begin New_Nodes_OK := New_Nodes_OK + 1; Withn := ! Make_With_Clause (Loc, ! Name => Build_Unit_Name (Nam)); P := Parent (Unit_Declaration_Node (Ent)); ! Set_Library_Unit (Withn, P); ! Set_Corresponding_Spec (Withn, Ent); ! Set_First_Name (Withn, True); ! Set_Implicit_With (Withn, True); -- If the unit is a package declaration, a private_with_clause on a -- child unit implies that the implicit with on the parent is also -- private. if Nkind (Unit (N)) = N_Package_Declaration then ! Set_Private_Present (Withn, Private_Present (Item)); end if; Prepend (Withn, Context_Items (N)); *************** package body Sem_Ch10 is *** 2729,2741 **** if Nkind (Unit) = N_Package_Body and then Nkind (Original_Node (Unit)) = N_Package_Instantiation then ! return ! Defining_Entity ! (Specification (Instance_Spec (Original_Node (Unit)))); ! elsif Nkind (Unit) = N_Package_Instantiation then return Defining_Entity (Specification (Instance_Spec (Unit))); - else return Defining_Entity (Unit); end if; --- 2769,2778 ---- if Nkind (Unit) = N_Package_Body and then Nkind (Original_Node (Unit)) = N_Package_Instantiation then ! return Defining_Entity ! (Specification (Instance_Spec (Original_Node (Unit)))); elsif Nkind (Unit) = N_Package_Instantiation then return Defining_Entity (Specification (Instance_Spec (Unit))); else return Defining_Entity (Unit); end if; *************** package body Sem_Ch10 is *** 2890,2896 **** end if; Install_Limited_Context_Clauses (N); - end Install_Context; ----------------------------- --- 2927,2932 ---- *************** package body Sem_Ch10 is *** 2913,2919 **** Item := First (Context_Items (N)); while Present (Item) and then Nkind (Item) = N_Pragma ! and then Chars (Item) in Configuration_Pragma_Names loop Next (Item); end loop; --- 2949,2955 ---- Item := First (Context_Items (N)); while Present (Item) and then Nkind (Item) = N_Pragma ! and then Pragma_Name (Item) in Configuration_Pragma_Names loop Next (Item); end loop; *************** package body Sem_Ch10 is *** 3166,3172 **** -- Check that if a limited_with clause of a given compilation_unit -- mentions a descendant of a private child of some library unit, -- then the given compilation_unit shall be the declaration of a ! -- private descendant of that library unit. procedure Expand_Limited_With_Clause (Comp_Unit : Node_Id; --- 3202,3212 ---- -- Check that if a limited_with clause of a given compilation_unit -- mentions a descendant of a private child of some library unit, -- then the given compilation_unit shall be the declaration of a ! -- private descendant of that library unit, or a public descendant ! -- of such. The code is analogous to that of Check_Private_Child_Unit ! -- but we cannot use entities on the limited with_clauses because ! -- their units have not been analyzed, so we have to climb the tree ! -- of ancestors looking for private keywords. procedure Expand_Limited_With_Clause (Comp_Unit : Node_Id; *************** package body Sem_Ch10 is *** 3277,3287 **** procedure Check_Private_Limited_Withed_Unit (Item : Node_Id) is Curr_Parent : Node_Id; Child_Parent : Node_Id; begin -- Compilation unit of the parent of the withed library unit ! Child_Parent := Parent_Spec (Unit (Library_Unit (Item))); -- If the child unit is a public child, then locate its nearest -- private ancestor, if any; Child_Parent will then be set to --- 3317,3328 ---- procedure Check_Private_Limited_Withed_Unit (Item : Node_Id) is Curr_Parent : Node_Id; Child_Parent : Node_Id; + Curr_Private : Boolean; begin -- Compilation unit of the parent of the withed library unit ! Child_Parent := Library_Unit (Item); -- If the child unit is a public child, then locate its nearest -- private ancestor, if any; Child_Parent will then be set to *************** package body Sem_Ch10 is *** 3297,3314 **** if No (Child_Parent) then return; end if; - - Child_Parent := Parent_Spec (Unit (Child_Parent)); end if; -- Traverse all the ancestors of the current compilation -- unit to check if it is a descendant of named library unit. Curr_Parent := Parent (Item); while Present (Parent_Spec (Unit (Curr_Parent))) and then Curr_Parent /= Child_Parent loop Curr_Parent := Parent_Spec (Unit (Curr_Parent)); end loop; if Curr_Parent /= Child_Parent then --- 3338,3358 ---- if No (Child_Parent) then return; end if; end if; + Child_Parent := Parent_Spec (Unit (Child_Parent)); + -- Traverse all the ancestors of the current compilation -- unit to check if it is a descendant of named library unit. Curr_Parent := Parent (Item); + Curr_Private := Private_Present (Curr_Parent); + while Present (Parent_Spec (Unit (Curr_Parent))) and then Curr_Parent /= Child_Parent loop Curr_Parent := Parent_Spec (Unit (Curr_Parent)); + Curr_Private := Curr_Private or else Private_Present (Curr_Parent); end loop; if Curr_Parent /= Child_Parent then *************** package body Sem_Ch10 is *** 3318,3329 **** ("\current unit must also have parent&!", Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); ! elsif not Private_Present (Parent (Item)) ! and then not Private_Present (Item) ! and then not Nkind_In (Unit (Parent (Item)), N_Package_Body, N_Subprogram_Body, N_Subunit) then Error_Msg_NE ("current unit must also be private descendant of&", Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); --- 3362,3379 ---- ("\current unit must also have parent&!", Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); ! elsif Private_Present (Parent (Item)) ! or else Curr_Private ! or else Private_Present (Item) ! or else Nkind_In (Unit (Parent (Item)), N_Package_Body, N_Subprogram_Body, N_Subunit) then + -- Current unit is private, of descendant of a private unit. + + null; + + else Error_Msg_NE ("current unit must also be private descendant of&", Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); *************** package body Sem_Ch10 is *** 3713,3718 **** --- 3763,3769 ---- Item : Node_Id; Id : Entity_Id; Prev : Entity_Id; + begin -- Iterate over explicit with clauses, and check whether the scope of -- each entity is an ancestor of the current unit, in which case it is *************** package body Sem_Ch10 is *** 3721,3736 **** Item := First (Context_Items (N)); while Present (Item) loop ! -- Do not install private_with_clauses if the unit is a package ! -- declaration, unless it is itself a private child unit. ! if Nkind (Item) = N_With_Clause ! and then not Implicit_With (Item) ! and then not Limited_Present (Item) ! and then ! (not Private_Present (Item) ! or else Nkind (Unit (N)) /= N_Package_Declaration ! or else Private_Present (N)) then Id := Entity (Name (Item)); --- 3772,3791 ---- Item := First (Context_Items (N)); while Present (Item) loop ! -- Do not install private_with_clauses declaration, unless ! -- unit is itself a private child unit, or is a body. ! -- Note that for a subprogram body the private_with_clause does ! -- not take effect until after the specification. ! if Nkind (Item) /= N_With_Clause ! or else Implicit_With (Item) ! or else Limited_Present (Item) ! then ! null; ! ! elsif not Private_Present (Item) ! or else Private_Present (N) ! or else Nkind (Unit (N)) = N_Package_Body then Id := Entity (Name (Item)); *************** package body Sem_Ch10 is *** 3791,3805 **** end loop; end; end if; end if; Next (Item); end loop; end Install_Siblings; ! ------------------------------- ! -- Install_Limited_With_Unit -- ! ------------------------------- procedure Install_Limited_Withed_Unit (N : Node_Id) is P_Unit : constant Entity_Id := Unit (Library_Unit (N)); --- 3846,3871 ---- end loop; end; end if; + + -- If the item is a private with-clause on a child unit, the parent + -- may have been installed already, but the child unit must remain + -- invisible until installed in a private part or body. + + elsif Private_Present (Item) then + Id := Entity (Name (Item)); + + if Is_Child_Unit (Id) then + Set_Is_Visible_Child_Unit (Id, False); + end if; end if; Next (Item); end loop; end Install_Siblings; ! --------------------------------- ! -- Install_Limited_Withed_Unit -- ! --------------------------------- procedure Install_Limited_Withed_Unit (N : Node_Id) is P_Unit : constant Entity_Id := Unit (Library_Unit (N)); *************** package body Sem_Ch10 is *** 3809,3814 **** --- 3875,3888 ---- Lim_Header : Entity_Id; Lim_Typ : Entity_Id; + procedure Check_Body_Required; + -- A unit mentioned in a limited with_clause may not be mentioned in + -- a regular with_clause, but must still be included in the current + -- partition. We need to determine whether the unit needs a body, so + -- that the binder can determine the name of the file to be compiled. + -- Checking whether a unit needs a body can be done without semantic + -- analysis, by examining the nature of the declarations in the package. + function Has_Limited_With_Clause (C_Unit : Entity_Id; Pack : Entity_Id) return Boolean; *************** package body Sem_Ch10 is *** 3827,3832 **** --- 3901,4057 ---- -- Check if some package installed though normal with-clauses has a -- renaming declaration of package P. AARM 10.1.2(21/2). + ------------------------- + -- Check_Body_Required -- + ------------------------- + + -- ??? misses pragma Import on subprograms + -- ??? misses pragma Import on renamed subprograms + + procedure Check_Body_Required is + PA : constant List_Id := + Pragmas_After (Aux_Decls_Node (Parent (P_Unit))); + + procedure Check_Declarations (Spec : Node_Id); + -- Recursive procedure that does the work and checks nested packages + + ------------------------ + -- Check_Declarations -- + ------------------------ + + procedure Check_Declarations (Spec : Node_Id) is + Decl : Node_Id; + Incomplete_Decls : constant Elist_Id := New_Elmt_List; + + begin + -- Search for Elaborate Body pragma + + Decl := First (Visible_Declarations (Spec)); + while Present (Decl) + and then Nkind (Decl) = N_Pragma + loop + if Get_Pragma_Id (Decl) = Pragma_Elaborate_Body then + Set_Body_Required (Library_Unit (N)); + return; + end if; + + Next (Decl); + end loop; + + -- Look for declarations that require the presence of a body + + while Present (Decl) loop + + -- Subprogram that comes from source means body required + -- This is where a test for Import is missing ??? + + if Comes_From_Source (Decl) + and then (Nkind_In (Decl, N_Subprogram_Declaration, + N_Generic_Subprogram_Declaration)) + then + Set_Body_Required (Library_Unit (N)); + return; + + -- Package declaration of generic package declaration. We need + -- to recursively examine nested declarations. + + elsif Nkind_In (Decl, N_Package_Declaration, + N_Generic_Package_Declaration) + then + Check_Declarations (Specification (Decl)); + end if; + + Next (Decl); + end loop; + + -- Same set of tests for private part. In addition to subprograms + -- detect the presence of Taft Amendment types (incomplete types + -- completed in the body). + + Decl := First (Private_Declarations (Spec)); + while Present (Decl) loop + if Comes_From_Source (Decl) + and then (Nkind_In (Decl, N_Subprogram_Declaration, + N_Generic_Subprogram_Declaration)) + then + Set_Body_Required (Library_Unit (N)); + + elsif Nkind_In (Decl, N_Package_Declaration, + N_Generic_Package_Declaration) + then + Check_Declarations (Specification (Decl)); + + -- Collect incomplete type declarations for separate pass + + elsif Nkind (Decl) = N_Incomplete_Type_Declaration then + Append_Elmt (Decl, Incomplete_Decls); + end if; + + Next (Decl); + end loop; + + -- Now check incomplete declarations to locate Taft amendment + -- types. This can be done by examining the defining identifiers + -- of type declarations without real semantic analysis. + + declare + Inc : Elmt_Id; + + begin + Inc := First_Elmt (Incomplete_Decls); + while Present (Inc) loop + Decl := Next (Node (Inc)); + while Present (Decl) loop + if Nkind (Decl) = N_Full_Type_Declaration + and then Chars (Defining_Identifier (Decl)) = + Chars (Defining_Identifier (Node (Inc))) + then + exit; + end if; + + Next (Decl); + end loop; + + -- If no completion, this is a TAT, and a body is needed + + if No (Decl) then + Set_Body_Required (Library_Unit (N)); + return; + end if; + + Next_Elmt (Inc); + end loop; + end; + end Check_Declarations; + + -- Start of processing for Check_Body_Required + + begin + -- If this is an imported package (Java and CIL usage) no body is + -- needed. Scan list of pragmas that may follow a compilation unit + -- to look for a relevant pragma Import. + + if Present (PA) then + declare + Prag : Node_Id; + + begin + Prag := First (PA); + while Present (Prag) loop + if Nkind (Prag) = N_Pragma + and then Get_Pragma_Id (Prag) = Pragma_Import + then + return; + end if; + + Next (Prag); + end loop; + end; + end if; + + Check_Declarations (Specification (P_Unit)); + end Check_Body_Required; + ----------------------------- -- Has_Limited_With_Clause -- ----------------------------- *************** package body Sem_Ch10 is *** 3950,3957 **** while Present (Item) loop if Nkind (Item) = N_With_Clause and then not Limited_Present (Item) ! and then Nkind (Unit (Library_Unit (Item))) ! = N_Package_Declaration then Decl := First (Visible_Declarations --- 4175,4182 ---- while Present (Item) loop if Nkind (Item) = N_With_Clause and then not Limited_Present (Item) ! and then Nkind (Unit (Library_Unit (Item))) = ! N_Package_Declaration then Decl := First (Visible_Declarations *************** package body Sem_Ch10 is *** 4016,4024 **** -- In case of limited with_clause on subprograms, generics, instances, -- or renamings, the corresponding error was previously posted and we ! -- have nothing to do here. ! if Nkind (P_Unit) /= N_Package_Declaration then return; end if; --- 4241,4252 ---- -- In case of limited with_clause on subprograms, generics, instances, -- or renamings, the corresponding error was previously posted and we ! -- have nothing to do here. If the file is missing altogether, it has ! -- no source location. ! if Nkind (P_Unit) /= N_Package_Declaration ! or else Sloc (P_Unit) = No_Location ! then return; end if; *************** package body Sem_Ch10 is *** 4104,4142 **** -- view of X supersedes its limited view. if Analyzed (P_Unit) ! and then (Is_Immediately_Visible (P) ! or else (Is_Child_Package ! and then Is_Visible_Child_Unit (P))) then - -- Ada 2005 (AI-262): Install the private declarations of P - - if Private_Present (N) - and then not In_Private_Part (P) - then - declare - Id : Entity_Id; - - begin - Id := First_Private_Entity (P); - while Present (Id) loop - if not Is_Internal (Id) - and then not Is_Child_Unit (Id) - then - if not In_Chain (Id) then - Set_Homonym (Id, Current_Entity (Id)); - Set_Current_Entity (Id); - end if; - - Set_Is_Immediately_Visible (Id); - end if; - - Next_Entity (Id); - end loop; - - Set_In_Private_Part (P); - end; - end if; - return; end if; --- 4332,4342 ---- -- view of X supersedes its limited view. if Analyzed (P_Unit) ! and then ! (Is_Immediately_Visible (P) ! or else ! (Is_Child_Package and then Is_Visible_Child_Unit (P))) then return; end if; *************** package body Sem_Ch10 is *** 4295,4300 **** --- 4495,4507 ---- Set_Is_Immediately_Visible (P); Set_Limited_View_Installed (N); + -- If unit has not been analyzed in some previous context, check + -- (imperfectly ???) whether it might need a body. + + if not Analyzed (P_Unit) then + Check_Body_Required; + end if; + -- If the package in the limited_with clause is a child unit, the -- clause is unanalyzed and appears as a selected component. Recast -- it as an expanded name so that the entity can be properly set. Use *************** package body Sem_Ch10 is *** 4599,4611 **** Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N)); P : constant Entity_Id := Cunit_Entity (Unum); ! Spec : Node_Id; -- To denote a package specification ! Lim_Typ : Entity_Id; -- To denote shadow entities ! Comp_Typ : Entity_Id; -- To denote real entities ! Lim_Header : Entity_Id; -- Package entity ! Last_Lim_E : Entity_Id := Empty; -- Last limited entity built ! Last_Pub_Lim_E : Entity_Id; -- To set the first private entity procedure Decorate_Incomplete_Type (E : Entity_Id; --- 4806,4818 ---- Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N)); P : constant Entity_Id := Cunit_Entity (Unum); ! Spec : Node_Id; -- To denote a package specification ! Lim_Typ : Entity_Id; -- To denote shadow entities ! Comp_Typ : Entity_Id; -- To denote real entities ! Lim_Header : Entity_Id; -- Package entity ! Last_Lim_E : Entity_Id := Empty; -- Last limited entity built ! Last_Pub_Lim_E : Entity_Id; -- To set the first private entity procedure Decorate_Incomplete_Type (E : Entity_Id; *************** package body Sem_Ch10 is *** 4673,4684 **** -- Build corresponding class_wide type, if not previously done ! -- Warning: The class-wide entity is shared by the limited-view -- and the full-view. if No (Class_Wide_Type (T)) then CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); Set_Ekind (CW, E_Class_Wide_Type); Set_Etype (CW, T); Set_Scope (CW, Scop); --- 4880,4903 ---- -- Build corresponding class_wide type, if not previously done ! -- Note: The class-wide entity is shared by the limited-view -- and the full-view. if No (Class_Wide_Type (T)) then CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + -- Set parent to be the same as the parent of the tagged type. + -- We need a parent field set, and it is supposed to point to + -- the declaration of the type. The tagged type declaration + -- essentially declares two separate types, the tagged type + -- itself and the corresponding class-wide type, so it is + -- reasonable for the parent fields to point to the declaration + -- in both cases. + + Set_Parent (CW, Parent (T)); + + -- Set remaining fields of classwide type + Set_Ekind (CW, E_Class_Wide_Type); Set_Etype (CW, T); Set_Scope (CW, Scop); *************** package body Sem_Ch10 is *** 4690,4695 **** --- 4909,4916 ---- Set_Equivalent_Type (CW, Empty); Set_From_With_Type (CW, From_With_Type (T)); + -- Link type to its class-wide type + Set_Class_Wide_Type (T, CW); end if; end Decorate_Tagged_Type; *************** package body Sem_Ch10 is *** 4805,4817 **** Set_Non_Limited_View (Lim_Typ, Comp_Typ); ! elsif Nkind (Decl) = N_Private_Type_Declaration ! or else Nkind (Decl) = N_Incomplete_Type_Declaration then Comp_Typ := Defining_Identifier (Decl); if not Analyzed_Unit then ! if Tagged_Present (Decl) then Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); else Decorate_Incomplete_Type (Comp_Typ, Scope); --- 5026,5045 ---- Set_Non_Limited_View (Lim_Typ, Comp_Typ); ! elsif Nkind_In (Decl, N_Private_Type_Declaration, ! N_Incomplete_Type_Declaration, ! N_Task_Type_Declaration, ! N_Protected_Type_Declaration) then Comp_Typ := Defining_Identifier (Decl); + Is_Tagged := + Nkind_In (Decl, N_Private_Type_Declaration, + N_Incomplete_Type_Declaration) + and then Tagged_Present (Decl); + if not Analyzed_Unit then ! if Is_Tagged then Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); else Decorate_Incomplete_Type (Comp_Typ, Scope); *************** package body Sem_Ch10 is *** 4827,4833 **** Set_Parent (Lim_Typ, Parent (Comp_Typ)); Set_From_With_Type (Lim_Typ); ! if Tagged_Present (Decl) then Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); else Decorate_Incomplete_Type (Lim_Typ, Scope); --- 5055,5061 ---- Set_Parent (Lim_Typ, Parent (Comp_Typ)); Set_From_With_Type (Lim_Typ); ! if Is_Tagged then Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); else Decorate_Incomplete_Type (Lim_Typ, Scope); *************** package body Sem_Ch10 is *** 4879,4885 **** Decorate_Package_Specification (Lim_Typ); Set_Scope (Lim_Typ, Scope); ! Set_Chars (Lim_Typ, Chars (Comp_Typ)); Set_Parent (Lim_Typ, Parent (Comp_Typ)); Set_From_With_Type (Lim_Typ); --- 5107,5113 ---- Decorate_Package_Specification (Lim_Typ); Set_Scope (Lim_Typ, Scope); ! Set_Chars (Lim_Typ, Chars (Comp_Typ)); Set_Parent (Lim_Typ, Parent (Comp_Typ)); Set_From_With_Type (Lim_Typ); *************** package body Sem_Ch10 is *** 4901,4913 **** begin pragma Assert (Limited_Present (N)); ! -- A library_item mentioned in a limited_with_clause shall ! -- be a package_declaration, not a subprogram_declaration, ! -- generic_declaration, generic_instantiation, or ! -- package_renaming_declaration case Nkind (Unit (Library_Unit (N))) is - when N_Package_Declaration => null; --- 5129,5139 ---- begin pragma Assert (Limited_Present (N)); ! -- A library_item mentioned in a limited_with_clause is a package ! -- declaration, not a subprogram declaration, generic declaration, ! -- generic instantiation, or package renaming declaration. case Nkind (Unit (Library_Unit (N))) is when N_Package_Declaration => null; *************** package body Sem_Ch10 is *** 4958,4965 **** -- Build the header of the limited_view ! Lim_Header := Make_Defining_Identifier (Sloc (N), ! Chars => New_Internal_Name (Id_Char => 'Z')); Set_Ekind (Lim_Header, E_Package); Set_Is_Internal (Lim_Header); Set_Limited_View (P, Lim_Header); --- 5184,5192 ---- -- Build the header of the limited_view ! Lim_Header := ! Make_Defining_Identifier (Sloc (N), ! Chars => New_Internal_Name (Id_Char => 'Z')); Set_Ekind (Lim_Header, E_Package); Set_Is_Internal (Lim_Header); Set_Limited_View (P, Lim_Header); *************** package body Sem_Ch10 is *** 5272,5278 **** Next_Entity (E); end loop; ! -- If the previous search was not sucessful then the entity -- to be restored in the homonym list is the non-limited view if E = First_Private_Entity (P) then --- 5499,5505 ---- Next_Entity (E); end loop; ! -- If the previous search was not successful then the entity -- to be restored in the homonym list is the non-limited view if E = First_Private_Entity (P) then *************** package body Sem_Ch10 is *** 5410,5416 **** if Nkind (Item) = N_With_Clause and then Private_Present (Item) then - -- If private_with_clause is redundant, remove it from -- context, as a small optimization to subsequent handling -- of private_with clauses in other nested packages.. --- 5637,5642 ---- *************** package body Sem_Ch10 is *** 5418,5424 **** if In_Regular_With_Clause (Entity (Name (Item))) then declare Nxt : constant Node_Id := Next (Item); - begin Remove (Item); Item := Nxt; --- 5644,5649 ---- *************** package body Sem_Ch10 is *** 5451,5457 **** P : constant Entity_Id := Scope (Unit_Name); begin - if Debug_Flag_I then Write_Str ("remove unit "); Write_Name (Chars (Unit_Name)); --- 5676,5681 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch10.ads gcc-4.4.0/gcc/ada/sem_ch10.ads *** gcc-4.3.3/gcc/ada/sem_ch10.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_ch10.ads Sun Apr 13 17:41:15 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Sem_Ch10 is *** 56,62 **** -- private part of a nested package, even if this package appears in -- the visible part of the enclosing compilation unit. This Ada 2005 -- rule imposes extra steps in order to install/remove the private_with ! -- clauses of the an enclosing unit. procedure Load_Needed_Body (N : Node_Id; OK : out Boolean); -- Load and analyze the body of a context unit that is generic, or --- 56,62 ---- -- private part of a nested package, even if this package appears in -- the visible part of the enclosing compilation unit. This Ada 2005 -- rule imposes extra steps in order to install/remove the private_with ! -- clauses of an enclosing unit. procedure Load_Needed_Body (N : Node_Id; OK : out Boolean); -- Load and analyze the body of a context unit that is generic, or diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch11.adb gcc-4.4.0/gcc/ada/sem_ch11.adb *** gcc-4.3.3/gcc/ada/sem_ch11.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/sem_ch11.adb Fri Feb 20 15:20:38 2009 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Sem_Ch11 is *** 185,192 **** -- scope for visibility purposes. We create an entity to denote -- the whole exception part, and use it as the scope of all the -- choices, which may even have the same name without conflict. ! -- This scope plays no other role in expansion or or code ! -- generation. Choice := Choice_Parameter (Handler); --- 185,191 ---- -- scope for visibility purposes. We create an entity to denote -- the whole exception part, and use it as the scope of all the -- choices, which may even have the same name without conflict. ! -- This scope plays no other role in expansion or code generation. Choice := Choice_Parameter (Handler); *************** package body Sem_Ch11 is *** 437,443 **** Exception_Id : constant Node_Id := Name (N); Exception_Name : Entity_Id := Empty; P : Node_Id; - Nkind_P : Node_Kind; begin Check_Unreachable_Code (N); --- 436,441 ---- *************** package body Sem_Ch11 is *** 484,499 **** if No (Exception_Id) then P := Parent (N); ! Nkind_P := Nkind (P); ! ! while Nkind_P /= N_Exception_Handler ! and then Nkind_P /= N_Subprogram_Body ! and then Nkind_P /= N_Package_Body ! and then Nkind_P /= N_Task_Body ! and then Nkind_P /= N_Entry_Body loop P := Parent (P); - Nkind_P := Nkind (P); end loop; if Nkind (P) /= N_Exception_Handler then --- 482,494 ---- if No (Exception_Id) then P := Parent (N); ! while not Nkind_In (P, N_Exception_Handler, ! N_Subprogram_Body, ! N_Package_Body, ! N_Task_Body, ! N_Entry_Body) loop P := Parent (P); end loop; if Nkind (P) /= N_Exception_Handler then *************** package body Sem_Ch11 is *** 506,512 **** else Set_Local_Raise_Not_OK (P); ! Check_Restriction (No_Exception_Propagation, N); end if; -- Normal case with exception id present --- 501,515 ---- else Set_Local_Raise_Not_OK (P); ! ! -- Do not check the restriction if the reraise statement is part ! -- of the code generated for an AT-END handler. That's because ! -- if the restriction is actually active, we never generate this ! -- raise anyway, so the apparent violation is bogus. ! ! if not From_At_End (N) then ! Check_Restriction (No_Exception_Propagation, N); ! end if; end if; -- Normal case with exception id present diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch12.adb gcc-4.4.0/gcc/ada/sem_ch12.adb *** gcc-4.3.3/gcc/ada/sem_ch12.adb Thu Dec 13 10:29:52 2007 --- gcc-4.4.0/gcc/ada/sem_ch12.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Sem_Ch12 is *** 111,117 **** -- b) Each instantiation copies the original tree, and inserts into it a -- series of declarations that describe the mapping between generic formals -- and actuals. For example, a generic In OUT parameter is an object ! -- renaming of the corresponing actual, etc. Generic IN parameters are -- constant declarations. -- c) In order to give the right visibility for these renamings, we use --- 111,117 ---- -- b) Each instantiation copies the original tree, and inserts into it a -- series of declarations that describe the mapping between generic formals -- and actuals. For example, a generic In OUT parameter is an object ! -- renaming of the corresponding actual, etc. Generic IN parameters are -- constant declarations. -- c) In order to give the right visibility for these renamings, we use *************** package body Sem_Ch12 is *** 434,448 **** function Find_Actual_Type (Typ : Entity_Id; ! Gen_Scope : Entity_Id) return Entity_Id; -- When validating the actual types of a child instance, check whether -- the formal is a formal type of the parent unit, and retrieve the current -- actual for it. Typ is the entity in the analyzed formal type declaration -- (component or index type of an array type, or designated type of an ! -- access formal) and Gen_Scope is the scope of the analyzed formal array -- or access type. The desired actual may be a formal of a parent, or may -- be declared in a formal package of a parent. In both cases it is a -- generic actual type because it appears within a visible instance. -- Ambiguities may still arise if two homonyms are declared in two formal -- packages, and the prefix of the formal type may be needed to resolve -- the ambiguity in the instance ??? --- 434,450 ---- function Find_Actual_Type (Typ : Entity_Id; ! Gen_Type : Entity_Id) return Entity_Id; -- When validating the actual types of a child instance, check whether -- the formal is a formal type of the parent unit, and retrieve the current -- actual for it. Typ is the entity in the analyzed formal type declaration -- (component or index type of an array type, or designated type of an ! -- access formal) and Gen_Type is the enclosing analyzed formal array -- or access type. The desired actual may be a formal of a parent, or may -- be declared in a formal package of a parent. In both cases it is a -- generic actual type because it appears within a visible instance. + -- Finally, it may be declared in a parent unit without being a formal + -- of that unit, in which case it must be retrieved by visibility. -- Ambiguities may still arise if two homonyms are declared in two formal -- packages, and the prefix of the formal type may be needed to resolve -- the ambiguity in the instance ??? *************** package body Sem_Ch12 is *** 452,458 **** Inst : Node_Id) return Boolean; -- True if the instantiation Inst and the given freeze_node F_Node appear -- within the same declarative part, ignoring subunits, but with no inter- ! -- vening suprograms or concurrent units. If true, the freeze node -- of the instance can be placed after the freeze node of the parent, -- which it itself an instance. --- 454,460 ---- Inst : Node_Id) return Boolean; -- True if the instantiation Inst and the given freeze_node F_Node appear -- within the same declarative part, ignoring subunits, but with no inter- ! -- vening subprograms or concurrent units. If true, the freeze node -- of the instance can be placed after the freeze node of the parent, -- which it itself an instance. *************** package body Sem_Ch12 is *** 463,469 **** function Is_Generic_Formal (E : Entity_Id) return Boolean; -- Utility to determine whether a given entity is declared by means of ! -- of a formal parameter declaration. Used to set properly the visiblity -- of generic formals of a generic package declared with a box or with -- partial parametrization. --- 465,471 ---- function Is_Generic_Formal (E : Entity_Id) return Boolean; -- Utility to determine whether a given entity is declared by means of ! -- of a formal parameter declaration. Used to set properly the visibility -- of generic formals of a generic package declared with a box or with -- partial parametrization. *************** package body Sem_Ch12 is *** 486,496 **** -- and has already been flipped during this phase of instantiation. procedure Hide_Current_Scope; ! -- When compiling a generic child unit, the parent context must be -- present, but the instance and all entities that may be generated -- must be inserted in the current scope. We leave the current scope -- on the stack, but make its entities invisible to avoid visibility ! -- problems. This is reversed at the end of instantiations. This is -- not done for the instantiation of the bodies, which only require the -- instances of the generic parents to be in scope. --- 488,498 ---- -- and has already been flipped during this phase of instantiation. procedure Hide_Current_Scope; ! -- When instantiating a generic child unit, the parent context must be -- present, but the instance and all entities that may be generated -- must be inserted in the current scope. We leave the current scope -- on the stack, but make its entities invisible to avoid visibility ! -- problems. This is reversed at the end of the instantiation. This is -- not done for the instantiation of the bodies, which only require the -- instances of the generic parents to be in scope. *************** package body Sem_Ch12 is *** 664,670 **** -- -- Nodes that are selected components in the parse tree may be rewritten -- as expanded names after resolution, and must be treated as potential ! -- entity holders. which is why they also have an Associated_Node. -- -- Nodes that do not come from source, such as freeze nodes, do not appear -- in the generic tree, and need not have an associated node. --- 666,672 ---- -- -- Nodes that are selected components in the parse tree may be rewritten -- as expanded names after resolution, and must be treated as potential ! -- entity holders, which is why they also have an Associated_Node. -- -- Nodes that do not come from source, such as freeze nodes, do not appear -- in the generic tree, and need not have an associated node. *************** package body Sem_Ch12 is *** 683,689 **** -- at the end of the enclosing generic package, which is semantically -- neutral. ! procedure Pre_Analyze_Actuals (N : Node_Id); -- Analyze actuals to perform name resolution. Full resolution is done -- later, when the expected types are known, but names have to be captured -- before installing parents of generics, that are not visible for the --- 685,691 ---- -- at the end of the enclosing generic package, which is semantically -- neutral. ! procedure Preanalyze_Actuals (N : Node_Id); -- Analyze actuals to perform name resolution. Full resolution is done -- later, when the expected types are known, but names have to be captured -- before installing parents of generics, that are not visible for the *************** package body Sem_Ch12 is *** 800,806 **** (Pack_Id : Entity_Id; Is_Package : Boolean := True); -- Restore the private views of external types, and unmark the generic ! -- renamings of actuals, so that they become comptible subtypes again. -- For subprograms, Pack_Id is the package constructed to hold the -- renamings. --- 802,808 ---- (Pack_Id : Entity_Id; Is_Package : Boolean := True); -- Restore the private views of external types, and unmark the generic ! -- renamings of actuals, so that they become compatible subtypes again. -- For subprograms, Pack_Id is the package constructed to hold the -- renamings. *************** package body Sem_Ch12 is *** 880,886 **** Default_Formals : constant List_Id := New_List; -- If an Other_Choice is present, some of the formals may be defaulted. ! -- To simplify the treatement of visibility in an instance, we introduce -- individual defaults for each such formal. These defaults are -- appended to the list of associations and replace the Others_Choice. --- 882,888 ---- Default_Formals : constant List_Id := New_List; -- If an Other_Choice is present, some of the formals may be defaulted. ! -- To simplify the treatment of visibility in an instance, we introduce -- individual defaults for each such formal. These defaults are -- appended to the list of associations and replace the Others_Choice. *************** package body Sem_Ch12 is *** 894,901 **** Num_Actuals : Int := 0; Others_Present : Boolean := False; ! -- In Ada 2005, indicates partial parametrization of of a formal ! -- package. As usual an others association must be last in the list. function Matching_Actual (F : Entity_Id; --- 896,903 ---- Num_Actuals : Int := 0; Others_Present : Boolean := False; ! -- In Ada 2005, indicates partial parametrization of a formal ! -- package. As usual an other association must be last in the list. function Matching_Actual (F : Entity_Id; *************** package body Sem_Ch12 is *** 1025,1030 **** --- 1027,1034 ---- procedure Process_Default (F : Entity_Id) is Loc : constant Source_Ptr := Sloc (I_Node); + F_Id : constant Entity_Id := Defining_Entity (F); + Decl : Node_Id; Default : Node_Id; Id : Entity_Id; *************** package body Sem_Ch12 is *** 1034,1050 **** -- new defining identifier for it. Decl := New_Copy_Tree (F); ! if Nkind (F) = N_Formal_Concrete_Subprogram_Declaration then ! Id := ! Make_Defining_Identifier (Sloc (Defining_Entity (F)), ! Chars => Chars (Defining_Entity (F))); Set_Defining_Unit_Name (Specification (Decl), Id); else - Id := - Make_Defining_Identifier (Sloc (Defining_Entity (F)), - Chars => Chars (Defining_Identifier (F))); Set_Defining_Identifier (Decl, Id); end if; --- 1038,1049 ---- -- new defining identifier for it. Decl := New_Copy_Tree (F); + Id := Make_Defining_Identifier (Sloc (F_Id), Chars => Chars (F_Id)); ! if Nkind (F) in N_Formal_Subprogram_Declaration then Set_Defining_Unit_Name (Specification (Decl), Id); else Set_Defining_Identifier (Decl, Id); end if; *************** package body Sem_Ch12 is *** 1066,1071 **** --- 1065,1071 ---- procedure Set_Analyzed_Formal is Kind : Node_Kind; + begin while Present (Analyzed_Formal) loop Kind := Nkind (Analyzed_Formal); *************** package body Sem_Ch12 is *** 1081,1092 **** (Defining_Unit_Name (Specification (Analyzed_Formal))); when N_Formal_Package_Declaration => ! exit when ! Kind = N_Formal_Package_Declaration ! or else ! Kind = N_Generic_Package_Declaration ! or else ! Kind = N_Package_Declaration; when N_Use_Package_Clause | N_Use_Type_Clause => exit; --- 1081,1089 ---- (Defining_Unit_Name (Specification (Analyzed_Formal))); when N_Formal_Package_Declaration => ! exit when Nkind_In (Kind, N_Formal_Package_Declaration, ! N_Generic_Package_Declaration, ! N_Package_Declaration); when N_Use_Package_Clause | N_Use_Type_Clause => exit; *************** package body Sem_Ch12 is *** 1097,1106 **** exit when Kind not in N_Formal_Subprogram_Declaration ! and then Kind /= N_Subprogram_Declaration ! and then Kind /= N_Freeze_Entity ! and then Kind /= N_Null_Statement ! and then Kind /= N_Itype_Reference and then Chars (Defining_Identifier (Formal)) = Chars (Defining_Identifier (Analyzed_Formal)); end case; --- 1094,1103 ---- exit when Kind not in N_Formal_Subprogram_Declaration ! and then not Nkind_In (Kind, N_Subprogram_Declaration, ! N_Freeze_Entity, ! N_Null_Statement, ! N_Itype_Reference) and then Chars (Defining_Identifier (Formal)) = Chars (Defining_Identifier (Analyzed_Formal)); end case; *************** package body Sem_Ch12 is *** 1123,1128 **** --- 1120,1126 ---- while Present (Actual) loop if Nkind (Actual) = N_Others_Choice then Others_Present := True; + if Present (Next (Actual)) then Error_Msg_N ("others must be last association", Actual); end if; *************** package body Sem_Ch12 is *** 1181,1187 **** -- to the outer instantiation. if Nkind (Named) /= N_Others_Choice ! and then Present (Explicit_Generic_Actual_Parameter (Named)) then Num_Actuals := Num_Actuals + 1; end if; --- 1179,1185 ---- -- to the outer instantiation. if Nkind (Named) /= N_Others_Choice ! and then Present (Explicit_Generic_Actual_Parameter (Named)) then Num_Actuals := Num_Actuals + 1; end if; *************** package body Sem_Ch12 is *** 1444,1451 **** end loop; end; ! -- If this is a formal package. normalize the parameter list by adding ! -- explicit box asssociations for the formals that are covered by an -- Others_Choice. if not Is_Empty_List (Default_Formals) then --- 1442,1449 ---- end loop; end; ! -- If this is a formal package, normalize the parameter list by adding ! -- explicit box associations for the formals that are covered by an -- Others_Choice. if not Is_Empty_List (Default_Formals) then *************** package body Sem_Ch12 is *** 1474,1482 **** if Nkind (Def) = N_Constrained_Array_Definition then DSS := First (Discrete_Subtype_Definitions (Def)); while Present (DSS) loop ! if Nkind (DSS) = N_Subtype_Indication ! or else Nkind (DSS) = N_Range ! or else Nkind (DSS) = N_Attribute_Reference then Error_Msg_N ("only a subtype mark is allowed in a formal", DSS); end if; --- 1472,1480 ---- if Nkind (Def) = N_Constrained_Array_Definition then DSS := First (Discrete_Subtype_Definitions (Def)); while Present (DSS) loop ! if Nkind_In (DSS, N_Subtype_Indication, ! N_Range, ! N_Attribute_Reference) then Error_Msg_N ("only a subtype mark is allowed in a formal", DSS); end if; *************** package body Sem_Ch12 is *** 1499,1506 **** elsif Is_Internal (Component_Type (T)) and then Present (Subtype_Indication (Component_Definition (Def))) and then Nkind (Original_Node ! (Subtype_Indication (Component_Definition (Def)))) ! = N_Subtype_Indication then Error_Msg_N ("in a formal, a subtype indication can only be " --- 1497,1504 ---- elsif Is_Internal (Component_Type (T)) and then Present (Subtype_Indication (Component_Definition (Def))) and then Nkind (Original_Node ! (Subtype_Indication (Component_Definition (Def)))) = ! N_Subtype_Indication then Error_Msg_N ("in a formal, a subtype indication can only be " *************** package body Sem_Ch12 is *** 1651,1657 **** Set_Size_Known_At_Compile_Time (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def)))); - end Analyze_Formal_Derived_Type; ---------------------------------- --- 1649,1654 ---- *************** package body Sem_Ch12 is *** 1813,1818 **** --- 1810,1829 ---- Find_Type (Subtype_Mark (N)); T := Entity (Subtype_Mark (N)); + -- Verify that there is no redundant null exclusion. + + if Null_Exclusion_Present (N) then + if not Is_Access_Type (T) then + Error_Msg_N + ("null exclusion can only apply to an access type", N); + + elsif Can_Never_Be_Null (T) then + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + N, T); + end if; + end if; + -- Ada 2005 (AI-423): Formal object with an access definition else *************** package body Sem_Ch12 is *** 1854,1860 **** end if; if Present (E) then ! Analyze_Per_Use_Expression (E, T); if Is_Limited_Type (T) and then not OK_For_Limited_Init (E) then Error_Msg_N --- 1865,1871 ---- end if; if Present (E) then ! Preanalyze_Spec_Expression (E, T); if Is_Limited_Type (T) and then not OK_For_Limited_Init (E) then Error_Msg_N *************** package body Sem_Ch12 is *** 1970,1976 **** -- The formal package is rewritten so that its parameters are replaced -- with corresponding declarations. For parameters with bona fide -- associations these declarations are created by Analyze_Associations ! -- as for aa regular instantiation. For boxed parameters, we preserve -- the formal declarations and analyze them, in order to introduce -- entities of the right kind in the environment of the formal. --- 1981,1987 ---- -- The formal package is rewritten so that its parameters are replaced -- with corresponding declarations. For parameters with bona fide -- associations these declarations are created by Analyze_Associations ! -- as for a regular instantiation. For boxed parameters, we preserve -- the formal declarations and analyze them, in order to introduce -- entities of the right kind in the environment of the formal. *************** package body Sem_Ch12 is *** 2364,2394 **** -- Default name may be overloaded, in which case the interpretation -- with the correct profile must be selected, as for a renaming. if Etype (Def) = Any_Type then return; elsif Nkind (Def) = N_Selected_Component then ! Subp := Entity (Selector_Name (Def)); ! ! if Ekind (Subp) /= E_Entry then Error_Msg_N ("expect valid subprogram name as default", Def); - return; end if; elsif Nkind (Def) = N_Indexed_Component then ! if Nkind (Prefix (Def)) /= N_Selected_Component then ! Error_Msg_N ("expect valid subprogram name as default", Def); ! return; ! ! else ! Subp := Entity (Selector_Name (Prefix (Def))); ! ! if Ekind (Subp) /= E_Entry_Family then Error_Msg_N ("expect valid subprogram name as default", Def); - return; end if; end if; elsif Nkind (Def) = N_Character_Literal then --- 2375,2408 ---- -- Default name may be overloaded, in which case the interpretation -- with the correct profile must be selected, as for a renaming. + -- If the definition is an indexed component, it must denote a + -- member of an entry family. If it is a selected component, it + -- can be a protected operation. if Etype (Def) = Any_Type then return; elsif Nkind (Def) = N_Selected_Component then ! if not Is_Overloadable (Entity (Selector_Name (Def))) then Error_Msg_N ("expect valid subprogram name as default", Def); end if; elsif Nkind (Def) = N_Indexed_Component then + if Is_Entity_Name (Prefix (Def)) then + if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then + Error_Msg_N ("expect valid subprogram name as default", Def); + end if; ! elsif Nkind (Prefix (Def)) = N_Selected_Component then ! if Ekind (Entity (Selector_Name (Prefix (Def)))) ! /= E_Entry_Family ! then Error_Msg_N ("expect valid subprogram name as default", Def); end if; + + else + Error_Msg_N ("expect valid subprogram name as default", Def); + return; end if; elsif Nkind (Def) = N_Character_Literal then *************** package body Sem_Ch12 is *** 2413,2418 **** --- 2427,2434 ---- Error_Msg_N ("no visible entity matches specification", Def); end if; + -- More than one interpretation, so disambiguate as for a renaming + else declare I : Interp_Index; *************** package body Sem_Ch12 is *** 2424,2430 **** Subp := Any_Id; Get_First_Interp (Def, I, It); while Present (It.Nam) loop - if Entity_Matches_Spec (It.Nam, Nam) then if Subp /= Any_Id then It1 := Disambiguate (Def, I1, I, Etype (Subp)); --- 2440,2445 ---- *************** package body Sem_Ch12 is *** 2726,2732 **** Save_Parent : Node_Id; begin ! -- Create copy of generic unit,and save for instantiation. If the unit -- is a child unit, do not copy the specifications for the parent, which -- are not part of the generic tree. --- 2741,2747 ---- Save_Parent : Node_Id; begin ! -- Create copy of generic unit, and save for instantiation. If the unit -- is a child unit, do not copy the specifications for the parent, which -- are not part of the generic tree. *************** package body Sem_Ch12 is *** 2910,2916 **** end if; Generate_Definition (Act_Decl_Id); ! Pre_Analyze_Actuals (N); Init_Env; Env_Installed := True; --- 2925,2931 ---- end if; Generate_Definition (Act_Decl_Id); ! Preanalyze_Actuals (N); Init_Env; Env_Installed := True; *************** package body Sem_Ch12 is *** 3124,3130 **** Inline_Now := True; -- In configurable_run_time mode we force the inlining of ! -- predefined subprogram marked Inline_Always, to minimize -- the use of the run-time library. elsif Is_Predefined_File_Name --- 3139,3145 ---- Inline_Now := True; -- In configurable_run_time mode we force the inlining of ! -- predefined subprograms marked Inline_Always, to minimize -- the use of the run-time library. elsif Is_Predefined_File_Name *************** package body Sem_Ch12 is *** 3184,3190 **** -- body to instantiate until the enclosing generic is instantiated -- and there is an actual for the formal package. If the formal -- package has parameters, we build a regular package instance for ! -- it, that preceeds the original formal package declaration. if In_Open_Scopes (Scope (Scope (Gen_Unit))) then declare --- 3199,3205 ---- -- body to instantiate until the enclosing generic is instantiated -- and there is an actual for the formal package. If the formal -- package has parameters, we build a regular package instance for ! -- it, that precedes the original formal package declaration. if In_Open_Scopes (Scope (Scope (Gen_Unit))) then declare *************** package body Sem_Ch12 is *** 3194,3203 **** begin if Nkind (Decl) = N_Formal_Package_Declaration or else (Nkind (Decl) = N_Package_Declaration ! and then Is_List_Member (Decl) ! and then Present (Next (Decl)) ! and then ! Nkind (Next (Decl)) = N_Formal_Package_Declaration) then Needs_Body := False; end if; --- 3209,3219 ---- begin if Nkind (Decl) = N_Formal_Package_Declaration or else (Nkind (Decl) = N_Package_Declaration ! and then Is_List_Member (Decl) ! and then Present (Next (Decl)) ! and then ! Nkind (Next (Decl)) = ! N_Formal_Package_Declaration) then Needs_Body := False; end if; *************** package body Sem_Ch12 is *** 3341,3348 **** -- on current node so context is complete for analysis (including -- nested instantiations). If this is the main unit, the declaration -- eventually replaces the instantiation node. If the instance body ! -- is later created, it replaces the instance node, and the declation ! -- is attached to it (see Build_Instance_Compilation_Unit_Nodes). else if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then --- 3357,3365 ---- -- on current node so context is complete for analysis (including -- nested instantiations). If this is the main unit, the declaration -- eventually replaces the instantiation node. If the instance body ! -- is created later, it replaces the instance node, and the ! -- declaration is attached to it (see ! -- Build_Instance_Compilation_Unit_Nodes). else if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then *************** package body Sem_Ch12 is *** 3538,3544 **** -- removed previously. -- If current scope is the body of a child unit, remove context of ! -- spec as well. If an enclosing scope is an instance body. the -- context has already been removed, but the entities in the body -- must be made invisible as well. --- 3555,3561 ---- -- removed previously. -- If current scope is the body of a child unit, remove context of ! -- spec as well. If an enclosing scope is an instance body, the -- context has already been removed, but the entities in the body -- must be made invisible as well. *************** package body Sem_Ch12 is *** 3750,3755 **** --- 3767,3804 ---- Analyze_Subprogram_Instantiation (N, E_Procedure); end Analyze_Procedure_Instantiation; + ----------------------------------- + -- Need_Subprogram_Instance_Body -- + ----------------------------------- + + function Need_Subprogram_Instance_Body + (N : Node_Id; + Subp : Entity_Id) return Boolean + is + begin + if (Is_In_Main_Unit (N) + or else Is_Inlined (Subp) + or else Is_Inlined (Alias (Subp))) + and then (Operating_Mode = Generate_Code + or else (Operating_Mode = Check_Semantics + and then ASIS_Mode)) + and then (Expander_Active or else ASIS_Mode) + and then not ABE_Is_Certain (N) + and then not Is_Eliminated (Subp) + then + Pending_Instantiations.Append + ((Inst_Node => N, + Act_Decl => Unit_Declaration_Node (Subp), + Expander_Status => Expander_Active, + Current_Sem_Unit => Current_Sem_Unit, + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)); + return True; + else + return False; + end if; + end Need_Subprogram_Instance_Body; + -------------------------------------- -- Analyze_Subprogram_Instantiation -- -------------------------------------- *************** package body Sem_Ch12 is *** 3825,3831 **** Set_Instance_Spec (N, Pack_Decl); Set_Is_Generic_Instance (Pack_Id); ! Set_Needs_Debug_Info (Pack_Id); -- Case of not a compilation unit --- 3874,3880 ---- Set_Instance_Spec (N, Pack_Decl); Set_Is_Generic_Instance (Pack_Id); ! Set_Debug_Info_Needed (Pack_Id); -- Case of not a compilation unit *************** package body Sem_Ch12 is *** 3875,3881 **** end if; Set_Is_Generic_Instance (Anon_Id); ! Set_Needs_Debug_Info (Anon_Id); Act_Decl_Id := New_Copy (Anon_Id); Set_Parent (Act_Decl_Id, Parent (Anon_Id)); --- 3924,3930 ---- end if; Set_Is_Generic_Instance (Anon_Id); ! Set_Debug_Info_Needed (Anon_Id); Act_Decl_Id := New_Copy (Anon_Id); Set_Parent (Act_Decl_Id, Parent (Anon_Id)); *************** package body Sem_Ch12 is *** 3887,3895 **** -- subprogram will be frozen at the point the wrapper package is -- frozen, so it does not need its own freeze node. In fact, if one -- is created, it might conflict with the freezing actions from the ! -- wrapper package (see 7206-013). ! ! -- Should not really reference non-public TN's in comments ??? Set_Has_Delayed_Freeze (Anon_Id, False); --- 3936,3942 ---- -- subprogram will be frozen at the point the wrapper package is -- frozen, so it does not need its own freeze node. In fact, if one -- is created, it might conflict with the freezing actions from the ! -- wrapper package. Set_Has_Delayed_Freeze (Anon_Id, False); *************** package body Sem_Ch12 is *** 3945,3951 **** -- Make node global for error reporting Instantiation_Node := N; ! Pre_Analyze_Actuals (N); Init_Env; Env_Installed := True; --- 3992,3998 ---- -- Make node global for error reporting Instantiation_Node := N; ! Preanalyze_Actuals (N); Init_Env; Env_Installed := True; *************** package body Sem_Ch12 is *** 4042,4048 **** --- 4089,4100 ---- Copy_Generic_Node (Original_Node (Gen_Decl), Empty, Instantiating => True); + -- Inherit overriding indicator from instance node + Act_Spec := Specification (Act_Tree); + Set_Must_Override (Act_Spec, Must_Override (N)); + Set_Must_Not_Override (Act_Spec, Must_Not_Override (N)); + Renaming_List := Analyze_Associations (N, *************** package body Sem_Ch12 is *** 4138,4159 **** -- If the context requires a full instantiation, mark node for -- subsequent construction of the body. ! if (Is_In_Main_Unit (N) ! or else Is_Inlined (Act_Decl_Id)) ! and then (Operating_Mode = Generate_Code ! or else (Operating_Mode = Check_Semantics ! and then ASIS_Mode)) ! and then (Expander_Active or else ASIS_Mode) ! and then not ABE_Is_Certain (N) ! and then not Is_Eliminated (Act_Decl_Id) ! then ! Pending_Instantiations.Append ! ((Inst_Node => N, ! Act_Decl => Act_Decl, ! Expander_Status => Expander_Active, ! Current_Sem_Unit => Current_Sem_Unit, ! Scope_Suppress => Scope_Suppress, ! Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)); Check_Forward_Instantiation (Gen_Decl); --- 4190,4196 ---- -- If the context requires a full instantiation, mark node for -- subsequent construction of the body. ! if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then Check_Forward_Instantiation (Gen_Decl); *************** package body Sem_Ch12 is *** 4207,4221 **** ------------------------- function Get_Associated_Node (N : Node_Id) return Node_Id is ! Assoc : Node_Id := Associated_Node (N); begin if Nkind (Assoc) /= Nkind (N) then return Assoc; ! elsif Nkind (Assoc) = N_Aggregate ! or else Nkind (Assoc) = N_Extension_Aggregate ! then return Assoc; else --- 4244,4258 ---- ------------------------- function Get_Associated_Node (N : Node_Id) return Node_Id is ! Assoc : Node_Id; begin + Assoc := Associated_Node (N); + if Nkind (Assoc) /= Nkind (N) then return Assoc; ! elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then return Assoc; else *************** package body Sem_Ch12 is *** 4235,4249 **** if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op) and then Present (Associated_Node (Assoc)) ! and then (Nkind (Associated_Node (Assoc)) = N_Function_Call ! or else ! Nkind (Associated_Node (Assoc)) = N_Explicit_Dereference ! or else ! Nkind (Associated_Node (Assoc)) = N_Integer_Literal ! or else ! Nkind (Associated_Node (Assoc)) = N_Real_Literal ! or else ! Nkind (Associated_Node (Assoc)) = N_String_Literal) then Assoc := Associated_Node (Assoc); end if; --- 4272,4282 ---- if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op) and then Present (Associated_Node (Assoc)) ! and then (Nkind_In (Associated_Node (Assoc), N_Function_Call, ! N_Explicit_Dereference, ! N_Integer_Literal, ! N_Real_Literal, ! N_String_Literal)) then Assoc := Associated_Node (Assoc); end if; *************** package body Sem_Ch12 is *** 4396,4404 **** if Kind = N_Formal_Type_Declaration then return; ! elsif Kind = N_Formal_Object_Declaration or else Kind in N_Formal_Subprogram_Declaration - or else Kind = N_Formal_Package_Declaration then null; --- 4429,4437 ---- if Kind = N_Formal_Type_Declaration then return; ! elsif Nkind_In (Kind, N_Formal_Object_Declaration, ! N_Formal_Package_Declaration) or else Kind in N_Formal_Subprogram_Declaration then null; *************** package body Sem_Ch12 is *** 4519,4525 **** if No (E1) then return; ! -- If the formal entity comes from a formal declaration. it was -- defaulted in the formal package, and no check is needed on it. elsif Nkind (Parent (E2)) = N_Formal_Object_Declaration then --- 4552,4558 ---- if No (E1) then return; ! -- If the formal entity comes from a formal declaration, it was -- defaulted in the formal package, and no check is needed on it. elsif Nkind (Parent (E2)) = N_Formal_Object_Declaration then *************** package body Sem_Ch12 is *** 4628,4638 **** elsif Is_Overloadable (E1) then ! -- Verify that the names of the entities match. Note that actuals ! -- that are attributes are rewritten as subprograms. ! Check_Mismatch ! (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2)); else raise Program_Error; --- 4661,4682 ---- elsif Is_Overloadable (E1) then ! -- Verify that the actual subprograms match. Note that actuals ! -- that are attributes are rewritten as subprograms. If the ! -- subprogram in the formal package is defaulted, no check is ! -- needed. Note that this can only happen in Ada 2005 when the ! -- formal package can be partially parametrized. ! if Nkind (Unit_Declaration_Node (E1)) = ! N_Subprogram_Renaming_Declaration ! and then From_Default (Unit_Declaration_Node (E1)) ! then ! null; ! ! else ! Check_Mismatch ! (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2)); ! end if; else raise Program_Error; *************** package body Sem_Ch12 is *** 4695,4701 **** begin -- The instantiation appears before the generic body if we are in the -- scope of the unit containing the generic, either in its spec or in ! -- the package body. and before the generic body. if Ekind (Gen_Comp) = E_Package_Body then Gen_Comp := Spec_Entity (Gen_Comp); --- 4739,4745 ---- begin -- The instantiation appears before the generic body if we are in the -- scope of the unit containing the generic, either in its spec or in ! -- the package body, and before the generic body. if Ekind (Gen_Comp) = E_Package_Body then Gen_Comp := Spec_Entity (Gen_Comp); *************** package body Sem_Ch12 is *** 5158,5165 **** Inst_Par := Entity (Prefix (Gen_Id)); while Present (Inst_Par) ! and then Ekind (Inst_Par) /= E_Package ! and then Ekind (Inst_Par) /= E_Generic_Package loop Inst_Par := Homonym (Inst_Par); end loop; --- 5202,5208 ---- Inst_Par := Entity (Prefix (Gen_Id)); while Present (Inst_Par) ! and then not Is_Package_Or_Generic_Package (Inst_Par) loop Inst_Par := Homonym (Inst_Par); end loop; *************** package body Sem_Ch12 is *** 5625,5634 **** -- Special casing for identifiers and other entity names and operators ! elsif Nkind (New_N) = N_Identifier ! or else Nkind (New_N) = N_Character_Literal ! or else Nkind (New_N) = N_Expanded_Name ! or else Nkind (New_N) = N_Operator_Symbol or else Nkind (New_N) in N_Op then if not Instantiating then --- 5668,5677 ---- -- Special casing for identifiers and other entity names and operators ! elsif Nkind_In (New_N, N_Identifier, ! N_Character_Literal, ! N_Expanded_Name, ! N_Operator_Symbol) or else Nkind (New_N) in N_Op then if not Instantiating then *************** package body Sem_Ch12 is *** 5673,5692 **** elsif No (Ent) or else ! not (Nkind (Ent) = N_Defining_Identifier ! or else ! Nkind (Ent) = N_Defining_Character_Literal ! or else ! Nkind (Ent) = N_Defining_Operator_Symbol) or else No (Scope (Ent)) or else (Scope (Ent) = Current_Instantiated_Parent.Gen_Id and then not Is_Child_Unit (Ent)) ! or else (Scope_Depth (Scope (Ent)) > Scope_Depth (Current_Instantiated_Parent.Gen_Id) ! and then ! Get_Source_Unit (Ent) = ! Get_Source_Unit (Current_Instantiated_Parent.Gen_Id)) then Set_Associated_Node (New_N, Empty); end if; --- 5716,5734 ---- elsif No (Ent) or else ! not Nkind_In (Ent, N_Defining_Identifier, ! N_Defining_Character_Literal, ! N_Defining_Operator_Symbol) or else No (Scope (Ent)) or else (Scope (Ent) = Current_Instantiated_Parent.Gen_Id and then not Is_Child_Unit (Ent)) ! or else ! (Scope_Depth (Scope (Ent)) > Scope_Depth (Current_Instantiated_Parent.Gen_Id) ! and then ! Get_Source_Unit (Ent) = ! Get_Source_Unit (Current_Instantiated_Parent.Gen_Id)) then Set_Associated_Node (New_N, Empty); end if; *************** package body Sem_Ch12 is *** 5702,5707 **** --- 5744,5750 ---- declare Assoc : constant Node_Id := Get_Associated_Node (N); + begin if Present (Assoc) then if Nkind (Assoc) = Nkind (N) then *************** package body Sem_Ch12 is *** 5711,5719 **** elsif Nkind (Assoc) = N_Function_Call then Set_Entity (New_N, Entity (Name (Assoc))); ! elsif (Nkind (Assoc) = N_Defining_Identifier ! or else Nkind (Assoc) = N_Defining_Character_Literal ! or else Nkind (Assoc) = N_Defining_Operator_Symbol) and then Expander_Active then -- Inlining case: we are copying a tree that contains --- 5754,5762 ---- elsif Nkind (Assoc) = N_Function_Call then Set_Entity (New_N, Entity (Name (Assoc))); ! elsif Nkind_In (Assoc, N_Defining_Identifier, ! N_Defining_Character_Literal, ! N_Defining_Operator_Symbol) and then Expander_Active then -- Inlining case: we are copying a tree that contains *************** package body Sem_Ch12 is *** 5771,5777 **** -- If we are not instantiating, then this is where we load and -- analyze subunits, i.e. at the point where the stub occurs. A ! -- more permissivle system might defer this analysis to the point -- of instantiation, but this seems to complicated for now. if not Instantiating then --- 5814,5820 ---- -- If we are not instantiating, then this is where we load and -- analyze subunits, i.e. at the point where the stub occurs. A ! -- more permissible system might defer this analysis to the point -- of instantiation, but this seems to complicated for now. if not Instantiating then *************** package body Sem_Ch12 is *** 5790,5796 **** Error_Node => N); -- If the proper body is not found, a warning message will be ! -- emitted when analyzing the stub, or later at the the point -- of instantiation. Here we just leave the stub as is. if Unum = No_Unit then --- 5833,5839 ---- Error_Node => N); -- If the proper body is not found, a warning message will be ! -- emitted when analyzing the stub, or later at the point -- of instantiation. Here we just leave the stub as is. if Unum = No_Unit then *************** package body Sem_Ch12 is *** 5857,5863 **** -- unit field of N points to the parent unit (which is a compilation -- unit) and need not (and cannot!) be copied. ! -- When the proper body of the stub is analyzed, thie library_unit link -- is used to establish the proper context (see sem_ch10). -- The other fields of a compilation unit are copied as usual --- 5900,5906 ---- -- unit field of N points to the parent unit (which is a compilation -- unit) and need not (and cannot!) be copied. ! -- When the proper body of the stub is analyzed, the library_unit link -- is used to establish the proper context (see sem_ch10). -- The other fields of a compilation unit are copied as usual *************** package body Sem_Ch12 is *** 5902,5910 **** Set_Assignment_OK (Name (New_N), True); end if; ! elsif Nkind (N) = N_Aggregate ! or else Nkind (N) = N_Extension_Aggregate ! then if not Instantiating then Set_Associated_Node (N, New_N); --- 5945,5951 ---- Set_Assignment_OK (Name (New_N), True); end if; ! elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then if not Instantiating then Set_Associated_Node (N, New_N); *************** package body Sem_Ch12 is *** 6029,6050 **** and then Instantiating then declare ! Prag_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N)); ! begin if Prag_Id = Pragma_Ident or else Prag_Id = Pragma_Comment then New_N := Make_Null_Statement (Sloc (N)); - else Copy_Descendants; end if; end; ! elsif Nkind (N) = N_Integer_Literal ! or else Nkind (N) = N_Real_Literal ! or else Nkind (N) = N_String_Literal then -- No descendant fields need traversing --- 6070,6089 ---- and then Instantiating then declare ! Prag_Id : constant Pragma_Id := Get_Pragma_Id (N); begin if Prag_Id = Pragma_Ident or else Prag_Id = Pragma_Comment then New_N := Make_Null_Statement (Sloc (N)); else Copy_Descendants; end if; end; ! elsif Nkind_In (N, N_Integer_Literal, ! N_Real_Literal, ! N_String_Literal) then -- No descendant fields need traversing *************** package body Sem_Ch12 is *** 6145,6164 **** ---------------------- function Find_Actual_Type ! (Typ : Entity_Id; ! Gen_Scope : Entity_Id) return Entity_Id is ! T : Entity_Id; begin if not Is_Child_Unit (Gen_Scope) then return Get_Instance_Of (Typ); elsif not Is_Generic_Type (Typ) ! or else Scope (Typ) = Gen_Scope then return Get_Instance_Of (Typ); else T := Current_Entity (Typ); while Present (T) loop --- 6184,6217 ---- ---------------------- function Find_Actual_Type ! (Typ : Entity_Id; ! Gen_Type : Entity_Id) return Entity_Id is ! Gen_Scope : constant Entity_Id := Scope (Gen_Type); ! T : Entity_Id; begin + -- Special processing only applies to child units + if not Is_Child_Unit (Gen_Scope) then return Get_Instance_Of (Typ); + -- If designated or component type is itself a formal of the child unit, + -- its instance is available. + + elsif Scope (Typ) = Gen_Scope then + return Get_Instance_Of (Typ); + + -- If the array or access type is not declared in the parent unit, + -- no special processing needed. + elsif not Is_Generic_Type (Typ) ! and then Scope (Gen_Scope) /= Scope (Typ) then return Get_Instance_Of (Typ); + -- Otherwise, retrieve designated or component type by visibility + else T := Current_Entity (Typ); while Present (T) loop *************** package body Sem_Ch12 is *** 6237,6243 **** end loop; end Find_Depth; ! -- Start of procesing for Earlier begin Find_Depth (P1, D1); --- 6290,6296 ---- end loop; end Find_Depth; ! -- Start of processing for Earlier begin Find_Depth (P1, D1); *************** package body Sem_Ch12 is *** 6354,6360 **** begin -- If the instance and the generic body appear within the same unit, and ! -- the instance preceeds the generic, the freeze node for the instance -- must appear after that of the generic. If the generic is nested -- within another instance I2, then current instance must be frozen -- after I2. In both cases, the freeze nodes are those of enclosing --- 6407,6413 ---- begin -- If the instance and the generic body appear within the same unit, and ! -- the instance precedes the generic, the freeze node for the instance -- must appear after that of the generic. If the generic is nested -- within another instance I2, then current instance must be frozen -- after I2. In both cases, the freeze nodes are those of enclosing *************** package body Sem_Ch12 is *** 6397,6403 **** or else (Nkind (Enc_I) = N_Package_Body and then ! In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I))) then -- The enclosing package may contain several instances. Rather -- than computing the earliest point at which to insert its --- 6450,6456 ---- or else (Nkind (Enc_I) = N_Package_Body and then ! In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I))) then -- The enclosing package may contain several instances. Rather -- than computing the earliest point at which to insert its *************** package body Sem_Ch12 is *** 6511,6518 **** if Nkind (Package_Instantiation (A)) = N_Package_Instantiation then return Package_Instantiation (A); ! elsif Nkind (Original_Node (Package_Instantiation (A))) ! = N_Package_Instantiation then return Original_Node (Package_Instantiation (A)); end if; --- 6564,6571 ---- if Nkind (Package_Instantiation (A)) = N_Package_Instantiation then return Package_Instantiation (A); ! elsif Nkind (Original_Node (Package_Instantiation (A))) = ! N_Package_Instantiation then return Original_Node (Package_Instantiation (A)); end if; *************** package body Sem_Ch12 is *** 6554,6561 **** else Inst := Next (Decl); ! while Nkind (Inst) /= N_Package_Instantiation ! and then Nkind (Inst) /= N_Formal_Package_Declaration loop Next (Inst); end loop; --- 6607,6614 ---- else Inst := Next (Decl); ! while not Nkind_In (Inst, N_Package_Instantiation, ! N_Formal_Package_Declaration) loop Next (Inst); end loop; *************** package body Sem_Ch12 is *** 6677,6687 **** if Nod = Decls then return True; ! elsif Nkind (Nod) = N_Subprogram_Body ! or else Nkind (Nod) = N_Package_Body ! or else Nkind (Nod) = N_Task_Body ! or else Nkind (Nod) = N_Protected_Body ! or else Nkind (Nod) = N_Block_Statement then return False; --- 6730,6740 ---- if Nod = Decls then return True; ! elsif Nkind_In (Nod, N_Subprogram_Body, ! N_Package_Body, ! N_Task_Body, ! N_Protected_Body, ! N_Block_Statement) then return False; *************** package body Sem_Ch12 is *** 6690,6695 **** --- 6743,6749 ---- elsif Nkind (Nod) = N_Compilation_Unit then return False; + else Nod := Parent (Nod); end if; *************** package body Sem_Ch12 is *** 6728,6734 **** -- might produce false positives in rare cases, but guarantees -- that we produce all the instance bodies we will need. ! if (Nkind (Nam) = N_Identifier and then Chars (Nam) = Chars (E)) or else (Nkind (Nam) = N_Selected_Component and then Chars (Selector_Name (Nam)) = Chars (E)) --- 6782,6788 ---- -- might produce false positives in rare cases, but guarantees -- that we produce all the instance bodies we will need. ! if (Is_Entity_Name (Nam) and then Chars (Nam) = Chars (E)) or else (Nkind (Nam) = N_Selected_Component and then Chars (Selector_Name (Nam)) = Chars (E)) *************** package body Sem_Ch12 is *** 6758,6764 **** -- The inherited context is attached to the enclosing compilation -- unit. This is either the main unit, or the declaration for the ! -- main unit (in case the instantation appears within the package -- declaration and the main unit is its body). Current_Unit := Parent (Inst); --- 6812,6818 ---- -- The inherited context is attached to the enclosing compilation -- unit. This is either the main unit, or the declaration for the ! -- main unit (in case the instantiation appears within the package -- declaration and the main unit is its body). Current_Unit := Parent (Inst); *************** package body Sem_Ch12 is *** 6895,6900 **** --- 6949,6955 ---- -- Start of processing for Install_Body begin + -- If the body is a subunit, the freeze point is the corresponding -- stub in the current compilation, not the subunit itself. *************** package body Sem_Ch12 is *** 6919,6926 **** Must_Delay := (Gen_Unit = Act_Unit ! and then ((Nkind (Gen_Unit) = N_Package_Declaration) ! or else Nkind (Gen_Unit) = N_Generic_Package_Declaration or else (Gen_Unit = Body_Unit and then True_Sloc (N) < Sloc (Orig_Body))) and then Is_In_Main_Unit (Gen_Unit) --- 6974,6981 ---- Must_Delay := (Gen_Unit = Act_Unit ! and then (Nkind_In (Gen_Unit, N_Package_Declaration, ! N_Generic_Package_Declaration) or else (Gen_Unit = Body_Unit and then True_Sloc (N) < Sloc (Orig_Body))) and then Is_In_Main_Unit (Gen_Unit) *************** package body Sem_Ch12 is *** 7242,7248 **** Actual_Ent : Entity_Id); -- Associates the formal entity with the actual. In the case -- where Formal_Ent is a formal package, this procedure iterates ! -- through all of its formals and enters associations betwen the -- actuals occurring in the formal package's corresponding actual -- package (given by Actual_Ent) and the formal package's formal -- parameters. This procedure recurses if any of the parameters is --- 7297,7303 ---- Actual_Ent : Entity_Id); -- Associates the formal entity with the actual. In the case -- where Formal_Ent is a formal package, this procedure iterates ! -- through all of its formals and enters associations between the -- actuals occurring in the formal package's corresponding actual -- package (given by Actual_Ent) and the formal package's formal -- parameters. This procedure recurses if any of the parameters is *************** package body Sem_Ch12 is *** 7259,7265 **** procedure Map_Entities (Form : Entity_Id; Act : Entity_Id); -- Within the generic part, entities in the formal package are -- visible. To validate subsequent type declarations, indicate ! -- the correspondence betwen the entities in the analyzed formal, -- and the entities in the actual package. There are three packages -- involved in the instantiation of a formal package: the parent -- generic P1 which appears in the generic declaration, the fake --- 7314,7320 ---- procedure Map_Entities (Form : Entity_Id; Act : Entity_Id); -- Within the generic part, entities in the formal package are -- visible. To validate subsequent type declarations, indicate ! -- the correspondence between the entities in the analyzed formal, -- and the entities in the actual package. There are three packages -- involved in the instantiation of a formal package: the parent -- generic P1 which appears in the generic declaration, the fake *************** package body Sem_Ch12 is *** 7827,7836 **** end if; if (Present (Act_E) and then Is_Overloadable (Act_E)) ! or else Nkind (Act) = N_Attribute_Reference ! or else Nkind (Act) = N_Indexed_Component ! or else Nkind (Act) = N_Character_Literal ! or else Nkind (Act) = N_Explicit_Dereference then return; end if; --- 7882,7891 ---- end if; if (Present (Act_E) and then Is_Overloadable (Act_E)) ! or else Nkind_In (Act, N_Attribute_Reference, ! N_Indexed_Component, ! N_Character_Literal, ! N_Explicit_Dereference) then return; end if; *************** package body Sem_Ch12 is *** 7900,7909 **** Nam := Actual; elsif Present (Default_Name (Formal)) then ! if Nkind (Default_Name (Formal)) /= N_Attribute_Reference ! and then Nkind (Default_Name (Formal)) /= N_Selected_Component ! and then Nkind (Default_Name (Formal)) /= N_Indexed_Component ! and then Nkind (Default_Name (Formal)) /= N_Character_Literal and then Present (Entity (Default_Name (Formal))) then Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc); --- 7955,7964 ---- Nam := Actual; elsif Present (Default_Name (Formal)) then ! if not Nkind_In (Default_Name (Formal), N_Attribute_Reference, ! N_Selected_Component, ! N_Indexed_Component, ! N_Character_Literal) and then Present (Entity (Default_Name (Formal))) then Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc); *************** package body Sem_Ch12 is *** 8194,8200 **** Resolve (Actual, Ftyp); ! if not Is_Variable (Actual) or else Paren_Count (Actual) > 0 then Error_Msg_NE ("actual for& must be a variable", Actual, Formal_Id); --- 8249,8255 ---- Resolve (Actual, Ftyp); ! if not Denotes_Variable (Actual) then Error_Msg_NE ("actual for& must be a variable", Actual, Formal_Id); *************** package body Sem_Ch12 is *** 8217,8223 **** end if; end if; ! Note_Possible_Modification (Actual); -- Check for instantiation of atomic/volatile actual for -- non-atomic/volatile formal (RM C.6 (12)). --- 8272,8278 ---- end if; end if; ! Note_Possible_Modification (Actual, Sure => True); -- Check for instantiation of atomic/volatile actual for -- non-atomic/volatile formal (RM C.6 (12)). *************** package body Sem_Ch12 is *** 8271,8277 **** Append (Decl_Node, List); -- No need to repeat (pre-)analysis of some expression nodes ! -- already handled in Pre_Analyze_Actuals. if Nkind (Actual) /= N_Allocator then Analyze (Actual); --- 8326,8332 ---- Append (Decl_Node, List); -- No need to repeat (pre-)analysis of some expression nodes ! -- already handled in Preanalyze_Actuals. if Nkind (Actual) /= N_Allocator then Analyze (Actual); *************** package body Sem_Ch12 is *** 8297,8303 **** -- a child unit. if Nkind (Actual) = N_Aggregate then ! Pre_Analyze_And_Resolve (Actual, Typ); end if; if Is_Limited_Type (Typ) --- 8352,8358 ---- -- a child unit. if Nkind (Actual) = N_Aggregate then ! Preanalyze_And_Resolve (Actual, Typ); end if; if Is_Limited_Type (Typ) *************** package body Sem_Ch12 is *** 8324,8331 **** Defining_Identifier => New_Copy (Formal_Id), Constant_Present => True, Object_Definition => New_Copy (Def), ! Expression => New_Copy_Tree (Default_Expression ! (Formal))); Append (Decl_Node, List); Set_Analyzed (Expression (Decl_Node), False); --- 8379,8386 ---- Defining_Identifier => New_Copy (Formal_Id), Constant_Present => True, Object_Definition => New_Copy (Def), ! Expression => New_Copy_Tree ! (Default_Expression (Formal))); Append (Decl_Node, List); Set_Analyzed (Expression (Decl_Node), False); *************** package body Sem_Ch12 is *** 8356,8364 **** Constant_Present => True, Object_Definition => New_Copy (Def), Expression => ! Make_Attribute_Reference (Sloc (Formal_Id), ! Attribute_Name => Name_First, ! Prefix => New_Copy (Def))); Append (Decl_Node, List); --- 8411,8419 ---- Constant_Present => True, Object_Definition => New_Copy (Def), Expression => ! Make_Attribute_Reference (Sloc (Formal_Id), ! Attribute_Name => Name_First, ! Prefix => New_Copy (Def))); Append (Decl_Node, List); *************** package body Sem_Ch12 is *** 8385,8400 **** if Ada_Version >= Ada_05 and then Present (Actual_Decl) and then ! (Nkind (Actual_Decl) = N_Formal_Object_Declaration ! or else Nkind (Actual_Decl) = N_Object_Declaration) and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration ! and then Has_Null_Exclusion (Actual_Decl) ! and then not Has_Null_Exclusion (Analyzed_Formal) then ! Error_Msg_Sloc := Sloc (Actual_Decl); Error_Msg_N ! ("`NOT NULL` required in formal, to match actual #", ! Analyzed_Formal); end if; return List; --- 8440,8454 ---- if Ada_Version >= Ada_05 and then Present (Actual_Decl) and then ! Nkind_In (Actual_Decl, N_Formal_Object_Declaration, ! N_Object_Declaration) and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration ! and then not Has_Null_Exclusion (Actual_Decl) ! and then Has_Null_Exclusion (Analyzed_Formal) then ! Error_Msg_Sloc := Sloc (Analyzed_Formal); Error_Msg_N ! ("actual must exclude null to match generic formal#", Actual); end if; return List; *************** package body Sem_Ch12 is *** 8604,8610 **** ("cannot find body of generic package &", Inst_Node, Gen_Unit); -- Don't attempt to perform any cleanup actions if some other error ! -- was aready detected, since this can cause blowups. else return; --- 8658,8664 ---- ("cannot find body of generic package &", Inst_Node, Gen_Unit); -- Don't attempt to perform any cleanup actions if some other error ! -- was already detected, since this can cause blowups. else return; *************** package body Sem_Ch12 is *** 8629,8635 **** Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id); -- If the instantiation is not a library unit, then append the ! -- declaration to the list of implicitly generated entities. unless -- it is already a list member which means that it was already -- processed --- 8683,8689 ---- Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id); -- If the instantiation is not a library unit, then append the ! -- declaration to the list of implicitly generated entities, unless -- it is already a list member which means that it was already -- processed *************** package body Sem_Ch12 is *** 8647,8653 **** --------------------------------- procedure Instantiate_Subprogram_Body ! (Body_Info : Pending_Body_Info) is Act_Decl : constant Node_Id := Body_Info.Act_Decl; Inst_Node : constant Node_Id := Body_Info.Inst_Node; --- 8701,8708 ---- --------------------------------- procedure Instantiate_Subprogram_Body ! (Body_Info : Pending_Body_Info; ! Body_Optional : Boolean := False) is Act_Decl : constant Node_Id := Body_Info.Act_Decl; Inst_Node : constant Node_Id := Body_Info.Inst_Node; *************** package body Sem_Ch12 is *** 8674,8679 **** --- 8729,8742 ---- begin Gen_Body_Id := Corresponding_Body (Gen_Decl); + -- Subprogram body may have been created already because of an inline + -- pragma, or because of multiple elaborations of the enclosing package + -- when several instances of the subprogram appear in the main unit. + + if Present (Corresponding_Body (Act_Decl)) then + return; + end if; + Expander_Mode_Save_And_Set (Body_Info.Expander_Status); -- Re-establish the state of information on which checks are suppressed. *************** package body Sem_Ch12 is *** 8685,8692 **** Scope_Suppress := Body_Info.Scope_Suppress; if No (Gen_Body_Id) then ! Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl)); ! Gen_Body_Id := Corresponding_Body (Gen_Decl); end if; Instantiation_Node := Inst_Node; --- 8748,8772 ---- Scope_Suppress := Body_Info.Scope_Suppress; if No (Gen_Body_Id) then ! ! -- For imported generic subprogram, no body to compile, complete ! -- the spec entity appropriately. ! ! if Is_Imported (Gen_Unit) then ! Set_Is_Imported (Anon_Id); ! Set_First_Rep_Item (Anon_Id, First_Rep_Item (Gen_Unit)); ! Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit)); ! Set_Convention (Anon_Id, Convention (Gen_Unit)); ! Set_Has_Completion (Anon_Id); ! return; ! ! -- For other cases, compile the body ! ! else ! Load_Parent_Of_Generic ! (Inst_Node, Specification (Gen_Decl), Body_Optional); ! Gen_Body_Id := Corresponding_Body (Gen_Decl); ! end if; end if; Instantiation_Node := Inst_Node; *************** package body Sem_Ch12 is *** 8735,8741 **** Check_Generic_Actuals (Pack_Id, False); -- Generate a reference to link the visible subprogram instance to ! -- the the generic body, which for navigation purposes is the only -- available source for the instance. Generate_Reference --- 8815,8821 ---- Check_Generic_Actuals (Pack_Id, False); -- Generate a reference to link the visible subprogram instance to ! -- the generic body, which for navigation purposes is the only -- available source for the instance. Generate_Reference *************** package body Sem_Ch12 is *** 8850,8856 **** elsif Serious_Errors_Detected = 0 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit then ! if Ekind (Anon_Id) = E_Procedure then Act_Body := Make_Subprogram_Body (Loc, Specification => --- 8930,8939 ---- elsif Serious_Errors_Detected = 0 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit then ! if Body_Optional then ! return; ! ! elsif Ekind (Anon_Id) = E_Procedure then Act_Body := Make_Subprogram_Body (Loc, Specification => *************** package body Sem_Ch12 is *** 9011,9018 **** procedure Validate_Access_Type_Instance is Desig_Type : constant Entity_Id := ! Find_Actual_Type ! (Designated_Type (A_Gen_T), Scope (A_Gen_T)); begin if not Is_Access_Type (Act_T) then --- 9094,9101 ---- procedure Validate_Access_Type_Instance is Desig_Type : constant Entity_Id := ! Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T); ! Desig_Act : Entity_Id; begin if not Is_Access_Type (Act_T) then *************** package body Sem_Ch12 is *** 9046,9054 **** -- by an access type declaration (and not by a subtype declaration) -- must match. if not Subtypes_Match ! (Desig_Type, Designated_Type (Base_Type (Act_T))) ! then Error_Msg_NE ("designated type of actual does not match that of formal &", Actual, Gen_T); --- 9129,9146 ---- -- by an access type declaration (and not by a subtype declaration) -- must match. + Desig_Act := Designated_Type (Base_Type (Act_T)); + + -- The designated type may have been introduced through a limited_ + -- with clause, in which case retrieve the non-limited view. This + -- applies to incomplete types as well as to class-wide types. + + if From_With_Type (Desig_Act) then + Desig_Act := Available_View (Desig_Act); + end if; + if not Subtypes_Match ! (Desig_Type, Desig_Act) then Error_Msg_NE ("designated type of actual does not match that of formal &", Actual, Gen_T); *************** package body Sem_Ch12 is *** 9155,9161 **** end if; if not Subtypes_Match ! (Find_Actual_Type (Etype (I1), Scope (A_Gen_T)), T2) then Error_Msg_NE ("index types of actual do not match those of formal &", --- 9247,9253 ---- end if; if not Subtypes_Match ! (Find_Actual_Type (Etype (I1), A_Gen_T), T2) then Error_Msg_NE ("index types of actual do not match those of formal &", *************** package body Sem_Ch12 is *** 9167,9176 **** Next_Index (I2); end loop; ! if not Subtypes_Match ( ! Find_Actual_Type (Component_Type (A_Gen_T), Scope (A_Gen_T)), ! Component_Type (Act_T)) then Error_Msg_NE ("component subtype of actual does not match that of formal &", Actual, Gen_T); --- 9259,9278 ---- Next_Index (I2); end loop; ! -- Check matching subtypes. Note that there are complex visibility ! -- issues when the generic is a child unit and some aspect of the ! -- generic type is declared in a parent unit of the generic. We do ! -- the test to handle this special case only after a direct check ! -- for static matching has failed. ! ! 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)) then + null; + else Error_Msg_NE ("component subtype of actual does not match that of formal &", Actual, Gen_T); *************** package body Sem_Ch12 is *** 9184,9190 **** ("actual must have aliased components to match formal type &", Actual, Gen_T); end if; - end Validate_Array_Type_Instance; ----------------------------------------------- --- 9286,9291 ---- *************** package body Sem_Ch12 is *** 9213,9219 **** -- Now verify that the actual includes all other ancestors of -- the formal. ! Elmt := First_Elmt (Abstract_Interfaces (A_Gen_T)); while Present (Elmt) loop if not Interface_Present_In_Ancestor (Act_T, Get_Instance_Of (Node (Elmt))) --- 9314,9320 ---- -- Now verify that the actual includes all other ancestors of -- the formal. ! Elmt := First_Elmt (Interfaces (A_Gen_T)); while Present (Elmt) loop if not Interface_Present_In_Ancestor (Act_T, Get_Instance_Of (Node (Elmt))) *************** package body Sem_Ch12 is *** 9340,9346 **** Abandon_Instantiation (Actual); end if; ! -- Ada 2005 (AI-443): Synchronized formal derived type ckecks. Note -- that the formal type declaration has been rewritten as a private -- extension. --- 9441,9447 ---- Abandon_Instantiation (Actual); end if; ! -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note -- that the formal type declaration has been rewritten as a private -- extension. *************** package body Sem_Ch12 is *** 9463,9469 **** Abandon_Instantiation (Actual); end if; ! -- This case should be caught by the earlier check for for -- constrainedness, but the check here is added for completeness. elsif Has_Discriminants (Act_T) --- 9564,9570 ---- Abandon_Instantiation (Actual); end if; ! -- This case should be caught by the earlier check for -- constrainedness, but the check here is added for completeness. elsif Has_Discriminants (Act_T) *************** package body Sem_Ch12 is *** 9520,9526 **** function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean is - Interfaces : Elist_Id; Intfc_Elmt : Elmt_Id; begin --- 9621,9626 ---- *************** package body Sem_Ch12 is *** 9544,9552 **** -- progenitors. else ! Interfaces := Abstract_Interfaces (T2); ! ! Intfc_Elmt := First_Elmt (Interfaces); while Present (Intfc_Elmt) loop if Is_Ancestor (T1, Node (Intfc_Elmt)) then return True; --- 9644,9650 ---- -- progenitors. else ! Intfc_Elmt := First_Elmt (Interfaces (T2)); while Present (Intfc_Elmt) loop if Is_Ancestor (T1, Node (Intfc_Elmt)) then return True; *************** package body Sem_Ch12 is *** 9726,9731 **** --- 9824,9847 ---- end loop; end Check_Abstract_Primitives; end if; + + -- Verify that limitedness matches. If parent is a limited + -- interface then the generic formal is not unless declared + -- explicitly so. If not declared limited, the actual cannot be + -- limited (see AI05-0087). + -- Disable check for now, limited interfaces implemented by + -- protected types are common, Need to update tests ??? + + if Is_Limited_Type (Act_T) + and then not Is_Limited_Type (A_Gen_T) + and then False + then + Error_Msg_NE + ("actual for non-limited & cannot be a limited type", Actual, + Gen_T); + Explain_Limited_Type (Act_T, Actual); + Abandon_Instantiation (Actual); + end if; end Validate_Derived_Type_Instance; -------------------------------------- *************** package body Sem_Ch12 is *** 9910,9916 **** Check_Restriction (No_Fixed_Point, Actual); end if; ! -- Deal with error of using incomplete type as generic actual if Ekind (Act_T) = E_Incomplete_Type or else (Is_Class_Wide_Type (Act_T) --- 10026,10034 ---- Check_Restriction (No_Fixed_Point, Actual); end if; ! -- Deal with error of using incomplete type as generic actual. ! -- This includes limited views of a type, even if the non-limited ! -- view may be available. if Ekind (Act_T) = E_Incomplete_Type or else (Is_Class_Wide_Type (Act_T) *************** package body Sem_Ch12 is *** 9918,9924 **** Ekind (Root_Type (Act_T)) = E_Incomplete_Type) then if Is_Class_Wide_Type (Act_T) ! or else No (Underlying_Type (Act_T)) then Error_Msg_N ("premature use of incomplete type", Actual); Abandon_Instantiation (Actual); --- 10036,10042 ---- Ekind (Root_Type (Act_T)) = E_Incomplete_Type) then if Is_Class_Wide_Type (Act_T) ! or else No (Full_View (Act_T)) then Error_Msg_N ("premature use of incomplete type", Actual); Abandon_Instantiation (Actual); *************** package body Sem_Ch12 is *** 10151,10159 **** else Kind := Nkind (Parent (E)); return ! Kind = N_Formal_Object_Declaration ! or else Kind = N_Formal_Package_Declaration ! or else Kind = N_Formal_Type_Declaration or else (Is_Formal_Subprogram (E) and then --- 10269,10277 ---- else Kind := Nkind (Parent (E)); return ! Nkind_In (Kind, N_Formal_Object_Declaration, ! N_Formal_Package_Declaration, ! N_Formal_Type_Declaration) or else (Is_Formal_Subprogram (E) and then *************** package body Sem_Ch12 is *** 10222,10228 **** -- instantiations are available, we must analyze them, to ensure that -- the public symbols generated are the same when the unit is compiled -- to generate code, and when it is compiled in the context of a unit ! -- that needs a particular nested instance. -------------------------------- -- Collect_Previous_Instances -- --- 10340,10347 ---- -- instantiations are available, we must analyze them, to ensure that -- the public symbols generated are the same when the unit is compiled -- to generate code, and when it is compiled in the context of a unit ! -- that needs a particular nested instance. This process is applied ! -- to both package and subprogram instances. -------------------------------- -- Collect_Previous_Instances -- *************** package body Sem_Ch12 is *** 10250,10255 **** --- 10369,10384 ---- then Append_Elmt (Decl, Previous_Instances); + -- For a subprogram instantiation, omit instantiations of + -- intrinsic operations (Unchecked_Conversions, etc.) that + -- have no bodies. + + elsif Nkind_In (Decl, N_Function_Instantiation, + N_Procedure_Instantiation) + and then not Is_Intrinsic_Subprogram (Entity (Name (Decl))) + then + Append_Elmt (Decl, Previous_Instances); + elsif Nkind (Decl) = N_Package_Declaration then Collect_Previous_Instances (Visible_Declarations (Specification (Decl))); *************** package body Sem_Ch12 is *** 10382,10387 **** --- 10511,10517 ---- then declare Decl : Elmt_Id; + Info : Pending_Body_Info; Par : Node_Id; begin *************** package body Sem_Ch12 is *** 10412,10429 **** Decl := First_Elmt (Previous_Instances); while Present (Decl) loop ! Instantiate_Package_Body ! (Body_Info => ! ((Inst_Node => Node (Decl), ! Act_Decl => ! Instance_Spec (Node (Decl)), ! Expander_Status => Exp_Status, ! Current_Sem_Unit => ! Get_Code_Unit (Sloc (Node (Decl))), ! Scope_Suppress => Scope_Suppress, ! Local_Suppress_Stack_Top => ! Local_Suppress_Stack_Top)), ! Body_Optional => True); Next_Elmt (Decl); end loop; --- 10542,10581 ---- Decl := First_Elmt (Previous_Instances); while Present (Decl) loop ! Info := ! (Inst_Node => Node (Decl), ! Act_Decl => ! Instance_Spec (Node (Decl)), ! Expander_Status => Exp_Status, ! Current_Sem_Unit => ! Get_Code_Unit (Sloc (Node (Decl))), ! Scope_Suppress => Scope_Suppress, ! Local_Suppress_Stack_Top => ! Local_Suppress_Stack_Top); ! ! -- Package instance ! ! if ! Nkind (Node (Decl)) = N_Package_Instantiation ! then ! Instantiate_Package_Body ! (Info, Body_Optional => True); ! ! -- Subprogram instance ! ! else ! -- The instance_spec is the wrapper package, ! -- and the subprogram declaration is the last ! -- declaration in the wrapper. ! ! Info.Act_Decl := ! Last ! (Visible_Declarations ! (Specification (Info.Act_Decl))); ! ! Instantiate_Subprogram_Body ! (Info, Body_Optional => True); ! end if; Next_Elmt (Decl); end loop; *************** package body Sem_Ch12 is *** 10440,10446 **** Scope_Suppress => Scope_Suppress, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)), ! Body_Optional => Body_Optional); end; end if; --- 10592,10598 ---- Scope_Suppress => Scope_Suppress, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)), ! Body_Optional => Body_Optional); end; end if; *************** package body Sem_Ch12 is *** 10600,10606 **** -- Preanalyze_Actuals -- ------------------------ ! procedure Pre_Analyze_Actuals (N : Node_Id) is Assoc : Node_Id; Act : Node_Id; Errs : constant Int := Serious_Errors_Detected; --- 10752,10758 ---- -- Preanalyze_Actuals -- ------------------------ ! procedure Preanalyze_Actuals (N : Node_Id) is Assoc : Node_Id; Act : Node_Id; Errs : constant Int := Serious_Errors_Detected; *************** package body Sem_Ch12 is *** 10613,10619 **** -- Within a nested instantiation, a defaulted actual is an empty -- association, so nothing to analyze. If the subprogram actual ! -- isan attribute, analyze prefix only, because actual is not a -- complete attribute reference. -- If actual is an allocator, analyze expression only. The full --- 10765,10771 ---- -- Within a nested instantiation, a defaulted actual is an empty -- association, so nothing to analyze. If the subprogram actual ! -- is an attribute, analyze prefix only, because actual is not a -- complete attribute reference. -- If actual is an allocator, analyze expression only. The full *************** package body Sem_Ch12 is *** 10670,10689 **** end if; if Errs /= Serious_Errors_Detected then Abandon_Instantiation (Act); end if; end if; Next (Assoc); end loop; ! end Pre_Analyze_Actuals; ------------------- -- Remove_Parent -- ------------------- procedure Remove_Parent (In_Body : Boolean := False) is ! S : Entity_Id := Current_Scope; E : Entity_Id; P : Entity_Id; Hidden : Elmt_Id; --- 10822,10859 ---- end if; if Errs /= Serious_Errors_Detected then + + -- Do a minimal analysis of the generic, to prevent spurious + -- warnings complaining about the generic being unreferenced, + -- before abandoning the instantiation. + + Analyze (Name (N)); + + if Is_Entity_Name (Name (N)) + and then Etype (Name (N)) /= Any_Type + then + Generate_Reference (Entity (Name (N)), Name (N)); + Set_Is_Instantiated (Entity (Name (N))); + end if; + Abandon_Instantiation (Act); end if; end if; Next (Assoc); end loop; ! end Preanalyze_Actuals; ------------------- -- Remove_Parent -- ------------------- procedure Remove_Parent (In_Body : Boolean := False) is ! S : Entity_Id := Current_Scope; ! -- S is the scope containing the instantiation just completed. The ! -- scope stack contains the parent instances of the instantiation, ! -- followed by the original S. ! E : Entity_Id; P : Entity_Id; Hidden : Elmt_Id; *************** package body Sem_Ch12 is *** 10701,10707 **** if In_Open_Scopes (P) then E := First_Entity (P); - while Present (E) loop Set_Is_Immediately_Visible (E, True); Next_Entity (E); --- 10871,10876 ---- *************** package body Sem_Ch12 is *** 10730,10743 **** and then not Parent_Unit_Visible) then Set_Is_Immediately_Visible (P, False); end if; end loop; -- Reset visibility of entities in the enclosing scope Set_Is_Hidden_Open_Scope (Current_Scope, False); - Hidden := First_Elmt (Hidden_Entities); while Present (Hidden) loop Set_Is_Immediately_Visible (Node (Hidden), True); Next_Elmt (Hidden); --- 10899,10936 ---- and then not Parent_Unit_Visible) then Set_Is_Immediately_Visible (P, False); + + -- If the current scope is itself an instantiation of a generic + -- nested within P, and we are in the private part of body of this + -- instantiation, restore the full views of P, that were removed + -- in End_Package_Scope above. This obscure case can occur when a + -- subunit of a generic contains an instance of a child unit of + -- its generic parent unit. + + elsif S = Current_Scope + and then Is_Generic_Instance (S) + then + declare + Par : constant Entity_Id := + Generic_Parent + (Specification (Unit_Declaration_Node (S))); + begin + if Present (Par) + and then P = Scope (Par) + and then (In_Package_Body (S) or else In_Private_Part (S)) + then + Set_In_Private_Part (P); + Install_Private_Declarations (P); + end if; + end; end if; end loop; -- Reset visibility of entities in the enclosing scope Set_Is_Hidden_Open_Scope (Current_Scope, False); + Hidden := First_Elmt (Hidden_Entities); while Present (Hidden) loop Set_Is_Immediately_Visible (Node (Hidden), True); Next_Elmt (Hidden); *************** package body Sem_Ch12 is *** 10772,10783 **** Restore_Private_Views (Empty); end if; ! Current_Instantiated_Parent := Saved.Instantiated_Parent; ! Exchanged_Views := Saved.Exchanged_Views; ! Hidden_Entities := Saved.Hidden_Entities; ! Current_Sem_Unit := Saved.Current_Sem_Unit; ! Parent_Unit_Visible := Saved.Parent_Unit_Visible; ! Instance_Parent_Unit := Saved.Instance_Parent_Unit; Restore_Opt_Config_Switches (Saved.Switches); --- 10965,10976 ---- Restore_Private_Views (Empty); end if; ! Current_Instantiated_Parent := Saved.Instantiated_Parent; ! Exchanged_Views := Saved.Exchanged_Views; ! Hidden_Entities := Saved.Hidden_Entities; ! Current_Sem_Unit := Saved.Current_Sem_Unit; ! Parent_Unit_Visible := Saved.Parent_Unit_Visible; ! Instance_Parent_Unit := Saved.Instance_Parent_Unit; Restore_Opt_Config_Switches (Saved.Switches); *************** package body Sem_Ch12 is *** 10816,10822 **** return; elsif Present (Associated_Formal_Package (Formal)) then - Ent := First_Entity (Formal); while Present (Ent) loop exit when Ekind (Ent) = E_Package --- 11009,11014 ---- *************** package body Sem_Ch12 is *** 10890,10897 **** -- An unusual case of aliasing: the actual may also be directly -- visible in the generic, and be private there, while it is fully ! -- visible in the context of the instance. The internal subtype is ! -- private in the instance, but has full visibility like its -- parent in the enclosing scope. This enforces the invariant that -- the privacy status of all private dependents of a type coincide -- with that of the parent type. This can only happen when a --- 11082,11089 ---- -- An unusual case of aliasing: the actual may also be directly -- visible in the generic, and be private there, while it is fully ! -- visible in the context of the instance. The internal subtype ! -- is private in the instance, but has full visibility like its -- parent in the enclosing scope. This enforces the invariant that -- the privacy status of all private dependents of a type coincide -- with that of the parent type. This can only happen when a *************** package body Sem_Ch12 is *** 10909,10922 **** -- package itself. If the instance is a subprogram, all entities -- in the corresponding package are renamings. If this entity is -- a formal package, make its own formals private as well. The ! -- actual in this case is itself the renaming of an instantation. -- If the entity is not a package renaming, it is the entity -- created to validate formal package actuals: ignore. -- If the actual is itself a formal package for the enclosing -- generic, or the actual for such a formal package, it remains ! -- visible on exit from the instance, and therefore nothing ! -- needs to be done either, except to keep it accessible. if Is_Package and then Renamed_Object (E) = Pack_Id --- 11101,11114 ---- -- package itself. If the instance is a subprogram, all entities -- in the corresponding package are renamings. If this entity is -- a formal package, make its own formals private as well. The ! -- actual in this case is itself the renaming of an instantiation. -- If the entity is not a package renaming, it is the entity -- created to validate formal package actuals: ignore. -- If the actual is itself a formal package for the enclosing -- generic, or the actual for such a formal package, it remains ! -- visible on exit from the instance, and therefore nothing needs ! -- to be done either, except to keep it accessible. if Is_Package and then Renamed_Object (E) = Pack_Id *************** package body Sem_Ch12 is *** 11033,11039 **** --------------- function Is_Global (E : Entity_Id) return Boolean is ! Se : Entity_Id := Scope (E); function Is_Instance_Node (Decl : Node_Id) return Boolean; -- Determine whether the parent node of a reference to a child unit --- 11225,11231 ---- --------------- function Is_Global (E : Entity_Id) return Boolean is ! Se : Entity_Id; function Is_Instance_Node (Decl : Node_Id) return Boolean; -- Determine whether the parent node of a reference to a child unit *************** package body Sem_Ch12 is *** 11064,11076 **** elsif Is_Child_Unit (E) and then (Is_Instance_Node (Parent (N2)) ! or else (Nkind (Parent (N2)) = N_Expanded_Name ! and then N2 = Selector_Name (Parent (N2)) ! and then Is_Instance_Node (Parent (Parent (N2))))) then return True; else while Se /= Gen_Scope loop if Se = Standard_Standard then return True; --- 11256,11270 ---- elsif Is_Child_Unit (E) and then (Is_Instance_Node (Parent (N2)) ! or else (Nkind (Parent (N2)) = N_Expanded_Name ! and then N2 = Selector_Name (Parent (N2)) ! and then ! Is_Instance_Node (Parent (Parent (N2))))) then return True; else + Se := Scope (E); while Se /= Gen_Scope loop if Se = Standard_Standard then return True; *************** package body Sem_Ch12 is *** 11153,11161 **** ------------------ function Top_Ancestor (E : Entity_Id) return Entity_Id is ! Par : Entity_Id := E; begin while Is_Child_Unit (Par) loop Par := Scope (Par); end loop; --- 11347,11356 ---- ------------------ function Top_Ancestor (E : Entity_Id) return Entity_Id is ! Par : Entity_Id; begin + Par := E; while Is_Child_Unit (Par) loop Par := Scope (Par); end loop; *************** package body Sem_Ch12 is *** 11241,11248 **** -- its value. Otherwise the folding will happen in any instantiation, elsif Nkind (Parent (N)) = N_Selected_Component ! and then (Nkind (Parent (N2)) = N_Integer_Literal ! or else Nkind (Parent (N2)) = N_Real_Literal) then if Present (Entity (Original_Node (Parent (N2)))) and then Is_Global (Entity (Original_Node (Parent (N2)))) --- 11436,11442 ---- -- its value. Otherwise the folding will happen in any instantiation, elsif Nkind (Parent (N)) = N_Selected_Component ! and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal) then if Present (Entity (Original_Node (Parent (N2)))) and then Is_Global (Entity (Original_Node (Parent (N2)))) *************** package body Sem_Ch12 is *** 11356,11362 **** Next (Act2); end loop; ! -- Find the associations added for default suprograms if Present (Act2) then while Nkind (Act2) /= N_Generic_Association --- 11550,11556 ---- Next (Act2); end loop; ! -- Find the associations added for default subprograms if Present (Act2) then while Nkind (Act2) /= N_Generic_Association *************** package body Sem_Ch12 is *** 11504,11512 **** if N = Empty then null; ! elsif Nkind (N) = N_Character_Literal ! or else Nkind (N) = N_Operator_Symbol ! then if Nkind (N) = Nkind (Get_Associated_Node (N)) then Reset_Entity (N); --- 11698,11704 ---- if N = Empty then null; ! elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then if Nkind (N) = Nkind (Get_Associated_Node (N)) then Reset_Entity (N); *************** package body Sem_Ch12 is *** 11545,11553 **** Set_Etype (N, Empty); end if; ! elsif Nkind (N2) = N_Integer_Literal ! or else Nkind (N2) = N_Real_Literal ! or else Nkind (N2) = N_String_Literal then if Present (Original_Node (N2)) and then Nkind (Original_Node (N2)) = Nkind (N) --- 11737,11745 ---- Set_Etype (N, Empty); end if; ! elsif Nkind_In (N2, N_Integer_Literal, ! N_Real_Literal, ! N_String_Literal) then if Present (Original_Node (N2)) and then Nkind (Original_Node (N2)) = Nkind (N) *************** package body Sem_Ch12 is *** 11588,11595 **** end if; end if; ! -- Complete the check on operands, if node has not been ! -- constant-folded. if Nkind (N) in N_Op then Save_Entity_Descendants (N); --- 11780,11786 ---- end if; end if; ! -- Complete operands check if node has not been constant-folded if Nkind (N) in N_Op then Save_Entity_Descendants (N); *************** package body Sem_Ch12 is *** 11624,11633 **** Set_Etype (N, Empty); end if; ! elsif ! (Nkind (N2) = N_Integer_Literal ! or else ! Nkind (N2) = N_Real_Literal) and then Is_Entity_Name (Original_Node (N2)) then -- Name resolves to named number that is constant-folded, --- 11815,11821 ---- Set_Etype (N, Empty); end if; ! elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal) and then Is_Entity_Name (Original_Node (N2)) then -- Name resolves to named number that is constant-folded, *************** package body Sem_Ch12 is *** 11712,11721 **** -- traversal, so it needs direct access to node fields. begin ! if Nkind (N) = N_Aggregate ! or else ! Nkind (N) = N_Extension_Aggregate ! then N2 := Get_Associated_Node (N); if No (N2) then --- 11900,11906 ---- -- traversal, so it needs direct access to node fields. begin ! if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then N2 := Get_Associated_Node (N); if No (N2) then *************** package body Sem_Ch12 is *** 11723,11732 **** else Typ := Etype (N2); ! -- In an instance within a generic, use the name of ! -- the actual and not the original generic parameter. ! -- If the actual is global in the current generic it ! -- must be preserved for its instantiation. if Nkind (Parent (Typ)) = N_Subtype_Declaration and then --- 11908,11917 ---- else Typ := Etype (N2); ! -- In an instance within a generic, use the name of the ! -- actual and not the original generic parameter. If the ! -- actual is global in the current generic it must be ! -- preserved for its instantiation. if Nkind (Parent (Typ)) = N_Subtype_Declaration and then *************** package body Sem_Ch12 is *** 11759,11766 **** if Nkind (N2) = Nkind (N) and then ! (Nkind (Parent (N2)) = N_Procedure_Call_Statement ! or else Nkind (Parent (N2)) = N_Function_Call) and then Comes_From_Source (Typ) then if Is_Immediately_Visible (Scope (Typ)) then --- 11944,11951 ---- if Nkind (N2) = Nkind (N) and then ! Nkind_In (Parent (N2), N_Procedure_Call_Statement, ! N_Function_Call) and then Comes_From_Source (Typ) then if Is_Immediately_Visible (Scope (Typ)) then diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch12.ads gcc-4.4.0/gcc/ada/sem_ch12.ads *** gcc-4.3.3/gcc/ada/sem_ch12.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_ch12.ads Fri Aug 1 08:19:04 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Sem_Ch12 is *** 100,108 **** -- between the current procedure and Load_Parent_Of_Generic. procedure Instantiate_Subprogram_Body ! (Body_Info : Pending_Body_Info); -- Called after semantic analysis, to complete the instantiation of ! -- function and procedure instances. procedure Save_Global_References (N : Node_Id); -- Traverse the original generic unit, and capture all references to --- 100,120 ---- -- between the current procedure and Load_Parent_Of_Generic. procedure Instantiate_Subprogram_Body ! (Body_Info : Pending_Body_Info; ! Body_Optional : Boolean := False); -- Called after semantic analysis, to complete the instantiation of ! -- function and procedure instances. The flag Body_Optional has the ! -- same purpose as described for Instantiate_Package_Body. ! ! function Need_Subprogram_Instance_Body ! (N : Node_Id; ! Subp : Entity_Id) return Boolean; ! ! -- If a subprogram instance is inlined, indicate that the body of it ! -- must be created, to be used in inlined calls by the back-end. The ! -- subprogram may be inlined because the generic itself carries the ! -- pragma, or because a pragma appears for the instance in the scope. ! -- of the instance. procedure Save_Global_References (N : Node_Id); -- Traverse the original generic unit, and capture all references to *************** package Sem_Ch12 is *** 128,134 **** -- an inlined body (so that errout can distinguish cases for generating -- error messages, otherwise the treatment is identical). In this call -- N is the subprogram body and E is the defining identifier of the ! -- subprogram in quiestion. The resulting Sloc adjustment factor is -- saved as part of the internal state of the Sem_Ch12 package for use -- in subsequent calls to copy nodes. --- 140,146 ---- -- an inlined body (so that errout can distinguish cases for generating -- error messages, otherwise the treatment is identical). In this call -- N is the subprogram body and E is the defining identifier of the ! -- subprogram in question. The resulting Sloc adjustment factor is -- saved as part of the internal state of the Sem_Ch12 package for use -- in subsequent calls to copy nodes. diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch13.adb gcc-4.4.0/gcc/ada/sem_ch13.adb *** gcc-4.3.3/gcc/ada/sem_ch13.adb Thu Dec 13 10:28:24 2007 --- gcc-4.4.0/gcc/ada/sem_ch13.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Einfo; use Einfo; *** 29,35 **** with Errout; use Errout; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; - with Layout; use Layout; with Lib; use Lib; with Lib.Xref; use Lib.Xref; with Namet; use Namet; --- 29,34 ---- *************** package body Sem_Ch13 is *** 68,80 **** procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id); -- This routine is called after setting the Esize of type entity Typ. ! -- The purpose is to deal with the situation where an aligment has been -- inherited from a derived type that is no longer appropriate for the -- new Esize value. In this case, we reset the Alignment to unknown. procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); -- Given two entities for record components or discriminants, checks ! -- if they hav overlapping component clauses and issues errors if so. function Get_Alignment_Value (Expr : Node_Id) return Uint; -- Given the expression for an alignment value, returns the corresponding --- 67,79 ---- procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id); -- This routine is called after setting the Esize of type entity Typ. ! -- The purpose is to deal with the situation where an alignment has been -- inherited from a derived type that is no longer appropriate for the -- new Esize value. In this case, we reset the Alignment to unknown. procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); -- Given two entities for record components or discriminants, checks ! -- if they have overlapping component clauses and issues errors if so. function Get_Alignment_Value (Expr : Node_Id) return Uint; -- Given the expression for an alignment value, returns the corresponding *************** package body Sem_Ch13 is *** 119,125 **** -- call to Validate_Unchecked_Conversions does the actual error -- checking and posting of warnings. The reason for this delayed -- processing is to take advantage of back-annotations of size and ! -- alignment values peformed by the back end. type UC_Entry is record Enode : Node_Id; -- node used for posting warnings --- 118,124 ---- -- call to Validate_Unchecked_Conversions does the actual error -- checking and posting of warnings. The reason for this delayed -- processing is to take advantage of back-annotations of size and ! -- alignment values performed by the back end. type UC_Entry is record Enode : Node_Id; -- node used for posting warnings *************** package body Sem_Ch13 is *** 180,196 **** and then Attribute_Name (N) = Name_Address then declare ! Nam : Node_Id := Prefix (N); begin ! while False ! or else Nkind (Nam) = N_Selected_Component ! or else Nkind (Nam) = N_Indexed_Component ! loop ! Nam := Prefix (Nam); end loop; ! if Is_Entity_Name (Nam) then ! return Entity (Nam); end if; end; end if; --- 179,194 ---- and then Attribute_Name (N) = Name_Address then declare ! P : Node_Id; ! begin ! P := Prefix (N); ! while Nkind_In (P, N_Selected_Component, N_Indexed_Component) loop ! P := Prefix (P); end loop; ! if Is_Entity_Name (P) then ! return Entity (P); end if; end; end if; *************** package body Sem_Ch13 is *** 224,289 **** Comp := First_Component_Or_Discriminant (R); while Present (Comp) loop declare ! CC : constant Node_Id := Component_Clause (Comp); ! Fbit : constant Uint := Static_Integer (First_Bit (CC)); begin if Present (CC) then ! -- Case of component with size > max machine scalar ! ! if Esize (Comp) > Max_Machine_Scalar_Size then ! -- Must begin on byte boundary ! if Fbit mod SSU /= 0 then ! Error_Msg_N ! ("illegal first bit value for reverse bit order", ! First_Bit (CC)); ! Error_Msg_Uint_1 := SSU; ! Error_Msg_Uint_2 := Max_Machine_Scalar_Size; ! Error_Msg_N ! ("\must be a multiple of ^ if size greater than ^", ! First_Bit (CC)); ! -- Must end on byte boundary ! elsif Esize (Comp) mod SSU /= 0 then ! Error_Msg_N ! ("illegal last bit value for reverse bit order", ! Last_Bit (CC)); ! Error_Msg_Uint_1 := SSU; ! Error_Msg_Uint_2 := Max_Machine_Scalar_Size; ! Error_Msg_N ! ("\must be a multiple of ^ if size greater than ^", ! Last_Bit (CC)); ! -- OK, give warning if enabled ! elsif Warn_On_Reverse_Bit_Order then ! Error_Msg_N ! ("multi-byte field specified with non-standard" ! & " Bit_Order?", CC); ! if Bytes_Big_Endian then ! Error_Msg_N ! ("\bytes are not reversed " ! & "(component is big-endian)?", CC); ! else Error_Msg_N ! ("\bytes are not reversed " ! & "(component is little-endian)?", CC); end if; - end if; ! -- Case where size is not greater than max machine scalar. ! -- For now, we just count these. ! else ! Num_CC := Num_CC + 1; ! end if; end if; end; --- 222,290 ---- Comp := First_Component_Or_Discriminant (R); while Present (Comp) loop declare ! CC : constant Node_Id := Component_Clause (Comp); begin if Present (CC) then + declare + Fbit : constant Uint := Static_Integer (First_Bit (CC)); ! begin ! -- Case of component with size > max machine scalar ! if Esize (Comp) > Max_Machine_Scalar_Size then ! -- Must begin on byte boundary ! if Fbit mod SSU /= 0 then ! Error_Msg_N ! ("illegal first bit value for reverse bit order", ! First_Bit (CC)); ! Error_Msg_Uint_1 := SSU; ! Error_Msg_Uint_2 := Max_Machine_Scalar_Size; ! Error_Msg_N ! ("\must be a multiple of ^ if size greater than ^", ! First_Bit (CC)); ! -- Must end on byte boundary ! elsif Esize (Comp) mod SSU /= 0 then ! Error_Msg_N ! ("illegal last bit value for reverse bit order", ! Last_Bit (CC)); ! Error_Msg_Uint_1 := SSU; ! Error_Msg_Uint_2 := Max_Machine_Scalar_Size; ! Error_Msg_N ! ("\must be a multiple of ^ if size greater than ^", ! Last_Bit (CC)); ! -- OK, give warning if enabled ! elsif Warn_On_Reverse_Bit_Order then Error_Msg_N ! ("multi-byte field specified with non-standard" ! & " Bit_Order?", CC); ! ! if Bytes_Big_Endian then ! Error_Msg_N ! ("\bytes are not reversed " ! & "(component is big-endian)?", CC); ! else ! Error_Msg_N ! ("\bytes are not reversed " ! & "(component is little-endian)?", CC); ! end if; end if; ! -- Case where size is not greater than max machine ! -- scalar. For now, we just count these. ! else ! Num_CC := Num_CC + 1; ! end if; ! end; end if; end; *************** package body Sem_Ch13 is *** 296,302 **** declare Comps : array (0 .. Num_CC) of Entity_Id; ! -- Array to collect component and discrimninant entities. The data -- starts at index 1, the 0'th entry is for the sort routine. function CP_Lt (Op1, Op2 : Natural) return Boolean; --- 297,303 ---- declare Comps : array (0 .. Num_CC) of Entity_Id; ! -- Array to collect component and discriminant entities. The data -- starts at index 1, the 0'th entry is for the sort routine. function CP_Lt (Op1, Op2 : Natural) return Boolean; *************** package body Sem_Ch13 is *** 419,425 **** -- 1 .. 4 3 .. 6 1 3 -- 4 .. 7 0 .. 3 4 0 ! -- The general rule is that the first bit is is obtained by -- subtracting the old ending bit from machine scalar size - 1. for C in Start .. Stop loop --- 420,426 ---- -- 1 .. 4 3 .. 6 1 3 -- 4 .. 7 0 .. 3 4 0 ! -- The general rule is that the first bit is obtained by -- subtracting the old ending bit from machine scalar size - 1. for C in Start .. Stop loop *************** package body Sem_Ch13 is *** 435,452 **** if Warn_On_Reverse_Bit_Order then Error_Msg_Uint_1 := MSS; Error_Msg_N ! ("?reverse bit order in machine " & ! "scalar of length^", First_Bit (CC)); Error_Msg_Uint_1 := NFB; Error_Msg_Uint_2 := NLB; if Bytes_Big_Endian then Error_Msg_NE ! ("?\big-endian range for component & is ^ .. ^", First_Bit (CC), Comp); else Error_Msg_NE ! ("?\little-endian range for component & is ^ .. ^", First_Bit (CC), Comp); end if; end if; --- 436,455 ---- if Warn_On_Reverse_Bit_Order then Error_Msg_Uint_1 := MSS; Error_Msg_N ! ("info: reverse bit order in machine " & ! "scalar of length^?", First_Bit (CC)); Error_Msg_Uint_1 := NFB; Error_Msg_Uint_2 := NLB; if Bytes_Big_Endian then Error_Msg_NE ! ("?\info: big-endian range for " ! & "component & is ^ .. ^", First_Bit (CC), Comp); else Error_Msg_NE ! ("?\info: little-endian range " ! & "for component & is ^ .. ^", First_Bit (CC), Comp); end if; end if; *************** package body Sem_Ch13 is *** 486,492 **** --- 489,499 ---- -- definition clause that is the preferred approach in Ada 95. procedure Analyze_At_Clause (N : Node_Id) is + CS : constant Boolean := Comes_From_Source (N); + begin + -- This is an obsolescent feature + Check_Restriction (No_Obsolescent_Features, N); if Warn_On_Obsolescent_Feature then *************** package body Sem_Ch13 is *** 496,506 **** --- 503,523 ---- ("\use address attribute definition clause instead?", N); end if; + -- Rewrite as address clause + Rewrite (N, Make_Attribute_Definition_Clause (Sloc (N), Name => Identifier (N), Chars => Name_Address, Expression => Expression (N))); + + -- We preserve Comes_From_Source, since logically the clause still + -- comes from the source program even though it is changed in form. + + Set_Comes_From_Source (N, CS); + + -- Analyze rewritten clause + Analyze_Attribute_Definition_Clause (N); end Analyze_At_Clause; *************** package body Sem_Ch13 is *** 530,535 **** --- 547,556 ---- -- Common processing for 'Read, 'Write, 'Input and 'Output attribute -- definition clauses. + ----------------------------------- + -- Analyze_Stream_TSS_Definition -- + ----------------------------------- + procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is Subp : Entity_Id := Empty; I : Interp_Index; *************** package body Sem_Ch13 is *** 589,595 **** return Base_Type (Typ) = Base_Type (Ent) and then No (Next_Formal (F)); - end Has_Good_Profile; -- Start of processing for Analyze_Stream_TSS_Definition --- 610,615 ---- *************** package body Sem_Ch13 is *** 740,745 **** --- 760,781 ---- -- Address attribute definition clause when Attribute_Address => Address : begin + + -- A little error check, catch for X'Address use X'Address; + + if Nkind (Nam) = N_Identifier + and then Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Address + and then Nkind (Prefix (Expr)) = N_Identifier + and then Chars (Nam) = Chars (Prefix (Expr)) + then + Error_Msg_NE + ("address for & is self-referencing", Prefix (Expr), Ent); + return; + end if; + + -- Not that special case, carry on with analysis of expression + Analyze_And_Resolve (Expr, RTE (RE_Address)); if Present (Address_Clause (U_Ent)) then *************** package body Sem_Ch13 is *** 876,882 **** -- We mark a possible modification of a variable with an -- address clause, since it is likely aliasing is occurring. ! Note_Possible_Modification (Nam); -- Here we are checking for explicit overlap of one variable -- by another, and if we find this then mark the overlapped --- 912,918 ---- -- We mark a possible modification of a variable with an -- address clause, since it is likely aliasing is occurring. ! Note_Possible_Modification (Nam, Sure => False); -- Here we are checking for explicit overlap of one variable -- by another, and if we find this then mark the overlapped *************** package body Sem_Ch13 is *** 921,942 **** -- If the address clause is of the form: ! -- for X'Address use Y'Address -- or ! -- Const : constant Address := Y'Address; -- ... ! -- for X'Address use Const; -- then we make an entry in the table for checking the size and -- alignment of the overlaying variable. We defer this check -- till after code generation to take full advantage of the -- annotation done by the back end. This entry is only made if -- we have not already posted a warning about size/alignment ! -- (some warnings of this type are posted in Checks). ! if Address_Clause_Overlay_Warnings then declare Ent_X : Entity_Id := Empty; Ent_Y : Entity_Id := Empty; --- 957,981 ---- -- If the address clause is of the form: ! -- for Y'Address use X'Address -- or ! -- Const : constant Address := X'Address; -- ... ! -- for Y'Address use Const; -- then we make an entry in the table for checking the size and -- alignment of the overlaying variable. We defer this check -- till after code generation to take full advantage of the -- annotation done by the back end. This entry is only made if -- we have not already posted a warning about size/alignment ! -- (some warnings of this type are posted in Checks), and if ! -- the address clause comes from source. ! if Address_Clause_Overlay_Warnings ! and then Comes_From_Source (N) ! then declare Ent_X : Entity_Id := Empty; Ent_Y : Entity_Id := Empty; *************** package body Sem_Ch13 is *** 946,952 **** if Present (Ent_Y) and then Is_Entity_Name (Name (N)) then Ent_X := Entity (Name (N)); ! Address_Clause_Checks.Append ((N, Ent_X, Ent_Y)); end if; end; end if; --- 985,1002 ---- if Present (Ent_Y) and then Is_Entity_Name (Name (N)) then Ent_X := Entity (Name (N)); ! Address_Clause_Checks.Append ((N, Ent_X, Ent_Y)); ! ! -- If variable overlays a constant view, and we are ! -- warning on overlays, then mark the variable as ! -- overlaying a constant (we will give warnings later ! -- if this variable is assigned). ! ! if Is_Constant_Object (Ent_Y) ! and then Ekind (Ent_X) = E_Variable ! then ! Set_Overlays_Constant (Ent_X); ! end if; end if; end; end if; *************** package body Sem_Ch13 is *** 1086,1091 **** --- 1136,1147 ---- Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); Set_Component_Type (Btype, New_Ctyp); + + if Warn_On_Biased_Representation then + Error_Msg_N + ("?component size clause forces biased " + & "representation", N); + end if; end if; Set_Component_Size (Btype, Csize); *************** package body Sem_Ch13 is *** 1285,1291 **** or else Has_Small_Clause (U_Ent) then Check_Size (Expr, Etyp, Size, Biased); ! Set_Has_Biased_Representation (U_Ent, Biased); end if; -- For types set RM_Size and Esize if possible --- 1341,1352 ---- or else Has_Small_Clause (U_Ent) then Check_Size (Expr, Etyp, Size, Biased); ! Set_Has_Biased_Representation (U_Ent, Biased); ! ! if Biased and Warn_On_Biased_Representation then ! Error_Msg_N ! ("?size clause forces biased representation", N); ! end if; end if; -- For types set RM_Size and Esize if possible *************** package body Sem_Ch13 is *** 1392,1398 **** Set_Has_Small_Clause (U_Ent); Set_Has_Small_Clause (Implicit_Base); Set_Has_Non_Standard_Rep (Implicit_Base); - Set_Discrete_RM_Size (U_Ent); end if; end Small; --- 1453,1458 ---- *************** package body Sem_Ch13 is *** 1437,1442 **** --- 1497,1507 ---- Analyze_And_Resolve (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); + if not Denotes_Variable (Expr) then + Error_Msg_N ("storage pool must be a variable", Expr); + return; + end if; + if Nkind (Expr) = N_Type_Conversion then T := Etype (Expression (Expr)); else *************** package body Sem_Ch13 is *** 1446,1452 **** -- The Stack_Bounded_Pool is used internally for implementing -- access types with a Storage_Size. Since it only work -- properly when used on one specific type, we need to check ! -- that it is not highjacked improperly: -- type T is access Integer; -- for T'Storage_Size use n; -- type Q is access Float; --- 1511,1517 ---- -- The Stack_Bounded_Pool is used internally for implementing -- access types with a Storage_Size. Since it only work -- properly when used on one specific type, we need to check ! -- that it is not hijacked improperly: -- type T is access Integer; -- for T'Storage_Size use n; -- type Q is access Float; *************** package body Sem_Ch13 is *** 1659,1664 **** --- 1724,1734 ---- if Is_Elementary_Type (U_Ent) then Check_Size (Expr, U_Ent, Size, Biased); Set_Has_Biased_Representation (U_Ent, Biased); + + if Biased and Warn_On_Biased_Representation then + Error_Msg_N + ("?value size clause forces biased representation", N); + end if; end if; Set_RM_Size (U_Ent, Size); *************** package body Sem_Ch13 is *** 1749,1758 **** while Present (Decl) loop DeclO := Original_Node (Decl); if Comes_From_Source (DeclO) ! and then Nkind (DeclO) /= N_Pragma ! and then Nkind (DeclO) /= N_Use_Package_Clause ! and then Nkind (DeclO) /= N_Use_Type_Clause ! and then Nkind (DeclO) /= N_Implicit_Label_Declaration then Error_Msg_N ("this declaration not allowed in machine code subprogram", --- 1819,1828 ---- while Present (Decl) loop DeclO := Original_Node (Decl); if Comes_From_Source (DeclO) ! and not Nkind_In (DeclO, N_Pragma, ! N_Use_Package_Clause, ! N_Use_Type_Clause, ! N_Implicit_Label_Declaration) then Error_Msg_N ("this declaration not allowed in machine code subprogram", *************** package body Sem_Ch13 is *** 1769,1777 **** while Present (Stmt) loop StmtO := Original_Node (Stmt); if Comes_From_Source (StmtO) ! and then Nkind (StmtO) /= N_Pragma ! and then Nkind (StmtO) /= N_Label ! and then Nkind (StmtO) /= N_Code_Statement then Error_Msg_N ("this statement is not allowed in machine code subprogram", --- 1839,1847 ---- while Present (Stmt) loop StmtO := Original_Node (Stmt); if Comes_From_Source (StmtO) ! and then not Nkind_In (StmtO, N_Pragma, ! N_Label, ! N_Code_Statement) then Error_Msg_N ("this statement is not allowed in machine code subprogram", *************** package body Sem_Ch13 is *** 1855,1864 **** -- Don't allow rep clause for standard [wide_[wide_]]character ! elsif Root_Type (Enumtype) = Standard_Character ! or else Root_Type (Enumtype) = Standard_Wide_Character ! or else Root_Type (Enumtype) = Standard_Wide_Wide_Character ! then Error_Msg_N ("enumeration rep clause not allowed for this type", N); return; --- 1925,1931 ---- -- Don't allow rep clause for standard [wide_[wide_]]character ! elsif Is_Standard_Character_Type (Enumtype) then Error_Msg_N ("enumeration rep clause not allowed for this type", N); return; *************** package body Sem_Ch13 is *** 2284,2290 **** -- The only pragma of interest is Complete_Representation ! if Chars (CC) = Name_Complete_Representation then CR_Pragma := CC; end if; --- 2351,2357 ---- -- The only pragma of interest is Complete_Representation ! if Pragma_Name (CC) = Name_Complete_Representation then CR_Pragma := CC; end if; *************** package body Sem_Ch13 is *** 2308,2313 **** --- 2375,2388 ---- Error_Msg_N ("first bit cannot be negative", First_Bit (CC)); + -- The Last_Bit specified in a component clause must not be + -- less than the First_Bit minus one (RM-13.5.1(10)). + + elsif Lbit < Fbit - 1 then + Error_Msg_N + ("last bit cannot be less than first bit minus one", + Last_Bit (CC)); + -- Values look OK, so find the corresponding record component -- Even though the syntax allows an attribute reference for -- implementation-defined components, GNAT does not allow the *************** package body Sem_Ch13 is *** 2345,2358 **** elsif Present (Component_Clause (Comp)) then ! -- Diagose duplicate rep clause, or check consistency ! -- if this is inherited component. In a double fault, -- there may be a duplicate inconsistent clause for an -- inherited component. ! if ! Scope (Original_Record_Component (Comp)) = Rectype ! or else Parent (Component_Clause (Comp)) = N then Error_Msg_Sloc := Sloc (Component_Clause (Comp)); Error_Msg_N ("component clause previously given#", CC); --- 2420,2432 ---- elsif Present (Component_Clause (Comp)) then ! -- Diagnose duplicate rep clause, or check consistency ! -- if this is an inherited component. In a double fault, -- there may be a duplicate inconsistent clause for an -- inherited component. ! if Scope (Original_Record_Component (Comp)) = Rectype ! or else Parent (Component_Clause (Comp)) = N then Error_Msg_Sloc := Sloc (Component_Clause (Comp)); Error_Msg_N ("component clause previously given#", CC); *************** package body Sem_Ch13 is *** 2360,2366 **** else declare Rep1 : constant Node_Id := Component_Clause (Comp); - begin if Intval (Position (Rep1)) /= Intval (Position (CC)) --- 2434,2439 ---- *************** package body Sem_Ch13 is *** 2371,2377 **** then Error_Msg_N ("component clause inconsistent " & "with representation of ancestor", CC); - elsif Warn_On_Redundant_Constructs then Error_Msg_N ("?redundant component clause " & "for inherited component!", CC); --- 2444,2449 ---- *************** package body Sem_Ch13 is *** 2440,2445 **** --- 2512,2523 ---- Set_Has_Biased_Representation (Comp, Biased); + if Biased and Warn_On_Biased_Representation then + Error_Msg_F + ("?component clause forces biased " + & "representation", CC); + end if; + if Present (Ocomp) then Set_Component_Clause (Ocomp, CC); Set_Component_Bit_Offset (Ocomp, Fbit); *************** package body Sem_Ch13 is *** 2467,2496 **** end loop; -- Now that we have processed all the component clauses, check for ! -- overlap. We have to leave this till last, since the components ! -- can appear in any arbitrary order in the representation clause. -- We do not need this check if all specified ranges were monotonic, -- as recorded by Overlap_Check_Required being False at this stage. ! -- This first section checks if there are any overlapping entries ! -- at all. It does this by sorting all entries and then seeing if ! -- there are any overlaps. If there are none, then that is decisive, ! -- but if there are overlaps, they may still be OK (they may result ! -- from fields in different variants). if Overlap_Check_Required then Overlap_Check1 : declare OC_Fbit : array (0 .. Ccount) of Uint; ! -- First-bit values for component clauses, the value is the ! -- offset of the first bit of the field from start of record. ! -- The zero entry is for use in sorting. OC_Lbit : array (0 .. Ccount) of Uint; ! -- Last-bit values for component clauses, the value is the ! -- offset of the last bit of the field from start of record. ! -- The zero entry is for use in sorting. OC_Count : Natural := 0; -- Count of entries in OC_Fbit and OC_Lbit --- 2545,2574 ---- end loop; -- Now that we have processed all the component clauses, check for ! -- overlap. We have to leave this till last, since the components can ! -- appear in any arbitrary order in the representation clause. -- We do not need this check if all specified ranges were monotonic, -- as recorded by Overlap_Check_Required being False at this stage. ! -- This first section checks if there are any overlapping entries at ! -- all. It does this by sorting all entries and then seeing if there are ! -- any overlaps. If there are none, then that is decisive, but if there ! -- are overlaps, they may still be OK (they may result from fields in ! -- different variants). if Overlap_Check_Required then Overlap_Check1 : declare OC_Fbit : array (0 .. Ccount) of Uint; ! -- First-bit values for component clauses, the value is the offset ! -- of the first bit of the field from start of record. The zero ! -- entry is for use in sorting. OC_Lbit : array (0 .. Ccount) of Uint; ! -- Last-bit values for component clauses, the value is the offset ! -- of the last bit of the field from start of record. The zero ! -- entry is for use in sorting. OC_Count : Natural := 0; -- Count of entries in OC_Fbit and OC_Lbit *************** package body Sem_Ch13 is *** 2548,2557 **** end Overlap_Check1; end if; ! -- If Overlap_Check_Required is still True, then we have to do ! -- the full scale overlap check, since we have at least two fields ! -- that do overlap, and we need to know if that is OK since they ! -- are in the same variant, or whether we have a definite problem if Overlap_Check_Required then Overlap_Check2 : declare --- 2626,2635 ---- end Overlap_Check1; end if; ! -- If Overlap_Check_Required is still True, then we have to do the full ! -- scale overlap check, since we have at least two fields that do ! -- overlap, and we need to know if that is OK since they are in ! -- different variant, or whether we have a definite problem. if Overlap_Check_Required then Overlap_Check2 : declare *************** package body Sem_Ch13 is *** 2569,2575 **** -- Loop through all components in record. For each component check -- for overlap with any of the preceding elements on the component ! -- list containing the component, and also, if the component is in -- a variant, check against components outside the case structure. -- This latter test is repeated recursively up the variant tree. --- 2647,2653 ---- -- Loop through all components in record. For each component check -- for overlap with any of the preceding elements on the component ! -- list containing the component and also, if the component is in -- a variant, check against components outside the case structure. -- This latter test is repeated recursively up the variant tree. *************** package body Sem_Ch13 is *** 2597,2603 **** Component_List_Loop : loop -- If derived type definition, go to full declaration ! -- If at outer level, check discriminants if there are any if Nkind (Clist) = N_Derived_Type_Definition then Clist := Parent (Clist); --- 2675,2681 ---- Component_List_Loop : loop -- If derived type definition, go to full declaration ! -- If at outer level, check discriminants if there are any. if Nkind (Clist) = N_Derived_Type_Definition then Clist := Parent (Clist); *************** package body Sem_Ch13 is *** 2605,2612 **** -- Outer level of record definition, check discriminants ! if Nkind (Clist) = N_Full_Type_Declaration ! or else Nkind (Clist) = N_Private_Type_Declaration then if Has_Discriminants (Defining_Identifier (Clist)) then C2_Ent := --- 2683,2690 ---- -- Outer level of record definition, check discriminants ! if Nkind_In (Clist, N_Full_Type_Declaration, ! N_Private_Type_Declaration) then if Has_Discriminants (Defining_Identifier (Clist)) then C2_Ent := *************** package body Sem_Ch13 is *** 2644,2666 **** -- be a variant, in which case its parent is a variant part, -- and the parent of the variant part is a component list -- whose components must all be checked against the current ! -- component for overlap. if Nkind (Parent (Clist)) = N_Variant then Clist := Parent (Parent (Parent (Clist))); -- Check for possible discriminant part in record, this is -- treated essentially as another level in the recursion. ! -- For this case we have the parent of the component list ! -- is the record definition, and its parent is the full ! -- type declaration which contains the discriminant ! -- specifications. elsif Nkind (Parent (Clist)) = N_Record_Definition then Clist := Parent (Parent ((Clist))); -- If neither of these two cases, we are at the top of ! -- the tree else exit Component_List_Loop; --- 2722,2743 ---- -- be a variant, in which case its parent is a variant part, -- and the parent of the variant part is a component list -- whose components must all be checked against the current ! -- component for overlap). if Nkind (Parent (Clist)) = N_Variant then Clist := Parent (Parent (Parent (Clist))); -- Check for possible discriminant part in record, this is -- treated essentially as another level in the recursion. ! -- For this case the parent of the component list is the ! -- record definition, and its parent is the full type ! -- declaration containing the discriminant specifications. elsif Nkind (Parent (Clist)) = N_Record_Definition then Clist := Parent (Parent ((Clist))); -- If neither of these two cases, we are at the top of ! -- the tree. else exit Component_List_Loop; *************** package body Sem_Ch13 is *** 2674,2697 **** end Overlap_Check2; end if; ! -- For records that have component clauses for all components, and ! -- whose size is less than or equal to 32, we need to know the size ! -- in the front end to activate possible packed array processing ! -- where the component type is a record. ! -- At this stage Hbit + 1 represents the first unused bit from all ! -- the component clauses processed, so if the component clauses are -- complete, then this is the length of the record. ! -- For records longer than System.Storage_Unit, and for those where ! -- not all components have component clauses, the back end determines ! -- the length (it may for example be appopriate to round up the size ! -- to some convenient boundary, based on alignment considerations etc). ! if Unknown_RM_Size (Rectype) ! and then Hbit + 1 <= 32 ! then ! -- Nothing to do if at least one component with no component clause Comp := First_Component_Or_Discriminant (Rectype); while Present (Comp) loop --- 2751,2773 ---- end Overlap_Check2; end if; ! -- For records that have component clauses for all components, and whose ! -- size is less than or equal to 32, we need to know the size in the ! -- front end to activate possible packed array processing where the ! -- component type is a record. ! -- At this stage Hbit + 1 represents the first unused bit from all the ! -- component clauses processed, so if the component clauses are -- complete, then this is the length of the record. ! -- For records longer than System.Storage_Unit, and for those where not ! -- all components have component clauses, the back end determines the ! -- length (it may for example be appropriate to round up the size ! -- to some convenient boundary, based on alignment considerations, etc). ! if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then ! ! -- Nothing to do if at least one component has no component clause Comp := First_Component_Or_Discriminant (Rectype); while Present (Comp) loop *************** package body Sem_Ch13 is *** 2722,2730 **** -- If no Complete_Representation pragma, warn if missing components ! elsif Warn_On_Unrepped_Components ! and then not Warnings_Off (Rectype) ! then declare Num_Repped_Components : Nat := 0; Num_Unrepped_Components : Nat := 0; --- 2798,2804 ---- -- If no Complete_Representation pragma, warn if missing components ! elsif Warn_On_Unrepped_Components then declare Num_Repped_Components : Nat := 0; Num_Unrepped_Components : Nat := 0; *************** package body Sem_Ch13 is *** 2736,2742 **** while Present (Comp) loop if Present (Component_Clause (Comp)) then Num_Repped_Components := Num_Repped_Components + 1; - else Num_Unrepped_Components := Num_Unrepped_Components + 1; end if; --- 2810,2815 ---- *************** package body Sem_Ch13 is *** 2747,2753 **** -- We are only interested in the case where there is at least one -- unrepped component, and at least half the components have rep -- clauses. We figure that if less than half have them, then the ! -- partial rep clause is really intentional. if Num_Unrepped_Components > 0 and then Num_Unrepped_Components < Num_Repped_Components --- 2820,2829 ---- -- We are only interested in the case where there is at least one -- unrepped component, and at least half the components have rep -- clauses. We figure that if less than half have them, then the ! -- partial rep clause is really intentional. If the component ! -- type has no underlying type set at this point (as for a generic ! -- formal type), we don't know enough to give a warning on the ! -- component. if Num_Unrepped_Components > 0 and then Num_Unrepped_Components < Num_Repped_Components *************** package body Sem_Ch13 is *** 2756,2764 **** --- 2832,2842 ---- while Present (Comp) loop if No (Component_Clause (Comp)) and then Comes_From_Source (Comp) + and then Present (Underlying_Type (Etype (Comp))) and then (Is_Scalar_Type (Underlying_Type (Etype (Comp))) or else Size_Known_At_Compile_Time (Underlying_Type (Etype (Comp)))) + and then not Has_Warnings_Off (Rectype) then Error_Msg_Sloc := Sloc (Comp); Error_Msg_NE *************** package body Sem_Ch13 is *** 2782,2790 **** if Present (Component_Clause (C1_Ent)) and then Present (Component_Clause (C2_Ent)) then ! -- Exclude odd case where we have two tag fields in the same ! -- record, both at location zero. This seems a bit strange, ! -- but it seems to happen in some circumstances ??? if Chars (C1_Ent) = Name_uTag and then Chars (C2_Ent) = Name_uTag --- 2860,2868 ---- if Present (Component_Clause (C1_Ent)) and then Present (Component_Clause (C2_Ent)) then ! -- Exclude odd case where we have two tag fields in the same record, ! -- both at location zero. This seems a bit strange, but it seems to ! -- happen in some circumstances ??? if Chars (C1_Ent) = Name_uTag and then Chars (C2_Ent) = Name_uTag *************** package body Sem_Ch13 is *** 2826,2839 **** U_Ent : Entity_Id) is procedure Check_At_Constant_Address (Nod : Node_Id); ! -- Checks that the given node N represents a name whose 'Address ! -- is constant (in the same sense as OK_Constant_Address_Clause, ! -- i.e. the address value is the same at the point of declaration ! -- of U_Ent and at the time of elaboration of the address clause. procedure Check_Expr_Constants (Nod : Node_Id); ! -- Checks that Nod meets the requirements for a constant address ! -- clause in the sense of the enclosing procedure. procedure Check_List_Constants (Lst : List_Id); -- Check that all elements of list Lst meet the requirements for a --- 2904,2917 ---- U_Ent : Entity_Id) is procedure Check_At_Constant_Address (Nod : Node_Id); ! -- Checks that the given node N represents a name whose 'Address is ! -- constant (in the same sense as OK_Constant_Address_Clause, i.e. the ! -- address value is the same at the point of declaration of U_Ent and at ! -- the time of elaboration of the address clause. procedure Check_Expr_Constants (Nod : Node_Id); ! -- Checks that Nod meets the requirements for a constant address clause ! -- in the sense of the enclosing procedure. procedure Check_List_Constants (Lst : List_Id); -- Check that all elements of list Lst meet the requirements for a *************** package body Sem_Ch13 is *** 2933,2943 **** -- If the node is an object declaration without initial -- value, some code has been expanded, and the expression -- is not constant, even if the constituents might be ! -- acceptable, as in A'Address + offset. if Ekind (Ent) = E_Variable ! and then Nkind (Declaration_Node (Ent)) ! = N_Object_Declaration and then No (Expression (Declaration_Node (Ent))) then --- 3011,3021 ---- -- If the node is an object declaration without initial -- value, some code has been expanded, and the expression -- is not constant, even if the constituents might be ! -- acceptable, as in A'Address + offset. if Ekind (Ent) = E_Variable ! and then ! Nkind (Declaration_Node (Ent)) = N_Object_Declaration and then No (Expression (Declaration_Node (Ent))) then *************** package body Sem_Ch13 is *** 2977,2992 **** or else Ekind (Ent) = 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 already processed. if not In_Same_Source_Unit (Ent, U_Ent) then return; ! -- Otherwise location of Ent must be before the ! -- location of U_Ent, that's what prior defined means. elsif Sloc (Ent) < Loc_U_Ent then return; --- 3055,3070 ---- or else Ekind (Ent) = 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 ! -- already processed. if not In_Same_Source_Unit (Ent, U_Ent) then return; ! -- Otherwise location of Ent must be before the location ! -- of U_Ent, that's what prior defined means. elsif Sloc (Ent) < Loc_U_Ent then return; *************** package body Sem_Ch13 is *** 3103,3117 **** when N_Unchecked_Type_Conversion => Check_Expr_Constants (Expression (Nod)); ! -- If this is a rewritten unchecked conversion, subtypes ! -- in this node are those created within the instance. ! -- To avoid order of elaboration issues, replace them ! -- with their base types. Note that address clauses can ! -- cause order of elaboration problems because they are ! -- elaborated by the back-end at the point of definition, ! -- and may mention entities declared in between (as long ! -- as everything is static). It is user-friendly to allow ! -- unchecked conversions in this context. if Nkind (Original_Node (Nod)) = N_Function_Call then Set_Etype (Expression (Nod), --- 3181,3195 ---- when N_Unchecked_Type_Conversion => Check_Expr_Constants (Expression (Nod)); ! -- If this is a rewritten unchecked conversion, subtypes in ! -- this node are those created within the instance. To avoid ! -- order of elaboration issues, replace them with their base ! -- types. Note that address clauses can cause order of ! -- elaboration problems because they are elaborated by the ! -- back-end at the point of definition, and may mention ! -- entities declared in between (as long as everything is ! -- static). It is user-friendly to allow unchecked conversions ! -- in this context. if Nkind (Original_Node (Nod)) = N_Function_Call then Set_Etype (Expression (Nod), *************** package body Sem_Ch13 is *** 3271,3277 **** if Siz < M then -- Size is less than minimum size, but one possibility remains ! -- that we can manage with the new size if we bias the type M := UI_From_Int (Minimum_Size (UT, Biased => True)); --- 3349,3355 ---- if Siz < M then -- Size is less than minimum size, but one possibility remains ! -- that we can manage with the new size if we bias the type. M := UI_From_Int (Minimum_Size (UT, Biased => True)); *************** package body Sem_Ch13 is *** 3343,3351 **** else declare Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); - begin ! return Id = Attribute_Input or else Id = Attribute_Output or else Id = Attribute_Read or else Id = Attribute_Write --- 3421,3428 ---- else declare Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); begin ! return Id = Attribute_Input or else Id = Attribute_Output or else Id = Attribute_Read or else Id = Attribute_Write *************** package body Sem_Ch13 is *** 3393,3399 **** -- we have short and long addresses, and it is possible for an access -- type to have a short address size (and thus be less than the size -- of System.Address itself). We simply skip the check for VMS, and ! -- leave the back end to do the check. elsif Is_Access_Type (T) then if OpenVMS_On_Target then --- 3470,3476 ---- -- we have short and long addresses, and it is possible for an access -- type to have a short address size (and thus be less than the size -- of System.Address itself). We simply skip the check for VMS, and ! -- leave it to the back end to do the check. elsif Is_Access_Type (T) then if OpenVMS_On_Target then *************** package body Sem_Ch13 is *** 3411,3419 **** elsif Is_Discrete_Type (T) then ! -- The following loop is looking for the nearest compile time ! -- known bounds following the ancestor subtype chain. The idea ! -- is to find the most restrictive known bounds information. Ancest := T; loop --- 3488,3496 ---- elsif Is_Discrete_Type (T) then ! -- The following loop is looking for the nearest compile time known ! -- bounds following the ancestor subtype chain. The idea is to find ! -- the most restrictive known bounds information. Ancest := T; loop *************** package body Sem_Ch13 is *** 3449,3465 **** end loop; -- Fixed-point types. We can't simply use Expr_Value to get the ! -- Corresponding_Integer_Value values of the bounds, since these ! -- do not get set till the type is frozen, and this routine can ! -- be called before the type is frozen. Similarly the test for ! -- bounds being static needs to include the case where we have ! -- unanalyzed real literals for the same reason. elsif Is_Fixed_Point_Type (T) then ! -- The following loop is looking for the nearest compile time ! -- known bounds following the ancestor subtype chain. The idea ! -- is to find the most restrictive known bounds information. Ancest := T; loop --- 3526,3542 ---- end loop; -- Fixed-point types. We can't simply use Expr_Value to get the ! -- Corresponding_Integer_Value values of the bounds, since these do not ! -- get set till the type is frozen, and this routine can be called ! -- before the type is frozen. Similarly the test for bounds being static ! -- needs to include the case where we have unanalyzed real literals for ! -- the same reason. elsif Is_Fixed_Point_Type (T) then ! -- The following loop is looking for the nearest compile time known ! -- bounds following the ancestor subtype chain. The idea is to find ! -- the most restrictive known bounds information. Ancest := T; loop *************** package body Sem_Ch13 is *** 3520,3526 **** -- Fall through with Hi and Lo set. Deal with biased case ! if (Biased and then not Is_Fixed_Point_Type (T)) or else Has_Biased_Representation (T) then Hi := Hi - Lo; --- 3597,3606 ---- -- Fall through with Hi and Lo set. Deal with biased case ! if (Biased ! and then not Is_Fixed_Point_Type (T) ! and then not (Is_Enumeration_Type (T) ! and then Has_Non_Standard_Rep (T))) or else Has_Biased_Representation (T) then Hi := Hi - Lo; *************** package body Sem_Ch13 is *** 3528,3535 **** end if; -- Signed case. Note that we consider types like range 1 .. -1 to be ! -- signed for the purpose of computing the size, since the bounds ! -- have to be accomodated in the base type. if Lo < 0 or else Hi < 0 then S := 1; --- 3608,3615 ---- end if; -- Signed case. Note that we consider types like range 1 .. -1 to be ! -- signed for the purpose of computing the size, since the bounds have ! -- to be accommodated in the base type. if Lo < 0 or else Hi < 0 then S := 1; *************** package body Sem_Ch13 is *** 3721,3727 **** return True; end if; ! -- Otherwise check for incompleted type if Is_Incomplete_Or_Private_Type (T) and then No (Underlying_Type (T)) --- 3801,3807 ---- return True; end if; ! -- Otherwise check for incomplete type if Is_Incomplete_Or_Private_Type (T) and then No (Underlying_Type (T)) *************** package body Sem_Ch13 is *** 3730,3736 **** ("representation item must be after full type declaration", N); return True; ! -- If the type has incompleted components, a representation clause is -- illegal but stream attributes and Convention pragmas are correct. elsif Has_Private_Component (T) then --- 3810,3816 ---- ("representation item must be after full type declaration", N); return True; ! -- If the type has incomplete components, a representation clause is -- illegal but stream attributes and Convention pragmas are correct. elsif Has_Private_Component (T) then *************** package body Sem_Ch13 is *** 3823,3845 **** if Is_Overloadable (T) and then Nkind (N) = N_Pragma - and then (Chars (N) = Name_Convention - or else - Chars (N) = Name_Import - or else - Chars (N) = Name_Export - or else - Chars (N) = Name_External - or else - Chars (N) = Name_Interface) then ! null; ! else ! Record_Rep_Item (T, N); end if; ! -- Rep item was OK, not too late ! return False; end Rep_Item_Too_Late; --- 3903,3924 ---- if Is_Overloadable (T) and then Nkind (N) = N_Pragma then ! declare ! Pname : constant Name_Id := Pragma_Name (N); ! begin ! if Pname = Name_Convention or else ! Pname = Name_Import or else ! Pname = Name_Export or else ! Pname = Name_External or else ! Pname = Name_Interface ! then ! return False; ! end if; ! end; end if; ! Record_Rep_Item (T, N); return False; end Rep_Item_Too_Late; *************** package body Sem_Ch13 is *** 3915,3922 **** return not Has_Non_Standard_Rep (T2); end if; ! -- Here the two types both have non-standard representation, and we ! -- need to determine if they have the same non-standard representation -- For arrays, we simply need to test if the component sizes are the -- same. Pragma Pack is reflected in modified component sizes, so this --- 3994,4001 ---- return not Has_Non_Standard_Rep (T2); end if; ! -- Here the two types both have non-standard representation, and we need ! -- to determine if they have the same non-standard representation. -- For arrays, we simply need to test if the component sizes are the -- same. Pragma Pack is reflected in modified component sizes, so this *************** package body Sem_Ch13 is *** 4014,4020 **** -- For enumeration types, we must check each literal to see if the -- representation is the same. Note that we do not permit enumeration ! -- reprsentation clauses for Character and Wide_Character, so these -- cases were already dealt with. elsif Is_Enumeration_Type (T1) then --- 4093,4099 ---- -- For enumeration types, we must check each literal to see if the -- representation is the same. Note that we do not permit enumeration ! -- representation clauses for Character and Wide_Character, so these -- cases were already dealt with. elsif Is_Enumeration_Type (T1) then *************** package body Sem_Ch13 is *** 4236,4243 **** Target := Ancestor_Subtype (Etype (Act_Unit)); ! -- If either type is generic, the instantiation happens within a ! -- generic unit, and there is nothing to check. The proper check -- will happen when the enclosing generic is instantiated. if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then --- 4315,4322 ---- Target := Ancestor_Subtype (Etype (Act_Unit)); ! -- If either type is generic, the instantiation happens within a generic ! -- unit, and there is nothing to check. The proper check -- will happen when the enclosing generic is instantiated. if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then *************** package body Sem_Ch13 is *** 4267,4274 **** and then Convention (Target) /= Convention (Source) and then Warn_On_Unchecked_Conversion then ! Error_Msg_N ! ("?conversion between pointers with different conventions!", N); end if; -- Warn if one of the operands is Ada.Calendar.Time. Do not emit a --- 4346,4362 ---- and then Convention (Target) /= Convention (Source) and then Warn_On_Unchecked_Conversion then ! -- Give warnings for subprogram pointers only on most targets. The ! -- exception is VMS, where data pointers can have different lengths ! -- depending on the pointer convention. ! ! if Is_Access_Subprogram_Type (Target) ! or else Is_Access_Subprogram_Type (Source) ! or else OpenVMS_On_Target ! then ! Error_Msg_N ! ("?conversion between pointers with different conventions!", N); ! end if; end if; -- Warn if one of the operands is Ada.Calendar.Time. Do not emit a *************** package body Sem_Ch13 is *** 4301,4310 **** end; end if; ! -- Make entry in unchecked conversion table for later processing ! -- by Validate_Unchecked_Conversions, which will check sizes and ! -- alignments (using values set by the back-end where possible). ! -- This is only done if the appropriate warning is active if Warn_On_Unchecked_Conversion then Unchecked_Conversions.Append --- 4389,4398 ---- end; end if; ! -- Make entry in unchecked conversion table for later processing by ! -- Validate_Unchecked_Conversions, which will check sizes and alignments ! -- (using values set by the back-end where possible). This is only done ! -- if the appropriate warning is active. if Warn_On_Unchecked_Conversion then Unchecked_Conversions.Append *************** package body Sem_Ch13 is *** 4326,4335 **** end if; end if; ! -- If unchecked conversion to access type, and access type is ! -- declared in the same unit as the unchecked conversion, then ! -- set the No_Strict_Aliasing flag (no strict aliasing is ! -- implicit in this situation). if Is_Access_Type (Target) and then In_Same_Source_Unit (Target, N) --- 4414,4423 ---- end if; end if; ! -- If unchecked conversion to access type, and access type is declared ! -- in the same unit as the unchecked conversion, then set the ! -- No_Strict_Aliasing flag (no strict aliasing is implicit in this ! -- situation). if Is_Access_Type (Target) and then In_Same_Source_Unit (Target, N) *************** package body Sem_Ch13 is *** 4340,4346 **** -- Generate N_Validate_Unchecked_Conversion node for back end in -- case the back end needs to perform special validation checks. ! -- Shouldn't this be in exp_ch13, since the check only gets done -- if we have full expansion and the back end is called ??? Vnode := --- 4428,4434 ---- -- Generate N_Validate_Unchecked_Conversion node for back end in -- case the back end needs to perform special validation checks. ! -- Shouldn't this be in Exp_Ch13, since the check only gets done -- if we have full expansion and the back end is called ??? Vnode := *************** package body Sem_Ch13 is *** 4348,4355 **** Set_Source_Type (Vnode, Source); Set_Target_Type (Vnode, Target); ! -- If the unchecked conversion node is in a list, just insert before ! -- it. If not we have some strange case, not worth bothering about. if Is_List_Member (N) then Insert_After (N, Vnode); --- 4436,4443 ---- Set_Source_Type (Vnode, Source); Set_Target_Type (Vnode, Target); ! -- If the unchecked conversion node is in a list, just insert before it. ! -- If not we have some strange case, not worth bothering about. if Is_List_Member (N) then Insert_After (N, Vnode); *************** package body Sem_Ch13 is *** 4374,4384 **** Target_Siz : Uint; begin ! -- This validation check, which warns if we have unequal sizes ! -- for unchecked conversion, and thus potentially implementation -- dependent semantics, is one of the few occasions on which we ! -- use the official RM size instead of Esize. See description ! -- in Einfo "Handling of Type'Size Values" for details. if Serious_Errors_Detected = 0 and then Known_Static_RM_Size (Source) --- 4462,4472 ---- Target_Siz : Uint; begin ! -- This validation check, which warns if we have unequal sizes for ! -- unchecked conversion, and thus potentially implementation -- dependent semantics, is one of the few occasions on which we ! -- use the official RM size instead of Esize. See description in ! -- Einfo "Handling of Type'Size Values" for details. if Serious_Errors_Detected = 0 and then Known_Static_RM_Size (Source) diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch13.ads gcc-4.4.0/gcc/ada/sem_ch13.ads *** gcc-4.3.3/gcc/ada/sem_ch13.ads Wed Sep 26 10:42:29 2007 --- gcc-4.4.0/gcc/ada/sem_ch13.ads Sat Jun 7 16:10:50 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Sem_Ch13 is *** 64,70 **** -- the given type, of the size the type would have if it were biased. If -- the type is already biased, then Minimum_Size returns the biased size, -- regardless of the setting of Biased. Also, fixed-point types are never ! -- biased in the current implementation. procedure Check_Constant_Address_Clause (Expr : Node_Id; U_Ent : Entity_Id); -- Expr is an expression for an address clause. This procedure checks --- 64,71 ---- -- the given type, of the size the type would have if it were biased. If -- the type is already biased, then Minimum_Size returns the biased size, -- regardless of the setting of Biased. Also, fixed-point types are never ! -- biased in the current implementation. If the size is not known at ! -- compile time, this function returns 0. procedure Check_Constant_Address_Clause (Expr : Node_Id; U_Ent : Entity_Id); -- Expr is an expression for an address clause. This procedure checks *************** package Sem_Ch13 is *** 99,105 **** function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean; -- Called at the start of processing a representation clause or a -- representation pragma. Used to check that the representation item ! -- is not being applied to an incompleted type or to a generic formal -- type or a type derived from a generic formal type. Returns False if -- no such error occurs. If this error does occur, appropriate error -- messages are posted on node N, and True is returned. --- 100,106 ---- function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean; -- Called at the start of processing a representation clause or a -- representation pragma. Used to check that the representation item ! -- is not being applied to an incomplete type or to a generic formal -- type or a type derived from a generic formal type. Returns False if -- no such error occurs. If this error does occur, appropriate error -- messages are posted on node N, and True is returned. *************** package Sem_Ch13 is *** 121,127 **** -- stream attributes, which, although certainly not subtype related -- attributes, clearly should not be subject to the para 10 restrictions -- (see AI95-00137). Similarly, we also skip the para 10 restrictions for ! -- the Storage_Size case where they also clearly do not apply. -- -- If the rep item is too late, an appropriate message is output and -- True is returned, which is a signal that the caller should abandon --- 122,129 ---- -- stream attributes, which, although certainly not subtype related -- attributes, clearly should not be subject to the para 10 restrictions -- (see AI95-00137). Similarly, we also skip the para 10 restrictions for ! -- the Storage_Size case where they also clearly do not apply, and for ! -- Stream_Convert which is in the same category as the stream attributes. -- -- If the rep item is too late, an appropriate message is output and -- True is returned, which is a signal that the caller should abandon *************** package Sem_Ch13 is *** 149,155 **** Act_Unit : Entity_Id); -- Validate a call to unchecked conversion. N is the node for the actual -- instantiation, which is used only for error messages. Act_Unit is the ! -- entity for the instantiation, from which the actual types etc for this -- instantiation can be determined. This procedure makes an entry in a -- table and/or generates an N_Validate_Unchecked_Conversion node. The -- actual checking is done in Validate_Unchecked_Conversions or in the --- 151,157 ---- Act_Unit : Entity_Id); -- Validate a call to unchecked conversion. N is the node for the actual -- instantiation, which is used only for error messages. Act_Unit is the ! -- entity for the instantiation, from which the actual types etc. for this -- instantiation can be determined. This procedure makes an entry in a -- table and/or generates an N_Validate_Unchecked_Conversion node. The -- actual checking is done in Validate_Unchecked_Conversions or in the diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch3.adb gcc-4.4.0/gcc/ada/sem_ch3.adb *** gcc-4.3.3/gcc/ada/sem_ch3.adb Wed Dec 19 16:24:34 2007 --- gcc-4.4.0/gcc/ada/sem_ch3.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Einfo; use Einfo; *** 31,36 **** --- 31,38 ---- with Errout; use Errout; with Eval_Fat; use Eval_Fat; with Exp_Ch3; use Exp_Ch3; + with Exp_Ch9; use Exp_Ch9; + with Exp_Disp; use Exp_Disp; with Exp_Dist; use Exp_Dist; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; *************** package body Sem_Ch3 is *** 94,100 **** -- Parent_Type is the entity for the parent type in the derived type -- definition and Derived_Type the actual derived type. Is_Completion must -- be set to False if Derived_Type is the N_Defining_Identifier node in N ! -- (ie Derived_Type = Defining_Identifier (N)). In this case N is not the -- completion of a private type declaration. If Is_Completion is set to -- True, N is the completion of a private type declaration and Derived_Type -- is different from the defining identifier inside N (i.e. Derived_Type /= --- 96,102 ---- -- Parent_Type is the entity for the parent type in the derived type -- definition and Derived_Type the actual derived type. Is_Completion must -- be set to False if Derived_Type is the N_Defining_Identifier node in N ! -- (i.e. Derived_Type = Defining_Identifier (N)). In this case N is not the -- completion of a private type declaration. If Is_Completion is set to -- True, N is the completion of a private type declaration and Derived_Type -- is different from the defining identifier inside N (i.e. Derived_Type /= *************** package body Sem_Ch3 is *** 236,241 **** --- 238,244 ---- -- itype. The Itype_Reference node forces the elaboration of the itype -- in the proper scope. The node is inserted after Nod, which is the -- enclosing declaration that generated Ityp. + -- -- A related mechanism is used during expansion, for itypes created in -- branches of conditionals. See Ensure_Defined in exp_util. -- Could both mechanisms be merged ??? *************** package body Sem_Ch3 is *** 252,260 **** -- view cannot itself have a full view (it would get clobbered during -- view exchanges). - procedure Check_Abstract_Interfaces (N : Node_Id; Def : Node_Id); - -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) - procedure Check_Access_Discriminant_Requires_Limited (D : Node_Id; Loc : Node_Id); --- 255,260 ---- *************** package body Sem_Ch3 is *** 288,293 **** --- 288,296 ---- -- Validate the initialization of an object declaration. T is the required -- type, and Exp is the initialization expression. + procedure Check_Interfaces (N : Node_Id; Def : Node_Id); + -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) + procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id; *************** package body Sem_Ch3 is *** 341,351 **** Constraints : Elist_Id); -- Build the list of entities for a constrained discriminated record -- subtype. If a component depends on a discriminant, replace its subtype ! -- using the discriminant values in the discriminant constraint. Subt is ! -- the defining identifier for the subtype whose list of constrained ! -- entities we will create. Decl_Node is the type declaration node where we ! -- will attach all the itypes created. Typ is the base discriminated type ! -- for the subtype Subt. Constraints is the list of discriminant -- constraints for Typ. function Constrain_Component_Type --- 344,354 ---- Constraints : Elist_Id); -- Build the list of entities for a constrained discriminated record -- subtype. If a component depends on a discriminant, replace its subtype ! -- using the discriminant values in the discriminant constraint. Subt ! -- is the defining identifier for the subtype whose list of constrained ! -- entities we will create. Decl_Node is the type declaration node where ! -- we will attach all the itypes created. Typ is the base discriminated ! -- type for the subtype Subt. Constraints is the list of discriminant -- constraints for Typ. function Constrain_Component_Type *************** package body Sem_Ch3 is *** 362,367 **** --- 365,371 ---- -- Constrained_Typ is the final constrained subtype to which the -- constrained Compon_Type belongs. Related_Node is the node where we will -- attach all the itypes created. + -- -- Above description is confused, what is Compon_Type??? procedure Constrain_Access *************** package body Sem_Ch3 is *** 484,497 **** -- appropriate semantic fields. If the full view of the parent is a record -- type, build constrained components of subtype. ! procedure Derive_Interface_Subprograms (Parent_Type : Entity_Id; ! Tagged_Type : Entity_Id; ! Ifaces_List : Elist_Id); ! -- Ada 2005 (AI-251): Derive primitives of abstract interface types that ! -- are not immediate ancestors of Tagged type and associate them their ! -- aliased primitive. Ifaces_List contains the abstract interface ! -- primitives that have been derived from Parent_Type. procedure Derived_Standard_Character (N : Node_Id; --- 488,503 ---- -- appropriate semantic fields. If the full view of the parent is a record -- type, build constrained components of subtype. ! procedure Derive_Progenitor_Subprograms (Parent_Type : Entity_Id; ! Tagged_Type : Entity_Id); ! -- Ada 2005 (AI-251): To complete type derivation, collect the primitive ! -- operations of progenitors of Tagged_Type, and replace the subsidiary ! -- subtypes with Tagged_Type, to build the specs of the inherited interface ! -- primitives. The derived primitives are aliased to those of the ! -- interface. This routine takes care also of transferring to the full-view ! -- subprograms associated with the partial-view of Tagged_Type that cover ! -- interface primitives. procedure Derived_Standard_Character (N : Node_Id; *************** package body Sem_Ch3 is *** 504,515 **** (T : Entity_Id; N : Node_Id; Is_Completion : Boolean); ! -- Process a derived type declaration. This routine will invoke ! -- Build_Derived_Type to process the actual derived type definition. ! -- Parameters N and Is_Completion have the same meaning as in ! -- Build_Derived_Type. T is the N_Defining_Identifier for the entity ! -- defined in the N_Full_Type_Declaration node N, that is T is the derived ! -- type. procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Insert each literal in symbol table, as an overloadable identifier. Each --- 510,520 ---- (T : Entity_Id; N : Node_Id; Is_Completion : Boolean); ! -- Process a derived type declaration. Build_Derived_Type is invoked ! -- to process the actual derived type definition. Parameters N and ! -- Is_Completion have the same meaning as in Build_Derived_Type. ! -- T is the N_Defining_Identifier for the entity defined in the ! -- N_Full_Type_Declaration node N, that is T is the derived type. procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Insert each literal in symbol table, as an overloadable identifier. Each *************** package body Sem_Ch3 is *** 521,527 **** function Expand_To_Stored_Constraint (Typ : Entity_Id; Constraint : Elist_Id) return Elist_Id; ! -- Given a Constraint (i.e. a list of expressions) on the discriminants of -- Typ, expand it into a constraint on the stored discriminants and return -- the new list of expressions constraining the stored discriminants. --- 526,532 ---- function Expand_To_Stored_Constraint (Typ : Entity_Id; Constraint : Elist_Id) return Elist_Id; ! -- Given a constraint (i.e. a list of expressions) on the discriminants of -- Typ, expand it into a constraint on the stored discriminants and return -- the new list of expressions constraining the stored discriminants. *************** package body Sem_Ch3 is *** 532,538 **** -- implicit types generated to Related_Nod procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id); ! -- Create a new float, and apply the constraint to obtain subtype of it function Has_Range_Constraint (N : Node_Id) return Boolean; -- Given an N_Subtype_Indication node N, return True if a range constraint --- 537,543 ---- -- implicit types generated to Related_Nod procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id); ! -- Create a new float and apply the constraint to obtain subtype of it function Has_Range_Constraint (N : Node_Id) return Boolean; -- Given an N_Subtype_Indication node N, return True if a range constraint *************** package body Sem_Ch3 is *** 582,587 **** --- 587,600 ---- -- copying the record declaration for the derived base. In the tagged case -- the value returned is irrelevant. + function Is_Progenitor + (Iface : Entity_Id; + Typ : Entity_Id) return Boolean; + -- Determine whether type Typ implements interface Iface. This requires + -- traversing the list of abstract interfaces of the type, as well as that + -- of the ancestor types. The predicate is used to determine when a formal + -- in the signature of an inherited operation must carry the derived type. + function Is_Valid_Constraint_Kind (T_Kind : Type_Kind; Constraint_Kind : Node_Kind) return Boolean; *************** package body Sem_Ch3 is *** 632,647 **** -- Similarly, access_to_subprogram types may have a parameter or a return -- type that is an incomplete type, and that must be replaced with the -- full type. ! -- If the full type is tagged, subprogram with access parameters that -- designated the incomplete may be primitive operations of the full type, -- and have to be processed accordingly. procedure Process_Real_Range_Specification (Def : Node_Id); ! -- Given the type definition for a real type, this procedure processes ! -- and checks the real range specification of this type definition if ! -- one is present. If errors are found, error messages are posted, and ! -- the Real_Range_Specification of Def is reset to Empty. procedure Record_Type_Declaration (T : Entity_Id; --- 645,660 ---- -- Similarly, access_to_subprogram types may have a parameter or a return -- type that is an incomplete type, and that must be replaced with the -- full type. ! -- -- If the full type is tagged, subprogram with access parameters that -- designated the incomplete may be primitive operations of the full type, -- and have to be processed accordingly. procedure Process_Real_Range_Specification (Def : Node_Id); ! -- Given the type definition for a real type, this procedure processes and ! -- checks the real range specification of this type definition if one is ! -- present. If errors are found, error messages are posted, and the ! -- Real_Range_Specification of Def is reset to Empty. procedure Record_Type_Declaration (T : Entity_Id; *************** package body Sem_Ch3 is *** 655,668 **** -- cross-referencing. Otherwise Prev = T. procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id); ! -- This routine is used to process the actual record type definition ! -- (both for untagged and tagged records). Def is a record type ! -- definition node. This procedure analyzes the components in this ! -- record type definition. Prev_T is the entity for the enclosing record ! -- type. It is provided so that its Has_Task flag can be set if any of ! -- the component have Has_Task set. If the declaration is the completion ! -- of an incomplete type declaration, Prev_T is the original incomplete ! -- type, whose full view is the record type. procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id); -- Subsidiary to Build_Derived_Record_Type. For untagged records, we --- 668,681 ---- -- cross-referencing. Otherwise Prev = T. procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id); ! -- This routine is used to process the actual record type definition (both ! -- for untagged and tagged records). Def is a record type definition node. ! -- This procedure analyzes the components in this record type definition. ! -- Prev_T is the entity for the enclosing record type. It is provided so ! -- that its Has_Task flag can be set if any of the component have Has_Task ! -- set. If the declaration is the completion of an incomplete type ! -- declaration, Prev_T is the original incomplete type, whose full view is ! -- the record type. procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id); -- Subsidiary to Build_Derived_Record_Type. For untagged records, we *************** package body Sem_Ch3 is *** 700,705 **** --- 713,722 ---- -- E is some record type. This routine computes E's Stored_Constraint -- from its Discriminant_Constraint. + procedure Diagnose_Interface (N : Node_Id; E : Entity_Id); + -- Check that an entity in a list of progenitors is an interface, + -- emit error otherwise. + ----------------------- -- Access_Definition -- ----------------------- *************** package body Sem_Ch3 is *** 740,746 **** -- formal part is currently being analyzed, but will be the parent scope -- in the case of a parameterless function, and we always want to use -- the function's parent scope. Finally, if the function is a child ! -- unit, we must traverse the the tree to retrieve the proper entity. elsif Nkind (Related_Nod) = N_Function_Specification and then Nkind (Parent (N)) /= N_Parameter_Specification --- 757,763 ---- -- formal part is currently being analyzed, but will be the parent scope -- in the case of a parameterless function, and we always want to use -- the function's parent scope. Finally, if the function is a child ! -- unit, we must traverse the tree to retrieve the proper entity. elsif Nkind (Related_Nod) = N_Function_Specification and then Nkind (Parent (N)) /= N_Parameter_Specification *************** package body Sem_Ch3 is *** 748,754 **** -- If the current scope is a protected type, the anonymous access -- is associated with one of the protected operations, and must -- be available in the scope that encloses the protected declaration. ! -- Otherwise the type is is in the scope enclosing the subprogram. if Ekind (Current_Scope) = E_Protected_Type then Anon_Scope := Scope (Scope (Defining_Entity (Related_Nod))); --- 765,771 ---- -- If the current scope is a protected type, the anonymous access -- is associated with one of the protected operations, and must -- be available in the scope that encloses the protected declaration. ! -- Otherwise the type is in the scope enclosing the subprogram. if Ekind (Current_Scope) = E_Protected_Type then Anon_Scope := Scope (Scope (Defining_Entity (Related_Nod))); *************** package body Sem_Ch3 is *** 809,816 **** Set_Directly_Designated_Type (Anon_Type, Desig_Type); Set_Etype (Anon_Type, Anon_Type); ! Init_Size_Align (Anon_Type); Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type)); -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if --- 826,845 ---- Set_Directly_Designated_Type (Anon_Type, Desig_Type); Set_Etype (Anon_Type, Anon_Type); ! ! -- Make sure the anonymous access type has size and alignment fields ! -- set, as required by gigi. This is necessary in the case of the ! -- Task_Body_Procedure. ! ! if not Has_Private_Component (Desig_Type) then ! Layout_Type (Anon_Type); ! end if; ! ! -- ???The following makes no sense, because Anon_Type is an access type ! -- and therefore cannot have components, private or otherwise. Hence ! -- the assertion. Not sure what was meant, here. Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type)); + pragma Assert (not Depends_On_Private (Anon_Type)); -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if *************** package body Sem_Ch3 is *** 904,909 **** --- 933,967 ---- if Nkind (Parent (Related_Nod)) = N_Protected_Definition then Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod))); + + -- Similarly, if the access definition is the return result of a + -- function, create an itype reference for it because it + -- will be used within the function body. For a regular function that + -- is not a compilation unit, insert reference after the declaration. + -- For a protected operation, insert it after the enclosing protected + -- type declaration. In either case, do not create a reference for a + -- type obtained through a limited_with clause, because this would + -- introduce semantic dependencies. + + elsif Nkind (Related_Nod) = N_Function_Specification + and then not From_With_Type (Anon_Type) + then + if Ekind (Current_Scope) = E_Protected_Type then + Build_Itype_Reference (Anon_Type, Parent (Current_Scope)); + + elsif Is_List_Member (Parent (Related_Nod)) + and then Nkind (Parent (N)) /= N_Parameter_Specification + then + Build_Itype_Reference (Anon_Type, Parent (Related_Nod)); + end if; + + -- Finally, create an itype reference for an object declaration of + -- an anonymous access type. This is strictly necessary only for + -- deferred constants, but in any case will avoid out-of-scope + -- problems in the back-end. + + elsif Nkind (Related_Nod) = N_Object_Declaration then + Build_Itype_Reference (Anon_Type, Related_Nod); end if; return Anon_Type; *************** package body Sem_Ch3 is *** 996,1001 **** --- 1054,1060 ---- or else Nkind_In (D_Ityp, N_Object_Declaration, N_Object_Renaming_Declaration, + N_Formal_Object_Declaration, N_Formal_Type_Declaration, N_Task_Type_Declaration, N_Protected_Type_Declaration)) *************** package body Sem_Ch3 is *** 1058,1070 **** if Present (Formals) then Push_Scope (Desig_Type); Process_Formals (Formals, Parent (T_Def)); ! -- A bit of a kludge here, End_Scope requires that the parent ! -- pointer be set to something reasonable, but Itypes don't have ! -- parent pointers. So we set it and then unset it ??? If and when ! -- Itypes have proper parent pointers to their declarations, this ! -- kludge can be removed. Set_Parent (Desig_Type, T_Name); End_Scope; --- 1117,1148 ---- if Present (Formals) then Push_Scope (Desig_Type); + + -- A bit of a kludge here. These kludges will be removed when Itypes + -- have proper parent pointers to their declarations??? + + -- Kludge 1) Link defining_identifier of formals. Required by + -- First_Formal to provide its functionality. + + declare + F : Node_Id; + + begin + F := First (Formals); + while Present (F) loop + if No (Parent (Defining_Identifier (F))) then + Set_Parent (Defining_Identifier (F), F); + end if; + + Next (F); + end loop; + end; + Process_Formals (Formals, Parent (T_Def)); ! -- Kludge 2) End_Scope requires that the parent pointer be set to ! -- something reasonable, but Itypes don't have parent pointers. So ! -- we set it and then unset it ??? Set_Parent (Desig_Type, T_Name); End_Scope; *************** package body Sem_Ch3 is *** 1101,1108 **** --- 1179,1191 ---- end loop; end if; + -- If the return type is incomplete, this is legal as long as the + -- type is declared in the current scope and will be completed in + -- it (rather than being part of limited view). + if Ekind (Etype (Desig_Type)) = E_Incomplete_Type and then not Has_Delayed_Freeze (Desig_Type) + and then In_Open_Scopes (Scope (Etype (Desig_Type))) then Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type))); Set_Has_Delayed_Freeze (Desig_Type); *************** package body Sem_Ch3 is *** 1215,1220 **** --- 1298,1310 ---- Set_Has_Task (T, False); Set_Has_Controlled_Component (T, False); + -- Initialize Associated_Final_Chain explicitly to Empty, to avoid + -- problems where an incomplete view of this entity has been previously + -- established by a limited with and an overlaid version of this field + -- (Stored_Constraint) was initialized for the incomplete view. + + Set_Associated_Final_Chain (T, Empty); + -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant -- attributes *************** package body Sem_Ch3 is *** 1228,1263 **** procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); - Elmt : Elmt_Id; - Ext : Node_Id; L : List_Id; Last_Tag : Node_Id; - Comp : Node_Id; - - procedure Add_Sync_Iface_Tags (T : Entity_Id); - -- Local subprogram used to recursively climb through the parents - -- of T to add the tags of all the progenitor interfaces. procedure Add_Tag (Iface : Entity_Id); -- Add tag for one of the progenitor interfaces - ------------------------- - -- Add_Sync_Iface_Tags -- - ------------------------- - - procedure Add_Sync_Iface_Tags (T : Entity_Id) is - begin - if Etype (T) /= T then - Add_Sync_Iface_Tags (Etype (T)); - end if; - - Elmt := First_Elmt (Abstract_Interfaces (T)); - while Present (Elmt) loop - Add_Tag (Node (Elmt)); - Next_Elmt (Elmt); - end loop; - end Add_Sync_Iface_Tags; - ------------- -- Add_Tag -- ------------- --- 1318,1329 ---- *************** package body Sem_Ch3 is *** 1342,1348 **** -- Local variables ! Iface_List : List_Id; -- Start of processing for Add_Interface_Tag_Components --- 1408,1416 ---- -- Local variables ! Elmt : Elmt_Id; ! Ext : Node_Id; ! Comp : Node_Id; -- Start of processing for Add_Interface_Tag_Components *************** package body Sem_Ch3 is *** 1358,1365 **** or else (Is_Concurrent_Record_Type (Typ) and then Is_Empty_List (Abstract_Interface_List (Typ))) or else (not Is_Concurrent_Record_Type (Typ) ! and then No (Abstract_Interfaces (Typ)) ! and then Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) then return; end if; --- 1426,1433 ---- or else (Is_Concurrent_Record_Type (Typ) and then Is_Empty_List (Abstract_Interface_List (Typ))) or else (not Is_Concurrent_Record_Type (Typ) ! and then No (Interfaces (Typ)) ! and then Is_Empty_Elmt_List (Interfaces (Typ))) then return; end if; *************** package body Sem_Ch3 is *** 1413,1428 **** -- corresponding with all the interfaces that are not implemented -- by the parent. ! if Is_Concurrent_Record_Type (Typ) then ! Iface_List := Abstract_Interface_List (Typ); ! ! if Is_Non_Empty_List (Iface_List) then ! Add_Sync_Iface_Tags (Etype (First (Iface_List))); ! end if; ! end if; ! ! if Present (Abstract_Interfaces (Typ)) then ! Elmt := First_Elmt (Abstract_Interfaces (Typ)); while Present (Elmt) loop Add_Tag (Node (Elmt)); Next_Elmt (Elmt); --- 1481,1488 ---- -- corresponding with all the interfaces that are not implemented -- by the parent. ! if Present (Interfaces (Typ)) then ! Elmt := First_Elmt (Interfaces (Typ)); while Present (Elmt) loop Add_Tag (Node (Elmt)); Next_Elmt (Elmt); *************** package body Sem_Ch3 is *** 1602,1612 **** -- package Sem). if Present (E) then ! Analyze_Per_Use_Expression (E, T); Check_Initialization (T, E); if Ada_Version >= Ada_05 and then Ekind (T) = E_Anonymous_Access_Type then -- Check RM 3.9.2(9): "if the expected type for an expression is -- an anonymous access-to-specific tagged type, then the object --- 1662,1673 ---- -- package Sem). if Present (E) then ! Preanalyze_Spec_Expression (E, T); Check_Initialization (T, E); if Ada_Version >= Ada_05 and then Ekind (T) = E_Anonymous_Access_Type + and then Etype (E) /= Any_Type then -- Check RM 3.9.2(9): "if the expected type for an expression is -- an anonymous access-to-specific tagged type, then the object *************** package body Sem_Ch3 is *** 1932,1938 **** End_Scope; ! -- If the type has discriminants, non-trivial subtypes may be be -- declared before the full view of the type. The full views of those -- subtypes will be built after the full view of the type. --- 1993,1999 ---- End_Scope; ! -- If the type has discriminants, non-trivial subtypes may be -- declared before the full view of the type. The full views of those -- subtypes will be built after the full view of the type. *************** package body Sem_Ch3 is *** 1948,1965 **** CW : constant Entity_Id := Class_Wide_Type (T); begin ! Set_Is_Tagged_Type (T); ! Set_Is_Limited_Record (T, Limited_Present (Def) ! or else Task_Present (Def) ! or else Protected_Present (Def) ! or else Synchronized_Present (Def)); -- Type is abstract if full declaration carries keyword, or if previous -- partial view did. Set_Is_Abstract_Type (T); ! Set_Is_Interface (T); -- Type is a limited interface if it includes the keyword limited, task, -- protected, or synchronized. --- 2009,2026 ---- CW : constant Entity_Id := Class_Wide_Type (T); begin ! Set_Is_Tagged_Type (T); ! Set_Is_Limited_Record (T, Limited_Present (Def) ! or else Task_Present (Def) ! or else Protected_Present (Def) ! or else Synchronized_Present (Def)); -- Type is abstract if full declaration carries keyword, or if previous -- partial view did. Set_Is_Abstract_Type (T); ! Set_Is_Interface (T); -- Type is a limited interface if it includes the keyword limited, task, -- protected, or synchronized. *************** package body Sem_Ch3 is *** 1970,1977 **** or else Synchronized_Present (Def) or else Task_Present (Def)); ! Set_Is_Protected_Interface (T, Protected_Present (Def)); ! Set_Is_Task_Interface (T, Task_Present (Def)); -- Type is a synchronized interface if it includes the keyword task, -- protected, or synchronized. --- 2031,2038 ---- or else Synchronized_Present (Def) or else Task_Present (Def)); ! Set_Is_Protected_Interface (T, Protected_Present (Def)); ! Set_Is_Task_Interface (T, Task_Present (Def)); -- Type is a synchronized interface if it includes the keyword task, -- protected, or synchronized. *************** package body Sem_Ch3 is *** 1981,1991 **** or else Protected_Present (Def) or else Task_Present (Def)); ! Set_Abstract_Interfaces (T, New_Elmt_List); ! Set_Primitive_Operations (T, New_Elmt_List); -- Complete the decoration of the class-wide entity if it was already ! -- built (ie. during the creation of the limited view) if Present (CW) then Set_Is_Interface (CW); --- 2042,2052 ---- or else Protected_Present (Def) or else Task_Present (Def)); ! Set_Interfaces (T, New_Elmt_List); ! Set_Primitive_Operations (T, New_Elmt_List); -- Complete the decoration of the class-wide entity if it was already ! -- built (i.e. during the creation of the limited view) if Present (CW) then Set_Is_Interface (CW); *************** package body Sem_Ch3 is *** 1994,1999 **** --- 2055,2071 ---- Set_Is_Synchronized_Interface (CW, Is_Synchronized_Interface (T)); Set_Is_Task_Interface (CW, Is_Task_Interface (T)); end if; + + -- Check runtime support for synchronized interfaces + + if VM_Target = No_VM + and then (Is_Task_Interface (T) + or else Is_Protected_Interface (T) + or else Is_Synchronized_Interface (T)) + and then not RTE_Available (RE_Select_Specific_Data) + then + Error_Msg_CRT ("synchronized interfaces", T); + end if; end Analyze_Interface_Declaration; ----------------------------- *************** package body Sem_Ch3 is *** 2161,2171 **** Prev_Entity : Entity_Id := Empty; function Count_Tasks (T : Entity_Id) return Uint; ! -- This function is called when a library level object of type is ! -- declared. It's function is to count the static number of tasks ! -- declared within the type (it is only called if Has_Tasks is set for ! -- T). As a side effect, if an array of tasks with non-static bounds or ! -- a variant record type is encountered, Check_Restrictions is called -- indicating the count is unknown. ----------------- --- 2233,2243 ---- Prev_Entity : Entity_Id := Empty; function Count_Tasks (T : Entity_Id) return Uint; ! -- This function is called when a non-generic library level object of a ! -- task type is declared. Its function is to count the static number of ! -- tasks declared within the type (it is only called if Has_Tasks is set ! -- for T). As a side effect, if an array of tasks with non-static bounds ! -- or a variant record type is encountered, Check_Restrictions is called -- indicating the count is unknown. ----------------- *************** package body Sem_Ch3 is *** 2242,2253 **** if Constant_Present (N) then Prev_Entity := Current_Entity_In_Scope (Id); ! -- If homograph is an implicit subprogram, it is overridden by the ! -- current declaration. if Present (Prev_Entity) ! and then Is_Overloadable (Prev_Entity) ! and then Is_Inherited_Operation (Prev_Entity) then Prev_Entity := Empty; end if; --- 2314,2336 ---- if Constant_Present (N) then Prev_Entity := Current_Entity_In_Scope (Id); ! -- If the homograph is an implicit subprogram, it is overridden by ! -- the current declaration. if Present (Prev_Entity) ! and then ! ((Is_Overloadable (Prev_Entity) ! and then Is_Inherited_Operation (Prev_Entity)) ! ! -- The current object is a discriminal generated for an entry ! -- family index. Even though the index is a constant, in this ! -- particular context there is no true constant redeclaration. ! -- Enter_Name will handle the visibility. ! ! or else ! (Is_Discriminal (Id) ! and then Ekind (Discriminal_Link (Id)) = ! E_Entry_Index_Parameter)) then Prev_Entity := Empty; end if; *************** package body Sem_Ch3 is *** 2337,2352 **** if Is_Imported (Defining_Identifier (N)) and then ! (T = RTE (RE_Tag) ! or else (Present (Full_View (T)) ! and then Full_View (T) = RTE (RE_Tag))) then null; ! elsif not Is_Package_Or_Generic_Package (Current_Scope) then Error_Msg_N ("invalid context for deferred constant declaration (RM 7.4)", ! N); Error_Msg_N ("\declaration requires an initialization expression", N); --- 2420,2453 ---- if Is_Imported (Defining_Identifier (N)) and then ! (T = RTE (RE_Tag) ! or else ! (Present (Full_View (T)) ! and then Full_View (T) = RTE (RE_Tag))) then null; ! -- A deferred constant may appear in the declarative part of the ! -- following constructs: ! ! -- blocks ! -- entry bodies ! -- extended return statements ! -- package specs ! -- package bodies ! -- subprogram bodies ! -- task bodies ! ! -- When declared inside a package spec, a deferred constant must be ! -- completed by a full constant declaration or pragma Import. In all ! -- other cases, the only proper completion is pragma Import. Extended ! -- return statements are flagged as invalid contexts because they do ! -- not have a declarative part and so cannot accommodate the pragma. ! ! elsif Ekind (Current_Scope) = E_Return_Statement then Error_Msg_N ("invalid context for deferred constant declaration (RM 7.4)", ! N); Error_Msg_N ("\declaration requires an initialization expression", N); *************** package body Sem_Ch3 is *** 2408,2413 **** --- 2509,2533 ---- -- Process initialization expression if present and not in error if Present (E) and then E /= Error then + + -- Generate an error in case of CPP class-wide object initialization. + -- Required because otherwise the expansion of the class-wide + -- assignment would try to use 'size to initialize the object + -- (primitive that is not available in CPP tagged types). + + if Is_Class_Wide_Type (Act_T) + and then + (Is_CPP_Class (Root_Type (Etype (Act_T))) + or else + (Present (Full_View (Root_Type (Etype (Act_T)))) + and then + Is_CPP_Class (Full_View (Root_Type (Etype (Act_T)))))) + then + Error_Msg_N + ("predefined assignment not available for 'C'P'P tagged types", + E); + end if; + Mark_Coextensions (N, E); Analyze (E); *************** package body Sem_Ch3 is *** 2424,2429 **** --- 2544,2569 ---- Set_Is_True_Constant (Id, True); + -- If we are analyzing a constant declaration, set its completion + -- flag after analyzing and resolving the expression. + + if Constant_Present (N) then + Set_Has_Completion (Id); + end if; + + -- Set type and resolve (type may be overridden later on) + + Set_Etype (Id, T); + Resolve (E, T); + + -- If E is null and has been replaced by an N_Raise_Constraint_Error + -- node (which was marked already-analyzed), we need to set the type + -- to something other than Any_Access in order to keep gigi happy. + + if Etype (E) = Any_Access then + Set_Etype (E, T); + end if; + -- If the object is an access to variable, the initialization -- expression cannot be an access to constant. *************** package body Sem_Ch3 is *** 2433,2452 **** and then Is_Access_Constant (Etype (E)) then Error_Msg_N ! ("object that is an access to variable cannot be initialized " & "with an access-to-constant expression", E); end if; - -- If we are analyzing a constant declaration, set its completion - -- flag after analyzing the expression. - - if Constant_Present (N) then - Set_Has_Completion (Id); - end if; - - Set_Etype (Id, T); -- may be overridden later on - Resolve (E, T); - if not Assignment_OK (N) then Check_Initialization (T, E); end if; --- 2573,2582 ---- and then Is_Access_Constant (Etype (E)) then Error_Msg_N ! ("access to variable cannot be initialized " & "with an access-to-constant expression", E); end if; if not Assignment_OK (N) then Check_Initialization (T, E); end if; *************** package body Sem_Ch3 is *** 2539,2544 **** --- 2669,2689 ---- Error_Msg_N ("unconstrained subtype not allowed (need initialization)", Object_Definition (N)); + + if Is_Record_Type (T) and then Has_Discriminants (T) then + Error_Msg_N + ("\provide initial value or explicit discriminant values", + Object_Definition (N)); + + Error_Msg_NE + ("\or give default discriminant values for type&", + Object_Definition (N), T); + + elsif Is_Array_Type (T) then + Error_Msg_N + ("\provide initial value or explicit array bounds", + Object_Definition (N)); + end if; end if; -- Case of initialization present but in error. Set initial *************** package body Sem_Ch3 is *** 2668,2674 **** Remove_Side_Effects (E); end if; ! if T = Standard_Wide_Character or else T = Standard_Wide_Wide_Character or else Root_Type (T) = Standard_Wide_String or else Root_Type (T) = Standard_Wide_Wide_String then --- 2813,2822 ---- Remove_Side_Effects (E); end if; ! -- Check No_Wide_Characters restriction ! ! if T = Standard_Wide_Character ! or else T = Standard_Wide_Wide_Character or else Root_Type (T) = Standard_Wide_String or else Root_Type (T) = Standard_Wide_Wide_String then *************** package body Sem_Ch3 is *** 2704,2710 **** end if; -- Set Has_Initial_Value if initializing expression present. Note ! -- that if there is no initializating expression, we leave the state -- of this flag unchanged (usually it will be False, but notably in -- the case of exception choice variables, it will already be true). --- 2852,2858 ---- end if; -- Set Has_Initial_Value if initializing expression present. Note ! -- that if there is no initializing expression, we leave the state -- of this flag unchanged (usually it will be False, but notably in -- the case of exception choice variables, it will already be true). *************** package body Sem_Ch3 is *** 2713,2722 **** end if; end if; ! -- Initialize alignment and size ! Init_Alignment (Id); ! Init_Esize (Id); -- Deal with aliased case --- 2861,2871 ---- end if; end if; ! -- Initialize alignment and size and capture alignment setting ! Init_Alignment (Id); ! Init_Esize (Id); ! Set_Optimize_Alignment_Flags (Id); -- Deal with aliased case *************** package body Sem_Ch3 is *** 2836,2843 **** if Has_Task (Etype (Id)) then Check_Restriction (No_Tasking, N); ! if Is_Library_Level_Entity (Id) then Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id))); else Check_Restriction (Max_Tasks, N); Check_Restriction (No_Task_Hierarchy, N); --- 2985,3006 ---- if Has_Task (Etype (Id)) then Check_Restriction (No_Tasking, N); ! -- Deal with counting max tasks ! ! -- Nothing to do if inside a generic ! ! if Inside_A_Generic then ! null; ! ! -- If library level entity, then count tasks ! ! elsif Is_Library_Level_Entity (Id) then Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id))); + + -- If not library level entity, then indicate we don't know max + -- tasks and also check task hierarchy restriction and blocking + -- operation (since starting a task is definitely blocking!) + else Check_Restriction (Max_Tasks, N); Check_Restriction (No_Task_Hierarchy, N); *************** package body Sem_Ch3 is *** 2928,2935 **** -- Force generation of debugging information for the constant and for -- the renamed function call. ! Set_Needs_Debug_Info (Id); ! Set_Needs_Debug_Info (Entity (Prefix (E))); end if; if Present (Prev_Entity) --- 3091,3098 ---- -- Force generation of debugging information for the constant and for -- the renamed function call. ! Set_Debug_Info_Needed (Id); ! Set_Debug_Info_Needed (Entity (Prefix (E))); end if; if Present (Prev_Entity) *************** package body Sem_Ch3 is *** 2948,2953 **** --- 3111,3124 ---- then Set_In_Private_Part (Id); end if; + + -- Check for violation of No_Local_Timing_Events + + if Is_RTE (Etype (Id), RE_Timing_Event) + and then not Is_Library_Level_Entity (Id) + then + Check_Restriction (No_Local_Timing_Events, N); + end if; end Analyze_Object_Declaration; --------------------------- *************** package body Sem_Ch3 is *** 2963,2980 **** null; end Analyze_Others_Choice; - -------------------------------- - -- Analyze_Per_Use_Expression -- - -------------------------------- - - procedure Analyze_Per_Use_Expression (N : Node_Id; T : Entity_Id) is - Save_In_Default_Expression : constant Boolean := In_Default_Expression; - begin - In_Default_Expression := True; - Pre_Analyze_And_Resolve (N, T); - In_Default_Expression := Save_In_Default_Expression; - end Analyze_Per_Use_Expression; - ------------------------------------------- -- Analyze_Private_Extension_Declaration -- ------------------------------------------- --- 3134,3139 ---- *************** package body Sem_Ch3 is *** 2998,3007 **** while Present (Intf) loop T := Find_Type_Of_Subtype_Indic (Intf); ! if not Is_Interface (T) then ! Error_Msg_NE ("(Ada 2005) & must be an interface", Intf, T); ! end if; ! Next (Intf); end loop; end; --- 3157,3163 ---- while Present (Intf) loop T := Find_Type_Of_Subtype_Indic (Intf); ! Diagnose_Interface (Intf, T); Next (Intf); end loop; end; *************** package body Sem_Ch3 is *** 3109,3121 **** -- The progenitors (if any) must be limited or synchronized -- interfaces. ! if Present (Abstract_Interfaces (T)) then declare Iface : Entity_Id; Iface_Elmt : Elmt_Id; begin ! Iface_Elmt := First_Elmt (Abstract_Interfaces (T)); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); --- 3265,3277 ---- -- The progenitors (if any) must be limited or synchronized -- interfaces. ! if Present (Interfaces (T)) then declare Iface : Entity_Id; Iface_Elmt : Elmt_Id; begin ! Iface_Elmt := First_Elmt (Interfaces (T)); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); *************** package body Sem_Ch3 is *** 3213,3218 **** --- 3369,3375 ---- Set_Treat_As_Volatile (Id, Treat_As_Volatile (T)); Set_Is_Atomic (Id, Is_Atomic (T)); Set_Is_Ada_2005_Only (Id, Is_Ada_2005_Only (T)); + Set_Convention (Id, Convention (T)); -- In the case where there is no constraint given in the subtype -- indication, Process_Subtype just returns the Subtype_Mark, so its *************** package body Sem_Ch3 is *** 3365,3371 **** Set_Stored_Constraint_From_Discriminant_Constraint (Id); -- This would seem semantically correct, but apparently ! -- confuses the back-end (4412-009). To be explained ??? -- Set_Has_Discriminants (Id); end if; --- 3522,3529 ---- Set_Stored_Constraint_From_Discriminant_Constraint (Id); -- This would seem semantically correct, but apparently ! -- confuses the back-end. To be explained and checked with ! -- current version ??? -- Set_Has_Discriminants (Id); end if; *************** package body Sem_Ch3 is *** 3557,3562 **** --- 3715,3721 ---- end if; end if; + Set_Optimize_Alignment_Flags (Id); Check_Eliminated (Id); end Analyze_Subtype_Declaration; *************** package body Sem_Ch3 is *** 3738,3745 **** Validate_Access_Type_Declaration (T, N); ! -- If we are in a Remote_Call_Interface package and define ! -- a RACW, Read and Write attribute must be added. if Is_Remote and then Is_Remote_Access_To_Class_Wide_Type (Def_Id) --- 3897,3905 ---- Validate_Access_Type_Declaration (T, N); ! -- If we are in a Remote_Call_Interface package and define a ! -- RACW, then calling stubs and specific stream attributes ! -- must be added. if Is_Remote and then Is_Remote_Access_To_Class_Wide_Type (Def_Id) *************** package body Sem_Ch3 is *** 3802,3811 **** B : constant Entity_Id := Base_Type (T); begin ! -- In the case where the base type is different from the first ! -- subtype, we pre-allocate a freeze node, and set the proper link ! -- to the first subtype. Freeze_Entity will use this preallocated ! -- freeze node when it freezes the entity. if B /= T then Ensure_Freeze_Node (B); --- 3962,3971 ---- B : constant Entity_Id := Base_Type (T); begin ! -- In the case where the base type differs from the first subtype, we ! -- pre-allocate a freeze node, and set the proper link to the first ! -- subtype. Freeze_Entity will use this preallocated freeze node when ! -- it freezes the entity. if B /= T then Ensure_Freeze_Node (B); *************** package body Sem_Ch3 is *** 3823,3833 **** if T /= Def_Id and then Is_Private_Type (Def_Id) then Process_Full_View (N, T, Def_Id); ! -- Record the reference. The form of this is a little strange, ! -- since the full declaration has been swapped in. So the first ! -- parameter here represents the entity to which a reference is ! -- made which is the "real" entity, i.e. the one swapped in, ! -- and the second parameter provides the reference location. -- Also, we want to kill Has_Pragma_Unreferenced temporarily here -- since we don't want a complaint about the full type being an --- 3983,3993 ---- if T /= Def_Id and then Is_Private_Type (Def_Id) then Process_Full_View (N, T, Def_Id); ! -- Record the reference. The form of this is a little strange, since ! -- the full declaration has been swapped in. So the first parameter ! -- here represents the entity to which a reference is made which is ! -- the "real" entity, i.e. the one swapped in, and the second ! -- parameter provides the reference location. -- Also, we want to kill Has_Pragma_Unreferenced temporarily here -- since we don't want a complaint about the full type being an *************** package body Sem_Ch3 is *** 3868,3873 **** --- 4028,4034 ---- Set_Is_Descendent_Of_Address (Prev); end if; + Set_Optimize_Alignment_Flags (Def_Id); Check_Eliminated (Def_Id); end Analyze_Type_Declaration; *************** package body Sem_Ch3 is *** 3878,3889 **** procedure Analyze_Variant_Part (N : Node_Id) is procedure Non_Static_Choice_Error (Choice : Node_Id); ! -- Error routine invoked by the generic instantiation below when ! -- the variant part has a non static choice. procedure Process_Declarations (Variant : Node_Id); ! -- Analyzes all the declarations associated with a Variant. ! -- Needed by the generic instantiation below. package Variant_Choices_Processing is new Generic_Choices_Processing --- 4039,4050 ---- procedure Analyze_Variant_Part (N : Node_Id) is procedure Non_Static_Choice_Error (Choice : Node_Id); ! -- Error routine invoked by the generic instantiation below when the ! -- variant part has a non static choice. procedure Process_Declarations (Variant : Node_Id); ! -- Analyzes all the declarations associated with a Variant. Needed by ! -- the generic instantiation below. package Variant_Choices_Processing is new Generic_Choices_Processing *************** package body Sem_Ch3 is *** 3920,3926 **** end if; end Process_Declarations; ! -- Variables local to Analyze_Case_Statement Discr_Name : Node_Id; Discr_Type : Entity_Id; --- 4081,4087 ---- end if; end Process_Declarations; ! -- Local Variables Discr_Name : Node_Id; Discr_Type : Entity_Id; *************** package body Sem_Ch3 is *** 3942,3954 **** Discr_Name := Name (N); Analyze (Discr_Name); ! if Etype (Discr_Name) = Any_Type then ! ! -- Prevent cascaded errors return; ! elsif Ekind (Entity (Discr_Name)) /= E_Discriminant then Error_Msg_N ("invalid discriminant name in variant part", Discr_Name); end if; --- 4103,4117 ---- Discr_Name := Name (N); Analyze (Discr_Name); ! -- If Discr_Name bad, get out (prevent cascaded errors) + if Etype (Discr_Name) = Any_Type then return; + end if; ! -- Check invalid discriminant in variant part ! ! if Ekind (Entity (Discr_Name)) /= E_Discriminant then Error_Msg_N ("invalid discriminant name in variant part", Discr_Name); end if; *************** package body Sem_Ch3 is *** 3988,3996 **** Index := First (Subtype_Marks (Def)); end if; ! -- Find proper names for the implicit types which may be public. ! -- in case of anonymous arrays we use the name of the first object ! -- of that type as prefix. if No (T) then Related_Id := Defining_Identifier (P); --- 4151,4159 ---- Index := First (Subtype_Marks (Def)); end if; ! -- Find proper names for the implicit types which may be public. In case ! -- of anonymous arrays we use the name of the first object of that type ! -- as prefix. if No (T) then Related_Id := Defining_Identifier (P); *************** package body Sem_Ch3 is *** 4011,4019 **** -- type Table is array (Index) of ... -- end; ! -- This is currently required by the expander to generate the ! -- internally generated equality subprogram of records with variant ! -- parts in which the etype of some component is such private type. if Ekind (Current_Scope) = E_Package and then In_Private_Part (Current_Scope) --- 4174,4182 ---- -- type Table is array (Index) of ... -- end; ! -- This is currently required by the expander for the internally ! -- generated equality subprogram of records with variant parts in ! -- which the etype of some component is such private type. if Ekind (Current_Scope) = E_Package and then In_Private_Part (Current_Scope) *************** package body Sem_Ch3 is *** 4086,4094 **** Set_Parent (Element_Type, Parent (T)); ! -- Ada 2005 (AI-230): In case of components that are anonymous ! -- access types the level of accessibility depends on the enclosing ! -- type declaration Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230) --- 4249,4257 ---- Set_Parent (Element_Type, Parent (T)); ! -- Ada 2005 (AI-230): In case of components that are anonymous access ! -- types the level of accessibility depends on the enclosing type ! -- declaration Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230) *************** package body Sem_Ch3 is *** 4118,4124 **** Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B'); - Init_Size_Align (Implicit_Base); Set_Etype (Implicit_Base, Implicit_Base); Set_Scope (Implicit_Base, Current_Scope); Set_Has_Delayed_Freeze (Implicit_Base); --- 4281,4286 ---- *************** package body Sem_Ch3 is *** 4188,4195 **** if Null_Exclusion_Present (Component_Definition (Def)) ! -- No need to check itypes because in their case this check ! -- was done at their point of creation and then not Is_Itype (Element_Type) then --- 4350,4357 ---- if Null_Exclusion_Present (Component_Definition (Def)) ! -- No need to check itypes because in their case this check was ! -- done at their point of creation and then not Is_Itype (Element_Type) then *************** package body Sem_Ch3 is *** 4223,4230 **** end if; end if; ! -- A syntax error in the declaration itself may lead to an empty ! -- index list, in which case do a minimal patch. if No (First_Index (T)) then Error_Msg_N ("missing index definition in array type declaration", T); --- 4385,4392 ---- end if; end if; ! -- A syntax error in the declaration itself may lead to an empty index ! -- list, in which case do a minimal patch. if No (First_Index (T)) then Error_Msg_N ("missing index definition in array type declaration", T); *************** package body Sem_Ch3 is *** 4263,4269 **** ("the type of a component cannot be abstract", Subtype_Indication (Component_Def)); end if; - end Array_Type_Declaration; ------------------------------------------------------ --- 4425,4430 ---- *************** package body Sem_Ch3 is *** 4313,4318 **** --- 4474,4483 ---- Comp := Object_Definition (N); Acc := Comp; + when N_Function_Specification => + Comp := Result_Definition (N); + Acc := Comp; + when others => raise Program_Error; end case; *************** package body Sem_Ch3 is *** 4324,4332 **** Mark_Rewrite_Insertion (Decl); ! -- Insert the new declaration in the nearest enclosing scope P := Parent (N); while Present (P) and then not Has_Declarations (P) loop P := Parent (P); end loop; --- 4489,4506 ---- Mark_Rewrite_Insertion (Decl); ! -- Insert the new declaration in the nearest enclosing scope. If the ! -- node is a body and N is its return type, the declaration belongs in ! -- the enclosing scope. P := Parent (N); + + if Nkind (P) = N_Subprogram_Body + and then Nkind (N) = N_Function_Specification + then + P := Parent (P); + end if; + while Present (P) and then not Has_Declarations (P) loop P := Parent (P); end loop; *************** package body Sem_Ch3 is *** 4357,4362 **** --- 4531,4540 ---- elsif Nkind (N) = N_Access_Function_Definition then Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); + elsif Nkind (N) = N_Function_Specification then + Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); + Set_Etype (Defining_Unit_Name (N), Anon); + else Rewrite (Comp, Make_Component_Definition (Loc, *************** package body Sem_Ch3 is *** 4365,4377 **** Mark_Rewrite_Insertion (Comp); - -- Temporarily remove the current scope from the stack to add the new - -- declarations to the enclosing scope - if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then Analyze (Decl); else Scope_Stack.Decrement_Last; Analyze (Decl); Set_Is_Itype (Anon); --- 4543,4555 ---- Mark_Rewrite_Insertion (Comp); if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then Analyze (Decl); else + -- Temporarily remove the current scope (record or subprogram) from + -- the stack to add the new declarations to the enclosing scope. + Scope_Stack.Decrement_Last; Analyze (Decl); Set_Is_Itype (Anon); *************** package body Sem_Ch3 is *** 4452,4462 **** Has_Private_Component (Derived_Type)); Conditional_Delay (Derived_Type, Subt); ! -- Ada 2005 (AI-231). Set the null-exclusion attribute ! if Null_Exclusion_Present (Type_Definition (N)) ! or else Can_Never_Be_Null (Parent_Type) ! then Set_Can_Never_Be_Null (Derived_Type); end if; --- 4630,4650 ---- Has_Private_Component (Derived_Type)); Conditional_Delay (Derived_Type, Subt); ! -- Ada 2005 (AI-231): Set the null-exclusion attribute, and verify ! -- that it is not redundant. ! if Null_Exclusion_Present (Type_Definition (N)) then ! Set_Can_Never_Be_Null (Derived_Type); ! ! if Can_Never_Be_Null (Parent_Type) ! and then False ! then ! Error_Msg_NE ! ("`NOT NULL` not allowed (& already excludes null)", ! N, Parent_Type); ! end if; ! ! elsif Can_Never_Be_Null (Parent_Type) then Set_Can_Never_Be_Null (Derived_Type); end if; *************** package body Sem_Ch3 is *** 4606,4614 **** --- 4794,4806 ---- begin Set_Stored_Constraint (Derived_Type, No_Elist); + -- Copy Storage_Size and Relative_Deadline variables if task case + if Is_Task_Type (Parent_Type) then Set_Storage_Size_Variable (Derived_Type, Storage_Size_Variable (Parent_Type)); + Set_Relative_Deadline_Variable (Derived_Type, + Relative_Deadline_Variable (Parent_Type)); end if; if Present (Discriminant_Specifications (N)) then *************** package body Sem_Ch3 is *** 4777,4786 **** -- and we construct the same skeletal representation as for the generic -- parent type. ! if Root_Type (Parent_Type) = Standard_Character ! or else Root_Type (Parent_Type) = Standard_Wide_Character ! or else Root_Type (Parent_Type) = Standard_Wide_Wide_Character ! then Derived_Standard_Character (N, Parent_Type, Derived_Type); elsif Is_Generic_Type (Root_Type (Parent_Type)) then --- 4969,4975 ---- -- and we construct the same skeletal representation as for the generic -- parent type. ! if Is_Standard_Character_Type (Parent_Type) then Derived_Standard_Character (N, Parent_Type, Derived_Type); elsif Is_Generic_Type (Root_Type (Parent_Type)) then *************** package body Sem_Ch3 is *** 5214,5222 **** if Ekind (Parent_Type) in Record_Kind or else (Ekind (Parent_Type) in Enumeration_Kind ! and then Root_Type (Parent_Type) /= Standard_Character ! and then Root_Type (Parent_Type) /= Standard_Wide_Character ! and then Root_Type (Parent_Type) /= Standard_Wide_Wide_Character and then not Is_Generic_Type (Root_Type (Parent_Type))) then Full_N := New_Copy_Tree (N); --- 5403,5409 ---- if Ekind (Parent_Type) in Record_Kind or else (Ekind (Parent_Type) in Enumeration_Kind ! and then not Is_Standard_Character_Type (Parent_Type) and then not Is_Generic_Type (Root_Type (Parent_Type))) then Full_N := New_Copy_Tree (N); *************** package body Sem_Ch3 is *** 5863,5869 **** -- which makes the treatment for T1 and T2 identical. -- What we want when inheriting S, is that references to D1 and D2 in R are ! -- replaced with references to their correct constraints, ie D1 and D2 in -- T1 and 1 and X in T2. So all R's discriminant references are replaced -- with either discriminant references in the derived type or expressions. -- This replacement is achieved as follows: before inheriting R's --- 6050,6056 ---- -- which makes the treatment for T1 and T2 identical. -- What we want when inheriting S, is that references to D1 and D2 in R are ! -- replaced with references to their correct constraints, i.e. D1 and D2 in -- T1 and 1 and X in T2. So all R's discriminant references are replaced -- with either discriminant references in the derived type or expressions. -- This replacement is achieved as follows: before inheriting R's *************** package body Sem_Ch3 is *** 5943,5949 **** -- The full view of a private extension is handled exactly as described -- above. The model chose for the private view of a private extension is ! -- the same for what concerns discriminants (ie they receive the same -- treatment as in the tagged case). However, the private view of the -- private extension always inherits the components of the parent base, -- without replacing any discriminant reference. Strictly speaking this is --- 6130,6136 ---- -- The full view of a private extension is handled exactly as described -- above. The model chose for the private view of a private extension is ! -- the same for what concerns discriminants (i.e. they receive the same -- treatment as in the tagged case). However, the private view of the -- private extension always inherits the components of the parent base, -- without replacing any discriminant reference. Strictly speaking this is *************** package body Sem_Ch3 is *** 6162,6169 **** and then Has_Private_Declaration (Derived_Type) and then Present (Discriminant_Constraint (Derived_Type)) then ! -- Verify that constraints of the full view conform to those ! -- given in partial view. declare C1, C2 : Elmt_Id; --- 6349,6356 ---- and then Has_Private_Declaration (Derived_Type) and then Present (Discriminant_Constraint (Derived_Type)) then ! -- Verify that constraints of the full view statically match ! -- those given in the partial view. declare C1, C2 : Elmt_Id; *************** package body Sem_Ch3 is *** 6172,6180 **** C1 := First_Elmt (New_Discrs); C2 := First_Elmt (Discriminant_Constraint (Derived_Type)); while Present (C1) and then Present (C2) loop ! if not ! Fully_Conformant_Expressions (Node (C1), Node (C2)) then Error_Msg_N ( "constraint not conformant to previous declaration", Node (C1)); --- 6359,6375 ---- C1 := First_Elmt (New_Discrs); C2 := First_Elmt (Discriminant_Constraint (Derived_Type)); while Present (C1) and then Present (C2) loop ! if Fully_Conformant_Expressions (Node (C1), Node (C2)) ! or else ! (Is_OK_Static_Expression (Node (C1)) ! and then ! Is_OK_Static_Expression (Node (C2)) ! and then ! Expr_Value (Node (C1)) = Expr_Value (Node (C2))) then + null; + + else Error_Msg_N ( "constraint not conformant to previous declaration", Node (C1)); *************** package body Sem_Ch3 is *** 6445,6451 **** if Limited_Present (Type_Def) then Set_Is_Limited_Record (Derived_Type); ! elsif Is_Limited_Record (Parent_Type) then if not Is_Interface (Parent_Type) or else Is_Synchronized_Interface (Parent_Type) or else Is_Protected_Interface (Parent_Type) --- 6640,6649 ---- if Limited_Present (Type_Def) then Set_Is_Limited_Record (Derived_Type); ! elsif Is_Limited_Record (Parent_Type) ! or else (Present (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) or else Is_Protected_Interface (Parent_Type) *************** package body Sem_Ch3 is *** 6627,6645 **** Analyze_Interface_Declaration (Derived_Type, Type_Def); end if; ! Set_Abstract_Interfaces (Derived_Type, No_Elist); end if; -- Fields inherited from the Parent_Type Set_Discard_Names ! (Derived_Type, Einfo.Discard_Names (Parent_Type)); Set_Has_Specified_Layout ! (Derived_Type, Has_Specified_Layout (Parent_Type)); Set_Is_Limited_Composite ! (Derived_Type, Is_Limited_Composite (Parent_Type)); Set_Is_Private_Composite ! (Derived_Type, Is_Private_Composite (Parent_Type)); -- Fields inherited from the Parent_Base --- 6825,6843 ---- Analyze_Interface_Declaration (Derived_Type, Type_Def); end if; ! Set_Interfaces (Derived_Type, No_Elist); end if; -- Fields inherited from the Parent_Type Set_Discard_Names ! (Derived_Type, Einfo.Discard_Names (Parent_Type)); Set_Has_Specified_Layout ! (Derived_Type, Has_Specified_Layout (Parent_Type)); Set_Is_Limited_Composite ! (Derived_Type, Is_Limited_Composite (Parent_Type)); Set_Is_Private_Composite ! (Derived_Type, Is_Private_Composite (Parent_Type)); -- Fields inherited from the Parent_Base *************** package body Sem_Ch3 is *** 6650,6662 **** Set_Has_Primitive_Operations (Derived_Type, Has_Primitive_Operations (Parent_Base)); ! -- For non-private case, we also inherit Has_Complex_Representation if Ekind (Derived_Type) = E_Record_Type then Set_Has_Complex_Representation (Derived_Type, Has_Complex_Representation (Parent_Base)); end if; -- Direct controlled types do not inherit Finalize_Storage_Only flag if not Is_Controlled (Parent_Type) then --- 6848,6869 ---- Set_Has_Primitive_Operations (Derived_Type, Has_Primitive_Operations (Parent_Base)); ! -- Fields inherited from the Parent_Base in the non-private case if Ekind (Derived_Type) = E_Record_Type then Set_Has_Complex_Representation (Derived_Type, Has_Complex_Representation (Parent_Base)); end if; + -- Fields inherited from the Parent_Base for record types + + if Is_Record_Type (Derived_Type) then + Set_OK_To_Reorder_Components + (Derived_Type, OK_To_Reorder_Components (Parent_Base)); + Set_Reverse_Bit_Order + (Derived_Type, Reverse_Bit_Order (Parent_Base)); + end if; + -- Direct controlled types do not inherit Finalize_Storage_Only flag if not Is_Controlled (Parent_Type) then *************** package body Sem_Ch3 is *** 6744,6759 **** -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) ! Check_Abstract_Interfaces (N, Type_Def); -- Ada 2005 (AI-251): Collect the list of progenitors that are -- not already in the parents. ! Collect_Abstract_Interfaces ! (T => Derived_Type, ! Ifaces_List => Ifaces_List, ! Exclude_Parent_Interfaces => True); ! Set_Abstract_Interfaces (Derived_Type, Ifaces_List); end; end if; --- 6951,6967 ---- -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) ! Check_Interfaces (N, Type_Def); -- Ada 2005 (AI-251): Collect the list of progenitors that are -- not already in the parents. ! Collect_Interfaces ! (T => Derived_Type, ! Ifaces_List => Ifaces_List, ! Exclude_Parents => True); ! ! Set_Interfaces (Derived_Type, Ifaces_List); end; end if; *************** package body Sem_Ch3 is *** 6851,6857 **** -- implemented interfaces if we are in expansion mode if Expander_Active ! and then Has_Abstract_Interfaces (Derived_Type) then Add_Interface_Tag_Components (N, Derived_Type); end if; --- 7059,7065 ---- -- implemented interfaces if we are in expansion mode if Expander_Active ! and then Has_Interfaces (Derived_Type) then Add_Interface_Tag_Components (N, Derived_Type); end if; *************** package body Sem_Ch3 is *** 7263,7269 **** -- and therefore when reanalyzing "subtype W is G (D => 1);" -- which really looks like "subtype W is Rec (D => 1);" at -- the point of instantiation, we want to find the discriminant ! -- that corresponds to D in Rec, ie X. if Present (Original_Discriminant (Id)) then Discr := Find_Corresponding_Discriminant (Id, T); --- 7471,7477 ---- -- and therefore when reanalyzing "subtype W is G (D => 1);" -- which really looks like "subtype W is Rec (D => 1);" at -- the point of instantiation, we want to find the discriminant ! -- that corresponds to D in Rec, i.e. X. if Present (Original_Discriminant (Id)) then Discr := Find_Corresponding_Discriminant (Id, T); *************** package body Sem_Ch3 is *** 7420,7425 **** --- 7628,7642 ---- (Designated_Type (Etype (Discr_Expr (J)))) then Wrong_Type (Discr_Expr (J), Etype (Discr)); + + elsif Is_Access_Type (Etype (Discr)) + and then not Is_Access_Constant (Etype (Discr)) + and then Is_Access_Type (Etype (Discr_Expr (J))) + and then Is_Access_Constant (Etype (Discr_Expr (J))) + then + Error_Msg_NE + ("constraint for discriminant& must be access to variable", + Def, Discr); end if; end if; *************** package body Sem_Ch3 is *** 7504,7510 **** Set_First_Entity (Def_Id, First_Entity (T)); Set_Last_Entity (Def_Id, Last_Entity (T)); ! Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); if Is_Tagged_Type (T) then Set_Is_Tagged_Type (Def_Id); --- 7721,7736 ---- Set_First_Entity (Def_Id, First_Entity (T)); Set_Last_Entity (Def_Id, Last_Entity (T)); ! ! -- If the subtype is the completion of a private declaration, there may ! -- have been representation clauses for the partial view, and they must ! -- be preserved. Build_Derived_Type chains the inherited clauses with ! -- the ones appearing on the extension. If this comes from a subtype ! -- declaration, all clauses are inherited. ! ! if No (First_Rep_Item (Def_Id)) then ! Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); ! end if; if Is_Tagged_Type (T) then Set_Is_Tagged_Type (Def_Id); *************** package body Sem_Ch3 is *** 7727,7861 **** end Build_Underlying_Full_View; ------------------------------- - -- Check_Abstract_Interfaces -- - ------------------------------- - - procedure Check_Abstract_Interfaces (N : Node_Id; Def : Node_Id) is - - procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); - -- Local subprogram used to avoid code duplication. In case of error - -- the message will be associated to Error_Node. - - ------------------ - -- Check_Ifaces -- - ------------------ - - procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is - begin - -- Ada 2005 (AI-345): Protected interfaces can only inherit from - -- limited, synchronized or protected interfaces. - - if Protected_Present (Def) then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - or else Protected_Present (Iface_Def) - then - null; - - elsif Task_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) protected interface cannot inherit" - & " from task interface", Error_Node); - - else - Error_Msg_N ("(Ada 2005) protected interface cannot inherit" - & " from non-limited interface", Error_Node); - end if; - - -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from - -- limited and synchronized. - - elsif Synchronized_Present (Def) then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - then - null; - - elsif Protected_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from protected interface", Error_Node); - - elsif Task_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from task interface", Error_Node); - - else - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from non-limited interface", Error_Node); - end if; - - -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, - -- synchronized or task interfaces. - - elsif Task_Present (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; - - -- Local variables - - Iface : Node_Id; - Iface_Def : Node_Id; - Iface_Typ : Entity_Id; - Parent_Node : Node_Id; - - -- Start of processing for Check_Abstract_Interfaces - - begin - -- Why is this still unsupported??? - - if Nkind (N) = N_Private_Extension_Declaration then - return; - end if; - - -- Check the parent in case of derivation of interface type - - if Nkind (Type_Definition (N)) = N_Derived_Type_Definition - and then Is_Interface (Etype (Defining_Identifier (N))) - then - Parent_Node := Parent (Etype (Defining_Identifier (N))); - - 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 - Error_Msg_NE ("(Ada 2005) & must be an 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; - - Next (Iface); - end loop; - end Check_Abstract_Interfaces; - - ------------------------------- -- Check_Abstract_Overriding -- ------------------------------- --- 7953,7958 ---- *************** package body Sem_Ch3 is *** 7900,7942 **** if Is_Null_Extension (T) and then Has_Controlling_Result (Subp) and then Ada_Version >= Ada_05 ! and then Present (Alias (Subp)) and then not Comes_From_Source (Subp) ! and then not Is_Abstract_Subprogram (Alias (Subp)) then null; elsif (Is_Abstract_Subprogram (Subp) ! or else Requires_Overriding (Subp) ! or else ! (Has_Controlling_Result (Subp) ! and then Present (Alias_Subp) ! and then not Comes_From_Source (Subp) ! and then Sloc (Subp) = Sloc (First_Subtype (T)))) and then not Is_TSS (Subp, TSS_Stream_Input) and then not Is_TSS (Subp, TSS_Stream_Output) and then not Is_Abstract_Type (T) and then Convention (T) /= Convention_CIL ! and then Chars (Subp) /= Name_uDisp_Asynchronous_Select ! and then Chars (Subp) /= Name_uDisp_Conditional_Select ! and then Chars (Subp) /= Name_uDisp_Get_Prim_Op_Kind ! and then Chars (Subp) /= Name_uDisp_Requeue ! and then Chars (Subp) /= Name_uDisp_Timed_Select -- Ada 2005 (AI-251): Do not consider hidden entities associated -- with abstract interface types because the check will be done -- with the aliased entity (otherwise we generate a duplicated -- error message). ! and then not Present (Abstract_Interface_Alias (Subp)) then if Present (Alias_Subp) then -- Only perform the check for a derived subprogram when the ! -- type has an explicit record extension. This avoids ! -- incorrectly flagging abstract subprograms for the case of a ! -- type without an extension derived from a formal type with a ! -- tagged actual (can occur within a private part). -- Ada 2005 (AI-391): In the case of an inherited function with -- a controlling result of the type, the rule does not apply if --- 7997,8043 ---- if Is_Null_Extension (T) and then Has_Controlling_Result (Subp) and then Ada_Version >= Ada_05 ! and then Present (Alias_Subp) and then not Comes_From_Source (Subp) ! and then not Is_Abstract_Subprogram (Alias_Subp) ! and then not Is_Access_Type (Etype (Subp)) then null; + -- Ada 2005 (AI-251): Internal entities of interfaces need no + -- processing because this check is done with the aliased + -- entity + + elsif Present (Interface_Alias (Subp)) then + null; + elsif (Is_Abstract_Subprogram (Subp) ! or else Requires_Overriding (Subp) ! or else ! (Has_Controlling_Result (Subp) ! and then Present (Alias_Subp) ! and then not Comes_From_Source (Subp) ! and then Sloc (Subp) = Sloc (First_Subtype (T)))) and then not Is_TSS (Subp, TSS_Stream_Input) and then not Is_TSS (Subp, TSS_Stream_Output) and then not Is_Abstract_Type (T) and then Convention (T) /= Convention_CIL ! and then not Is_Predefined_Interface_Primitive (Subp) -- Ada 2005 (AI-251): Do not consider hidden entities associated -- with abstract interface types because the check will be done -- with the aliased entity (otherwise we generate a duplicated -- error message). ! and then not Present (Interface_Alias (Subp)) then if Present (Alias_Subp) then -- Only perform the check for a derived subprogram when the ! -- type has an explicit record extension. This avoids incorrect ! -- flagging of abstract subprograms for the case of a type ! -- without an extension that is derived from a formal type ! -- with a tagged actual (can occur within a private part). -- Ada 2005 (AI-391): In the case of an inherited function with -- a controlling result of the type, the rule does not apply if *************** package body Sem_Ch3 is *** 7959,7971 **** or else Requires_Overriding (Subp) or else Is_Access_Type (Etype (Subp))) then ! -- The body of predefined primitives of tagged types derived ! -- from interface types are generated later by Freeze_Type. ! if Is_Predefined_Dispatching_Operation (Subp) ! and then Is_Abstract_Subprogram (Alias_Subp) ! and then Is_Interface ! (Root_Type (Find_Dispatching_Type (Subp))) then null; --- 8060,8074 ---- or else Requires_Overriding (Subp) or else Is_Access_Type (Etype (Subp))) then ! -- Avoid reporting error in case of abstract predefined ! -- primitive inherited from interface type because the ! -- body of internally generated predefined primitives ! -- of tagged types are generated later by Freeze_Type ! if Is_Interface (Root_Type (T)) ! and then Is_Abstract_Subprogram (Subp) ! and then Is_Predefined_Dispatching_Operation (Subp) ! and then not Comes_From_Source (Ultimate_Alias (Subp)) then null; *************** package body Sem_Ch3 is *** 8005,8011 **** -- abstract interfaces. elsif Is_Concurrent_Record_Type (T) ! and then Present (Abstract_Interfaces (T)) then -- The controlling formal of Subp must be of mode "out", -- "in out" or an access-to-variable to be overridden. --- 8108,8114 ---- -- abstract interfaces. elsif Is_Concurrent_Record_Type (T) ! and then Present (Interfaces (T)) then -- The controlling formal of Subp must be of mode "out", -- "in out" or an access-to-variable to be overridden. *************** package body Sem_Ch3 is *** 8014,8025 **** -- in -gnatj mode) ??? if Ekind (First_Formal (Subp)) = E_In_Parameter then ! Error_Msg_NE ! ("first formal of & must be of mode `OUT`, `IN OUT` " & ! "or access-to-variable", T, Subp); ! Error_Msg_N ! ("\to be overridden by protected procedure or " & ! "entry (RM 9.4(11.9/2))", T); -- Some other kind of overriding failure --- 8117,8130 ---- -- in -gnatj mode) ??? if Ekind (First_Formal (Subp)) = E_In_Parameter then ! if not Is_Predefined_Dispatching_Operation (Subp) then ! Error_Msg_NE ! ("first formal of & must be of mode `OUT`, " & ! "`IN OUT` or access-to-variable", T, Subp); ! Error_Msg_N ! ("\to be overridden by protected procedure or " & ! "entry (RM 9.4(11.9/2))", T); ! end if; -- Some other kind of overriding failure *************** package body Sem_Ch3 is *** 8052,8059 **** if Ada_Version >= Ada_05 and then Is_Hidden (Subp) ! and then Present (Abstract_Interface_Alias (Subp)) ! and then Implemented_By_Entry (Abstract_Interface_Alias (Subp)) and then Present (Alias_Subp) and then (not Is_Primitive_Wrapper (Alias_Subp) --- 8157,8164 ---- if Ada_Version >= Ada_05 and then Is_Hidden (Subp) ! and then Present (Interface_Alias (Subp)) ! and then Implemented_By_Entry (Interface_Alias (Subp)) and then Present (Alias_Subp) and then (not Is_Primitive_Wrapper (Alias_Subp) *************** package body Sem_Ch3 is *** 8067,8073 **** Error_Ent := Corresponding_Concurrent_Type (Error_Ent); end if; ! Error_Msg_Node_2 := Abstract_Interface_Alias (Subp); Error_Msg_NE ("type & must implement abstract subprogram & with an entry", Error_Ent, Error_Ent); --- 8172,8178 ---- Error_Ent := Corresponding_Concurrent_Type (Error_Ent); end if; ! Error_Msg_Node_2 := Interface_Alias (Subp); Error_Msg_NE ("type & must implement abstract subprogram & with an entry", Error_Ent, Error_Ent); *************** package body Sem_Ch3 is *** 8479,8484 **** --- 8584,8815 ---- end if; end Check_Initialization; + ---------------------- + -- Check_Interfaces -- + ---------------------- + + procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is + Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); + + Iface : Node_Id; + Iface_Def : Node_Id; + Iface_Typ : Entity_Id; + Parent_Node : Node_Id; + + Is_Task : Boolean := False; + -- Set True if parent type or any progenitor is a task interface + + Is_Protected : Boolean := False; + -- Set True if parent type or any progenitor is a protected interface + + 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. + + ------------------ + -- Check_Ifaces -- + ------------------ + + 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; + + if Is_Task_Interface (Iface_Id) then + Is_Task := True; + + elsif Is_Protected_Interface (Iface_Id) then + Is_Protected := True; + end if; + + -- 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. + + 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); + + 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 + then + Error_Msg_NE + ("progenitor& must be limited interface", + Error_Node, Iface_Id); + end if; + + -- Protected interfaces can only inherit from limited, synchronized + -- or protected interfaces. + + 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; + + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) protected interface cannot inherit" + & " from task interface", Error_Node); + + else + Error_Msg_N ("(Ada 2005) protected interface cannot inherit" + & " from non-limited interface", Error_Node); + end if; + + -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from + -- limited and synchronized. + + elsif Synchronized_Present (Type_Def) then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + then + null; + + 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); + + 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); + + 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; + + -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, + -- synchronized or task interfaces. + + 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; + + -- Start of processing for Check_Interfaces + + begin + if Is_Interface (Parent_Type) then + if Is_Task_Interface (Parent_Type) then + Is_Task := True; + + elsif Is_Protected_Interface (Parent_Type) then + Is_Protected := True; + end if; + end if; + + if Nkind (N) = N_Private_Extension_Declaration then + + -- Check that progenitors are compatible with declaration + + 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 + Check_Ifaces (Iface_Def, Iface); + end if; + + Next (Iface); + end loop; + + if Is_Task and Is_Protected then + Error_Msg_N + ("type cannot derive from task and protected interface", N); + end if; + + return; + end if; + + -- Full type declaration of derived type. + -- Check compatibility with parent if it is interface type + + if Nkind (Type_Definition (N)) = N_Derived_Type_Definition + and then Is_Interface (Parent_Type) + then + Parent_Node := Parent (Parent_Type); + + -- More detailed checks for interface varieties + + 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; + + Next (Iface); + 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; + ------------------------------------ -- Check_Or_Process_Discriminants -- ------------------------------------ *************** package body Sem_Ch3 is *** 8921,8926 **** --- 9252,9263 ---- 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)))) *************** package body Sem_Ch3 is *** 8930,8935 **** --- 9267,9281 ---- Set_Full_View (Prev, Id); Set_Etype (Id, Any_Type); + 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 so, process the full constant declaration else *************** package body Sem_Ch3 is *** 8958,8964 **** end if; -- Allow incomplete declaration of tags (used to handle forward ! -- references to tags). The check on Ada_Tags avoids cicularities -- when rebuilding the compiler. if RTU_Loaded (Ada_Tags) --- 9304,9310 ---- end if; -- Allow incomplete declaration of tags (used to handle forward ! -- references to tags). The check on Ada_Tags avoids circularities -- when rebuilding the compiler. if RTU_Loaded (Ada_Tags) *************** package body Sem_Ch3 is *** 9593,9599 **** function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is D : Entity_Id; E : Elmt_Id; - G : Elmt_Id; begin -- The discriminant may be declared for the type, in which case we --- 9939,9944 ---- *************** package body Sem_Ch3 is *** 9623,9636 **** -- 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 Is_Derived_Type (Typ) - and then Present (Stored_Constraint (Typ)) and then Scope (Entity (Discrim)) = Etype (Typ) then D := First_Discriminant (Etype (Typ)); E := First_Elmt (Constraints); - G := First_Elmt (Stored_Constraint (Typ)); while Present (D) loop if D = Entity (Discrim) then return Node (E); --- 9968,9982 ---- -- 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? 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); *************** package body Sem_Ch3 is *** 9638,9644 **** Next_Discriminant (D); Next_Elmt (E); - Next_Elmt (G); end loop; end if; --- 9984,9989 ---- *************** package body Sem_Ch3 is *** 9678,9684 **** -- discriminant is declared in the private entity. or else (Is_Private_Type (Typ) ! and then Chars (Discrim_Scope) = Chars (Typ)) -- Or we are constrained the corresponding record of a -- synchronized type that completes a private declaration. --- 10023,10029 ---- -- discriminant is declared in the private entity. or else (Is_Private_Type (Typ) ! and then Chars (Discrim_Scope) = Chars (Typ)) -- Or we are constrained the corresponding record of a -- synchronized type that completes a private declaration. *************** package body Sem_Ch3 is *** 9691,9697 **** -- discriminant found belongs to the root type. or else (Is_Class_Wide_Type (Typ) ! and then Etype (Typ) = Discrim_Scope)); return True; end if; --- 10036,10042 ---- -- discriminant found belongs to the root type. or else (Is_Class_Wide_Type (Typ) ! and then Etype (Typ) = Discrim_Scope)); return True; end if; *************** package body Sem_Ch3 is *** 9794,9800 **** begin Set_Etype (T_Sub, Corr_Rec); - Init_Size_Align (T_Sub); Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt)); Set_Is_Constrained (T_Sub, True); Set_First_Entity (T_Sub, First_Entity (Corr_Rec)); --- 10139,10144 ---- *************** package body Sem_Ch3 is *** 9930,9936 **** Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); end if; ! Set_Etype (Def_Id, Any_Type); Set_Error_Posted (Def_Id); end Fixup_Bad_Constraint; --- 10274,10282 ---- Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); end if; ! -- Set Etype to the known type, to reduce chances of cascaded errors ! ! Set_Etype (Def_Id, E); Set_Error_Posted (Def_Id); end Fixup_Bad_Constraint; *************** package body Sem_Ch3 is *** 10911,10918 **** Scale_Val : Uint; Bound_Val : Ureal; - -- Start of processing for Decimal_Fixed_Point_Type_Declaration - begin Check_Restriction (No_Fixed_Point, Def); --- 11257,11262 ---- *************** package body Sem_Ch3 is *** 10992,11003 **** Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val); ! -- Set size to 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. ! Init_Size_Align (Implicit_Base); -- If there are bounds given in the declaration use them as the -- bounds of the first named subtype. --- 11336,11347 ---- 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. *************** package body Sem_Ch3 is *** 11054,11275 **** Set_Is_Constrained (T); end Decimal_Fixed_Point_Type_Declaration; ! ---------------------------------- ! -- Derive_Interface_Subprograms -- ! ---------------------------------- ! procedure Derive_Interface_Subprograms (Parent_Type : Entity_Id; ! Tagged_Type : Entity_Id; ! Ifaces_List : Elist_Id) is ! function Collect_Interface_Primitives ! (Tagged_Type : Entity_Id) return Elist_Id; ! -- Ada 2005 (AI-251): Collect the primitives of all the implemented ! -- interfaces. ! function In_List (L : Elist_Id; Subp : Entity_Id) return Boolean; ! -- Determine if Subp already in the list L ! procedure Remove_Homonym (E : Entity_Id); ! -- Removes E from the homonym chain ! ---------------------------------- ! -- Collect_Interface_Primitives -- ! ---------------------------------- ! function Collect_Interface_Primitives ! (Tagged_Type : Entity_Id) return Elist_Id ! is ! Op_List : constant Elist_Id := New_Elmt_List; ! Elmt : Elmt_Id; ! Ifaces_List : Elist_Id; ! Iface_Elmt : Elmt_Id; ! Prim : Entity_Id; ! begin ! pragma Assert (Is_Tagged_Type (Tagged_Type) ! and then Has_Abstract_Interfaces (Tagged_Type)); ! Collect_Abstract_Interfaces (Tagged_Type, Ifaces_List); ! Iface_Elmt := First_Elmt (Ifaces_List); ! while Present (Iface_Elmt) loop ! Elmt := First_Elmt (Primitive_Operations (Node (Iface_Elmt))); ! while Present (Elmt) loop ! Prim := Node (Elmt); ! if not Is_Predefined_Dispatching_Operation (Prim) then ! Append_Elmt (Prim, Op_List); end if; - - Next_Elmt (Elmt); - end loop; - - Next_Elmt (Iface_Elmt); - end loop; - - return Op_List; - end Collect_Interface_Primitives; - - ------------- - -- In_List -- - ------------- - - function In_List (L : Elist_Id; Subp : Entity_Id) return Boolean is - Elmt : Elmt_Id; - begin - Elmt := First_Elmt (L); - while Present (Elmt) loop - if Node (Elmt) = Subp then - return True; end if; Next_Elmt (Elmt); end loop; - - return False; - end In_List; - - -------------------- - -- Remove_Homonym -- - -------------------- - - procedure Remove_Homonym (E : Entity_Id) is - Prev : Entity_Id := Empty; - H : Entity_Id; - - begin - if E = Current_Entity (E) then - Set_Current_Entity (Homonym (E)); - else - H := Current_Entity (E); - while Present (H) and then H /= E loop - Prev := H; - H := Homonym (H); - end loop; - - Set_Homonym (Prev, Homonym (E)); - end if; - end Remove_Homonym; - - -- Local Variables - - E : Entity_Id; - Elmt : Elmt_Id; - Iface : Entity_Id; - Iface_Subp : Entity_Id; - New_Subp : Entity_Id := Empty; - Op_List : Elist_Id; - Parent_Base : Entity_Id; - Subp : Entity_Id; - - -- Start of processing for Derive_Interface_Subprograms - - begin - if Ada_Version < Ada_05 - or else not Is_Record_Type (Tagged_Type) - or else not Is_Tagged_Type (Tagged_Type) - or else not Has_Abstract_Interfaces (Tagged_Type) - then - return; end if; ! -- Add to the list of interface subprograms all the primitives inherited ! -- from abstract interfaces that are not immediate ancestors and also ! -- add their derivation to the list of interface primitives. ! ! Op_List := Collect_Interface_Primitives (Tagged_Type); ! Elmt := First_Elmt (Op_List); ! while Present (Elmt) loop ! Subp := Node (Elmt); ! Iface := Find_Dispatching_Type (Subp); ! if Is_Concurrent_Record_Type (Tagged_Type) then ! if not Present (Abstract_Interface_Alias (Subp)) then ! Derive_Subprogram (New_Subp, Subp, Tagged_Type, Iface); ! Append_Elmt (New_Subp, Ifaces_List); ! end if; ! elsif not Is_Parent (Iface, Tagged_Type) then ! Derive_Subprogram (New_Subp, Subp, Tagged_Type, Iface); ! Append_Elmt (New_Subp, Ifaces_List); ! end if; ! Next_Elmt (Elmt); ! end loop; ! -- Complete the derivation of the interface subprograms. Assign to each ! -- entity associated with abstract interfaces their aliased entity and ! -- complete their decoration as hidden interface entities that will be ! -- used later to build the secondary dispatch tables. ! if not Is_Empty_Elmt_List (Ifaces_List) then ! 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; ! Elmt := First_Elmt (Ifaces_List); ! while Present (Elmt) loop ! Iface_Subp := Node (Elmt); ! -- Look for the first overriding entity in the homonym chain. ! -- In this way if we are in the private part of a package spec ! -- we get the last overriding subprogram. ! E := Current_Entity_In_Scope (Iface_Subp); ! while Present (E) loop ! if Is_Dispatching_Operation (E) ! and then Scope (E) = Scope (Iface_Subp) ! and then Type_Conformant (E, Iface_Subp) ! and then not In_List (Ifaces_List, E) ! then ! exit; end if; ! E := Homonym (E); end loop; ! -- Create an overriding entity if not found in the homonym chain ! ! if not Present (E) then ! Derive_Subprogram ! (E, Alias (Iface_Subp), Tagged_Type, Parent_Base); ! ! elsif not In_List (Primitive_Operations (Tagged_Type), E) then ! ! -- Inherit the operation from the private view ! ! Append_Elmt (E, Primitive_Operations (Tagged_Type)); ! end if; ! ! -- Complete the decoration of the hidden interface entity ! ! Set_Is_Hidden (Iface_Subp); ! Set_Abstract_Interface_Alias (Iface_Subp, Alias (Iface_Subp)); ! Set_Alias (Iface_Subp, E); ! Set_Is_Abstract_Subprogram (Iface_Subp, ! Is_Abstract_Subprogram (E)); ! Remove_Homonym (Iface_Subp); ! ! -- Hidden entities associated with interfaces must have set the ! -- Has_Delay_Freeze attribute to ensure that the corresponding ! -- entry of the secondary dispatch table is filled when such ! -- entity is frozen. ! ! Set_Has_Delayed_Freeze (Iface_Subp); ! ! Next_Elmt (Elmt); end loop; end if; ! end Derive_Interface_Subprograms; ----------------------- -- Derive_Subprogram -- --- 11398,11529 ---- Set_Is_Constrained (T); end Decimal_Fixed_Point_Type_Declaration; ! ----------------------------------- ! -- Derive_Progenitor_Subprograms -- ! ----------------------------------- ! 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; ! begin ! pragma Assert (Ada_Version >= Ada_05 ! and then Is_Record_Type (Tagged_Type) ! and then Is_Tagged_Type (Tagged_Type) ! and then Has_Interfaces (Tagged_Type)); ! -- 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)). ! -- Small optimization: This work is only required if the parent is ! -- abstract. 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 Freeze_Record_Type). ! if In_Private_Part (Current_Scope) ! and then Is_Abstract_Type (Parent_Type) ! then ! Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); ! while Present (Elmt) loop ! Subp := Node (Elmt); ! -- At this stage it is not possible to have entities in the list ! -- of primitives that have attribute Interface_Alias ! pragma Assert (No (Interface_Alias (Subp))); ! Typ := Find_Dispatching_Type (Ultimate_Alias (Subp)); ! 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; ! -- Step 2: Add primitives of progenitors that are not implemented by ! -- parents of Tagged_Type ! if Present (Interfaces (Tagged_Type)) then ! Iface_Elmt := First_Elmt (Interfaces (Tagged_Type)); ! while Present (Iface_Elmt) loop ! Iface := Node (Iface_Elmt); ! Prim_Elmt := First_Elmt (Primitive_Operations (Iface)); ! while Present (Prim_Elmt) loop ! Iface_Subp := Node (Prim_Elmt); ! -- Exclude derivation of predefined primitives except those ! -- that come from source. Required to catch declarations of ! -- equality operators of interfaces. For example: ! -- type Iface is interface; ! -- function "=" (Left, Right : Iface) return Boolean; ! if not Is_Predefined_Dispatching_Operation (Iface_Subp) ! or else Comes_From_Source (Iface_Subp) ! then ! E := Find_Primitive_Covering_Interface ! (Tagged_Type => Tagged_Type, ! Iface_Prim => Iface_Subp); ! -- If not found we derive a new primitive leaving its alias ! -- attribute referencing the interface primitive ! if No (E) then ! Derive_Subprogram ! (New_Subp, Iface_Subp, Tagged_Type, Iface); ! -- 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; ! Next_Elmt (Iface_Elmt); end loop; end if; ! end Derive_Progenitor_Subprograms; ----------------------- -- Derive_Subprogram -- *************** package body Sem_Ch3 is *** 11282,11300 **** Parent_Type : Entity_Id; Actual_Subp : Entity_Id := Empty) is ! Formal : Entity_Id; ! New_Formal : Entity_Id; Visible_Subp : Entity_Id := Parent_Subp; function Is_Private_Overriding return Boolean; ! -- If Subp is a private overriding of a visible operation, the in- ! -- herited 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 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. procedure Replace_Type (Id, New_Id : Entity_Id); -- When the type is an anonymous access type, create a new access type --- 11536,11563 ---- Parent_Type : Entity_Id; Actual_Subp : Entity_Id := Empty) is ! Formal : Entity_Id; ! -- Formal parameter of parent primitive operation ! ! 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. ! ! New_Formal : Entity_Id; ! -- Formal of inherited operation ! Visible_Subp : Entity_Id := Parent_Subp; 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. procedure Replace_Type (Id, New_Id : Entity_Id); -- When the type is an anonymous access type, create a new access type *************** package body Sem_Ch3 is *** 11455,11460 **** --- 11718,11724 ---- elsif Is_Interface (Etype (Id)) and then not Is_Class_Wide_Type (Etype (Id)) + and then Is_Progenitor (Etype (Id), Derived_Type) then Set_Etype (New_Id, Derived_Type); *************** package body Sem_Ch3 is *** 11477,11482 **** --- 11741,11750 ---- end if; end Set_Derived_Name; + -- Local variables + + Parent_Overrides_Interface_Primitive : Boolean := False; + -- Start of processing for Derive_Subprogram begin *************** package body Sem_Ch3 is *** 11484,11489 **** --- 11752,11774 ---- New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); Set_Ekind (New_Subp, Ekind (Parent_Subp)); + -- Check whether the parent overrides an interface primitive + + if Is_Overriding_Operation (Parent_Subp) then + declare + E : Entity_Id := Parent_Subp; + begin + while Present (Overridden_Operation (E)) loop + E := Ultimate_Alias (Overridden_Operation (E)); + end loop; + + Parent_Overrides_Interface_Primitive := + Is_Dispatching_Operation (E) + and then Present (Find_Dispatching_Type (E)) + and then Is_Interface (Find_Dispatching_Type (E)); + end; + end if; + -- 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 *************** package body Sem_Ch3 is *** 11529,11538 **** then Set_Derived_Name; ! -- Ada 2005 (AI-251): Hidden entity associated with abstract interface ! -- primitive ! elsif Present (Abstract_Interface_Alias (Parent_Subp)) then Set_Derived_Name; -- The type is inheriting a private operation, so enter --- 11814,11824 ---- then Set_Derived_Name; ! -- 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)) ! elsif Parent_Overrides_Interface_Primitive then Set_Derived_Name; -- The type is inheriting a private operation, so enter *************** package body Sem_Ch3 is *** 11543,11552 **** end if; Set_Parent (New_Subp, Parent (Derived_Type)); ! Replace_Type (Parent_Subp, New_Subp); Conditional_Delay (New_Subp, Parent_Subp); Formal := First_Formal (Parent_Subp); while Present (Formal) loop New_Formal := New_Copy (Formal); --- 11829,11857 ---- end if; Set_Parent (New_Subp, Parent (Derived_Type)); ! ! if Present (Actual_Subp) then ! Replace_Type (Actual_Subp, New_Subp); ! else ! Replace_Type (Parent_Subp, New_Subp); ! end if; ! Conditional_Delay (New_Subp, Parent_Subp); + -- 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. + Formal := First_Formal (Parent_Subp); + + if Present (Actual_Subp) then + Formal_Of_Actual := First_Formal (Actual_Subp); + else + Formal_Of_Actual := Empty; + end if; + while Present (Formal) loop New_Formal := New_Copy (Formal); *************** package body Sem_Ch3 is *** 11556,11574 **** -- original formal's parameter specification in this case. Set_Parent (New_Formal, Parent (Formal)); - Append_Entity (New_Formal, New_Subp); ! Replace_Type (Formal, New_Formal); Next_Formal (Formal); end loop; -- 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. if No (Actual_Subp) then if Is_Intrinsic_Subprogram (Parent_Subp) then --- 11861,11884 ---- -- original formal's parameter specification in this case. Set_Parent (New_Formal, Parent (Formal)); Append_Entity (New_Formal, New_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; ! Next_Formal (Formal); end loop; -- 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. if No (Actual_Subp) then if Is_Intrinsic_Subprogram (Parent_Subp) then *************** package body Sem_Ch3 is *** 11658,11667 **** Set_Is_Abstract_Subprogram (New_Subp); -- 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. --- 11968,11977 ---- Set_Is_Abstract_Subprogram (New_Subp); -- 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. *************** package body Sem_Ch3 is *** 11724,11740 **** Derived_Type : Entity_Id; Generic_Actual : Entity_Id := Empty) is ! Op_List : constant Elist_Id := ! Collect_Primitive_Operations (Parent_Type); ! Ifaces_List : constant Elist_Id := New_Elmt_List; ! Predef_Prims : constant Elist_Id := New_Elmt_List; Act_List : Elist_Id; ! Act_Elmt : Elmt_Id; Elmt : Elmt_Id; New_Subp : Entity_Id := Empty; Parent_Base : Entity_Id; Subp : Entity_Id; begin if Ekind (Parent_Type) = E_Record_Type_With_Private and then Has_Discriminants (Parent_Type) --- 12034,12135 ---- Derived_Type : Entity_Id; Generic_Actual : Entity_Id := Empty) is ! Op_List : constant Elist_Id := ! Collect_Primitive_Operations (Parent_Type); ! ! function Check_Derived_Type return Boolean; ! -- Check that all primitive inherited from Parent_Type are found in ! -- the list of primitives of Derived_Type exactly in the same order. ! ! 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; ! ! begin ! -- Traverse list of entities in the current scope searching for ! -- an incomplete type whose full-view is derived type ! ! 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 ! ! return True; ! end if; ! ! E := Next_Entity (E); ! end loop; ! ! List := Collect_Primitive_Operations (Derived_Type); ! Elmt := First_Elmt (List); ! ! Op_Elmt := First_Elmt (Op_List); ! while Present (Op_Elmt) loop ! Subp := Node (Op_Elmt); ! New_Subp := Node (Elmt); ! ! -- 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. ! ! exit when Present (Interface_Alias (Subp)); ! ! -- Handle hidden entities ! ! 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; ! ! 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; ! ! Next_Elmt (Elmt); ! end if; ! ! Next_Elmt (Op_Elmt); ! end loop; ! ! return True; ! end Check_Derived_Type; ! ! -- Local variables ! ! Alias_Subp : Entity_Id; Act_List : Elist_Id; ! Act_Elmt : Elmt_Id := No_Elmt; ! 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 Derive_Subprograms + begin if Ekind (Parent_Type) = E_Record_Type_With_Private and then Has_Discriminants (Parent_Type) *************** package body Sem_Ch3 is *** 11745,11870 **** Parent_Base := Parent_Type; end if; - -- 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 Present (Generic_Actual) then Act_List := Collect_Primitive_Operations (Generic_Actual); Act_Elmt := First_Elmt (Act_List); - else - Act_Elmt := No_Elmt; end if; ! -- Literals are derived earlier in the process of building the derived ! -- type, and are skipped here. ! Elmt := First_Elmt (Op_List); ! while Present (Elmt) loop ! Subp := Node (Elmt); ! if Ekind (Subp) /= E_Enumeration_Literal then ! if Ada_Version >= Ada_05 ! and then Present (Abstract_Interface_Alias (Subp)) ! then null; ! -- We derive predefined primitives in a later round to ensure that ! -- they are always added to the list of primitives after user ! -- defined primitives (because predefined primitives have to be ! -- skipped when matching the operations of a parent interface to ! -- those of a concrete type). However it is unclear why those ! -- primitives would be needed in an instantiation??? ! elsif Is_Predefined_Dispatching_Operation (Subp) then ! Append_Elmt (Subp, Predef_Prims); ! elsif No (Generic_Actual) then ! Derive_Subprogram (New_Subp, Subp, Derived_Type, Parent_Base); ! -- Ada 2005 (AI-251): Add derivation of an abstract interface ! -- primitive to the list of entities to which we have to ! -- associate an aliased entity. ! if Ada_Version >= Ada_05 ! and then Is_Dispatching_Operation (Subp) ! and then Present (Find_Dispatching_Type (Subp)) ! and then Is_Interface (Find_Dispatching_Type (Subp)) ! then ! Append_Elmt (New_Subp, Ifaces_List); end if; ! else ! -- 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_Interface (Parent_Type) ! and then Root_Type (Derived_Type) /= Parent_Type then ! -- Find the corresponding operation in the generic actual. ! -- Given that the actual is not a direct descendant of the ! -- parent, as in Ada 95, the primitives are not necessarily ! -- in the same order, so we have to traverse the list of ! -- primitive operations of the actual to find the one that ! -- implements the interface operation. ! -- Note that if the parent type is the 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. Act_Elmt := First_Elmt (Act_List); while Present (Act_Elmt) loop ! exit when ! Abstract_Interface_Alias (Node (Act_Elmt)) = Subp; Next_Elmt (Act_Elmt); end loop; end if; ! -- If the formal is not an interface, the actual is a direct ! -- descendant and the common primitive operations appear in ! -- the same order. 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; - end if; ! Next_Elmt (Elmt); ! end loop; ! -- Inherit additional operations from progenitor interfaces. However, ! -- if the derived type is a generic actual, there are not new primitive ! -- operations for the type, because it has those of the actual, so ! -- 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 Ada_Version >= Ada_05 ! and then Is_Tagged_Type (Derived_Type) ! and then No (Generic_Actual) ! then ! Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List); ! end if; ! -- Derive predefined primitives - if not Is_Empty_Elmt_List (Predef_Prims) then - Elmt := First_Elmt (Predef_Prims); - while Present (Elmt) loop - Derive_Subprogram - (New_Subp, Node (Elmt), Derived_Type, Parent_Base); Next_Elmt (Elmt); end loop; end if; end Derive_Subprograms; -------------------------------- --- 12140,12405 ---- Parent_Base := Parent_Type; end if; if Present (Generic_Actual) then Act_List := Collect_Primitive_Operations (Generic_Actual); Act_Elmt := First_Elmt (Act_List); end if; ! -- 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. ! -- Case 1: Derived_Type does not implement interfaces ! 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); ! -- Literals are derived earlier in the process of building the ! -- derived type, and are skipped here. ! ! if Ekind (Subp) = E_Enumeration_Literal then null; ! -- The actual is a direct descendant and the common primitive ! -- operations appear in the same order. ! -- 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. ! else ! 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; ! 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. ! ! if Present (Generic_Actual) then ! declare ! Has_Predefined_Primitives : Boolean := False; ! ! begin ! -- Check if the parent type has predefined primitives ! ! Elmt := First_Elmt (Op_List); ! while Present (Elmt) loop ! Subp := Node (Elmt); ! ! if Is_Predefined_Dispatching_Operation (Subp) ! and then not Comes_From_Source (Ultimate_Alias (Subp)) ! then ! Has_Predefined_Primitives := True; ! exit; ! end if; ! ! Next_Elmt (Elmt); ! end loop; ! ! -- 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_Predefined_Dispatching_Operation (Subp) ! or else Comes_From_Source (Subp) ! then ! Append_Elmt (Subp, Aux_List); ! end if; ! ! Next_Elmt (Elmt); ! end loop; ! ! Act_List := Aux_List; ! end; end if; ! Act_Elmt := First_Elmt (Act_List); ! Act_Subp := Node (Act_Elmt); ! end; ! end if; ! -- 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. ! ! Elmt := First_Elmt (Op_List); ! while Present (Elmt) loop ! Subp := Node (Elmt); ! Alias_Subp := Ultimate_Alias (Subp); ! ! -- 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. ! ! exit when Present (Interface_Alias (Subp)); ! ! -- 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. ! ! if Need_Search ! or else ! (Present (Generic_Actual) ! and then Present (Act_Subp) ! and then not Primitive_Names_Match (Subp, Act_Subp)) ! then ! pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual)); ! pragma Assert (Is_Interface (Parent_Base)); ! ! -- Remember that we need searching for all the pending ! -- primitives ! ! Need_Search := True; ! ! -- Handle entities associated with interface primitives ! ! if Present (Alias (Subp)) ! and then Is_Interface (Find_Dispatching_Type (Alias (Subp))) ! and then not Is_Predefined_Dispatching_Operation (Subp) then ! Act_Subp := ! Find_Primitive_Covering_Interface ! (Tagged_Type => Generic_Actual, ! Iface_Prim => Subp); ! -- Handle predefined primitives plus the rest of user-defined ! -- primitives + else Act_Elmt := First_Elmt (Act_List); while Present (Act_Elmt) loop ! Act_Subp := Node (Act_Elmt); ! ! 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_Elmt (Act_Elmt); end loop; 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. ! ! 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. + elsif Present (Alias (Subp)) + 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 Derive_Subprogram ! (New_Subp => New_Subp, ! Parent_Subp => Alias_Subp, ! Derived_Type => Derived_Type, ! Parent_Type => Find_Dispatching_Type (Alias_Subp), ! Actual_Subp => Act_Subp); ! if No (Generic_Actual) then ! Set_Alias (New_Subp, Subp); end if; ! -- Case 3: Common derivation ! else ! Derive_Subprogram ! (New_Subp => New_Subp, ! Parent_Subp => Subp, ! Derived_Type => Derived_Type, ! Parent_Type => Parent_Base, ! Actual_Subp => Act_Subp); ! end if; ! -- No need to update Act_Elm if we must search for the ! -- corresponding operation in the generic actual ! if not Need_Search ! and then Present (Act_Elmt) ! then ! Next_Elmt (Act_Elmt); ! Act_Subp := Node (Act_Elmt); ! end if; Next_Elmt (Elmt); end loop; + + -- 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 No (Generic_Actual) then + Derive_Progenitor_Subprograms (Parent_Base, Derived_Type); + end if; end if; + + -- Final check: Direct descendants must have their primitives in the + -- same order. We exclude from this test non-tagged 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; -------------------------------- *************** package body Sem_Ch3 is *** 12004,12011 **** if Interface_Present (Def) then if not Is_Interface (Parent_Type) then ! Error_Msg_NE ! ("(Ada 2005) & must be an interface", Indic, Parent_Type); else Parent_Node := Parent (Base_Type (Parent_Type)); --- 12539,12545 ---- if Interface_Present (Def) then if not Is_Interface (Parent_Type) then ! Diagnose_Interface (Indic, Parent_Type); else Parent_Node := Parent (Base_Type (Parent_Type)); *************** package body Sem_Ch3 is *** 12098,12104 **** T := Find_Type_Of_Subtype_Indic (Intf); if not Is_Interface (T) then ! Error_Msg_NE ("(Ada 2005) & must be an interface", Intf, T); -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow -- a limited type from having a nonlimited progenitor. --- 12632,12638 ---- T := Find_Type_Of_Subtype_Indic (Intf); if not Is_Interface (T) then ! Diagnose_Interface (Intf, T); -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow -- a limited type from having a nonlimited progenitor. *************** package body Sem_Ch3 is *** 12388,12393 **** --- 12922,12933 ---- end; end if; + 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; + Build_Derived_Type (N, Parent_Type, T, Is_Completion); -- AI-419: The parent type of an explicitly limited derived type must *************** package body Sem_Ch3 is *** 12411,12416 **** --- 12951,12969 ---- end if; end Derived_Type_Declaration; + ------------------------ + -- Diagnose_Interface -- + ------------------------ + + 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; + ---------------------------------- -- Enumeration_Type_Declaration -- ---------------------------------- *************** package body Sem_Ch3 is *** 12615,12620 **** --- 13168,13198 ---- New_Id : Entity_Id; Prev_Par : Node_Id; + 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. + + ------------------ + -- Tag_Mismatch -- + ------------------ + + procedure Tag_Mismatch is + begin + if Sloc (Prev) < Sloc (Id) then + Error_Msg_NE + ("full declaration of } must be a tagged type ", Id, Prev); + else + Error_Msg_NE + ("full declaration of } must be a tagged type ", Prev, Id); + end if; + end Tag_Mismatch; + + -- Start processing for Find_Type_Name + begin -- Find incomplete declaration, if one was given *************** package body Sem_Ch3 is *** 12647,12652 **** --- 13225,13237 ---- Set_Scope (Id, Current_Scope); New_Id := Id; + -- If this is a repeated incomplete declaration, no further + -- checks are possible. + + if Nkind (N) = N_Incomplete_Type_Declaration then + return Prev; + end if; + -- Case of full declaration of incomplete type elsif Ekind (Prev) = E_Incomplete_Type then *************** package body Sem_Ch3 is *** 12747,12753 **** New_Id := Prev; end if; ! -- Verify that full declaration conforms to incomplete one if Is_Incomplete_Or_Private_Type (Prev) and then Present (Discriminant_Specifications (Prev_Par)) --- 13332,13338 ---- New_Id := Prev; end if; ! -- Verify that full declaration conforms to partial one if Is_Incomplete_Or_Private_Type (Prev) and then Present (Discriminant_Specifications (Prev_Par)) *************** package body Sem_Ch3 is *** 12771,12793 **** end if; end if; ! -- A prior untagged private type can have an associated class-wide ! -- type due to use of the class attribute, and in this case also the ! -- full type is required to be tagged. if Is_Type (Prev) and then (Is_Tagged_Type (Prev) or else Present (Class_Wide_Type (Prev))) - and then not Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) then ! -- The full declaration is either a tagged record or an ! -- extension otherwise this is an error - if Nkind (Type_Definition (N)) = N_Record_Definition then if not Tagged_Present (Type_Definition (N)) then ! Error_Msg_NE ! ("full declaration of } must be tagged", Prev, Id); Set_Is_Tagged_Type (Id); Set_Primitive_Operations (Id, New_Elmt_List); end if; --- 13356,13390 ---- end if; end if; ! -- 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. if Is_Type (Prev) and then (Is_Tagged_Type (Prev) or else Present (Class_Wide_Type (Prev))) then ! -- 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 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; ! ! elsif Nkind (Type_Definition (N)) = N_Record_Definition then ! ! -- Indicate that the previous declaration (tagged incomplete ! -- or private declaration) requires the same on the full one. if not Tagged_Present (Type_Definition (N)) then ! Tag_Mismatch; Set_Is_Tagged_Type (Id); Set_Primitive_Operations (Id, New_Elmt_List); end if; *************** package body Sem_Ch3 is *** 12802,12810 **** end if; else ! Error_Msg_NE ! ("full declaration of } must be a tagged type", Prev, Id); ! end if; end if; --- 13399,13405 ---- end if; else ! Tag_Mismatch; end if; end if; *************** package body Sem_Ch3 is *** 12938,12943 **** --- 13533,13540 ---- Typ := Entity (S); end if; + -- Check No_Wide_Characters restriction + if Typ = Standard_Wide_Character or else Typ = Standard_Wide_Wide_Character or else Typ = Standard_Wide_String *************** package body Sem_Ch3 is *** 13279,13284 **** --- 13876,13883 ---- return Result; end Search_Derivation_Levels; + -- Local Variables + Result : Node_Or_Entity_Id; -- Start of processing for Get_Discriminant_Value *************** package body Sem_Ch3 is *** 13688,13693 **** --- 14287,14305 ---- end if; end Is_Null_Extension; + -------------------- + -- Is_Progenitor -- + -------------------- + + function Is_Progenitor + (Iface : Entity_Id; + Typ : Entity_Id) return Boolean + is + begin + return Implements_Interface (Typ, Iface, + Exclude_Parents => True); + end Is_Progenitor; + ------------------------------ -- Is_Valid_Constraint_Kind -- ------------------------------ *************** package body Sem_Ch3 is *** 13878,13885 **** Ancestor := Etype (Ancestor); end loop; - - return True; end; end if; end Is_Visible_Component; --- 14490,14495 ---- *************** package body Sem_Ch3 is *** 13931,13937 **** Set_Is_Abstract_Type (CW_Type, False); Set_Is_Constrained (CW_Type, False); Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); - Init_Size_Align (CW_Type); if Ekind (T) = E_Class_Wide_Subtype then Set_Etype (CW_Type, Etype (Base_Type (T))); --- 14541,14546 ---- *************** package body Sem_Ch3 is *** 14002,14007 **** --- 14611,14623 ---- T := Standard_Character; 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 (I) = Universal_Integer then + T := Standard_Integer; + else T := Any_Type; *************** package body Sem_Ch3 is *** 14413,14419 **** function OK_For_Limited_Init_In_05 (Exp : Node_Id) return Boolean is begin - -- 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 give in prefixed --- 15029,15034 ---- *************** package body Sem_Ch3 is *** 14562,14569 **** Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val); Set_Fixed_Range (T, Loc, Low_Val, High_Val); - Init_Size_Align (Implicit_Base); - -- Complete definition of first subtype Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); --- 15177,15182 ---- *************** package body Sem_Ch3 is *** 14715,14721 **** -- Object Expressions" in spec of package Sem). if Present (Expression (Discr)) then ! Analyze_Per_Use_Expression (Expression (Discr), Discr_Type); if Nkind (N) = N_Formal_Type_Declaration then Error_Msg_N --- 15328,15334 ---- -- Object Expressions" in spec of package Sem). if Present (Expression (Discr)) then ! Preanalyze_Spec_Expression (Expression (Discr), Discr_Type); if Nkind (N) = N_Formal_Type_Declaration then Error_Msg_N *************** package body Sem_Ch3 is *** 14777,14786 **** Create_Null_Excluding_Itype (T => Discr_Type, Related_Nod => Discr)); end if; -- Ada 2005 (AI-402): access discriminants of nonlimited types ! -- can't have defaults if Is_Access_Type (Discr_Type) then if Ekind (Discr_Type) /= E_Anonymous_Access_Type --- 15390,15412 ---- Create_Null_Excluding_Itype (T => Discr_Type, Related_Nod => Discr)); + + -- Check for improper null exclusion if the type is otherwise + -- legal for a discriminant. + + 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; -- 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 Is_Access_Type (Discr_Type) then if Ekind (Discr_Type) /= E_Anonymous_Access_Type *************** package body Sem_Ch3 is *** 14790,14796 **** or else Is_Concurrent_Record_Type (Current_Scope) or else Ekind (Current_Scope) = E_Limited_Private_Type then ! null; elsif Present (Expression (Discr)) then Error_Msg_N --- 15416,15434 ---- 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; ! ! else ! Error_Msg_N ("access discriminants of nonlimited types", ! Expression (Discr)); ! Error_Msg_N ("\cannot have defaults", Expression (Discr)); ! end if; elsif Present (Expression (Discr)) then Error_Msg_N *************** package body Sem_Ch3 is *** 14947,14954 **** -- Handle entities in the list of abstract interfaces ! if Present (Abstract_Interfaces (Typ)) then ! Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ)); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); --- 15585,15592 ---- -- Handle entities in the list of abstract interfaces ! if Present (Interfaces (Typ)) then ! Iface_Elmt := First_Elmt (Interfaces (Typ)); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); *************** package body Sem_Ch3 is *** 15086,15092 **** -- 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 case are performed by Build_Derived_Record_Type. elsif not Is_Interface (Base_Type (Priv_Parent)) and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) --- 15724,15730 ---- -- 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 not Is_Interface (Base_Type (Priv_Parent)) and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) *************** package body Sem_Ch3 is *** 15278,15322 **** -- If the private view was tagged, copy the new primitive operations -- from the private view to the full view. ! if Is_Tagged_Type (Full_T) ! and then not Is_Concurrent_Type (Full_T) ! then declare ! Priv_List : Elist_Id; ! Full_List : constant Elist_Id := Primitive_Operations (Full_T); ! P1, P2 : Elmt_Id; Prim : Entity_Id; ! D_Type : Entity_Id; begin if Is_Tagged_Type (Priv_T) then Priv_List := Primitive_Operations (Priv_T); ! P1 := First_Elmt (Priv_List); ! while Present (P1) loop ! Prim := Node (P1); ! -- Transfer explicit primitives, not those inherited from ! -- parent of partial view, which will be re-inherited on ! -- the full view. ! if Comes_From_Source (Prim) then ! P2 := First_Elmt (Full_List); ! while Present (P2) and then Node (P2) /= Prim loop ! Next_Elmt (P2); end loop; ! -- If not found, that is a new one ! if No (P2) then Append_Elmt (Prim, Full_List); end if; - end if; ! Next_Elmt (P1); ! end loop; else -- 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 --- 15916,16032 ---- -- If the private view was tagged, copy the new primitive operations -- from the private view to the full view. ! 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; ! ! function Contains ! (E : Entity_Id; ! L : Elist_Id) return Boolean; ! -- Determine whether list L contains element E ! ! -------------- ! -- Contains -- ! -------------- ! ! function Contains ! (E : Entity_Id; ! L : Elist_Id) return Boolean ! is ! List_Elmt : Elmt_Id; ! ! begin ! List_Elmt := First_Elmt (L); ! while Present (List_Elmt) loop ! if Node (List_Elmt) = E then ! return True; ! end if; ! ! Next_Elmt (List_Elmt); ! end loop; ! ! return False; ! end Contains; ! ! -- Start of processing begin if Is_Tagged_Type (Priv_T) then Priv_List := Primitive_Operations (Priv_T); + Prim_Elmt := First_Elmt (Priv_List); ! -- 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. ! if Is_Concurrent_Type (Full_T) then ! declare ! Conc_Typ : constant Entity_Id := ! Corresponding_Record_Type (Full_T); ! Loc : constant Source_Ptr := Sloc (Conc_Typ); ! Curr_Nod : Node_Id := Parent (Conc_Typ); ! Wrap_Spec : Node_Id; ! begin ! while Present (Prim_Elmt) loop ! Prim := Node (Prim_Elmt); ! ! if Comes_From_Source (Prim) ! and then not Is_Abstract_Subprogram (Prim) ! then ! Wrap_Spec := ! Make_Subprogram_Declaration (Loc, ! Specification => ! Build_Wrapper_Spec (Loc, ! Subp_Id => Prim, ! Obj_Typ => Conc_Typ, ! Formals => ! Parameter_Specifications ( ! Parent (Prim)))); ! ! Insert_After (Curr_Nod, Wrap_Spec); ! Curr_Nod := Wrap_Spec; ! ! Analyze (Wrap_Spec); ! end if; ! ! Next_Elmt (Prim_Elmt); end loop; ! return; ! end; ! -- 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. ! ! else ! Full_List := Primitive_Operations (Full_T); ! ! while Present (Prim_Elmt) loop ! Prim := Node (Prim_Elmt); ! ! if Comes_From_Source (Prim) ! and then not Contains (Prim, Full_List) ! then Append_Elmt (Prim, Full_List); end if; ! Next_Elmt (Prim_Elmt); ! end loop; ! end if; ! ! -- Untagged private view else + Full_List := Primitive_Operations (Full_T); + -- 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 *************** package body Sem_Ch3 is *** 15335,15344 **** or else Ekind (Prim) = E_Function then ! D_Type := Find_Dispatching_Type (Prim); ! ! if D_Type = Full_T and then (Chars (Prim) /= Name_Op_Ne or else Comes_From_Source (Prim)) then --- 16045,16053 ---- or else Ekind (Prim) = E_Function then + Disp_Typ := Find_Dispatching_Type (Prim); ! if Disp_Typ = Full_T and then (Chars (Prim) /= Name_Op_Ne or else Comes_From_Source (Prim)) then *************** package body Sem_Ch3 is *** 15351,15363 **** end if; elsif Is_Dispatching_Operation (Prim) ! and then D_Type /= Full_T then -- Verify that it is not otherwise controlled by a -- formal or a return value of type T. ! Check_Controlling_Formals (D_Type, Prim); end if; end if; --- 16060,16072 ---- end if; elsif Is_Dispatching_Operation (Prim) ! and then Disp_Typ /= Full_T then -- Verify that it is not otherwise controlled by a -- formal or a return value of type T. ! Check_Controlling_Formals (Disp_Typ, Prim); end if; end if; *************** package body Sem_Ch3 is *** 15845,15851 **** --- 16554,16562 ---- 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); *************** package body Sem_Ch3 is *** 15890,15895 **** --- 16601,16609 ---- Error_Node := Subtype_Indication (Component_Definition (Related_Nod)); + when N_Allocator => + Error_Node := Expression (Related_Nod); + when others => pragma Assert (False); Error_Node := Related_Nod; *************** package body Sem_Ch3 is *** 16110,16116 **** -- view of the type. function Designates_T (Subt : Node_Id) return Boolean; ! -- Check whether a node designates the enclosing record type function Mentions_T (Acc_Def : Node_Id) return Boolean; -- Check whether an access definition includes a reference to --- 16824,16831 ---- -- view of the type. function Designates_T (Subt : Node_Id) return Boolean; ! -- Check whether a node designates the enclosing record type, or 'Class ! -- of that type function Mentions_T (Acc_Def : Node_Id) return Boolean; -- Check whether an access definition includes a reference to *************** package body Sem_Ch3 is *** 16128,16140 **** Inc_T : Entity_Id; H : Entity_Id; 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. if Prev /= Typ then ! if Tagged_Present (Type_Definition (Typ_Decl)) then Make_Class_Wide_Type (Prev); Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); Set_Etype (Class_Wide_Type (Typ), Typ); --- 16843,16867 ---- Inc_T : Entity_Id; H : Entity_Id; + -- Is_Tagged indicates whether the type is tagged. It is tagged if + -- it's "is new ... with record" or else "is tagged record ...". + + 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))); + 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. 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); *************** package body Sem_Ch3 is *** 16143,16148 **** --- 16870,16884 ---- return; elsif Has_Private_Declaration (Typ) then + + -- 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. + + if Is_Tagged then + Make_Class_Wide_Type (Typ); + end if; + return; -- If there was a previous anonymous access type, the incomplete *************** package body Sem_Ch3 is *** 16155,16162 **** return; else ! Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); ! Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); -- Type has already been inserted into the current scope. -- Remove it, and add incomplete declaration for type, so --- 16891,16898 ---- return; else ! Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); ! Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); -- Type has already been inserted into the current scope. -- Remove it, and add incomplete declaration for type, so *************** package body Sem_Ch3 is *** 16184,16197 **** Analyze (Decl); Set_Full_View (Inc_T, Typ); ! if (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition ! and then ! Present ! (Record_Extension_Part (Type_Definition (Typ_Decl)))) ! or else Tagged_Present (Type_Definition (Typ_Decl)) ! then -- Create a common class-wide type for both views, and set ! -- the etype of the class-wide type to the full view. Make_Class_Wide_Type (Inc_T); Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); --- 16920,16928 ---- Analyze (Decl); Set_Full_View (Inc_T, Typ); ! if Is_Tagged then -- Create a common class-wide type for both views, and set ! -- the Etype of the class-wide type to the full view. Make_Class_Wide_Type (Inc_T); Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); *************** package body Sem_Ch3 is *** 16454,16459 **** --- 17185,17202 ---- end if; end Check_Anonymous_Access_Components; + -------------------------------- + -- 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; + ----------------------------- -- Record_Type_Declaration -- ----------------------------- *************** package body Sem_Ch3 is *** 16471,16481 **** -- These flags must be initialized before calling Process_Discriminants -- because this routine makes use of them. ! Set_Ekind (T, E_Record_Type); ! Set_Etype (T, T); ! Init_Size_Align (T); ! Set_Abstract_Interfaces (T, No_Elist); ! Set_Stored_Constraint (T, No_Elist); -- Normal case --- 17214,17224 ---- -- These flags must be initialized before calling Process_Discriminants -- because this routine makes use of them. ! Set_Ekind (T, E_Record_Type); ! Set_Etype (T, T); ! Init_Size_Align (T); ! Set_Interfaces (T, No_Elist); ! Set_Stored_Constraint (T, No_Elist); -- Normal case *************** package body Sem_Ch3 is *** 16521,16527 **** if Ada_Version >= Ada_05 and then Present (Interface_List (Def)) then ! Check_Abstract_Interfaces (N, Def); declare Ifaces_List : Elist_Id; --- 17264,17270 ---- if Ada_Version >= Ada_05 and then Present (Interface_List (Def)) then ! Check_Interfaces (N, Def); declare Ifaces_List : Elist_Id; *************** package body Sem_Ch3 is *** 16530,16541 **** -- Ada 2005 (AI-251): Collect the list of progenitors that are not -- already in the parents. ! Collect_Abstract_Interfaces ! (T => T, ! Ifaces_List => Ifaces_List, ! Exclude_Parent_Interfaces => True); ! Set_Abstract_Interfaces (T, Ifaces_List); end; end if; --- 17273,17284 ---- -- Ada 2005 (AI-251): Collect the list of progenitors that are not -- already in the parents. ! Collect_Interfaces ! (T => T, ! Ifaces_List => Ifaces_List, ! Exclude_Parents => True); ! Set_Interfaces (T, Ifaces_List); end; end if; *************** package body Sem_Ch3 is *** 16582,16588 **** -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the -- implemented interfaces. ! if Has_Abstract_Interfaces (T) then Add_Interface_Tag_Components (N, T); end if; end if; --- 17325,17331 ---- -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the -- implemented interfaces. ! if Has_Interfaces (T) then Add_Interface_Tag_Components (N, T); end if; end if; *************** package body Sem_Ch3 is *** 16619,16629 **** if Is_Tagged and then not Is_Empty_List (Interface_List (Def)) then ! declare ! Ifaces_List : constant Elist_Id := New_Elmt_List; ! begin ! Derive_Interface_Subprograms (T, T, Ifaces_List); ! end; end if; end Record_Type_Declaration; --- 17362,17368 ---- if Is_Tagged and then not Is_Empty_List (Interface_List (Def)) then ! Derive_Progenitor_Subprograms (T, T); end if; end Record_Type_Declaration; *************** package body Sem_Ch3 is *** 16699,16709 **** elsif Has_Controlled_Component (Etype (Component)) or else (Chars (Component) /= Name_uParent ! and then Is_Controlled (Etype (Component))) then Set_Has_Controlled_Component (T, True); ! Final_Storage_Only := Final_Storage_Only ! and then Finalize_Storage_Only (Etype (Component)); Ctrl_Components := True; end if; --- 17438,17449 ---- elsif Has_Controlled_Component (Etype (Component)) or else (Chars (Component) /= Name_uParent ! and then Is_Controlled (Etype (Component))) then Set_Has_Controlled_Component (T, True); ! Final_Storage_Only := ! Final_Storage_Only ! and then Finalize_Storage_Only (Etype (Component)); Ctrl_Components := True; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch3.ads gcc-4.4.0/gcc/ada/sem_ch3.ads *** gcc-4.3.3/gcc/ada/sem_ch3.ads Thu Dec 13 10:48:09 2007 --- gcc-4.4.0/gcc/ada/sem_ch3.ads Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** *** 26,32 **** with Nlists; use Nlists; with Types; use Types; ! package Sem_Ch3 is procedure Analyze_Component_Declaration (N : Node_Id); procedure Analyze_Incomplete_Type_Decl (N : Node_Id); procedure Analyze_Itype_Reference (N : Node_Id); --- 26,32 ---- with Nlists; use Nlists; with Types; use Types; ! package Sem_Ch3 is procedure Analyze_Component_Declaration (N : Node_Id); procedure Analyze_Incomplete_Type_Decl (N : Node_Id); procedure Analyze_Itype_Reference (N : Node_Id); *************** package Sem_Ch3 is *** 71,84 **** procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id); -- Analyze an interface declaration or a formal interface declaration - procedure Analyze_Per_Use_Expression (N : Node_Id; T : Entity_Id); - -- Default and per object expressions do not freeze their components, - -- and must be analyzed and resolved accordingly. The analysis is - -- done by calling the Pre_Analyze_And_Resolve routine and setting - -- the global In_Default_Expression flag. See the documentation section - -- entitled "Handling of Default and Per-Object Expressions" in sem.ads - -- for details. N is the expression to be analyzed, T is the expected type. - procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id); -- Process an array type declaration. If the array is constrained, we -- create an implicit parent array type, with the same index types and --- 71,76 ---- *************** package Sem_Ch3 is *** 179,184 **** --- 171,177 ---- -- family declaration or a loop iteration. The index is given by an -- index declaration (a 'box'), or by a discrete range. The later can -- be the name of a discrete type, or a subtype indication. + -- -- Related_Nod is the node where the potential generated implicit types -- will be inserted. The 2 last parameters are used for creating the name. *************** package Sem_Ch3 is *** 187,193 **** -- attributes of a class wide type are inherited from those of the type T. -- If T is introduced by a private declaration, the corresponding class -- wide type is created at the same time, and therefore there is a private ! -- and a full declaration for the class wide type type as well. function OK_For_Limited_Init_In_05 (Exp : Node_Id) return Boolean; -- Presuming Exp is an expression of an inherently limited type, returns --- 180,186 ---- -- attributes of a class wide type are inherited from those of the type T. -- If T is introduced by a private declaration, the corresponding class -- wide type is created at the same time, and therefore there is a private ! -- and a full declaration for the class wide type as well. function OK_For_Limited_Init_In_05 (Exp : Node_Id) return Boolean; -- Presuming Exp is an expression of an inherently limited type, returns *************** package Sem_Ch3 is *** 204,209 **** --- 197,210 ---- -- Always False in Ada 95 mode. Equivalent to OK_For_Limited_Init_In_05 in -- Ada 2005 mode. + procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id); + -- Default and per object expressions do not freeze their components, and + -- must be analyzed and resolved accordingly. The analysis is done by + -- calling the Preanalyze_And_Resolve routine and setting the global + -- In_Default_Expression flag. See the documentation section entitled + -- "Handling of Default and Per-Object Expressions" in sem.ads for full + -- details. N is the expression to be analyzed, T is the expected type. + procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id); -- Process some semantic actions when the full view of a private type is -- encountered and analyzed. The first action is to create the full views diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch4.adb gcc-4.4.0/gcc/ada/sem_ch4.adb *** gcc-4.3.3/gcc/ada/sem_ch4.adb Wed Dec 19 16:24:44 2007 --- gcc-4.4.0/gcc/ada/sem_ch4.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Sem_Ch4 is *** 73,79 **** -- function, and if so must be converted into an explicit call node -- and analyzed as such. This deproceduring must be done during the first -- pass of overload resolution, because otherwise a procedure call with ! -- overloaded actuals may fail to resolve. See 4327-001 for an example. procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id); -- Analyze a call of the form "+"(x, y), etc. The prefix of the call --- 73,79 ---- -- function, and if so must be converted into an explicit call node -- and analyzed as such. This deproceduring must be done during the first -- pass of overload resolution, because otherwise a procedure call with ! -- overloaded actuals may fail to resolve. procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id); -- Analyze a call of the form "+"(x, y), etc. The prefix of the call *************** package body Sem_Ch4 is *** 132,138 **** -- an invalid selector error message. function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean; ! -- Verify that type T is declared in scope S. Used to find intepretations -- for operators given by expanded names. This is abstracted as a separate -- function to handle extensions to System, where S is System, but T is -- declared in the extension. --- 132,138 ---- -- an invalid selector error message. function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean; ! -- Verify that type T is declared in scope S. Used to find interpretations -- for operators given by expanded names. This is abstracted as a separate -- function to handle extensions to System, where S is System, but T is -- declared in the extension. *************** package body Sem_Ch4 is *** 268,273 **** --- 268,278 ---- function Try_Object_Operation (N : Node_Id) return Boolean; -- Ada 2005 (AI-252): Support the object.operation notation + procedure wpo (T : Entity_Id); + pragma Warnings (Off, wpo); + -- Used for debugging: obtain list of primitive operations even if + -- type is not frozen and dispatch table is not built yet. + ------------------------ -- Ambiguous_Operands -- ------------------------ *************** package body Sem_Ch4 is *** 356,367 **** Type_Id : Entity_Id; begin ! Check_Restriction (No_Allocators, N); if Nkind (E) = N_Qualified_Expression then Acc_Type := Create_Itype (E_Allocator_Type, N); Set_Etype (Acc_Type, Acc_Type); - Init_Size_Align (Acc_Type); Find_Type (Subtype_Mark (E)); -- Analyze the qualified expression, and apply the name resolution --- 361,376 ---- Type_Id : Entity_Id; begin ! -- In accordance with H.4(7), the No_Allocators restriction only applies ! -- to user-written allocators. ! ! if Comes_From_Source (N) then ! Check_Restriction (No_Allocators, N); ! end if; if Nkind (E) = N_Qualified_Expression then Acc_Type := Create_Itype (E_Allocator_Type, N); Set_Etype (Acc_Type, Acc_Type); Find_Type (Subtype_Mark (E)); -- Analyze the qualified expression, and apply the name resolution *************** package body Sem_Ch4 is *** 486,500 **** Type_Id := Process_Subtype (E, N); Acc_Type := Create_Itype (E_Allocator_Type, N); Set_Etype (Acc_Type, Acc_Type); - Init_Size_Align (Acc_Type); Set_Directly_Designated_Type (Acc_Type, Type_Id); Check_Fully_Declared (Type_Id, N); ! -- Ada 2005 (AI-231) if Can_Never_Be_Null (Type_Id) then ! Error_Msg_N ("(Ada 2005) qualified expression required", ! Expression (N)); end if; -- Check restriction against dynamically allocated protected --- 495,521 ---- Type_Id := Process_Subtype (E, N); Acc_Type := Create_Itype (E_Allocator_Type, N); Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, Type_Id); Check_Fully_Declared (Type_Id, N); ! -- Ada 2005 (AI-231): If the designated type is itself an access ! -- type that excludes null, its default initialization will ! -- be a null object, and we can insert an unconditional raise ! -- before the allocator. if Can_Never_Be_Null (Type_Id) then ! declare ! Not_Null_Check : constant Node_Id := ! Make_Raise_Constraint_Error (Sloc (E), ! Reason => CE_Null_Not_Allowed); ! begin ! if Expander_Active then ! Insert_Action (N, Not_Null_Check); ! Analyze (Not_Null_Check); ! else ! Error_Msg_N ("null value not allowed here?", E); ! end if; ! end; end if; -- Check restriction against dynamically allocated protected *************** package body Sem_Ch4 is *** 676,693 **** procedure Analyze_Call (N : Node_Id) is Actuals : constant List_Id := Parameter_Associations (N); ! Nam : Node_Id := Name (N); X : Interp_Index; It : Interp; Nam_Ent : Entity_Id; Success : Boolean := False; function Name_Denotes_Function return Boolean; ! -- If the type of the name is an access to subprogram, this may be ! -- the type of a name, or the return type of the function being called. ! -- If the name is not an entity then it can denote a protected function. ! -- Until we distinguish Etype from Return_Type, we must use this ! -- routine to resolve the meaning of the name in the call. --------------------------- -- Name_Denotes_Function -- --- 697,721 ---- procedure Analyze_Call (N : Node_Id) is Actuals : constant List_Id := Parameter_Associations (N); ! Nam : Node_Id; X : Interp_Index; It : Interp; Nam_Ent : Entity_Id; Success : Boolean := False; + Deref : Boolean := False; + -- Flag indicates whether an interpretation of the prefix is a + -- parameterless call that returns an access_to_subprogram. + function Name_Denotes_Function return Boolean; ! -- If the type of the name is an access to subprogram, this may be the ! -- type of a name, or the return type of the function being called. If ! -- the name is not an entity then it can denote a protected function. ! -- Until we distinguish Etype from Return_Type, we must use this routine ! -- to resolve the meaning of the name in the call. ! ! procedure No_Interpretation; ! -- Output error message when no valid interpretation exists --------------------------- -- Name_Denotes_Function -- *************** package body Sem_Ch4 is *** 706,711 **** --- 734,776 ---- end if; end Name_Denotes_Function; + ----------------------- + -- No_Interpretation -- + ----------------------- + + procedure No_Interpretation is + L : constant Boolean := Is_List_Member (N); + K : constant Node_Kind := Nkind (Parent (N)); + + begin + -- If the node is in a list whose parent is not an expression then it + -- must be an attempted procedure call. + + if L and then K not in N_Subexpr then + if Ekind (Entity (Nam)) = E_Generic_Procedure then + Error_Msg_NE + ("must instantiate generic procedure& before call", + Nam, Entity (Nam)); + else + Error_Msg_N + ("procedure or entry name expected", Nam); + end if; + + -- Check for tasking cases where only an entry call will do + + elsif not L + and then Nkind_In (K, N_Entry_Call_Alternative, + N_Triggering_Alternative) + then + Error_Msg_N ("entry name expected", Nam); + + -- Otherwise give general error message + + else + Error_Msg_N ("invalid prefix in call", Nam); + end if; + end No_Interpretation; + -- Start of processing for Analyze_Call begin *************** package body Sem_Ch4 is *** 714,719 **** --- 779,786 ---- Set_Etype (N, Any_Type); + Nam := Name (N); + if not Is_Overloaded (Nam) then -- Only one interpretation to check *************** package body Sem_Ch4 is *** 726,738 **** -- name, or if it is a function name in the context of a procedure -- call. In this latter case, we have a call to a parameterless -- function that returns a pointer_to_procedure which is the entity ! -- being called. elsif Is_Access_Type (Etype (Nam)) and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type and then (not Name_Denotes_Function ! or else Nkind (N) = N_Procedure_Call_Statement) then Nam_Ent := Designated_Type (Etype (Nam)); Insert_Explicit_Dereference (Nam); --- 793,811 ---- -- name, or if it is a function name in the context of a procedure -- call. In this latter case, we have a call to a parameterless -- function that returns a pointer_to_procedure which is the entity ! -- being called. Finally, F (X) may be a call to a parameterless ! -- function that returns a pointer to a function with parameters. elsif Is_Access_Type (Etype (Nam)) and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type and then (not Name_Denotes_Function ! or else Nkind (N) = N_Procedure_Call_Statement ! or else ! (Nkind (Parent (N)) /= N_Explicit_Dereference ! and then Is_Entity_Name (Nam) ! and then No (First_Formal (Entity (Nam))) ! and then Present (Actuals))) then Nam_Ent := Designated_Type (Etype (Nam)); Insert_Explicit_Dereference (Nam); *************** package body Sem_Ch4 is *** 778,818 **** -- If no interpretations, give error message if not Is_Overloadable (Nam_Ent) then ! declare ! L : constant Boolean := Is_List_Member (N); ! K : constant Node_Kind := Nkind (Parent (N)); ! ! begin ! -- If the node is in a list whose parent is not an ! -- expression then it must be an attempted procedure call. ! ! if L and then K not in N_Subexpr then ! if Ekind (Entity (Nam)) = E_Generic_Procedure then ! Error_Msg_NE ! ("must instantiate generic procedure& before call", ! Nam, Entity (Nam)); ! else ! Error_Msg_N ! ("procedure or entry name expected", Nam); ! end if; ! ! -- Check for tasking cases where only an entry call will do ! ! elsif not L ! and then Nkind_In (K, N_Entry_Call_Alternative, ! N_Triggering_Alternative) ! then ! Error_Msg_N ("entry name expected", Nam); ! ! -- Otherwise give general error message ! else ! Error_Msg_N ("invalid prefix in call", Nam); ! end if; ! return; ! end; ! end if; end if; Analyze_One_Call (N, Nam_Ent, True, Success); --- 851,867 ---- -- If no interpretations, give error message if not Is_Overloadable (Nam_Ent) then ! No_Interpretation; ! return; ! end if; ! end if; ! -- Operations generated for RACW stub types are called only through ! -- dispatching, and can never be the static interpretation of a call. ! if Is_RACW_Stub_Type_Operation (Nam_Ent) then ! No_Interpretation; ! return; end if; Analyze_One_Call (N, Nam_Ent, True, Success); *************** package body Sem_Ch4 is *** 832,840 **** end if; else ! -- An overloaded selected component must denote overloaded ! -- operations of a concurrent type. The interpretations are ! -- attached to the simple name of those operations. if Nkind (Nam) = N_Selected_Component then Nam := Selector_Name (Nam); --- 881,889 ---- end if; else ! -- An overloaded selected component must denote overloaded operations ! -- of a concurrent type. The interpretations are attached to the ! -- simple name of those operations. if Nkind (Nam) = N_Selected_Component then Nam := Selector_Name (Nam); *************** package body Sem_Ch4 is *** 844,849 **** --- 893,899 ---- while Present (It.Nam) loop Nam_Ent := It.Nam; + Deref := False; -- Name may be call that returns an access to subprogram, or more -- generally an overloaded expression one of whose interpretations *************** package body Sem_Ch4 is *** 858,868 **** Nam_Ent := Designated_Type (Nam_Ent); elsif Is_Access_Type (Etype (Nam_Ent)) ! and then not Is_Entity_Name (Nam) and then Ekind (Designated_Type (Etype (Nam_Ent))) = E_Subprogram_Type then Nam_Ent := Designated_Type (Etype (Nam_Ent)); end if; Analyze_One_Call (N, Nam_Ent, False, Success); --- 908,924 ---- Nam_Ent := Designated_Type (Nam_Ent); elsif Is_Access_Type (Etype (Nam_Ent)) ! and then ! (not Is_Entity_Name (Nam) ! or else Nkind (N) = N_Procedure_Call_Statement) and then Ekind (Designated_Type (Etype (Nam_Ent))) = E_Subprogram_Type then Nam_Ent := Designated_Type (Etype (Nam_Ent)); + + if Is_Entity_Name (Nam) then + Deref := True; + end if; end if; Analyze_One_Call (N, Nam_Ent, False, Success); *************** package body Sem_Ch4 is *** 874,880 **** -- guation is done directly in Resolve. if Success then ! Set_Etype (Nam, It.Typ); elsif Nkind_In (Name (N), N_Selected_Component, N_Function_Call) --- 930,945 ---- -- guation is done directly in Resolve. if Success then ! if Deref ! and then Nkind (Parent (N)) /= N_Explicit_Dereference ! then ! Set_Entity (Nam, It.Nam); ! Insert_Explicit_Dereference (Nam); ! Set_Etype (Nam, Nam_Ent); ! ! else ! Set_Etype (Nam, It.Typ); ! end if; elsif Nkind_In (Name (N), N_Selected_Component, N_Function_Call) *************** package body Sem_Ch4 is *** 966,991 **** End_Interp_List; end if; - - -- Check for not-yet-implemented cases of AI-318. We only need to check - -- for inherently limited types, because other limited types will be - -- returned by copy, which works just fine. - -- If the context is an attribute reference 'Class, this is really a - -- type conversion, which is illegal, and will be caught elsewhere. - - if Ada_Version >= Ada_05 - and then not Debug_Flag_Dot_L - and then Is_Inherently_Limited_Type (Etype (N)) - and then (Nkind_In (Parent (N), N_Selected_Component, - N_Indexed_Component, - N_Slice) - or else - (Nkind (Parent (N)) = N_Attribute_Reference - and then Attribute_Name (Parent (N)) /= Name_Class)) - then - Error_Msg_N ("(Ada 2005) limited function call in this context" & - " is not yet implemented", N); - end if; end Analyze_Call; --------------------------- --- 1031,1036 ---- *************** package body Sem_Ch4 is *** 1356,1362 **** if not Is_Overloaded (P) then if Is_Access_Type (Etype (P)) then ! -- Set the Etype. We need to go thru Is_For_Access_Subtypes to -- avoid other problems caused by the Private_Subtype and it is -- safe to go to the Base_Type because this is the same as -- converting the access value to its Base_Type. --- 1401,1407 ---- if not Is_Overloaded (P) then if Is_Access_Type (Etype (P)) then ! -- Set the Etype. We need to go through Is_For_Access_Subtypes to -- avoid other problems caused by the Private_Subtype and it is -- safe to go to the Base_Type because this is the same as -- converting the access value to its Base_Type. *************** package body Sem_Ch4 is *** 1439,1445 **** -- where the prefix might include functions that return access to -- subprograms and others that return a regular type. Disambiguation -- of those has to take place in Resolve. - -- See e.g. 7117-014 and E317-001. New_N := Make_Function_Call (Loc, --- 1484,1489 ---- *************** package body Sem_Ch4 is *** 1471,1484 **** and then Is_Overloaded (N) then -- The prefix may include access to subprograms and other access ! -- types. If the context selects the interpretation that is a call, ! -- we cannot rewrite the node yet, but we include the result of ! -- the call interpretation. Get_First_Interp (N, I, It); while Present (It.Nam) loop if Ekind (Base_Type (It.Typ)) = E_Subprogram_Type and then Etype (Base_Type (It.Typ)) /= Standard_Void_Type then Add_One_Interp (N, Etype (It.Typ), Etype (It.Typ)); end if; --- 1515,1529 ---- and then Is_Overloaded (N) then -- The prefix may include access to subprograms and other access ! -- types. If the context selects the interpretation that is a ! -- function call (not a procedure call) we cannot rewrite the node ! -- yet, but we include the result of the call interpretation. Get_First_Interp (N, I, It); while Present (It.Nam) loop if Ekind (Base_Type (It.Typ)) = E_Subprogram_Type and then Etype (Base_Type (It.Typ)) /= Standard_Void_Type + and then Nkind (Parent (N)) /= N_Procedure_Call_Statement then Add_One_Interp (N, Etype (It.Typ), Etype (It.Typ)); end if; *************** package body Sem_Ch4 is *** 1781,1787 **** end loop; if Etype (N) = Any_Type then ! Error_Msg_N ("no legal interpetation for indexed component", N); Set_Is_Overloaded (N, False); end if; --- 1826,1832 ---- end loop; if Etype (N) = Any_Type then ! Error_Msg_N ("no legal interpretation for indexed component", N); Set_Is_Overloaded (N, False); end if; *************** package body Sem_Ch4 is *** 2095,2105 **** -- is already known to be compatible, and because this may be an -- indexing of a call with default parameters. ! Formal : Entity_Id; ! Actual : Node_Id; ! Is_Indexed : Boolean := False; ! Subp_Type : constant Entity_Id := Etype (Nam); ! Norm_OK : Boolean; function Operator_Hidden_By (Fun : Entity_Id) return Boolean; -- There may be a user-defined operator that hides the current --- 2140,2151 ---- -- is already known to be compatible, and because this may be an -- indexing of a call with default parameters. ! Formal : Entity_Id; ! Actual : Node_Id; ! Is_Indexed : Boolean := False; ! Is_Indirect : Boolean := False; ! Subp_Type : constant Entity_Id := Etype (Nam); ! Norm_OK : Boolean; function Operator_Hidden_By (Fun : Entity_Id) return Boolean; -- There may be a user-defined operator that hides the current *************** package body Sem_Ch4 is *** 2208,2213 **** --- 2254,2266 ---- -- in prefix notation, so that the rebuilt parameter list has more than -- one actual. + if not Is_Overloadable (Nam) + and then Ekind (Nam) /= E_Subprogram_Type + and then Ekind (Nam) /= E_Entry_Family + then + return; + end if; + if Present (Actuals) and then (Needs_No_Actuals (Nam) *************** package body Sem_Ch4 is *** 2226,2248 **** (N, Nam, Designated_Type (Subp_Type), Must_Skip); -- The prefix can also be a parameterless function that returns an ! -- access to subprogram. in which case this is an indirect call. elsif Is_Access_Type (Subp_Type) and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type then ! Is_Indexed := Try_Indirect_Call (N, Nam, Subp_Type); end if; end if; ! Normalize_Actuals (N, Nam, (Report and not Is_Indexed), Norm_OK); if not Norm_OK then -- Mismatch in number or names of parameters ! if Debug_Flag_E then Write_Str (" normalization fails in call "); Write_Int (Int (N)); Write_Str (" with subprogram "); --- 2279,2321 ---- (N, Nam, Designated_Type (Subp_Type), Must_Skip); -- The prefix can also be a parameterless function that returns an ! -- access to subprogram, in which case this is an indirect call. ! -- If this succeeds, an explicit dereference is added later on, ! -- in Analyze_Call or Resolve_Call. elsif Is_Access_Type (Subp_Type) and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type then ! Is_Indirect := Try_Indirect_Call (N, Nam, Subp_Type); end if; end if; ! -- If the call has been transformed into a slice, it is of the form ! -- F (Subtype) where F is parameterless. The node has been rewritten in ! -- Try_Indexed_Call and there is nothing else to do. ! ! if Is_Indexed ! and then Nkind (N) = N_Slice ! then ! return; ! end if; ! ! Normalize_Actuals ! (N, Nam, (Report and not Is_Indexed and not Is_Indirect), Norm_OK); if not Norm_OK then + -- If an indirect call is a possible interpretation, indicate + -- success to the caller. + + if Is_Indirect then + Success := True; + return; + -- Mismatch in number or names of parameters ! elsif Debug_Flag_E then Write_Str (" normalization fails in call "); Write_Int (Int (N)); Write_Str (" with subprogram "); *************** package body Sem_Ch4 is *** 2368,2374 **** Write_Eol; end if; ! if Report and not Is_Indexed then -- Ada 2005 (AI-251): Complete the error notification -- to help new Ada 2005 users --- 2441,2447 ---- Write_Eol; end if; ! if Report and not Is_Indexed and not Is_Indirect then -- Ada 2005 (AI-251): Complete the error notification -- to help new Ada 2005 users *************** package body Sem_Ch4 is *** 2711,2717 **** procedure Check_Common_Type (T1, T2 : Entity_Id) is begin ! if Covers (T1, T2) or else Covers (T2, T1) then if T1 = Universal_Integer or else T1 = Universal_Real or else T1 = Any_Character --- 2784,2793 ---- procedure Check_Common_Type (T1, T2 : Entity_Id) is begin ! if Covers (T1 => T1, T2 => T2) ! or else ! Covers (T1 => T2, T2 => T1) ! then if T1 = Universal_Integer or else T1 = Universal_Real or else T1 = Any_Character *************** package body Sem_Ch4 is *** 2803,2814 **** procedure Analyze_Reference (N : Node_Id) is P : constant Node_Id := Prefix (N); Acc_Type : Entity_Id; begin Analyze (P); Acc_Type := Create_Itype (E_Allocator_Type, N); ! Set_Etype (Acc_Type, Acc_Type); ! Init_Size_Align (Acc_Type); Set_Directly_Designated_Type (Acc_Type, Etype (P)); Set_Etype (N, Acc_Type); end Analyze_Reference; --- 2879,2928 ---- procedure Analyze_Reference (N : Node_Id) is P : constant Node_Id := Prefix (N); + E : Entity_Id; + T : Entity_Id; Acc_Type : Entity_Id; + begin Analyze (P); + + -- An interesting error check, if we take the 'Reference of an object + -- for which a pragma Atomic or Volatile has been given, and the type + -- of the object is not Atomic or Volatile, then we are in trouble. The + -- problem is that no trace of the atomic/volatile status will remain + -- for the backend to respect when it deals with the resulting pointer, + -- since the pointer type will not be marked atomic (it is a pointer to + -- the base type of the object). + + -- It is not clear if that can ever occur, but in case it does, we will + -- generate an error message. Not clear if this message can ever be + -- generated, and pretty clear that it represents a bug if it is, still + -- seems worth checking! + + T := Etype (P); + + if Is_Entity_Name (P) + and then Is_Object_Reference (P) + then + E := Entity (P); + T := Etype (P); + + if (Has_Atomic_Components (E) + and then not Has_Atomic_Components (T)) + or else + (Has_Volatile_Components (E) + and then not Has_Volatile_Components (T)) + or else (Is_Atomic (E) and then not Is_Atomic (T)) + or else (Is_Volatile (E) and then not Is_Volatile (T)) + then + Error_Msg_N ("cannot take reference to Atomic/Volatile object", N); + end if; + end if; + + -- Carry on with normal processing + Acc_Type := Create_Itype (E_Allocator_Type, N); ! Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, Etype (P)); Set_Etype (N, Acc_Type); end Analyze_Reference; *************** package body Sem_Ch4 is *** 2840,2846 **** -- It is known that the parent of N denotes a subprogram call. Comp -- is an overloadable component of the concurrent type of the prefix. -- Determine whether all formals of the parent of N and Comp are mode ! -- conformant. ------------------------------ -- Has_Mode_Conformant_Spec -- --- 2954,2961 ---- -- It is known that the parent of N denotes a subprogram call. Comp -- is an overloadable component of the concurrent type of the prefix. -- Determine whether all formals of the parent of N and Comp are mode ! -- conformant. If the parent node is not analyzed yet it may be an ! -- indexed component rather than a function call. ------------------------------ -- Has_Mode_Conformant_Spec -- *************** package body Sem_Ch4 is *** 2853,2859 **** begin Comp_Param := First_Formal (Comp); ! Param := First (Parameter_Associations (Parent (N))); while Present (Comp_Param) and then Present (Param) loop --- 2968,2980 ---- begin Comp_Param := First_Formal (Comp); ! ! if Nkind (Parent (N)) = N_Indexed_Component then ! Param := First (Expressions (Parent (N))); ! else ! Param := First (Parameter_Associations (Parent (N))); ! end if; ! while Present (Comp_Param) and then Present (Param) loop *************** package body Sem_Ch4 is *** 2903,2916 **** -- A RACW object can never be used as prefix of a selected -- component since that means it is dereferenced without -- being a controlling operand of a dispatching operation ! -- (RM E.2.2(15)). if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type) and then Comes_From_Source (N) then ! Error_Msg_N ! ("invalid dereference of a remote access to class-wide value", ! N); -- Normal case of selected component applied to access type --- 3024,3042 ---- -- A RACW object can never be used as prefix of a selected -- component since that means it is dereferenced without -- being a controlling operand of a dispatching operation ! -- (RM E.2.2(16/1)). Before reporting an error, we must check ! -- whether this is actually a dispatching call in prefix form. if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type) and then Comes_From_Source (N) then ! if Try_Object_Operation (N) then ! return; ! else ! Error_Msg_N ! ("invalid dereference of a remote access-to-class-wide value", ! N); ! end if; -- Normal case of selected component applied to access type *************** package body Sem_Ch4 is *** 2927,2932 **** --- 3053,3079 ---- Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name); end if; + + -- If we have an explicit dereference of a remote access-to-class-wide + -- value, then issue an error (see RM-E.2.2(16/1)). However we first + -- have to check for the case of a prefix that is a controlling operand + -- of a prefixed dispatching call, as the dereference is legal in that + -- case. Normally this condition is checked in Validate_Remote_Access_ + -- To_Class_Wide_Type, but we have to defer the checking for selected + -- component prefixes because of the prefixed dispatching call case. + -- Note that implicit dereferences are checked for this just above. + + elsif Nkind (Name) = N_Explicit_Dereference + and then Is_Remote_Access_To_Class_Wide_Type (Etype (Prefix (Name))) + and then Comes_From_Source (N) + then + if Try_Object_Operation (N) then + return; + else + Error_Msg_N + ("invalid dereference of a remote access-to-class-wide value", + N); + end if; end if; -- (Ada 2005): if the prefix is the limited view of a type, and *************** package body Sem_Ch4 is *** 3134,3140 **** -- If the prefix is a private extension, check only the visible -- components of the partial view. This must include the tag, ! -- wich can appear in expanded code in a tag check. if Ekind (Type_To_Use) = E_Record_Type_With_Private and then Chars (Selector_Name (N)) /= Name_uTag --- 3281,3287 ---- -- If the prefix is a private extension, check only the visible -- components of the partial view. This must include the tag, ! -- which can appear in expanded code in a tag check. if Ekind (Type_To_Use) = E_Record_Type_With_Private and then Chars (Selector_Name (N)) /= Name_uTag *************** package body Sem_Ch4 is *** 3201,3207 **** Set_Original_Discriminant (Sel, Comp); end if; ! -- Before declararing an error, check whether this is tagged -- private type and a call to a primitive operation. elsif Ada_Version >= Ada_05 --- 3348,3354 ---- Set_Original_Discriminant (Sel, Comp); end if; ! -- Before declaring an error, check whether this is tagged -- private type and a call to a primitive operation. elsif Ada_Version >= Ada_05 *************** package body Sem_Ch4 is *** 3251,3257 **** if Is_Tagged_Type (Prefix_Type) and then Nkind_In (Parent (N), N_Procedure_Call_Statement, ! N_Function_Call) and then Has_Mode_Conformant_Spec (Comp) then Has_Candidate := True; --- 3398,3405 ---- if Is_Tagged_Type (Prefix_Type) and then Nkind_In (Parent (N), N_Procedure_Call_Statement, ! N_Function_Call, ! N_Indexed_Component) and then Has_Mode_Conformant_Spec (Comp) then Has_Candidate := True; *************** package body Sem_Ch4 is *** 3317,3322 **** --- 3465,3471 ---- -- the controlling formal is implicit ??? elsif Nkind (Parent (N)) /= N_Procedure_Call_Statement + and then Nkind (Parent (N)) /= N_Indexed_Component and then Try_Object_Operation (N) then return; *************** package body Sem_Ch4 is *** 3430,3436 **** Error_Msg_NE ("no selector& for}", N, Sel); Check_Misspelled_Selector (Type_To_Use, Sel); - end if; Set_Entity (Sel, Any_Id); --- 3579,3584 ---- *************** package body Sem_Ch4 is *** 3811,3816 **** --- 3959,3968 ---- -- predefined operator. Used to implement Ada 2005 AI-264, to make -- such operators more visible and therefore useful. + -- If the name of the operation is an expanded name with prefix + -- Standard, the predefined universal fixed operator is available, + -- as specified by AI-420 (RM 4.5.5 (19.1/2)). + function Specific_Type (T1, T2 : Entity_Id) return Entity_Id; -- Get specific type (i.e. non-universal type if there is one) *************** package body Sem_Ch4 is *** 3825,3830 **** --- 3977,3992 ---- F2 : Entity_Id; begin + -- If the universal_fixed operation is given explicitly the rule + -- concerning primitive operations of the type do not apply. + + if Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Expanded_Name + and then Entity (Prefix (Name (N))) = Standard_Standard + then + return False; + end if; + -- The operation is treated as primitive if it is declared in the -- same scope as the type, and therefore on the same entity chain. *************** package body Sem_Ch4 is *** 3880,3886 **** if Is_Numeric_Type (T1) and then Is_Numeric_Type (T2) ! and then (Covers (T1, T2) or else Covers (T2, T1)) then Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); end if; --- 4042,4050 ---- if Is_Numeric_Type (T1) and then Is_Numeric_Type (T2) ! and then (Covers (T1 => T1, T2 => T2) ! or else ! Covers (T1 => T2, T2 => T1)) then Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); end if; *************** package body Sem_Ch4 is *** 3919,3925 **** elsif Is_Numeric_Type (T1) and then Is_Numeric_Type (T2) ! and then (Covers (T1, T2) or else Covers (T2, T1)) then Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); --- 4083,4091 ---- elsif Is_Numeric_Type (T1) and then Is_Numeric_Type (T2) ! and then (Covers (T1 => T1, T2 => T2) ! or else ! Covers (T1 => T2, T2 => T1)) then Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); *************** package body Sem_Ch4 is *** 3964,3970 **** -- already set (case of operation constructed by Exp_Fixed). if Is_Integer_Type (T1) ! and then (Covers (T1, T2) or else Covers (T2, T1)) then Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); end if; --- 4130,4138 ---- -- already set (case of operation constructed by Exp_Fixed). if Is_Integer_Type (T1) ! and then (Covers (T1 => T1, T2 => T2) ! or else ! Covers (T1 => T2, T2 => T1)) then Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); end if; *************** package body Sem_Ch4 is *** 4395,4401 **** if Nkind (L) = N_Aggregate and then Nkind (R) /= N_Aggregate then ! Find_Comparison_Types (R, L, Op_Id, N); return; end if; --- 4563,4569 ---- if Nkind (L) = N_Aggregate and then Nkind (R) /= N_Aggregate then ! Find_Comparison_Types (L => R, R => L, Op_Id => Op_Id, N => N); return; end if; *************** package body Sem_Ch4 is *** 4613,4619 **** if Nkind (L) = N_Aggregate and then Nkind (R) /= N_Aggregate then ! Find_Equality_Types (R, L, Op_Id, N); return; end if; --- 4781,4787 ---- if Nkind (L) = N_Aggregate and then Nkind (R) /= N_Aggregate then ! Find_Equality_Types (L => R, R => L, Op_Id => Op_Id, N => N); return; end if; *************** package body Sem_Ch4 is *** 5257,5264 **** -- is never appropriate, even when Address is defined as a visible -- Integer type. The reason is that we would really prefer Address -- to behave as a private type, even in this case, which is there ! -- only to accomodate oddities of VMS address sizes. If Address is ! -- a visible integer type, we get lots of overload ambiguities. if Nkind (N) in N_Binary_Op then declare --- 5425,5432 ---- -- is never appropriate, even when Address is defined as a visible -- Integer type. The reason is that we would really prefer Address -- to behave as a private type, even in this case, which is there ! -- only to accommodate oddities of VMS address sizes. If Address ! -- is a visible integer type, we get lots of overload ambiguities. if Nkind (N) in N_Binary_Op then declare *************** package body Sem_Ch4 is *** 5452,5460 **** Typ : Entity_Id; Skip_First : Boolean) return Boolean is ! Actuals : constant List_Id := Parameter_Associations (N); ! Actual : Node_Id; ! Index : Entity_Id; begin Actual := First (Actuals); --- 5620,5629 ---- Typ : Entity_Id; Skip_First : Boolean) return Boolean is ! Loc : constant Source_Ptr := Sloc (N); ! Actuals : constant List_Id := Parameter_Associations (N); ! Actual : Node_Id; ! Index : Entity_Id; begin Actual := First (Actuals); *************** package body Sem_Ch4 is *** 5476,5482 **** return False; end if; ! if not Has_Compatible_Type (Actual, Etype (Index)) then return False; end if; --- 5645,5665 ---- return False; end if; ! if Is_Entity_Name (Actual) ! and then Is_Type (Entity (Actual)) ! and then No (Next (Actual)) ! then ! Rewrite (N, ! Make_Slice (Loc, ! Prefix => Make_Function_Call (Loc, ! Name => Relocate_Node (Name (N))), ! Discrete_Range => ! New_Occurrence_Of (Entity (Actual), Sloc (Actual)))); ! ! Analyze (N); ! return True; ! ! elsif not Has_Compatible_Type (Actual, Etype (Index)) then return False; end if; *************** package body Sem_Ch4 is *** 5634,5641 **** (Call_Node : Node_Id; Node_To_Replace : Node_Id) is ! Formal_Type : constant Entity_Id := ! Etype (First_Formal (Entity (Subprog))); First_Actual : Node_Id; begin --- 5817,5824 ---- (Call_Node : Node_Id; Node_To_Replace : Node_Id) is ! Control : constant Entity_Id := First_Formal (Entity (Subprog)); ! Formal_Type : constant Entity_Id := Etype (Control); First_Actual : Node_Id; begin *************** package body Sem_Ch4 is *** 5697,5702 **** --- 5880,5898 ---- elsif Is_Access_Type (Formal_Type) and then not Is_Access_Type (Etype (Obj)) then + -- A special case: A.all'access is illegal if A is an access to a + -- constant and the context requires an access to a variable. + + if not Is_Access_Constant (Formal_Type) then + if (Nkind (Obj) = N_Explicit_Dereference + and then Is_Access_Constant (Etype (Prefix (Obj)))) + or else not Is_Variable (Obj) + then + Error_Msg_NE + ("actual for& must be a variable", Obj, Control); + end if; + end if; + Rewrite (First_Actual, Make_Attribute_Reference (Loc, Attribute_Name => Name_Access, *************** package body Sem_Ch4 is *** 6238,6246 **** ----------------------------- function Valid_First_Argument_Of (Op : Entity_Id) return Boolean is ! Typ : constant Entity_Id := Etype (First_Formal (Op)); begin -- Simple case. Object may be a subtype of the tagged type or -- may be the corresponding record of a synchronized type. --- 6434,6448 ---- ----------------------------- function Valid_First_Argument_Of (Op : Entity_Id) return Boolean is ! Typ : Entity_Id := Etype (First_Formal (Op)); begin + if Is_Concurrent_Type (Typ) + and then Present (Corresponding_Record_Type (Typ)) + then + Typ := Corresponding_Record_Type (Typ); + end if; + -- Simple case. Object may be a subtype of the tagged type or -- may be the corresponding record of a synchronized type. *************** package body Sem_Ch4 is *** 6269,6278 **** -- must be identical, and the kind of call indicates the expected -- kind of operation (function or procedure). If the type is a -- (tagged) synchronized type, the primitive ops are attached to the ! -- corresponding record type. if Is_Concurrent_Type (Obj_Type) then ! Corr_Type := Corresponding_Record_Type (Obj_Type); Elmt := First_Elmt (Primitive_Operations (Corr_Type)); elsif not Is_Generic_Type (Obj_Type) then --- 6471,6484 ---- -- must be identical, and the kind of call indicates the expected -- kind of operation (function or procedure). If the type is a -- (tagged) synchronized type, the primitive ops are attached to the ! -- corresponding record (base) type. if Is_Concurrent_Type (Obj_Type) then ! if not Present (Corresponding_Record_Type (Obj_Type)) then ! return False; ! end if; ! ! Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); Elmt := First_Elmt (Primitive_Operations (Corr_Type)); elsif not Is_Generic_Type (Obj_Type) then *************** package body Sem_Ch4 is *** 6300,6313 **** -- primitive is also in this list of primitive operations and -- will be used instead. ! if (Present (Abstract_Interface_Alias (Prim_Op)) ! and then Is_Ancestor (Find_Dispatching_Type ! (Alias (Prim_Op)), Corr_Type)) or else ! -- Do not consider hidden primitives unless the type is in an ! -- open scope or we are within an instance, where visibility ! -- is known to be correct. (Is_Hidden (Prim_Op) and then not Is_Immediately_Visible (Obj_Type) --- 6506,6519 ---- -- primitive is also in this list of primitive operations and -- will be used instead. ! if (Present (Interface_Alias (Prim_Op)) ! and then Is_Ancestor (Find_Dispatching_Type ! (Alias (Prim_Op)), Corr_Type)) or else ! -- Do not consider hidden primitives unless the type is ! -- in an open scope or we are within an instance, where ! -- visibility is known to be correct. (Is_Hidden (Prim_Op) and then not Is_Immediately_Visible (Obj_Type) *************** package body Sem_Ch4 is *** 6461,6464 **** --- 6667,6696 ---- end if; end Try_Object_Operation; + --------- + -- wpo -- + --------- + + procedure wpo (T : Entity_Id) is + Op : Entity_Id; + E : Elmt_Id; + + begin + if not Is_Tagged_Type (T) then + return; + end if; + + E := First_Elmt (Primitive_Operations (Base_Type (T))); + while Present (E) loop + Op := Node (E); + Write_Int (Int (Op)); + Write_Str (" === "); + Write_Name (Chars (Op)); + Write_Str (" in "); + Write_Name (Chars (Scope (Op))); + Next_Elmt (E); + Write_Eol; + end loop; + end wpo; + end Sem_Ch4; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch5.adb gcc-4.4.0/gcc/ada/sem_ch5.adb *** gcc-4.3.3/gcc/ada/sem_ch5.adb Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/sem_ch5.adb Fri Aug 22 13:26:19 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Sem_Ch5 is *** 118,148 **** -- Some special bad cases of entity names elsif Is_Entity_Name (N) then ! if Ekind (Entity (N)) = E_In_Parameter then ! Error_Msg_N ! ("assignment to IN mode parameter not allowed", N); ! -- Private declarations in a protected object are turned into ! -- constants when compiling a protected function. ! elsif Present (Scope (Entity (N))) ! and then Is_Protected_Type (Scope (Entity (N))) ! and then ! (Ekind (Current_Scope) = E_Function ! or else ! Ekind (Enclosing_Dynamic_Scope (Current_Scope)) = E_Function) ! then ! Error_Msg_N ! ("protected function cannot modify protected object", N); ! elsif Ekind (Entity (N)) = E_Loop_Parameter then ! Error_Msg_N ! ("assignment to loop parameter not allowed", N); ! else ! Error_Msg_N ! ("left hand side of assignment must be a variable", N); ! end if; -- For indexed components or selected components, test prefix --- 118,157 ---- -- Some special bad cases of entity names elsif Is_Entity_Name (N) then ! declare ! Ent : constant Entity_Id := Entity (N); ! begin ! if Ekind (Ent) = E_In_Parameter then ! Error_Msg_N ! ("assignment to IN mode parameter not allowed", N); ! -- Renamings of protected private components are turned into ! -- constants when compiling a protected function. In the case ! -- of single protected types, the private component appears ! -- directly. ! elsif (Is_Prival (Ent) ! and then ! (Ekind (Current_Scope) = E_Function ! or else Ekind (Enclosing_Dynamic_Scope ( ! Current_Scope)) = E_Function)) ! or else ! (Ekind (Ent) = E_Component ! and then Is_Protected_Type (Scope (Ent))) ! then ! Error_Msg_N ! ("protected function cannot modify protected object", N); ! elsif Ekind (Ent) = E_Loop_Parameter then ! Error_Msg_N ! ("assignment to loop parameter not allowed", N); ! ! else ! Error_Msg_N ! ("left hand side of assignment must be a variable", N); ! end if; ! end; -- For indexed components or selected components, test prefix *************** package body Sem_Ch5 is *** 430,435 **** --- 439,453 ---- ("left hand of assignment must not be limited type", Lhs); Explain_Limited_Type (T1, Lhs); return; + + -- Enforce RM 3.9.3 (8): left-hand side cannot be abstract + + elsif Is_Interface (T1) + and then not Is_Class_Wide_Type (T1) + then + Error_Msg_N + ("target of assignment operation may not be abstract", Lhs); + return; end if; -- Resolution may have updated the subtype, in case the left-hand *************** package body Sem_Ch5 is *** 469,474 **** --- 487,493 ---- -- This is the point at which we check for an unset reference Check_Unset_Reference (Rhs); + Check_Unprotected_Access (Lhs, Rhs); -- Remaining steps are skipped if Rhs was syntactically in error *************** package body Sem_Ch5 is *** 560,574 **** end if; end if; ! -- Ada 2005 (AI-230 and AI-385): When the lhs type is an anonymous ! -- access type, apply an implicit conversion of the rhs to that type ! -- to force appropriate static and run-time accessibility checks. if Ada_Version >= Ada_05 ! and then Ekind (T1) = E_Anonymous_Access_Type then ! Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); ! Analyze_And_Resolve (Rhs, T1); end if; -- Ada 2005 (AI-231): Assignment to not null variable --- 579,599 ---- end if; end if; ! -- Ada 2005 (AI-385): When the lhs type is an anonymous access type, ! -- apply an implicit conversion of the rhs to that type to force ! -- appropriate static and run-time accessibility checks. This applies ! -- as well to anonymous access-to-subprogram types that are component ! -- subtypes or formal parameters. if Ada_Version >= Ada_05 ! and then Is_Access_Type (T1) then ! if Is_Local_Anonymous_Access (T1) ! or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type ! then ! Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); ! Analyze_And_Resolve (Rhs, T1); ! end if; end if; -- Ada 2005 (AI-231): Assignment to not null variable *************** package body Sem_Ch5 is *** 588,594 **** -- We still mark this as a possible modification, that's necessary -- to reset Is_True_Constant, and desirable for xref purposes. ! Note_Possible_Modification (Lhs); return; -- If we know the right hand side is non-null, then we convert to the --- 613,619 ---- -- We still mark this as a possible modification, that's necessary -- to reset Is_True_Constant, and desirable for xref purposes. ! Note_Possible_Modification (Lhs, Sure => True); return; -- If we know the right hand side is non-null, then we convert to the *************** package body Sem_Ch5 is *** 635,641 **** -- Note: modifications of the Lhs may only be recorded after -- checks have been applied. ! Note_Possible_Modification (Lhs); -- ??? a real accessibility check is needed when ??? --- 660,666 ---- -- Note: modifications of the Lhs may only be recorded after -- checks have been applied. ! Note_Possible_Modification (Lhs, Sure => True); -- ??? a real accessibility check is needed when ??? *************** package body Sem_Ch5 is *** 799,805 **** begin -- Initialize unblocked exit count for statements of begin block ! -- plus one for each excption handler that is present. Unblocked_Exit_Count := 1; --- 824,830 ---- begin -- Initialize unblocked exit count for statements of begin block ! -- plus one for each exception handler that is present. Unblocked_Exit_Count := 1; *************** package body Sem_Ch5 is *** 851,856 **** --- 876,882 ---- if Present (Decls) then Analyze_Declarations (Decls); Check_Completion; + Inspect_Deferred_Constant_Completion (Decls); end if; Analyze (HSS); *************** package body Sem_Ch5 is *** 911,917 **** procedure Non_Static_Choice_Error (Choice : Node_Id); -- Error routine invoked by the generic instantiation below when ! -- the case statment has a non static choice. procedure Process_Statements (Alternative : Node_Id); -- Analyzes all the statements associated to a case alternative. --- 937,943 ---- procedure Non_Static_Choice_Error (Choice : Node_Id); -- Error routine invoked by the generic instantiation below when ! -- the case statement has a non static choice. procedure Process_Statements (Alternative : Node_Id); -- Analyzes all the statements associated to a case alternative. *************** package body Sem_Ch5 is *** 1439,1448 **** function One_Bound (Original_Bound : Node_Id; Analyzed_Bound : Node_Id) return Node_Id; ! -- Create one declaration followed by one assignment statement ! -- to capture the value of bound. We create a separate assignment ! -- in order to force the creation of a block in case the bound ! -- contains a call that uses the secondary stack. --------------- -- One_Bound -- --- 1465,1471 ---- function One_Bound (Original_Bound : Node_Id; Analyzed_Bound : Node_Id) return Node_Id; ! -- Capture value of bound and return captured value --------------- -- One_Bound -- *************** package body Sem_Ch5 is *** 1473,1487 **** then Analyze_And_Resolve (Original_Bound, Typ); return Original_Bound; - - else - Analyze_And_Resolve (Original_Bound, Typ); end if; Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); Decl := Make_Object_Declaration (Loc, Defining_Identifier => Id, --- 1496,1548 ---- then Analyze_And_Resolve (Original_Bound, Typ); return Original_Bound; end if; + -- Here we need to capture the value + + Analyze_And_Resolve (Original_Bound, Typ); + Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); + -- Normally, the best approach is simply to generate a constant + -- declaration that captures the bound. However, there is a nasty + -- case where this is wrong. If the bound is complex, and has a + -- possible use of the secondary stack, we need to generate a + -- separate assignment statement to ensure the creation of a block + -- which will release the secondary stack. + + -- We prefer the constant declaration, since it leaves us with a + -- proper trace of the value, useful in optimizations that get rid + -- of junk range checks. + + -- Probably we want something like the Side_Effect_Free routine + -- in Exp_Util, but for now, we just optimize the cases of 'Last + -- and 'First applied to an entity, since these are the important + -- cases for range check optimizations. + + if Nkind (Original_Bound) = N_Attribute_Reference + and then (Attribute_Name (Original_Bound) = Name_First + or else + Attribute_Name (Original_Bound) = Name_Last) + and then Is_Entity_Name (Prefix (Original_Bound)) + then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Original_Bound)); + + Insert_Before (Parent (N), Decl); + Analyze (Decl); + Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); + return Expression (Decl); + end if; + + -- Here we make a declaration with a separate assignment statement + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Id, *************** package body Sem_Ch5 is *** 1901,1920 **** Analyze (Id); Ent := Entity (Id); - Generate_Reference (Ent, Loop_Statement, ' '); - Generate_Definition (Ent); ! -- If we found a label, mark its type. If not, ignore it, since it ! -- means we have a conflicting declaration, which would already have ! -- been diagnosed at declaration time. Set Label_Construct of the ! -- implicit label declaration, which is not created by the parser ! -- for generic units. ! if Ekind (Ent) = E_Label then ! Set_Ekind (Ent, E_Loop); ! if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then ! Set_Label_Construct (Parent (Ent), Loop_Statement); end if; end if; --- 1962,1997 ---- Analyze (Id); Ent := Entity (Id); ! -- Guard against serious error (typically, a scope mismatch when ! -- semantic analysis is requested) by creating loop entity to ! -- continue analysis. ! if No (Ent) then ! if Total_Errors_Detected /= 0 then ! Ent := ! New_Internal_Entity ! (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L'); ! else ! raise Program_Error; ! end if; ! else ! Generate_Reference (Ent, Loop_Statement, ' '); ! Generate_Definition (Ent); ! ! -- If we found a label, mark its type. If not, ignore it, since it ! -- means we have a conflicting declaration, which would already ! -- have been diagnosed at declaration time. Set Label_Construct ! -- of the implicit label declaration, which is not created by the ! -- parser for generic units. ! ! if Ekind (Ent) = E_Label then ! Set_Ekind (Ent, E_Loop); ! ! if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then ! Set_Label_Construct (Parent (Ent), Loop_Statement); ! end if; end if; end if; *************** package body Sem_Ch5 is *** 1928,1937 **** Set_Parent (Ent, Loop_Statement); end if; ! -- Kill current values on entry to loop, since statements in body ! -- of loop may have been executed before the loop is entered. ! -- Similarly we kill values after the loop, since we do not know ! -- that the body of the loop was executed. Kill_Current_Values; Push_Scope (Ent); --- 2005,2014 ---- Set_Parent (Ent, Loop_Statement); end if; ! -- Kill current values on entry to loop, since statements in body of ! -- loop may have been executed before the loop is entered. Similarly we ! -- kill values after the loop, since we do not know that the body of the ! -- loop was executed. Kill_Current_Values; Push_Scope (Ent); *************** package body Sem_Ch5 is *** 1941,1946 **** --- 2018,2030 ---- End_Scope; Kill_Current_Values; Check_Infinite_Loop_Warning (N); + + -- Code after loop is unreachable if the loop has no WHILE or FOR + -- and contains no EXIT statements within the body of the loop. + + if No (Iter) and then not Has_Exit (Ent) then + Check_Unreachable_Code (N); + end if; end Analyze_Loop_Statement; ---------------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch5.ads gcc-4.4.0/gcc/ada/sem_ch5.ads *** gcc-4.3.3/gcc/ada/sem_ch5.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_ch5.ads Tue Apr 8 06:50:04 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Sem_Ch5 is *** 47,55 **** -- be assumed to be reachable. procedure Check_Unreachable_Code (N : Node_Id); ! -- This procedure is called with N being the node for a statement that ! -- is an unconditional transfer of control. It checks to see if the ! -- statement is followed by some other statement, and if so generates ! -- an appropriate warning for unreachable code. end Sem_Ch5; --- 47,55 ---- -- be assumed to be reachable. procedure Check_Unreachable_Code (N : Node_Id); ! -- This procedure is called with N being the node for a statement that is ! -- an unconditional transfer of control or an apparent infinite loop. It ! -- checks to see if the statement is followed by some other statement, and ! -- if so generates an appropriate warning for unreachable code. end Sem_Ch5; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch6.adb gcc-4.4.0/gcc/ada/sem_ch6.adb *** gcc-4.3.3/gcc/ada/sem_ch6.adb Wed Dec 19 16:24:34 2007 --- gcc-4.4.0/gcc/ada/sem_ch6.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Errout; use Errout; *** 32,37 **** --- 32,39 ---- with Expander; use Expander; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; + with Exp_Ch9; use Exp_Ch9; + with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; *************** package body Sem_Ch6 is *** 111,117 **** procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id); -- If a subprogram has pragma Inline and inlining is active, use generic -- machinery to build an unexpanded body for the subprogram. This body is ! -- subsequenty used for inline expansions at call sites. If subprogram can -- be inlined (depending on size and nature of local declarations) this -- function returns true. Otherwise subprogram body is treated normally. -- If proper warnings are enabled and the subprogram contains a construct --- 113,119 ---- procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id); -- If a subprogram has pragma Inline and inlining is active, use generic -- machinery to build an unexpanded body for the subprogram. This body is ! -- subsequently used for inline expansions at call sites. If subprogram can -- be inlined (depending on size and nature of local declarations) this -- function returns true. Otherwise subprogram body is treated normally. -- If proper warnings are enabled and the subprogram contains a construct *************** package body Sem_Ch6 is *** 138,153 **** -- against a formal access-to-subprogram type so Get_Instance_Of must -- be called. - procedure Check_Overriding_Indicator - (Subp : Entity_Id; - Overridden_Subp : Entity_Id; - Is_Primitive : Boolean); - -- Verify the consistency of an overriding_indicator given for subprogram - -- declaration, body, renaming, or instantiation. Overridden_Subp is set - -- if the scope where we are introducing the subprogram contains a - -- type-conformant subprogram that becomes hidden by the new subprogram. - -- Is_Primitive indicates whether the subprogram is primitive. - procedure Check_Subprogram_Order (N : Node_Id); -- N is the N_Subprogram_Body node for a subprogram. This routine applies -- the alpha ordering rule for N if this ordering requirement applicable. --- 140,145 ---- *************** package body Sem_Ch6 is *** 174,184 **** procedure Install_Entity (E : Entity_Id); -- Make single entity visible. Used for generic formals as well - procedure Install_Formals (Id : Entity_Id); - -- On entry to a subprogram body, make the formals visible. Note that - -- simply placing the subprogram on the scope stack is not sufficient: - -- the formals must become the current entities for their names. - function Is_Non_Overriding_Operation (Prev_E : Entity_Id; New_E : Entity_Id) return Boolean; --- 166,171 ---- *************** package body Sem_Ch6 is *** 196,201 **** --- 183,198 ---- -- Flag functions that can be called without parameters, i.e. those that -- have no parameters, or those for which defaults exist for all parameters + procedure Process_PPCs + (N : Node_Id; + Spec_Id : Entity_Id; + Body_Id : Entity_Id); + -- Called from Analyze_Body to deal with scanning post conditions for the + -- body and assembling and inserting the _postconditions procedure. N is + -- the node for the subprogram body and Body_Id/Spec_Id are the entities + -- for the body and separate spec (if there is no separate spec, Spec_Id + -- is Empty). + procedure Set_Formal_Validity (Formal_Id : Entity_Id); -- Formal_Id is an formal parameter entity. This procedure deals with -- setting the proper validity status for this entity, which depends *************** package body Sem_Ch6 is *** 545,560 **** -- "return access T" case; check that the return statement also has -- "access T", and that the subtypes statically match: if R_Type_Is_Anon_Access then if R_Stm_Type_Is_Anon_Access then ! if Base_Type (Designated_Type (R_Stm_Type)) /= ! Base_Type (Designated_Type (R_Type)) ! or else not Subtypes_Statically_Match (R_Stm_Type, R_Type) then ! Error_Msg_N ! ("subtype must statically match function result subtype", ! Subtype_Mark (Subtype_Ind)); end if; else --- 542,574 ---- -- "return access T" case; check that the return statement also has -- "access T", and that the subtypes statically match: + -- if this is an access to subprogram the signatures must match. if R_Type_Is_Anon_Access then if R_Stm_Type_Is_Anon_Access then ! if ! Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type then ! if Base_Type (Designated_Type (R_Stm_Type)) /= ! Base_Type (Designated_Type (R_Type)) ! or else not Subtypes_Statically_Match (R_Stm_Type, R_Type) ! then ! Error_Msg_N ! ("subtype must statically match function result subtype", ! Subtype_Mark (Subtype_Ind)); ! end if; ! ! else ! -- For two anonymous access to subprogram types, the ! -- types themselves must be type conformant. ! ! if not Conforming_Types ! (R_Stm_Type, R_Type, Fully_Conformant) ! then ! Error_Msg_N ! ("subtype must statically match function result subtype", ! Subtype_Ind); ! end if; end if; else *************** package body Sem_Ch6 is *** 562,570 **** end if; -- Subtype_indication case; check that the types are the same, and ! -- statically match if appropriate: elsif Base_Type (R_Stm_Type) = Base_Type (R_Type) then if Is_Constrained (R_Type) then if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then Error_Msg_N --- 576,597 ---- end if; -- Subtype_indication case; check that the types are the same, and ! -- statically match if appropriate. A null exclusion may be present ! -- on the return type, on the function specification, on the object ! -- declaration or on the subtype itself. elsif Base_Type (R_Stm_Type) = Base_Type (R_Type) then + if Is_Access_Type (R_Type) + and then + (Can_Never_Be_Null (R_Type) + or else Null_Exclusion_Present (Parent (Scope_Id))) /= + Can_Never_Be_Null (R_Stm_Type) + then + Error_Msg_N + ("subtype must statically match function result subtype", + Subtype_Ind); + end if; + if Is_Constrained (R_Type) then if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then Error_Msg_N *************** package body Sem_Ch6 is *** 579,595 **** -- definition matches the class-wide type. This prevents rejection -- in the case where the object declaration is initialized by a call -- to a build-in-place function with a specific result type and the ! -- object entity had its type changed to that specific type. (Note ! -- that the ARG believes that return objects should be allowed to ! -- have a type covered by a class-wide result type in any case, so ! -- once that relaxation is made (see AI05-32), the above check for ! -- type compatibility should be changed to test Covers rather than ! -- equality, and then the following special test will no longer be ! -- needed. ???) elsif Is_Class_Wide_Type (R_Type) and then ! R_Type = Etype (Object_Definition (Original_Node (Obj_Decl))) then null; --- 606,627 ---- -- definition matches the class-wide type. This prevents rejection -- in the case where the object declaration is initialized by a call -- to a build-in-place function with a specific result type and the ! -- object entity had its type changed to that specific type. This is ! -- also allowed in the case where Obj_Decl does not come from source, ! -- which can occur for an expansion of a simple return statement of ! -- a build-in-place class-wide function when the result expression ! -- has a specific type, because a return object with a specific type ! -- is created. (Note that the ARG believes that return objects should ! -- be allowed to have a type covered by a class-wide result type in ! -- any case, so once that relaxation is made (see AI05-32), the above ! -- check for type compatibility should be changed to test Covers ! -- rather than equality, and the following special test will no ! -- longer be needed. ???) elsif Is_Class_Wide_Type (R_Type) and then ! (R_Type = Etype (Object_Definition (Original_Node (Obj_Decl))) ! or else not Comes_From_Source (Obj_Decl)) then null; *************** package body Sem_Ch6 is *** 631,639 **** -- Analyze_Object_Declaration; we treat it as a normal -- object declaration. Analyze (Obj_Decl); - Set_Is_Return_Object (Defining_Identifier (Obj_Decl)); Check_Return_Subtype_Indication (Obj_Decl); if Present (HSS) then --- 663,671 ---- -- Analyze_Object_Declaration; we treat it as a normal -- object declaration. + Set_Is_Return_Object (Defining_Identifier (Obj_Decl)); Analyze (Obj_Decl); Check_Return_Subtype_Indication (Obj_Decl); if Present (HSS) then *************** package body Sem_Ch6 is *** 653,666 **** end; end if; ! -- Case of Expr present (Etype check defends against previous errors) if Present (Expr) and then Present (Etype (Expr)) then -- Apply constraint check. Note that this is done before the implicit -- conversion of the expression done for anonymous access types to ! -- ensure correct generation of the null-excluding check asssociated -- with null-excluding expressions found in return statements. Apply_Constraint_Check (Expr, R_Type); --- 685,702 ---- end; end if; ! -- Case of Expr present if Present (Expr) + + -- Defend against previous errors + + and then Nkind (Expr) /= N_Empty and then Present (Etype (Expr)) then -- Apply constraint check. Note that this is done before the implicit -- conversion of the expression done for anonymous access types to ! -- ensure correct generation of the null-excluding check associated -- with null-excluding expressions found in return statements. Apply_Constraint_Check (Expr, R_Type); *************** package body Sem_Ch6 is *** 676,681 **** --- 712,733 ---- Analyze_And_Resolve (Expr, R_Type); end if; + -- If the result type is class-wide, then check that the return + -- expression's type is not declared at a deeper level than the + -- function (RM05-6.5(5.6/2)). + + if Ada_Version >= Ada_05 + and then Is_Class_Wide_Type (R_Type) + then + if Type_Access_Level (Etype (Expr)) > + Subprogram_Access_Level (Scope_Id) + then + Error_Msg_N + ("level of return expression type is deeper than " & + "class-wide function!", Expr); + end if; + end if; + if (Is_Class_Wide_Type (Etype (Expr)) or else Is_Dynamically_Tagged (Expr)) and then not Is_Class_Wide_Type (R_Type) *************** package body Sem_Ch6 is *** 861,866 **** --- 913,949 ---- end if; Set_Actual_Subtypes (N, Current_Scope); + Process_PPCs (N, Gen_Id, Body_Id); + + -- If the generic unit carries pre- or post-conditions, copy them + -- to the original generic tree, so that they are properly added + -- to any instantiation. + + declare + Orig : constant Node_Id := Original_Node (N); + Cond : Node_Id; + + begin + Cond := First (Declarations (N)); + while Present (Cond) loop + if Nkind (Cond) = N_Pragma + and then Pragma_Name (Cond) = Name_Check + then + Prepend (New_Copy_Tree (Cond), Declarations (Orig)); + + elsif Nkind (Cond) = N_Pragma + and then Pragma_Name (Cond) = Name_Postcondition + then + Set_Ekind (Defining_Entity (Orig), Ekind (Gen_Id)); + Prepend (New_Copy_Tree (Cond), Declarations (Orig)); + else + exit; + end if; + + Next (Cond); + end loop; + end; + Analyze_Declarations (Declarations (N)); Check_Completion; Analyze (Handled_Statement_Sequence (N)); *************** package body Sem_Ch6 is *** 969,975 **** -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote -- a procedure call or an entry call. The prefix may denote an access -- to subprogram type, in which case an implicit dereference applies. ! -- If the prefix is an indexed component (without implicit defererence) -- then the construct denotes a call to a member of an entire family. -- If the prefix is a simple name, it may still denote a call to a -- parameterless member of an entry family. Resolution of these various --- 1052,1058 ---- -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote -- a procedure call or an entry call. The prefix may denote an access -- to subprogram type, in which case an implicit dereference applies. ! -- If the prefix is an indexed component (without implicit dereference) -- then the construct denotes a call to a member of an entire family. -- If the prefix is a simple name, it may still denote a call to a -- parameterless member of an entry family. Resolution of these various *************** package body Sem_Ch6 is *** 1179,1185 **** if Result_Definition (N) /= Error then if Nkind (Result_Definition (N)) = N_Access_Definition then ! Typ := Access_Definition (N, Result_Definition (N)); Set_Parent (Typ, Result_Definition (N)); Set_Is_Local_Anonymous_Access (Typ); Set_Etype (Designator, Typ); --- 1262,1281 ---- if Result_Definition (N) /= Error then if Nkind (Result_Definition (N)) = N_Access_Definition then ! ! -- Ada 2005 (AI-254): Handle anonymous access to subprograms ! ! declare ! AD : constant Node_Id := ! Access_To_Subprogram_Definition (Result_Definition (N)); ! begin ! if Present (AD) and then Protected_Present (AD) then ! Typ := Replace_Anonymous_Access_To_Protected_Subprogram (N); ! else ! Typ := Access_Definition (N, Result_Definition (N)); ! end if; ! end; ! Set_Parent (Typ, Result_Definition (N)); Set_Is_Local_Anonymous_Access (Typ); Set_Etype (Designator, Typ); *************** package body Sem_Ch6 is *** 1228,1245 **** procedure Analyze_Subprogram_Body (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Body_Spec : constant Node_Id := Specification (N); Body_Id : Entity_Id := Defining_Entity (Body_Spec); Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); - Body_Deleted : constant Boolean := False; - - HSS : Node_Id; - Spec_Id : Entity_Id; - Spec_Decl : Node_Id := Empty; - Last_Formal : Entity_Id := Empty; Conformant : Boolean; Missing_Ret : Boolean; P_Ent : Entity_Id; procedure Check_Anonymous_Return; -- (Ada 2005): if a function returns an access type that denotes a task, --- 1324,1360 ---- procedure Analyze_Subprogram_Body (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); + Body_Deleted : constant Boolean := False; Body_Spec : constant Node_Id := Specification (N); Body_Id : Entity_Id := Defining_Entity (Body_Spec); Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); Conformant : Boolean; + HSS : Node_Id; Missing_Ret : Boolean; P_Ent : Entity_Id; + Prot_Typ : Entity_Id := Empty; + Spec_Id : Entity_Id; + Spec_Decl : Node_Id := Empty; + + Last_Real_Spec_Entity : Entity_Id := Empty; + -- When we analyze a separate spec, the entity chain ends up containing + -- the formals, as well as any itypes generated during analysis of the + -- default expressions for parameters, or the arguments of associated + -- precondition/postcondition pragmas (which are analyzed in the context + -- of the spec since they have visibility on formals). + -- + -- These entities belong with the spec and not the body. However we do + -- the analysis of the body in the context of the spec (again to obtain + -- visibility to the formals), and all the entities generated during + -- this analysis end up also chained to the entity chain of the spec. + -- But they really belong to the body, and there is circuitry to move + -- them from the spec to the body. + -- + -- However, when we do this move, we don't want to move the real spec + -- entities (first para above) to the body. The Last_Real_Spec_Entity + -- variable points to the last real spec entity, so we only move those + -- chained beyond that point. It is initialized to Empty to deal with + -- the case where there is no separate spec. procedure Check_Anonymous_Return; -- (Ada 2005): if a function returns an access type that denotes a task, *************** package body Sem_Ch6 is *** 1254,1264 **** -- unconditionally, otherwise only if Front_End_Inlining is requested. -- If the body acts as a spec, and inlining is required, we create a -- subprogram declaration for it, in order to attach the body to inline. ! procedure Copy_Parameter_List (Plist : List_Id); ! -- Utility to create a parameter profile for a new subprogram spec, ! -- when the subprogram has a body that acts as spec. This is done for ! -- some cases of inlining, and for private protected ops. procedure Verify_Overriding_Indicator; -- If there was a previous spec, the entity has been entered in the --- 1369,1394 ---- -- unconditionally, otherwise only if Front_End_Inlining is requested. -- If the body acts as a spec, and inlining is required, we create a -- subprogram declaration for it, in order to attach the body to inline. + -- If pragma does not appear after the body, check whether there is + -- an inline pragma before any local declarations. ! function Disambiguate_Spec return Entity_Id; ! -- When a primitive is declared between the private view and the full ! -- view of a concurrent type which implements an interface, a special ! -- mechanism is used to find the corresponding spec of the primitive ! -- body. ! ! function Is_Private_Concurrent_Primitive ! (Subp_Id : Entity_Id) return Boolean; ! -- Determine whether subprogram Subp_Id is a primitive of a concurrent ! -- type that implements an interface and has a private view. ! ! procedure Set_Trivial_Subprogram (N : Node_Id); ! -- Sets the Is_Trivial_Subprogram flag in both spec and body of the ! -- subprogram whose body is being analyzed. N is the statement node ! -- causing the flag to be set, if the following statement is a return ! -- of an entity, we mark the entity as set in source to suppress any ! -- warning on the stylized use of function stubs with a dummy return. procedure Verify_Overriding_Indicator; -- If there was a previous spec, the entity has been entered in the *************** package body Sem_Ch6 is *** 1316,1321 **** --- 1446,1476 ---- Prag : Node_Id; Plist : List_Id; + function Is_Inline_Pragma (N : Node_Id) return Boolean; + -- True when N is a pragma Inline or Inline_Always that applies + -- to this subprogram. + + ----------------------- + -- Is_Inline_Pragma -- + ----------------------- + + function Is_Inline_Pragma (N : Node_Id) return Boolean is + begin + return + Nkind (N) = N_Pragma + and then + (Pragma_Name (N) = Name_Inline_Always + or else + (Front_End_Inlining + and then Pragma_Name (N) = Name_Inline)) + and then + Chars + (Expression (First (Pragma_Argument_Associations (N)))) + = Chars (Body_Id); + end Is_Inline_Pragma; + + -- Start of processing for Check_Inline_Pragma + begin if not Expander_Active then return; *************** package body Sem_Ch6 is *** 1323,1347 **** if Is_List_Member (N) and then Present (Next (N)) ! and then Nkind (Next (N)) = N_Pragma then Prag := Next (N); ! if Nkind (Prag) = N_Pragma ! and then ! (Get_Pragma_Id (Chars (Prag)) = Pragma_Inline_Always ! or else ! (Front_End_Inlining ! and then Get_Pragma_Id (Chars (Prag)) = Pragma_Inline)) ! and then ! Chars ! (Expression (First (Pragma_Argument_Associations (Prag)))) ! = Chars (Body_Id) ! then ! Prag := Next (N); ! else ! Prag := Empty; ! end if; else Prag := Empty; end if; --- 1478,1493 ---- if Is_List_Member (N) and then Present (Next (N)) ! and then Is_Inline_Pragma (Next (N)) then Prag := Next (N); ! elsif Nkind (N) /= N_Subprogram_Body_Stub ! and then Present (Declarations (N)) ! and then Is_Inline_Pragma (First (Declarations (N))) ! then ! Prag := First (Declarations (N)); ! else Prag := Empty; end if; *************** package body Sem_Ch6 is *** 1367,1374 **** Set_Defining_Unit_Name (Specification (Decl), Subp); if Present (First_Formal (Body_Id)) then ! Plist := New_List; ! Copy_Parameter_List (Plist); Set_Parameter_Specifications (Specification (Decl), Plist); end if; --- 1513,1519 ---- Set_Defining_Unit_Name (Specification (Decl), Subp); if Present (First_Formal (Body_Id)) then ! Plist := Copy_Parameter_List (Body_Id); Set_Parameter_Specifications (Specification (Decl), Plist); end if; *************** package body Sem_Ch6 is *** 1378,1387 **** Analyze (Prag); Set_Has_Pragma_Inline (Subp); ! if Get_Pragma_Id (Chars (Prag)) = Pragma_Inline_Always then Set_Is_Inlined (Subp); ! Set_Next_Rep_Item (Prag, First_Rep_Item (Subp)); ! Set_First_Rep_Item (Subp, Prag); end if; Spec := Subp; --- 1523,1531 ---- Analyze (Prag); Set_Has_Pragma_Inline (Subp); ! if Pragma_Name (Prag) = Name_Inline_Always then Set_Is_Inlined (Subp); ! Set_Has_Pragma_Inline_Always (Subp); end if; Spec := Subp; *************** package body Sem_Ch6 is *** 1390,1422 **** end if; end Check_Inline_Pragma; ! ------------------------- ! -- Copy_Parameter_List -- ! ------------------------- ! procedure Copy_Parameter_List (Plist : List_Id) is ! Formal : Entity_Id; begin ! Formal := First_Formal (Body_Id); ! while Present (Formal) loop ! Append ! (Make_Parameter_Specification (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Sloc (Formal), ! Chars => Chars (Formal)), ! In_Present => In_Present (Parent (Formal)), ! Out_Present => Out_Present (Parent (Formal)), ! Parameter_Type => ! New_Reference_To (Etype (Formal), Loc), ! Expression => ! New_Copy_Tree (Expression (Parent (Formal)))), ! Plist); ! Next_Formal (Formal); ! end loop; ! end Copy_Parameter_List; --------------------------------- -- Verify_Overriding_Indicator -- --- 1534,1690 ---- end if; end Check_Inline_Pragma; ! ----------------------- ! -- Disambiguate_Spec -- ! ----------------------- ! function Disambiguate_Spec return Entity_Id is ! Priv_Spec : Entity_Id; ! Spec_N : Entity_Id; ! ! procedure Replace_Types (To_Corresponding : Boolean); ! -- Depending on the flag, replace the type of formal parameters of ! -- Body_Id if it is a concurrent type implementing interfaces with ! -- the corresponding record type or the other way around. ! ! procedure Replace_Types (To_Corresponding : Boolean) is ! Formal : Entity_Id; ! Formal_Typ : Entity_Id; ! ! begin ! Formal := First_Formal (Body_Id); ! while Present (Formal) loop ! Formal_Typ := Etype (Formal); ! ! -- From concurrent type to corresponding record ! ! if To_Corresponding then ! if Is_Concurrent_Type (Formal_Typ) ! and then Present (Corresponding_Record_Type (Formal_Typ)) ! and then Present (Interfaces ( ! Corresponding_Record_Type (Formal_Typ))) ! then ! Set_Etype (Formal, ! Corresponding_Record_Type (Formal_Typ)); ! end if; ! ! -- From corresponding record to concurrent type ! ! else ! if Is_Concurrent_Record_Type (Formal_Typ) ! and then Present (Interfaces (Formal_Typ)) ! then ! Set_Etype (Formal, ! Corresponding_Concurrent_Type (Formal_Typ)); ! end if; ! end if; ! ! Next_Formal (Formal); ! end loop; ! end Replace_Types; ! ! -- Start of processing for Disambiguate_Spec begin ! -- Try to retrieve the specification of the body as is. All error ! -- messages are suppressed because the body may not have a spec in ! -- its current state. ! Spec_N := Find_Corresponding_Spec (N, False); ! -- It is possible that this is the body of a primitive declared ! -- between a private and a full view of a concurrent type. The ! -- controlling parameter of the spec carries the concurrent type, ! -- not the corresponding record type as transformed by Analyze_ ! -- Subprogram_Specification. In such cases, we undo the change ! -- made by the analysis of the specification and try to find the ! -- spec again. ! ! -- Note that wrappers already have their corresponding specs and ! -- bodies set during their creation, so if the candidate spec is ! -- a wrapper, then we definitely need to swap all types to their ! -- original concurrent status. ! ! if No (Spec_N) ! or else Is_Primitive_Wrapper (Spec_N) ! then ! -- Restore all references of corresponding record types to the ! -- original concurrent types. ! ! Replace_Types (To_Corresponding => False); ! Priv_Spec := Find_Corresponding_Spec (N, False); ! ! -- The current body truly belongs to a primitive declared between ! -- a private and a full view. We leave the modified body as is, ! -- and return the true spec. ! ! if Present (Priv_Spec) ! and then Is_Private_Primitive (Priv_Spec) ! then ! return Priv_Spec; ! end if; ! ! -- In case that this is some sort of error, restore the original ! -- state of the body. ! ! Replace_Types (To_Corresponding => True); ! end if; ! ! return Spec_N; ! end Disambiguate_Spec; ! ! ------------------------------------- ! -- Is_Private_Concurrent_Primitive -- ! ------------------------------------- ! ! function Is_Private_Concurrent_Primitive ! (Subp_Id : Entity_Id) return Boolean ! is ! Formal_Typ : Entity_Id; ! ! begin ! if Present (First_Formal (Subp_Id)) then ! Formal_Typ := Etype (First_Formal (Subp_Id)); ! ! if Is_Concurrent_Record_Type (Formal_Typ) then ! Formal_Typ := Corresponding_Concurrent_Type (Formal_Typ); ! end if; ! ! -- The type of the first formal is a concurrent tagged type with ! -- a private view. ! ! return ! Is_Concurrent_Type (Formal_Typ) ! and then Is_Tagged_Type (Formal_Typ) ! and then Has_Private_Declaration (Formal_Typ); ! end if; ! ! return False; ! end Is_Private_Concurrent_Primitive; ! ! ---------------------------- ! -- Set_Trivial_Subprogram -- ! ---------------------------- ! ! procedure Set_Trivial_Subprogram (N : Node_Id) is ! Nxt : constant Node_Id := Next (N); ! ! begin ! Set_Is_Trivial_Subprogram (Body_Id); ! ! if Present (Spec_Id) then ! Set_Is_Trivial_Subprogram (Spec_Id); ! end if; ! ! if Present (Nxt) ! and then Nkind (Nxt) = N_Simple_Return_Statement ! and then No (Next (Nxt)) ! and then Present (Expression (Nxt)) ! and then Is_Entity_Name (Expression (Nxt)) ! then ! Set_Never_Set_In_Source (Entity (Expression (Nxt)), False); ! end if; ! end Set_Trivial_Subprogram; --------------------------------- -- Verify_Overriding_Indicator -- *************** package body Sem_Ch6 is *** 1424,1439 **** procedure Verify_Overriding_Indicator is begin ! if Must_Override (Body_Spec) ! and then not Is_Overriding_Operation (Spec_Id) ! then ! Error_Msg_NE ! ("subprogram& is not overriding", Body_Spec, Spec_Id); elsif Must_Not_Override (Body_Spec) then if Is_Overriding_Operation (Spec_Id) then Error_Msg_NE ("subprogram& overrides inherited operation", Body_Spec, Spec_Id); -- If this is not a primitive operation the overriding indicator --- 1692,1719 ---- procedure Verify_Overriding_Indicator is begin ! if Must_Override (Body_Spec) then ! if Nkind (Spec_Id) = N_Defining_Operator_Symbol ! and then Operator_Matches_Spec (Spec_Id, Spec_Id) ! then ! null; ! ! elsif not Is_Overriding_Operation (Spec_Id) then ! Error_Msg_NE ! ("subprogram& is not overriding", Body_Spec, Spec_Id); ! end if; elsif Must_Not_Override (Body_Spec) then if Is_Overriding_Operation (Spec_Id) then Error_Msg_NE ("subprogram& overrides inherited operation", + Body_Spec, Spec_Id); + + elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol + and then Operator_Matches_Spec (Spec_Id, Spec_Id) + then + Error_Msg_NE + ("subprogram & overrides predefined operator ", Body_Spec, Spec_Id); -- If this is not a primitive operation the overriding indicator *************** package body Sem_Ch6 is *** 1444,1449 **** --- 1724,1735 ---- "if subprogram is primitive", Body_Spec); end if; + + elsif Style_Check + and then Is_Overriding_Operation (Spec_Id) + then + pragma Assert (Unit_Declaration_Node (Body_Id) = N); + Style.Missing_Overriding (N, Body_Id); end if; end Verify_Overriding_Indicator; *************** package body Sem_Ch6 is *** 1506,1512 **** if Nkind (N) = N_Subprogram_Body_Stub or else No (Corresponding_Spec (N)) then ! Spec_Id := Find_Corresponding_Spec (N); -- If this is a duplicate body, no point in analyzing it --- 1792,1802 ---- if Nkind (N) = N_Subprogram_Body_Stub or else No (Corresponding_Spec (N)) then ! if Is_Private_Concurrent_Primitive (Body_Id) then ! Spec_Id := Disambiguate_Spec; ! else ! Spec_Id := Find_Corresponding_Spec (N); ! end if; -- If this is a duplicate body, no point in analyzing it *************** package body Sem_Ch6 is *** 1519,1533 **** -- subprogram will get frozen too late (there may be code within -- the body that depends on the subprogram having been frozen, -- such as uses of extra formals), so we force it to be frozen ! -- here. Same holds if the body and the spec are compilation ! -- units. if No (Spec_Id) then Freeze_Before (N, Body_Id); elsif Nkind (Parent (N)) = N_Compilation_Unit then Freeze_Before (N, Spec_Id); end if; else Spec_Id := Corresponding_Spec (N); end if; --- 1809,1830 ---- -- subprogram will get frozen too late (there may be code within -- the body that depends on the subprogram having been frozen, -- such as uses of extra formals), so we force it to be frozen ! -- here. Same holds if the body and spec are compilation units. ! -- Finally, if the return type is an anonymous access to protected ! -- subprogram, it must be frozen before the body because its ! -- expansion has generated an equivalent type that is used when ! -- elaborating the body. if No (Spec_Id) then Freeze_Before (N, Body_Id); elsif Nkind (Parent (N)) = N_Compilation_Unit then Freeze_Before (N, Spec_Id); + + elsif Is_Access_Subprogram_Type (Etype (Body_Id)) then + Freeze_Before (N, Etype (Body_Id)); end if; + else Spec_Id := Corresponding_Spec (N); end if; *************** package body Sem_Ch6 is *** 1595,1608 **** if Present (Formal) or else Expander_Active then ! Plist := New_List; ! else Plist := No_List; end if; - Copy_Parameter_List (Plist); - if Nkind (Body_Spec) = N_Procedure_Specification then New_Spec := Make_Procedure_Specification (Loc, --- 1892,1902 ---- if Present (Formal) or else Expander_Active then ! Plist := Copy_Parameter_List (Body_Id); else Plist := No_List; end if; if Nkind (Body_Spec) = N_Procedure_Specification then New_Spec := Make_Procedure_Specification (Loc, *************** package body Sem_Ch6 is *** 1665,1670 **** --- 1959,1968 ---- end if; end if; + if Chars (Body_Id) = Name_uPostconditions then + Set_Has_Postconditions (Current_Scope); + end if; + -- Place subprogram on scope stack, and make formals visible. If there -- is a spec, the visible entity remains that of the spec. *************** package body Sem_Ch6 is *** 1685,1696 **** if Is_Abstract_Subprogram (Spec_Id) then Error_Msg_N ("an abstract subprogram cannot have a body", N); return; else Set_Convention (Body_Id, Convention (Spec_Id)); Set_Has_Completion (Spec_Id); if Is_Protected_Type (Scope (Spec_Id)) then ! Set_Privals_Chain (Spec_Id, New_Elmt_List); end if; -- If this is a body generated for a renaming, do not check for --- 1983,1995 ---- if Is_Abstract_Subprogram (Spec_Id) then Error_Msg_N ("an abstract subprogram cannot have a body", N); return; + else Set_Convention (Body_Id, Convention (Spec_Id)); Set_Has_Completion (Spec_Id); if Is_Protected_Type (Scope (Spec_Id)) then ! Prot_Typ := Scope (Spec_Id); end if; -- If this is a body generated for a renaming, do not check for *************** package body Sem_Ch6 is *** 1710,1719 **** N_Subprogram_Renaming_Declaration)) then Conformant := True; else Check_Conformance (Body_Id, Spec_Id, ! Fully_Conformant, True, Conformant, Body_Id); end if; -- If the body is not fully conformant, we have to decide if we --- 2009,2019 ---- N_Subprogram_Renaming_Declaration)) then Conformant := True; + else Check_Conformance (Body_Id, Spec_Id, ! Fully_Conformant, True, Conformant, Body_Id); end if; -- If the body is not fully conformant, we have to decide if we *************** package body Sem_Ch6 is *** 1755,1765 **** and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type and then Is_Tagged_Type (Etype (First_Entity (Spec_Id))) and then ! Present (Abstract_Interfaces (Etype (First_Entity (Spec_Id)))) and then Present ! (Corresponding_Concurrent_Type ! (Etype (First_Entity (Spec_Id)))) then declare Typ : constant Entity_Id := Etype (First_Entity (Spec_Id)); --- 2055,2065 ---- and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type and then Is_Tagged_Type (Etype (First_Entity (Spec_Id))) and then ! Present (Interfaces (Etype (First_Entity (Spec_Id)))) and then Present ! (Corresponding_Concurrent_Type ! (Etype (First_Entity (Spec_Id)))) then declare Typ : constant Entity_Id := Etype (First_Entity (Spec_Id)); *************** package body Sem_Ch6 is *** 1777,1787 **** end; end if; ! -- Now make the formals visible, and place subprogram ! -- on scope stack. Install_Formals (Spec_Id); ! Last_Formal := Last_Entity (Spec_Id); Push_Scope (Spec_Id); -- Make sure that the subprogram is immediately visible. For --- 2077,2088 ---- end; end if; ! -- Make the formals visible, and place subprogram on scope stack. ! -- This is also the point at which we set Last_Real_Spec_Entity ! -- to mark the entities which will not be moved to the body. Install_Formals (Spec_Id); ! Last_Real_Spec_Entity := Last_Entity (Spec_Id); Push_Scope (Spec_Id); -- Make sure that the subprogram is immediately visible. For *************** package body Sem_Ch6 is *** 1820,1884 **** end if; end if; ! -- Ada 2005 (AI-251): Check wrong placement of abstract interface ! -- primitives, and update anonymous access returns with limited views. if Ada_Version >= Ada_05 and then Comes_From_Source (N) then declare - E : Entity_Id; Etyp : Entity_Id; Rtyp : Entity_Id; begin - -- Check the type of the formals - - E := First_Entity (Body_Id); - while Present (E) loop - Etyp := Etype (E); - - if Is_Access_Type (Etyp) then - Etyp := Directly_Designated_Type (Etyp); - end if; - - if not Is_Class_Wide_Type (Etyp) - and then Is_Interface (Etyp) - then - Error_Msg_Name_1 := Chars (Defining_Entity (N)); - Error_Msg_N - ("(Ada 2005) abstract interface primitives must be" & - " defined in package specs", N); - exit; - end if; - - Next_Entity (E); - end loop; - - -- In case of functions, check the type of the result - - if Ekind (Body_Id) = E_Function then - Etyp := Etype (Body_Id); - - if Is_Access_Type (Etyp) then - Etyp := Directly_Designated_Type (Etyp); - end if; - - if not Is_Class_Wide_Type (Etyp) - and then Is_Interface (Etyp) - then - Error_Msg_Name_1 := Chars (Defining_Entity (N)); - Error_Msg_N - ("(Ada 2005) abstract interface primitives must be" & - " defined in package specs", N); - end if; - end if; - - -- If the return type is an anonymous access type whose - -- designated type is the limited view of a class-wide type - -- and the non-limited view is available. update the return - -- type accordingly. - Rtyp := Etype (Current_Scope); if Ekind (Rtyp) = E_Anonymous_Access_Type then --- 2121,2138 ---- end if; end if; ! -- If the return type is an anonymous access type whose designated type ! -- is the limited view of a class-wide type and the non-limited view is ! -- available, update the return type accordingly. if Ada_Version >= Ada_05 and then Comes_From_Source (N) then declare Etyp : Entity_Id; Rtyp : Entity_Id; begin Rtyp := Etype (Current_Scope); if Ekind (Rtyp) = E_Anonymous_Access_Type then *************** package body Sem_Ch6 is *** 1948,1956 **** -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis -- if its specification we have to install the private withed units. if Is_Compilation_Unit (Body_Id) ! and then Scope (Body_Id) = Standard_Standard then Install_Private_With_Clauses (Body_Id); end if; --- 2202,2211 ---- -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis -- if its specification we have to install the private withed units. + -- This holds for child units as well. if Is_Compilation_Unit (Body_Id) ! or else Nkind (Parent (N)) = N_Compilation_Unit then Install_Private_With_Clauses (Body_Id); end if; *************** package body Sem_Ch6 is *** 1978,1986 **** begin while Present (Prot_Ext_Formal) loop pragma Assert (Present (Impl_Ext_Formal)); - Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal); - Next_Formal_With_Extras (Prot_Ext_Formal); Next_Formal_With_Extras (Impl_Ext_Formal); end loop; --- 2233,2239 ---- *************** package body Sem_Ch6 is *** 1991,1999 **** --- 2244,2284 ---- HSS := Handled_Statement_Sequence (N); Set_Actual_Subtypes (N, Current_Scope); + + -- Deal with preconditions and postconditions + + Process_PPCs (N, Spec_Id, Body_Id); + + -- Add a declaration for the Protection object, renaming declarations + -- for discriminals and privals and finally a declaration for the entry + -- family index (if applicable). This form of early expansion is done + -- when the Expander is active because Install_Private_Data_Declarations + -- references entities which were created during regular expansion. + + if Expander_Active + and then Comes_From_Source (N) + and then Present (Prot_Typ) + and then Present (Spec_Id) + and then not Is_Eliminated (Spec_Id) + then + Install_Private_Data_Declarations + (Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N)); + end if; + + -- Analyze the declarations (this call will analyze the precondition + -- Check pragmas we prepended to the list, as well as the declaration + -- of the _Postconditions procedure). + Analyze_Declarations (Declarations (N)); + + -- Check completion, and analyze the statements + Check_Completion; + Inspect_Deferred_Constant_Completion (Declarations (N)); Analyze (HSS); + + -- Deal with end of scope processing for the body + Process_End_Label (HSS, 't', Current_Scope); End_Scope; Check_Subprogram_Order (N); *************** package body Sem_Ch6 is *** 2017,2030 **** (Unit_Declaration_Node (Spec_Id), Spec_Id); end if; ! if Present (Last_Formal) then ! Set_Next_Entity ! (Last_Entity (Body_Id), Next_Entity (Last_Formal)); ! Set_Next_Entity (Last_Formal, Empty); Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); ! Set_Last_Entity (Spec_Id, Last_Formal); else Set_First_Entity (Body_Id, First_Entity (Spec_Id)); Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); Set_First_Entity (Spec_Id, Empty); --- 2302,2336 ---- (Unit_Declaration_Node (Spec_Id), Spec_Id); end if; ! -- Here is where we move entities from the spec to the body ! ! -- Case where there are entities that stay with the spec ! ! if Present (Last_Real_Spec_Entity) then ! ! -- No body entities (happens when the only real spec entities ! -- come from precondition and postcondition pragmas) ! ! if No (Last_Entity (Body_Id)) then ! Set_First_Entity ! (Body_Id, Next_Entity (Last_Real_Spec_Entity)); ! ! -- Body entities present (formals), so chain stuff past them ! ! else ! Set_Next_Entity ! (Last_Entity (Body_Id), Next_Entity (Last_Real_Spec_Entity)); ! end if; ! ! Set_Next_Entity (Last_Real_Spec_Entity, Empty); Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); ! Set_Last_Entity (Spec_Id, Last_Real_Spec_Entity); ! ! -- Case where there are no spec entities, in this case there can ! -- be no body entities either, so just move everything. else + pragma Assert (No (Last_Entity (Body_Id))); Set_First_Entity (Body_Id, First_Entity (Spec_Id)); Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); Set_First_Entity (Spec_Id, Empty); *************** package body Sem_Ch6 is *** 2069,2075 **** end if; -- Now we are going to check for variables that are never modified in ! -- the body of the procedure. We omit these checks if the first -- statement of the procedure raises an exception. In particular this -- deals with the common idiom of a stubbed function, which might -- appear as something like --- 2375,2386 ---- end if; -- Now we are going to check for variables that are never modified in ! -- the body of the procedure. But first we deal with a special case ! -- where we want to modify this check. If the body of the subprogram ! -- starts with a raise statement or its equivalent, or if the body ! -- consists entirely of a null statement, then it is pretty obvious ! -- that it is OK to not reference the parameters. For example, this ! -- might be the following common idiom for a stubbed function: -- statement of the procedure raises an exception. In particular this -- deals with the common idiom of a stubbed function, which might -- appear as something like *************** package body Sem_Ch6 is *** 2081,2090 **** -- return X; -- end F; ! -- Here the purpose of X is simply to satisfy the (annoying) ! -- requirement in Ada that there be at least one return, and we ! -- certainly do not want to go posting warnings on X that it is not ! -- initialized! declare Stm : Node_Id; --- 2392,2408 ---- -- return X; -- end F; ! -- Here the purpose of X is simply to satisfy the annoying requirement ! -- in Ada that there be at least one return, and we certainly do not ! -- want to go posting warnings on X that it is not initialized! On ! -- the other hand, if X is entirely unreferenced that should still ! -- get a warning. ! ! -- What we do is to detect these cases, and if we find them, flag the ! -- subprogram as being Is_Trivial_Subprogram and then use that flag to ! -- suppress unwanted warnings. For the case of the function stub above ! -- we have a special test to set X as apparently assigned to suppress ! -- the warning. declare Stm : Node_Id; *************** package body Sem_Ch6 is *** 2107,2116 **** Ostm : constant Node_Id := Original_Node (Stm); begin ! -- If explicit raise statement, return with no checks if Nkind (Ostm) = N_Raise_Statement then ! return; -- Check for explicit call cases which likely raise an exception --- 2425,2442 ---- Ostm : constant Node_Id := Original_Node (Stm); begin ! -- If explicit raise statement, turn on flag if Nkind (Ostm) = N_Raise_Statement then ! Set_Trivial_Subprogram (Stm); ! ! -- If null statement, and no following statements, turn on flag ! ! elsif Nkind (Stm) = N_Null_Statement ! and then Comes_From_Source (Stm) ! and then No (Next (Stm)) ! then ! Set_Trivial_Subprogram (Stm); -- Check for explicit call cases which likely raise an exception *************** package body Sem_Ch6 is *** 2122,2143 **** begin -- If the procedure is marked No_Return, then likely it -- raises an exception, but in any case it is not coming ! -- back here, so no need to check beyond the call. if Ekind (Ent) = E_Procedure and then No_Return (Ent) then ! return; ! ! -- If the procedure name is Raise_Exception, then also ! -- assume that it raises an exception. The main target ! -- here is Ada.Exceptions.Raise_Exception, but this name ! -- is pretty evocative in any context! Note that the ! -- procedure in Ada.Exceptions is not marked No_Return ! -- because of the annoying case of the null exception Id. ! ! elsif Chars (Ent) = Name_Raise_Exception then ! return; end if; end; end if; --- 2448,2459 ---- begin -- If the procedure is marked No_Return, then likely it -- raises an exception, but in any case it is not coming ! -- back here, so turn on the flag. if Ekind (Ent) = E_Procedure and then No_Return (Ent) then ! Set_Trivial_Subprogram (Stm); end if; end; end if; *************** package body Sem_Ch6 is *** 2221,2226 **** --- 2537,2558 ---- New_Overloaded_Entity (Designator); Check_Delayed_Subprogram (Designator); + -- If the type of the first formal of the current subprogram is a non + -- generic tagged private type , mark the subprogram as being a private + -- primitive. + + if Present (First_Formal (Designator)) then + declare + Formal_Typ : constant Entity_Id := + Etype (First_Formal (Designator)); + begin + Set_Is_Private_Primitive (Designator, + Is_Tagged_Type (Formal_Typ) + and then Is_Private_Type (Formal_Typ) + and then not Is_Generic_Actual_Type (Formal_Typ)); + end; + end if; + -- Ada 2005 (AI-251): Abstract interface primitives must be abstract -- or null. *************** package body Sem_Ch6 is *** 2333,2340 **** function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is Designator : constant Entity_Id := Defining_Entity (N); - Formal : Entity_Id; - Formal_Typ : Entity_Id; Formals : constant List_Id := Parameter_Specifications (N); -- Start of processing for Analyze_Subprogram_Specification --- 2665,2670 ---- *************** package body Sem_Ch6 is *** 2359,2386 **** Push_Scope (Designator); Process_Formals (Formals, N); ! -- Ada 2005 (AI-345): Allow the overriding of interface primitives ! -- by subprograms which belong to a concurrent type implementing an ! -- interface. Set the parameter type of each controlling formal to ! -- the corresponding record type. if Ada_Version >= Ada_05 then ! Formal := First_Formal (Designator); ! while Present (Formal) loop ! Formal_Typ := Etype (Formal); ! if (Ekind (Formal_Typ) = E_Protected_Type ! or else Ekind (Formal_Typ) = E_Task_Type) ! and then Present (Corresponding_Record_Type (Formal_Typ)) ! and then Present (Abstract_Interfaces ! (Corresponding_Record_Type (Formal_Typ))) ! then ! Set_Etype (Formal, ! Corresponding_Record_Type (Formal_Typ)); ! end if; ! Formal := Next_Formal (Formal); ! end loop; end if; End_Scope; --- 2689,2723 ---- Push_Scope (Designator); Process_Formals (Formals, N); ! -- Ada 2005 (AI-345): If this is an overriding operation of an ! -- inherited interface operation, and the controlling type is ! -- a synchronized type, replace the type with its corresponding ! -- record, to match the proper signature of an overriding operation. if Ada_Version >= Ada_05 then ! declare ! Formal : Entity_Id; ! Formal_Typ : Entity_Id; ! Rec_Typ : Entity_Id; ! begin ! Formal := First_Formal (Designator); ! while Present (Formal) loop ! Formal_Typ := Etype (Formal); ! if Is_Concurrent_Type (Formal_Typ) ! and then Present (Corresponding_Record_Type (Formal_Typ)) ! then ! Rec_Typ := Corresponding_Record_Type (Formal_Typ); ! ! if Present (Interfaces (Rec_Typ)) then ! Set_Etype (Formal, Rec_Typ); ! end if; ! end if; ! ! Next_Formal (Formal); ! end loop; ! end; end if; End_Scope; *************** package body Sem_Ch6 is *** 2396,2415 **** May_Need_Actuals (Designator); ! -- Ada 2005 (AI-251): In case of primitives associated with abstract ! -- interface types the following error message will be reported later ! -- (see Analyze_Subprogram_Declaration). if Is_Abstract_Type (Etype (Designator)) and then not Is_Interface (Etype (Designator)) ! and then Nkind (Parent (N)) ! /= N_Abstract_Subprogram_Declaration ! and then (Nkind (Parent (N))) ! /= N_Formal_Abstract_Subprogram_Declaration ! and then (Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration ! or else not Is_Entity_Name (Name (Parent (N))) ! or else not Is_Abstract_Subprogram ! (Entity (Name (Parent (N))))) then Error_Msg_N ("function that returns abstract type must be abstract", N); --- 2733,2751 ---- May_Need_Actuals (Designator); ! -- Ada 2005 (AI-251): If the return type is abstract, verify that ! -- the subprogram is abstract also. This does not apply to renaming ! -- declarations, where abstractness is inherited. ! -- In case of primitives associated with abstract interface types ! -- the check is applied later (see Analyze_Subprogram_Declaration). if Is_Abstract_Type (Etype (Designator)) and then not Is_Interface (Etype (Designator)) ! and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration ! and then Nkind (Parent (N)) /= ! N_Abstract_Subprogram_Declaration ! and then ! (Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration then Error_Msg_N ("function that returns abstract type must be abstract", N); *************** package body Sem_Ch6 is *** 2453,2462 **** -- variable as is done for other inlined calls. procedure Remove_Pragmas; ! -- A pragma Unreferenced that mentions a formal parameter has no meaning ! -- when the body is inlined and the formals are rewritten. Remove it ! -- from body to inline. The analysis of the non-inlined body will handle ! -- the pragma properly. function Uses_Secondary_Stack (Bod : Node_Id) return Boolean; -- If the body of the subprogram includes a call that returns an --- 2789,2798 ---- -- variable as is done for other inlined calls. procedure Remove_Pragmas; ! -- A pragma Unreferenced or pragma Unmodified that mentions a formal ! -- parameter has no meaning when the body is inlined and the formals ! -- are rewritten. Remove it from body to inline. The analysis of the ! -- non-inlined body will handle the pragma properly. function Uses_Secondary_Stack (Bod : Node_Id) return Boolean; -- If the body of the subprogram includes a call that returns an *************** package body Sem_Ch6 is *** 2709,2715 **** Nxt := Next (Decl); if Nkind (Decl) = N_Pragma ! and then Chars (Decl) = Name_Unreferenced then Remove (Decl); end if; --- 3045,3053 ---- Nxt := Next (Decl); if Nkind (Decl) = N_Pragma ! and then (Pragma_Name (Decl) = Name_Unreferenced ! or else ! Pragma_Name (Decl) = Name_Unmodified) then Remove (Decl); end if; *************** package body Sem_Ch6 is *** 2780,2786 **** -- actions interfere in complex ways with inlining. elsif Ekind (Subp) = E_Function ! and then Controlled_Type (Etype (Subp)) then Cannot_Inline ("cannot inline & (controlled return type)?", N, Subp); --- 3118,3124 ---- -- actions interfere in complex ways with inlining. elsif Ekind (Subp) = E_Function ! and then Needs_Finalization (Etype (Subp)) then Cannot_Inline ("cannot inline & (controlled return type)?", N, Subp); *************** package body Sem_Ch6 is *** 2829,2835 **** -- Within an instance, the body to inline must be treated as a nested -- generic, so that the proper global references are preserved. ! if In_Instance then Save_Env (Scope (Current_Scope), Scope (Current_Scope)); Original_Body := Copy_Generic_Node (N, Empty, True); else --- 3167,3177 ---- -- Within an instance, the body to inline must be treated as a nested -- generic, so that the proper global references are preserved. ! -- Note that we do not do this at the library level, because it is not ! -- needed, and furthermore this causes trouble if front end inlining ! -- is activated (-gnatN). ! ! if In_Instance and then Scope (Current_Scope) /= Standard_Standard then Save_Env (Scope (Current_Scope), Scope (Current_Scope)); Original_Body := Copy_Generic_Node (N, Empty, True); else *************** package body Sem_Ch6 is *** 2877,2883 **** Expander_Mode_Restore; ! if In_Instance then Restore_Env; end if; --- 3219,3227 ---- Expander_Mode_Restore; ! -- Restore environment if previously saved ! ! if In_Instance and then Scope (Current_Scope) /= Standard_Standard then Restore_Env; end if; *************** package body Sem_Ch6 is *** 3033,3039 **** if Old_Type /= Standard_Void_Type and then New_Type /= Standard_Void_Type then ! if not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then Conformance_Error ("\return type does not match!", New_Id); return; end if; --- 3377,3394 ---- if Old_Type /= Standard_Void_Type and then New_Type /= Standard_Void_Type then ! ! -- If we are checking interface conformance we omit controlling ! -- arguments and result, because we are only checking the conformance ! -- of the remaining parameters. ! ! if Has_Controlling_Result (Old_Id) ! and then Has_Controlling_Result (New_Id) ! and then Skip_Controlling_Formals ! then ! null; ! ! elsif not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then Conformance_Error ("\return type does not match!", New_Id); return; end if; *************** package body Sem_Ch6 is *** 3309,3315 **** if NewD then Push_Scope (New_Id); ! Analyze_Per_Use_Expression (Default_Value (New_Formal), Etype (New_Formal)); End_Scope; end if; --- 3664,3670 ---- if NewD then Push_Scope (New_Id); ! Preanalyze_Spec_Expression (Default_Value (New_Formal), Etype (New_Formal)); End_Scope; end if; *************** package body Sem_Ch6 is *** 3398,3415 **** ----------------------- procedure Check_Conventions (Typ : Entity_Id) is ! function Skip_Check (Op : Entity_Id) return Boolean; ! pragma Inline (Skip_Check); ! -- A small optimization: skip the predefined dispatching operations, ! -- since they always have the same convention. Also do not consider ! -- abstract primitives since those are left by an erroneous overriding. ! -- This function returns True for any operation that is thus exempted ! -- exempted from checking. ! ! procedure Check_Convention ! (Op : Entity_Id; ! Search_From : Elmt_Id); -- Verify that the convention of inherited dispatching operation Op is -- consistent among all subprograms it overrides. In order to minimize -- the search, Search_From is utilized to designate a specific point in --- 3753,3761 ---- ----------------------- procedure Check_Conventions (Typ : Entity_Id) is + Ifaces_List : Elist_Id; ! procedure Check_Convention (Op : Entity_Id); -- Verify that the convention of inherited dispatching operation Op is -- consistent among all subprograms it overrides. In order to minimize -- the search, Search_From is utilized to designate a specific point in *************** package body Sem_Ch6 is *** 3419,3507 **** -- Check_Convention -- ---------------------- ! procedure Check_Convention ! (Op : Entity_Id; ! Search_From : Elmt_Id) ! is ! procedure Error_Msg_Operation (Op : Entity_Id); ! -- Emit a continuation to an error message depicting the kind, name, ! -- convention and source location of subprogram Op. ! ------------------------- ! -- Error_Msg_Operation -- ! ------------------------- ! procedure Error_Msg_Operation (Op : Entity_Id) is ! begin ! Error_Msg_Name_1 := Chars (Op); ! -- Error messages of primitive subprograms do not contain a ! -- convention attribute since the convention may have been first ! -- inherited from a parent subprogram, then changed by a pragma. ! if Comes_From_Source (Op) then ! Error_Msg_Sloc := Sloc (Op); ! Error_Msg_N ! ("\ primitive % defined #", Typ); ! else ! Error_Msg_Name_2 := Get_Convention_Name (Convention (Op)); ! if Present (Abstract_Interface_Alias (Op)) then ! Error_Msg_Sloc := Sloc (Abstract_Interface_Alias (Op)); Error_Msg_N ("\\overridden operation % with " & "convention % defined #", Typ); ! else pragma Assert (Present (Alias (Op))); ! Error_Msg_Sloc := Sloc (Alias (Op)); ! Error_Msg_N ("\\inherited operation % with " & ! "convention % defined #", Typ); ! end if; ! end if; ! end Error_Msg_Operation; ! ! -- Local variables ! ! Second_Prim_Op : Entity_Id; ! Second_Prim_Op_Elmt : Elmt_Id; ! ! -- Start of processing for Check_Convention ! ! begin ! Second_Prim_Op_Elmt := Next_Elmt (Search_From); ! while Present (Second_Prim_Op_Elmt) loop ! Second_Prim_Op := Node (Second_Prim_Op_Elmt); ! ! if not Skip_Check (Second_Prim_Op) ! and then Chars (Second_Prim_Op) = Chars (Op) ! and then Type_Conformant (Second_Prim_Op, Op) ! and then Convention (Second_Prim_Op) /= Convention (Op) ! then ! Error_Msg_N ! ("inconsistent conventions in primitive operations", Typ); ! ! Error_Msg_Operation (Op); ! Error_Msg_Operation (Second_Prim_Op); ! -- Avoid cascading errors ! return; ! end if; ! Next_Elmt (Second_Prim_Op_Elmt); end loop; end Check_Convention; - ---------------- - -- Skip_Check -- - ---------------- - - function Skip_Check (Op : Entity_Id) return Boolean is - begin - return Is_Predefined_Dispatching_Operation (Op) - or else Is_Abstract_Subprogram (Op); - end Skip_Check; - -- Local variables Prim_Op : Entity_Id; --- 3765,3826 ---- -- Check_Convention -- ---------------------- ! procedure Check_Convention (Op : Entity_Id) is ! Iface_Elmt : Elmt_Id; ! Iface_Prim_Elmt : Elmt_Id; ! Iface_Prim : Entity_Id; ! begin ! Iface_Elmt := First_Elmt (Ifaces_List); ! while Present (Iface_Elmt) loop ! Iface_Prim_Elmt := ! First_Elmt (Primitive_Operations (Node (Iface_Elmt))); ! while Present (Iface_Prim_Elmt) loop ! Iface_Prim := Node (Iface_Prim_Elmt); ! if Is_Interface_Conformant (Typ, Iface_Prim, Op) ! and then Convention (Iface_Prim) /= Convention (Op) ! then ! Error_Msg_N ! ("inconsistent conventions in primitive operations", Typ); ! Error_Msg_Name_1 := Chars (Op); ! Error_Msg_Name_2 := Get_Convention_Name (Convention (Op)); ! Error_Msg_Sloc := Sloc (Op); ! if Comes_From_Source (Op) then ! if not Is_Overriding_Operation (Op) then ! Error_Msg_N ("\\primitive % defined #", Typ); ! else ! Error_Msg_N ("\\overriding operation % with " & ! "convention % defined #", Typ); ! end if; ! else pragma Assert (Present (Alias (Op))); ! Error_Msg_Sloc := Sloc (Alias (Op)); ! Error_Msg_N ("\\inherited operation % with " & ! "convention % defined #", Typ); ! end if; ! Error_Msg_Name_1 := Chars (Op); ! Error_Msg_Name_2 := ! Get_Convention_Name (Convention (Iface_Prim)); ! Error_Msg_Sloc := Sloc (Iface_Prim); Error_Msg_N ("\\overridden operation % with " & "convention % defined #", Typ); ! -- Avoid cascading errors ! return; ! end if; ! Next_Elmt (Iface_Prim_Elmt); ! end loop; ! Next_Elmt (Iface_Elmt); end loop; end Check_Convention; -- Local variables Prim_Op : Entity_Id; *************** package body Sem_Ch6 is *** 3510,3531 **** -- Start of processing for Check_Conventions begin -- The algorithm checks every overriding dispatching operation against -- all the corresponding overridden dispatching operations, detecting ! -- differences in coventions. Prim_Op_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Op_Elmt) loop Prim_Op := Node (Prim_Op_Elmt); -- A small optimization: skip the predefined dispatching operations ! -- since they always have the same convention. Also avoid processing ! -- of abstract primitives left from an erroneous overriding. ! if not Skip_Check (Prim_Op) then ! Check_Convention ! (Op => Prim_Op, ! Search_From => Prim_Op_Elmt); end if; Next_Elmt (Prim_Op_Elmt); --- 3829,3853 ---- -- Start of processing for Check_Conventions begin + if not Has_Interfaces (Typ) then + return; + end if; + + Collect_Interfaces (Typ, Ifaces_List); + -- The algorithm checks every overriding dispatching operation against -- all the corresponding overridden dispatching operations, detecting ! -- differences in conventions. Prim_Op_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Op_Elmt) loop Prim_Op := Node (Prim_Op_Elmt); -- A small optimization: skip the predefined dispatching operations ! -- since they always have the same convention. ! if not Is_Predefined_Dispatching_Operation (Prim_Op) then ! Check_Convention (Prim_Op); end if; Next_Elmt (Prim_Op_Elmt); *************** package body Sem_Ch6 is *** 3605,3611 **** if Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Designator); ! elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then Set_Returns_By_Ref (Designator); end if; end; --- 3927,3933 ---- if Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Designator); ! elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Designator); end if; end; *************** package body Sem_Ch6 is *** 3703,3709 **** -- expanded, so expand now to check conformance. if NewD then ! Analyze_Per_Use_Expression (Expression (New_Discr), New_Discr_Type); end if; --- 4025,4031 ---- -- expanded, so expand now to check conformance. if NewD then ! Preanalyze_Spec_Expression (Expression (New_Discr), New_Discr_Type); end if; *************** package body Sem_Ch6 is *** 3846,3851 **** --- 4168,4180 ---- Error_Msg_NE ("subprogram & overrides inherited operation #", Spec, Subp); end if; + + elsif Is_Subprogram (Subp) then + Set_Is_Overriding_Operation (Subp); + end if; + + if Style_Check and then not Must_Override (Spec) then + Style.Missing_Overriding (Decl, Subp); end if; -- If Subp is an operator, it may override a predefined operation. *************** package body Sem_Ch6 is *** 3854,3879 **** -- signature of Subp matches that of a predefined operator. Note that -- first argument provides the name of the operator, and the second -- argument the signature that may match that of a standard operation. ! elsif Nkind (Subp) = N_Defining_Operator_Symbol ! and then Must_Not_Override (Spec) ! then ! if Operator_Matches_Spec (Subp, Subp) then ! Error_Msg_NE ! ("subprogram & overrides predefined operator ", ! Spec, Subp); ! end if; ! elsif Must_Override (Spec) then ! if Ekind (Subp) = E_Entry then ! Error_Msg_NE ("entry & is not overriding", Spec, Subp); ! elsif Nkind (Subp) = N_Defining_Operator_Symbol then ! if not Operator_Matches_Spec (Subp, Subp) then Error_Msg_NE ! ("subprogram & is not overriding", Spec, Subp); end if; else Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); end if; --- 4183,4227 ---- -- signature of Subp matches that of a predefined operator. Note that -- first argument provides the name of the operator, and the second -- argument the signature that may match that of a standard operation. + -- If the indicator is overriding, then the operator must match a + -- predefined signature, because we know already that there is no + -- explicit overridden operation. ! elsif Nkind (Subp) = N_Defining_Operator_Symbol then ! if Must_Not_Override (Spec) then ! if not Is_Primitive then ! Error_Msg_N ! ("overriding indicator only allowed " ! & "if subprogram is primitive", Subp); ! elsif Operator_Matches_Spec (Subp, Subp) then Error_Msg_NE ! ("subprogram & overrides predefined operator ", Spec, Subp); end if; + elsif Must_Override (Spec) then + if Is_Overriding_Operation (Subp) then + Set_Is_Overriding_Operation (Subp); + + elsif not Operator_Matches_Spec (Subp, Subp) then + Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); + end if; + + elsif not Error_Posted (Subp) + and then Style_Check + and then Operator_Matches_Spec (Subp, Subp) + and then + not Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Subp))) + then + Set_Is_Overriding_Operation (Subp); + Style.Missing_Overriding (Decl, Subp); + end if; + + elsif Must_Override (Spec) then + if Ekind (Subp) = E_Entry then + Error_Msg_NE ("entry & is not overriding", Spec, Subp); else Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); end if; *************** package body Sem_Ch6 is *** 3891,3897 **** Error_Msg_N ("overriding indicator only allowed if subprogram is primitive", Subp); - return; end if; end Check_Overriding_Indicator; --- 4239,4244 ---- *************** package body Sem_Ch6 is *** 4140,4147 **** then null; ! -- A loop with no exit statement or iteration scheme if either ! -- an inifite loop, or it has some other exit (raise/return). -- In either case, no warning is required. else --- 4487,4494 ---- then null; ! -- A loop with no exit statement or iteration scheme is either ! -- an infinite loop, or it has some other exit (raise/return). -- In either case, no warning is required. else *************** package body Sem_Ch6 is *** 4375,4389 **** ------------------------------ procedure Check_Subtype_Conformant ! (New_Id : Entity_Id; ! Old_Id : Entity_Id; ! Err_Loc : Node_Id := Empty) is Result : Boolean; pragma Warnings (Off, Result); begin Check_Conformance ! (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc); end Check_Subtype_Conformant; --------------------------- --- 4722,4738 ---- ------------------------------ procedure Check_Subtype_Conformant ! (New_Id : Entity_Id; ! Old_Id : Entity_Id; ! Err_Loc : Node_Id := Empty; ! Skip_Controlling_Formals : Boolean := False) is Result : Boolean; pragma Warnings (Off, Result); begin Check_Conformance ! (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc, ! Skip_Controlling_Formals => Skip_Controlling_Formals); end Check_Subtype_Conformant; --------------------------- *************** package body Sem_Ch6 is *** 4749,4755 **** end if; -- If this is a derived subprogram then the subtypes of the parent ! -- subprogram's formal parameters will be used to to determine the need -- for extra formals. if Is_Overloadable (E) and then Present (Alias (E)) then --- 5098,5104 ---- end if; -- If this is a derived subprogram then the subtypes of the parent ! -- subprogram's formal parameters will be used to determine the need -- for extra formals. if Is_Overloadable (E) and then Present (Alias (E)) then *************** package body Sem_Ch6 is *** 4898,4904 **** -- can be called in a dispatching context and such calls must be -- handled like calls to a class-wide function. ! if not Is_Constrained (Result_Subt) or else Is_Tagged_Type (Underlying_Type (Result_Subt)) then Discard := --- 5247,5253 ---- -- can be called in a dispatching context and such calls must be -- handled like calls to a class-wide function. ! if not Is_Constrained (Underlying_Type (Result_Subt)) or else Is_Tagged_Type (Underlying_Type (Result_Subt)) then Discard := *************** package body Sem_Ch6 is *** 4919,4931 **** -- returns. This is true even if we are able to get away with -- having 'in out' parameters, which are normally illegal for -- functions. This formal is also needed when the function has ! -- a tagged result, because generally such functions can be called ! -- in a dispatching context and such calls must be handled like ! -- calls to class-wide functions. ! if Controlled_Type (Result_Subt) ! or else Is_Tagged_Type (Underlying_Type (Result_Subt)) ! then Discard := Add_Extra_Formal (E, RTE (RE_Finalizable_Ptr_Ptr), --- 5268,5276 ---- -- returns. This is true even if we are able to get away with -- having 'in out' parameters, which are normally illegal for -- functions. This formal is also needed when the function has ! -- a tagged result. ! if Needs_BIP_Final_List (E) then Discard := Add_Extra_Formal (E, RTE (RE_Finalizable_Ptr_Ptr), *************** package body Sem_Ch6 is *** 4958,4964 **** begin Set_Directly_Designated_Type (Formal_Type, Result_Subt); Set_Etype (Formal_Type, Formal_Type); - Init_Size_Align (Formal_Type); Set_Depends_On_Private (Formal_Type, Has_Private_Component (Formal_Type)); Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type))); --- 5303,5308 ---- *************** package body Sem_Ch6 is *** 5061,5067 **** -- Find_Corresponding_Spec -- ----------------------------- ! function Find_Corresponding_Spec (N : Node_Id) return Entity_Id is Spec : constant Node_Id := Specification (N); Designator : constant Entity_Id := Defining_Entity (Spec); --- 5405,5414 ---- -- Find_Corresponding_Spec -- ----------------------------- ! function Find_Corresponding_Spec ! (N : Node_Id; ! Post_Error : Boolean := True) return Entity_Id ! is Spec : constant Node_Id := Specification (N); Designator : constant Entity_Id := Defining_Entity (Spec); *************** package body Sem_Ch6 is *** 5105,5111 **** end if; if not Has_Completion (E) then - if Nkind (N) /= N_Subprogram_Body_Stub then Set_Corresponding_Spec (N, E); end if; --- 5452,5457 ---- *************** package body Sem_Ch6 is *** 5150,5163 **** return Empty; end if; ! -- If body already exists, this is an error unless the ! -- previous declaration is the implicit declaration of ! -- a derived subprogram, or this is a spurious overloading ! -- in an instance. elsif No (Alias (E)) and then not Is_Intrinsic_Subprogram (E) and then not In_Instance then Error_Msg_Sloc := Sloc (E); if Is_Imported (E) then --- 5496,5510 ---- return Empty; end if; ! -- If the body already exists, then this is an error unless ! -- the previous declaration is the implicit declaration of a ! -- derived subprogram, or this is a spurious overloading in an ! -- instance. elsif No (Alias (E)) and then not Is_Intrinsic_Subprogram (E) and then not In_Instance + and then Post_Error then Error_Msg_Sloc := Sloc (E); if Is_Imported (E) then *************** package body Sem_Ch6 is *** 5169,5184 **** end if; end if; elsif Is_Child_Unit (E) and then Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body and then Nkind (Parent (Unit_Declaration_Node (Designator))) = ! N_Compilation_Unit then - -- Child units cannot be overloaded, so a conformance mismatch - -- between body and a previous spec is an error. - Error_Msg_N ("body of child unit does not match previous declaration", N); end if; --- 5516,5532 ---- end if; end if; + -- Child units cannot be overloaded, so a conformance mismatch + -- between body and a previous spec is an error. + elsif Is_Child_Unit (E) and then Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body and then Nkind (Parent (Unit_Declaration_Node (Designator))) = ! N_Compilation_Unit ! and then Post_Error then Error_Msg_N ("body of child unit does not match previous declaration", N); end if; *************** package body Sem_Ch6 is *** 5674,5679 **** --- 6022,6092 ---- end loop; end Install_Formals; + ----------------------------- + -- Is_Interface_Conformant -- + ----------------------------- + + function Is_Interface_Conformant + (Tagged_Type : Entity_Id; + Iface_Prim : Entity_Id; + Prim : Entity_Id) return Boolean + is + Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim); + Typ : constant Entity_Id := Find_Dispatching_Type (Prim); + + begin + pragma Assert (Is_Subprogram (Iface_Prim) + and then Is_Subprogram (Prim) + and then Is_Dispatching_Operation (Iface_Prim) + and then Is_Dispatching_Operation (Prim)); + + pragma Assert (Is_Interface (Iface) + or else (Present (Alias (Iface_Prim)) + and then + Is_Interface + (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim))))); + + if Prim = Iface_Prim + or else not Is_Subprogram (Prim) + or else Ekind (Prim) /= Ekind (Iface_Prim) + or else not Is_Dispatching_Operation (Prim) + or else Scope (Prim) /= Scope (Tagged_Type) + or else No (Typ) + or else Base_Type (Typ) /= Tagged_Type + or else not Primitive_Names_Match (Iface_Prim, Prim) + then + return False; + + -- Case of a procedure, or a function that does not have a controlling + -- result (I or access I). + + elsif Ekind (Iface_Prim) = E_Procedure + or else Etype (Prim) = Etype (Iface_Prim) + or else not Has_Controlling_Result (Prim) + then + return Type_Conformant (Prim, Iface_Prim, + Skip_Controlling_Formals => True); + + -- Case of a function returning an interface, or an access to one. + -- Check that the return types correspond. + + elsif Implements_Interface (Typ, Iface) then + if (Ekind (Etype (Prim)) = E_Anonymous_Access_Type) + /= + (Ekind (Etype (Iface_Prim)) = E_Anonymous_Access_Type) + then + return False; + else + return + Type_Conformant (Prim, Iface_Prim, + Skip_Controlling_Formals => True); + end if; + + else + return False; + end if; + end Is_Interface_Conformant; + --------------------------------- -- Is_Non_Overriding_Operation -- --------------------------------- *************** package body Sem_Ch6 is *** 6036,6042 **** procedure Check_Synchronized_Overriding (Def_Id : Entity_Id; - First_Hom : Entity_Id; Overridden_Subp : out Entity_Id); -- First determine if Def_Id is an entry or a subprogram either defined -- in the scope of a task or protected type, or is a primitive of such --- 6449,6454 ---- *************** package body Sem_Ch6 is *** 6082,6088 **** procedure Check_Private_Overriding (T : Entity_Id) is begin ! if Ekind (Current_Scope) = E_Package and then In_Private_Part (Current_Scope) and then Visible_Part_Type (T) and then not In_Instance --- 6494,6500 ---- procedure Check_Private_Overriding (T : Entity_Id) is begin ! if Is_Package_Or_Generic_Package (Current_Scope) and then In_Private_Part (Current_Scope) and then Visible_Part_Type (T) and then not In_Instance *************** package body Sem_Ch6 is *** 6167,6174 **** elsif Current_Scope = Standard_Standard then null; ! elsif ((Ekind (Current_Scope) = E_Package ! or else Ekind (Current_Scope) = E_Generic_Package) and then not In_Package_Body (Current_Scope)) or else Is_Overriding then --- 6579,6585 ---- elsif Current_Scope = Standard_Standard then null; ! elsif (Is_Package_Or_Generic_Package (Current_Scope) and then not In_Package_Body (Current_Scope)) or else Is_Overriding then *************** package body Sem_Ch6 is *** 6231,6252 **** procedure Check_Synchronized_Overriding (Def_Id : Entity_Id; - First_Hom : Entity_Id; Overridden_Subp : out Entity_Id) is - Formal_Typ : Entity_Id; Ifaces_List : Elist_Id; In_Scope : Boolean; Typ : Entity_Id; begin Overridden_Subp := Empty; ! -- Def_Id must be an entry or a subprogram ! if Ekind (Def_Id) /= E_Entry ! and then Ekind (Def_Id) /= E_Function ! and then Ekind (Def_Id) /= E_Procedure then return; end if; --- 6642,6800 ---- procedure Check_Synchronized_Overriding (Def_Id : Entity_Id; Overridden_Subp : out Entity_Id) is Ifaces_List : Elist_Id; In_Scope : Boolean; Typ : Entity_Id; + function Matches_Prefixed_View_Profile + (Prim_Params : List_Id; + Iface_Params : List_Id) return Boolean; + -- Determine whether a subprogram's parameter profile Prim_Params + -- matches that of a potentially overridden interface subprogram + -- Iface_Params. Also determine if the type of first parameter of + -- Iface_Params is an implemented interface. + + ----------------------------------- + -- Matches_Prefixed_View_Profile -- + ----------------------------------- + + function Matches_Prefixed_View_Profile + (Prim_Params : List_Id; + Iface_Params : List_Id) return Boolean + is + Iface_Id : Entity_Id; + Iface_Param : Node_Id; + Iface_Typ : Entity_Id; + Prim_Id : Entity_Id; + Prim_Param : Node_Id; + Prim_Typ : Entity_Id; + + function Is_Implemented + (Ifaces_List : Elist_Id; + Iface : Entity_Id) return Boolean; + -- Determine if Iface is implemented by the current task or + -- protected type. + + -------------------- + -- Is_Implemented -- + -------------------- + + function Is_Implemented + (Ifaces_List : Elist_Id; + Iface : Entity_Id) return Boolean + is + Iface_Elmt : Elmt_Id; + + begin + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + if Node (Iface_Elmt) = Iface then + return True; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + + return False; + end Is_Implemented; + + -- Start of processing for Matches_Prefixed_View_Profile + + begin + Iface_Param := First (Iface_Params); + Iface_Typ := Etype (Defining_Identifier (Iface_Param)); + + if Is_Access_Type (Iface_Typ) then + Iface_Typ := Designated_Type (Iface_Typ); + end if; + + Prim_Param := First (Prim_Params); + + -- The first parameter of the potentially overridden subprogram + -- must be an interface implemented by Prim. + + if not Is_Interface (Iface_Typ) + or else not Is_Implemented (Ifaces_List, Iface_Typ) + then + return False; + end if; + + -- The checks on the object parameters are done, move onto the + -- rest of the parameters. + + if not In_Scope then + Prim_Param := Next (Prim_Param); + end if; + + Iface_Param := Next (Iface_Param); + while Present (Iface_Param) and then Present (Prim_Param) loop + Iface_Id := Defining_Identifier (Iface_Param); + Iface_Typ := Find_Parameter_Type (Iface_Param); + + Prim_Id := Defining_Identifier (Prim_Param); + Prim_Typ := Find_Parameter_Type (Prim_Param); + + if Ekind (Iface_Typ) = E_Anonymous_Access_Type + and then Ekind (Prim_Typ) = E_Anonymous_Access_Type + and then Is_Concurrent_Type (Designated_Type (Prim_Typ)) + then + Iface_Typ := Designated_Type (Iface_Typ); + Prim_Typ := Designated_Type (Prim_Typ); + end if; + + -- Case of multiple interface types inside a parameter profile + + -- (Obj_Param : in out Iface; ...; Param : Iface) + + -- If the interface type is implemented, then the matching type + -- in the primitive should be the implementing record type. + + if Ekind (Iface_Typ) = E_Record_Type + and then Is_Interface (Iface_Typ) + and then Is_Implemented (Ifaces_List, Iface_Typ) + then + if Prim_Typ /= Typ then + return False; + end if; + + -- The two parameters must be both mode and subtype conformant + + elsif Ekind (Iface_Id) /= Ekind (Prim_Id) + or else not + Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant) + then + return False; + end if; + + Next (Iface_Param); + Next (Prim_Param); + end loop; + + -- One of the two lists contains more parameters than the other + + if Present (Iface_Param) or else Present (Prim_Param) then + return False; + end if; + + return True; + end Matches_Prefixed_View_Profile; + + -- Start of processing for Check_Synchronized_Overriding + begin Overridden_Subp := Empty; ! -- Def_Id must be an entry or a subprogram. We should skip predefined ! -- primitives internally generated by the frontend; however at this ! -- stage predefined primitives are still not fully decorated. As a ! -- minor optimization we skip here internally generated subprograms. ! if (Ekind (Def_Id) /= E_Entry ! and then Ekind (Def_Id) /= E_Function ! and then Ekind (Def_Id) /= E_Procedure) ! or else not Comes_From_Source (Def_Id) then return; end if; *************** package body Sem_Ch6 is *** 6262,6276 **** Typ := Scope (Def_Id); In_Scope := True; ! -- The subprogram may be a primitive of a concurrent type ! elsif Present (First_Formal (Def_Id)) then ! Formal_Typ := Etype (First_Formal (Def_Id)); ! if Is_Concurrent_Type (Formal_Typ) ! and then not Is_Generic_Actual_Type (Formal_Typ) then - Typ := Formal_Typ; In_Scope := False; -- This case occurs when the concurrent type is declared within --- 6810,6834 ---- Typ := Scope (Def_Id); In_Scope := True; ! -- The enclosing scope is not a synchronized type and the subprogram ! -- has no formals ! elsif No (First_Formal (Def_Id)) then ! return; ! -- The subprogram has formals and hence it may be a primitive of a ! -- concurrent type ! ! else ! Typ := Etype (First_Formal (Def_Id)); ! ! if Is_Access_Type (Typ) then ! Typ := Directly_Designated_Type (Typ); ! end if; ! ! if Is_Concurrent_Type (Typ) ! and then not Is_Generic_Actual_Type (Typ) then In_Scope := False; -- This case occurs when the concurrent type is declared within *************** package body Sem_Ch6 is *** 6278,6314 **** -- built and used as the type of the first formal, we just have -- to retrieve the corresponding concurrent type. ! elsif Is_Concurrent_Record_Type (Formal_Typ) ! and then Present (Corresponding_Concurrent_Type (Formal_Typ)) then ! Typ := Corresponding_Concurrent_Type (Formal_Typ); In_Scope := False; else return; end if; ! else return; end if; ! -- Gather all limited, protected and task interfaces that Typ ! -- implements. There is no overriding to check if is an inherited ! -- operation in a type derivation on for a generic actual. ! if Nkind (Parent (Typ)) /= N_Full_Type_Declaration ! and then ! not Nkind_In (Parent (Def_Id), N_Subtype_Declaration, ! N_Task_Type_Declaration, ! N_Protected_Type_Declaration) ! then ! Collect_Abstract_Interfaces (Typ, Ifaces_List); ! if not Is_Empty_Elmt_List (Ifaces_List) then ! Overridden_Subp := ! Find_Overridden_Synchronized_Primitive ! (Def_Id, First_Hom, Ifaces_List, In_Scope); end if; ! end if; end Check_Synchronized_Overriding; ---------------------------- --- 6836,6990 ---- -- built and used as the type of the first formal, we just have -- to retrieve the corresponding concurrent type. ! elsif Is_Concurrent_Record_Type (Typ) ! and then Present (Corresponding_Concurrent_Type (Typ)) then ! Typ := Corresponding_Concurrent_Type (Typ); In_Scope := False; else return; end if; ! end if; ! ! -- There is no overriding to check if is an inherited operation in a ! -- type derivation on for a generic actual. ! ! Collect_Interfaces (Typ, Ifaces_List); ! ! if Is_Empty_Elmt_List (Ifaces_List) then return; end if; ! -- Determine whether entry or subprogram Def_Id overrides a primitive ! -- operation that belongs to one of the interfaces in Ifaces_List. ! declare ! Candidate : Entity_Id := Empty; ! Hom : Entity_Id := Empty; ! Iface_Typ : Entity_Id; ! Subp : Entity_Id := Empty; ! begin ! -- Traverse the homonym chain, looking at a potentially ! -- overridden subprogram that belongs to an implemented ! -- interface. ! ! Hom := Current_Entity_In_Scope (Def_Id); ! while Present (Hom) loop ! Subp := Hom; ! ! if Subp = Def_Id ! or else not Is_Overloadable (Subp) ! or else not Is_Primitive (Subp) ! or else not Is_Dispatching_Operation (Subp) ! or else not Is_Interface (Find_Dispatching_Type (Subp)) ! then ! null; ! ! -- Entries and procedures can override abstract or null ! -- interface procedures ! ! elsif (Ekind (Def_Id) = E_Procedure ! or else Ekind (Def_Id) = E_Entry) ! and then Ekind (Subp) = E_Procedure ! and then Matches_Prefixed_View_Profile ! (Parameter_Specifications (Parent (Def_Id)), ! Parameter_Specifications (Parent (Subp))) ! then ! Candidate := Subp; ! ! -- For an overridden subprogram Subp, check whether the mode ! -- of its first parameter is correct depending on the kind ! -- of synchronized type. ! ! declare ! Formal : constant Node_Id := First_Formal (Candidate); ! ! begin ! -- In order for an entry or a protected procedure to ! -- override, the first parameter of the overridden ! -- routine must be of mode "out", "in out" or ! -- access-to-variable. ! ! if (Ekind (Candidate) = E_Entry ! or else Ekind (Candidate) = E_Procedure) ! and then Is_Protected_Type (Typ) ! and then Ekind (Formal) /= E_In_Out_Parameter ! and then Ekind (Formal) /= E_Out_Parameter ! and then Nkind (Parameter_Type (Parent (Formal))) ! /= N_Access_Definition ! then ! null; ! ! -- All other cases are OK since a task entry or routine ! -- does not have a restriction on the mode of the first ! -- parameter of the overridden interface routine. ! ! else ! Overridden_Subp := Candidate; ! return; ! end if; ! end; ! ! -- Functions can override abstract interface functions ! ! elsif Ekind (Def_Id) = E_Function ! and then Ekind (Subp) = E_Function ! and then Matches_Prefixed_View_Profile ! (Parameter_Specifications (Parent (Def_Id)), ! Parameter_Specifications (Parent (Subp))) ! and then Etype (Result_Definition (Parent (Def_Id))) = ! Etype (Result_Definition (Parent (Subp))) ! then ! Overridden_Subp := Subp; ! return; ! end if; ! ! Hom := Homonym (Hom); ! end loop; ! ! -- After examining all candidates for overriding, we are ! -- left with the best match which is a mode incompatible ! -- interface routine. Do not emit an error if the Expander ! -- is active since this error will be detected later on ! -- after all concurrent types are expanded and all wrappers ! -- are built. This check is meant for spec-only ! -- compilations. ! ! if Present (Candidate) ! and then not Expander_Active ! then ! Iface_Typ := ! Find_Parameter_Type (Parent (First_Formal (Candidate))); ! ! -- Def_Id is primitive of a protected type, declared ! -- inside the type, and the candidate is primitive of a ! -- limited or synchronized interface. ! ! if In_Scope ! and then Is_Protected_Type (Typ) ! and then ! (Is_Limited_Interface (Iface_Typ) ! or else Is_Protected_Interface (Iface_Typ) ! or else Is_Synchronized_Interface (Iface_Typ) ! or else Is_Task_Interface (Iface_Typ)) ! then ! -- Must reword this message, comma before to in -gnatj ! -- mode ??? ! ! Error_Msg_NE ! ("first formal of & must be of mode `OUT`, `IN OUT`" ! & " or access-to-variable", Typ, Candidate); ! Error_Msg_N ! ("\to be overridden by protected procedure or entry " ! & "(RM 9.4(11.9/2))", Typ); ! end if; end if; ! ! Overridden_Subp := Candidate; ! return; ! end; end Check_Synchronized_Overriding; ---------------------------- *************** package body Sem_Ch6 is *** 6361,6367 **** -- has an overriding indicator. if Comes_From_Source (S) then ! Check_Synchronized_Overriding (S, Homonym (S), Overridden_Subp); Check_Overriding_Indicator (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp); end if; --- 7037,7043 ---- -- has an overriding indicator. if Comes_From_Source (S) then ! Check_Synchronized_Overriding (S, Overridden_Subp); Check_Overriding_Indicator (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp); end if; *************** package body Sem_Ch6 is *** 6410,6416 **** else Error_Msg_Sloc := Sloc (E); ! -- Generate message,with useful additionalwarning if in generic if Is_Generic_Unit (E) then Error_Msg_N ("previous generic unit cannot be overloaded", S); --- 7086,7092 ---- else Error_Msg_Sloc := Sloc (E); ! -- Generate message, with useful additional warning if in generic if Is_Generic_Unit (E) then Error_Msg_N ("previous generic unit cannot be overloaded", S); *************** package body Sem_Ch6 is *** 6434,6445 **** and then Is_Dispatching_Operation (Alias (S)) and then Present (Find_Dispatching_Type (Alias (S))) and then Is_Interface (Find_Dispatching_Type (Alias (S))) - and then not Is_Predefined_Dispatching_Operation (Alias (S)) then goto Add_New_Entity; end if; ! Check_Synchronized_Overriding (S, E, Overridden_Subp); -- Loop through E and its homonyms to determine if any of them is -- the candidate for overriding by S. --- 7110,7120 ---- and then Is_Dispatching_Operation (Alias (S)) and then Present (Find_Dispatching_Type (Alias (S))) and then Is_Interface (Find_Dispatching_Type (Alias (S))) then goto Add_New_Entity; end if; ! Check_Synchronized_Overriding (S, Overridden_Subp); -- Loop through E and its homonyms to determine if any of them is -- the candidate for overriding by S. *************** package body Sem_Ch6 is *** 6461,6469 **** -- There are some cases when both can be implicit, for example -- when both a literal and a function that overrides it are ! -- inherited in a derivation, or when an inhertited operation -- of a tagged full type overrides the inherited operation of ! -- a private extension. Ada 83 had a special rule for the the -- literal case. In Ada95, the later implicit operation hides -- the former, and the literal is always the former. In the -- odd case where both are derived operations declared at the --- 7136,7144 ---- -- There are some cases when both can be implicit, for example -- when both a literal and a function that overrides it are ! -- inherited in a derivation, or when an inherited operation -- of a tagged full type overrides the inherited operation of ! -- a private extension. Ada 83 had a special rule for the -- literal case. In Ada95, the later implicit operation hides -- the former, and the literal is always the former. In the -- odd case where both are derived operations declared at the *************** package body Sem_Ch6 is *** 6832,6840 **** Default : Node_Id; Ptype : Entity_Id; - -- The following are used for setting Is_Only_Out_ Num_Out_Params : Nat := 0; First_Out_Param : Entity_Id := Empty; function Is_Class_Wide_Default (D : Node_Id) return Boolean; -- Check whether the default has a class-wide type. After analysis the --- 7507,7515 ---- Default : Node_Id; Ptype : Entity_Id; Num_Out_Params : Nat := 0; First_Out_Param : Entity_Id := Empty; + -- Used for setting Is_Only_Out_Parameter function Is_Class_Wide_Default (D : Node_Id) return Boolean; -- Check whether the default has a class-wide type. After analysis the *************** package body Sem_Ch6 is *** 6994,7000 **** -- Do the special preanalysis of the expression (see section on -- "Handling of Default Expressions" in the spec of package Sem). ! Analyze_Per_Use_Expression (Default, Formal_Type); -- An access to constant cannot be the default for -- an access parameter that is an access to variable. --- 7669,7675 ---- -- Do the special preanalysis of the expression (see section on -- "Handling of Default Expressions" in the spec of package Sem). ! Preanalyze_Spec_Expression (Default, Formal_Type); -- An access to constant cannot be the default for -- an access parameter that is an access to variable. *************** package body Sem_Ch6 is *** 7092,7097 **** --- 7767,7989 ---- end if; end Process_Formals; + ------------------ + -- Process_PPCs -- + ------------------ + + procedure Process_PPCs + (N : Node_Id; + Spec_Id : Entity_Id; + Body_Id : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Prag : Node_Id; + Plist : List_Id := No_List; + Subp : Entity_Id; + Parms : List_Id; + + function Grab_PPC (Nam : Name_Id) return Node_Id; + -- Prag contains an analyzed precondition or postcondition pragma. + -- This function copies the pragma, changes it to the corresponding + -- Check pragma and returns the Check pragma as the result. The + -- argument Nam is either Name_Precondition or Name_Postcondition. + + -------------- + -- Grab_PPC -- + -------------- + + function Grab_PPC (Nam : Name_Id) return Node_Id is + CP : constant Node_Id := New_Copy_Tree (Prag); + + begin + -- Set Analyzed to false, since we want to reanalyze the check + -- procedure. Note that it is only at the outer level that we + -- do this fiddling, for the spec cases, the already preanalyzed + -- parameters are not affected. + + -- For a postcondition pragma within a generic, preserve the pragma + -- for later expansion. + + Set_Analyzed (CP, False); + + if Nam = Name_Postcondition + and then not Expander_Active + then + return CP; + end if; + + -- Change pragma into corresponding pragma Check + + Prepend_To (Pragma_Argument_Associations (CP), + Make_Pragma_Argument_Association (Sloc (Prag), + Expression => + Make_Identifier (Loc, + Chars => Nam))); + Set_Pragma_Identifier (CP, + Make_Identifier (Sloc (Prag), + Chars => Name_Check)); + + return CP; + end Grab_PPC; + + -- Start of processing for Process_PPCs + + begin + -- Nothing to do if we are not generating code + + if Operating_Mode /= Generate_Code then + return; + end if; + + -- Grab preconditions from spec + + if Present (Spec_Id) then + + -- Loop through PPC pragmas from spec. Note that preconditions from + -- the body will be analyzed and converted when we scan the body + -- declarations below. + + Prag := Spec_PPC_List (Spec_Id); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Precondition + and then PPC_Enabled (Prag) + then + -- Add pragma Check at the start of the declarations of N. + -- Note that this processing reverses the order of the list, + -- which is what we want since new entries were chained to + -- the head of the list. + + Prepend (Grab_PPC (Name_Precondition), Declarations (N)); + end if; + + Prag := Next_Pragma (Prag); + end loop; + end if; + + -- Build postconditions procedure if needed and prepend the following + -- declaration to the start of the declarations for the subprogram. + + -- procedure _postconditions [(_Result : resulttype)] is + -- begin + -- pragma Check (Postcondition, condition [,message]); + -- pragma Check (Postcondition, condition [,message]); + -- ... + -- end; + + -- First we deal with the postconditions in the body + + if Is_Non_Empty_List (Declarations (N)) then + + -- Loop through declarations + + Prag := First (Declarations (N)); + while Present (Prag) loop + if Nkind (Prag) = N_Pragma then + + -- If pragma, capture if enabled postcondition, else ignore + + if Pragma_Name (Prag) = Name_Postcondition + and then Check_Enabled (Name_Postcondition) + then + if Plist = No_List then + Plist := Empty_List; + end if; + + Analyze (Prag); + + -- If expansion is disabled, as in a generic unit, + -- save pragma for later expansion. + + if not Expander_Active then + Prepend (Grab_PPC (Name_Postcondition), Declarations (N)); + else + Append (Grab_PPC (Name_Postcondition), Plist); + end if; + end if; + + Next (Prag); + + -- Not a pragma, if comes from source, then end scan + + elsif Comes_From_Source (Prag) then + exit; + + -- Skip stuff not coming from source + + else + Next (Prag); + end if; + end loop; + end if; + + -- Now deal with any postconditions from the spec + + if Present (Spec_Id) then + + -- Loop through PPC pragmas from spec + + Prag := Spec_PPC_List (Spec_Id); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Postcondition + and then PPC_Enabled (Prag) + then + if Plist = No_List then + Plist := Empty_List; + end if; + + if not Expander_Active then + Prepend (Grab_PPC (Name_Postcondition), Declarations (N)); + else + Append (Grab_PPC (Name_Postcondition), Plist); + end if; + end if; + + Prag := Next_Pragma (Prag); + end loop; + end if; + + -- If we had any postconditions and expansion is enabled, build + -- the Postconditions procedure. + + if Present (Plist) + and then Expander_Active + then + Subp := Defining_Entity (N); + + if Etype (Subp) /= Standard_Void_Type then + Parms := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Name_uResult), + Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc))); + else + Parms := No_List; + end if; + + Prepend_To (Declarations (N), + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_uPostconditions), + Parameter_Specifications => Parms), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Plist))); + + if Present (Spec_Id) then + Set_Has_Postconditions (Spec_Id); + else + Set_Has_Postconditions (Body_Id); + end if; + end if; + end Process_PPCs; + ---------------------------- -- Reference_Body_Formals -- ---------------------------- *************** package body Sem_Ch6 is *** 7137,7143 **** AS_Needed : Boolean; begin ! -- If this is an emtpy initialization procedure, no need to create -- actual subtypes (small optimization). if Ekind (Subp) = E_Procedure --- 8029,8035 ---- AS_Needed : Boolean; begin ! -- If this is an empty initialization procedure, no need to create -- actual subtypes (small optimization). if Ekind (Subp) = E_Procedure *************** package body Sem_Ch6 is *** 7361,7370 **** -- Subtype_Conformant -- ------------------------ ! function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is Result : Boolean; begin ! Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result); return Result; end Subtype_Conformant; --- 8253,8267 ---- -- Subtype_Conformant -- ------------------------ ! function Subtype_Conformant ! (New_Id : Entity_Id; ! Old_Id : Entity_Id; ! Skip_Controlling_Formals : Boolean := False) return Boolean ! is Result : Boolean; begin ! Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result, ! Skip_Controlling_Formals => Skip_Controlling_Formals); return Result; end Subtype_Conformant; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch6.ads gcc-4.4.0/gcc/ada/sem_ch6.ads *** gcc-4.3.3/gcc/ada/sem_ch6.ads Thu Dec 13 10:28:24 2007 --- gcc-4.4.0/gcc/ada/sem_ch6.ads Wed Jul 30 15:53:21 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Sem_Ch6 is *** 78,84 **** (New_Id : Entity_Id; Old_Id : Entity_Id; Err_Loc : Node_Id := Empty); ! -- Check that two callable entitites (subprograms, entries, literals) -- are fully conformant, post error message if not (RM 6.3.1(17)) with -- the flag being placed on the Err_Loc node if it is specified, and -- on the appropriate component of the New_Id construct if not. Note: --- 78,84 ---- (New_Id : Entity_Id; Old_Id : Entity_Id; Err_Loc : Node_Id := Empty); ! -- Check that two callable entities (subprograms, entries, literals) -- are fully conformant, post error message if not (RM 6.3.1(17)) with -- the flag being placed on the Err_Loc node if it is specified, and -- on the appropriate component of the New_Id construct if not. Note: *************** package Sem_Ch6 is *** 92,98 **** Old_Id : Entity_Id; Err_Loc : Node_Id := Empty; Get_Inst : Boolean := False); ! -- Check that two callable entitites (subprograms, entries, literals) -- are mode conformant, post error message if not (RM 6.3.1(15)) with -- the flag being placed on the Err_Loc node if it is specified, and -- on the appropriate component of the New_Id construct if not. The --- 92,98 ---- Old_Id : Entity_Id; Err_Loc : Node_Id := Empty; Get_Inst : Boolean := False); ! -- Check that two callable entities (subprograms, entries, literals) -- are mode conformant, post error message if not (RM 6.3.1(15)) with -- the flag being placed on the Err_Loc node if it is specified, and -- on the appropriate component of the New_Id construct if not. The *************** package Sem_Ch6 is *** 100,110 **** -- formal access-to-subprogram type, indicating that mapping of types -- is needed. procedure Check_Subtype_Conformant ! (New_Id : Entity_Id; ! Old_Id : Entity_Id; ! Err_Loc : Node_Id := Empty); ! -- Check that two callable entitites (subprograms, entries, literals) -- are subtype conformant, post error message if not (RM 6.3.1(16)) -- the flag being placed on the Err_Loc node if it is specified, and -- on the appropriate component of the New_Id construct if not. --- 100,121 ---- -- formal access-to-subprogram type, indicating that mapping of types -- is needed. + procedure Check_Overriding_Indicator + (Subp : Entity_Id; + Overridden_Subp : Entity_Id; + Is_Primitive : Boolean); + -- Verify the consistency of an overriding_indicator given for subprogram + -- declaration, body, renaming, or instantiation. Overridden_Subp is set + -- if the scope where we are introducing the subprogram contains a + -- type-conformant subprogram that becomes hidden by the new subprogram. + -- Is_Primitive indicates whether the subprogram is primitive. + procedure Check_Subtype_Conformant ! (New_Id : Entity_Id; ! Old_Id : Entity_Id; ! Err_Loc : Node_Id := Empty; ! Skip_Controlling_Formals : Boolean := False); ! -- Check that two callable entities (subprograms, entries, literals) -- are subtype conformant, post error message if not (RM 6.3.1(16)) -- the flag being placed on the Err_Loc node if it is specified, and -- on the appropriate component of the New_Id construct if not. *************** package Sem_Ch6 is *** 113,119 **** (New_Id : Entity_Id; Old_Id : Entity_Id; Err_Loc : Node_Id := Empty); ! -- Check that two callable entitites (subprograms, entries, literals) -- are type conformant, post error message if not (RM 6.3.1(14)) with -- the flag being placed on the Err_Loc node if it is specified, and -- on the appropriate component of the New_Id construct if not. --- 124,130 ---- (New_Id : Entity_Id; Old_Id : Entity_Id; Err_Loc : Node_Id := Empty); ! -- Check that two callable entities (subprograms, entries, literals) -- are type conformant, post error message if not (RM 6.3.1(14)) with -- the flag being placed on the Err_Loc node if it is specified, and -- on the appropriate component of the New_Id construct if not. *************** package Sem_Ch6 is *** 125,132 **** Get_Inst : Boolean := False) return Boolean; -- Check that the types of two formal parameters are conforming. In most -- cases this is just a name comparison, but within an instance it involves ! -- generic actual types, and in the presence of anonymous access types ! -- it must examine the designated types. procedure Create_Extra_Formals (E : Entity_Id); -- For each parameter of a subprogram or entry that requires an additional --- 136,143 ---- Get_Inst : Boolean := False) return Boolean; -- Check that the types of two formal parameters are conforming. In most -- cases this is just a name comparison, but within an instance it involves ! -- generic actual types, and in the presence of anonymous access types it ! -- must examine the designated types. procedure Create_Extra_Formals (E : Entity_Id); -- For each parameter of a subprogram or entry that requires an additional *************** package Sem_Ch6 is *** 136,142 **** -- the end of Subp's parameter list (with each subsequent extra formal -- being attached to the preceding extra formal). ! function Find_Corresponding_Spec (N : Node_Id) return Entity_Id; -- Use the subprogram specification in the body to retrieve the previous -- subprogram declaration, if any. --- 147,155 ---- -- the end of Subp's parameter list (with each subsequent extra formal -- being attached to the preceding extra formal). ! function Find_Corresponding_Spec ! (N : Node_Id; ! Post_Error : Boolean := True) return Entity_Id; -- Use the subprogram specification in the body to retrieve the previous -- subprogram declaration, if any. *************** package Sem_Ch6 is *** 146,163 **** function Fully_Conformant_Expressions (Given_E1 : Node_Id; ! Given_E2 : Node_Id) ! return Boolean; -- Determines if two (non-empty) expressions are fully conformant -- as defined by (RM 6.3.1(18-21)) function Fully_Conformant_Discrete_Subtypes (Given_S1 : Node_Id; ! Given_S2 : Node_Id) ! return Boolean; -- Determines if two subtype definitions are fully conformant. Used -- for entry family conformance checks (RM 6.3.1 (24)). function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; -- Determine whether two callable entities (subprograms, entries, -- literals) are mode conformant (RM 6.3.1(15)) --- 159,189 ---- function Fully_Conformant_Expressions (Given_E1 : Node_Id; ! Given_E2 : Node_Id) return Boolean; -- Determines if two (non-empty) expressions are fully conformant -- as defined by (RM 6.3.1(18-21)) function Fully_Conformant_Discrete_Subtypes (Given_S1 : Node_Id; ! Given_S2 : Node_Id) return Boolean; -- Determines if two subtype definitions are fully conformant. Used -- for entry family conformance checks (RM 6.3.1 (24)). + procedure Install_Formals (Id : Entity_Id); + -- On entry to a subprogram body, make the formals visible. Note that + -- simply placing the subprogram on the scope stack is not sufficient: + -- the formals must become the current entities for their names. This + -- procedure is also used to get visibility to the formals when analyzing + -- preconditions and postconditions appearing in the spec. + + function Is_Interface_Conformant + (Tagged_Type : Entity_Id; + Iface_Prim : Entity_Id; + Prim : Entity_Id) return Boolean; + -- Returns true if both primitives have a matching name and they are also + -- type conformant. Special management is done for functions returning + -- interfaces. + function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; -- Determine whether two callable entities (subprograms, entries, -- literals) are mode conformant (RM 6.3.1(15)) *************** package Sem_Ch6 is *** 197,203 **** procedure Set_Formal_Mode (Formal_Id : Entity_Id); -- Set proper Ekind to reflect formal mode (in, out, in out) ! function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; -- Determine whether two callable entities (subprograms, entries, -- literals) are subtype conformant (RM6.3.1(16)). --- 223,232 ---- procedure Set_Formal_Mode (Formal_Id : Entity_Id); -- Set proper Ekind to reflect formal mode (in, out, in out) ! function Subtype_Conformant ! (New_Id : Entity_Id; ! Old_Id : Entity_Id; ! Skip_Controlling_Formals : Boolean := False) return Boolean; -- Determine whether two callable entities (subprograms, entries, -- literals) are subtype conformant (RM6.3.1(16)). diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch7.adb gcc-4.4.0/gcc/ada/sem_ch7.adb *** gcc-4.3.3/gcc/ada/sem_ch7.adb Thu Dec 13 10:22:06 2007 --- gcc-4.4.0/gcc/ada/sem_ch7.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Sem_Ch8; use Sem_Ch8; *** 51,56 **** --- 51,57 ---- with Sem_Ch10; use Sem_Ch10; with Sem_Ch12; use Sem_Ch12; with Sem_Disp; use Sem_Disp; + with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Snames; use Snames; *************** package body Sem_Ch7 is *** 99,110 **** -- created at the beginning of the corresponding package body and inserted -- before other body declarations. - procedure Inspect_Deferred_Constant_Completion (Decls : List_Id); - -- Examines the deferred constants in the private part of the package - -- specification, or in a package body. Emits the error message - -- "constant declaration requires initialization expression" if not - -- completed by an Import pragma. - procedure Install_Package_Entity (Id : Entity_Id); -- Supporting procedure for Install_{Visible,Private}_Declarations. -- Places one entity on its visibility chain, and recurses on the visible --- 100,105 ---- *************** package body Sem_Ch7 is *** 757,762 **** --- 752,763 ---- -- private_with_clauses, and remove them at the end of the nested -- package. + procedure Analyze_PPCs (Decls : List_Id); + -- Given a list of declarations, go through looking for subprogram + -- specs, and for each one found, analyze any pre/postconditions that + -- are chained to the spec. This is the implementation of the late + -- visibility analysis for preconditions and postconditions in specs. + procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id); -- Clears constant indications (Never_Set_In_Source, Constant_Value, -- and Is_True_Constant) on all variables that are entities of Id, *************** package body Sem_Ch7 is *** 785,790 **** --- 786,818 ---- -- private part rather than being done in Sem_Ch12.Install_Parent -- (which is where the parents' visible declarations are installed). + ------------------ + -- Analyze_PPCs -- + ------------------ + + procedure Analyze_PPCs (Decls : List_Id) is + Decl : Node_Id; + Spec : Node_Id; + Sent : Entity_Id; + Prag : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) loop + if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then + Spec := Specification (Original_Node (Decl)); + Sent := Defining_Unit_Name (Spec); + Prag := Spec_PPC_List (Sent); + while Present (Prag) loop + Analyze_PPC_In_Decl_Part (Prag, Sent); + Prag := Next_Pragma (Prag); + end loop; + end if; + + Next (Decl); + end loop; + end Analyze_PPCs; + --------------------- -- Clear_Constants -- --------------------- *************** package body Sem_Ch7 is *** 819,828 **** Set_Is_Known_Non_Null (E, False); end if; ! elsif Ekind (E) = E_Package ! or else ! Ekind (E) = E_Generic_Package ! then Clear_Constants (E, First_Entity (E)); Clear_Constants (E, First_Private_Entity (E)); end if; --- 847,853 ---- Set_Is_Known_Non_Null (E, False); end if; ! elsif Is_Package_Or_Generic_Package (E) then Clear_Constants (E, First_Entity (E)); Clear_Constants (E, First_Private_Entity (E)); end if; *************** package body Sem_Ch7 is *** 937,942 **** --- 962,968 ---- begin Inst_Par := Inst_Id; + Gen_Par := Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par))); while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop *************** package body Sem_Ch7 is *** 963,973 **** -- happens when a generic child is instantiated, and the -- instance is a child of the parent instance. ! -- Installing the use clauses of the parent instance twice is ! -- both unnecessary and wrong, because it would cause the ! -- clauses to be chained to themselves in the use clauses list ! -- of the scope stack entry. That in turn would cause ! -- End_Use_Clauses to get into an endless look upon scope exit. if Present (Gen_Par) then if not In_Private_Part (Inst_Par) then --- 989,1006 ---- -- happens when a generic child is instantiated, and the -- instance is a child of the parent instance. ! -- Installing the use clauses of the parent instance twice ! -- is both unnecessary and wrong, because it would cause the ! -- clauses to be chained to themselves in the use clauses ! -- list of the scope stack entry. That in turn would cause ! -- an endless loop from End_Use_Clauses upon scope exit. ! ! -- The parent is now fully visible. It may be a hidden open ! -- scope if we are currently compiling some child instance ! -- declared within it, but while the current instance is being ! -- compiled the parent is immediately visible. In particular ! -- its entities must remain visible if a stack save/restore ! -- takes place through a call to Rtsfind. if Present (Gen_Par) then if not In_Private_Part (Inst_Par) then *************** package body Sem_Ch7 is *** 975,980 **** --- 1008,1014 ---- Set_Use (Private_Declarations (Specification (Unit_Declaration_Node (Inst_Par)))); + Set_Is_Hidden_Open_Scope (Inst_Par, False); end if; -- If we've reached the end of the generic instance parents, *************** package body Sem_Ch7 is *** 1008,1013 **** --- 1042,1048 ---- begin if Present (Vis_Decls) then Analyze_Declarations (Vis_Decls); + Analyze_PPCs (Vis_Decls); end if; -- Verify that incomplete types have received full declarations *************** package body Sem_Ch7 is *** 1107,1114 **** declare Comp_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); begin ! if (Ekind (Comp_Unit) = E_Package ! or else Ekind (Comp_Unit) = E_Generic_Package) and then not In_Private_Part (Comp_Unit) and then not In_Instance then --- 1142,1148 ---- declare Comp_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); begin ! if Is_Package_Or_Generic_Package (Comp_Unit) and then not In_Private_Part (Comp_Unit) and then not In_Instance then *************** package body Sem_Ch7 is *** 1143,1148 **** --- 1177,1183 ---- end if; Analyze_Declarations (Priv_Decls); + Analyze_PPCs (Priv_Decls); -- Check the private declarations for incomplete deferred constants *************** package body Sem_Ch7 is *** 1269,1276 **** Set_Is_Pure (Id, PF); Init_Size_Align (Id); ! if (Ekind (Current_Scope) /= E_Package ! and then Ekind (Current_Scope) /= E_Generic_Package) or else In_Private_Part (Current_Scope) then Error_Msg_N ("invalid context for private declaration", N); --- 1304,1310 ---- Set_Is_Pure (Id, PF); Init_Size_Align (Id); ! if not Is_Package_Or_Generic_Package (Current_Scope) or else In_Private_Part (Current_Scope) then Error_Msg_N ("invalid context for private declaration", N); *************** package body Sem_Ch7 is *** 1336,1348 **** Formal : Entity_Id; begin ! if Etype (S) = T then return True; else Formal := First_Formal (S); while Present (Formal) loop ! if Etype (Formal) = T then return True; end if; --- 1370,1386 ---- Formal : Entity_Id; begin ! -- If the full view is a scalar type, the type is the anonymous ! -- base type, but the operation mentions the first subtype, so ! -- check the signature against the base type. ! ! if Base_Type (Etype (S)) = Base_Type (T) then return True; else Formal := First_Formal (S); while Present (Formal) loop ! if Base_Type (Etype (Formal)) = Base_Type (T) then return True; end if; *************** package body Sem_Ch7 is *** 1418,1423 **** --- 1456,1462 ---- Replace_Elmt (Op_Elmt, New_Op); Remove_Elmt (Op_List, Op_Elmt_2); Set_Is_Overriding_Operation (New_Op); + Set_Overridden_Operation (New_Op, Parent_Subp); -- We don't need to inherit its dispatching slot. -- Set_All_DT_Position has previously ensured that *************** package body Sem_Ch7 is *** 1554,1594 **** Set_Homonym (Full_Id, H2); end Exchange_Declarations; - ------------------------------------------ - -- Inspect_Deferred_Constant_Completion -- - ------------------------------------------ - - procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is - Decl : Node_Id; - - begin - Decl := First (Decls); - while Present (Decl) loop - - -- Deferred constant signature - - if Nkind (Decl) = N_Object_Declaration - and then Constant_Present (Decl) - and then No (Expression (Decl)) - - -- No need to check internally generated constants - - and then Comes_From_Source (Decl) - - -- The constant is not completed. A full object declaration - -- or a pragma Import complete a deferred constant. - - and then not Has_Completion (Defining_Identifier (Decl)) - then - Error_Msg_N - ("constant declaration requires initialization expression", - Defining_Identifier (Decl)); - end if; - - Decl := Next (Decl); - end loop; - end Inspect_Deferred_Constant_Completion; - ---------------------------- -- Install_Package_Entity -- ---------------------------- --- 1593,1598 ---- *************** package body Sem_Ch7 is *** 1655,1665 **** --- 1659,1676 ---- -- when the parent type is defined in the parent unit. At this -- point the current type is not private either, and we have to -- install the underlying full view, which is now visible. + -- Save the current full view as well, so that all views can + -- be restored on exit. It may seem that after compiling the + -- child body there are not environments to restore, but the + -- back-end expects those links to be valid, and freeze nodes + -- depend on them. if No (Full_View (Full)) and then Present (Underlying_Full_View (Full)) then Set_Full_View (Id, Underlying_Full_View (Full)); + Set_Underlying_Full_View (Id, Full); + Set_Underlying_Full_View (Full, Empty); Set_Is_Frozen (Full_View (Id)); end if; *************** package body Sem_Ch7 is *** 2104,2110 **** then if not Has_Private_Declaration (Etype (Id)) then ! -- We assume that the user did not not intend a deferred -- constant declaration, and the expression is just missing. Error_Msg_N --- 2115,2121 ---- then if not Has_Private_Declaration (Etype (Id)) then ! -- We assume that the user did not intend a deferred -- constant declaration, and the expression is just missing. Error_Msg_N *************** package body Sem_Ch7 is *** 2144,2150 **** end if; -- Make private entities invisible and exchange full and private ! -- declarations for private types. while Present (Id) loop if Debug_Flag_E then --- 2155,2162 ---- end if; -- Make private entities invisible and exchange full and private ! -- declarations for private types. Id is now the first private ! -- entity in the package. while Present (Id) loop if Debug_Flag_E then *************** package body Sem_Ch7 is *** 2231,2236 **** --- 2243,2264 ---- Exchange_Declarations (Id); + -- If we have installed an underlying full view for a type + -- derived from a private type in a child unit, restore the + -- proper views of private and full view. See corresponding + -- code in Install_Private_Declarations. + -- After the exchange, Full denotes the private type in the + -- visible part of the package. + + if Is_Private_Base_Type (Full) + and then Present (Full_View (Full)) + and then Present (Underlying_Full_View (Full)) + and then In_Package_Body (Current_Scope) + then + Set_Full_View (Full, Underlying_Full_View (Full)); + Set_Underlying_Full_View (Full, Empty); + end if; + elsif Ekind (Id) = E_Incomplete_Type and then No (Full_View (Id)) then diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch7.ads gcc-4.4.0/gcc/ada/sem_ch7.ads *** gcc-4.3.3/gcc/ada/sem_ch7.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_ch7.ads Tue May 20 12:50:03 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch8.adb gcc-4.4.0/gcc/ada/sem_ch8.adb *** gcc-4.3.3/gcc/ada/sem_ch8.adb Wed Dec 19 16:24:55 2007 --- gcc-4.4.0/gcc/ada/sem_ch8.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Sem_Ch8 is *** 462,468 **** -- gram in an instance, for which special visibility checks apply. function Has_Implicit_Operator (N : Node_Id) return Boolean; ! -- N is an expanded name whose selector is an operator name (eg P."+"). -- declarative part contains an implicit declaration of an operator if it -- has a declaration of a type to which one of the predefined operators -- apply. The existence of this routine is an implementation artifact. A --- 462,468 ---- -- gram in an instance, for which special visibility checks apply. function Has_Implicit_Operator (N : Node_Id) return Boolean; ! -- N is an expanded name whose selector is an operator name (e.g. P."+"). -- declarative part contains an implicit declaration of an operator if it -- has a declaration of a type to which one of the predefined operators -- apply. The existence of this routine is an implementation artifact. A *************** package body Sem_Ch8 is *** 747,752 **** --- 747,765 ---- Resolve (Nam, T); + -- Check that a class-wide object is not being renamed as an object + -- of a specific type. The test for access types is needed to exclude + -- cases where the renamed object is a dynamically tagged access + -- result, such as occurs in certain expansions. + + if (Is_Class_Wide_Type (Etype (Nam)) + or else (Is_Dynamically_Tagged (Nam) + and then not Is_Access_Type (T))) + and then not Is_Class_Wide_Type (T) + then + Error_Msg_N ("dynamically tagged expression not allowed!", Nam); + end if; + -- Ada 2005 (AI-230/AI-254): Access renaming else pragma Assert (Present (Access_Definition (N))); *************** package body Sem_Ch8 is *** 819,825 **** if Nkind (Nam) = N_Explicit_Dereference and then Ekind (Etype (T2)) = E_Incomplete_Type then ! Error_Msg_N ("invalid use of incomplete type", Id); return; end if; --- 832,841 ---- if Nkind (Nam) = N_Explicit_Dereference and then Ekind (Etype (T2)) = E_Incomplete_Type then ! Error_Msg_NE ("invalid use of incomplete type&", Id, T2); ! return; ! elsif Ekind (Etype (T)) = E_Incomplete_Type then ! Error_Msg_NE ("invalid use of incomplete type&", Id, T); return; end if; *************** package body Sem_Ch8 is *** 835,844 **** and then Nkind (Nam) in N_Has_Entity then declare - Error_Node : Node_Id; Nam_Decl : Node_Id; Nam_Ent : Entity_Id; - Subtyp_Decl : Node_Id; begin if Nkind (Nam) = N_Attribute_Reference then --- 851,858 ---- *************** package body Sem_Ch8 is *** 848,854 **** end if; Nam_Decl := Parent (Nam_Ent); - Subtyp_Decl := Parent (Etype (Nam_Ent)); if Has_Null_Exclusion (N) and then not Has_Null_Exclusion (Nam_Decl) --- 862,867 ---- *************** package body Sem_Ch8 is *** 863,895 **** if Is_Formal_Object (Nam_Ent) and then In_Generic_Scope (Id) then - if Present (Subtype_Mark (Nam_Decl)) then - Error_Node := Subtype_Mark (Nam_Decl); - else - pragma Assert - (Ada_Version >= Ada_05 - and then Present (Access_Definition (Nam_Decl))); - - Error_Node := Access_Definition (Nam_Decl); - end if; - Error_Msg_N ! ("`NOT NULL` required in formal object declaration", ! Error_Node); ! Error_Msg_Sloc := Sloc (N); ! Error_Msg_N ! ("\because of renaming # (RM 8.5.4(4))", Error_Node); -- Ada 2005 (AI-423): Otherwise, the subtype of the object name -- shall exclude null. ! elsif Nkind (Subtyp_Decl) = N_Subtype_Declaration ! and then not Has_Null_Exclusion (Subtyp_Decl) ! then Error_Msg_N ! ("`NOT NULL` required for subtype & (RM 8.5.1(4.6/2))", ! Defining_Identifier (Subtyp_Decl)); end if; end if; end; end if; --- 876,906 ---- if Is_Formal_Object (Nam_Ent) and then In_Generic_Scope (Id) then Error_Msg_N ! ("renamed formal does not exclude `NULL` " ! & "(RM 8.5.1(4.6/2))", N); -- Ada 2005 (AI-423): Otherwise, the subtype of the object name -- shall exclude null. ! elsif not Can_Never_Be_Null (Etype (Nam_Ent)) then Error_Msg_N ! ("renamed object does not exclude `NULL` " ! & "(RM 8.5.1(4.6/2))", N); ! ! elsif Can_Never_Be_Null (Etype (Nam_Ent)) then ! Error_Msg_NE ! ("`NOT NULL` not allowed (type of& already excludes null)", ! N, Nam_Ent); ! end if; + + elsif Has_Null_Exclusion (N) + and then No (Access_Definition (N)) + and then Can_Never_Be_Null (T) + then + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", N, T); end if; end; end if; *************** package body Sem_Ch8 is *** 951,956 **** --- 962,972 ---- then null; + -- Allow internally generated x'Reference expression + + elsif Nkind (Nam) = N_Reference then + null; + else Error_Msg_N ("expect object name in renaming", Nam); end if; *************** package body Sem_Ch8 is *** 1046,1052 **** Generate_Reference (Old_P, Name (N)); -- If the renaming is in the visible part of a package, then we set ! -- In_Package_Spec for the renamed package, to prevent giving -- warnings about no entities referenced. Such a warning would be -- overenthusiastic, since clients can see entities in the renamed -- package via the visible package renaming. --- 1062,1068 ---- Generate_Reference (Old_P, Name (N)); -- If the renaming is in the visible part of a package, then we set ! -- Renamed_In_Spec for the renamed package, to prevent giving -- warnings about no entities referenced. Such a warning would be -- overenthusiastic, since clients can see entities in the renamed -- package via the visible package renaming. *************** package body Sem_Ch8 is *** 1431,1437 **** -- in Sub must also have one. Otherwise the subtype of the Sub's -- formal parameter must exclude null. -- ! -- If Ren is a renaming of a formal function and its retrun -- profile has a null exclusion, then Sub's return profile must -- have one. Otherwise the subtype of Sub's return profile must -- exclude null. --- 1447,1453 ---- -- in Sub must also have one. Otherwise the subtype of the Sub's -- formal parameter must exclude null. -- ! -- If Ren is a renaming of a formal function and its return -- profile has a null exclusion, then Sub's return profile must -- have one. Otherwise the subtype of Sub's return profile must -- exclude null. *************** package body Sem_Ch8 is *** 1578,1602 **** -- an abstract formal subprogram must be dispatching -- operation). ! case Attribute_Name (Nam) is ! when Name_Input => ! Stream_Prim := ! Find_Prim_Op (Prefix_Type, TSS_Stream_Input); ! when Name_Output => ! Stream_Prim := ! Find_Prim_Op (Prefix_Type, TSS_Stream_Output); ! when Name_Read => ! Stream_Prim := ! Find_Prim_Op (Prefix_Type, TSS_Stream_Read); ! when Name_Write => ! Stream_Prim := ! Find_Prim_Op (Prefix_Type, TSS_Stream_Write); ! when others => ! Error_Msg_N ! ("attribute must be a primitive dispatching operation", ! Nam); ! return; ! end case; -- Rewrite the attribute into the name of its corresponding -- primitive dispatching subprogram. We can then proceed with --- 1594,1638 ---- -- an abstract formal subprogram must be dispatching -- operation). ! begin ! case Attribute_Name (Nam) is ! when Name_Input => ! Stream_Prim := ! Find_Prim_Op (Prefix_Type, TSS_Stream_Input); ! when Name_Output => ! Stream_Prim := ! Find_Prim_Op (Prefix_Type, TSS_Stream_Output); ! when Name_Read => ! Stream_Prim := ! Find_Prim_Op (Prefix_Type, TSS_Stream_Read); ! when Name_Write => ! Stream_Prim := ! Find_Prim_Op (Prefix_Type, TSS_Stream_Write); ! when others => ! Error_Msg_N ! ("attribute must be a primitive" ! & " dispatching operation", Nam); ! return; ! end case; ! ! exception ! ! -- If no operation was found, and the type is limited, ! -- the user should have defined one. ! ! when Program_Error => ! if Is_Limited_Type (Prefix_Type) then ! Error_Msg_NE ! ("stream operation not defined for type&", ! N, Prefix_Type); ! return; ! ! -- Otherwise, compiler should have generated default ! ! else ! raise; ! end if; ! end; -- Rewrite the attribute into the name of its corresponding -- primitive dispatching subprogram. We can then proceed with *************** package body Sem_Ch8 is *** 1721,1744 **** Set_Corresponding_Spec (N, Rename_Spec); ! -- Deal with special case of Input and Output stream functions if Nkind (Unit_Declaration_Node (Rename_Spec)) = N_Abstract_Subprogram_Declaration then ! -- Input and Output stream functions are abstract if the object ! -- type is abstract. However, these functions may receive explicit ! -- declarations in representation clauses, making the attribute ! -- subprograms usable as defaults in subsequent type extensions. -- In this case we rewrite the declaration to make the subprogram -- non-abstract. We remove the previous declaration, and insert -- the new one at the point of the renaming, to prevent premature -- access to unfrozen types. The new declaration reuses the -- specification of the previous one, and must not be analyzed. ! pragma Assert (Is_TSS (Rename_Spec, TSS_Stream_Output) ! or else Is_TSS (Rename_Spec, TSS_Stream_Input)); ! declare Old_Decl : constant Node_Id := Unit_Declaration_Node (Rename_Spec); --- 1757,1784 ---- Set_Corresponding_Spec (N, Rename_Spec); ! -- Deal with special case of stream functions of abstract types ! -- and interfaces. if Nkind (Unit_Declaration_Node (Rename_Spec)) = N_Abstract_Subprogram_Declaration then ! -- Input stream functions are abstract if the object type is ! -- abstract. Similarly, all default stream functions for an ! -- interface type are abstract. However, these subprograms may ! -- receive explicit declarations in representation clauses, making ! -- the attribute subprograms usable as defaults in subsequent ! -- type extensions. -- In this case we rewrite the declaration to make the subprogram -- non-abstract. We remove the previous declaration, and insert -- the new one at the point of the renaming, to prevent premature -- access to unfrozen types. The new declaration reuses the -- specification of the previous one, and must not be analyzed. ! pragma Assert ! (Is_Primitive (Entity (Nam)) ! and then ! Is_Abstract_Type (Find_Dispatching_Type (Entity (Nam)))); declare Old_Decl : constant Node_Id := Unit_Declaration_Node (Rename_Spec); *************** package body Sem_Ch8 is *** 1782,1797 **** -- Ada 2005: check overriding indicator ! if Must_Override (Specification (N)) ! and then not Is_Overriding_Operation (Rename_Spec) ! then ! Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec); ! elsif Must_Not_Override (Specification (N)) ! and then Is_Overriding_Operation (Rename_Spec) ! then ! Error_Msg_NE ! ("subprogram& overrides inherited operation", N, Rename_Spec); end if; -- Normal subprogram renaming (not renaming as body) --- 1822,1840 ---- -- Ada 2005: check overriding indicator ! if Is_Overriding_Operation (Rename_Spec) then ! if Must_Not_Override (Specification (N)) then ! Error_Msg_NE ! ("subprogram& overrides inherited operation", ! N, Rename_Spec); ! elsif ! Style_Check and then not Must_Override (Specification (N)) ! then ! Style.Missing_Overriding (N, Rename_Spec); ! end if; ! elsif Must_Override (Specification (N)) then ! Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec); end if; -- Normal subprogram renaming (not renaming as body) *************** package body Sem_Ch8 is *** 1925,1933 **** --- 1968,1978 ---- -- Most common case: subprogram renames subprogram. No body is generated -- in this case, so we must indicate the declaration is complete as is. + -- and inherit various attributes of the renamed subprogram. if No (Rename_Spec) then Set_Has_Completion (New_S); + Set_Is_Imported (New_S, Is_Imported (Entity (Nam))); Set_Is_Pure (New_S, Is_Pure (Entity (Nam))); Set_Is_Preelaborated (New_S, Is_Preelaborated (Entity (Nam))); *************** package body Sem_Ch8 is *** 1957,1963 **** if Is_Actual then null; ! -- Guard agaisnt previous errors, and omit renamings of predefined -- operators. elsif Ekind (Old_S) /= E_Function --- 2002,2008 ---- if Is_Actual then null; ! -- Guard against previous errors, and omit renamings of predefined -- operators. elsif Ekind (Old_S) /= E_Function *************** package body Sem_Ch8 is *** 2018,2024 **** Check_Frozen_Renaming (N, Rename_Spec); -- Check explicitly that renamed entity is not intrinsic, because ! -- in in a generic the renamed body is not built. In this case, -- the renaming_as_body is a completion. if Inside_A_Generic then --- 2063,2069 ---- Check_Frozen_Renaming (N, Rename_Spec); -- Check explicitly that renamed entity is not intrinsic, because ! -- in a generic the renamed body is not built. In this case, -- the renaming_as_body is a completion. if Inside_A_Generic then *************** package body Sem_Ch8 is *** 2396,2401 **** --- 2441,2451 ---- Use_One_Package (Pack, N); end if; end if; + + -- Report error because name denotes something other than a package + + else + Error_Msg_N ("& is not a package", Pack_Name); end if; Next (Pack_Name); *************** package body Sem_Ch8 is *** 2888,2896 **** Error_Msg_N ("renamed generic unit must be a library unit", Name (N)); ! elsif Ekind (Old_E) = E_Package ! or else Ekind (Old_E) = E_Generic_Package ! then -- Inherit categorization flags New_E := Defining_Entity (N); --- 2938,2945 ---- Error_Msg_N ("renamed generic unit must be a library unit", Name (N)); ! elsif Is_Package_Or_Generic_Package (Old_E) then ! -- Inherit categorization flags New_E := Defining_Entity (N); *************** package body Sem_Ch8 is *** 3066,3074 **** begin Pack_Name := First (Names (N)); while Present (Pack_Name) loop - Pack := Entity (Pack_Name); ! if Ekind (Pack) = E_Package then if In_Open_Scopes (Pack) then null; --- 3115,3128 ---- begin Pack_Name := First (Names (N)); while Present (Pack_Name) loop ! -- Test that Pack_Name actually denotes a package before processing ! ! if Is_Entity_Name (Pack_Name) ! and then Ekind (Entity (Pack_Name)) = E_Package ! then ! Pack := Entity (Pack_Name); ! if In_Open_Scopes (Pack) then null; *************** package body Sem_Ch8 is *** 3192,3197 **** --- 3246,3253 ---- elsif not Redundant_Use (Id) then Set_In_Use (T, False); Set_In_Use (Base_Type (T), False); + Set_Current_Use_Clause (T, Empty); + Set_Current_Use_Clause (Base_Type (T), Empty); Op_List := Collect_Primitive_Operations (T); Elmt := First_Elmt (Op_List); *************** package body Sem_Ch8 is *** 3569,3583 **** declare Case_Stm : constant Node_Id := Parent (Parent (N)); Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm)); - Case_Rtp : constant Entity_Id := Root_Type (Case_Typ); Lit : Node_Id; begin if Is_Enumeration_Type (Case_Typ) ! and then Case_Rtp /= Standard_Character ! and then Case_Rtp /= Standard_Wide_Character ! and then Case_Rtp /= Standard_Wide_Wide_Character then Lit := First_Literal (Case_Typ); Get_Name_String (Chars (Lit)); --- 3625,3636 ---- declare Case_Stm : constant Node_Id := Parent (Parent (N)); Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm)); Lit : Node_Id; begin if Is_Enumeration_Type (Case_Typ) ! and then not Is_Standard_Character_Type (Case_Typ) then Lit := First_Literal (Case_Typ); Get_Name_String (Chars (Lit)); *************** package body Sem_Ch8 is *** 3768,3775 **** E := Homonyms; while Present (E) loop ! -- If entity is immediately visible or potentially use ! -- visible, then process the entity and we are done. if Is_Immediately_Visible (E) then goto Immediately_Visible_Entity; --- 3821,3828 ---- E := Homonyms; while Present (E) loop ! -- If entity is immediately visible or potentially use visible, then ! -- process the entity and we are done. if Is_Immediately_Visible (E) then goto Immediately_Visible_Entity; *************** package body Sem_Ch8 is *** 3838,3845 **** Only_One_Visible := False; All_Overloadable := All_Overloadable and Is_Overloadable (E2); ! -- Ada 2005 (AI-262): Protect against a form of Beujolais effect ! -- that can occurr in private_with clauses. Example: -- with A; -- private with B; package A is --- 3891,3898 ---- Only_One_Visible := False; All_Overloadable := All_Overloadable and Is_Overloadable (E2); ! -- Ada 2005 (AI-262): Protect against a form of Beaujolais effect ! -- that can occur in private_with clauses. Example: -- with A; -- private with B; package A is *************** package body Sem_Ch8 is *** 3949,3963 **** -- Come here with E set to the first immediately visible entity on -- the homonym chain. This is the one we want unless there is another ! -- immediately visible entity further on in the chain for a more ! -- inner scope (RM 8.3(8)). <> declare Level : Int; Scop : Entity_Id; begin ! -- Find scope level of initial entity. When compiling through -- Rtsfind, the previous context is not completely invisible, and -- an outer entity may appear on the chain, whose scope is below -- the entry for Standard that delimits the current scope stack. --- 4002,4016 ---- -- Come here with E set to the first immediately visible entity on -- the homonym chain. This is the one we want unless there is another ! -- immediately visible entity further on in the chain for an inner ! -- scope (RM 8.3(8)). <> declare Level : Int; Scop : Entity_Id; begin ! -- Find scope level of initial entity. When compiling through -- Rtsfind, the previous context is not completely invisible, and -- an outer entity may appear on the chain, whose scope is below -- the entry for Standard that delimits the current scope stack. *************** package body Sem_Ch8 is *** 4028,4034 **** -- When distribution features are available (Get_PCS_Name /= -- Name_No_DSA), a remote access-to-subprogram type is converted -- into a record type holding whatever information is needed to ! -- perform a remote call on an RCI suprogram. In that case we -- rewrite any occurrence of the RAS type into the equivalent record -- type here. 'Access attribute references and RAS dereferences are -- then implemented using specific TSSs. However when distribution is --- 4081,4087 ---- -- When distribution features are available (Get_PCS_Name /= -- Name_No_DSA), a remote access-to-subprogram type is converted -- into a record type holding whatever information is needed to ! -- perform a remote call on an RCI subprogram. In that case we -- rewrite any occurrence of the RAS type into the equivalent record -- type here. 'Access attribute references and RAS dereferences are -- then implemented using specific TSSs. However when distribution is *************** package body Sem_Ch8 is *** 4108,4113 **** --- 4161,4177 ---- if Is_Object (E) and then Present (Renamed_Object (E)) then Generate_Reference (E, N); + -- If the renamed entity is a private protected component, + -- reference the original component as well. This needs to be + -- done because the private renamings are installed before any + -- analysis has occurred. Reference to a private component will + -- resolve to the renaming and the original component will be + -- left unreferenced, hence the following. + + if Is_Prival (E) then + Generate_Reference (Prival_Link (E), N); + end if; + -- One odd case is that we do not want to set the Referenced flag -- if the entity is a label, and the identifier is the label in -- the source, since this is not a reference from the point of *************** package body Sem_Ch8 is *** 4133,4143 **** -- the entity is unambiguous, because the tree is not -- sufficiently typed at this point for Generate_Reference to -- determine whether this reference modifies the denoted object ! -- (because implicit derefences cannot be identified prior to -- full type resolution). -- ! -- ??? The Is_Actual_Parameter routine takes care of one of these ! -- cases but there are others probably else if not Is_Actual_Parameter then --- 4197,4207 ---- -- the entity is unambiguous, because the tree is not -- sufficiently typed at this point for Generate_Reference to -- determine whether this reference modifies the denoted object ! -- (because implicit dereferences cannot be identified prior to -- full type resolution). -- ! -- The Is_Actual_Parameter routine takes care of one of these ! -- cases but there are others probably ??? else if not Is_Actual_Parameter then *************** package body Sem_Ch8 is *** 4157,4163 **** -- processing a generic spec or body, because the discriminal -- has not been not generated in this case. ! if not In_Default_Expression or else Ekind (E) /= E_Discriminant or else Inside_A_Generic then --- 4221,4230 ---- -- processing a generic spec or body, because the discriminal -- has not been not generated in this case. ! -- The replacement is also skipped if we are in special ! -- spec-expression mode. Why is this skipped in this case ??? ! ! if not In_Spec_Expression or else Ekind (E) /= E_Discriminant or else Inside_A_Generic then *************** package body Sem_Ch8 is *** 4220,4227 **** P_Name := Entity (Prefix (N)); O_Name := P_Name; ! -- If the prefix is a renamed package, look for the entity ! -- in the original package. if Ekind (P_Name) = E_Package and then Present (Renamed_Object (P_Name)) --- 4287,4294 ---- P_Name := Entity (Prefix (N)); O_Name := P_Name; ! -- If the prefix is a renamed package, look for the entity in the ! -- original package. if Ekind (P_Name) = E_Package and then Present (Renamed_Object (P_Name)) *************** package body Sem_Ch8 is *** 4312,4321 **** if No (Id) or else Chars (Id) /= Chars (Selector) then Set_Etype (N, Any_Type); ! -- If we are looking for an entity defined in System, try to ! -- find it in the child package that may have been provided as ! -- an extension to System. The Extend_System pragma will have ! -- supplied the name of the extension, which may have to be loaded. if Chars (P_Name) = Name_System and then Scope (P_Name) = Standard_Standard --- 4379,4388 ---- if No (Id) or else Chars (Id) /= Chars (Selector) then Set_Etype (N, Any_Type); ! -- If we are looking for an entity defined in System, try to find it ! -- in the child package that may have been provided as an extension ! -- to System. The Extend_System pragma will have supplied the name of ! -- the extension, which may have to be loaded. if Chars (P_Name) = Name_System and then Scope (P_Name) = Standard_Standard *************** package body Sem_Ch8 is *** 4345,4353 **** return; else ! -- If the prefix is a single concurrent object, use its ! -- name in the error message, rather than that of the ! -- anonymous type. if Is_Concurrent_Type (P_Name) and then Is_Internal_Name (Chars (P_Name)) --- 4412,4419 ---- return; else ! -- If the prefix is a single concurrent object, use its name in ! -- the error message, rather than that of the anonymous type. if Is_Concurrent_Type (P_Name) and then Is_Internal_Name (Chars (P_Name)) *************** package body Sem_Ch8 is *** 4518,4524 **** else Error_Msg_N ("limited withed package can only be used to access " ! & " incomplete types", N); end if; end if; --- 4584,4590 ---- else Error_Msg_N ("limited withed package can only be used to access " ! & "incomplete types", N); end if; end if; *************** package body Sem_Ch8 is *** 4737,4743 **** end if; -- Operator is visible if prefix of expanded name denotes ! -- scope of type, or else type type is defined in System_Aux -- and the prefix denotes System. return Scope (Btyp) = Scop --- 4803,4809 ---- end if; -- Operator is visible if prefix of expanded name denotes ! -- scope of type, or else type is defined in System_Aux -- and the prefix denotes System. return Scope (Btyp) = Scop *************** package body Sem_Ch8 is *** 4894,4900 **** -- in the expansion of record equality). elsif Present (Entity (Selector_Name (N))) then - if No (Etype (N)) or else Etype (N) = Any_Type then --- 4960,4965 ---- *************** package body Sem_Ch8 is *** 5257,5263 **** and then False then Error_Msg_N ! ("applying 'Class to an untagged imcomplete type" & " is an obsolescent feature (RM J.11)", N); end if; --- 5322,5328 ---- and then False then Error_Msg_N ! ("applying 'Class to an untagged incomplete type" & " is an obsolescent feature (RM J.11)", N); end if; *************** package body Sem_Ch8 is *** 5347,5353 **** and then Warn_On_Redundant_Constructs then Error_Msg_NE ! ("?redudant attribute, & is its own base type", N, Typ); end if; T := Base_Type (Typ); --- 5412,5418 ---- and then Warn_On_Redundant_Constructs then Error_Msg_NE ! ("?redundant attribute, & is its own base type", N, Typ); end if; T := Base_Type (Typ); *************** package body Sem_Ch8 is *** 5522,5535 **** end if; Id := First_Entity (P); - while Present (Id) and then Id /= Priv_Id loop ! if Is_Character_Type (Id) ! and then (Root_Type (Id) = Standard_Character ! or else Root_Type (Id) = Standard_Wide_Character ! or else Root_Type (Id) = Standard_Wide_Wide_Character) and then Id = Base_Type (Id) then -- We replace the node with the literal itself, resolve as a --- 5587,5596 ---- end if; Id := First_Entity (P); while Present (Id) and then Id /= Priv_Id loop ! if Is_Standard_Character_Type (Id) and then Id = Base_Type (Id) then -- We replace the node with the literal itself, resolve as a *************** package body Sem_Ch8 is *** 6101,6107 **** end if; -- If the new use clause appears in the private part of a parent unit ! -- it may appear to be redudant w.r.t. a use clause in a child unit, -- but the previous use clause was needed in the visible part of the -- child, and no warning should be emitted. --- 6162,6168 ---- end if; -- If the new use clause appears in the private part of a parent unit ! -- it may appear to be redundant w.r.t. a use clause in a child unit, -- but the previous use clause was needed in the visible part of the -- child, and no warning should be emitted. *************** package body Sem_Ch8 is *** 6126,6131 **** --- 6187,6202 ---- end; end if; + -- Finally, if the current use clause is in the context then + -- the clause is redundant when it is nested within the unit. + + elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit + and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit + and then Get_Source_Unit (Cur_Use) = Get_Source_Unit (Clause) + then + Redundant := Clause; + Prev_Use := Cur_Use; + else null; end if; *************** package body Sem_Ch8 is *** 6150,6157 **** Write_Info; end if; ! Scope_Suppress := SST.Save_Scope_Suppress; Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top; if Debug_Flag_W then Write_Str ("--> exiting scope: "); --- 6221,6229 ---- Write_Info; end if; ! Scope_Suppress := SST.Save_Scope_Suppress; Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top; + Check_Policy_List := SST.Save_Check_Policy_List; if Debug_Flag_W then Write_Str ("--> exiting scope: "); *************** package body Sem_Ch8 is *** 6223,6228 **** --- 6295,6301 ---- SST.Entity := S; SST.Save_Scope_Suppress := Scope_Suppress; SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top; + SST.Save_Check_Policy_List := Check_Policy_List; if Scope_Stack.Last > Scope_Stack.First then SST.Component_Alignment_Default := Scope_Stack.Table *************** package body Sem_Ch8 is *** 6576,6588 **** then Full_Vis := True; ! elsif (Ekind (S) = E_Package ! or else Ekind (S) = E_Generic_Package) and then (In_Private_Part (S) or else In_Package_Body (S)) then Full_Vis := True; elsif (Ekind (S) = E_Procedure or else Ekind (S) = E_Function) and then Has_Completion (S) --- 6649,6667 ---- then Full_Vis := True; ! elsif Is_Package_Or_Generic_Package (S) and then (In_Private_Part (S) or else In_Package_Body (S)) then Full_Vis := True; + -- if S is the scope of some instance (which has already been + -- seen on the stack) it does not affect the visibility of + -- other scopes. + + elsif Is_Hidden_Open_Scope (S) then + null; + elsif (Ekind (S) = E_Procedure or else Ekind (S) = E_Function) and then Has_Completion (S) *************** package body Sem_Ch8 is *** 6945,6950 **** --- 7024,7030 ---- elsif not Redundant_Use (Id) then Set_In_Use (T); + Set_Current_Use_Clause (T, Parent (Id)); Op_List := Collect_Primitive_Operations (T); Elmt := First_Elmt (Op_List); *************** package body Sem_Ch8 is *** 6970,6988 **** -- type T ... use P.T; -- The compilation unit is the body of X. GNAT first compiles the ! -- spec of X, then procedes to the body. At that point P is marked -- as use visible. The analysis then reinstalls the spec along with -- its context. The use clause P.T is now recognized as redundant, -- but in the wrong context. Do not emit a warning in such cases. and then not Spec_Reloaded_For_Body then -- The type already has a use clause if In_Use (T) then ! Error_Msg_NE ! ("& is already use-visible through previous use type clause?", ! Id, Id); -- The package where T is declared is already used --- 7050,7186 ---- -- type T ... use P.T; -- The compilation unit is the body of X. GNAT first compiles the ! -- spec of X, then proceeds to the body. At that point P is marked -- as use visible. The analysis then reinstalls the spec along with -- its context. The use clause P.T is now recognized as redundant, -- but in the wrong context. Do not emit a warning in such cases. + -- Do not emit a warning either if we are in an instance, there + -- is no redundancy between an outer use_clause and one that appears + -- within the generic. and then not Spec_Reloaded_For_Body + and then not In_Instance then -- The type already has a use clause if In_Use (T) then ! ! -- Case where we know the current use clause for the type ! ! if Present (Current_Use_Clause (T)) then ! Use_Clause_Known : declare ! Clause1 : constant Node_Id := Parent (Id); ! Clause2 : constant Node_Id := Current_Use_Clause (T); ! Ent1 : Entity_Id; ! Ent2 : Entity_Id; ! Err_No : Node_Id; ! Unit1 : Node_Id; ! Unit2 : Node_Id; ! ! function Entity_Of_Unit (U : Node_Id) return Entity_Id; ! -- Return the appropriate entity for determining which unit ! -- has a deeper scope: the defining entity for U, unless U ! -- is a package instance, in which case we retrieve the ! -- entity of the instance spec. ! ! -------------------- ! -- Entity_Of_Unit -- ! -------------------- ! ! function Entity_Of_Unit (U : Node_Id) return Entity_Id is ! begin ! if Nkind (U) = N_Package_Instantiation ! and then Analyzed (U) ! then ! return Defining_Entity (Instance_Spec (U)); ! else ! return Defining_Entity (U); ! end if; ! end Entity_Of_Unit; ! ! -- Start of processing for Use_Clause_Known ! ! begin ! -- If both current use type clause and the use type ! -- clause for the type are at the compilation unit level, ! -- one of the units must be an ancestor of the other, and ! -- the warning belongs on the descendant. ! ! if Nkind (Parent (Clause1)) = N_Compilation_Unit ! and then ! Nkind (Parent (Clause2)) = N_Compilation_Unit ! then ! Unit1 := Unit (Parent (Clause1)); ! Unit2 := Unit (Parent (Clause2)); ! ! -- There is a redundant use type clause in a child unit. ! -- Determine which of the units is more deeply nested. ! -- If a unit is a package instance, retrieve the entity ! -- and its scope from the instance spec. ! ! Ent1 := Entity_Of_Unit (Unit1); ! Ent2 := Entity_Of_Unit (Unit2); ! ! if Scope (Ent2) = Standard_Standard then ! Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); ! Err_No := Clause1; ! ! elsif Scope (Ent1) = Standard_Standard then ! Error_Msg_Sloc := Sloc (Id); ! Err_No := Clause2; ! ! -- If both units are child units, we determine which one ! -- is the descendant by the scope distance to the ! -- ultimate parent unit. ! ! else ! declare ! S1, S2 : Entity_Id; ! ! begin ! S1 := Scope (Ent1); ! S2 := Scope (Ent2); ! while S1 /= Standard_Standard ! and then ! S2 /= Standard_Standard ! loop ! S1 := Scope (S1); ! S2 := Scope (S2); ! end loop; ! ! if S1 = Standard_Standard then ! Error_Msg_Sloc := Sloc (Id); ! Err_No := Clause2; ! else ! Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); ! Err_No := Clause1; ! end if; ! end; ! end if; ! ! Error_Msg_NE ! ("& is already use-visible through previous " ! & "use_type_clause #?", Err_No, Id); ! ! -- Case where current use type clause and the use type ! -- clause for the type are not both at the compilation unit ! -- level. In this case we don't have location information. ! ! else ! Error_Msg_NE ! ("& is already use-visible through previous " ! & "use type clause?", Id, Id); ! end if; ! end Use_Clause_Known; ! ! -- Here if Current_Use_Clause is not set for T, another case ! -- where we do not have the location information available. ! ! else ! Error_Msg_NE ! ("& is already use-visible through previous " ! & "use type clause?", Id, Id); ! end if; -- The package where T is declared is already used diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch8.ads gcc-4.4.0/gcc/ada/sem_ch8.ads *** gcc-4.3.3/gcc/ada/sem_ch8.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_ch8.ads Tue May 20 13:00:35 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Sem_Ch8 is *** 77,84 **** procedure Find_Direct_Name (N : Node_Id); -- Given a direct name (Identifier or Operator_Symbol), this routine scans -- the homonym chain for the name searching for corresponding visible ! -- entities to find the referenced entity (or in the case of overloading), ! -- entities. On return, the Entity and Etype fields are set. In the -- non-overloaded case, these are the correct final entries. In the -- overloaded case, Is_Overloaded is set, Etype and Entity refer to an -- arbitrary element of the overloads set, and an appropriate list of --- 77,84 ---- procedure Find_Direct_Name (N : Node_Id); -- Given a direct name (Identifier or Operator_Symbol), this routine scans -- the homonym chain for the name searching for corresponding visible ! -- entities to find the referenced entity (or in the case of overloading, ! -- entities). On return, the Entity and Etype fields are set. In the -- non-overloaded case, these are the correct final entries. In the -- overloaded case, Is_Overloaded is set, Etype and Entity refer to an -- arbitrary element of the overloads set, and an appropriate list of *************** package Sem_Ch8 is *** 146,152 **** -- return, the contents of the scope stack must be made accessible again. -- The flag Handle_Use indicates whether local use clauses must be -- removed/installed. In the case of inlining of instance bodies, the ! -- visiblity handling is done fully in Inline_Instance_Body, and use -- clauses are handled there. procedure Set_Use (L : List_Id); --- 146,152 ---- -- return, the contents of the scope stack must be made accessible again. -- The flag Handle_Use indicates whether local use clauses must be -- removed/installed. In the case of inlining of instance bodies, the ! -- visibility handling is done fully in Inline_Instance_Body, and use -- clauses are handled there. procedure Set_Use (L : List_Id); diff -Nrcpad gcc-4.3.3/gcc/ada/sem_ch9.adb gcc-4.4.0/gcc/ada/sem_ch9.adb *** gcc-4.3.3/gcc/ada/sem_ch9.adb Thu Dec 13 10:32:01 2007 --- gcc-4.4.0/gcc/ada/sem_ch9.adb Mon May 26 13:43:18 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Sem_Ch9 is *** 570,578 **** -- expression is only evaluated if the guard is open. if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then ! Pre_Analyze_And_Resolve (Expr, Standard_Duration); else ! Pre_Analyze_And_Resolve (Expr); end if; Typ := First_Subtype (Etype (Expr)); --- 570,578 ---- -- expression is only evaluated if the guard is open. if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then ! Preanalyze_And_Resolve (Expr, Standard_Duration); else ! Preanalyze_And_Resolve (Expr); end if; Typ := First_Subtype (Etype (Expr)); *************** package body Sem_Ch9 is *** 646,653 **** Stats : constant Node_Id := Handled_Statement_Sequence (N); Formals : constant Node_Id := Entry_Body_Formal_Part (N); P_Type : constant Entity_Id := Current_Scope; - Entry_Name : Entity_Id; E : Entity_Id; begin Tasking_Used := True; --- 646,653 ---- Stats : constant Node_Id := Handled_Statement_Sequence (N); Formals : constant Node_Id := Entry_Body_Formal_Part (N); P_Type : constant Entity_Id := Current_Scope; E : Entity_Id; + Entry_Name : Entity_Id; begin Tasking_Used := True; *************** package body Sem_Ch9 is *** 765,771 **** Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name); Push_Scope (Entry_Name); - Exp_Ch9.Expand_Entry_Body_Declarations (N); Install_Declarations (Entry_Name); Set_Actual_Subtypes (N, Current_Scope); --- 765,770 ---- *************** package body Sem_Ch9 is *** 783,790 **** --- 782,801 ---- Set_Entry_Parameters_Type (Id, Entry_Parameters_Type (Entry_Name)); + -- Add a declaration for the Protection object, renaming declarations + -- for the discriminals and privals and finally a declaration for the + -- entry family index (if applicable). + + if Expander_Active + and then Is_Protected_Type (P_Type) + then + Install_Private_Data_Declarations + (Sloc (N), Entry_Name, P_Type, N, Decls); + end if; + if Present (Decls) then Analyze_Declarations (Decls); + Inspect_Deferred_Constant_Completion (Decls); end if; if Present (Stats) then *************** package body Sem_Ch9 is *** 907,913 **** if Nkind (Call) = N_Attribute_Reference then -- Possibly a stream attribute, but definitely illegal. Other ! -- illegalitles, such as procedure calls, are diagnosed after -- resolution. Error_Msg_N ("entry call alternative requires an entry call", Call); --- 918,924 ---- if Nkind (Call) = N_Attribute_Reference then -- Possibly a stream attribute, but definitely illegal. Other ! -- illegalities, such as procedure calls, are diagnosed after -- resolution. Error_Msg_N ("entry call alternative requires an entry call", Call); *************** package body Sem_Ch9 is *** 926,965 **** ------------------------------- procedure Analyze_Entry_Declaration (N : Node_Id) is - Formals : constant List_Id := Parameter_Specifications (N); - Id : constant Entity_Id := Defining_Identifier (N); D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N); begin ! Generate_Definition (Id); Tasking_Used := True; if No (D_Sdef) then ! Set_Ekind (Id, E_Entry); else ! Enter_Name (Id); ! Set_Ekind (Id, E_Entry_Family); Analyze (D_Sdef); ! Make_Index (D_Sdef, N, Id); end if; ! Set_Etype (Id, Standard_Void_Type); ! Set_Convention (Id, Convention_Entry); ! Set_Accept_Address (Id, New_Elmt_List); if Present (Formals) then ! Set_Scope (Id, Current_Scope); ! Push_Scope (Id); Process_Formals (Formals, N); ! Create_Extra_Formals (Id); End_Scope; end if; ! if Ekind (Id) = E_Entry then ! New_Overloaded_Entity (Id); end if; ! Generate_Reference_To_Formals (Id); end Analyze_Entry_Declaration; --------------------------------------- --- 937,976 ---- ------------------------------- procedure Analyze_Entry_Declaration (N : Node_Id) is D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N); + Def_Id : constant Entity_Id := Defining_Identifier (N); + Formals : constant List_Id := Parameter_Specifications (N); begin ! Generate_Definition (Def_Id); Tasking_Used := True; if No (D_Sdef) then ! Set_Ekind (Def_Id, E_Entry); else ! Enter_Name (Def_Id); ! Set_Ekind (Def_Id, E_Entry_Family); Analyze (D_Sdef); ! Make_Index (D_Sdef, N, Def_Id); end if; ! Set_Etype (Def_Id, Standard_Void_Type); ! Set_Convention (Def_Id, Convention_Entry); ! Set_Accept_Address (Def_Id, New_Elmt_List); if Present (Formals) then ! Set_Scope (Def_Id, Current_Scope); ! Push_Scope (Def_Id); Process_Formals (Formals, N); ! Create_Extra_Formals (Def_Id); End_Scope; end if; ! if Ekind (Def_Id) = E_Entry then ! New_Overloaded_Entity (Def_Id); end if; ! Generate_Reference_To_Formals (Def_Id); end Analyze_Entry_Declaration; --------------------------------------- *************** package body Sem_Ch9 is *** 973,979 **** -- order to make it available to the barrier, we create an additional -- scope, as for a loop, whose only declaration is the index name. This -- loop is not attached to the tree and does not appear as an entity local ! -- to the protected type, so its existence need only be knwown to routines -- that process entry families. procedure Analyze_Entry_Index_Specification (N : Node_Id) is --- 984,990 ---- -- order to make it available to the barrier, we create an additional -- scope, as for a loop, whose only declaration is the index name. This -- loop is not attached to the tree and does not appear as an entity local ! -- to the protected type, so its existence need only be known to routines -- that process entry families. procedure Analyze_Entry_Index_Specification (N : Node_Id) is *************** package body Sem_Ch9 is *** 1061,1067 **** Set_Has_Completion (Spec_Id); Install_Declarations (Spec_Id); ! Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id); Last_E := Last_Entity (Spec_Id); --- 1072,1078 ---- Set_Has_Completion (Spec_Id); Install_Declarations (Spec_Id); ! Expand_Protected_Body_Declarations (N, Spec_Id); Last_E := Last_Entity (Spec_Id); *************** package body Sem_Ch9 is *** 1093,1098 **** --- 1104,1158 ---- E : Entity_Id; L : Entity_Id; + procedure Undelay_Itypes (T : Entity_Id); + -- Itypes created for the private components of a protected type + -- do not receive freeze nodes, because there is no scope in which + -- they can be elaborated, and they can depend on discriminants of + -- the enclosed protected type. Given that the components can be + -- composite types with inner components, we traverse recursively + -- the private components of the protected type, and indicate that + -- all itypes within are frozen. This ensures that no freeze nodes + -- will be generated for them. + -- + -- On the other hand, components of the corresponding record are + -- frozen (or receive itype references) as for other records. + + -------------------- + -- Undelay_Itypes -- + -------------------- + + procedure Undelay_Itypes (T : Entity_Id) is + Comp : Entity_Id; + + begin + if Is_Protected_Type (T) then + Comp := First_Private_Entity (T); + elsif Is_Record_Type (T) then + Comp := First_Entity (T); + else + return; + end if; + + while Present (Comp) loop + if Is_Type (Comp) + and then Is_Itype (Comp) + then + Set_Has_Delayed_Freeze (Comp, False); + Set_Is_Frozen (Comp); + + if Is_Record_Type (Comp) + or else Is_Protected_Type (Comp) + then + Undelay_Itypes (Comp); + end if; + end if; + + Next_Entity (Comp); + end loop; + end Undelay_Itypes; + + -- Start of processing for Analyze_Protected_Definition + begin Tasking_Used := True; Analyze_Declarations (Visible_Declarations (N)); *************** package body Sem_Ch9 is *** 1127,1132 **** --- 1187,1194 ---- Next_Entity (E); end loop; + Undelay_Itypes (Current_Scope); + Check_Max_Entries (N, Max_Protected_Entries); Process_End_Label (N, 'e', Current_Scope); end Analyze_Protected_Definition; *************** package body Sem_Ch9 is *** 1151,1157 **** T := Find_Type_Name (N); ! if Ekind (T) = E_Incomplete_Type then T := Full_View (T); Set_Completion_Referenced (T); end if; --- 1213,1222 ---- T := Find_Type_Name (N); ! -- In the case of an incomplete type, use the full view, unless it's not ! -- present (as can occur for an incomplete view from a limited with). ! ! if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then T := Full_View (T); Set_Completion_Referenced (T); end if; *************** package body Sem_Ch9 is *** 1776,1781 **** --- 1841,1847 ---- procedure Analyze_Task_Body (N : Node_Id) is Body_Id : constant Entity_Id := Defining_Identifier (N); + Decls : constant List_Id := Declarations (N); HSS : constant Node_Id := Handled_Statement_Sequence (N); Last_E : Entity_Id; *************** package body Sem_Ch9 is *** 1842,1848 **** Install_Declarations (Spec_Id); Last_E := Last_Entity (Spec_Id); ! Analyze_Declarations (Declarations (N)); -- For visibility purposes, all entities in the body are private. Set -- First_Private_Entity accordingly, if there was no private part in the --- 1908,1915 ---- Install_Declarations (Spec_Id); Last_E := Last_Entity (Spec_Id); ! Analyze_Declarations (Decls); ! Inspect_Deferred_Constant_Completion (Decls); -- For visibility purposes, all entities in the body are private. Set -- First_Private_Entity accordingly, if there was no private part in the *************** package body Sem_Ch9 is *** 1946,1952 **** T := Find_Type_Name (N); Generate_Definition (T); ! if Ekind (T) = E_Incomplete_Type then T := Full_View (T); Set_Completion_Referenced (T); end if; --- 2013,2022 ---- T := Find_Type_Name (N); Generate_Definition (T); ! -- In the case of an incomplete type, use the full view, unless it's not ! -- present (as can occur for an incomplete view from a limited with). ! ! if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then T := Full_View (T); Set_Completion_Referenced (T); end if; *************** package body Sem_Ch9 is *** 2107,2113 **** ("triggering statement must be delay or entry call", Trigger); -- Ada 2005 (AI-345): If a procedure_call_statement is used for a ! -- procedure_or_entry_call, the procedure_name or pro- cedure_prefix -- of the procedure_call_statement shall denote an entry renamed by a -- procedure, or (a view of) a primitive subprogram of a limited -- interface whose first parameter is a controlling parameter. --- 2177,2183 ---- ("triggering statement must be delay or entry call", Trigger); -- Ada 2005 (AI-345): If a procedure_call_statement is used for a ! -- procedure_or_entry_call, the procedure_name or procedure_prefix -- of the procedure_call_statement shall denote an entry renamed by a -- procedure, or (a view of) a primitive subprogram of a limited -- interface whose first parameter is a controlling parameter. *************** package body Sem_Ch9 is *** 2347,2362 **** if Present (Interface_List (N)) or else (Is_Tagged_Type (Priv_T) ! and then Has_Abstract_Interfaces ! (Priv_T, Use_Full_View => False)) then if Is_Tagged_Type (Priv_T) then ! Collect_Abstract_Interfaces (Priv_T, Priv_T_Ifaces, Use_Full_View => False); end if; if Is_Tagged_Type (T) then ! Collect_Abstract_Interfaces (T, Full_T_Ifaces); end if; Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); --- 2417,2432 ---- if Present (Interface_List (N)) or else (Is_Tagged_Type (Priv_T) ! and then Has_Interfaces ! (Priv_T, Use_Full_View => False)) then if Is_Tagged_Type (Priv_T) then ! Collect_Interfaces (Priv_T, Priv_T_Ifaces, Use_Full_View => False); end if; if Is_Tagged_Type (T) then ! Collect_Interfaces (T, Full_T_Ifaces); end if; Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); diff -Nrcpad gcc-4.3.3/gcc/ada/sem_disp.adb gcc-4.4.0/gcc/ada/sem_disp.adb *** gcc-4.3.3/gcc/ada/sem_disp.adb Wed Dec 19 16:25:18 2007 --- gcc-4.4.0/gcc/ada/sem_disp.adb Mon May 26 13:43:18 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Exp_Disp; use Exp_Disp; *** 31,36 **** --- 31,37 ---- with Exp_Ch7; use Exp_Ch7; with Exp_Tss; use Exp_Tss; with Errout; use Errout; + with Lib.Xref; use Lib.Xref; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; *************** package body Sem_Disp is *** 617,622 **** --- 618,636 ---- Tagged_Type := Corresponding_Record_Type (Tagged_Type); end if; + -- (AI-345): The task body procedure is not a primitive of the tagged + -- type + + if Present (Tagged_Type) + and then Is_Concurrent_Record_Type (Tagged_Type) + and then Present (Corresponding_Concurrent_Type (Tagged_Type)) + and then Is_Task_Type (Corresponding_Concurrent_Type (Tagged_Type)) + and then Subp = Get_Task_Body_Procedure + (Corresponding_Concurrent_Type (Tagged_Type)) + then + return; + end if; + -- If Subp is derived from a dispatching operation then it should -- always be treated as dispatching. In this case various checks -- below will be bypassed. Makes sure that late declarations for *************** package body Sem_Disp is *** 641,647 **** begin E := First_Entity (Subp); while Present (E) loop ! if Is_Access_Type (Etype (E)) then Typ := Designated_Type (Etype (E)); else Typ := Etype (E); --- 655,664 ---- begin E := First_Entity (Subp); while Present (E) loop ! ! -- For an access parameter, check designated type. ! ! if Ekind (Etype (E)) = E_Anonymous_Access_Type then Typ := Designated_Type (Etype (E)); else Typ := Etype (E); *************** package body Sem_Disp is *** 787,792 **** --- 804,812 ---- -- if the subprogram is already frozen, we must update -- its dispatching information explicitly here. The -- information is taken from the overridden subprogram. + -- We must also generate a cross-reference entry because + -- references to other primitives were already created + -- when type was frozen. Body_Is_Last_Primitive := True; *************** package body Sem_Disp is *** 816,821 **** --- 836,843 ---- Prim => Subp, Ins_Nod => Subp_Body); end if; + + Generate_Reference (Tagged_Type, Subp, 'p', False); end if; end if; end if; *************** package body Sem_Disp is *** 861,866 **** --- 883,892 ---- -- Now it should be a correct primitive operation, put it in the list if Present (Old_Subp) then + + -- If the type has interfaces we complete this check after we + -- set attribute Is_Dispatching_Operation + Check_Subtype_Conformant (Subp, Old_Subp); if (Chars (Subp) = Name_Initialize *************** package body Sem_Disp is *** 893,899 **** Prim := Node (Elmt); if Present (Alias (Prim)) ! and then Present (Abstract_Interface_Alias (Prim)) and then Alias (Prim) = Subp then Register_Primitive (Sloc (Prim), --- 919,925 ---- Prim := Node (Elmt); if Present (Alias (Prim)) ! and then Present (Interface_Alias (Prim)) and then Alias (Prim) = Subp then Register_Primitive (Sloc (Prim), *************** package body Sem_Disp is *** 924,929 **** --- 950,1027 ---- Set_Is_Dispatching_Operation (Subp, True); + -- Ada 2005 (AI-251): If the type implements interfaces we must check + -- subtype conformance against all the interfaces covered by this + -- primitive. + + if Present (Old_Subp) + and then Has_Interfaces (Tagged_Type) + then + declare + Ifaces_List : Elist_Id; + Iface_Elmt : Elmt_Id; + Iface_Prim_Elmt : Elmt_Id; + Iface_Prim : Entity_Id; + Ret_Typ : Entity_Id; + + begin + Collect_Interfaces (Tagged_Type, Ifaces_List); + + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + if not Is_Ancestor (Node (Iface_Elmt), Tagged_Type) then + Iface_Prim_Elmt := + First_Elmt (Primitive_Operations (Node (Iface_Elmt))); + while Present (Iface_Prim_Elmt) loop + Iface_Prim := Node (Iface_Prim_Elmt); + + if Is_Interface_Conformant + (Tagged_Type, Iface_Prim, Subp) + then + -- Handle procedures, functions whose return type + -- matches, or functions not returning interfaces + + if Ekind (Subp) = E_Procedure + or else Etype (Iface_Prim) = Etype (Subp) + or else not Is_Interface (Etype (Iface_Prim)) + then + Check_Subtype_Conformant + (New_Id => Subp, + Old_Id => Iface_Prim, + Err_Loc => Subp, + Skip_Controlling_Formals => True); + + -- Handle functions returning interfaces + + elsif Implements_Interface + (Etype (Subp), Etype (Iface_Prim)) + then + -- Temporarily force both entities to return the + -- same type. Required because Subtype_Conformant + -- does not handle this case. + + Ret_Typ := Etype (Iface_Prim); + Set_Etype (Iface_Prim, Etype (Subp)); + + Check_Subtype_Conformant + (New_Id => Subp, + Old_Id => Iface_Prim, + Err_Loc => Subp, + Skip_Controlling_Formals => True); + + Set_Etype (Iface_Prim, Ret_Typ); + end if; + end if; + + Next_Elmt (Iface_Prim_Elmt); + end loop; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + end; + end if; + if not Body_Is_Last_Primitive then Set_DT_Position (Subp, No_Uint); *************** package body Sem_Disp is *** 1074,1080 **** if Derives_From (Node (Op1)) then if No (Prev) then ! Prepend_Elmt (Subp, New_Prim); else Insert_Elmt_After (Subp, Prev); end if; --- 1172,1184 ---- if Derives_From (Node (Op1)) then if No (Prev) then ! ! -- Avoid adding it to the list of primitives if already there! ! ! if Node (Op2) /= Subp then ! Prepend_Elmt (Subp, New_Prim); ! end if; ! else Insert_Elmt_After (Subp, Prev); end if; *************** package body Sem_Disp is *** 1293,1298 **** --- 1397,1434 ---- return Empty; end Find_Dispatching_Type; + --------------------------------------- + -- Find_Primitive_Covering_Interface -- + --------------------------------------- + + function Find_Primitive_Covering_Interface + (Tagged_Type : Entity_Id; + Iface_Prim : Entity_Id) return Entity_Id + is + E : Entity_Id; + + begin + pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim)) + or else (Present (Alias (Iface_Prim)) + and then + Is_Interface + (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim))))); + + E := Current_Entity (Iface_Prim); + while Present (E) loop + if Is_Subprogram (E) + and then Is_Dispatching_Operation (E) + and then Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) + then + return E; + end if; + + E := Homonym (E); + end loop; + + return Empty; + end Find_Primitive_Covering_Interface; + --------------------------- -- Is_Dynamically_Tagged -- --------------------------- *************** package body Sem_Disp is *** 1416,1422 **** Replace_Elmt (Elmt, New_Op); if Ada_Version >= Ada_05 ! and then Has_Abstract_Interfaces (Tagged_Type) then -- Ada 2005 (AI-251): Update the attribute alias of all the aliased -- entities of the overridden primitive to reference New_Op, and also --- 1552,1558 ---- Replace_Elmt (Elmt, New_Op); if Ada_Version >= Ada_05 ! and then Has_Interfaces (Tagged_Type) then -- Ada 2005 (AI-251): Update the attribute alias of all the aliased -- entities of the overridden primitive to reference New_Op, and also *************** package body Sem_Disp is *** 1425,1430 **** --- 1561,1568 ---- -- operations that it implements (for operations inherited from the -- parent itself, this check is made when building the derived type). + -- Note: This code is only executed in case of late overriding + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); while Present (Elmt) loop Prim := Node (Elmt); *************** package body Sem_Disp is *** 1436,1449 **** -- reading attributes in entities that are not yet fully decorated elsif Is_Subprogram (Prim) ! and then Present (Abstract_Interface_Alias (Prim)) and then Alias (Prim) = Prev_Op and then Present (Etype (New_Op)) then Set_Alias (Prim, New_Op); Check_Subtype_Conformant (New_Op, Prim); ! Set_Is_Abstract_Subprogram ! (Prim, Is_Abstract_Subprogram (New_Op)); -- Ensure that this entity will be expanded to fill the -- corresponding entry in its dispatch table. --- 1574,1587 ---- -- reading attributes in entities that are not yet fully decorated elsif Is_Subprogram (Prim) ! and then Present (Interface_Alias (Prim)) and then Alias (Prim) = Prev_Op and then Present (Etype (New_Op)) then Set_Alias (Prim, New_Op); Check_Subtype_Conformant (New_Op, Prim); ! Set_Is_Abstract_Subprogram (Prim, ! Is_Abstract_Subprogram (New_Op)); -- Ensure that this entity will be expanded to fill the -- corresponding entry in its dispatch table. *************** package body Sem_Disp is *** 1540,1545 **** --- 1678,1691 ---- if VM_Target = No_VM then Expand_Dispatching_Call (Call_Node); + + -- Expansion of a dispatching call results in an indirect call, which in + -- turn causes current values to be killed (see Resolve_Call), so on VM + -- targets we do the call here to ensure consistent warnings between VM + -- and non-VM targets. + + else + Kill_Current_Values; end if; end Propagate_Tag; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_disp.ads gcc-4.4.0/gcc/ada/sem_disp.ads *** gcc-4.3.3/gcc/ada/sem_disp.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_disp.ads Mon May 26 13:43:18 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Sem_Disp is *** 69,74 **** --- 69,82 ---- -- Check whether a subprogram is dispatching, and find the tagged -- type of the controlling argument or arguments. + function Find_Primitive_Covering_Interface + (Tagged_Type : Entity_Id; + Iface_Prim : Entity_Id) return Entity_Id; + -- Search in the homonym chain for the primitive of Tagged_Type that + -- covers Iface_Prim. The homonym chain traversal is required to catch + -- primitives associated with the partial view of private types when + -- processing the corresponding full view. + function Is_Dynamically_Tagged (N : Node_Id) return Boolean; -- Used to determine whether a call is dispatching, i.e. if is an -- an expression of a class_Wide type, or a call to a function with diff -Nrcpad gcc-4.3.3/gcc/ada/sem_dist.adb gcc-4.4.0/gcc/ada/sem_dist.adb *** gcc-4.3.3/gcc/ada/sem_dist.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_dist.adb Mon May 26 14:43:50 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Namet; use Namet; *** 35,40 **** --- 35,41 ---- with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; + with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; *************** package body Sem_Dist is *** 63,69 **** procedure Add_Stub_Constructs (N : Node_Id) is U : constant Node_Id := Unit (N); Spec : Entity_Id := Empty; ! Exp : Node_Id := U; -- Unit that will be expanded begin pragma Assert (Distribution_Stub_Mode /= No_Stubs); --- 64,72 ---- procedure Add_Stub_Constructs (N : Node_Id) is U : constant Node_Id := Unit (N); Spec : Entity_Id := Empty; ! ! Exp : Node_Id := U; ! -- Unit that will be expanded begin pragma Assert (Distribution_Stub_Mode /= No_Stubs); *************** package body Sem_Dist is *** 83,89 **** or else Is_Remote_Call_Interface (Spec)); if Distribution_Stub_Mode = Generate_Caller_Stub_Body then - if Is_Shared_Passive (Spec) then null; elsif Nkind (U) = N_Package_Body then --- 86,91 ---- *************** package body Sem_Dist is *** 94,100 **** end if; else - if Is_Shared_Passive (Spec) then Build_Passive_Partition_Stub (Exp); else --- 96,101 ---- *************** package body Sem_Dist is *** 185,191 **** if Parent_Name /= No_String then Start_String (Parent_Name); Store_String_Char (Get_Char_Code ('.')); - else Start_String; end if; --- 186,191 ---- *************** package body Sem_Dist is *** 241,255 **** Par : Node_Id; begin ! if (Nkind (N) = N_Function_Call ! or else Nkind (N) = N_Procedure_Call_Statement) and then Nkind (Name (N)) in N_Has_Entity and then Is_Remote_Call_Interface (Entity (Name (N))) and then Has_All_Calls_Remote (Scope (Entity (Name (N)))) and then Comes_From_Source (N) then Par := Parent (Entity (Name (N))); - while Present (Par) and then (Nkind (Par) /= N_Package_Specification or else Is_Wrapper_Package (Defining_Entity (Par))) --- 241,253 ---- Par : Node_Id; begin ! if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) and then Nkind (Name (N)) in N_Has_Entity and then Is_Remote_Call_Interface (Entity (Name (N))) and then Has_All_Calls_Remote (Scope (Entity (Name (N)))) and then Comes_From_Source (N) then Par := Parent (Entity (Name (N))); while Present (Par) and then (Nkind (Par) /= N_Package_Specification or else Is_Wrapper_Package (Defining_Entity (Par))) *************** package body Sem_Dist is *** 268,280 **** end if; end Is_All_Remote_Call; ------------------------------------ -- Package_Specification_Of_Scope -- ------------------------------------ function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is ! N : Node_Id := Parent (E); begin while Nkind (N) /= N_Package_Specification loop N := Parent (N); end loop; --- 266,300 ---- end if; end Is_All_Remote_Call; + --------------------------------- + -- Is_RACW_Stub_Type_Operation -- + --------------------------------- + + function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean is + Dispatching_Type : Entity_Id; + + begin + case Ekind (Op) is + when E_Function | E_Procedure => + Dispatching_Type := Find_Dispatching_Type (Op); + return Present (Dispatching_Type) + and then Is_RACW_Stub_Type (Dispatching_Type) + and then not Is_Internal (Op); + + when others => + return False; + end case; + end Is_RACW_Stub_Type_Operation; + ------------------------------------ -- Package_Specification_Of_Scope -- ------------------------------------ function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is ! N : Node_Id; ! begin + N := Parent (E); while Nkind (N) /= N_Package_Specification loop N := Parent (N); end loop; *************** package body Sem_Dist is *** 295,305 **** Typ : constant Entity_Id := Etype (N); begin - Ety := Entity (Prefix (N)); - -- In case prefix is not a library unit entity, get the entity -- of library unit. while (Present (Scope (Ety)) and then Scope (Ety) /= Standard_Standard) and not Is_Child_Unit (Ety) --- 315,324 ---- Typ : constant Entity_Id := Etype (N); begin -- In case prefix is not a library unit entity, get the entity -- of library unit. + Ety := Entity (Prefix (N)); while (Present (Scope (Ety)) and then Scope (Ety) /= Standard_Standard) and not Is_Child_Unit (Ety) *************** package body Sem_Dist is *** 341,347 **** else Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id); - end if; -- Replace the attribute node by a conversion of the function call --- 360,365 ---- *************** package body Sem_Dist is *** 404,413 **** Tick_Access_Conv_Call := Make_Function_Call (Loc, ! Name => New_Occurrence_Of (Attribute_Subp, Loc), Parameter_Associations => New_List ( ! Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)), Build_Subprogram_Id (Loc, Remote_Subp), New_Occurrence_Of (Async_E, Loc), New_Occurrence_Of (All_Calls_Remote_E, Loc))); --- 422,432 ---- Tick_Access_Conv_Call := Make_Function_Call (Loc, ! Name => New_Occurrence_Of (Attribute_Subp, Loc), Parameter_Associations => New_List ( ! Make_String_Literal (Loc, ! Strval => Full_Qualified_Name (RS_Pkg_E)), Build_Subprogram_Id (Loc, Remote_Subp), New_Occurrence_Of (Async_E, Loc), New_Occurrence_Of (All_Calls_Remote_E, Loc))); *************** package body Sem_Dist is *** 505,512 **** Append_To (Priv_Decls, Make_Full_Type_Declaration (Loc, ! Defining_Identifier => ! Full_Obj_Type, Type_Definition => Make_Record_Definition (Loc, Abstract_Present => True, --- 524,530 ---- Append_To (Priv_Decls, Make_Full_Type_Declaration (Loc, ! Defining_Identifier => Full_Obj_Type, Type_Definition => Make_Record_Definition (Loc, Abstract_Present => True, *************** package body Sem_Dist is *** 536,574 **** All_Present => True, Subtype_Indication => Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of (Obj_Type, Loc), ! Attribute_Name => ! Name_Class)))); Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI); Set_Is_Remote_Types (RACW_Type, Is_RT); Subpkg_Decl := Make_Package_Declaration (Loc, Make_Package_Specification (Loc, ! Defining_Unit_Name => ! Subpkg, ! Visible_Declarations => ! Vis_Decls, ! Private_Declarations => ! Priv_Decls, ! End_Label => ! New_Occurrence_Of (Subpkg, Loc))); Set_Is_Remote_Call_Interface (Subpkg, Is_RCI); Set_Is_Remote_Types (Subpkg, Is_RT); Insert_After_And_Analyze (N, Subpkg_Decl); -- Generate package body to receive RACW calling stubs ! -- Note: Analyze_Declarations has an absolute requirement that ! -- the declaration list be non-empty, so we provide a dummy null ! -- statement here. Subpkg_Body := Make_Package_Body (Loc, ! Defining_Unit_Name => ! Make_Defining_Identifier (Loc, Chars (Subpkg)), ! Declarations => New_List ( ! Make_Null_Statement (Loc))); Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body); -- Many parts of the analyzer and expander expect --- 554,586 ---- All_Present => True, Subtype_Indication => Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Obj_Type, Loc), ! Attribute_Name => Name_Class)))); ! Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI); Set_Is_Remote_Types (RACW_Type, Is_RT); Subpkg_Decl := Make_Package_Declaration (Loc, Make_Package_Specification (Loc, ! Defining_Unit_Name => Subpkg, ! Visible_Declarations => Vis_Decls, ! Private_Declarations => Priv_Decls, ! End_Label => New_Occurrence_Of (Subpkg, Loc))); ! Set_Is_Remote_Call_Interface (Subpkg, Is_RCI); Set_Is_Remote_Types (Subpkg, Is_RT); Insert_After_And_Analyze (N, Subpkg_Decl); -- Generate package body to receive RACW calling stubs ! ! -- Note: Analyze_Declarations has an absolute requirement that the ! -- declaration list be non-empty, so provide dummy null statement here. Subpkg_Body := Make_Package_Body (Loc, ! Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)), ! Declarations => New_List (Make_Null_Statement (Loc))); Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body); -- Many parts of the analyzer and expander expect *************** package body Sem_Dist is *** 590,599 **** Make_Defining_Identifier (Loc, Name_Ras), Component_Definition => Make_Component_Definition (Loc, ! Aliased_Present => ! False, Subtype_Indication => New_Occurrence_Of (RACW_Type, Loc))))))); Set_Equivalent_Type (User_Type, Fat_Type); Set_Corresponding_Remote_Type (Fat_Type, User_Type); Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl); --- 602,611 ---- Make_Defining_Identifier (Loc, Name_Ras), Component_Definition => Make_Component_Definition (Loc, ! Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (RACW_Type, Loc))))))); + Set_Equivalent_Type (User_Type, Fat_Type); Set_Corresponding_Remote_Type (Fat_Type, User_Type); Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl); *************** package body Sem_Dist is *** 634,640 **** end if; elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then - Params := Expressions (Deref_Subp_Call); if Present (Params) then --- 646,651 ---- *************** package body Sem_Dist is *** 659,671 **** if Ekind (Deref_Proc) = E_Function then Call_Node := Make_Function_Call (Loc, ! Name => New_Occurrence_Of (Deref_Proc, Loc), Parameter_Associations => Params); - else Call_Node := Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (Deref_Proc, Loc), Parameter_Associations => Params); end if; --- 670,681 ---- if Ekind (Deref_Proc) = E_Function then Call_Node := Make_Function_Call (Loc, ! Name => New_Occurrence_Of (Deref_Proc, Loc), Parameter_Associations => Params); else Call_Node := Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (Deref_Proc, Loc), Parameter_Associations => Params); end if; *************** package body Sem_Dist is *** 689,696 **** and then (Is_Remote_Call_Interface (ET) or else Is_Remote_Types (ET)) and then Present (Corresponding_Remote_Type (ET)) ! and then (Nkind (Parent (Parent (P))) = N_Procedure_Call_Statement ! or else Nkind (Parent (Parent (P))) = N_Indexed_Component) and then Expander_Active then RAS_E_Dereference (P); --- 699,706 ---- and then (Is_Remote_Call_Interface (ET) or else Is_Remote_Types (ET)) and then Present (Corresponding_Remote_Type (ET)) ! and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement, ! N_Indexed_Component) and then Expander_Active then RAS_E_Dereference (P); *************** package body Sem_Dist is *** 766,782 **** -- We do not have to handle this case return False; - end if; Rewrite (N, Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, ! Choices => New_List ( ! Make_Identifier (Loc, Name_Ras)), ! Expression => ! Make_Null (Loc))))); Analyze_And_Resolve (N, Target_Type); return True; end Remote_AST_Null_Value; --- 776,789 ---- -- We do not have to handle this case return False; end if; Rewrite (N, Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, ! Choices => New_List (Make_Identifier (Loc, Name_Ras)), ! Expression => Make_Null (Loc))))); Analyze_And_Resolve (N, Target_Type); return True; end Remote_AST_Null_Value; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_dist.ads gcc-4.4.0/gcc/ada/sem_dist.ads *** gcc-4.3.3/gcc/ada/sem_dist.ads Wed Sep 26 10:42:09 2007 --- gcc-4.4.0/gcc/ada/sem_dist.ads Tue May 20 12:50:52 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Types; use Types; *** 31,38 **** package Sem_Dist is function Get_PCS_Name return PCS_Names; ! -- Return the name of a literal of type System.Partition_Interface. ! -- DSA_Implementation_Type indicating what PCS is currently in use. function Get_PCS_Version return Int; -- Return the version number of the PCS API implemented by the PCS. --- 31,38 ---- package Sem_Dist is function Get_PCS_Name return PCS_Names; ! -- Return the name of a literal of type DSA_Implementation_Name in package ! -- System.Partition_Interface indicating what PCS is currently in use. function Get_PCS_Version return Int; -- Return the version number of the PCS API implemented by the PCS. *************** package Sem_Dist is *** 100,103 **** --- 100,106 ---- function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id; -- Return the N_Package_Specification corresponding to a scope E + function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean; + -- True when Op is a primitive operation of an RACW stub type + end Sem_Dist; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_elab.adb gcc-4.4.0/gcc/ada/sem_elab.adb *** gcc-4.3.3/gcc/ada/sem_elab.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_elab.adb Sun Apr 13 17:41:15 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2008, 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- -- *************** with Uname; use Uname; *** 58,68 **** package body Sem_Elab is ! -- The following table records the recursive call chain for output ! -- in the Output routine. Each entry records the call node and the ! -- entity of the called routine. The number of entries in the table ! -- (i.e. the value of Elab_Call.Last) indicates the current depth ! -- of recursion and is used to identify the outer level. type Elab_Call_Entry is record Cloc : Source_Ptr; --- 58,68 ---- package body Sem_Elab is ! -- The following table records the recursive call chain for output in the ! -- Output routine. Each entry records the call node and the entity of the ! -- called routine. The number of entries in the table (i.e. the value of ! -- Elab_Call.Last) indicates the current depth of recursion and is used to ! -- identify the outer level. type Elab_Call_Entry is record Cloc : Source_Ptr; *************** package body Sem_Elab is *** 77,86 **** Table_Increment => 100, Table_Name => "Elab_Call"); ! -- This table is initialized at the start of each outer level call. ! -- It holds the entities for all subprograms that have been examined ! -- for this particular outer level call, and is used to prevent both ! -- infinite recursion, and useless reanalysis of bodies already seen package Elab_Visited is new Table.Table ( Table_Component_Type => Entity_Id, --- 77,86 ---- Table_Increment => 100, Table_Name => "Elab_Call"); ! -- This table is initialized at the start of each outer level call. It ! -- holds the entities for all subprograms that have been examined for this ! -- particular outer level call, and is used to prevent both infinite ! -- recursion, and useless reanalysis of bodies already seen package Elab_Visited is new Table.Table ( Table_Component_Type => Entity_Id, *************** package body Sem_Elab is *** 127,135 **** Table_Name => "Delay_Check"); C_Scope : Entity_Id; ! -- Top level scope of current scope. We need to compute this only ! -- once at the outer level, i.e. for a call to Check_Elab_Call from ! -- outside this unit. Outer_Level_Sloc : Source_Ptr; -- Save Sloc value for outer level call node for comparisons of source --- 127,134 ---- Table_Name => "Delay_Check"); C_Scope : Entity_Id; ! -- Top level scope of current scope. Compute this only once at the outer ! -- level, i.e. for a call to Check_Elab_Call from outside this unit. Outer_Level_Sloc : Source_Ptr; -- Save Sloc value for outer level call node for comparisons of source *************** package body Sem_Elab is *** 149,157 **** Delaying_Elab_Checks : Boolean := True; -- This is set True till the compilation is complete, including the ! -- insertion of all instance bodies. Then when Check_Elab_Calls is ! -- called, the delay table is used to make the delayed calls and ! -- this flag is reset to False, so that the calls are processed ----------------------- -- Local Subprograms -- --- 148,156 ---- Delaying_Elab_Checks : Boolean := True; -- This is set True till the compilation is complete, including the ! -- insertion of all instance bodies. Then when Check_Elab_Calls is called, ! -- the delay table is used to make the delayed calls and this flag is reset ! -- to False, so that the calls are processed ----------------------- -- Local Subprograms -- *************** package body Sem_Elab is *** 177,192 **** Outer_Scope : Entity_Id; Inter_Unit_Only : Boolean; Generate_Warnings : Boolean := True); ! -- This is the internal recursive routine that is called to check for ! -- a possible elaboration error. The argument N is a subprogram call ! -- or generic instantiation to be checked, and E is the entity of ! -- the called subprogram, or instantiated generic unit. The flag ! -- Outer_Scope is the outer level scope for the original call. ! -- Inter_Unit_Only is set if the call is only to be checked in the ! -- case where it is to another unit (and skipped if within a unit). ! -- Generate_Warnings is set to False to suppress warning messages ! -- about missing pragma Elaborate_All's. These messages are not ! -- wanted for inner calls in the dynamic model. procedure Check_Bad_Instantiation (N : Node_Id); -- N is a node for an instantiation (if called with any other node kind, --- 176,190 ---- Outer_Scope : Entity_Id; Inter_Unit_Only : Boolean; Generate_Warnings : Boolean := True); ! -- This is the internal recursive routine that is called to check for a ! -- possible elaboration error. The argument N is a subprogram call or ! -- generic instantiation to be checked, and E is the entity of the called ! -- subprogram, or instantiated generic unit. The flag Outer_Scope is the ! -- outer level scope for the original call. Inter_Unit_Only is set if the ! -- call is only to be checked in the case where it is to another unit (and ! -- skipped if within a unit). Generate_Warnings is set to False to suppress ! -- warning messages about missing pragma Elaborate_All's. These messages ! -- are not wanted for inner calls in the dynamic model. procedure Check_Bad_Instantiation (N : Node_Id); -- N is a node for an instantiation (if called with any other node kind, *************** package body Sem_Elab is *** 207,220 **** E : Entity_Id; Outer_Scope : Entity_Id; Orig_Ent : Entity_Id); ! -- N is a function call or procedure statement call node and E is ! -- the entity of the called function, which is within the current ! -- compilation unit (where subunits count as part of the parent). ! -- This call checks if this call, or any call within any accessed ! -- body could cause an ABE, and if so, outputs a warning. Orig_Ent ! -- differs from E only in the case of renamings, and points to the ! -- original name of the entity. This is used for error messages. ! -- Outer_Scope is the outer level scope for the original call. procedure Check_Internal_Call_Continue (N : Node_Id; --- 205,218 ---- E : Entity_Id; Outer_Scope : Entity_Id; Orig_Ent : Entity_Id); ! -- N is a function call or procedure statement call node and E is the ! -- entity of the called function, which is within the current compilation ! -- unit (where subunits count as part of the parent). This call checks if ! -- this call, or any call within any accessed body could cause an ABE, and ! -- if so, outputs a warning. Orig_Ent differs from E only in the case of ! -- renamings, and points to the original name of the entity. This is used ! -- for error messages. Outer_Scope is the outer level scope for the ! -- original call. procedure Check_Internal_Call_Continue (N : Node_Id; *************** package body Sem_Elab is *** 224,233 **** -- The processing for Check_Internal_Call is divided up into two phases, -- and this represents the second phase. The second phase is delayed if -- Delaying_Elab_Calls is set to True. In this delayed case, the first ! -- phase makes an entry in the Delay_Check table, which is processed ! -- when Check_Elab_Calls is called. N, E and Orig_Ent are as for the call ! -- to Check_Internal_Call. Outer_Scope is the outer level scope for ! -- the original call. procedure Set_Elaboration_Constraint (Call : Node_Id; --- 222,231 ---- -- The processing for Check_Internal_Call is divided up into two phases, -- and this represents the second phase. The second phase is delayed if -- Delaying_Elab_Calls is set to True. In this delayed case, the first ! -- phase makes an entry in the Delay_Check table, which is processed when ! -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to ! -- Check_Internal_Call. Outer_Scope is the outer level scope for the ! -- original call. procedure Set_Elaboration_Constraint (Call : Node_Id; *************** package body Sem_Elab is *** 268,283 **** -- inevitable, given the optional body semantics of Ada). procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); ! -- Given code for an elaboration check (or unconditional raise if ! -- the check is not needed), inserts the code in the appropriate ! -- place. N is the call or instantiation node for which the check ! -- code is required. C is the test whose failure triggers the raise. procedure Output_Calls (N : Node_Id); ! -- Outputs chain of calls stored in the Elab_Call table. The caller ! -- has already generated the main warning message, so the warnings ! -- generated are all continuation messages. The argument is the ! -- call node at which the messages are to be placed. function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; -- Given two scopes, determine whether they are the same scope from an --- 266,281 ---- -- inevitable, given the optional body semantics of Ada). procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); ! -- Given code for an elaboration check (or unconditional raise if the check ! -- is not needed), inserts the code in the appropriate place. N is the call ! -- or instantiation node for which the check code is required. C is the ! -- test whose failure triggers the raise. procedure Output_Calls (N : Node_Id); ! -- Outputs chain of calls stored in the Elab_Call table. The caller has ! -- already generated the main warning message, so the warnings generated ! -- are all continuation messages. The argument is the call node at which ! -- the messages are to be placed. function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; -- Given two scopes, determine whether they are the same scope from an *************** package body Sem_Elab is *** 288,304 **** -- to be the enclosing compilation unit of this scope. function Spec_Entity (E : Entity_Id) return Entity_Id; ! -- Given a compilation unit entity, if it is a spec entity, it is ! -- returned unchanged. If it is a body entity, then the spec for ! -- the corresponding spec is returned procedure Supply_Bodies (N : Node_Id); -- Given a node, N, that is either a subprogram declaration or a package -- declaration, this procedure supplies dummy bodies for the subprogram -- or for all subprograms in the package. If the given node is not one -- of these two possibilities, then Supply_Bodies does nothing. The ! -- dummy body is supplied by setting the subprogram to be Imported with ! -- convention Stubbed. procedure Supply_Bodies (L : List_Id); -- Calls Supply_Bodies for all elements of the given list L --- 286,301 ---- -- to be the enclosing compilation unit of this scope. function Spec_Entity (E : Entity_Id) return Entity_Id; ! -- Given a compilation unit entity, if it is a spec entity, it is returned ! -- unchanged. If it is a body entity, then the spec for the corresponding ! -- spec is returned procedure Supply_Bodies (N : Node_Id); -- Given a node, N, that is either a subprogram declaration or a package -- declaration, this procedure supplies dummy bodies for the subprogram -- or for all subprograms in the package. If the given node is not one -- of these two possibilities, then Supply_Bodies does nothing. The ! -- dummy body contains a single Raise statement. procedure Supply_Bodies (L : List_Id); -- Calls Supply_Bodies for all elements of the given list L *************** package body Sem_Elab is *** 480,490 **** Decl : Node_Id; E_Scope : Entity_Id; ! -- Top level scope of entity for called subprogram. This ! -- value includes following renamings and derivations, so ! -- this scope can be in a non-visible unit. This is the ! -- scope that is to be investigated to see whether an ! -- elaboration check is required. W_Scope : Entity_Id; -- Top level scope of directly called entity for subprogram. This --- 477,486 ---- Decl : Node_Id; E_Scope : Entity_Id; ! -- Top level scope of entity for called subprogram. This value includes ! -- following renamings and derivations, so this scope can be in a ! -- non-visible unit. This is the scope that is to be investigated to ! -- see whether an elaboration check is required. W_Scope : Entity_Id; -- Top level scope of directly called entity for subprogram. This *************** package body Sem_Elab is *** 495,501 **** -- calls and calls involving object notation) where W_Scope might not -- be in the context of the current unit, and there is an intermediate -- package that is, in which case the Elaborate_All has to be placed ! -- on this intedermediate package. These special cases are handled in -- Set_Elaboration_Constraint. Body_Acts_As_Spec : Boolean; --- 491,497 ---- -- calls and calls involving object notation) where W_Scope might not -- be in the context of the current unit, and there is an intermediate -- package that is, in which case the Elaborate_All has to be placed ! -- on this intermediate package. These special cases are handled in -- Set_Elaboration_Constraint. Body_Acts_As_Spec : Boolean; *************** package body Sem_Elab is *** 531,538 **** return; end if; ! -- Go to parent for derived subprogram, or to original subprogram ! -- in the case of a renaming (Alias covers both these cases) Ent := E; loop --- 527,534 ---- return; end if; ! -- Go to parent for derived subprogram, or to original subprogram in the ! -- case of a renaming (Alias covers both these cases). Ent := E; loop *************** package body Sem_Elab is *** 646,661 **** return; end if; ! -- Nothing to do for a generic instance, because in this case ! -- the checking was at the point of instantiation of the generic ! -- However, this shortcut is only applicable in static mode. if Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then return; end if; ! -- Nothing to do if subprogram with no separate spec. However, ! -- a call to Deep_Initialize may result in a call to a user-defined -- Initialize procedure, which imposes a body dependency. This -- happens only if the type is controlled and the Initialize -- procedure is not inherited. --- 642,657 ---- return; end if; ! -- Nothing to do for a generic instance, because in this case the ! -- checking was at the point of instantiation of the generic However, ! -- this shortcut is only applicable in static mode. if Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then return; end if; ! -- Nothing to do if subprogram with no separate spec. However, a ! -- call to Deep_Initialize may result in a call to a user-defined -- Initialize procedure, which imposes a body dependency. This -- happens only if the type is controlled and the Initialize -- procedure is not inherited. *************** package body Sem_Elab is *** 762,769 **** then E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); ! -- If we don't get a spec entity, just ignore call. Not ! -- quite clear why this check is necessary. if No (E_Scope) then return; --- 758,765 ---- then E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); ! -- If we don't get a spec entity, just ignore call. Not quite ! -- clear why this check is necessary. ??? if No (E_Scope) then return; *************** package body Sem_Elab is *** 775,790 **** E_Scope := Scope (E_Scope); end loop; ! -- For the case N is not an instance, or a call within instance ! -- We recompute E_Scope for the error message, since we ! -- do NOT want to go to the unit which has the ultimate ! -- declaration in the case of renaming and derivation and ! -- we also want to go to the generic unit in the case of ! -- an instance, and no further. else ! -- Loop to carefully follow renamings and derivations ! -- one step outside the current unit, but not further. if not Inst_Case and then Present (Alias (Ent)) --- 771,785 ---- E_Scope := Scope (E_Scope); end loop; ! -- For the case N is not an instance, or a call within instance, we ! -- recompute E_Scope for the error message, since we do NOT want to ! -- go to the unit which has the ultimate declaration in the case of ! -- renaming and derivation and we also want to go to the generic unit ! -- in the case of an instance, and no further. else ! -- Loop to carefully follow renamings and derivations one step ! -- outside the current unit, but not further. if not Inst_Case and then Present (Alias (Ent)) *************** package body Sem_Elab is *** 879,885 **** if Inst_Case then Elab_Warning ("instantiation of& may raise Program_Error?", ! "instantiation of& during elaboration?", Ent); else if Nkind (Name (N)) in N_Has_Entity --- 874,880 ---- if Inst_Case then Elab_Warning ("instantiation of& may raise Program_Error?", ! "info: instantiation of& during elaboration?", Ent); else if Nkind (Name (N)) in N_Has_Entity *************** package body Sem_Elab is *** 888,900 **** then Elab_Warning ("implicit call to & may raise Program_Error?", ! "implicit call to & during elaboration?", Ent); else Elab_Warning ("call to & may raise Program_Error?", ! "call to & during elaboration?", Ent); end if; end if; --- 883,895 ---- then Elab_Warning ("implicit call to & may raise Program_Error?", ! "info: implicit call to & during elaboration?", Ent); else Elab_Warning ("call to & may raise Program_Error?", ! "info: call to & during elaboration?", Ent); end if; end if; *************** package body Sem_Elab is *** 904,915 **** if Nkind (N) in N_Subprogram_Instantiation then Elab_Warning ("\missing pragma Elaborate for&?", ! "\implicit pragma Elaborate for& generated?", W_Scope); else Elab_Warning ("\missing pragma Elaborate_All for&?", ! "\implicit pragma Elaborate_All for & generated?", W_Scope); end if; end Generate_Elab_Warnings; --- 899,910 ---- if Nkind (N) in N_Subprogram_Instantiation then Elab_Warning ("\missing pragma Elaborate for&?", ! "\info: implicit pragma Elaborate for& generated?", W_Scope); else Elab_Warning ("\missing pragma Elaborate_All for&?", ! "\info: implicit pragma Elaborate_All for & generated?", W_Scope); end if; end Generate_Elab_Warnings; *************** package body Sem_Elab is *** 936,943 **** -- Runtime elaboration check required. Generate check of the -- elaboration Boolean for the unit containing the entity. ! -- Note that for this case, we do check the real unit (the ! -- one from following renamings, since that is the issue!) -- Could this possibly miss a useless but required PE??? --- 931,938 ---- -- Runtime elaboration check required. Generate check of the -- elaboration Boolean for the unit containing the entity. ! -- Note that for this case, we do check the real unit (the one ! -- from following renamings, since that is the issue!) -- Could this possibly miss a useless but required PE??? *************** package body Sem_Elab is *** 952,961 **** -- Case of static elaboration model else ! -- Do not do anything if elaboration checks suppressed. Note ! -- that we check Ent here, not E, since we want the real entity ! -- for the body to see if checks are suppressed for it, not the ! -- dummy entry for renamings or derivations. if Elaboration_Checks_Suppressed (Ent) or else Elaboration_Checks_Suppressed (E_Scope) --- 947,956 ---- -- Case of static elaboration model else ! -- Do not do anything if elaboration checks suppressed. Note that ! -- we check Ent here, not E, since we want the real entity for the ! -- body to see if checks are suppressed for it, not the dummy ! -- entry for renamings or derivations. if Elaboration_Checks_Suppressed (Ent) or else Elaboration_Checks_Suppressed (E_Scope) *************** package body Sem_Elab is *** 1111,1117 **** function Get_Called_Ent return Entity_Id; -- Retrieve called entity. If this is a call to a protected subprogram, -- entity is a selected component. The callable entity may be absent, ! -- in which case there is no check to perform. This happens with -- non-analyzed calls in nested generics. -------------------- --- 1106,1112 ---- function Get_Called_Ent return Entity_Id; -- Retrieve called entity. If this is a call to a protected subprogram, -- entity is a selected component. The callable entity may be absent, ! -- in which case there is no check to perform. This happens with -- non-analyzed calls in nested generics. -------------------- *************** package body Sem_Elab is *** 1201,1208 **** -- is at the time of the actual call (statically speaking) that we must -- do our static check, not at the time of its initial analysis). ! -- However, we have to check calls within component definitions (e.g., a ! -- function call that determines an array component bound), so we -- terminate the loop in that case. P := Parent (N); --- 1196,1203 ---- -- is at the time of the actual call (statically speaking) that we must -- do our static check, not at the time of its initial analysis). ! -- However, we have to check calls within component definitions (e.g. ! -- a function call that determines an array component bound), so we -- terminate the loop in that case. P := Parent (N); *************** package body Sem_Elab is *** 1229,1236 **** if No (Outer_Scope) then Elab_Visited.Set_Last (0); ! -- Nothing to do if current scope is Standard (this is a bit ! -- odd, but it happens in the case of generic instantiations). C_Scope := Current_Scope; --- 1224,1231 ---- if No (Outer_Scope) then Elab_Visited.Set_Last (0); ! -- Nothing to do if current scope is Standard (this is a bit odd, but ! -- it happens in the case of generic instantiations). C_Scope := Current_Scope; *************** package body Sem_Elab is *** 1243,1251 **** From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; if From_Elab_Code then ! -- Complain if call that comes from source in preelaborated ! -- unit and we are not inside a subprogram (i.e. we are in ! -- elab code) if Comes_From_Source (N) and then In_Preelaborated_Unit --- 1238,1245 ---- From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; if From_Elab_Code then ! -- Complain if call that comes from source in preelaborated unit ! -- and we are not inside a subprogram (i.e. we are in elab code). if Comes_From_Source (N) and then In_Preelaborated_Unit *************** package body Sem_Elab is *** 1456,1464 **** -- A call to an Init_Proc in elaboration code may bring additional -- dependencies, if some of the record components thereof have ! -- initializations that are function calls that come from source. ! -- We treat the current node as a call to each of these functions, ! -- to check their elaboration impact. if Is_Init_Proc (Ent) and then From_Elab_Code --- 1450,1458 ---- -- A call to an Init_Proc in elaboration code may bring additional -- dependencies, if some of the record components thereof have ! -- initializations that are function calls that come from source. We ! -- treat the current node as a call to each of these functions, to check ! -- their elaboration impact. if Is_Init_Proc (Ent) and then From_Elab_Code *************** package body Sem_Elab is *** 1521,1529 **** Pkg_Body : Entity_Id; begin ! -- For record or array component, check prefix. If it is an access ! -- type, then there is nothing to do (we do not know what is being ! -- assigned), but otherwise this is an assignment to the prefix. if Nkind (N) = N_Indexed_Component or else --- 1515,1523 ---- Pkg_Body : Entity_Id; begin ! -- For record or array component, check prefix. If it is an access type, ! -- then there is nothing to do (we do not know what is being assigned), ! -- but otherwise this is an assignment to the prefix. if Nkind (N) = N_Indexed_Component or else *************** package body Sem_Elab is *** 1654,1665 **** return; end if; - -- All OK if warnings suppressed on the entity - - if Warnings_Off (Ent) then - return; - end if; - -- All OK if all warnings suppressed if Warning_Mode = Suppress then --- 1648,1653 ---- *************** package body Sem_Elab is *** 1691,1706 **** -- Here is where we give the warning ! Error_Msg_Sloc := Sloc (Ent); ! Error_Msg_NE ! ("?elaboration code may access& before it is initialized", ! N, Ent); ! Error_Msg_NE ! ("\?suggest adding pragma Elaborate_Body to spec of &", ! N, Scop); ! Error_Msg_N ! ("\?or an explicit initialization could be added #", N); if not All_Errors_Mode then Set_Suppress_Elaboration_Warnings (Ent); --- 1679,1698 ---- -- Here is where we give the warning ! -- All OK if warnings suppressed on the entity ! if not Has_Warnings_Off (Ent) then ! Error_Msg_Sloc := Sloc (Ent); ! ! Error_Msg_NE ! ("?elaboration code may access& before it is initialized", ! N, Ent); ! Error_Msg_NE ! ("\?suggest adding pragma Elaborate_Body to spec of &", ! N, Scop); ! Error_Msg_N ! ("\?or an explicit initialization could be added #", N); ! end if; if not All_Errors_Mode then Set_Suppress_Elaboration_Warnings (Ent); *************** package body Sem_Elab is *** 1714,1723 **** procedure Check_Elab_Calls is begin ! -- If expansion is disabled, do not generate any checks. Also ! -- skip checks if any subunits are missing because in either ! -- case we lack the full information that we need, and no object ! -- file will be created in any case. if not Expander_Active or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) --- 1706,1715 ---- procedure Check_Elab_Calls is begin ! -- If expansion is disabled, do not generate any checks. Also skip ! -- checks if any subunits are missing because in either case we lack the ! -- full information that we need, and no object file will be created in ! -- any case. if not Expander_Active or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) *************** package body Sem_Elab is *** 1803,1809 **** -- outer level call. -- It is an outer level instantiation from elaboration code, or the ! -- instantiated entity is in the same elaboratoin scope. -- And in these cases, we will check both the inter-unit case and -- the intra-unit (within a single unit) case. --- 1795,1801 ---- -- outer level call. -- It is an outer level instantiation from elaboration code, or the ! -- instantiated entity is in the same elaboration scope. -- And in these cases, we will check both the inter-unit case and -- the intra-unit (within a single unit) case. *************** package body Sem_Elab is *** 1824,1834 **** Set_C_Scope; Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); ! -- If none of those cases holds, but Dynamic_Elaboration_Checks mode ! -- is set, then we will do the check, but only in the inter-unit case ! -- (this is to accommodate unguarded elaboration calls from other units ! -- in which this same mode is set). We inhibit warnings in this case, ! -- since this instantiation is not occurring in elaboration code. elsif Dynamic_Elaboration_Checks then Set_C_Scope; --- 1816,1826 ---- Set_C_Scope; Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); ! -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is ! -- set, then we will do the check, but only in the inter-unit case (this ! -- is to accommodate unguarded elaboration calls from other units in ! -- which this same mode is set). We inhibit warnings in this case, since ! -- this instantiation is not occurring in elaboration code. elsif Dynamic_Elaboration_Checks then Set_C_Scope; *************** package body Sem_Elab is *** 1884,1893 **** elsif not Full_Analysis then return; ! -- Nothing to do if within a default expression, since the call ! -- is not actualy being made at this time. ! elsif In_Default_Expression then return; -- Nothing to do for call to intrinsic subprogram --- 1876,1885 ---- elsif not Full_Analysis then return; ! -- Nothing to do if analyzing in special spec-expression mode, since the ! -- call is not actually being made at this time. ! elsif In_Spec_Expression then return; -- Nothing to do for call to intrinsic subprogram *************** package body Sem_Elab is *** 1993,2008 **** Check_Elab_Instantiation (N, Outer_Scope); return OK; ! -- Skip subprogram bodies that come from source (wait for ! -- call to analyze these). The reason for the come from ! -- source test is to avoid catching task bodies. ! -- For task bodies, we should really avoid these too, waiting ! -- for the task activation, but that's too much trouble to ! -- catch for now, so we go in unconditionally. This is not ! -- so terrible, it means the error backtrace is not quite ! -- complete, and we are too eager to scan bodies of tasks ! -- that are unused, but this is hardly very significant! elsif Nkind (N) = N_Subprogram_Body and then Comes_From_Source (N) --- 1985,2000 ---- Check_Elab_Instantiation (N, Outer_Scope); return OK; ! -- Skip subprogram bodies that come from source (wait for call to ! -- analyze these). The reason for the come from source test is to ! -- avoid catching task bodies. ! -- For task bodies, we should really avoid these too, waiting for the ! -- task activation, but that's too much trouble to catch for now, so ! -- we go in unconditionally. This is not so terrible, it means the ! -- error backtrace is not quite complete, and we are too eager to ! -- scan bodies of tasks that are unused, but this is hardly very ! -- significant! elsif Nkind (N) = N_Subprogram_Body and then Comes_From_Source (N) *************** package body Sem_Elab is *** 2053,2060 **** end if; end if; ! -- If the body appears after the outer level call or ! -- instantiation then we have an error case handled below. if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) and then not In_Task_Activation --- 2045,2052 ---- end if; end if; ! -- If the body appears after the outer level call or instantiation then ! -- we have an error case handled below. if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) and then not In_Task_Activation *************** package body Sem_Elab is *** 2067,2074 **** elsif Inst_Case then return; ! -- Otherwise we have a call, so we trace through the called ! -- body to see if it has any problems .. else pragma Assert (Nkind (Sbody) = N_Subprogram_Body); --- 2059,2066 ---- elsif Inst_Case then return; ! -- Otherwise we have a call, so we trace through the called body to see ! -- if it has any problems. else pragma Assert (Nkind (Sbody) = N_Subprogram_Body); *************** package body Sem_Elab is *** 2085,2093 **** Write_Eol; end if; ! -- Now traverse declarations and statements of subprogram body. ! -- Note that we cannot simply Traverse (Sbody), since traverse ! -- does not normally visit subprogram bodies. declare Decl : Node_Id; --- 2077,2085 ---- Write_Eol; end if; ! -- Now traverse declarations and statements of subprogram body. Note ! -- that we cannot simply Traverse (Sbody), since traverse does not ! -- normally visit subprogram bodies. declare Decl : Node_Id; *************** package body Sem_Elab is *** 2105,2115 **** return; end if; ! -- Here is the case of calling a subprogram where the body has ! -- not yet been encountered, a warning message is needed. ! -- If we have nothing in the call stack, then this is at the ! -- outer level, and the ABE is bound to occur. if Elab_Call.Last = 0 then if Inst_Case then --- 2097,2107 ---- return; end if; ! -- Here is the case of calling a subprogram where the body has not yet ! -- been encountered, a warning message is needed. ! -- If we have nothing in the call stack, then this is at the outer ! -- level, and the ABE is bound to occur. if Elab_Call.Last = 0 then if Inst_Case then *************** package body Sem_Elab is *** 2416,2422 **** and then not Restriction_Active (No_Entry_Calls_In_Elaboration_Code) then ! -- Runtime elaboration check required. generate check of the -- elaboration Boolean for the unit containing the entity. Insert_Elab_Check (N, --- 2408,2414 ---- and then not Restriction_Active (No_Entry_Calls_In_Elaboration_Code) then ! -- Runtime elaboration check required. Generate check of the -- elaboration Boolean for the unit containing the entity. Insert_Elab_Check (N, *************** package body Sem_Elab is *** 2479,2486 **** and then Present (Parameter_Associations (Call)) and then Is_Controlled (Etype (First_Actual (Call))); begin ! -- If the unit is mentioned in a with_clause of the current ! -- unit, it is visible, and we can set the elaboration flag. if Is_Immediately_Visible (Scop) or else (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop)) --- 2471,2478 ---- and then Present (Parameter_Associations (Call)) and then Is_Controlled (Etype (First_Actual (Call))); begin ! -- If the unit is mentioned in a with_clause of the current unit, it is ! -- visible, and we can set the elaboration flag. if Is_Immediately_Visible (Scop) or else (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop)) *************** package body Sem_Elab is *** 2507,2515 **** return; end if; ! -- If the unit is not in the context, there must be an intermediate ! -- unit that is, on which we need to place to elaboration flag. This ! -- happens with init proc calls. if Is_Init_Proc (Subp) or else Init_Call --- 2499,2507 ---- return; end if; ! -- If the unit is not in the context, there must be an intermediate unit ! -- that is, on which we need to place to elaboration flag. This happens ! -- with init proc calls. if Is_Init_Proc (Subp) or else Init_Call *************** package body Sem_Elab is *** 2563,2592 **** function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; -- Determine if the list of nodes headed by N and linked by Next ! -- contains a package body for the package spec entity E, and if ! -- so return the package body. If not, then returns Empty. function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; -- This procedure is called load the unit whose name is given by Nam. -- This unit is being loaded to see whether it contains an optional ! -- generic body. The returned value is the loaded unit, which is ! -- always a package body (only package bodies can contain other ! -- entities in the sense in which Has_Generic_Body is interested). ! -- We only attempt to load bodies if we are generating code. If we ! -- are in semantics check only mode, then it would be wrong to load ! -- bodies that are not required from a semantic point of view, so ! -- in this case we return Empty. The result is that the caller may ! -- incorrectly decide that a generic spec does not have a body when ! -- in fact it does, but the only harm in this is that some warnings ! -- on elaboration problems may be lost in semantic checks only mode, ! -- which is not big loss. We also return Empty if we go for a body ! -- and it is not there. function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; -- PE is the entity for a package spec. This function locates the ! -- corresponding package body, returning Empty if none is found. ! -- The package body returned is fully parsed but may not yet be ! -- analyzed, so only syntactic fields should be referenced. ------------------ -- Find_Body_In -- --- 2555,2583 ---- function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; -- Determine if the list of nodes headed by N and linked by Next ! -- contains a package body for the package spec entity E, and if so ! -- return the package body. If not, then returns Empty. function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; -- This procedure is called load the unit whose name is given by Nam. -- This unit is being loaded to see whether it contains an optional ! -- generic body. The returned value is the loaded unit, which is always ! -- a package body (only package bodies can contain other entities in the ! -- sense in which Has_Generic_Body is interested). We only attempt to ! -- load bodies if we are generating code. If we are in semantics check ! -- only mode, then it would be wrong to load bodies that are not ! -- required from a semantic point of view, so in this case we return ! -- Empty. The result is that the caller may incorrectly decide that a ! -- generic spec does not have a body when in fact it does, but the only ! -- harm in this is that some warnings on elaboration problems may be ! -- lost in semantic checks only mode, which is not big loss. We also ! -- return Empty if we go for a body and it is not there. function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; -- PE is the entity for a package spec. This function locates the ! -- corresponding package body, returning Empty if none is found. The ! -- package body returned is fully parsed but may not yet be analyzed, ! -- so only syntactic fields should be referenced. ------------------ -- Find_Body_In -- *************** package body Sem_Elab is *** 2668,2684 **** begin if Is_Library_Level_Entity (PE) then ! -- If package is a library unit that requires a body, we have ! -- no choice but to go after that body because it might contain ! -- an optional body for the original generic package. if Unit_Requires_Body (PE) then ! -- Load the body. Note that we are a little careful here to ! -- use Spec to get the unit number, rather than PE or Decl, ! -- since in the case where the package is itself a library ! -- level instantiation, Spec will properly reference the ! -- generic template, which is what we really want. return Load_Package_Body --- 2659,2675 ---- begin if Is_Library_Level_Entity (PE) then ! -- If package is a library unit that requires a body, we have no ! -- choice but to go after that body because it might contain an ! -- optional body for the original generic package. if Unit_Requires_Body (PE) then ! -- Load the body. Note that we are a little careful here to use ! -- Spec to get the unit number, rather than PE or Decl, since ! -- in the case where the package is itself a library level ! -- instantiation, Spec will properly reference the generic ! -- template, which is what we really want. return Load_Package_Body *************** package body Sem_Elab is *** 3043,3050 **** declare Ent : constant Entity_Id := Defining_Unit_Name (Specification (N)); begin ! Set_Is_Imported (Ent); ! Set_Convention (Ent, Convention_Stubbed); end; elsif Nkind (N) = N_Package_Declaration then --- 3034,3088 ---- declare Ent : constant Entity_Id := Defining_Unit_Name (Specification (N)); begin ! ! -- Internal subprograms will already have a generated body, so ! -- there is no need to provide a stub for them. ! ! if No (Corresponding_Body (N)) then ! declare ! Loc : constant Source_Ptr := Sloc (N); ! B : Node_Id; ! Formals : constant List_Id := ! Copy_Parameter_List (Ent); ! Nam : constant Entity_Id := ! Make_Defining_Identifier (Loc, Chars (Ent)); ! Spec : Node_Id; ! Stats : constant List_Id := ! New_List ! (Make_Raise_Program_Error (Loc, ! Reason => PE_Access_Before_Elaboration)); ! begin ! if Ekind (Ent) = E_Function then ! Spec := ! Make_Function_Specification (Loc, ! Defining_Unit_Name => Nam, ! Parameter_Specifications => Formals, ! Result_Definition => ! New_Copy_Tree ! (Result_Definition (Specification (N)))); ! ! -- We cannot reliably make a return statement for this ! -- body, but none is needed because the call raises ! -- program error. ! ! Set_Return_Present (Ent); ! ! else ! Spec := ! Make_Procedure_Specification (Loc, ! Defining_Unit_Name => Nam, ! Parameter_Specifications => Formals); ! end if; ! ! B := Make_Subprogram_Body (Loc, ! Specification => Spec, ! Declarations => New_List, ! Handled_Statement_Sequence => ! Make_Handled_Sequence_Of_Statements (Loc, Stats)); ! Insert_After (N, B); ! Analyze (B); ! end; ! end if; end; elsif Nkind (N) = N_Package_Declaration then *************** package body Sem_Elab is *** 3077,3098 **** function Within (E1, E2 : Entity_Id) return Boolean is Scop : Entity_Id; - begin Scop := E1; loop if Scop = E2 then return True; - elsif Scop = Standard_Standard then return False; - else Scop := Scope (Scop); end if; end loop; - - raise Program_Error; end Within; -------------------------- --- 3115,3131 ---- *************** package body Sem_Elab is *** 3109,3115 **** Item := First (Context_Items (Cunit (Current_Sem_Unit))); while Present (Item) loop if Nkind (Item) = N_Pragma ! and then Get_Pragma_Id (Chars (Item)) = Pragma_Elaborate_All then -- Return if some previous error on the pragma itself --- 3142,3148 ---- Item := First (Context_Items (Cunit (Current_Sem_Unit))); while Present (Item) loop if Nkind (Item) = N_Pragma ! and then Pragma_Name (Item) = Name_Elaborate_All then -- Return if some previous error on the pragma itself diff -Nrcpad gcc-4.3.3/gcc/ada/sem_elab.ads gcc-4.4.0/gcc/ada/sem_elab.ads *** gcc-4.3.3/gcc/ada/sem_elab.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_elab.ads Sun Apr 13 17:41:15 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2008, 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- -- *************** package Sem_Elab is *** 85,91 **** -- Note on pragma Elaborate. The checking here assumes that a pragma -- Elaborate on a with'ed unit guarantees that subprograms within the -- unit can be called without causing an ABE. This is not in fact the ! -- case since pragma Elaborate does not guarantee the transititive -- coverage guaranteed by Elaborate_All. However, we leave this issue -- up to the binder, which has generates warnings if there are possible -- problems in the use of pragma Elaborate. --- 85,91 ---- -- Note on pragma Elaborate. The checking here assumes that a pragma -- Elaborate on a with'ed unit guarantees that subprograms within the -- unit can be called without causing an ABE. This is not in fact the ! -- case since pragma Elaborate does not guarantee the transitive -- coverage guaranteed by Elaborate_All. However, we leave this issue -- up to the binder, which has generates warnings if there are possible -- problems in the use of pragma Elaborate. diff -Nrcpad gcc-4.3.3/gcc/ada/sem_elim.adb gcc-4.4.0/gcc/ada/sem_elim.adb *** gcc-4.3.3/gcc/ada/sem_elim.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_elim.adb Fri Feb 20 15:20:38 2009 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2008, 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- -- *************** package body Sem_Elim is *** 476,482 **** end loop; -- Find last non-space before this colon. If there ! -- is no no space character before this colon, then -- return False. Otherwise, End_Idx set to point to -- this non-space character. --- 476,482 ---- end loop; -- Find last non-space before this colon. If there ! -- is no space character before this colon, then -- return False. Otherwise, End_Idx set to point to -- this non-space character. diff -Nrcpad gcc-4.3.3/gcc/ada/sem_elim.ads gcc-4.4.0/gcc/ada/sem_elim.ads *** gcc-4.3.3/gcc/ada/sem_elim.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_elim.ads Sun Apr 13 17:41:15 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2008, 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- -- *************** with Types; use Types; *** 30,36 **** package Sem_Elim is procedure Initialize; ! -- Initialize for new main souce program procedure Process_Eliminate_Pragma (Pragma_Node : Node_Id; --- 30,36 ---- package Sem_Elim is procedure Initialize; ! -- Initialize for new main source program procedure Process_Eliminate_Pragma (Pragma_Node : Node_Id; *************** package Sem_Elim is *** 53,59 **** -- flag on the given entity. procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id); ! -- Called by the back end on encouterning a call to an eliminated -- subprogram. N is the node for the call, and E is the entity of -- the subprogram being eliminated. --- 53,59 ---- -- flag on the given entity. procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id); ! -- Called by the back end on encountering a call to an eliminated -- subprogram. N is the node for the call, and E is the entity of -- the subprogram being eliminated. diff -Nrcpad gcc-4.3.3/gcc/ada/sem_eval.adb gcc-4.4.0/gcc/ada/sem_eval.adb *** gcc-4.3.3/gcc/ada/sem_eval.adb Thu Dec 13 10:32:23 2007 --- gcc-4.4.0/gcc/ada/sem_eval.adb Fri Aug 22 13:27:35 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Sem_Eval is *** 57,63 **** ----------------------------------------- -- The compile time evaluation of expressions is distributed over several ! -- Eval_xxx procedures. These procedures are called immediatedly after -- a subexpression is resolved and is therefore accomplished in a bottom -- up fashion. The flags are synthesized using the following approach. --- 57,63 ---- ----------------------------------------- -- The compile time evaluation of expressions is distributed over several ! -- Eval_xxx procedures. These procedures are called immediately after -- a subexpression is resolved and is therefore accomplished in a bottom -- up fashion. The flags are synthesized using the following approach. *************** package body Sem_Eval is *** 378,405 **** -------------------------- function Compile_Time_Compare ! (L, R : Node_Id; ! Rec : Boolean := False) return Compare_Result is ! Ltyp : constant Entity_Id := Etype (L); ! Rtyp : constant Entity_Id := Etype (R); procedure Compare_Decompose (N : Node_Id; R : out Node_Id; V : out Uint); ! -- This procedure decomposes the node N into an expression node ! -- and a signed offset, so that the value of N is equal to the ! -- value of R plus the value V (which may be negative). If no ! -- such decomposition is possible, then on return R is a copy ! -- of N, and V is set to zero. function Compare_Fixup (N : Node_Id) return Node_Id; ! -- This function deals with replacing 'Last and 'First references ! -- with their corresponding type bounds, which we then can compare. ! -- The argument is the original node, the result is the identity, ! -- unless we have a 'Last/'First reference in which case the value ! -- returned is the appropriate type bound. function Is_Same_Value (L, R : Node_Id) return Boolean; -- Returns True iff L and R represent expressions that definitely --- 378,409 ---- -------------------------- function Compile_Time_Compare ! (L, R : Node_Id; ! Assume_Valid : Boolean; ! Rec : Boolean := False) return Compare_Result is ! Ltyp : Entity_Id := Etype (L); ! Rtyp : Entity_Id := Etype (R); ! -- These get reset to the base type for the case of entities where ! -- Is_Known_Valid is not set. This takes care of handling possible ! -- invalid representations using the value of the base type, in ! -- accordance with RM 13.9.1(10). procedure Compare_Decompose (N : Node_Id; R : out Node_Id; V : out Uint); ! -- This procedure decomposes the node N into an expression node and a ! -- signed offset, so that the value of N is equal to the value of R plus ! -- the value V (which may be negative). If no such decomposition is ! -- possible, then on return R is a copy of N, and V is set to zero. function Compare_Fixup (N : Node_Id) return Node_Id; ! -- This function deals with replacing 'Last and 'First references with ! -- their corresponding type bounds, which we then can compare. The ! -- argument is the original node, the result is the identity, unless we ! -- have a 'Last/'First reference in which case the value returned is the ! -- appropriate type bound. function Is_Same_Value (L, R : Node_Id) return Boolean; -- Returns True iff L and R represent expressions that definitely *************** package body Sem_Eval is *** 432,438 **** return; elsif Nkind (N) = N_Attribute_Reference then - if Attribute_Name (N) = Name_Succ then R := First (Expressions (N)); V := Uint_1; --- 436,441 ---- *************** package body Sem_Eval is *** 570,586 **** -- Start of processing for Is_Same_Value begin ! -- Values are the same if they are the same identifier and the ! -- identifier refers to a constant object (E_Constant). This ! -- does not however apply to Float types, since we may have two ! -- NaN values and they should never compare equal. ! if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier and then Entity (Lf) = Entity (Rf) and then not Is_Floating_Point_Type (Etype (L)) ! and then (Ekind (Entity (Lf)) = E_Constant or else ! Ekind (Entity (Lf)) = E_In_Parameter or else ! Ekind (Entity (Lf)) = E_Loop_Parameter) then return True; --- 573,589 ---- -- Start of processing for Is_Same_Value begin ! -- Values are the same if they refer to the same entity and the ! -- entity is a constant object (E_Constant). This does not however ! -- apply to Float types, since we may have two NaN values and they ! -- should never compare equal. ! if Nkind_In (Lf, N_Identifier, N_Expanded_Name) ! and then Nkind_In (Rf, N_Identifier, N_Expanded_Name) and then Entity (Lf) = Entity (Rf) + and then Present (Entity (Lf)) and then not Is_Floating_Point_Type (Etype (L)) ! and then Is_Constant_Object (Entity (Lf)) then return True; *************** package body Sem_Eval is *** 593,616 **** then return True; ! -- Or if they are both 'First or 'Last values applying to the ! -- same entity (first and last don't change even if value does) elsif Nkind (Lf) = N_Attribute_Reference - and then - Nkind (Rf) = N_Attribute_Reference and then Attribute_Name (Lf) = Attribute_Name (Rf) and then (Attribute_Name (Lf) = Name_First or else Attribute_Name (Lf) = Name_Last) ! and then Is_Entity_Name (Prefix (Lf)) ! and then Is_Entity_Name (Prefix (Rf)) and then Entity (Prefix (Lf)) = Entity (Prefix (Rf)) and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf)) then return True; ! -- All other cases, we can't tell else return False; --- 596,648 ---- then return True; ! -- False if Nkind of the two nodes is different for remaining cases ! ! elsif Nkind (Lf) /= Nkind (Rf) then ! return False; ! ! -- True if both 'First or 'Last values applying to the same entity ! -- (first and last don't change even if value does). Note that we ! -- need this even with the calls to Compare_Fixup, to handle the ! -- case of unconstrained array attributes where Compare_Fixup ! -- cannot find useful bounds. elsif Nkind (Lf) = N_Attribute_Reference and then Attribute_Name (Lf) = Attribute_Name (Rf) and then (Attribute_Name (Lf) = Name_First or else Attribute_Name (Lf) = Name_Last) ! and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name) ! and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name) and then Entity (Prefix (Lf)) = Entity (Prefix (Rf)) and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf)) then return True; ! -- True if the same selected component from the same record ! ! elsif Nkind (Lf) = N_Selected_Component ! and then Selector_Name (Lf) = Selector_Name (Rf) ! and then Is_Same_Value (Prefix (Lf), Prefix (Rf)) ! then ! return True; ! ! -- True if the same unary operator applied to the same operand ! ! elsif Nkind (Lf) in N_Unary_Op ! and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf)) ! then ! return True; ! ! -- True if the same binary operator applied to the same operands ! ! elsif Nkind (Lf) in N_Binary_Op ! and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf)) ! and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf)) ! then ! return True; ! ! -- All other cases, we can't tell, so return False else return False; *************** package body Sem_Eval is *** 712,717 **** --- 744,763 ---- return Unknown; end if; + -- Replace types by base types for the case of entities which are + -- not known to have valid representations. This takes care of + -- properly dealing with invalid representations. + + if not Assume_Valid then + if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then + Ltyp := Base_Type (Ltyp); + end if; + + if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then + Rtyp := Base_Type (Rtyp); + end if; + end if; + -- Here is where we check for comparisons against maximum bounds of -- types, where we know that no value can be outside the bounds of -- the subtype. Note that this routine is allowed to assume that all *************** package body Sem_Eval is *** 731,758 **** -- See if we can get a decisive check against one operand and -- a bound of the other operand (four possible tests here). ! case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), True) is when LT => return LT; when LE => return LE; when EQ => return LE; when others => null; end case; ! case Compile_Time_Compare (L, Type_High_Bound (Rtyp), True) is when GT => return GT; when GE => return GE; when EQ => return GE; when others => null; end case; ! case Compile_Time_Compare (Type_Low_Bound (Ltyp), R, True) is when GT => return GT; when GE => return GE; when EQ => return GE; when others => null; end case; ! case Compile_Time_Compare (Type_High_Bound (Ltyp), R, True) is when LT => return LT; when LE => return LE; when EQ => return LE; --- 777,808 ---- -- See if we can get a decisive check against one operand and -- a bound of the other operand (four possible tests here). ! case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), ! Assume_Valid, Rec => True) is when LT => return LT; when LE => return LE; when EQ => return LE; when others => null; end case; ! case Compile_Time_Compare (L, Type_High_Bound (Rtyp), ! Assume_Valid, Rec => True) is when GT => return GT; when GE => return GE; when EQ => return GE; when others => null; end case; ! case Compile_Time_Compare (Type_Low_Bound (Ltyp), R, ! Assume_Valid, Rec => True) is when GT => return GT; when GE => return GE; when EQ => return GE; when others => null; end case; ! case Compile_Time_Compare (Type_High_Bound (Ltyp), R, ! Assume_Valid, Rec => True) is when LT => return LT; when LE => return LE; when EQ => return LE; *************** package body Sem_Eval is *** 971,984 **** return False; end if; ! -- If this is not a static expression and we are in configurable run ! -- time mode, then we consider it not known at compile time. This ! -- avoids anomalies where whether something is permitted with a given ! -- configurable run-time library depends on how good the compiler is ! -- at optimizing and knowing that things are constant when they ! -- are non-static. ! if Configurable_Run_Time_Mode and then not Is_Static_Expression (Op) then return False; end if; --- 1021,1037 ---- return False; end if; ! -- If this is not a static expression or a null literal, and we are in ! -- configurable run-time mode, then we consider it not known at compile ! -- time. This avoids anomalies where whether something is allowed with a ! -- given configurable run-time library depends on how good the compiler ! -- is at optimizing and knowing that things are constant when they are ! -- nonstatic. ! if Configurable_Run_Time_Mode ! and then K /= N_Null ! and then not Is_Static_Expression (Op) ! then return False; end if; *************** package body Sem_Eval is *** 1432,1440 **** Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); ! if (C_Typ = Standard_Character ! or else C_Typ = Standard_Wide_Character ! or else C_Typ = Standard_Wide_Wide_Character) and then Fold then null; --- 1485,1491 ---- Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); ! if Is_Standard_Character_Type (C_Typ) and then Fold then null; *************** package body Sem_Eval is *** 2269,2282 **** Fold : Boolean; begin ! -- One special case to deal with first. If we can tell that ! -- the result will be false because the lengths of one or ! -- more index subtypes are compile time known and different, ! -- then we can replace the entire result by False. We only ! -- do this for one dimensional arrays, because the case of ! -- multi-dimensional arrays is rare and too much trouble! ! -- If one of the operands is an illegal aggregate, its type ! -- might still be an arbitrary composite type, so nothing to do. if Is_Array_Type (Typ) and then Typ /= Any_Composite --- 2320,2332 ---- Fold : Boolean; begin ! -- One special case to deal with first. If we can tell that the result ! -- will be false because the lengths of one or more index subtypes are ! -- compile time known and different, then we can replace the entire ! -- result by False. We only do this for one dimensional arrays, because ! -- the case of multi-dimensional arrays is rare and too much trouble! If ! -- one of the operands is an illegal aggregate, its type might still be ! -- an arbitrary composite type, so nothing to do. if Is_Array_Type (Typ) and then Typ /= Any_Composite *************** package body Sem_Eval is *** 2289,2295 **** return; end if; ! declare procedure Get_Static_Length (Op : Node_Id; Len : out Uint); -- If Op is an expression for a constrained array with a known -- at compile time length, then Len is set to this (non-negative --- 2339,2347 ---- return; end if; ! -- OK, we have the case where we may be able to do this fold ! ! Length_Mismatch : declare procedure Get_Static_Length (Op : Node_Id; Len : out Uint); -- If Op is an expression for a constrained array with a known -- at compile time length, then Len is set to this (non-negative *************** package body Sem_Eval is *** 2303,2335 **** T : Entity_Id; begin if Nkind (Op) = N_String_Literal then Len := UI_From_Int (String_Length (Strval (Op))); ! elsif not Is_Constrained (Etype (Op)) then Len := Uint_Minus_1; ! else ! T := Etype (First_Index (Etype (Op))); ! if Is_Discrete_Type (T) ! and then ! Compile_Time_Known_Value (Type_Low_Bound (T)) ! and then ! Compile_Time_Known_Value (Type_High_Bound (T)) then ! Len := UI_Max (Uint_0, ! Expr_Value (Type_High_Bound (T)) - ! Expr_Value (Type_Low_Bound (T)) + 1); else Len := Uint_Minus_1; end if; ! end if; end Get_Static_Length; Len_L : Uint; Len_R : Uint; begin Get_Static_Length (Left, Len_L); Get_Static_Length (Right, Len_R); --- 2355,2499 ---- T : Entity_Id; begin + -- First easy case string literal + if Nkind (Op) = N_String_Literal then Len := UI_From_Int (String_Length (Strval (Op))); + return; + end if; ! -- Second easy case, not constrained subtype, so no length ! ! if not Is_Constrained (Etype (Op)) then Len := Uint_Minus_1; + return; + end if; ! -- General case ! T := Etype (First_Index (Etype (Op))); ! ! -- The simple case, both bounds are known at compile time ! ! if Is_Discrete_Type (T) ! and then ! Compile_Time_Known_Value (Type_Low_Bound (T)) ! and then ! Compile_Time_Known_Value (Type_High_Bound (T)) ! then ! Len := UI_Max (Uint_0, ! Expr_Value (Type_High_Bound (T)) - ! Expr_Value (Type_Low_Bound (T)) + 1); ! return; ! end if; ! ! -- A more complex case, where the bounds are of the form ! -- X [+/- K1] .. X [+/- K2]), where X is an expression that is ! -- either A'First or A'Last (with A an entity name), or X is an ! -- entity name, and the two X's are the same and K1 and K2 are ! -- known at compile time, in this case, the length can also be ! -- computed at compile time, even though the bounds are not ! -- known. A common case of this is e.g. (X'First..X'First+5). ! ! Extract_Length : declare ! procedure Decompose_Expr ! (Expr : Node_Id; ! Ent : out Entity_Id; ! Kind : out Character; ! Cons : out Uint); ! -- Given an expression, see if is of the form above, ! -- X [+/- K]. If so Ent is set to the entity in X, ! -- Kind is 'F','L','E' for 'First/'Last/simple entity, ! -- and Cons is the value of K. If the expression is ! -- not of the required form, Ent is set to Empty. ! ! -------------------- ! -- Decompose_Expr -- ! -------------------- ! ! procedure Decompose_Expr ! (Expr : Node_Id; ! Ent : out Entity_Id; ! Kind : out Character; ! Cons : out Uint) ! is ! Exp : Node_Id; ! ! begin ! if Nkind (Expr) = N_Op_Add ! and then Compile_Time_Known_Value (Right_Opnd (Expr)) ! then ! Exp := Left_Opnd (Expr); ! Cons := Expr_Value (Right_Opnd (Expr)); ! ! elsif Nkind (Expr) = N_Op_Subtract ! and then Compile_Time_Known_Value (Right_Opnd (Expr)) ! then ! Exp := Left_Opnd (Expr); ! Cons := -Expr_Value (Right_Opnd (Expr)); ! ! else ! Exp := Expr; ! Cons := Uint_0; ! end if; ! ! -- At this stage Exp is set to the potential X ! ! if Nkind (Exp) = N_Attribute_Reference then ! if Attribute_Name (Exp) = Name_First then ! Kind := 'F'; ! elsif Attribute_Name (Exp) = Name_Last then ! Kind := 'L'; ! else ! Ent := Empty; ! return; ! end if; ! ! Exp := Prefix (Exp); ! ! else ! Kind := 'E'; ! end if; ! ! if Is_Entity_Name (Exp) ! and then Present (Entity (Exp)) ! then ! Ent := Entity (Exp); ! else ! Ent := Empty; ! end if; ! end Decompose_Expr; ! ! -- Local Variables ! ! Ent1, Ent2 : Entity_Id; ! Kind1, Kind2 : Character; ! Cons1, Cons2 : Uint; ! ! -- Start of processing for Extract_Length ! ! begin ! Decompose_Expr (Type_Low_Bound (T), Ent1, Kind1, Cons1); ! Decompose_Expr (Type_High_Bound (T), Ent2, Kind2, Cons2); ! ! if Present (Ent1) ! and then Kind1 = Kind2 ! and then Ent1 = Ent2 then ! Len := Cons2 - Cons1 + 1; else Len := Uint_Minus_1; end if; ! end Extract_Length; end Get_Static_Length; + -- Local Variables + Len_L : Uint; Len_R : Uint; + -- Start of processing for Length_Mismatch + begin Get_Static_Length (Left, Len_L); Get_Static_Length (Right, Len_R); *************** package body Sem_Eval is *** 2342,2353 **** Warn_On_Known_Condition (N); return; end if; ! end; -- Another special case: comparisons of access types, where one or both -- operands are known to be null, so the result can be determined. ! elsif Is_Access_Type (Typ) then if Known_Null (Left) then if Known_Null (Right) then Fold_Uint (N, Test (Nkind (N) = N_Op_Eq), False); --- 2506,2518 ---- Warn_On_Known_Condition (N); return; end if; ! end Length_Mismatch; ! end if; -- Another special case: comparisons of access types, where one or both -- operands are known to be null, so the result can be determined. ! if Is_Access_Type (Typ) then if Known_Null (Left) then if Known_Null (Right) then Fold_Uint (N, Test (Nkind (N) = N_Op_Eq), False); *************** package body Sem_Eval is *** 2568,2573 **** --- 2733,2767 ---- Check_Non_Static_Context (Low_Bound (Drange)); Check_Non_Static_Context (High_Bound (Drange)); end if; + + -- A slice of the form A (subtype), when the subtype is the index of + -- the type of A, is redundant, the slice can be replaced with A, and + -- this is worth a warning. + + if Is_Entity_Name (Prefix (N)) then + declare + E : constant Entity_Id := Entity (Prefix (N)); + T : constant Entity_Id := Etype (E); + begin + if Ekind (E) = E_Constant + and then Is_Array_Type (T) + and then Is_Entity_Name (Drange) + then + if Is_Entity_Name (Original_Node (First_Index (T))) + and then Entity (Original_Node (First_Index (T))) + = Entity (Drange) + then + if Warn_On_Redundant_Constructs then + Error_Msg_N ("redundant slice denotes whole array?", N); + end if; + + -- The following might be a useful optimization ???? + + -- Rewrite (N, New_Occurrence_Of (E, Sloc (N))); + end if; + end if; + end; + end if; end Eval_Slice; ------------------------- *************** package body Sem_Eval is *** 3117,3123 **** return Ureal_0; end if; ! -- If we fall through, we have a node that cannot be interepreted -- as a compile time constant. That is definitely an error. raise Program_Error; --- 3311,3317 ---- return Ureal_0; end if; ! -- If we fall through, we have a node that cannot be interpreted -- as a compile time constant. That is definitely an error. raise Program_Error; *************** package body Sem_Eval is *** 3197,3207 **** Typ := Full_View (Typ); end if; ! -- For a result of type integer, subsitute an N_Integer_Literal node -- for the result of the compile time evaluation of the expression. if Is_Integer_Type (Typ) then Rewrite (N, Make_Integer_Literal (Loc, Val)); Set_Original_Entity (N, Ent); -- Otherwise we have an enumeration type, and we substitute either --- 3391,3404 ---- Typ := Full_View (Typ); end if; ! -- For a result of type integer, substitute an N_Integer_Literal node -- for the result of the compile time evaluation of the expression. + -- For ASIS use, set a link to the original named number when not in + -- a generic context. if Is_Integer_Type (Typ) then Rewrite (N, Make_Integer_Literal (Loc, Val)); + Set_Original_Entity (N, Ent); -- Otherwise we have an enumeration type, and we substitute either *************** package body Sem_Eval is *** 3245,3250 **** --- 3442,3450 ---- end if; Rewrite (N, Make_Real_Literal (Loc, Realval => Val)); + + -- Set link to original named number, for ASIS use + Set_Original_Entity (N, Ent); -- Both the actual and expected type comes from the original expression *************** package body Sem_Eval is *** 3308,3316 **** -------------------- function In_Subrange_Of ! (T1 : Entity_Id; ! T2 : Entity_Id; ! Fixed_Int : Boolean := False) return Boolean is L1 : Node_Id; H1 : Node_Id; --- 3508,3517 ---- -------------------- function In_Subrange_Of ! (T1 : Entity_Id; ! T2 : Entity_Id; ! Assume_Valid : Boolean; ! Fixed_Int : Boolean := False) return Boolean is L1 : Node_Id; H1 : Node_Id; *************** package body Sem_Eval is *** 3337,3345 **** -- Check bounds to see if comparison possible at compile time ! if Compile_Time_Compare (L1, L2) in Compare_GE and then ! Compile_Time_Compare (H1, H2) in Compare_LE then return True; end if; --- 3538,3546 ---- -- Check bounds to see if comparison possible at compile time ! if Compile_Time_Compare (L1, L2, Assume_Valid) in Compare_GE and then ! Compile_Time_Compare (H1, H2, Assume_Valid) in Compare_LE then return True; end if; *************** package body Sem_Eval is *** 3387,3393 **** end if; -- If any exception occurs, it means that we have some bug in the compiler ! -- possibly triggered by a previous error, or by some unforseen peculiar -- occurrence. However, this is only an optimization attempt, so there is -- really no point in crashing the compiler. Instead we just decide, too -- bad, we can't figure out the answer in this case after all. --- 3588,3594 ---- end if; -- If any exception occurs, it means that we have some bug in the compiler ! -- possibly triggered by a previous error, or by some unforeseen peculiar -- occurrence. However, this is only an optimization attempt, so there is -- really no point in crashing the compiler. Instead we just decide, too -- bad, we can't figure out the answer in this case after all. *************** package body Sem_Eval is *** 3589,3598 **** --------------------- function Is_Out_Of_Range ! (N : Node_Id; ! Typ : Entity_Id; ! Fixed_Int : Boolean := False; ! Int_Real : Boolean := False) return Boolean is Val : Uint; Valr : Ureal; --- 3790,3799 ---- --------------------- function Is_Out_Of_Range ! (N : Node_Id; ! Typ : Entity_Id; ! Fixed_Int : Boolean := False; ! Int_Real : Boolean := False) return Boolean is Val : Uint; Valr : Ureal; *************** package body Sem_Eval is *** 3987,3993 **** -- To understand the requirement for this test, see RM 4.9.1(1). -- As is made clear in RM 3.5.4(11), type Integer, for example -- is a constrained subtype with constraint bounds matching the ! -- bounds of its corresponding uncontrained base type. In this -- situation, Integer and Integer'Base do not statically match, -- even though they have the same bounds. --- 4188,4194 ---- -- To understand the requirement for this test, see RM 4.9.1(1). -- As is made clear in RM 3.5.4(11), type Integer, for example -- is a constrained subtype with constraint bounds matching the ! -- bounds of its corresponding unconstrained base type. In this -- situation, Integer and Integer'Base do not statically match, -- even though they have the same bounds. diff -Nrcpad gcc-4.3.3/gcc/ada/sem_eval.ads gcc-4.4.0/gcc/ada/sem_eval.ads *** gcc-4.3.3/gcc/ada/sem_eval.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_eval.ads Fri Aug 22 13:27:35 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Sem_Eval is *** 43,49 **** -- Handling of Static Expressions -- ------------------------------------ ! -- This package contains a set of routine that process individual -- subexpression nodes with the objective of folding (precomputing) the -- value of static expressions that are known at compile time and properly -- computing the setting of two flags that appear in every subexpression --- 43,49 ---- -- Handling of Static Expressions -- ------------------------------------ ! -- This package contains a set of routines that process individual -- subexpression nodes with the objective of folding (precomputing) the -- value of static expressions that are known at compile time and properly -- computing the setting of two flags that appear in every subexpression *************** package Sem_Eval is *** 56,62 **** -- Raises_Constraint_Error ! -- This flag indicatest that it is known at compile time that the -- evaluation of an expression raises constraint error. If the -- expression is static, and this flag is off, then it is also known at -- compile time that the expression does not raise constraint error --- 56,62 ---- -- Raises_Constraint_Error ! -- This flag indicates that it is known at compile time that the -- evaluation of an expression raises constraint error. If the -- expression is static, and this flag is off, then it is also known at -- compile time that the expression does not raise constraint error *************** package Sem_Eval is *** 133,148 **** subtype Compare_GE is Compare_Result range EQ .. GE; subtype Compare_LE is Compare_Result range LT .. EQ; function Compile_Time_Compare ! (L, R : Node_Id; ! Rec : Boolean := False) return Compare_Result; -- Given two expression nodes, finds out whether it can be determined at -- compile time how the runtime values will compare. An Unknown result -- means that the result of a comparison cannot be determined at compile -- time, otherwise the returned result indicates the known result of the -- comparison, given as tightly as possible (i.e. EQ or LT is preferred ! -- returned value to LE). Rec is a parameter that is set True for a ! -- recursive call from within Compile_Time_Compare to avoid some infinite ! -- recursion cases. It should never be set by a client. procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id); -- This procedure is called after it has been determined that Expr is not --- 133,153 ---- subtype Compare_GE is Compare_Result range EQ .. GE; subtype Compare_LE is Compare_Result range LT .. EQ; function Compile_Time_Compare ! (L, R : Node_Id; ! Assume_Valid : Boolean; ! Rec : Boolean := False) return Compare_Result; -- Given two expression nodes, finds out whether it can be determined at -- compile time how the runtime values will compare. An Unknown result -- means that the result of a comparison cannot be determined at compile -- time, otherwise the returned result indicates the known result of the -- comparison, given as tightly as possible (i.e. EQ or LT is preferred ! -- returned value to LE). If Assume_Valid is true, the result reflects ! -- the result of assuming that entities involved in the comparison have ! -- valid representations. If Assume_Valid is false, then the base type of ! -- any involved entity is used so that no assumption of validity is made. ! -- Rec is a parameter that is set True for a recursive call from within ! -- Compile_Time_Compare to avoid some infinite recursion cases. It should ! -- never be set by a client. procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id); -- This procedure is called after it has been determined that Expr is not *************** package Sem_Eval is *** 159,165 **** -- An OK static expression is one that is static in the RM definition sense -- and which does not raise constraint error. For most legality checking -- purposes you should use Is_Static_Expression. For those legality checks ! -- where the expression N should not raise constaint error use this -- routine. This routine is *not* to be used in contexts where the test is -- for compile time evaluation purposes. Use Compile_Time_Known_Value -- instead (see section on "Compile-Time Known Values" above). --- 164,170 ---- -- An OK static expression is one that is static in the RM definition sense -- and which does not raise constraint error. For most legality checking -- purposes you should use Is_Static_Expression. For those legality checks ! -- where the expression N should not raise constraint error use this -- routine. This routine is *not* to be used in contexts where the test is -- for compile time evaluation purposes. Use Compile_Time_Known_Value -- instead (see section on "Compile-Time Known Values" above). *************** package Sem_Eval is *** 328,334 **** Int_Real : Boolean := False) return Boolean; -- Returns True if it can be guaranteed at compile time that expression is -- known to be in range of the subtype Typ. If the values of N or of either ! -- bouds of Type are unknown at compile time, False will always be -- returned. A result of False does not mean that the expression is out of -- range, merely that it cannot be determined at compile time that it is in -- range. If Typ is a floating point type or Int_Real is set, any integer --- 333,339 ---- Int_Real : Boolean := False) return Boolean; -- Returns True if it can be guaranteed at compile time that expression is -- known to be in range of the subtype Typ. If the values of N or of either ! -- bounds of Type are unknown at compile time, False will always be -- returned. A result of False does not mean that the expression is out of -- range, merely that it cannot be determined at compile time that it is in -- range. If Typ is a floating point type or Int_Real is set, any integer *************** package Sem_Eval is *** 339,346 **** -- is True then any fixed-point value is treated as though it was discrete -- value (i.e. the underlying integer value is used). In this case we use -- the corresponding integer value, both for the bounds of Typ, and for the ! -- value of the expression N. If Typ is a discret type and Fixed_Int as ! -- well as Int_Real are false, intere values are used throughout. function Is_Out_Of_Range (N : Node_Id; --- 344,351 ---- -- is True then any fixed-point value is treated as though it was discrete -- value (i.e. the underlying integer value is used). In this case we use -- the corresponding integer value, both for the bounds of Typ, and for the ! -- value of the expression N. If Typ is a discrete type and Fixed_Int as ! -- well as Int_Real are false, integer values are used throughout. function Is_Out_Of_Range (N : Node_Id; *************** package Sem_Eval is *** 357,370 **** -- and Fixed_Int are used as in routine Is_In_Range above. function In_Subrange_Of ! (T1 : Entity_Id; ! T2 : Entity_Id; ! Fixed_Int : Boolean := False) return Boolean; -- Returns True if it can be guaranteed at compile time that the range of -- values for scalar type T1 are always in the range of scalar type T2. A -- result of False does not mean that T1 is not in T2's subrange, only that -- it cannot be determined at compile time. Flag Fixed_Int is used as in ! -- routine Is_In_Range above. function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean; -- Returns True if it can guarantee that Lo .. Hi is a null range. If it --- 362,378 ---- -- and Fixed_Int are used as in routine Is_In_Range above. function In_Subrange_Of ! (T1 : Entity_Id; ! T2 : Entity_Id; ! Assume_Valid : Boolean; ! Fixed_Int : Boolean := False) return Boolean; -- Returns True if it can be guaranteed at compile time that the range of -- values for scalar type T1 are always in the range of scalar type T2. A -- result of False does not mean that T1 is not in T2's subrange, only that -- it cannot be determined at compile time. Flag Fixed_Int is used as in ! -- routine Is_In_Range above. If Assume_Valid is true, the result reflects ! -- the result of assuming that entities involved in the comparison have ! -- valid representations. function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean; -- Returns True if it can guarantee that Lo .. Hi is a null range. If it diff -Nrcpad gcc-4.3.3/gcc/ada/sem_intr.adb gcc-4.4.0/gcc/ada/sem_intr.adb *** gcc-4.3.3/gcc/ada/sem_intr.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_intr.adb Tue May 20 12:44:55 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Sem_Intr is *** 132,138 **** end if; -- Check for the case of freeing a non-null object which will raise ! -- Constaint_Error. Issue warning here, do the expansion in Exp_Intr. elsif Cnam = Name_Free and then Can_Never_Be_Null (Etype (Arg1)) --- 132,138 ---- end if; -- Check for the case of freeing a non-null object which will raise ! -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr. elsif Cnam = Name_Free and then Can_Never_Be_Null (Etype (Arg1)) *************** package body Sem_Intr is *** 158,164 **** T2 : Entity_Id; begin ! -- Aritnmetic operators if Nam = Name_Op_Add or else --- 158,164 ---- T2 : Entity_Id; begin ! -- Arithmetic operators if Nam = Name_Op_Add or else *************** package body Sem_Intr is *** 304,310 **** Errint ("unrecognized intrinsic subprogram", E, N); -- We always allow intrinsic specifications in language defined units ! -- and in expanded code. We assume that the GNAT implemetors know what -- they are doing, and do not write or generate junk use of intrinsic! elsif not Comes_From_Source (E) --- 304,310 ---- Errint ("unrecognized intrinsic subprogram", E, N); -- We always allow intrinsic specifications in language defined units ! -- and in expanded code. We assume that the GNAT implementors know what -- they are doing, and do not write or generate junk use of intrinsic! elsif not Comes_From_Source (E) *************** package body Sem_Intr is *** 418,426 **** Ptyp1, N); return; ! elsif Is_Modular_Integer_Type (Typ1) ! and then Non_Binary_Modulus (Typ1) ! then Errint ("shifts not allowed for non-binary modular types", Ptyp1, N); --- 418,424 ---- Ptyp1, N); return; ! elsif Non_Binary_Modulus (Typ1) then Errint ("shifts not allowed for non-binary modular types", Ptyp1, N); diff -Nrcpad gcc-4.3.3/gcc/ada/sem_mech.adb gcc-4.4.0/gcc/ada/sem_mech.adb *** gcc-4.3.3/gcc/ada/sem_mech.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_mech.adb Fri Aug 1 07:56:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2008, 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- -- *************** package body Sem_Mech is *** 69,75 **** ("mechanism for & has already been set", Mech_Name, Ent); end if; ! -- MECHANISM_NAME ::= value | reference | descriptor if Nkind (Mech_Name) = N_Identifier then if Chars (Mech_Name) = Name_Value then --- 69,75 ---- ("mechanism for & has already been set", Mech_Name, Ent); end if; ! -- MECHANISM_NAME ::= value | reference | descriptor | short_descriptor if Nkind (Mech_Name) = N_Identifier then if Chars (Mech_Name) = Name_Value then *************** package body Sem_Mech is *** 85,90 **** --- 85,95 ---- Set_Mechanism_With_Checks (Ent, By_Descriptor, Mech_Name); return; + elsif Chars (Mech_Name) = Name_Short_Descriptor then + Check_VMS (Mech_Name); + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor, Mech_Name); + return; + elsif Chars (Mech_Name) = Name_Copy then Error_Msg_N ("bad mechanism name, Value assumed", Mech_Name); *************** package body Sem_Mech is *** 95,101 **** return; end if; ! -- MECHANISM_NAME ::= descriptor (CLASS_NAME) -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca -- Note: this form is parsed as an indexed component --- 100,107 ---- return; end if; ! -- MECHANISM_NAME ::= descriptor (CLASS_NAME) | ! -- short_descriptor (CLASS_NAME) -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca -- Note: this form is parsed as an indexed component *************** package body Sem_Mech is *** 104,117 **** Class := First (Expressions (Mech_Name)); if Nkind (Prefix (Mech_Name)) /= N_Identifier ! or else Chars (Prefix (Mech_Name)) /= Name_Descriptor or else Present (Next (Class)) then Bad_Mechanism; return; end if; ! -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca -- Note: this form is parsed as a function call --- 110,125 ---- Class := First (Expressions (Mech_Name)); if Nkind (Prefix (Mech_Name)) /= N_Identifier ! or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else ! Chars (Prefix (Mech_Name)) = Name_Short_Descriptor) or else Present (Next (Class)) then Bad_Mechanism; return; end if; ! -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | ! -- short_descriptor (Class => CLASS_NAME) -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca -- Note: this form is parsed as a function call *************** package body Sem_Mech is *** 121,127 **** Param := First (Parameter_Associations (Mech_Name)); if Nkind (Name (Mech_Name)) /= N_Identifier ! or else Chars (Name (Mech_Name)) /= Name_Descriptor or else Present (Next (Param)) or else No (Selector_Name (Param)) or else Chars (Selector_Name (Param)) /= Name_Class --- 129,136 ---- Param := First (Parameter_Associations (Mech_Name)); if Nkind (Name (Mech_Name)) /= N_Identifier ! or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else ! Chars (Name (Mech_Name)) = Name_Short_Descriptor) or else Present (Next (Param)) or else No (Selector_Name (Param)) or else Chars (Selector_Name (Param)) /= Name_Class *************** package body Sem_Mech is *** 145,171 **** Bad_Class; return; ! elsif Chars (Class) = Name_UBS then Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS, Mech_Name); ! elsif Chars (Class) = Name_UBSB then Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name); ! elsif Chars (Class) = Name_UBA then Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA, Mech_Name); ! elsif Chars (Class) = Name_S then Set_Mechanism_With_Checks (Ent, By_Descriptor_S, Mech_Name); ! elsif Chars (Class) = Name_SB then Set_Mechanism_With_Checks (Ent, By_Descriptor_SB, Mech_Name); ! elsif Chars (Class) = Name_A then Set_Mechanism_With_Checks (Ent, By_Descriptor_A, Mech_Name); ! elsif Chars (Class) = Name_NCA then Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA, Mech_Name); else Bad_Class; return; --- 154,229 ---- Bad_Class; return; ! elsif Chars (Name (Mech_Name)) = Name_Descriptor ! and then Chars (Class) = Name_UBS ! then Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS, Mech_Name); ! elsif Chars (Name (Mech_Name)) = Name_Descriptor ! and then Chars (Class) = Name_UBSB ! then Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name); ! elsif Chars (Name (Mech_Name)) = Name_Descriptor ! and then Chars (Class) = Name_UBA ! then Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA, Mech_Name); ! elsif Chars (Name (Mech_Name)) = Name_Descriptor ! and then Chars (Class) = Name_S ! then Set_Mechanism_With_Checks (Ent, By_Descriptor_S, Mech_Name); ! elsif Chars (Name (Mech_Name)) = Name_Descriptor ! and then Chars (Class) = Name_SB ! then Set_Mechanism_With_Checks (Ent, By_Descriptor_SB, Mech_Name); ! elsif Chars (Name (Mech_Name)) = Name_Descriptor ! and then Chars (Class) = Name_A ! then Set_Mechanism_With_Checks (Ent, By_Descriptor_A, Mech_Name); ! elsif Chars (Name (Mech_Name)) = Name_Descriptor ! and then Chars (Class) = Name_NCA ! then Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA, Mech_Name); + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_UBS + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBS, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_UBSB + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBSB, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_UBA + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBA, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_S + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_S, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_SB + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_SB, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_A + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_A, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_NCA + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_NCA, Mech_Name); + else Bad_Class; return; *************** package body Sem_Mech is *** 183,189 **** is begin -- Right now we only do some checks for functions returning arguments ! -- by desctiptor. Probably mode checks need to be added here ??? if Mech in Descriptor_Codes and then not Is_Formal (Ent) then if Is_Record_Type (Etype (Ent)) then --- 241,247 ---- is begin -- Right now we only do some checks for functions returning arguments ! -- by descriptor. Probably mode checks need to be added here ??? if Mech in Descriptor_Codes and then not Is_Formal (Ent) then if Is_Record_Type (Etype (Ent)) then *************** package body Sem_Mech is *** 207,213 **** begin -- Skip this processing if inside a generic template. Not only is ! -- it uneccessary (since neither extra formals nor mechanisms are -- relevant for the template itself), but at least at the moment, -- procedures get frozen early inside a template so attempting to -- look at the formal types does not work too well if they are --- 265,271 ---- begin -- Skip this processing if inside a generic template. Not only is ! -- it unnecessary (since neither extra formals nor mechanisms are -- relevant for the template itself), but at least at the moment, -- procedures get frozen early inside a template so attempting to -- look at the formal types does not work too well if they are *************** package body Sem_Mech is *** 241,247 **** --------- -- Note: all RM defined conventions are treated the same ! -- from the point of view of parameter passing mechanims when Convention_Ada | Convention_Intrinsic | --- 299,305 ---- --------- -- Note: all RM defined conventions are treated the same ! -- from the point of view of parameter passing mechanism when Convention_Ada | Convention_Intrinsic | diff -Nrcpad gcc-4.3.3/gcc/ada/sem_mech.ads gcc-4.4.0/gcc/ada/sem_mech.ads *** gcc-4.3.3/gcc/ada/sem_mech.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_mech.ads Fri Aug 1 07:56:20 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2008, 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- -- *************** package Sem_Mech is *** 95,100 **** --- 95,108 ---- By_Descriptor_SB : constant Mechanism_Type := -8; By_Descriptor_A : constant Mechanism_Type := -9; By_Descriptor_NCA : constant Mechanism_Type := -10; + By_Short_Descriptor : constant Mechanism_Type := -11; + By_Short_Descriptor_UBS : constant Mechanism_Type := -12; + By_Short_Descriptor_UBSB : constant Mechanism_Type := -13; + By_Short_Descriptor_UBA : constant Mechanism_Type := -14; + By_Short_Descriptor_S : constant Mechanism_Type := -15; + By_Short_Descriptor_SB : constant Mechanism_Type := -16; + By_Short_Descriptor_A : constant Mechanism_Type := -17; + By_Short_Descriptor_NCA : constant Mechanism_Type := -18; -- These values are used only in OpenVMS ports of GNAT. Pass by descriptor -- is forced, as described in the OpenVMS ABI. The suffix indicates the -- descriptor type: *************** package Sem_Mech is *** 113,119 **** -- type based on the Ada type in accordance with the OpenVMS ABI. subtype Descriptor_Codes is Mechanism_Type ! range By_Descriptor_NCA .. By_Descriptor; -- Subtype including all descriptor mechanisms -- All the above special values are non-positive. Positive values for --- 121,127 ---- -- type based on the Ada type in accordance with the OpenVMS ABI. subtype Descriptor_Codes is Mechanism_Type ! range By_Short_Descriptor_NCA .. By_Descriptor; -- Subtype including all descriptor mechanisms -- All the above special values are non-positive. Positive values for *************** package Sem_Mech is *** 144,150 **** -- this call is to set mechanism values for formals and for the -- function return if they have not already been explicitly set by -- a use of an extended Import or Export pragma. The idea is to set ! -- mechanism values whereever the semantics is dictated by either -- requirements or implementation advice in the RM, and to leave -- the mechanism set to Default if there is no requirement, so that -- the back-end is free to choose the most efficient method. --- 152,158 ---- -- this call is to set mechanism values for formals and for the -- function return if they have not already been explicitly set by -- a use of an extended Import or Export pragma. The idea is to set ! -- mechanism values wherever the semantics is dictated by either -- requirements or implementation advice in the RM, and to leave -- the mechanism set to Default if there is no requirement, so that -- the back-end is free to choose the most efficient method. diff -Nrcpad gcc-4.3.3/gcc/ada/sem_prag.adb gcc-4.4.0/gcc/ada/sem_prag.adb *** gcc-4.3.3/gcc/ada/sem_prag.adb Wed Dec 19 16:22:02 2007 --- gcc-4.4.0/gcc/ada/sem_prag.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Exp_Dist; use Exp_Dist; *** 40,46 **** with Lib; use Lib; with Lib.Writ; use Lib.Writ; with Lib.Xref; use Lib.Xref; - with Namet; use Namet; with Namet.Sp; use Namet.Sp; with Nlists; use Nlists; with Nmake; use Nmake; --- 40,45 ---- *************** with Restrict; use Restrict; *** 50,57 **** --- 49,59 ---- with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; + with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; + with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; + with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Dist; use Sem_Dist; with Sem_Elim; use Sem_Elim; *************** with Targparm; use Targparm; *** 75,80 **** --- 77,83 ---- with Tbuild; use Tbuild; with Ttypes; with Uintp; use Uintp; + with Uname; use Uname; with Urealp; use Urealp; with Validsw; use Validsw; *************** package body Sem_Prag is *** 172,177 **** --- 175,188 ---- -- (the original one, following the renaming chain) is returned. -- Otherwise the entity is returned unchanged. Should be in Einfo??? + function Get_Pragma_Arg (Arg : Node_Id) return Node_Id; + -- All the routines that check pragma arguments take either a pragma + -- argument association (in which case the expression of the argument + -- association is checked), or the expression directly. The function + -- Get_Pragma_Arg is a utility used to deal with these two cases. If Arg + -- is a pragma argument association node, then its expression is returned, + -- otherwise Arg is returned unchanged. + procedure rv; -- This is a dummy function called by the processing for pragma Reviewable. -- It is there for assisting front end debugging. By placing a Reviewable *************** package body Sem_Prag is *** 229,240 **** --- 240,287 ---- end if; end Adjust_External_Name_Case; + ------------------------------ + -- Analyze_PPC_In_Decl_Part -- + ------------------------------ + + procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (N)); + Arg2 : constant Node_Id := Next (Arg1); + + begin + -- Install formals and push subprogram spec onto scope stack + -- so that we can see the formals from the pragma. + + Install_Formals (S); + Push_Scope (S); + + -- Preanalyze the boolean expression, we treat this as a + -- spec expression (i.e. similar to a default expression). + + Preanalyze_Spec_Expression + (Get_Pragma_Arg (Arg1), Standard_Boolean); + + -- If there is a message argument, analyze it the same way + + if Present (Arg2) then + Preanalyze_Spec_Expression + (Get_Pragma_Arg (Arg2), Standard_String); + end if; + + -- Remove the subprogram from the scope stack now that the + -- pre-analysis of the precondition/postcondition is done. + + End_Scope; + end Analyze_PPC_In_Decl_Part; + -------------------- -- Analyze_Pragma -- -------------------- procedure Analyze_Pragma (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); + Pname : constant Name_Id := Pragma_Name (N); Prag_Id : Pragma_Id; Pragma_Exit : exception; *************** package body Sem_Prag is *** 310,315 **** --- 357,363 ---- procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id); + procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3, N4 : Name_Id); -- Check the specified argument Arg to make sure that it is an -- identifier whose name matches either N1 or N2 (or N3 if present). -- If not then give error and raise Pragma_Exit. *************** package body Sem_Prag is *** 362,368 **** procedure Check_In_Main_Program; -- Common checks for pragmas that appear within a main program ! -- (Priority, Main_Storage, Time_Slice). procedure Check_Interrupt_Or_Attach_Handler; -- Common processing for first argument of pragma Interrupt_Handler --- 410,416 ---- procedure Check_In_Main_Program; -- Common checks for pragmas that appear within a main program ! -- (Priority, Main_Storage, Time_Slice, Relative_Deadline). procedure Check_Interrupt_Or_Attach_Handler; -- Common processing for first argument of pragma Interrupt_Handler *************** package body Sem_Prag is *** 395,400 **** --- 443,472 ---- -- In this version of the procedure, the identifier name is given as -- a string with lower case letters. + procedure Check_Precondition_Postcondition (In_Body : out Boolean); + -- Called to process a precondition or postcondition pragma. There are + -- three cases: + -- + -- The pragma appears after a subprogram spec + -- + -- If the corresponding check is not enabled, the pragma is analyzed + -- but otherwise ignored and control returns with In_Body set False. + -- + -- If the check is enabled, then the first step is to analyze the + -- pragma, but this is skipped if the subprogram spec appears within + -- a package specification (because this is the case where we delay + -- analysis till the end of the spec). Then (whether or not it was + -- analyzed), the pragma is chained to the subprogram in question + -- (using Spec_PPC_List and Next_Pragma) and control returns to the + -- caller with In_Body set False. + -- + -- The pragma appears at the start of subprogram body declarations + -- + -- In this case an immediate return to the caller is made with + -- In_Body set True, and the pragma is NOT analyzed. + -- + -- In all other cases, an error message for bad placement is given + procedure Check_Static_Constraint (Constr : Node_Id); -- Constr is a constraint from an N_Subtype_Indication node from a -- component constraint in an Unchecked_Union type. This routine checks *************** package body Sem_Prag is *** 450,455 **** --- 522,534 ---- -- reference the identifier. After placing the message, Pragma_Exit -- is raised. + procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id); + pragma No_Return (Error_Pragma_Ref); + -- Outputs error message for current pragma. The message may contain + -- a % that will be replaced with the pragma name. The parameter Ref + -- must be an entity whose name can be referenced by & and sloc by #. + -- After placing the message, Pragma_Exit is raised. + function Find_Lib_Unit_Name return Entity_Id; -- Used for a library unit pragma to find the entity to which the -- library unit pragma applies, returns the entity found. *************** package body Sem_Prag is *** 482,495 **** -- optional identifiers when it returns). An entry in Args is Empty -- on return if the corresponding argument is not present. - function Get_Pragma_Arg (Arg : Node_Id) return Node_Id; - -- All the routines that check pragma arguments take either a pragma - -- argument association (in which case the expression of the argument - -- association is checked), or the expression directly. The function - -- Get_Pragma_Arg is a utility used to deal with these two cases. If - -- Arg is a pragma argument association node, then its expression is - -- returned, otherwise Arg is returned unchanged. - procedure GNAT_Pragma; -- Called for all GNAT defined pragmas to check the relevant restriction -- (No_Implementation_Pragmas). --- 561,566 ---- *************** package body Sem_Prag is *** 501,508 **** -- Decls where Decls is the list of declarative items. function Is_Configuration_Pragma return Boolean; ! -- Deterermines if the placement of the current pragma is appropriate ! -- for a configuration pragma (precedes the current compilation unit). function Is_In_Context_Clause return Boolean; -- Returns True if pragma appears within the context clause of a unit, --- 572,579 ---- -- Decls where Decls is the list of declarative items. function Is_Configuration_Pragma return Boolean; ! -- Determines if the placement of the current pragma is appropriate ! -- for a configuration pragma. function Is_In_Context_Clause return Boolean; -- Returns True if pragma appears within the context clause of a unit, *************** package body Sem_Prag is *** 513,518 **** --- 584,590 ---- -- expression, returns True if so, False if non-static or not String. procedure Pragma_Misplaced; + pragma No_Return (Pragma_Misplaced); -- Issue fatal error message for misplaced pragma procedure Process_Atomic_Shared_Volatile; *************** package body Sem_Prag is *** 524,530 **** -- Common processing for Compile_Time_Error and Compile_Time_Warning procedure Process_Convention (C : out Convention_Id; E : out Entity_Id); ! -- Common procesing for Convention, Interface, Import and Export. -- Checks first two arguments of pragma, and sets the appropriate -- convention value in the specified entity or entities. On return -- C is the convention, E is the referenced entity. --- 596,602 ---- -- Common processing for Compile_Time_Error and Compile_Time_Warning procedure Process_Convention (C : out Convention_Id; E : out Entity_Id); ! -- Common processing for Convention, Interface, Import and Export. -- Checks first two arguments of pragma, and sets the appropriate -- convention value in the specified entity or entities. On return -- C is the convention, E is the referenced entity. *************** package body Sem_Prag is *** 543,549 **** (Arg_Internal : Node_Id; Arg_External : Node_Id; Arg_Size : Node_Id); ! -- Common processing for the pragmass Import/Export_Object. -- The three arguments correspond to the three named parameters -- of the pragmas. An argument is empty if the corresponding -- parameter is not present in the pragma. --- 615,621 ---- (Arg_Internal : Node_Id; Arg_External : Node_Id; Arg_Size : Node_Id); ! -- Common processing for the pragmas Import/Export_Object. -- The three arguments correspond to the three named parameters -- of the pragmas. An argument is empty if the corresponding -- parameter is not present in the pragma. *************** package body Sem_Prag is *** 566,572 **** Arg_First_Optional_Parameter : Node_Id := Empty); -- Common processing for all extended Import and Export pragmas -- applying to subprograms. The caller omits any arguments that do ! -- bnot apply to the pragma in question (for example, Arg_Result_Type -- can be non-Empty only in the Import_Function and Export_Function -- cases). The argument names correspond to the allowed pragma -- association identifiers. --- 638,644 ---- Arg_First_Optional_Parameter : Node_Id := Empty); -- Common processing for all extended Import and Export pragmas -- applying to subprograms. The caller omits any arguments that do ! -- not apply to the pragma in question (for example, Arg_Result_Type -- can be non-Empty only in the Import_Function and Export_Function -- cases). The argument names correspond to the allowed pragma -- association identifiers. *************** package body Sem_Prag is *** 601,607 **** procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean); -- Common processing for Restrictions and Restriction_Warnings pragmas. ! -- Warn is False for Restrictions, True for Restriction_Warnings. procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean); -- Common processing for Suppress and Unsuppress. The boolean parameter --- 673,681 ---- procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean); -- Common processing for Restrictions and Restriction_Warnings pragmas. ! -- Warn is True for Restriction_Warnings, or for Restrictions if the ! -- flag Treat_Restrictions_As_Warnings is set, and False if this flag ! -- is not set in the Restrictions case. procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean); -- Common processing for Suppress and Unsuppress. The boolean parameter *************** package body Sem_Prag is *** 715,721 **** -- Here we have a real error (non-static expression) else ! Error_Msg_Name_1 := Chars (N); Flag_Non_Static_Expr ("argument for pragma% must be a identifier or " & "static string expression!", Argx); --- 789,795 ---- -- Here we have a real error (non-static expression) else ! Error_Msg_Name_1 := Pname; Flag_Non_Static_Expr ("argument for pragma% must be a identifier or " & "static string expression!", Argx); *************** package body Sem_Prag is *** 854,859 **** --- 928,951 ---- end if; end Check_Arg_Is_One_Of; + procedure Check_Arg_Is_One_Of + (Arg : Node_Id; + N1, N2, N3, N4 : Name_Id) + is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + Check_Arg_Is_Identifier (Argx); + + if Chars (Argx) /= N1 + and then Chars (Argx) /= N2 + and then Chars (Argx) /= N3 + and then Chars (Argx) /= N4 + then + Error_Pragma_Arg ("invalid argument for pragma%", Argx); + end if; + end Check_Arg_Is_One_Of; + --------------------------------- -- Check_Arg_Is_Queuing_Policy -- --------------------------------- *************** package body Sem_Prag is *** 909,915 **** -- Finally, we have a real error else ! Error_Msg_Name_1 := Chars (N); Flag_Non_Static_Expr ("argument for pragma% must be a static expression!", Argx); raise Pragma_Exit; --- 1001,1007 ---- -- Finally, we have a real error else ! Error_Msg_Name_1 := Pname; Flag_Non_Static_Expr ("argument for pragma% must be a static expression!", Argx); raise Pragma_Exit; *************** package body Sem_Prag is *** 962,968 **** for K in Names'Range loop if Chars (Arg) = Names (K) then if K < Highest_So_Far then ! Error_Msg_Name_1 := Chars (N); Error_Msg_N ("parameters out of order for pragma%", Arg); Error_Msg_Name_1 := Names (K); --- 1054,1060 ---- for K in Names'Range loop if Chars (Arg) = Names (K) then if K < Highest_So_Far then ! Error_Msg_Name_1 := Pname; Error_Msg_N ("parameters out of order for pragma%", Arg); Error_Msg_Name_1 := Names (K); *************** package body Sem_Prag is *** 1112,1118 **** elsif Present (Parameter_Specifications (Specification (P))) or else not Is_Compilation_Unit (Defining_Entity (P)) then ! Error_Msg_Name_1 := Chars (N); Error_Msg_N ("?pragma% is only effective in main program", N); end if; --- 1204,1210 ---- elsif Present (Parameter_Specifications (Specification (P))) or else not Is_Compilation_Unit (Defining_Entity (P)) then ! Error_Msg_Name_1 := Pname; Error_Msg_N ("?pragma% is only effective in main program", N); end if; *************** package body Sem_Prag is *** 1189,1198 **** -- sequence, so the only way we get here is by being in the -- declarative part of the body. ! elsif Nkind (P) = N_Subprogram_Body ! or else Nkind (P) = N_Package_Body ! or else Nkind (P) = N_Task_Body ! or else Nkind (P) = N_Entry_Body then return; end if; --- 1281,1290 ---- -- sequence, so the only way we get here is by being in the -- declarative part of the body. ! elsif Nkind_In (P, N_Subprogram_Body, ! N_Package_Body, ! N_Task_Body, ! N_Entry_Body) then return; end if; *************** package body Sem_Prag is *** 1239,1245 **** begin if Present (Arg) and then Chars (Arg) /= No_Name then if Chars (Arg) /= Id then ! Error_Msg_Name_1 := Chars (N); Error_Msg_Name_2 := Id; Error_Msg_N ("pragma% argument expects identifier%", Arg); raise Pragma_Exit; --- 1331,1337 ---- begin if Present (Arg) and then Chars (Arg) /= No_Name then if Chars (Arg) /= Id then ! Error_Msg_Name_1 := Pname; Error_Msg_Name_2 := Id; Error_Msg_N ("pragma% argument expects identifier%", Arg); raise Pragma_Exit; *************** package body Sem_Prag is *** 1254,1259 **** --- 1346,1488 ---- Check_Optional_Identifier (Arg, Name_Find); end Check_Optional_Identifier; + -------------------------------------- + -- Check_Precondition_Postcondition -- + -------------------------------------- + + procedure Check_Precondition_Postcondition (In_Body : out Boolean) is + P : Node_Id; + PO : Node_Id; + + procedure Chain_PPC (PO : Node_Id); + -- If PO is a subprogram declaration node (or a generic subprogram + -- declaration node), then the precondition/postcondition applies + -- to this subprogram and the processing for the pragma is completed. + -- Otherwise the pragma is misplaced. + + --------------- + -- Chain_PPC -- + --------------- + + procedure Chain_PPC (PO : Node_Id) is + S : Node_Id; + + begin + if not Nkind_In (PO, N_Subprogram_Declaration, + N_Generic_Subprogram_Declaration) + then + Pragma_Misplaced; + end if; + + -- Here if we have subprogram or generic subprogram declaration + + S := Defining_Unit_Name (Specification (PO)); + + -- Analyze the pragma unless it appears within a package spec, + -- which is the case where we delay the analysis of the PPC until + -- the end of the package declarations (for details, see + -- Analyze_Package_Specification.Analyze_PPCs). + + if not Is_Package_Or_Generic_Package (Scope (S)) then + Analyze_PPC_In_Decl_Part (N, S); + end if; + + -- Chain spec PPC pragma to list for subprogram + + Set_Next_Pragma (N, Spec_PPC_List (S)); + Set_Spec_PPC_List (S, N); + + -- Return indicating spec case + + In_Body := False; + return; + end Chain_PPC; + + -- Start of processing for Check_Precondition_Postcondition + + begin + if not Is_List_Member (N) then + Pragma_Misplaced; + end if; + + -- Record whether pragma is enabled + + Set_PPC_Enabled (N, Check_Enabled (Pname)); + + -- If we are within an inlined body, the legality of the pragma + -- has been checked already. + + if In_Inlined_Body then + In_Body := True; + return; + end if; + + -- Search prior declarations + + P := N; + while Present (Prev (P)) loop + P := Prev (P); + + -- If the previous node is a generic subprogram, do not go to + -- to the original node, which is the unanalyzed tree: we need + -- to attach the pre/postconditions to the analyzed version + -- at this point. They get propagated to the original tree when + -- analyzing the corresponding body. + + if Nkind (P) not in N_Generic_Declaration then + PO := Original_Node (P); + else + PO := P; + end if; + + -- Skip past prior pragma + + if Nkind (PO) = N_Pragma then + null; + + -- Skip stuff not coming from source + + elsif not Comes_From_Source (PO) then + null; + + -- Only remaining possibility is subprogram declaration + + else + Chain_PPC (PO); + return; + end if; + end loop; + + -- If we fall through loop, pragma is at start of list, so see if + -- it is at the start of declarations of a subprogram body. + + if Nkind (Parent (N)) = N_Subprogram_Body + and then List_Containing (N) = Declarations (Parent (N)) + then + if Operating_Mode /= Generate_Code then + + -- Analyze expression in pragma, for correctness + -- and for ASIS use. + + Preanalyze_Spec_Expression + (Get_Pragma_Arg (Arg1), Standard_Boolean); + end if; + + In_Body := True; + return; + + -- See if it is in the pragmas after a library level subprogram + + elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then + Chain_PPC (Unit (Parent (Parent (N)))); + return; + end if; + + -- If we fall through, pragma was misplaced + + Pragma_Misplaced; + end Check_Precondition_Postcondition; + ----------------------------- -- Check_Static_Constraint -- ----------------------------- *************** package body Sem_Prag is *** 1265,1277 **** procedure Check_Static_Constraint (Constr : Node_Id) is -------------------- -- Require_Static -- -------------------- - procedure Require_Static (E : Node_Id); - -- Require given expression to be static expression - procedure Require_Static (E : Node_Id) is begin if not Is_OK_Static_Expression (E) then --- 1494,1506 ---- procedure Check_Static_Constraint (Constr : Node_Id) is + procedure Require_Static (E : Node_Id); + -- Require given expression to be static expression + -------------------- -- Require_Static -- -------------------- procedure Require_Static (E : Node_Id) is begin if not Is_OK_Static_Expression (E) then *************** package body Sem_Prag is *** 1319,1327 **** -- Check_Valid_Configuration_Pragma -- -------------------------------------- ! -- A configuration pragma must appear in the context clause of ! -- a compilation unit, at the start of the list (i.e. only other ! -- pragmas may precede it). procedure Check_Valid_Configuration_Pragma is begin --- 1548,1556 ---- -- Check_Valid_Configuration_Pragma -- -------------------------------------- ! -- A configuration pragma must appear in the context clause of a ! -- compilation unit, and only other pragmas may precede it. Note that ! -- the test also allows use in a configuration pragma file. procedure Check_Valid_Configuration_Pragma is begin *************** package body Sem_Prag is *** 1500,1506 **** procedure Error_Pragma (Msg : String) is begin ! Error_Msg_Name_1 := Chars (N); Error_Msg_N (Msg, N); raise Pragma_Exit; end Error_Pragma; --- 1729,1735 ---- procedure Error_Pragma (Msg : String) is begin ! Error_Msg_Name_1 := Pname; Error_Msg_N (Msg, N); raise Pragma_Exit; end Error_Pragma; *************** package body Sem_Prag is *** 1511,1524 **** procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is begin ! Error_Msg_Name_1 := Chars (N); Error_Msg_N (Msg, Get_Pragma_Arg (Arg)); raise Pragma_Exit; end Error_Pragma_Arg; procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is begin ! Error_Msg_Name_1 := Chars (N); Error_Msg_N (Msg1, Get_Pragma_Arg (Arg)); Error_Pragma_Arg (Msg2, Arg); end Error_Pragma_Arg; --- 1740,1753 ---- procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is begin ! Error_Msg_Name_1 := Pname; Error_Msg_N (Msg, Get_Pragma_Arg (Arg)); raise Pragma_Exit; end Error_Pragma_Arg; procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is begin ! Error_Msg_Name_1 := Pname; Error_Msg_N (Msg1, Get_Pragma_Arg (Arg)); Error_Pragma_Arg (Msg2, Arg); end Error_Pragma_Arg; *************** package body Sem_Prag is *** 1529,1539 **** procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is begin ! Error_Msg_Name_1 := Chars (N); Error_Msg_N (Msg, Arg); raise Pragma_Exit; end Error_Pragma_Arg_Ident; ------------------------ -- Find_Lib_Unit_Name -- ------------------------ --- 1758,1780 ---- procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is begin ! Error_Msg_Name_1 := Pname; Error_Msg_N (Msg, Arg); raise Pragma_Exit; end Error_Pragma_Arg_Ident; + ---------------------- + -- Error_Pragma_Ref -- + ---------------------- + + procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is + begin + Error_Msg_Name_1 := Pname; + Error_Msg_Sloc := Sloc (Ref); + Error_Msg_NE (Msg, N, Ref); + raise Pragma_Exit; + end Error_Pragma_Ref; + ------------------------ -- Find_Lib_Unit_Name -- ------------------------ *************** package body Sem_Prag is *** 1717,1723 **** end if; if Index = Names'Last then ! Error_Msg_Name_1 := Chars (N); Error_Msg_N ("pragma% does not allow & argument", Arg); -- Check for possible misspelling --- 1958,1964 ---- end if; if Index = Names'Last then ! Error_Msg_Name_1 := Pname; Error_Msg_N ("pragma% does not allow & argument", Arg); -- Check for possible misspelling *************** package body Sem_Prag is *** 1741,1759 **** end loop; end Gather_Associations; - -------------------- - -- Get_Pragma_Arg -- - -------------------- - - function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is - begin - if Nkind (Arg) = N_Pragma_Argument_Association then - return Expression (Arg); - else - return Arg; - end if; - end Get_Pragma_Arg; - ----------------- -- GNAT_Pragma -- ----------------- --- 1982,1987 ---- *************** package body Sem_Prag is *** 1792,1800 **** -- Is_Configuration_Pragma -- ----------------------------- ! -- A configuration pragma must appear in the context clause of ! -- a compilation unit, at the start of the list (i.e. only other ! -- pragmas may precede it). function Is_Configuration_Pragma return Boolean is Lis : constant List_Id := List_Containing (N); --- 2020,2028 ---- -- Is_Configuration_Pragma -- ----------------------------- ! -- A configuration pragma must appear in the context clause of a ! -- compilation unit, and only other pragmas may precede it. Note that ! -- the test below also permits use in a configuration pragma file. function Is_Configuration_Pragma return Boolean is Lis : constant List_Id := List_Containing (N); *************** package body Sem_Prag is *** 1893,1902 **** Utyp : Entity_Id; procedure Set_Atomic (E : Entity_Id); ! -- Set given type as atomic, and if no explicit alignment was ! -- given, set alignment to unknown, since back end knows what ! -- the alignment requirements are for atomic arrays. Note that ! -- this step is necessary for derived types. ---------------- -- Set_Atomic -- --- 2121,2130 ---- Utyp : Entity_Id; procedure Set_Atomic (E : Entity_Id); ! -- Set given type as atomic, and if no explicit alignment was given, ! -- set alignment to unknown, since back end knows what the alignment ! -- requirements are for atomic arrays. Note: this step is necessary ! -- for derived types. ---------------- -- Set_Atomic -- *************** package body Sem_Prag is *** 1944,1952 **** Set_Atomic (Base_Type (E)); end if; ! -- Attribute belongs on the base type. If the ! -- view of the type is currently private, it also ! -- belongs on the underlying type. Set_Is_Volatile (Base_Type (E)); Set_Is_Volatile (Underlying_Type (E)); --- 2172,2179 ---- Set_Atomic (Base_Type (E)); end if; ! -- Attribute belongs on the base type. If the view of the type is ! -- currently private, it also belongs on the underlying type. Set_Is_Volatile (Base_Type (E)); Set_Is_Volatile (Underlying_Type (E)); *************** package body Sem_Prag is *** 1965,1974 **** if Prag_Id /= Pragma_Volatile then Set_Is_Atomic (E); ! -- If the object declaration has an explicit ! -- initialization, a temporary may have to be ! -- created to hold the expression, to insure ! -- that access to the object remain atomic. if Nkind (Parent (E)) = N_Object_Declaration and then Present (Expression (Parent (E))) --- 2192,2200 ---- if Prag_Id /= Pragma_Volatile then Set_Is_Atomic (E); ! -- If the object declaration has an explicit initialization, a ! -- temporary may have to be created to hold the expression, to ! -- ensure that access to the object remain atomic. if Nkind (Parent (E)) = N_Object_Declaration and then Present (Expression (Parent (E))) *************** package body Sem_Prag is *** 1978,1984 **** -- An interesting improvement here. If an object of type X -- is declared atomic, and the type X is not atomic, that's ! -- a pity, since it may not have appropraite alignment etc. -- We can rescue this in the special case where the object -- and type are in the same unit by just setting the type -- as atomic, so that the back end will process it as atomic. --- 2204,2210 ---- -- An interesting improvement here. If an object of type X -- is declared atomic, and the type X is not atomic, that's ! -- a pity, since it may not have appropriate alignment etc. -- We can rescue this in the special case where the object -- and type are in the same unit by just setting the type -- as atomic, so that the back end will process it as atomic. *************** package body Sem_Prag is *** 2013,2019 **** Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); begin - GNAT_Pragma; Check_Arg_Count (2); Check_No_Identifiers; Check_Arg_Is_Static_Expression (Arg2, Standard_String); --- 2239,2244 ---- *************** package body Sem_Prag is *** 2029,2043 **** Ptr : Nat; CC : Char_Code; C : Character; ! begin ! Cont := False; ! Ptr := 1; -- Loop through segments of message separated by line -- feeds. We output these segments as separate messages -- with continuation marks for all but the first. loop Error_Msg_Strlen := 0; --- 2254,2280 ---- Ptr : Nat; CC : Char_Code; C : Character; + Cent : constant Entity_Id := + Cunit_Entity (Current_Sem_Unit); ! Force : constant Boolean := ! Prag_Id = Pragma_Compile_Time_Warning ! and then ! Is_Spec_Name (Unit_Name (Current_Sem_Unit)) ! and then (Ekind (Cent) /= E_Package ! or else not In_Private_Part (Cent)); ! -- Set True if this is the warning case, and we are in the ! -- visible part of a package spec, or in a subprogram spec, ! -- in which case we want to force the client to see the ! -- warning, even though it is not in the main unit. + begin -- Loop through segments of message separated by line -- feeds. We output these segments as separate messages -- with continuation marks for all but the first. + Cont := False; + Ptr := 1; loop Error_Msg_Strlen := 0; *************** package body Sem_Prag is *** 2063,2073 **** Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning; ! if Cont = False then ! Error_Msg_N ("<~", Arg1); ! Cont := True; else ! Error_Msg_N ("\<~", Arg1); end if; exit when Ptr > Len; --- 2300,2332 ---- Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning; ! -- If this is a warning in a spec, then we want clients ! -- to see the warning, so mark the message with the ! -- special sequence !! to force the warning. In the case ! -- of a package spec, we do not force this if we are in ! -- the private part of the spec. ! ! if Force then ! if Cont = False then ! Error_Msg_N ("<~!!", Arg1); ! Cont := True; ! else ! Error_Msg_N ("\<~!!", Arg1); ! end if; ! ! -- Error, rather than warning, or in a body, so we do not ! -- need to force visibility for client (error will be ! -- output in any case, and this is the situation in which ! -- we do not want a client to get a warning, since the ! -- warning is in the body or the spec private part. ! else ! if Cont = False then ! Error_Msg_N ("<~", Arg1); ! Cont := True; ! else ! Error_Msg_N ("\<~", Arg1); ! end if; end if; exit when Ptr > Len; *************** package body Sem_Prag is *** 2229,2237 **** if Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Renaming_Declaration then E := Alias (E); ! elsif Nkind (Parent (E)) = N_Full_Type_Declaration and then Scope (E) = Scope (Alias (E)) then E := Alias (E); --- 2488,2501 ---- if Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Renaming_Declaration then + if Scope (E) /= Scope (Alias (E)) then + Error_Pragma_Ref + ("cannot apply pragma% to non-local renaming&#", E); + end if; E := Alias (E); ! elsif Nkind_In (Parent (E), N_Full_Type_Declaration, ! N_Private_Extension_Declaration) and then Scope (E) = Scope (Alias (E)) then E := Alias (E); *************** package body Sem_Prag is *** 2253,2259 **** or else Ekind (E) = E_Named_Real then ! Error_Msg_Name_1 := Chars (N); Error_Msg_N ("cannot apply pragma% to named constant!", Get_Pragma_Arg (Arg2)); --- 2517,2523 ---- or else Ekind (E) = E_Named_Real then ! Error_Msg_Name_1 := Pname; Error_Msg_N ("cannot apply pragma% to named constant!", Get_Pragma_Arg (Arg2)); *************** package body Sem_Prag is *** 2353,2363 **** E1 := Homonym (E1); exit when No (E1) or else Scope (E1) /= Current_Scope; if Comes_From_Source (E1) and then Comp_Unit = Get_Source_Unit (E1) and then Nkind (Original_Node (Parent (E1))) /= ! N_Full_Type_Declaration then Set_Convention_From_Pragma (E1); if Prag_Id = Pragma_Import then --- 2617,2637 ---- E1 := Homonym (E1); exit when No (E1) or else Scope (E1) /= Current_Scope; + -- Do not set the pragma on inherited operations or on + -- formal subprograms. + if Comes_From_Source (E1) and then Comp_Unit = Get_Source_Unit (E1) + and then not Is_Formal_Subprogram (E1) and then Nkind (Original_Node (Parent (E1))) /= ! N_Full_Type_Declaration then + if Present (Alias (E1)) + and then Scope (E1) /= Scope (Alias (E1)) + then + Error_Pragma_Ref + ("cannot apply pragma% to non-local renaming&#", E1); + end if; Set_Convention_From_Pragma (E1); if Prag_Id = Pragma_Import then *************** package body Sem_Prag is *** 2382,2389 **** Code_Val : Uint; begin - GNAT_Pragma; - if not OpenVMS_On_Target then Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)"); --- 2656,2661 ---- *************** package body Sem_Prag is *** 2441,2448 **** (Arg_Internal : Node_Id := Empty) is begin - GNAT_Pragma; - if No (Arg_Internal) then Error_Pragma ("Internal parameter required for pragma%"); end if; --- 2713,2718 ---- *************** package body Sem_Prag is *** 2581,2587 **** "\no initialization allowed for & declared#", Arg1); else Set_Imported (Def_Id); ! Note_Possible_Modification (Arg_Internal); end if; end if; end Process_Extended_Import_Export_Object_Pragma; --- 2851,2857 ---- "\no initialization allowed for & declared#", Arg1); else Set_Imported (Def_Id); ! Note_Possible_Modification (Arg_Internal, Sure => False); end if; end if; end Process_Extended_Import_Export_Object_Pragma; *************** package body Sem_Prag is *** 2642,2648 **** end if; -- We have a match if the corresponding argument is of an ! -- anonymous access type, and its designicated type matches -- the type of the prefix of the access attribute return Ekind (Ftyp) = E_Anonymous_Access_Type --- 2912,2918 ---- end if; -- We have a match if the corresponding argument is of an ! -- anonymous access type, and its designated type matches -- the type of the prefix of the access attribute return Ekind (Ftyp) = E_Anonymous_Access_Type *************** package body Sem_Prag is *** 2694,2702 **** -- Pragma cannot apply to subprogram body if Is_Subprogram (Def_Id) ! and then ! Nkind (Parent ! (Declaration_Node (Def_Id))) = N_Subprogram_Body then Error_Pragma ("pragma% requires separate spec" --- 2964,2971 ---- -- Pragma cannot apply to subprogram body if Is_Subprogram (Def_Id) ! and then Nkind (Parent (Declaration_Node (Def_Id))) = ! N_Subprogram_Body then Error_Pragma ("pragma% requires separate spec" *************** package body Sem_Prag is *** 2713,2720 **** elsif Etype (Def_Id) /= Standard_Void_Type and then ! (Chars (N) = Name_Export_Procedure ! or else Chars (N) = Name_Import_Procedure) then Match := False; --- 2982,2990 ---- elsif Etype (Def_Id) /= Standard_Void_Type and then ! (Pname = Name_Export_Procedure ! or else ! Pname = Name_Import_Procedure) then Match := False; *************** package body Sem_Prag is *** 2792,2798 **** else if not Ambiguous then Ambiguous := True; ! Error_Msg_Name_1 := Chars (N); Error_Msg_N ("pragma% does not uniquely identify subprogram!", N); --- 3062,3068 ---- else if not Ambiguous then Ambiguous := True; ! Error_Msg_Name_1 := Pname; Error_Msg_N ("pragma% does not uniquely identify subprogram!", N); *************** package body Sem_Prag is *** 2826,2832 **** return; end if; ! -- Import pragmas must be be for imported entities if Prag_Id = Pragma_Import_Function or else --- 3096,3102 ---- return; end if; ! -- Import pragmas must be for imported entities if Prag_Id = Pragma_Import_Function or else *************** package body Sem_Prag is *** 2850,2856 **** then null; ! -- In all other cases, set entit as exported else Set_Exported (Ent, Arg_Internal); --- 3120,3126 ---- then null; ! -- In all other cases, set entity as exported else Set_Exported (Ent, Arg_Internal); *************** package body Sem_Prag is *** 2973,2978 **** --- 3243,3253 ---- if Chars (Choice) = Chars (Formal) then Set_Mechanism_Value (Formal, Expression (Massoc)); + + -- Set entity on identifier for ASIS + + Set_Entity (Choice, Formal); + exit; end if; *************** package body Sem_Prag is *** 3053,3059 **** Exp : Node_Id; begin - GNAT_Pragma; Check_No_Identifiers; Check_At_Least_N_Arguments (1); --- 3328,3333 ---- *************** package body Sem_Prag is *** 3089,3095 **** begin Process_Convention (C, Def_Id); Kill_Size_Check_Code (Def_Id); ! Note_Possible_Modification (Expression (Arg2)); if Ekind (Def_Id) = E_Variable or else --- 3363,3369 ---- begin Process_Convention (C, Def_Id); Kill_Size_Check_Code (Def_Id); ! Note_Possible_Modification (Expression (Arg2), Sure => False); if Ekind (Def_Id) = E_Variable or else *************** package body Sem_Prag is *** 3121,3127 **** Process_Interface_Name (Def_Id, Arg3, Arg4); -- Note that we do not set Is_Public here. That's because we ! -- only want to set if if there is no address clause, and we -- don't know that yet, so we delay that processing till -- freeze time. --- 3395,3401 ---- Process_Interface_Name (Def_Id, Arg3, Arg4); -- Note that we do not set Is_Public here. That's because we ! -- only want to set it if there is no address clause, and we -- don't know that yet, so we delay that processing till -- freeze time. *************** package body Sem_Prag is *** 3228,3237 **** if Present (Decl) and then Nkind (Decl) = N_Subprogram_Declaration and then Present (Corresponding_Body (Decl)) ! and then ! Nkind ! (Unit_Declaration_Node ! (Corresponding_Body (Decl))) = N_Subprogram_Renaming_Declaration then Error_Msg_Sloc := Sloc (Def_Id); --- 3502,3509 ---- if Present (Decl) and then Nkind (Decl) = N_Subprogram_Declaration and then Present (Corresponding_Body (Decl)) ! and then Nkind (Unit_Declaration_Node ! (Corresponding_Body (Decl))) = N_Subprogram_Renaming_Declaration then Error_Msg_Sloc := Sloc (Def_Id); *************** package body Sem_Prag is *** 3264,3271 **** elsif (C = Convention_Java or else C = Convention_CIL) and then ! (Ekind (Def_Id) = E_Package ! or else Ekind (Def_Id) = E_Generic_Package or else Ekind (Def_Id) = E_Exception or else Nkind (Parent (Def_Id)) = N_Component_Declaration) then --- 3536,3542 ---- elsif (C = Convention_Java or else C = Convention_CIL) and then ! (Is_Package_Or_Generic_Package (Def_Id) or else Ekind (Def_Id) = E_Exception or else Nkind (Parent (Def_Id)) = N_Component_Declaration) then *************** package body Sem_Prag is *** 3345,3351 **** function Inlining_Not_Possible (Subp : Entity_Id) return Boolean; -- Returns True if it can be determined at this stage that inlining ! -- is not possible, for examle if the body is available and contains -- exception handlers, we prevent inlining, since otherwise we can -- get undefined symbols at link time. This function also emits a -- warning if front-end inlining is enabled and the pragma appears --- 3616,3622 ---- function Inlining_Not_Possible (Subp : Entity_Id) return Boolean; -- Returns True if it can be determined at this stage that inlining ! -- is not possible, for example if the body is available and contains -- exception handlers, we prevent inlining, since otherwise we can -- get undefined symbols at link time. This function also emits a -- warning if front-end inlining is enabled and the pragma appears *************** package body Sem_Prag is *** 3433,3461 **** return; -- Here we have a candidate for inlining, but we must exclude ! -- derived operations. Otherwise we will end up trying to ! -- inline a phantom declaration, and the result would be to ! -- drag in a body which has no direct inlining associated with ! -- it. That would not only be inefficient but would also result ! -- in the backend doing cross-unit inlining in cases where it ! -- was definitely inappropriate to do so. ! -- However, a simple Comes_From_Source test is insufficient, ! -- since we do want to allow inlining of generic instances, ! -- which also do not come from source. Predefined operators do ! -- not come from source but are not inlineable either. elsif not Comes_From_Source (Subp) - and then not Is_Generic_Instance (Subp) and then Scope (Subp) /= Standard_Standard then Applies := True; return; -- The referenced entity must either be the enclosing entity, -- or an entity declared within the current open scope. ! elsif Present (Scope (Subp)) and then Scope (Subp) /= Current_Scope and then Subp /= Current_Scope then --- 3704,3739 ---- return; -- Here we have a candidate for inlining, but we must exclude ! -- derived operations. Otherwise we would end up trying to inline ! -- a phantom declaration, and the result would be to drag in a ! -- body which has no direct inlining associated with it. That ! -- would not only be inefficient but would also result in the ! -- backend doing cross-unit inlining in cases where it was ! -- definitely inappropriate to do so. ! -- However, a simple Comes_From_Source test is insufficient, since ! -- we do want to allow inlining of generic instances which also do ! -- not come from source. We also need to recognize specs ! -- generated by the front-end for bodies that carry the pragma. ! -- Finally, predefined operators do not come from source but are ! -- not inlineable either. ! ! elsif Is_Generic_Instance (Subp) ! or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration ! then ! null; elsif not Comes_From_Source (Subp) and then Scope (Subp) /= Standard_Standard then Applies := True; return; + end if; -- The referenced entity must either be the enclosing entity, -- or an entity declared within the current open scope. ! if Present (Scope (Subp)) and then Scope (Subp) /= Current_Scope and then Subp /= Current_Scope then *************** package body Sem_Prag is *** 3483,3488 **** --- 3761,3782 ---- and then Present (Corresponding_Body (Decl)) then Set_Inline_Flags (Corresponding_Body (Decl)); + + elsif Is_Generic_Instance (Subp) then + + -- Indicate that the body needs to be created for + -- inlining subsequent calls. The instantiation + -- node follows the declaration of the wrapper + -- package created for it. + + if Scope (Subp) /= Standard_Standard + and then + Need_Subprogram_Instance_Body + (Next (Unit_Declaration_Node (Scope (Alias (Subp)))), + Subp) + then + null; + end if; end if; end if; *************** package body Sem_Prag is *** 3601,3617 **** Link_Nam : Node_Id; String_Val : String_Id; ! procedure Check_Form_Of_Interface_Name (SN : Node_Id); -- SN is a string literal node for an interface name. This routine -- performs some minimal checks that the name is reasonable. In -- particular that no spaces or other obviously incorrect characters -- appear. This is only a warning, since any characters are allowed. ---------------------------------- -- Check_Form_Of_Interface_Name -- ---------------------------------- ! procedure Check_Form_Of_Interface_Name (SN : Node_Id) is S : constant String_Id := Strval (Expr_Value_S (SN)); SL : constant Nat := String_Length (S); C : Char_Code; --- 3895,3917 ---- Link_Nam : Node_Id; String_Val : String_Id; ! procedure Check_Form_Of_Interface_Name ! (SN : Node_Id; ! Ext_Name_Case : Boolean); -- SN is a string literal node for an interface name. This routine -- performs some minimal checks that the name is reasonable. In -- particular that no spaces or other obviously incorrect characters -- appear. This is only a warning, since any characters are allowed. + -- Ext_Name_Case is True for an External_Name, False for a Link_Name. ---------------------------------- -- Check_Form_Of_Interface_Name -- ---------------------------------- ! procedure Check_Form_Of_Interface_Name ! (SN : Node_Id; ! Ext_Name_Case : Boolean) ! is S : constant String_Id := Strval (Expr_Value_S (SN)); SL : constant Nat := String_Length (S); C : Char_Code; *************** package body Sem_Prag is *** 3624,3638 **** for J in 1 .. SL loop C := Get_String_Char (S, J); ! if Warn_On_Export_Import ! and then ! (not In_Character_Range (C) ! or else (Get_Character (C) = ' ' ! and then VM_Target /= CLI_Target) ! or else Get_Character (C) = ',') then ! Error_Msg_N ! ("?interface name contains illegal character", SN); end if; end loop; end Check_Form_Of_Interface_Name; --- 3924,3951 ---- for J in 1 .. SL loop C := Get_String_Char (S, J); ! -- Look for dubious character and issue unconditional warning. ! -- Definitely dubious if not in character range. ! ! if not In_Character_Range (C) ! ! -- For all cases except external names on CLI target, ! -- commas, spaces and slashes are dubious (in CLI, we use ! -- spaces and commas in external names to specify assembly ! -- version and public key). ! ! or else ((not Ext_Name_Case or else VM_Target /= CLI_Target) ! and then (Get_Character (C) = ' ' ! or else ! Get_Character (C) = ',' ! or else ! Get_Character (C) = '/' ! or else ! Get_Character (C) = '\')) then ! Error_Msg ! ("?interface name contains illegal character", ! Sloc (SN) + Source_Ptr (J)); end if; end loop; end Check_Form_Of_Interface_Name; *************** package body Sem_Prag is *** 3677,3689 **** if Present (Ext_Nam) then Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String); ! Check_Form_Of_Interface_Name (Ext_Nam); ! -- Verify that the external name is not the name of a local ! -- entity, which would hide the imported one and lead to ! -- run-time surprises. The problem can only arise for entities ! -- declared in a package body (otherwise the external name is ! -- fully qualified and won't conflict). declare Nam : Name_Id; --- 3990,4002 ---- if Present (Ext_Nam) then Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String); ! Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True); ! -- Verify that external name is not the name of a local entity, ! -- which would hide the imported one and could lead to run-time ! -- surprises. The problem can only arise for entities declared in ! -- a package body (otherwise the external name is fully qualified ! -- and will not conflict). declare Nam : Name_Id; *************** package body Sem_Prag is *** 3706,3715 **** Par := Parent (E); while Present (Par) loop if Nkind (Par) = N_Package_Body then ! Error_Msg_Sloc := Sloc (E); Error_Msg_NE ("imported entity is hidden by & declared#", ! Ext_Arg, E); exit; end if; --- 4019,4028 ---- Par := Parent (E); while Present (Par) loop if Nkind (Par) = N_Package_Body then ! Error_Msg_Sloc := Sloc (E); Error_Msg_NE ("imported entity is hidden by & declared#", ! Ext_Arg, E); exit; end if; *************** package body Sem_Prag is *** 3722,3728 **** if Present (Link_Nam) then Check_Arg_Is_Static_Expression (Link_Nam, Standard_String); ! Check_Form_Of_Interface_Name (Link_Nam); end if; -- If there is no link name, just set the external name --- 4035,4041 ---- if Present (Link_Nam) then Check_Arg_Is_Static_Expression (Link_Nam, Standard_String); ! Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False); end if; -- If there is no link name, just set the external name *************** package body Sem_Prag is *** 3847,3859 **** (Process_Restriction_Synonyms (Expr)); if R_Id not in All_Boolean_Restrictions then ! Error_Pragma_Arg ! ("invalid restriction identifier", Arg); end if; if Implementation_Restriction (R_Id) then ! Check_Restriction ! (No_Implementation_Restrictions, Arg); end if; -- If this is a warning, then set the warning unless we already --- 4160,4199 ---- (Process_Restriction_Synonyms (Expr)); if R_Id not in All_Boolean_Restrictions then ! Error_Msg_Name_1 := Pname; ! Error_Msg_N ! ("invalid restriction identifier&", Get_Pragma_Arg (Arg)); ! ! -- Check for possible misspelling ! ! for J in Restriction_Id loop ! declare ! Rnm : constant String := Restriction_Id'Image (J); ! ! begin ! Name_Buffer (1 .. Rnm'Length) := Rnm; ! Name_Len := Rnm'Length; ! Set_Casing (All_Lower_Case); ! ! if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then ! Set_Casing ! (Identifier_Casing (Current_Source_File)); ! Error_Msg_String (1 .. Rnm'Length) := ! Name_Buffer (1 .. Name_Len); ! Error_Msg_Strlen := Rnm'Length; ! Error_Msg_N ! ("\possible misspelling of ""~""", ! Get_Pragma_Arg (Arg)); ! exit; ! end if; ! end; ! end loop; ! ! raise Pragma_Exit; end if; if Implementation_Restriction (R_Id) then ! Check_Restriction (No_Implementation_Restrictions, Arg); end if; -- If this is a warning, then set the warning unless we already *************** package body Sem_Prag is *** 3963,3971 **** E : Entity_Id; In_Package_Spec : constant Boolean := ! (Ekind (Current_Scope) = E_Package ! or else ! Ekind (Current_Scope) = E_Generic_Package) and then not In_Package_Body (Current_Scope); procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); --- 4303,4309 ---- E : Entity_Id; In_Package_Spec : constant Boolean := ! Is_Package_Or_Generic_Package (Current_Scope) and then not In_Package_Body (Current_Scope); procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); *************** package body Sem_Prag is *** 4289,4295 **** Error_Msg_NE ("entity& was previously imported", N, E); end if; ! Error_Msg_Name_1 := Chars (N); Error_Msg_N ("\(pragma% applies to all previous entities)", N); --- 4627,4633 ---- Error_Msg_NE ("entity& was previously imported", N, E); end if; ! Error_Msg_Name_1 := Pname; Error_Msg_N ("\(pragma% applies to all previous entities)", N); *************** package body Sem_Prag is *** 4326,4331 **** --- 4664,4670 ---- procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is Class : Node_Id; Param : Node_Id; + Mech_Name_Id : Name_Id; procedure Bad_Class; -- Signal bad descriptor class name *************** package body Sem_Prag is *** 4359,4365 **** ("mechanism for & has already been set", Mech_Name, Ent); end if; ! -- MECHANISM_NAME ::= value | reference | descriptor if Nkind (Mech_Name) = N_Identifier then if Chars (Mech_Name) = Name_Value then --- 4698,4705 ---- ("mechanism for & has already been set", Mech_Name, Ent); end if; ! -- MECHANISM_NAME ::= value | reference | descriptor | ! -- short_descriptor if Nkind (Mech_Name) = N_Identifier then if Chars (Mech_Name) = Name_Value then *************** package body Sem_Prag is *** 4375,4380 **** --- 4715,4725 ---- Set_Mechanism (Ent, By_Descriptor); return; + elsif Chars (Mech_Name) = Name_Short_Descriptor then + Check_VMS (Mech_Name); + Set_Mechanism (Ent, By_Short_Descriptor); + return; + elsif Chars (Mech_Name) = Name_Copy then Error_Pragma_Arg ("bad mechanism name, Value assumed", Mech_Name); *************** package body Sem_Prag is *** 4383,4404 **** Bad_Mechanism; end if; ! -- MECHANISM_NAME ::= descriptor (CLASS_NAME) -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca -- Note: this form is parsed as an indexed component elsif Nkind (Mech_Name) = N_Indexed_Component then Class := First (Expressions (Mech_Name)); if Nkind (Prefix (Mech_Name)) /= N_Identifier ! or else Chars (Prefix (Mech_Name)) /= Name_Descriptor ! or else Present (Next (Class)) then Bad_Mechanism; end if; ! -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca -- Note: this form is parsed as a function call --- 4728,4755 ---- Bad_Mechanism; end if; ! -- MECHANISM_NAME ::= descriptor (CLASS_NAME) | ! -- short_descriptor (CLASS_NAME) -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca -- Note: this form is parsed as an indexed component elsif Nkind (Mech_Name) = N_Indexed_Component then + Class := First (Expressions (Mech_Name)); if Nkind (Prefix (Mech_Name)) /= N_Identifier ! or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else ! Chars (Prefix (Mech_Name)) = Name_Short_Descriptor) ! or else Present (Next (Class)) then Bad_Mechanism; + else + Mech_Name_Id := Chars (Prefix (Mech_Name)); end if; ! -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | ! -- short_descriptor (Class => CLASS_NAME) -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca -- Note: this form is parsed as a function call *************** package body Sem_Prag is *** 4408,4414 **** Param := First (Parameter_Associations (Mech_Name)); if Nkind (Name (Mech_Name)) /= N_Identifier ! or else Chars (Name (Mech_Name)) /= Name_Descriptor or else Present (Next (Param)) or else No (Selector_Name (Param)) or else Chars (Selector_Name (Param)) /= Name_Class --- 4759,4766 ---- Param := First (Parameter_Associations (Mech_Name)); if Nkind (Name (Mech_Name)) /= N_Identifier ! or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else ! Chars (Name (Mech_Name)) = Name_Short_Descriptor) or else Present (Next (Param)) or else No (Selector_Name (Param)) or else Chars (Selector_Name (Param)) /= Name_Class *************** package body Sem_Prag is *** 4416,4421 **** --- 4768,4774 ---- Bad_Mechanism; else Class := Explicit_Actual_Parameter (Param); + Mech_Name_Id := Chars (Name (Mech_Name)); end if; else *************** package body Sem_Prag is *** 4429,4455 **** if Nkind (Class) /= N_Identifier then Bad_Class; ! elsif Chars (Class) = Name_UBS then Set_Mechanism (Ent, By_Descriptor_UBS); ! elsif Chars (Class) = Name_UBSB then Set_Mechanism (Ent, By_Descriptor_UBSB); ! elsif Chars (Class) = Name_UBA then Set_Mechanism (Ent, By_Descriptor_UBA); ! elsif Chars (Class) = Name_S then Set_Mechanism (Ent, By_Descriptor_S); ! elsif Chars (Class) = Name_SB then Set_Mechanism (Ent, By_Descriptor_SB); ! elsif Chars (Class) = Name_A then Set_Mechanism (Ent, By_Descriptor_A); ! elsif Chars (Class) = Name_NCA then Set_Mechanism (Ent, By_Descriptor_NCA); else Bad_Class; end if; --- 4782,4857 ---- if Nkind (Class) /= N_Identifier then Bad_Class; ! elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_UBS ! then Set_Mechanism (Ent, By_Descriptor_UBS); ! elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_UBSB ! then Set_Mechanism (Ent, By_Descriptor_UBSB); ! elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_UBA ! then Set_Mechanism (Ent, By_Descriptor_UBA); ! elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_S ! then Set_Mechanism (Ent, By_Descriptor_S); ! elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_SB ! then Set_Mechanism (Ent, By_Descriptor_SB); ! elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_A ! then Set_Mechanism (Ent, By_Descriptor_A); ! elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_NCA ! then Set_Mechanism (Ent, By_Descriptor_NCA); + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_UBS + then + Set_Mechanism (Ent, By_Short_Descriptor_UBS); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_UBSB + then + Set_Mechanism (Ent, By_Short_Descriptor_UBSB); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_UBA + then + Set_Mechanism (Ent, By_Short_Descriptor_UBA); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_S + then + Set_Mechanism (Ent, By_Short_Descriptor_S); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_SB + then + Set_Mechanism (Ent, By_Short_Descriptor_SB); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_A + then + Set_Mechanism (Ent, By_Short_Descriptor_A); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_NCA + then + Set_Mechanism (Ent, By_Short_Descriptor_NCA); + else Bad_Class; end if; *************** package body Sem_Prag is *** 4517,4523 **** -- Set the corresponding restrictions ! Set_Profile_Restrictions (Ravenscar, N, Warn => False); end Set_Ravenscar_Profile; -- Start of processing for Analyze_Pragma --- 4919,4926 ---- -- Set the corresponding restrictions ! Set_Profile_Restrictions ! (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings); end Set_Ravenscar_Profile; -- Start of processing for Analyze_Pragma *************** package body Sem_Prag is *** 4525,4537 **** begin -- Deal with unrecognized pragma ! if not Is_Pragma_Name (Chars (N)) then if Warn_On_Unrecognized_Pragma then ! Error_Msg_Name_1 := Chars (N); Error_Msg_N ("?unrecognized pragma%!", Pragma_Identifier (N)); for PN in First_Pragma_Name .. Last_Pragma_Name loop ! if Is_Bad_Spelling_Of (Chars (N), PN) then Error_Msg_Name_1 := PN; Error_Msg_N ("\?possible misspelling of %!", Pragma_Identifier (N)); --- 4928,4940 ---- begin -- Deal with unrecognized pragma ! if not Is_Pragma_Name (Pname) then if Warn_On_Unrecognized_Pragma then ! Error_Msg_Name_1 := Pname; Error_Msg_N ("?unrecognized pragma%!", Pragma_Identifier (N)); for PN in First_Pragma_Name .. Last_Pragma_Name loop ! if Is_Bad_Spelling_Of (Pname, PN) then Error_Msg_Name_1 := PN; Error_Msg_N ("\?possible misspelling of %!", Pragma_Identifier (N)); *************** package body Sem_Prag is *** 4545,4551 **** -- Here to start processing for recognized pragma ! Prag_Id := Get_Pragma_Id (Chars (N)); -- Preset arguments --- 4948,4954 ---- -- Here to start processing for recognized pragma ! Prag_Id := Get_Pragma_Id (Pname); -- Preset arguments *************** package body Sem_Prag is *** 4584,4590 **** end; -- An enumeration type defines the pragmas that are supported by the ! -- implementation. Get_Pragma_Id (in package Prag) transorms a name -- into the corresponding enumeration value for the following case. case Prag_Id is --- 4987,4993 ---- end; -- An enumeration type defines the pragmas that are supported by the ! -- implementation. Get_Pragma_Id (in package Prag) transforms a name -- into the corresponding enumeration value for the following case. case Prag_Id is *************** package body Sem_Prag is *** 4803,4809 **** when Pragma_Assert => Assert : declare Expr : Node_Id; ! Eloc : Source_Ptr; begin Ada_2005_Pragma; --- 5206,5212 ---- when Pragma_Assert => Assert : declare Expr : Node_Id; ! Newa : List_Id; begin Ada_2005_Pragma; *************** package body Sem_Prag is *** 4812,4882 **** Check_Arg_Order ((Name_Check, Name_Message)); Check_Optional_Identifier (Arg1, Name_Check); ! if Arg_Count > 1 then ! Check_Optional_Identifier (Arg2, Name_Message); ! Check_Arg_Is_Static_Expression (Arg2, Standard_String); ! end if; ! ! -- If expansion is active and assertions are inactive, then ! -- we rewrite the Assertion as: ! ! -- if False and then condition then ! -- null; ! -- end if; ! ! -- The reason we do this rewriting during semantic analysis rather ! -- than as part of normal expansion is that we cannot analyze and ! -- expand the code for the boolean expression directly, or it may ! -- cause insertion of actions that would escape the attempt to ! -- suppress the assertion code. ! ! -- Note that the Sloc for the if statement corresponds to the ! -- argument condition, not the pragma itself. The reason for this ! -- is that we may generate a warning if the condition is False at ! -- compile time, and we do not want to delete this warning when we ! -- delete the if statement. ! Expr := Expression (Arg1); ! Eloc := Sloc (Expr); ! if Expander_Active and not Assertions_Enabled then ! Rewrite (N, ! Make_If_Statement (Eloc, ! Condition => ! Make_And_Then (Eloc, ! Left_Opnd => New_Occurrence_Of (Standard_False, Eloc), ! Right_Opnd => Expr), ! Then_Statements => New_List ( ! Make_Null_Statement (Eloc)))); ! Analyze (N); ! -- Otherwise (if assertions are enabled, or if we are not ! -- operating with expansion active), then we just analyze ! -- and resolve the expression. ! else ! Analyze_And_Resolve (Expr, Any_Boolean); end if; ! -- If assertion is of the form (X'First = literal), where X is ! -- formal parameter, then set Low_Bound_Known flag on this formal. ! ! if Nkind (Expr) = N_Op_Eq then ! declare ! Right : constant Node_Id := Right_Opnd (Expr); ! Left : constant Node_Id := Left_Opnd (Expr); ! begin ! if Nkind (Left) = N_Attribute_Reference ! and then Attribute_Name (Left) = Name_First ! and then Is_Entity_Name (Prefix (Left)) ! and then Is_Formal (Entity (Prefix (Left))) ! and then Nkind (Right) = N_Integer_Literal ! then ! Set_Low_Bound_Known (Entity (Prefix (Left))); ! end if; ! end; ! end if; end Assert; ---------------------- --- 5215,5247 ---- Check_Arg_Order ((Name_Check, Name_Message)); Check_Optional_Identifier (Arg1, Name_Check); ! -- We treat pragma Assert as equivalent to: ! -- pragma Check (Assertion, condition [, msg]); ! -- So rewrite pragma in this manner, and analyze the result ! Expr := Get_Pragma_Arg (Arg1); ! Newa := New_List ( ! Make_Pragma_Argument_Association (Loc, ! Expression => ! Make_Identifier (Loc, ! Chars => Name_Assertion)), ! Make_Pragma_Argument_Association (Sloc (Expr), ! Expression => Expr)); ! if Arg_Count > 1 then ! Check_Optional_Identifier (Arg2, Name_Message); ! Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String); ! Append_To (Newa, Relocate_Node (Arg2)); end if; ! Rewrite (N, ! Make_Pragma (Loc, ! Chars => Name_Check, ! Pragma_Argument_Associations => Newa)); ! Analyze (N); end Assert; ---------------------- *************** package body Sem_Prag is *** 4885,4895 **** -- pragma Assertion_Policy (Check | Ignore) ! when Pragma_Assertion_Policy => Ada_2005_Pragma; Check_Arg_Count (1); Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore); ! Assertions_Enabled := Chars (Expression (Arg1)) = Name_Check; --------------- -- AST_Entry -- --- 5250,5312 ---- -- pragma Assertion_Policy (Check | Ignore) ! when Pragma_Assertion_Policy => Assertion_Policy : declare ! Policy : Node_Id; ! ! begin Ada_2005_Pragma; + Check_Valid_Configuration_Pragma; Check_Arg_Count (1); + Check_No_Identifiers; Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore); ! ! -- We treat pragma Assertion_Policy as equivalent to: ! ! -- pragma Check_Policy (Assertion, policy) ! ! -- So rewrite the pragma in that manner and link on to the chain ! -- of Check_Policy pragmas, marking the pragma as analyzed. ! ! Policy := Get_Pragma_Arg (Arg1); ! ! Rewrite (N, ! Make_Pragma (Loc, ! Chars => Name_Check_Policy, ! ! Pragma_Argument_Associations => New_List ( ! Make_Pragma_Argument_Association (Loc, ! Expression => ! Make_Identifier (Loc, ! Chars => Name_Assertion)), ! ! Make_Pragma_Argument_Association (Loc, ! Expression => ! Make_Identifier (Sloc (Policy), ! Chars => Chars (Policy)))))); ! ! Set_Analyzed (N); ! Set_Next_Pragma (N, Opt.Check_Policy_List); ! Opt.Check_Policy_List := N; ! end Assertion_Policy; ! ! ------------------------------ ! -- Assume_No_Invalid_Values -- ! ------------------------------ ! ! -- pragma Assume_No_Invalid_Values (On | Off); ! ! when Pragma_Assume_No_Invalid_Values => ! GNAT_Pragma; ! Check_Valid_Configuration_Pragma; ! Check_Arg_Count (1); ! Check_No_Identifiers; ! Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); ! ! if Chars (Expression (Arg1)) = Name_On then ! Assume_No_Invalid_Values := True; ! else ! Assume_No_Invalid_Values := False; ! end if; --------------- -- AST_Entry -- *************** package body Sem_Prag is *** 5200,5206 **** New_Copy_Tree (Expression (Arg2)); begin Set_Parent (Temp, N); ! Pre_Analyze_And_Resolve (Temp, RTE (RE_Interrupt_ID)); end; else --- 5617,5623 ---- New_Copy_Tree (Expression (Arg2)); begin Set_Parent (Temp, N); ! Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID)); end; else *************** package body Sem_Prag is *** 5248,5253 **** --- 5665,5761 ---- end if; end C_Pass_By_Copy; + ----------- + -- Check -- + ----------- + + -- pragma Check ([Name =>] Identifier, + -- [Check =>] Boolean_Expression + -- [,[Message =>] String_Expression]); + + when Pragma_Check => Check : declare + Expr : Node_Id; + Eloc : Source_Ptr; + + Check_On : Boolean; + -- Set True if category of assertions referenced by Name enabled + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (2); + Check_At_Most_N_Arguments (3); + Check_Optional_Identifier (Arg1, Name_Name); + Check_Optional_Identifier (Arg2, Name_Check); + + if Arg_Count = 3 then + Check_Optional_Identifier (Arg3, Name_Message); + Analyze_And_Resolve (Get_Pragma_Arg (Arg3), Standard_String); + end if; + + Check_Arg_Is_Identifier (Arg1); + Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1))); + + -- If expansion is active and the check is not enabled then we + -- rewrite the Check as: + + -- if False and then condition then + -- null; + -- end if; + + -- The reason we do this rewriting during semantic analysis rather + -- than as part of normal expansion is that we cannot analyze and + -- expand the code for the boolean expression directly, or it may + -- cause insertion of actions that would escape the attempt to + -- suppress the check code. + + -- Note that the Sloc for the if statement corresponds to the + -- argument condition, not the pragma itself. The reason for this + -- is that we may generate a warning if the condition is False at + -- compile time, and we do not want to delete this warning when we + -- delete the if statement. + + Expr := Expression (Arg2); + + if Expander_Active and then not Check_On then + Eloc := Sloc (Expr); + + Rewrite (N, + Make_If_Statement (Eloc, + Condition => + Make_And_Then (Eloc, + Left_Opnd => New_Occurrence_Of (Standard_False, Eloc), + Right_Opnd => Expr), + Then_Statements => New_List ( + Make_Null_Statement (Eloc)))); + + Analyze (N); + + -- Check is active + + else + Analyze_And_Resolve (Expr, Any_Boolean); + end if; + + -- If assertion is of the form (X'First = literal), where X is + -- a formal, then set Low_Bound_Known flag on this formal. + + if Nkind (Expr) = N_Op_Eq then + declare + Right : constant Node_Id := Right_Opnd (Expr); + Left : constant Node_Id := Left_Opnd (Expr); + begin + if Nkind (Left) = N_Attribute_Reference + and then Attribute_Name (Left) = Name_First + and then Is_Entity_Name (Prefix (Left)) + and then Is_Formal (Entity (Prefix (Left))) + and then Nkind (Right) = N_Integer_Literal + then + Set_Low_Bound_Known (Entity (Prefix (Left))); + end if; + end; + end if; + end Check; + ---------------- -- Check_Name -- ---------------- *************** package body Sem_Prag is *** 5274,5279 **** --- 5782,5819 ---- Check_Names.Append (Nam); end; + ------------------ + -- Check_Policy -- + ------------------ + + -- pragma Check_Policy ([Name =>] IDENTIFIER, + -- POLICY_IDENTIFIER; + + -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE + + -- Note: this is a configuration pragma, but it is allowed to + -- appear anywhere else. + + when Pragma_Check_Policy => + GNAT_Pragma; + Check_Arg_Count (2); + Check_No_Identifier (Arg2); + Check_Optional_Identifier (Arg1, Name_Name); + Check_Arg_Is_One_Of + (Arg2, Name_On, Name_Off, Name_Check, Name_Ignore); + + -- A Check_Policy pragma can appear either as a configuration + -- pragma, or in a declarative part or a package spec (see RM + -- 11.5(5) for rules for Suppress/Unsuppress which are also + -- followed for Check_Policy). + + if not Is_Configuration_Pragma then + Check_Is_In_Decl_Part_Or_Package_Spec; + end if; + + Set_Next_Pragma (N, Opt.Check_Policy_List); + Opt.Check_Policy_List := N; + --------------------- -- CIL_Constructor -- --------------------- *************** package body Sem_Prag is *** 5288,5298 **** -- pragma Comment (static_string_EXPRESSION) ! -- Processing for pragma Comment shares the circuitry for ! -- pragma Ident. The only differences are that Ident enforces ! -- a limit of 31 characters on its argument, and also enforces ! -- limitations on placement for DEC compatibility. Pragma ! -- Comment shares neither of these restrictions. ------------------- -- Common_Object -- --- 5828,5838 ---- -- pragma Comment (static_string_EXPRESSION) ! -- Processing for pragma Comment shares the circuitry for pragma ! -- Ident. The only differences are that Ident enforces a limit of 31 ! -- characters on its argument, and also enforces limitations on ! -- placement for DEC compatibility. Pragma Comment shares neither of ! -- these restrictions. ------------------- -- Common_Object -- *************** package body Sem_Prag is *** 5313,5318 **** --- 5853,5859 ---- -- (boolean_EXPRESSION, static_string_EXPRESSION); when Pragma_Compile_Time_Error => + GNAT_Pragma; Process_Compile_Time_Warning_Or_Error; -------------------------- *************** package body Sem_Prag is *** 5323,5328 **** --- 5864,5870 ---- -- (boolean_EXPRESSION, static_string_EXPRESSION); when Pragma_Compile_Time_Warning => + GNAT_Pragma; Process_Compile_Time_Warning_Or_Error; ------------------- *************** package body Sem_Prag is *** 5697,5702 **** --- 6239,6246 ---- when Pragma_CPP_Virtual => CPP_Virtual : declare begin + GNAT_Pragma; + if Warn_On_Obsolescent_Feature then Error_Msg_N ("'G'N'A'T pragma cpp'_virtual is now obsolete and has " & *************** package body Sem_Prag is *** 5710,5715 **** --- 6254,6261 ---- when Pragma_CPP_Vtable => CPP_Vtable : declare begin + GNAT_Pragma; + if Warn_On_Obsolescent_Feature then Error_Msg_N ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " & *************** package body Sem_Prag is *** 5788,5795 **** -- pragma Discard_Names [([On =>] LOCAL_NAME)]; when Pragma_Discard_Names => Discard_Names : declare - E_Id : Entity_Id; E : Entity_Id; begin Check_Ada_83_Warning; --- 6334,6341 ---- -- pragma Discard_Names [([On =>] LOCAL_NAME)]; when Pragma_Discard_Names => Discard_Names : declare E : Entity_Id; + E_Id : Entity_Id; begin Check_Ada_83_Warning; *************** package body Sem_Prag is *** 5819,5824 **** --- 6365,6371 ---- Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_On); Check_Arg_Is_Local_Name (Arg1); + E_Id := Expression (Arg1); if Etype (E_Id) = Any_Type then *************** package body Sem_Prag is *** 5828,5835 **** end if; if (Is_First_Subtype (E) ! and then (Is_Enumeration_Type (E) ! or else Is_Tagged_Type (E))) or else Ekind (E) = E_Exception then Set_Discard_Names (E); --- 6375,6382 ---- end if; if (Is_First_Subtype (E) ! and then ! (Is_Enumeration_Type (E) or else Is_Tagged_Type (E))) or else Ekind (E) = E_Exception then Set_Discard_Names (E); *************** package body Sem_Prag is *** 5837,5842 **** --- 6384,6390 ---- Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); end if; + end if; end if; end Discard_Names; *************** package body Sem_Prag is *** 5907,5913 **** -- compilation unit. If the pragma appears in some unit -- in the context, there might still be a need for an -- Elaborate_All_Desirable from the current compilation ! -- to the the named unit, so we keep the check enabled. if In_Extended_Main_Source_Unit (N) then Set_Suppress_Elaboration_Warnings --- 6455,6461 ---- -- compilation unit. If the pragma appears in some unit -- in the context, there might still be a need for an -- Elaborate_All_Desirable from the current compilation ! -- to the named unit, so we keep the check enabled. if In_Extended_Main_Source_Unit (N) then Set_Suppress_Elaboration_Warnings *************** package body Sem_Prag is *** 5929,5935 **** end loop Outer; -- Give a warning if operating in static mode with -gnatwl ! -- (elaboration warnings eanbled) switch set. if Elab_Warnings and not Dynamic_Elaboration_Checks then Error_Msg_N --- 6477,6483 ---- end loop Outer; -- Give a warning if operating in static mode with -gnatwl ! -- (elaboration warnings enabled) switch set. if Elab_Warnings and not Dynamic_Elaboration_Checks then Error_Msg_N *************** package body Sem_Prag is *** 6182,6192 **** Process_Convention (C, Def_Id); if Ekind (Def_Id) /= E_Constant then ! Note_Possible_Modification (Expression (Arg2)); end if; Process_Interface_Name (Def_Id, Arg3, Arg4); Set_Exported (Def_Id, Arg2); end Export; ---------------------- --- 6730,6756 ---- Process_Convention (C, Def_Id); if Ekind (Def_Id) /= E_Constant then ! Note_Possible_Modification (Expression (Arg2), Sure => False); end if; Process_Interface_Name (Def_Id, Arg3, Arg4); Set_Exported (Def_Id, Arg2); + + -- If the entity is a deferred constant, propagate the + -- information to the full view, because gigi elaborates + -- the full view only. + + if Ekind (Def_Id) = E_Constant + and then Present (Full_View (Def_Id)) + then + declare + Id2 : constant Entity_Id := Full_View (Def_Id); + begin + Set_Is_Exported (Id2, Is_Exported (Def_Id)); + Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id)); + Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id)); + end; + end if; end Export; ---------------------- *************** package body Sem_Prag is *** 6213,6218 **** --- 6777,6784 ---- Code : Node_Id renames Args (4); begin + GNAT_Pragma; + if Inside_A_Generic then Error_Pragma ("pragma% cannot be used for generic entities"); end if; *************** package body Sem_Prag is *** 6574,6580 **** Check_At_Least_N_Arguments (2); Check_At_Most_N_Arguments (4); Process_Convention (C, Def_Id); ! Note_Possible_Modification (Expression (Arg2)); Process_Interface_Name (Def_Id, Arg3, Arg4); Set_Exported (Def_Id, Arg2); end External; --- 7140,7146 ---- Check_At_Least_N_Arguments (2); Check_At_Most_N_Arguments (4); Process_Convention (C, Def_Id); ! Note_Possible_Modification (Expression (Arg2), Sure => False); Process_Interface_Name (Def_Id, Arg3, Arg4); Set_Exported (Def_Id, Arg2); end External; *************** package body Sem_Prag is *** 6647,6653 **** -- If it's an access-to-subprogram type (in particular, not a -- subtype), set the flag on that type. ! if Ekind (Named_Entity) in Access_Subprogram_Type_Kind then Set_Can_Use_Internal_Rep (Named_Entity, False); -- Otherwise it's an error (name denotes the wrong sort of entity) --- 7213,7219 ---- -- If it's an access-to-subprogram type (in particular, not a -- subtype), set the flag on that type. ! if Is_Access_Subprogram_Type (Named_Entity) then Set_Can_Use_Internal_Rep (Named_Entity, False); -- Otherwise it's an error (name denotes the wrong sort of entity) *************** package body Sem_Prag is *** 6682,6687 **** --- 7248,7254 ---- Typ : Entity_Id; begin + GNAT_Pragma; Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); *************** package body Sem_Prag is *** 7015,7020 **** --- 7582,7588 ---- Code : Node_Id renames Args (4); begin + GNAT_Pragma; Gather_Associations (Names, Args); if Present (External) and then Present (Code) then *************** package body Sem_Prag is *** 7300,7305 **** --- 7868,7874 ---- -- pragma Inline_Always ( NAME {, NAME} ); when Pragma_Inline_Always => + GNAT_Pragma; Process_Inline (True); -------------------- *************** package body Sem_Prag is *** 7309,7314 **** --- 7878,7884 ---- -- pragma Inline_Generic (NAME {, NAME}); when Pragma_Inline_Generic => + GNAT_Pragma; Process_Generic_List; ---------------------- *************** package body Sem_Prag is *** 7394,7405 **** Def_Id := Entity (Id); end if; ! -- Special DEC-compatible processing for the object case, ! -- forces object to be imported. if Ekind (Def_Id) = E_Variable then Kill_Size_Check_Code (Def_Id); ! Note_Possible_Modification (Id); -- Initialization is not allowed for imported variable --- 7964,7975 ---- Def_Id := Entity (Id); end if; ! -- Special DEC-compatible processing for the object case, forces ! -- object to be imported. if Ekind (Def_Id) = E_Variable then Kill_Size_Check_Code (Def_Id); ! Note_Possible_Modification (Id, Sure => False); -- Initialization is not allowed for imported variable *************** package body Sem_Prag is *** 7419,7425 **** if Is_Imported (Def_Id) and then Present (First_Rep_Item (Def_Id)) and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma ! and then Chars (First_Rep_Item (Def_Id)) = Name_Interface then null; else --- 7989,7996 ---- if Is_Imported (Def_Id) and then Present (First_Rep_Item (Def_Id)) and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma ! and then ! Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface then null; else *************** package body Sem_Prag is *** 7505,7511 **** -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. ! Analyze_Per_Use_Expression (Arg, RTE (RE_Interrupt_Priority)); end if; if Nkind (P) /= N_Task_Definition --- 8076,8082 ---- -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. ! Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority)); end if; if Nkind (P) /= N_Task_Definition *************** package body Sem_Prag is *** 8027,8048 **** Check_No_Identifiers; Check_Arg_Count (1); Check_Is_In_Decl_Part_Or_Package_Spec; if Operating_Mode = Generate_Code and then In_Extended_Main_Source_Unit (N) then - Check_Arg_Is_Static_Expression (Arg1, Standard_String); - Start_String (Strval (Expr_Value_S (Expression (Arg1)))); - - Arg := Arg2; - while Present (Arg) loop - Check_Arg_Is_Static_Expression (Arg, Standard_String); - Store_String_Char (ASCII.NUL); - Store_String_Chars - (Strval (Expr_Value_S (Expression (Arg)))); - Arg := Next (Arg); - end loop; - Store_Linker_Option_String (End_String); end if; end Linker_Options; --- 8598,8617 ---- Check_No_Identifiers; Check_Arg_Count (1); Check_Is_In_Decl_Part_Or_Package_Spec; + Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Start_String (Strval (Expr_Value_S (Expression (Arg1)))); + + Arg := Arg2; + while Present (Arg) loop + Check_Arg_Is_Static_Expression (Arg, Standard_String); + Store_String_Char (ASCII.NUL); + Store_String_Chars (Strval (Expr_Value_S (Expression (Arg)))); + Arg := Next (Arg); + end loop; if Operating_Mode = Generate_Code and then In_Extended_Main_Source_Unit (N) then Store_Linker_Option_String (End_String); end if; end Linker_Options; *************** package body Sem_Prag is *** 8064,8069 **** --- 8633,8644 ---- Check_Arg_Is_Library_Level_Local_Name (Arg1); Check_Arg_Is_Static_Expression (Arg2, Standard_String); + -- This pragma applies only to objects + + if not Is_Object (Entity (Expression (Arg1))) then + Error_Pragma_Arg ("pragma% applies only to objects", Arg1); + end if; + -- The only processing required is to link this item on to the -- list of rep items for the given entity. This is accomplished -- by the call to Rep_Item_Too_Late (when no error is detected *************** package body Sem_Prag is *** 8251,8259 **** Nod := Next (N); while Present (Nod) loop if Nkind (Nod) = N_Pragma ! and then Chars (Nod) = Name_Main then ! Error_Msg_Name_1 := Chars (N); Error_Msg_N ("duplicate pragma% not permitted", Nod); end if; --- 8826,8834 ---- Nod := Next (N); while Present (Nod) loop if Nkind (Nod) = N_Pragma ! and then Pragma_Name (Nod) = Name_Main then ! Error_Msg_Name_1 := Pname; Error_Msg_N ("duplicate pragma% not permitted", Nod); end if; *************** package body Sem_Prag is *** 8295,8303 **** Nod := Next (N); while Present (Nod) loop if Nkind (Nod) = N_Pragma ! and then Chars (Nod) = Name_Main_Storage then ! Error_Msg_Name_1 := Chars (N); Error_Msg_N ("duplicate pragma% not permitted", Nod); end if; --- 8870,8878 ---- Nod := Next (N); while Present (Nod) loop if Nkind (Nod) = N_Pragma ! and then Pragma_Name (Nod) = Name_Main_Storage then ! Error_Msg_Name_1 := Pname; Error_Msg_N ("duplicate pragma% not permitted", Nod); end if; *************** package body Sem_Prag is *** 8334,8340 **** -- it was misplaced. when Pragma_No_Body => ! Error_Pragma ("misplaced pragma %"); --------------- -- No_Return -- --- 8909,8916 ---- -- it was misplaced. when Pragma_No_Body => ! GNAT_Pragma; ! Pragma_Misplaced; --------------- -- No_Return -- *************** package body Sem_Prag is *** 8400,8412 **** end loop; end No_Return; ------------------------ -- No_Strict_Aliasing -- ------------------------ -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)]; ! when Pragma_No_Strict_Aliasing => No_Strict_Alias : declare E_Id : Entity_Id; begin --- 8976,9018 ---- end loop; end No_Return; + ----------------- + -- No_Run_Time -- + ----------------- + + -- pragma No_Run_Time; + + -- Note: this pragma is retained for backwards compatibility. + -- See body of Rtsfind for full details on its handling. + + when Pragma_No_Run_Time => + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (0); + + No_Run_Time_Mode := True; + Configurable_Run_Time_Mode := True; + + -- Set Duration to 32 bits if word size is 32 + + if Ttypes.System_Word_Size = 32 then + Duration_32_Bits_On_Target := True; + end if; + + -- Set appropriate restrictions + + Set_Restriction (No_Finalization, N); + Set_Restriction (No_Exception_Handlers, N); + Set_Restriction (Max_Tasks, N, 0); + Set_Restriction (No_Tasking, N); + ------------------------ -- No_Strict_Aliasing -- ------------------------ -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)]; ! when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare E_Id : Entity_Id; begin *************** package body Sem_Prag is *** 8430,8436 **** Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id)); end if; ! end No_Strict_Alias; ----------------- -- Obsolescent -- --- 9036,9055 ---- Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id)); end if; ! end No_Strict_Aliasing; ! ! ----------------------- ! -- Normalize_Scalars -- ! ----------------------- ! ! -- pragma Normalize_Scalars; ! ! when Pragma_Normalize_Scalars => ! Check_Ada_83_Warning; ! Check_Arg_Count (0); ! Check_Valid_Configuration_Pragma; ! Normalize_Scalars := True; ! Init_Or_Norm_Scalars := True; ----------------- -- Obsolescent -- *************** package body Sem_Prag is *** 8465,8473 **** if Present (Ename) then -- If entity name matches, we are fine if Chars (Ename) = Chars (Ent) then ! null; -- If entity name does not match, only possibility is an -- enumeration literal from an enumeration type declaration. --- 9084,9094 ---- if Present (Ename) then -- If entity name matches, we are fine + -- Save entity in pragma argument, for ASIS use. if Chars (Ename) = Chars (Ent) then ! Set_Entity (Ename, Ent); ! Generate_Reference (Ent, Ename); -- If entity name does not match, only possibility is an -- enumeration literal from an enumeration type declaration. *************** package body Sem_Prag is *** 8485,8490 **** --- 9106,9113 ---- "enumeration literal"); elsif Chars (Ent) = Chars (Ename) then + Set_Entity (Ename, Ent); + Generate_Reference (Ent, Ename); exit; else *************** package body Sem_Prag is *** 8511,8517 **** end if; end loop; ! Set_Obsolescent_Warning (Ent, Expression (Arg1)); -- Check for Ada_05 parameter --- 9134,9141 ---- end if; end loop; ! Obsolescent_Warnings.Append ! ((Ent => Ent, Msg => Strval (Expression (Arg1)))); -- Check for Ada_05 parameter *************** package body Sem_Prag is *** 8610,8618 **** declare Ent : constant Entity_Id := Find_Lib_Unit_Name; begin ! if Ekind (Ent) = E_Package ! or else Ekind (Ent) = E_Generic_Package ! then Set_Obsolescent (Ent); return; end if; --- 9234,9240 ---- declare Ent : constant Entity_Id := Find_Lib_Unit_Name; begin ! if Is_Package_Or_Generic_Package (Ent) then Set_Obsolescent (Ent); return; end if; *************** package body Sem_Prag is *** 8637,8690 **** end if; end Obsolescent; - ----------------- - -- No_Run_Time -- - ----------------- - - -- pragma No_Run_Time - - -- Note: this pragma is retained for backwards compatibiltiy. - -- See body of Rtsfind for full details on its handling. - - when Pragma_No_Run_Time => - GNAT_Pragma; - Check_Valid_Configuration_Pragma; - Check_Arg_Count (0); - - No_Run_Time_Mode := True; - Configurable_Run_Time_Mode := True; - - -- Set Duration to 32 bits if word size is 32 - - if Ttypes.System_Word_Size = 32 then - Duration_32_Bits_On_Target := True; - end if; - - -- Set appropriate restrictions - - Set_Restriction (No_Finalization, N); - Set_Restriction (No_Exception_Handlers, N); - Set_Restriction (Max_Tasks, N, 0); - Set_Restriction (No_Tasking, N); - - ----------------------- - -- Normalize_Scalars -- - ----------------------- - - -- pragma Normalize_Scalars; - - when Pragma_Normalize_Scalars => - Check_Ada_83_Warning; - Check_Arg_Count (0); - Check_Valid_Configuration_Pragma; - Normalize_Scalars := True; - Init_Or_Norm_Scalars := True; - -------------- -- Optimize -- -------------- ! -- pragma Optimize (Time | Space); -- The actual check for optimize is done in Gigi. Note that this -- pragma does not actually change the optimization setting, it --- 9259,9269 ---- end if; end Obsolescent; -------------- -- Optimize -- -------------- ! -- pragma Optimize (Time | Space | Off); -- The actual check for optimize is done in Gigi. Note that this -- pragma does not actually change the optimization setting, it *************** package body Sem_Prag is *** 8695,8700 **** --- 9274,9312 ---- Check_Arg_Count (1); Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off); + ------------------------ + -- Optimize_Alignment -- + ------------------------ + + -- pragma Optimize_Alignment (Time | Space | Off); + + when Pragma_Optimize_Alignment => + GNAT_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Valid_Configuration_Pragma; + + declare + Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); + begin + case Nam is + when Name_Time => + Opt.Optimize_Alignment := 'T'; + when Name_Space => + Opt.Optimize_Alignment := 'S'; + when Name_Off => + Opt.Optimize_Alignment := 'O'; + when others => + Error_Pragma_Arg ("invalid argument for pragma%", Arg1); + end case; + end; + + -- Set indication that mode is set locally. If we are in fact in a + -- configuration pragma file, this setting is harmless since the + -- switch will get reset anyway at the start of each unit. + + Optimize_Alignment_Local := True; + ---------- -- Pack -- ---------- *************** package body Sem_Prag is *** 8883,8901 **** end if; end Preelab_Init; - ------------- - -- Polling -- - ------------- - - -- pragma Polling (ON | OFF); - - when Pragma_Polling => - GNAT_Pragma; - Check_Arg_Count (1); - Check_No_Identifiers; - Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); - Polling_Required := (Chars (Expression (Arg1)) = Name_On); - -------------------- -- Persistent_BSS -- -------------------- --- 9495,9500 ---- *************** package body Sem_Prag is *** 8954,8959 **** --- 9553,9647 ---- end if; end Persistent_BSS; + ------------- + -- Polling -- + ------------- + + -- pragma Polling (ON | OFF); + + when Pragma_Polling => + GNAT_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); + Polling_Required := (Chars (Expression (Arg1)) = Name_On); + + ------------------- + -- Postcondition -- + ------------------- + + -- pragma Postcondition ([Check =>] Boolean_Expression + -- [,[Message =>] String_Expression]); + + when Pragma_Postcondition => Postcondition : declare + In_Body : Boolean; + pragma Warnings (Off, In_Body); + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); + Check_Optional_Identifier (Arg1, Name_Check); + + -- All we need to do here is call the common check procedure, + -- the remainder of the processing is found in Sem_Ch6/Sem_Ch7. + + Check_Precondition_Postcondition (In_Body); + end Postcondition; + + ------------------ + -- Precondition -- + ------------------ + + -- pragma Precondition ([Check =>] Boolean_Expression + -- [,[Message =>] String_Expression]); + + when Pragma_Precondition => Precondition : declare + In_Body : Boolean; + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); + Check_Optional_Identifier (Arg1, Name_Check); + + Check_Precondition_Postcondition (In_Body); + + -- If in spec, nothing to do. If in body, then we convert the + -- pragma to pragma Check (Precondition, cond [, msg]). Note we + -- do this whether or not precondition checks are enabled. That + -- works fine since pragma Check will do this check. + + if In_Body then + if Arg_Count = 2 then + Check_Optional_Identifier (Arg3, Name_Message); + Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String); + end if; + + Analyze_And_Resolve (Get_Pragma_Arg (Arg1), Standard_Boolean); + + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Loc, + Chars => Name_Precondition)), + + Make_Pragma_Argument_Association (Sloc (Arg1), + Expression => Relocate_Node (Get_Pragma_Arg (Arg1)))))); + + if Arg_Count = 2 then + Append_To (Pragma_Argument_Associations (N), + Make_Pragma_Argument_Association (Sloc (Arg2), + Expression => Relocate_Node (Get_Pragma_Arg (Arg2)))); + end if; + + Analyze (N); + end if; + end Precondition; + ------------------ -- Preelaborate -- ------------------ *************** package body Sem_Prag is *** 9107,9113 **** -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. ! Analyze_Per_Use_Expression (Arg, Standard_Integer); if not Is_Static_Expression (Arg) then Check_Restriction (Static_Priorities, Arg); --- 9795,9801 ---- -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. ! Preanalyze_Spec_Expression (Arg, Standard_Integer); if not Is_Static_Expression (Arg) then Check_Restriction (Static_Priorities, Arg); *************** package body Sem_Prag is *** 9274,9280 **** -- pragma Profile (profile_IDENTIFIER); ! -- profile_IDENTIFIER => Protected | Ravenscar when Pragma_Profile => Ada_2005_Pragma; --- 9962,9968 ---- -- pragma Profile (profile_IDENTIFIER); ! -- profile_IDENTIFIER => Restricted | Ravenscar when Pragma_Profile => Ada_2005_Pragma; *************** package body Sem_Prag is *** 9288,9294 **** if Chars (Argx) = Name_Ravenscar then Set_Ravenscar_Profile (N); elsif Chars (Argx) = Name_Restricted then ! Set_Profile_Restrictions (Restricted, N, Warn => False); else Error_Pragma_Arg ("& is not a valid profile", Argx); end if; --- 9976,9983 ---- if Chars (Argx) = Name_Ravenscar then Set_Ravenscar_Profile (N); elsif Chars (Argx) = Name_Restricted then ! Set_Profile_Restrictions ! (Restricted, N, Warn => Treat_Restrictions_As_Warnings); else Error_Pragma_Arg ("& is not a valid profile", Argx); end if; *************** package body Sem_Prag is *** 9300,9306 **** -- pragma Profile_Warnings (profile_IDENTIFIER); ! -- profile_IDENTIFIER => Protected | Ravenscar when Pragma_Profile_Warnings => GNAT_Pragma; --- 9989,9995 ---- -- pragma Profile_Warnings (profile_IDENTIFIER); ! -- profile_IDENTIFIER => Restricted | Ravenscar when Pragma_Profile_Warnings => GNAT_Pragma; *************** package body Sem_Prag is *** 9634,9639 **** --- 10323,10377 ---- end if; end; + ----------------------- + -- Relative_Deadline -- + ----------------------- + + -- pragma Relative_Deadline (time_span_EXPRESSION); + + when Pragma_Relative_Deadline => Relative_Deadline : declare + P : constant Node_Id := Parent (N); + Arg : Node_Id; + + begin + Ada_2005_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + + Arg := Expression (Arg1); + + -- The expression must be analyzed in the special manner described + -- in "Handling of Default and Per-Object Expressions" in sem.ads. + + Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); + + -- Subprogram case + + if Nkind (P) = N_Subprogram_Body then + Check_In_Main_Program; + + -- Tasks + + elsif Nkind (P) = N_Task_Definition then + null; + + -- Anything else is incorrect + + else + Pragma_Misplaced; + end if; + + if Has_Relative_Deadline_Pragma (P) then + Error_Pragma ("duplicate pragma% not allowed"); + else + Set_Has_Relative_Deadline_Pragma (P, True); + + if Nkind (P) = N_Task_Definition then + Record_Rep_Item (Defining_Identifier (Parent (P)), N); + end if; + end if; + end Relative_Deadline; + --------------------------- -- Remote_Call_Interface -- --------------------------- *************** package body Sem_Prag is *** 9734,9740 **** GNAT_Pragma; Check_Arg_Count (0); Check_Valid_Configuration_Pragma; ! Set_Profile_Restrictions (Restricted, N, Warn => False); if Warn_On_Obsolescent_Feature then Error_Msg_N --- 10472,10479 ---- GNAT_Pragma; Check_Arg_Count (0); Check_Valid_Configuration_Pragma; ! Set_Profile_Restrictions ! (Restricted, N, Warn => Treat_Restrictions_As_Warnings); if Warn_On_Obsolescent_Feature then Error_Msg_N *************** package body Sem_Prag is *** 9754,9760 **** -- | restriction_parameter_IDENTIFIER => EXPRESSION when Pragma_Restrictions => ! Process_Restrictions_Or_Restriction_Warnings (Warn => False); -------------------------- -- Restriction_Warnings -- --- 10493,10500 ---- -- | restriction_parameter_IDENTIFIER => EXPRESSION when Pragma_Restrictions => ! Process_Restrictions_Or_Restriction_Warnings ! (Warn => Treat_Restrictions_As_Warnings); -------------------------- -- Restriction_Warnings -- *************** package body Sem_Prag is *** 9767,9772 **** --- 10507,10513 ---- -- | restriction_parameter_IDENTIFIER => EXPRESSION when Pragma_Restriction_Warnings => + GNAT_Pragma; Process_Restrictions_Or_Restriction_Warnings (Warn => True); ---------------- *************** package body Sem_Prag is *** 9960,9972 **** Check_No_Identifiers; Check_Arg_Count (1); ! -- The expression must be analyzed in the special manner ! -- described in "Handling of Default Expressions" in sem.ads. ! ! -- Set In_Default_Expression for per-object case ??? Arg := Expression (Arg1); ! Analyze_Per_Use_Expression (Arg, Any_Integer); if not Is_Static_Expression (Arg) then Check_Restriction (Static_Storage_Size, Arg); --- 10701,10711 ---- Check_No_Identifiers; Check_Arg_Count (1); ! -- The expression must be analyzed in the special manner described ! -- in "Handling of Default Expressions" in sem.ads. Arg := Expression (Arg1); ! Preanalyze_Spec_Expression (Arg, Any_Integer); if not Is_Static_Expression (Arg) then Check_Restriction (Static_Storage_Size, Arg); *************** package body Sem_Prag is *** 10052,10058 **** end if; end Check_OK_Stream_Convert_Function; ! -- Start of procecessing for Stream_Convert begin GNAT_Pragma; --- 10791,10797 ---- end if; end Check_OK_Stream_Convert_Function; ! -- Start of processing for Stream_Convert begin GNAT_Pragma; *************** package body Sem_Prag is *** 10072,10095 **** Write : constant Entity_Id := Entity (Expression (Arg3)); begin ! if Etype (Typ) = Any_Type ! or else ! Etype (Read) = Any_Type or else ! Etype (Write) = Any_Type then return; end if; ! Check_First_Subtype (Arg1); ! if Rep_Item_Too_Early (Typ, N) or else ! Rep_Item_Too_Late (Typ, N) then return; end if; if Underlying_Type (Etype (Read)) /= Typ then Error_Pragma_Arg ("incorrect return type for function&", Arg2); --- 10811,10845 ---- Write : constant Entity_Id := Entity (Expression (Arg3)); begin ! Check_First_Subtype (Arg1); ! ! -- Check for too early or too late. Note that we don't enforce ! -- the rule about primitive operations in this case, since, as ! -- is the case for explicit stream attributes themselves, these ! -- restrictions are not appropriate. Note that the chaining of ! -- the pragma by Rep_Item_Too_Late is actually the critical ! -- processing done for this pragma. ! ! if Rep_Item_Too_Early (Typ, N) or else ! Rep_Item_Too_Late (Typ, N, FOnly => True) then return; end if; ! -- Return if previous error ! if Etype (Typ) = Any_Type or else ! Etype (Read) = Any_Type ! or else ! Etype (Write) = Any_Type then return; end if; + -- Error checks + if Underlying_Type (Etype (Read)) /= Typ then Error_Pragma_Arg ("incorrect return type for function&", Arg2); *************** package body Sem_Prag is *** 10332,10337 **** --- 11082,11088 ---- -- or the identifier GCC, no other identifiers are acceptable. when Pragma_System_Name => + GNAT_Pragma; Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat); *************** package body Sem_Prag is *** 10412,10419 **** -- pragma Task_Name (string_EXPRESSION); when Pragma_Task_Name => Task_Name : declare - -- pragma Priority (EXPRESSION); - P : constant Node_Id := Parent (N); Arg : Node_Id; --- 11163,11168 ---- *************** package body Sem_Prag is *** 10508,10516 **** Nod := Next (N); while Present (Nod) loop if Nkind (Nod) = N_Pragma ! and then Chars (Nod) = Name_Time_Slice then ! Error_Msg_Name_1 := Chars (N); Error_Msg_N ("duplicate pragma% not permitted", Nod); end if; --- 11257,11265 ---- Nod := Next (N); while Present (Nod) loop if Nkind (Nod) = N_Pragma ! and then Pragma_Name (Nod) = Name_Time_Slice then ! Error_Msg_Name_1 := Pname; Error_Msg_N ("duplicate pragma% not permitted", Nod); end if; *************** package body Sem_Prag is *** 10582,10588 **** Variant : Node_Id; begin ! GNAT_Pragma; Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); --- 11331,11337 ---- Variant : Node_Id; begin ! Ada_2005_Pragma; Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); *************** package body Sem_Prag is *** 10949,10955 **** -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]); when Pragma_Unsuppress => ! GNAT_Pragma; Process_Suppress_Unsuppress (False); ------------------- --- 11698,11704 ---- -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]); when Pragma_Unsuppress => ! Ada_2005_Pragma; Process_Suppress_Unsuppress (False); ------------------- *************** package body Sem_Prag is *** 11165,11170 **** --- 11914,11925 ---- Set_Warnings_Off (E, (Chars (Expression (Arg1)) = Name_Off)); + if Chars (Expression (Arg1)) = Name_Off + and then Warn_On_Warnings_Off + then + Warnings_Off_Pragmas.Append ((N, E)); + end if; + if Is_Enumeration_Type (E) then declare Lit : Entity_Id; *************** package body Sem_Prag is *** 11267,11272 **** --- 12022,12028 ---- -- pragma Wide_Character_Encoding (IDENTIFIER); when Pragma_Wide_Character_Encoding => + GNAT_Pragma; -- Nothing to do, handled in parser. Note that we do not enforce -- configuration pragma placement, this pragma can appear at any *************** package body Sem_Prag is *** 11290,11304 **** when Pragma_Exit => null; end Analyze_Pragma; --------------------------------- -- Delay_Config_Pragma_Analyze -- --------------------------------- function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is begin ! return Chars (N) = Name_Interrupt_State or else ! Chars (N) = Name_Priority_Specific_Dispatching; end Delay_Config_Pragma_Analyze; ------------------------- --- 12046,12093 ---- when Pragma_Exit => null; end Analyze_Pragma; + ------------------- + -- Check_Enabled -- + ------------------- + + function Check_Enabled (Nam : Name_Id) return Boolean is + PP : Node_Id; + + begin + PP := Opt.Check_Policy_List; + loop + if No (PP) then + return Assertions_Enabled; + + elsif + Nam = Chars (Expression (First (Pragma_Argument_Associations (PP)))) + then + case + Chars (Expression (Last (Pragma_Argument_Associations (PP)))) + is + when Name_On | Name_Check => + return True; + when Name_Off | Name_Ignore => + return False; + when others => + raise Program_Error; + end case; + + else + PP := Next_Pragma (PP); + end if; + end loop; + end Check_Enabled; + --------------------------------- -- Delay_Config_Pragma_Analyze -- --------------------------------- function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is begin ! return Pragma_Name (N) = Name_Interrupt_State or else ! Pragma_Name (N) = Name_Priority_Specific_Dispatching; end Delay_Config_Pragma_Analyze; ------------------------- *************** package body Sem_Prag is *** 11325,11330 **** --- 12114,12141 ---- return Result; end Get_Base_Subprogram; + -------------------- + -- Get_Pragma_Arg -- + -------------------- + + function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is + begin + if Nkind (Arg) = N_Pragma_Argument_Association then + return Expression (Arg); + else + return Arg; + end if; + end Get_Pragma_Arg; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Externals.Init; + end Initialize; + ----------------------------- -- Is_Config_Static_String -- ----------------------------- *************** package body Sem_Prag is *** 11377,11383 **** return True; end Add_Config_Static_String; ! -- Start of prorcessing for Is_Config_Static_String begin --- 12188,12194 ---- return True; end Add_Config_Static_String; ! -- Start of processing for Is_Config_Static_String begin *************** package body Sem_Prag is *** 11392,11402 **** -- This function makes use of the following static table which indicates -- whether a given pragma is significant. A value of -1 in this table -- indicates that the reference is significant. A value of zero indicates ! -- than appearence as any argument is insignificant, a positive value ! -- indicates that appearence in that parameter position is significant. ! Sig_Flags : constant array (Pragma_Id) of Int := (Pragma_AST_Entry => -1, Pragma_Abort_Defer => -1, Pragma_Ada_83 => -1, --- 12203,12216 ---- -- This function makes use of the following static table which indicates -- whether a given pragma is significant. A value of -1 in this table -- indicates that the reference is significant. A value of zero indicates ! -- than appearance as any argument is insignificant, a positive value ! -- indicates that appearance in that parameter position is significant. ! -- A value of 99 flags a special case requiring a special check (this is ! -- used for cases not covered by this standard encoding, e.g. pragma Check ! -- where the first argument is not significant, but the others are). + Sig_Flags : constant array (Pragma_Id) of Int := (Pragma_AST_Entry => -1, Pragma_Abort_Defer => -1, Pragma_Ada_83 => -1, *************** package body Sem_Prag is *** 11407,11417 **** --- 12221,12234 ---- Pragma_Annotate => -1, Pragma_Assert => -1, Pragma_Assertion_Policy => 0, + Pragma_Assume_No_Invalid_Values => 0, Pragma_Asynchronous => -1, Pragma_Atomic => 0, Pragma_Atomic_Components => 0, Pragma_Attach_Handler => -1, + Pragma_Check => 99, Pragma_Check_Name => 0, + Pragma_Check_Policy => 0, Pragma_CIL_Constructor => -1, Pragma_CPP_Class => 0, Pragma_CPP_Constructor => 0, *************** package body Sem_Prag is *** 11496,11507 **** --- 12313,12327 ---- Pragma_Normalize_Scalars => -1, Pragma_Obsolescent => 0, Pragma_Optimize => -1, + Pragma_Optimize_Alignment => -1, Pragma_Pack => 0, Pragma_Page => -1, Pragma_Passive => -1, Pragma_Preelaborable_Initialization => -1, Pragma_Polling => -1, Pragma_Persistent_BSS => 0, + Pragma_Postcondition => -1, + Pragma_Precondition => -1, Pragma_Preelaborate => -1, Pragma_Preelaborate_05 => -1, Pragma_Priority => -1, *************** package body Sem_Prag is *** 11515,11520 **** --- 12335,12341 ---- Pragma_Pure_Function => -1, Pragma_Queuing_Policy => -1, Pragma_Ravenscar => -1, + Pragma_Relative_Deadline => -1, Pragma_Remote_Call_Interface => -1, Pragma_Remote_Types => -1, Pragma_Restricted_Run_Time => -1, *************** package body Sem_Prag is *** 11564,11572 **** Unknown_Pragma => 0); function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is ! P : Node_Id; ! C : Int; ! A : Node_Id; begin P := Parent (N); --- 12385,12394 ---- Unknown_Pragma => 0); function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is ! Id : Pragma_Id; ! P : Node_Id; ! C : Int; ! A : Node_Id; begin P := Parent (N); *************** package body Sem_Prag is *** 11575,11581 **** return False; else ! C := Sig_Flags (Get_Pragma_Id (Chars (Parent (P)))); case C is when -1 => --- 12397,12404 ---- return False; else ! Id := Get_Pragma_Id (Parent (P)); ! C := Sig_Flags (Id); case C is when -1 => *************** package body Sem_Prag is *** 11584,11589 **** --- 12407,12427 ---- when 0 => return True; + when 99 => + case Id is + + -- For pragma Check, the first argument is not significant, + -- the second and the third (if present) arguments are + -- significant. + + when Pragma_Check => + return + P = First (Pragma_Argument_Associations (Parent (P))); + + when others => + raise Program_Error; + end case; + when others => A := First (Pragma_Argument_Associations (Parent (P))); for J in 1 .. C - 1 loop *************** package body Sem_Prag is *** 11594,11600 **** Next (A); end loop; ! return A = P; end case; end if; end Is_Non_Significant_Pragma_Reference; --- 12432,12438 ---- Next (A); end loop; ! return A = P; -- is this wrong way round ??? end case; end if; end Is_Non_Significant_Pragma_Reference; *************** package body Sem_Prag is *** 11612,11618 **** function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is Pragn : constant Node_Id := Parent (Par); Assoc : constant List_Id := Pragma_Argument_Associations (Pragn); ! Pname : constant Name_Id := Chars (Pragn); Argn : Natural; N : Node_Id; --- 12450,12456 ---- function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is Pragn : constant Node_Id := Parent (Par); Assoc : constant List_Id := Pragma_Argument_Associations (Pragn); ! Pname : constant Name_Id := Pragma_Name (Pragn); Argn : Natural; N : Node_Id; *************** package body Sem_Prag is *** 11686,11692 **** if Present (PA) then P := First (PA); while Present (P) loop ! if Chars (P) = Name_Suppress_All then Prepend_To (Context_Items (N), Make_Pragma (Sloc (P), Chars => Name_Suppress, --- 12524,12530 ---- if Present (PA) then P := First (PA); while Present (P) loop ! if Pragma_Name (P) = Name_Suppress_All then Prepend_To (Context_Items (N), Make_Pragma (Sloc (P), Chars => Name_Suppress, *************** package body Sem_Prag is *** 11848,11851 **** --- 12686,12690 ---- Set_Entity (Pref, Scop); end if; end Set_Unit_Name; + end Sem_Prag; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_prag.ads gcc-4.4.0/gcc/ada/sem_prag.ads *** gcc-4.3.3/gcc/ada/sem_prag.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_prag.ads Mon Apr 14 21:07:59 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** *** 26,38 **** --- 26,61 ---- -- Pragma handling is isolated in a separate package -- (logically this processing belongs in chapter 4) + with Namet; use Namet; with Types; use Types; package Sem_Prag is + ----------------- + -- Subprograms -- + ----------------- + + procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id); + -- Special analyze routine for precondition/postcondition pragma that + -- appears within a declarative part where the pragma is associated + -- with a subprogram specification. N is the pragma node, and S is the + -- entity for the related subprogram. This procedure does a preanalysis + -- of the expressions in the pragma as "spec expressions" (see section + -- in Sem "Handling of Default and Per-Object Expressions..."). + procedure Analyze_Pragma (N : Node_Id); -- Analyze procedure for pragma reference node N + function Check_Enabled (Nam : Name_Id) return Boolean; + -- This function is used in connection with pragmas Assertion, Check, + -- Precondition, and Postcondition to determine if Check pragmas (or + -- corresponding Assert, Precondition, or Postcondition pragmas) are + -- currently active, as determined by the presence of -gnata on the + -- command line (which sets the default), and the appearance of pragmas + -- Check_Policy and Assertion_Policy as configuration pragmas either in + -- a configuration pragma file, or at the start of the current unit. + -- True is returned if the specified check is enabled. + function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean; -- N is a pragma appearing in a configuration pragma file. Most such -- pragmas are analyzed when the file is read, before parsing and analyzing *************** package Sem_Prag is *** 43,54 **** -- True have their analysis delayed until after the main program is parsed -- and analyzed. function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean; -- The node N is a node for an entity and the issue is whether the -- occurrence is a reference for the purposes of giving warnings about -- unreferenced variables. This function returns True if the reference is -- not a reference from this point of view (e.g. the occurrence in a pragma ! -- Pack) and False if it is a real reference (e.g. the occcurrence in a -- pragma Export); function Is_Pragma_String_Literal (Par : Node_Id) return Boolean; --- 66,81 ---- -- True have their analysis delayed until after the main program is parsed -- and analyzed. + procedure Initialize; + -- Initializes data structures used for pragma processing. Must be called + -- before analyzing each new main source program. + function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean; -- The node N is a node for an entity and the issue is whether the -- occurrence is a reference for the purposes of giving warnings about -- unreferenced variables. This function returns True if the reference is -- not a reference from this point of view (e.g. the occurrence in a pragma ! -- Pack) and False if it is a real reference (e.g. the occurrence in a -- pragma Export); function Is_Pragma_String_Literal (Par : Node_Id) return Boolean; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_res.adb gcc-4.4.0/gcc/ada/sem_res.adb *** gcc-4.3.3/gcc/ada/sem_res.adb Wed Dec 19 16:22:40 2007 --- gcc-4.4.0/gcc/ada/sem_res.adb Wed Aug 6 09:35:06 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Sem_Cat; use Sem_Cat; *** 56,61 **** --- 56,62 ---- with Sem_Ch4; use Sem_Ch4; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; + with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Elab; use Sem_Elab; *************** with Sinfo; use Sinfo; *** 68,73 **** --- 69,75 ---- with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; + with Style; use Style; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; *************** package body Sem_Res is *** 395,403 **** D : Node_Id; begin ! -- Any use in a default expression is legal ! if In_Default_Expression then null; elsif Nkind (PN) = N_Range then --- 397,405 ---- D : Node_Id; begin ! -- Any use in a spec-expression is legal ! if In_Spec_Expression then null; elsif Nkind (PN) = N_Range then *************** package body Sem_Res is *** 434,443 **** and then Scope (Disc) = Current_Scope and then not (Nkind (Parent (P)) = N_Subtype_Indication ! and then ! (Nkind (Parent (Parent (P))) = N_Component_Definition ! or else ! Nkind (Parent (Parent (P))) = N_Subtype_Declaration) and then Paren_Count (N) = 0) then Error_Msg_N --- 436,444 ---- and then Scope (Disc) = Current_Scope and then not (Nkind (Parent (P)) = N_Subtype_Indication ! and then ! Nkind_In (Parent (Parent (P)), N_Component_Definition, ! N_Subtype_Declaration) and then Paren_Count (N) = 0) then Error_Msg_N *************** package body Sem_Res is *** 445,460 **** return; end if; ! -- Detect a common beginner error: -- type R (D : Positive := 100) is record -- Name : String (1 .. D); -- end record; ! -- The default value causes an object of type R to be ! -- allocated with room for Positive'Last characters. ! declare SI : Node_Id; T : Entity_Id; TB : Node_Id; --- 446,463 ---- return; end if; ! -- Detect a common error: -- type R (D : Positive := 100) is record -- Name : String (1 .. D); -- end record; ! -- The default value causes an object of type R to be allocated ! -- with room for Positive'Last characters. The RM does not mandate ! -- the allocation of the maximum size, but that is what GNAT does ! -- so we should warn the programmer that there is a problem. ! Check_Large : declare SI : Node_Id; T : Entity_Id; TB : Node_Id; *************** package body Sem_Res is *** 471,484 **** function Large_Storage_Type (T : Entity_Id) return Boolean is begin ! return ! T = Standard_Integer ! or else ! T = Standard_Positive ! or else ! T = Standard_Natural; end Large_Storage_Type; begin -- Check that the Disc has a large range --- 474,492 ---- function Large_Storage_Type (T : Entity_Id) return Boolean is begin ! -- The type is considered large if its bounds are known at ! -- compile time and if it requires at least as many bits as ! -- a Positive to store the possible values. ! ! return Compile_Time_Known_Value (Type_Low_Bound (T)) ! and then Compile_Time_Known_Value (Type_High_Bound (T)) ! and then ! Minimum_Size (T, Biased => True) >= ! RM_Size (Standard_Positive); end Large_Storage_Type; + -- Start of processing for Check_Large + begin -- Check that the Disc has a large range *************** package body Sem_Res is *** 549,561 **** <> null; ! end; end if; -- Legal case is in index or discriminant constraint ! elsif Nkind (PN) = N_Index_Or_Discriminant_Constraint ! or else Nkind (PN) = N_Discriminant_Association then if Paren_Count (N) > 0 then Error_Msg_N --- 557,569 ---- <> null; ! end Check_Large; end if; -- Legal case is in index or discriminant constraint ! elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint, ! N_Discriminant_Association) then if Paren_Count (N) > 0 then Error_Msg_N *************** package body Sem_Res is *** 576,584 **** else D := PN; P := Parent (PN); ! while Nkind (P) /= N_Component_Declaration ! and then Nkind (P) /= N_Subtype_Indication ! and then Nkind (P) /= N_Entry_Declaration loop D := P; P := Parent (P); --- 584,592 ---- else D := PN; P := Parent (PN); ! while not Nkind_In (P, N_Component_Declaration, ! N_Subtype_Indication, ! N_Entry_Declaration) loop D := P; P := Parent (P); *************** package body Sem_Res is *** 591,600 **** -- is of course a double fault. if (Nkind (P) = N_Subtype_Indication ! and then ! (Nkind (Parent (P)) = N_Component_Definition ! or else ! Nkind (Parent (P)) = N_Derived_Type_Definition) and then D = Constraint (P)) -- The constraint itself may be given by a subtype indication, --- 599,606 ---- -- is of course a double fault. if (Nkind (P) = N_Subtype_Indication ! and then Nkind_In (Parent (P), N_Component_Definition, ! N_Derived_Type_Definition) and then D = Constraint (P)) -- The constraint itself may be given by a subtype indication, *************** package body Sem_Res is *** 720,747 **** -- Start of processing for Check_Infinite_Recursion begin ! -- Loop moving up tree, quitting if something tells us we are ! -- definitely not in an infinite recursion situation. C := N; loop P := Parent (C); exit when Nkind (P) = N_Subprogram_Body; ! if Nkind (P) = N_Or_Else or else ! Nkind (P) = N_And_Then or else ! Nkind (P) = N_If_Statement or else ! Nkind (P) = N_Case_Statement then return False; elsif Nkind (P) = N_Handled_Sequence_Of_Statements and then C /= First (Statements (P)) then ! -- If the call is the expression of a return statement and ! -- the actuals are identical to the formals, it's worth a ! -- warning. However, we skip this if there is an immediately ! -- preceding raise statement, since the call is never executed. -- Furthermore, this corresponds to a common idiom: --- 726,793 ---- -- Start of processing for Check_Infinite_Recursion begin ! -- Special case, if this is a procedure call and is a call to the ! -- current procedure with the same argument list, then this is for ! -- sure an infinite recursion and we insert a call to raise SE. ! ! if Is_List_Member (N) ! and then List_Length (List_Containing (N)) = 1 ! and then Same_Argument_List ! then ! declare ! P : constant Node_Id := Parent (N); ! begin ! if Nkind (P) = N_Handled_Sequence_Of_Statements ! and then Nkind (Parent (P)) = N_Subprogram_Body ! and then Is_Empty_List (Declarations (Parent (P))) ! then ! Error_Msg_N ("!?infinite recursion", N); ! Error_Msg_N ("\!?Storage_Error will be raised at run time", N); ! Insert_Action (N, ! Make_Raise_Storage_Error (Sloc (N), ! Reason => SE_Infinite_Recursion)); ! return True; ! end if; ! end; ! end if; ! ! -- If not that special case, search up tree, quitting if we reach a ! -- construct (e.g. a conditional) that tells us that this is not a ! -- case for an infinite recursion warning. C := N; loop P := Parent (C); + + -- If no parent, then we were not inside a subprogram, this can for + -- example happen when processing certain pragmas in a spec. Just + -- return False in this case. + + if No (P) then + return False; + end if; + + -- Done if we get to subprogram body, this is definitely an infinite + -- recursion case if we did not find anything to stop us. + exit when Nkind (P) = N_Subprogram_Body; ! -- If appearing in conditional, result is false ! ! if Nkind_In (P, N_Or_Else, ! N_And_Then, ! N_If_Statement, ! N_Case_Statement) then return False; elsif Nkind (P) = N_Handled_Sequence_Of_Statements and then C /= First (Statements (P)) then ! -- If the call is the expression of a return statement and the ! -- actuals are identical to the formals, it's worth a warning. ! -- However, we skip this if there is an immediately preceding ! -- raise statement, since the call is never executed. -- Furthermore, this corresponds to a common idiom: *************** package body Sem_Res is *** 805,811 **** function Uses_SS (T : Entity_Id) return Boolean; -- Check whether the creation of an object of the type will involve -- use of the secondary stack. If T is a record type, this is true ! -- if the expression for some component uses the secondary stack, eg. -- through a call to a function that returns an unconstrained value. -- False if T is controlled, because cleanups occur elsewhere. --- 851,857 ---- function Uses_SS (T : Entity_Id) return Boolean; -- Check whether the creation of an object of the type will involve -- use of the secondary stack. If T is a record type, this is true ! -- if the expression for some component uses the secondary stack, e.g. -- through a call to a function that returns an unconstrained value. -- False if T is controlled, because cleanups occur elsewhere. *************** package body Sem_Res is *** 937,961 **** Require_Entity (N); end if; ! -- If the context expects a value, and the name is a procedure, ! -- this is most likely a missing 'Access. Do not try to resolve ! -- the parameterless call, error will be caught when the outer ! -- call is analyzed. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Procedure and then not Is_Overloaded (N) and then ! (Nkind (Parent (N)) = N_Parameter_Association ! or else Nkind (Parent (N)) = N_Function_Call ! or else Nkind (Parent (N)) = N_Procedure_Call_Statement) then return; end if; ! -- Rewrite as call if overloadable entity that is (or could be, in ! -- the overloaded case) a function call. If we know for sure that ! -- the entity is an enumeration literal, we do not rewrite it. if (Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) --- 983,1006 ---- Require_Entity (N); end if; ! -- If the context expects a value, and the name is a procedure, this is ! -- most likely a missing 'Access. Don't try to resolve the parameterless ! -- call, error will be caught when the outer call is analyzed. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Procedure and then not Is_Overloaded (N) and then ! Nkind_In (Parent (N), N_Parameter_Association, ! N_Function_Call, ! N_Procedure_Call_Statement) then return; end if; ! -- Rewrite as call if overloadable entity that is (or could be, in the ! -- overloaded case) a function call. If we know for sure that the entity ! -- is an enumeration literal, we do not rewrite it. if (Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) *************** package body Sem_Res is *** 963,969 **** or else Is_Overloaded (N))) -- Rewrite as call if it is an explicit deference of an expression of ! -- a subprogram access type, and the suprogram type is not that of a -- procedure or entry. or else --- 1008,1014 ---- or else Is_Overloaded (N))) -- Rewrite as call if it is an explicit deference of an expression of ! -- a subprogram access type, and the subprogram type is not that of a -- procedure or entry. or else *************** package body Sem_Res is *** 1360,1366 **** Set_Entity (Op_Node, Op_Id); Generate_Reference (Op_Id, N, ' '); ! Rewrite (N, Op_Node); -- If this is an arithmetic operator and the result type is private, -- the operands and the result must be wrapped in conversion to --- 1405,1423 ---- Set_Entity (Op_Node, Op_Id); Generate_Reference (Op_Id, N, ' '); ! ! -- Do rewrite setting Comes_From_Source on the result if the original ! -- call came from source. Although it is not strictly the case that the ! -- operator as such comes from the source, logically it corresponds ! -- exactly to the function call in the source, so it should be marked ! -- this way (e.g. to make sure that validity checks work fine). ! ! declare ! CS : constant Boolean := Comes_From_Source (N); ! begin ! Rewrite (N, Op_Node); ! Set_Comes_From_Source (N, CS); ! end; -- If this is an arithmetic operator and the result type is private, -- the operands and the result must be wrapped in conversion to *************** package body Sem_Res is *** 1461,1471 **** return Kind; end Operator_Kind; ! ----------------------------- ! -- Pre_Analyze_And_Resolve -- ! ----------------------------- ! procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id) is Save_Full_Analysis : constant Boolean := Full_Analysis; begin --- 1518,1528 ---- return Kind; end Operator_Kind; ! ---------------------------- ! -- Preanalyze_And_Resolve -- ! ---------------------------- ! procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is Save_Full_Analysis : constant Boolean := Full_Analysis; begin *************** package body Sem_Res is *** 1480,1490 **** Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; ! end Pre_Analyze_And_Resolve; -- Version without context type ! procedure Pre_Analyze_And_Resolve (N : Node_Id) is Save_Full_Analysis : constant Boolean := Full_Analysis; begin --- 1537,1547 ---- Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; ! end Preanalyze_And_Resolve; -- Version without context type ! procedure Preanalyze_And_Resolve (N : Node_Id) is Save_Full_Analysis : constant Boolean := Full_Analysis; begin *************** package body Sem_Res is *** 1496,1502 **** Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; ! end Pre_Analyze_And_Resolve; ---------------------------------- -- Replace_Actual_Discriminants -- --- 1553,1559 ---- Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; ! end Preanalyze_And_Resolve; ---------------------------------- -- Replace_Actual_Discriminants -- *************** package body Sem_Res is *** 1621,1626 **** --- 1678,1684 ---- Intval => UR_To_Uint (Realval (N)))); Set_Etype (N, Universal_Integer); Set_Is_Static_Expression (N); + elsif Nkind (N) = N_String_Literal and then Is_Character_Type (Typ) then *************** package body Sem_Res is *** 1883,1890 **** -- of the arguments is Any_Type, and if so, suppress -- the message, since it is a cascaded error. ! if Nkind (N) = N_Function_Call ! or else Nkind (N) = N_Procedure_Call_Statement then declare A : Node_Id; --- 1941,1948 ---- -- of the arguments is Any_Type, and if so, suppress -- the message, since it is a cascaded error. ! if Nkind_In (N, N_Function_Call, ! N_Procedure_Call_Statement) then declare A : Node_Id; *************** package body Sem_Res is *** 2053,2066 **** -- with a name that is an explicit dereference, there is -- nothing to be done at this point. ! elsif Nkind (N) = N_Explicit_Dereference ! or else Nkind (N) = N_Attribute_Reference ! or else Nkind (N) = N_And_Then ! or else Nkind (N) = N_Indexed_Component ! or else Nkind (N) = N_Or_Else ! or else Nkind (N) = N_Range ! or else Nkind (N) = N_Selected_Component ! or else Nkind (N) = N_Slice or else Nkind (Name (N)) = N_Explicit_Dereference then null; --- 2111,2124 ---- -- with a name that is an explicit dereference, there is -- nothing to be done at this point. ! elsif Nkind_In (N, N_Explicit_Dereference, ! N_Attribute_Reference, ! N_And_Then, ! N_Indexed_Component, ! N_Or_Else, ! N_Range, ! N_Selected_Component, ! N_Slice) or else Nkind (Name (N)) = N_Explicit_Dereference then null; *************** package body Sem_Res is *** 2068,2075 **** -- For procedure or function calls, set the type of the name, -- and also the entity pointer for the prefix ! elsif (Nkind (N) = N_Procedure_Call_Statement ! or else Nkind (N) = N_Function_Call) and then (Is_Entity_Name (Name (N)) or else Nkind (Name (N)) = N_Operator_Symbol) then --- 2126,2132 ---- -- For procedure or function calls, set the type of the name, -- and also the entity pointer for the prefix ! elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) and then (Is_Entity_Name (Name (N)) or else Nkind (Name (N)) = N_Operator_Symbol) then *************** package body Sem_Res is *** 2353,2359 **** end if; end if; ! -- A user-defined operator is tranformed into a function call at -- this point, so that further processing knows that operators are -- really operators (i.e. are predefined operators). User-defined -- operators that are intrinsic are just renamings of the predefined --- 2410,2416 ---- end if; end if; ! -- A user-defined operator is transformed into a function call at -- this point, so that further processing knows that operators are -- really operators (i.e. are predefined operators). User-defined -- operators that are intrinsic are just renamings of the predefined *************** package body Sem_Res is *** 2372,2379 **** elsif Present (Alias (Entity (N))) and then ! Nkind (Parent (Parent (Entity (N)))) ! = N_Subprogram_Renaming_Declaration then Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ); --- 2429,2436 ---- elsif Present (Alias (Entity (N))) and then ! Nkind (Parent (Parent (Entity (N)))) = ! N_Subprogram_Renaming_Declaration then Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ); *************** package body Sem_Res is *** 2587,2592 **** --- 2644,2654 ---- Prev : Node_Id := Empty; Orig_A : Node_Id; + procedure Check_Argument_Order; + -- Performs a check for the case where the actuals are all simple + -- identifiers that correspond to the formal names, but in the wrong + -- order, which is considered suspicious and cause for a warning. + procedure Check_Prefixed_Call; -- If the original node is an overloaded call in prefix notation, -- insert an 'Access or a dereference as needed over the first actual. *************** package body Sem_Res is *** 2604,2609 **** --- 2666,2784 ---- -- common type. Used to enforce the restrictions on array conversions -- of AI95-00246. + -------------------------- + -- Check_Argument_Order -- + -------------------------- + + procedure Check_Argument_Order is + begin + -- Nothing to do if no parameters, or original node is neither a + -- function call nor a procedure call statement (happens in the + -- operator-transformed-to-function call case), or the call does + -- not come from source, or this warning is off. + + if not Warn_On_Parameter_Order + or else + No (Parameter_Associations (N)) + or else + not Nkind_In (Original_Node (N), N_Procedure_Call_Statement, + N_Function_Call) + or else + not Comes_From_Source (N) + then + return; + end if; + + declare + Nargs : constant Nat := List_Length (Parameter_Associations (N)); + + begin + -- Nothing to do if only one parameter + + if Nargs < 2 then + return; + end if; + + -- Here if at least two arguments + + declare + Actuals : array (1 .. Nargs) of Node_Id; + Actual : Node_Id; + Formal : Node_Id; + + Wrong_Order : Boolean := False; + -- Set True if an out of order case is found + + begin + -- Collect identifier names of actuals, fail if any actual is + -- not a simple identifier, and record max length of name. + + Actual := First (Parameter_Associations (N)); + for J in Actuals'Range loop + if Nkind (Actual) /= N_Identifier then + return; + else + Actuals (J) := Actual; + Next (Actual); + end if; + end loop; + + -- If we got this far, all actuals are identifiers and the list + -- of their names is stored in the Actuals array. + + Formal := First_Formal (Nam); + for J in Actuals'Range loop + + -- If we ran out of formals, that's odd, probably an error + -- which will be detected elsewhere, but abandon the search. + + if No (Formal) then + return; + end if; + + -- If name matches and is in order OK + + if Chars (Formal) = Chars (Actuals (J)) then + null; + + else + -- If no match, see if it is elsewhere in list and if so + -- flag potential wrong order if type is compatible. + + for K in Actuals'Range loop + if Chars (Formal) = Chars (Actuals (K)) + and then + Has_Compatible_Type (Actuals (K), Etype (Formal)) + then + Wrong_Order := True; + goto Continue; + end if; + end loop; + + -- No match + + return; + end if; + + <> Next_Formal (Formal); + end loop; + + -- If Formals left over, also probably an error, skip warning + + if Present (Formal) then + return; + end if; + + -- Here we give the warning if something was out of order + + if Wrong_Order then + Error_Msg_N + ("actuals for this call may be in wrong order?", N); + end if; + end; + end; + end Check_Argument_Order; + ------------------------- -- Check_Prefixed_Call -- ------------------------- *************** package body Sem_Res is *** 2717,2723 **** Set_Parent (Actval, N); -- Resolve aggregates with their base type, to avoid scope ! -- anomalies: the subtype was first built in the suprogram -- declaration, and the current call may be nested. if Nkind (Actval) = N_Aggregate --- 2892,2898 ---- Set_Parent (Actval, N); -- Resolve aggregates with their base type, to avoid scope ! -- anomalies: the subtype was first built in the subprogram -- declaration, and the current call may be nested. if Nkind (Actval) = N_Aggregate *************** package body Sem_Res is *** 2840,2845 **** --- 3015,3022 ---- -- Start of processing for Resolve_Actuals begin + Check_Argument_Order; + if Present (First_Actual (N)) then Check_Prefixed_Call; end if; *************** package body Sem_Res is *** 2863,2869 **** -- Case where actual is present ! -- If the actual is an entity, generate a reference to it now. We -- do this before the actual is resolved, because a formal of some -- protected subprogram, or a task discriminant, will be rewritten -- during expansion, and the reference to the source entity may --- 3040,3046 ---- -- Case where actual is present ! -- If the actual is an entity, generate a reference to it now. We -- do this before the actual is resolved, because a formal of some -- protected subprogram, or a task discriminant, will be rewritten -- during expansion, and the reference to the source entity may *************** package body Sem_Res is *** 2880,2886 **** and then Ekind (F) /= E_In_Parameter then Generate_Reference (Orig_A, A, 'm'); - elsif not Is_Overloaded (A) then Generate_Reference (Orig_A, A); end if; --- 3057,3062 ---- *************** package body Sem_Res is *** 2892,2897 **** --- 3068,3081 ---- or else Chars (Selector_Name (Parent (A))) = Chars (F)) then + -- If style checking mode on, check match of formal name + + if Style_Check then + if Nkind (Parent (A)) = N_Parameter_Association then + Check_Identifier (Selector_Name (Parent (A)), F); + end if; + end if; + -- If the formal is Out or In_Out, do not resolve and expand the -- conversion, because it is subsequently expanded into explicit -- temporaries and assignments. However, the object of the *************** package body Sem_Res is *** 2915,2946 **** if Has_Aliased_Components (Etype (Expression (A))) /= Has_Aliased_Components (Etype (F)) then - if Ada_Version < Ada_05 then - Error_Msg_N - ("both component types in a view conversion must be" - & " aliased, or neither", A); ! -- Ada 2005: rule is relaxed (see AI-363) ! elsif Has_Aliased_Components (Etype (F)) ! and then ! not Has_Aliased_Components (Etype (Expression (A))) then Error_Msg_N ! ("view conversion operand must have aliased " & ! "components", N); ! Error_Msg_N ! ("\since target type has aliased components", N); end if; - - elsif not Same_Ancestor (Etype (F), Etype (Expression (A))) - and then - (Is_By_Reference_Type (Etype (F)) - or else Is_By_Reference_Type (Etype (Expression (A)))) - then - Error_Msg_N - ("view conversion between unrelated by reference " & - "array types not allowed (\'A'I-00246)", A); end if; end if; --- 3099,3149 ---- if Has_Aliased_Components (Etype (Expression (A))) /= Has_Aliased_Components (Etype (F)) then ! -- In a view conversion, the conversion must be legal in ! -- both directions, and thus both component types must be ! -- aliased, or neither (4.6 (8)). ! -- The additional rule 4.6 (24.9.2) seems unduly ! -- restrictive: the privacy requirement should not ! -- apply to generic types, and should be checked in ! -- an instance. ARG query is in order. ! ! Error_Msg_N ! ("both component types in a view conversion must be" ! & " aliased, or neither", A); ! ! elsif ! not Same_Ancestor (Etype (F), Etype (Expression (A))) ! then ! if Is_By_Reference_Type (Etype (F)) ! or else Is_By_Reference_Type (Etype (Expression (A))) then Error_Msg_N ! ("view conversion between unrelated by reference " & ! "array types not allowed (\'A'I-00246)", A); ! else ! declare ! Comp_Type : constant Entity_Id := ! Component_Type ! (Etype (Expression (A))); ! begin ! if Comes_From_Source (A) ! and then Ada_Version >= Ada_05 ! and then ! ((Is_Private_Type (Comp_Type) ! and then not Is_Generic_Type (Comp_Type)) ! or else Is_Tagged_Type (Comp_Type) ! or else Is_Volatile (Comp_Type)) ! then ! Error_Msg_N ! ("component type of a view conversion cannot" ! & " be private, tagged, or volatile" ! & " (RM 4.6 (24))", ! Expression (A)); ! end if; ! end; end if; end if; end if; *************** package body Sem_Res is *** 2998,3011 **** declare DDT : constant Entity_Id := Directly_Designated_Type (Base_Type (Etype (F))); New_Itype : Entity_Id; begin if Is_Class_Wide_Type (DDT) and then Is_Interface (DDT) then New_Itype := Create_Itype (E_Anonymous_Access_Type, A); ! Set_Etype (New_Itype, Etype (A)); ! Init_Size_Align (New_Itype); Set_Directly_Designated_Type (New_Itype, Directly_Designated_Type (Etype (A))); Set_Etype (A, New_Itype); --- 3201,3215 ---- declare DDT : constant Entity_Id := Directly_Designated_Type (Base_Type (Etype (F))); + New_Itype : Entity_Id; + begin if Is_Class_Wide_Type (DDT) and then Is_Interface (DDT) then New_Itype := Create_Itype (E_Anonymous_Access_Type, A); ! Set_Etype (New_Itype, Etype (A)); Set_Directly_Designated_Type (New_Itype, Directly_Designated_Type (Etype (A))); Set_Etype (A, New_Itype); *************** package body Sem_Res is *** 3017,3024 **** -- enabled only, otherwise the transient scope will not -- be removed in the expansion of the wrapped construct. ! if (Is_Controlled (DDT) ! or else Has_Task (DDT)) and then Expander_Active then Establish_Transient_Scope (A, False); --- 3221,3227 ---- -- enabled only, otherwise the transient scope will not -- be removed in the expansion of the wrapped construct. ! if (Is_Controlled (DDT) or else Has_Task (DDT)) and then Expander_Active then Establish_Transient_Scope (A, False); *************** package body Sem_Res is *** 3030,3050 **** -- a tagged synchronized type, declared outside of the type. -- In this case the controlling actual must be converted to -- its corresponding record type, which is the formal type. ! if Is_Concurrent_Type (Etype (A)) ! and then Etype (F) = Corresponding_Record_Type (Etype (A)) ! then ! Rewrite (A, ! Unchecked_Convert_To ! (Corresponding_Record_Type (Etype (A)), A)); ! end if; ! Resolve (A, Etype (F)); end if; A_Typ := Etype (A); F_Typ := Etype (F); -- Perform error checks for IN and IN OUT parameters if Ekind (F) /= E_Out_Parameter then --- 3233,3304 ---- -- a tagged synchronized type, declared outside of the type. -- In this case the controlling actual must be converted to -- its corresponding record type, which is the formal type. + -- The actual may be a subtype, either because of a constraint + -- or because it is a generic actual, so use base type to + -- locate concurrent type. ! A_Typ := Base_Type (Etype (A)); ! F_Typ := Base_Type (Etype (F)); ! declare ! Full_A_Typ : Entity_Id; ! ! begin ! if Present (Full_View (A_Typ)) then ! Full_A_Typ := Base_Type (Full_View (A_Typ)); ! else ! Full_A_Typ := A_Typ; ! end if; ! ! -- Tagged synchronized type (case 1): the actual is a ! -- concurrent type ! ! if Is_Concurrent_Type (A_Typ) ! and then Corresponding_Record_Type (A_Typ) = F_Typ ! then ! Rewrite (A, ! Unchecked_Convert_To ! (Corresponding_Record_Type (A_Typ), A)); ! Resolve (A, Etype (F)); ! ! -- Tagged synchronized type (case 2): the formal is a ! -- concurrent type ! ! elsif Ekind (Full_A_Typ) = E_Record_Type ! and then Present ! (Corresponding_Concurrent_Type (Full_A_Typ)) ! and then Is_Concurrent_Type (F_Typ) ! and then Present (Corresponding_Record_Type (F_Typ)) ! and then Full_A_Typ = Corresponding_Record_Type (F_Typ) ! then ! Resolve (A, Corresponding_Record_Type (F_Typ)); ! ! -- Common case ! ! else ! Resolve (A, Etype (F)); ! end if; ! end; end if; A_Typ := Etype (A); F_Typ := Etype (F); + -- For mode IN, if actual is an entity, and the type of the formal + -- has warnings suppressed, then we reset Never_Set_In_Source for + -- the calling entity. The reason for this is to catch cases like + -- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram + -- uses trickery to modify an IN parameter. + + if Ekind (F) = E_In_Parameter + and then Is_Entity_Name (A) + and then Present (Entity (A)) + and then Ekind (Entity (A)) = E_Variable + and then Has_Warnings_Off (F_Typ) + then + Set_Never_Set_In_Source (Entity (A), False); + end if; + -- Perform error checks for IN and IN OUT parameters if Ekind (F) /= E_Out_Parameter then *************** package body Sem_Res is *** 3089,3102 **** if Ekind (F) /= E_In_Parameter then -- For an Out parameter, check for useless assignment. Note ! -- that we can't set Last_Assignment this early, because we ! -- may kill current values in Resolve_Call, and that call ! -- would clobber the Last_Assignment field. ! -- Note: call Warn_On_Useless_Assignment before doing the ! -- check below for Is_OK_Variable_For_Out_Formal so that the ! -- setting of Referenced_As_LHS/Referenced_As_Out_Formal ! -- properly reflects the last assignment, not this one! if Ekind (F) = E_Out_Parameter then if Warn_On_Modified_As_Out_Parameter (F) --- 3343,3356 ---- if Ekind (F) /= E_In_Parameter then -- For an Out parameter, check for useless assignment. Note ! -- that we can't set Last_Assignment this early, because we may ! -- kill current values in Resolve_Call, and that call would ! -- clobber the Last_Assignment field. ! -- Note: call Warn_On_Useless_Assignment before doing the check ! -- below for Is_OK_Variable_For_Out_Formal so that the setting ! -- of Referenced_As_LHS/Referenced_As_Out_Formal properly ! -- reflects the last assignment, not this one! if Ekind (F) = E_Out_Parameter then if Warn_On_Modified_As_Out_Parameter (F) *************** package body Sem_Res is *** 3217,3224 **** end if; -- An actual associated with an access parameter is implicitly ! -- converted to the anonymous access type of the formal and ! -- must satisfy the legality checks for access conversions. if Ekind (F_Typ) = E_Anonymous_Access_Type then if not Valid_Conversion (A, F_Typ, A) then --- 3471,3478 ---- end if; -- An actual associated with an access parameter is implicitly ! -- converted to the anonymous access type of the formal and must ! -- satisfy the legality checks for access conversions. if Ekind (F_Typ) = E_Anonymous_Access_Type then if not Valid_Conversion (A, F_Typ, A) then *************** package body Sem_Res is *** 3386,3392 **** -- 1) Analyze Top_Record -- 2) Analyze Level_1_Coextension -- 3) Analyze Level_2_Coextension ! -- 4) Resolve Level_2_Coextnesion. The allocator is marked as a -- coextension. -- 5) Expand Level_2_Coextension. A temporary variable Temp_1 is -- generated to capture the allocated object. Temp_1 is attached --- 3640,3646 ---- -- 1) Analyze Top_Record -- 2) Analyze Level_1_Coextension -- 3) Analyze Level_2_Coextension ! -- 4) Resolve Level_2_Coextension. The allocator is marked as a -- coextension. -- 5) Expand Level_2_Coextension. A temporary variable Temp_1 is -- generated to capture the allocated object. Temp_1 is attached *************** package body Sem_Res is *** 3459,3466 **** function In_Dispatching_Context return Boolean is Par : constant Node_Id := Parent (N); begin ! return (Nkind (Par) = N_Function_Call ! or else Nkind (Par) = N_Procedure_Call_Statement) and then Is_Entity_Name (Name (Par)) and then Is_Dispatching_Operation (Entity (Name (Par))); end In_Dispatching_Context; --- 3713,3719 ---- function In_Dispatching_Context return Boolean is Par : constant Node_Id := Parent (N); begin ! return Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement) and then Is_Entity_Name (Name (Par)) and then Is_Dispatching_Operation (Entity (Name (Par))); end In_Dispatching_Context; *************** package body Sem_Res is *** 3477,3483 **** function Process_Allocator (Nod : Node_Id) return Traverse_Result; -- Recognize an allocator or a rewritten allocator node and add it ! -- allong with its nested coextensions to the list of Root. --------------- -- Copy_List -- --- 3730,3736 ---- function Process_Allocator (Nod : Node_Id) return Traverse_Result; -- Recognize an allocator or a rewritten allocator node and add it ! -- along with its nested coextensions to the list of Root. --------------- -- Copy_List -- *************** package body Sem_Res is *** 3635,3641 **** -- A special accessibility check is needed for allocators that -- constrain access discriminants. The level of the type of the -- expression used to constrain an access discriminant cannot be ! -- deeper than the type of the allocator (in constrast to access -- parameters, where the level of the actual can be arbitrary). -- We can't use Valid_Conversion to perform this check because --- 3888,3894 ---- -- A special accessibility check is needed for allocators that -- constrain access discriminants. The level of the type of the -- expression used to constrain an access discriminant cannot be ! -- deeper than the type of the allocator (in contrast to access -- parameters, where the level of the actual can be arbitrary). -- We can't use Valid_Conversion to perform this check because *************** package body Sem_Res is *** 3650,3659 **** Aggr := Original_Node (Expression (E)); if Has_Discriminants (Subtyp) ! and then ! (Nkind (Aggr) = N_Aggregate ! or else ! Nkind (Aggr) = N_Extension_Aggregate) then Discrim := First_Discriminant (Base_Type (Subtyp)); --- 3903,3909 ---- Aggr := Original_Node (Expression (E)); if Has_Discriminants (Subtyp) ! and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate) then Discrim := First_Discriminant (Base_Type (Subtyp)); *************** package body Sem_Res is *** 3717,3723 **** -- A special accessibility check is needed for allocators that -- constrain access discriminants. The level of the type of the -- expression used to constrain an access discriminant cannot be ! -- deeper than the type of the allocator (in constrast to access -- parameters, where the level of the actual can be arbitrary). -- We can't use Valid_Conversion to perform this check because -- in general the type of the allocator is unrelated to the type --- 3967,3973 ---- -- A special accessibility check is needed for allocators that -- constrain access discriminants. The level of the type of the -- expression used to constrain an access discriminant cannot be ! -- deeper than the type of the allocator (in contrast to access -- parameters, where the level of the actual can be arbitrary). -- We can't use Valid_Conversion to perform this check because -- in general the type of the allocator is unrelated to the type *************** package body Sem_Res is *** 3897,3914 **** -- N is the expression after "delta" in a fixed_point_definition; -- see RM-3.5.9(6): ! return Nkind (Parent (N)) = N_Ordinary_Fixed_Point_Definition ! or else Nkind (Parent (N)) = N_Decimal_Fixed_Point_Definition -- N is one of the bounds in a real_range_specification; -- see RM-3.5.7(5): ! or else Nkind (Parent (N)) = N_Real_Range_Specification -- N is the expression of a delta_constraint; -- see RM-J.3(3): ! or else Nkind (Parent (N)) = N_Delta_Constraint; end Expected_Type_Is_Any_Real; ----------------------------- --- 4147,4164 ---- -- N is the expression after "delta" in a fixed_point_definition; -- see RM-3.5.9(6): ! return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition, ! N_Decimal_Fixed_Point_Definition, -- N is one of the bounds in a real_range_specification; -- see RM-3.5.7(5): ! N_Real_Range_Specification, -- N is the expression of a delta_constraint; -- see RM-J.3(3): ! N_Delta_Constraint); end Expected_Type_Is_Any_Real; ----------------------------- *************** package body Sem_Res is *** 4102,4109 **** -- conversion to a specific fixed-point type (instead the expander -- takes care of the case). ! elsif (B_Typ = Universal_Integer ! or else B_Typ = Universal_Real) and then Present (Universal_Interpretation (L)) and then Present (Universal_Interpretation (R)) then --- 4352,4358 ---- -- conversion to a specific fixed-point type (instead the expander -- takes care of the case). ! elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real) and then Present (Universal_Interpretation (L)) and then Present (Universal_Interpretation (R)) then *************** package body Sem_Res is *** 4112,4126 **** Set_Etype (N, B_Typ); elsif (B_Typ = Universal_Real ! or else Etype (N) = Universal_Fixed ! or else (Etype (N) = Any_Fixed ! and then Is_Fixed_Point_Type (B_Typ)) ! or else (Is_Fixed_Point_Type (B_Typ) ! and then (Is_Integer_Or_Universal (L) ! or else ! Is_Integer_Or_Universal (R)))) ! and then (Nkind (N) = N_Op_Multiply or else ! Nkind (N) = N_Op_Divide) then if TL = Universal_Integer or else TR = Universal_Integer then Check_For_Visible_Operator (N, B_Typ); --- 4361,4374 ---- Set_Etype (N, B_Typ); elsif (B_Typ = Universal_Real ! or else Etype (N) = Universal_Fixed ! or else (Etype (N) = Any_Fixed ! and then Is_Fixed_Point_Type (B_Typ)) ! or else (Is_Fixed_Point_Type (B_Typ) ! and then (Is_Integer_Or_Universal (L) ! or else ! Is_Integer_Or_Universal (R)))) ! and then Nkind_In (N, N_Op_Multiply, N_Op_Divide) then if TL = Universal_Integer or else TR = Universal_Integer then Check_For_Visible_Operator (N, B_Typ); *************** package body Sem_Res is *** 4148,4185 **** Set_Mixed_Mode_Operand (R, TL); end if; ! -- Check the rule in RM05-4.5.5(19.1/2) disallowing the ! -- universal_fixed multiplying operators from being used when the ! -- expected type is also universal_fixed. Note that B_Typ will be ! -- Universal_Fixed in some cases where the expected type is actually ! -- Any_Real; Expected_Type_Is_Any_Real takes care of that case. if Etype (N) = Universal_Fixed or else Etype (N) = Any_Fixed then if B_Typ = Universal_Fixed and then not Expected_Type_Is_Any_Real (N) ! and then Nkind (Parent (N)) /= N_Type_Conversion ! and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion then ! Error_Msg_N ! ("type cannot be determined from context!", N); ! Error_Msg_N ! ("\explicit conversion to result type required", N); Set_Etype (L, Any_Type); Set_Etype (R, Any_Type); else if Ada_Version = Ada_83 ! and then Etype (N) = Universal_Fixed ! and then Nkind (Parent (N)) /= N_Type_Conversion ! and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion then Error_Msg_N ! ("(Ada 83) fixed-point operation " & ! "needs explicit conversion", ! N); end if; -- The expected type is "any real type" in contexts like --- 4396,4431 ---- Set_Mixed_Mode_Operand (R, TL); end if; ! -- Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed ! -- multiplying operators from being used when the expected type is ! -- also universal_fixed. Note that B_Typ will be Universal_Fixed in ! -- some cases where the expected type is actually Any_Real; ! -- Expected_Type_Is_Any_Real takes care of that case. if Etype (N) = Universal_Fixed or else Etype (N) = Any_Fixed then if B_Typ = Universal_Fixed and then not Expected_Type_Is_Any_Real (N) ! and then not Nkind_In (Parent (N), N_Type_Conversion, ! N_Unchecked_Type_Conversion) then ! Error_Msg_N ("type cannot be determined from context!", N); ! Error_Msg_N ("\explicit conversion to result type required", N); Set_Etype (L, Any_Type); Set_Etype (R, Any_Type); else if Ada_Version = Ada_83 ! and then Etype (N) = Universal_Fixed ! and then not ! Nkind_In (Parent (N), N_Type_Conversion, ! N_Unchecked_Type_Conversion) then Error_Msg_N ! ("(Ada 83) fixed-point operation " ! & "needs explicit conversion", N); end if; -- The expected type is "any real type" in contexts like *************** package body Sem_Res is *** 4198,4205 **** and then (Is_Integer_Or_Universal (L) or else Nkind (L) = N_Real_Literal or else Nkind (R) = N_Real_Literal ! or else ! Is_Integer_Or_Universal (R)) then Set_Etype (N, B_Typ); --- 4444,4450 ---- and then (Is_Integer_Or_Universal (L) or else Nkind (L) = N_Real_Literal or else Nkind (R) = N_Real_Literal ! or else Is_Integer_Or_Universal (R)) then Set_Etype (N, B_Typ); *************** package body Sem_Res is *** 4213,4219 **** else if (TL = Universal_Integer or else TL = Universal_Real) ! and then (TR = Universal_Integer or else TR = Universal_Real) then Check_For_Visible_Operator (N, B_Typ); end if; --- 4458,4465 ---- else if (TL = Universal_Integer or else TL = Universal_Real) ! and then ! (TR = Universal_Integer or else TR = Universal_Real) then Check_For_Visible_Operator (N, B_Typ); end if; *************** package body Sem_Res is *** 4222,4230 **** -- universal fixed, this is an error, unless there is only one -- applicable fixed_point type (usually duration). ! if B_Typ = Universal_Fixed ! and then Etype (L) = Universal_Fixed ! then T := Unique_Fixed_Point_Type (N); if T = Any_Type then --- 4468,4474 ---- -- universal fixed, this is an error, unless there is only one -- applicable fixed_point type (usually duration). ! if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then T := Unique_Fixed_Point_Type (N); if T = Any_Type then *************** package body Sem_Res is *** 4265,4283 **** -- Give warning if explicit division by zero ! if (Nkind (N) = N_Op_Divide ! or else Nkind (N) = N_Op_Rem ! or else Nkind (N) = N_Op_Mod) and then not Division_Checks_Suppressed (Etype (N)) then Rop := Right_Opnd (N); if Compile_Time_Known_Value (Rop) and then ((Is_Integer_Type (Etype (Rop)) ! and then Expr_Value (Rop) = Uint_0) or else (Is_Real_Type (Etype (Rop)) ! and then Expr_Value_R (Rop) = Ureal_0)) then -- Specialize the warning message according to the operation --- 4509,4525 ---- -- Give warning if explicit division by zero ! if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod) and then not Division_Checks_Suppressed (Etype (N)) then Rop := Right_Opnd (N); if Compile_Time_Known_Value (Rop) and then ((Is_Integer_Type (Etype (Rop)) ! and then Expr_Value (Rop) = Uint_0) or else (Is_Real_Type (Etype (Rop)) ! and then Expr_Value_R (Rop) = Ureal_0)) then -- Specialize the warning message according to the operation *************** package body Sem_Res is *** 4310,4315 **** --- 4552,4589 ---- Activate_Division_Check (N); end if; end if; + + -- If Restriction No_Implicit_Conditionals is active, then it is + -- violated if either operand can be negative for mod, or for rem + -- if both operands can be negative. + + if Restrictions.Set (No_Implicit_Conditionals) + and then Nkind_In (N, N_Op_Rem, N_Op_Mod) + then + declare + Lo : Uint; + Hi : Uint; + OK : Boolean; + + LNeg : Boolean; + RNeg : Boolean; + -- Set if corresponding operand might be negative + + begin + Determine_Range (Left_Opnd (N), OK, Lo, Hi); + LNeg := (not OK) or else Lo < 0; + + Determine_Range (Right_Opnd (N), OK, Lo, Hi); + RNeg := (not OK) or else Lo < 0; + + if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg)) + or else + (Nkind (N) = N_Op_Mod and then (LNeg or RNeg)) + then + Check_Restriction (No_Implicit_Conditionals, N); + end if; + end; + end if; end if; Check_Unset_Reference (L); *************** package body Sem_Res is *** 4385,4392 **** -- operations use the same circuitry because the name in the call -- can be an arbitrary expression with special resolution rules. ! elsif Nkind (Subp) = N_Selected_Component ! or else Nkind (Subp) = N_Indexed_Component or else (Is_Entity_Name (Subp) and then Ekind (Entity (Subp)) = E_Entry) then --- 4659,4665 ---- -- operations use the same circuitry because the name in the call -- can be an arbitrary expression with special resolution rules. ! elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component) or else (Is_Entity_Name (Subp) and then Ekind (Entity (Subp)) = E_Entry) then *************** package body Sem_Res is *** 4423,4428 **** --- 4696,4721 ---- end loop; end if; + if Is_Access_Subprogram_Type (Base_Type (Etype (Nam))) + and then not Is_Access_Subprogram_Type (Base_Type (Typ)) + and then Nkind (Subp) /= N_Explicit_Dereference + and then Present (Parameter_Associations (N)) + then + -- The prefix is a parameterless function call that returns an access + -- to subprogram. If parameters are present in the current call, add + -- add an explicit dereference. We use the base type here because + -- within an instance these may be subtypes. + + -- The dereference is added either in Analyze_Call or here. Should + -- be consolidated ??? + + Set_Is_Overloaded (Subp, False); + Set_Etype (Subp, Etype (Nam)); + Insert_Explicit_Dereference (Subp); + Nam := Designated_Type (Etype (Nam)); + Resolve (Subp, Nam); + end if; + -- Check that a call to Current_Task does not occur in an entry body if Is_RTE (Nam, RE_Current_Task) then *************** package body Sem_Res is *** 4433,4443 **** P := N; loop P := Parent (P); ! exit when No (P); if Nkind (P) = N_Entry_Body or else (Nkind (P) = N_Subprogram_Body ! and then Is_Entry_Barrier_Function (P)) then Rtype := Etype (N); Error_Msg_NE --- 4726,4741 ---- P := N; loop P := Parent (P); ! ! -- Exclude calls that occur within the default of a formal ! -- parameter of the entry, since those are evaluated outside ! -- of the body. ! ! exit when No (P) or else Nkind (P) = N_Parameter_Specification; if Nkind (P) = N_Entry_Body or else (Nkind (P) = N_Subprogram_Body ! and then Is_Entry_Barrier_Function (P)) then Rtype := Etype (N); Error_Msg_NE *************** package body Sem_Res is *** 4471,4478 **** Error_Msg_N ("entry call required in select statement", N); -- Ada 2005 (AI-345): If a procedure_call_statement is used ! -- for a procedure_or_entry_call, the procedure_name or pro- ! -- cedure_prefix of the procedure_call_statement shall denote -- an entry renamed by a procedure, or (a view of) a primitive -- subprogram of a limited interface whose first parameter is -- a controlling parameter. --- 4769,4776 ---- Error_Msg_N ("entry call required in select statement", N); -- Ada 2005 (AI-345): If a procedure_call_statement is used ! -- for a procedure_or_entry_call, the procedure_name or ! -- procedure_prefix of the procedure_call_statement shall denote -- an entry renamed by a procedure, or (a view of) a primitive -- subprogram of a limited interface whose first parameter is -- a controlling parameter. *************** package body Sem_Res is *** 4486,4493 **** end if; end if; ! -- Check that this is not a call to a protected procedure or ! -- entry from within a protected function. if Ekind (Current_Scope) = E_Function and then Ekind (Scope (Current_Scope)) = E_Protected_Type --- 4784,4791 ---- end if; end if; ! -- Check that this is not a call to a protected procedure or entry from ! -- within a protected function. if Ekind (Current_Scope) = E_Function and then Ekind (Scope (Current_Scope)) = E_Protected_Type *************** package body Sem_Res is *** 4499,4505 **** Error_Msg_N ("\cannot call operation that may modify it", N); end if; ! -- Freeze the subprogram name if not in default expression. Note that we -- freeze procedure calls as well as function calls. Procedure calls are -- not frozen according to the rules (RM 13.14(14)) because it is -- impossible to have a procedure call to a non-frozen procedure in pure --- 4797,4803 ---- Error_Msg_N ("\cannot call operation that may modify it", N); end if; ! -- Freeze the subprogram name if not in a spec-expression. Note that we -- freeze procedure calls as well as function calls. Procedure calls are -- not frozen according to the rules (RM 13.14(14)) because it is -- impossible to have a procedure call to a non-frozen procedure in pure *************** package body Sem_Res is *** 4507,4513 **** -- needs extending because we can generate procedure calls that need -- freezing. ! if Is_Entity_Name (Subp) and then not In_Default_Expression then Freeze_Expression (Subp); end if; --- 4805,4811 ---- -- needs extending because we can generate procedure calls that need -- freezing. ! if Is_Entity_Name (Subp) and then not In_Spec_Expression then Freeze_Expression (Subp); end if; *************** package body Sem_Res is *** 4625,4641 **** if Comes_From_Source (N) then Scop := Current_Scope; if Nam = Scop and then not Restriction_Active (No_Recursion) and then Check_Infinite_Recursion (N) then -- Here we detected and flagged an infinite recursion, so we do ! -- not need to test the case below for further warnings. ! null; ! -- If call is to immediately containing subprogram, then check for ! -- the case of a possible run-time detectable infinite recursion. else Scope_Loop : while Scop /= Standard_Standard loop --- 4923,4945 ---- if Comes_From_Source (N) then Scop := Current_Scope; + -- Issue warning for possible infinite recursion in the absence + -- of the No_Recursion restriction. + if Nam = Scop and then not Restriction_Active (No_Recursion) and then Check_Infinite_Recursion (N) then -- Here we detected and flagged an infinite recursion, so we do ! -- not need to test the case below for further warnings. Also if ! -- we now have a raise SE node, we are all done. ! if Nkind (N) = N_Raise_Storage_Error then ! return; ! end if; ! -- If call is to immediately containing subprogram, then check for ! -- the case of a possible run-time detectable infinite recursion. else Scope_Loop : while Scop /= Standard_Standard loop *************** package body Sem_Res is *** 4756,4767 **** -- If the subprogram is marked Inline_Always, then even if it returns -- an unconstrained type the call does not require use of the secondary ! -- stack. if Is_Inlined (Nam) ! and then Present (First_Rep_Item (Nam)) ! and then Nkind (First_Rep_Item (Nam)) = N_Pragma ! and then Chars (First_Rep_Item (Nam)) = Name_Inline_Always then null; --- 5060,5073 ---- -- If the subprogram is marked Inline_Always, then even if it returns -- an unconstrained type the call does not require use of the secondary ! -- stack. However, inlining will only take place if the body to inline ! -- is already present. It may not be available if e.g. the subprogram is ! -- declared in a child instance. if Is_Inlined (Nam) ! and then Has_Pragma_Inline_Always (Nam) ! and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration ! and then Present (Body_To_Inline (Unit_Declaration_Node (Nam))) then null; *************** package body Sem_Res is *** 4836,4843 **** -- way we still take advantage of the current value information while -- scanning the actuals. ! if (not Is_Library_Level_Entity (Nam) ! or else Suppress_Value_Tracking_On_Call (Current_Scope)) and then (Comes_From_Source (Nam) or else (Present (Alias (Nam)) and then Comes_From_Source (Alias (Nam)))) --- 5142,5155 ---- -- way we still take advantage of the current value information while -- scanning the actuals. ! -- We suppress killing values if we are processing the nodes associated ! -- with N_Freeze_Entity nodes. Otherwise the declaration of a tagged ! -- type kills all the values as part of analyzing the code that ! -- initializes the dispatch tables. ! ! if Inside_Freezing_Actions = 0 ! and then (not Is_Library_Level_Entity (Nam) ! or else Suppress_Value_Tracking_On_Call (Current_Scope)) and then (Comes_From_Source (Nam) or else (Present (Alias (Nam)) and then Comes_From_Source (Alias (Nam)))) *************** package body Sem_Res is *** 4909,4914 **** --- 5221,5239 ---- Check_Intrinsic_Call (N); end if; + -- Check for violation of restriction No_Specific_Termination_Handlers + -- and warn on a potentially blocking call to Abort_Task. + + if Is_RTE (Nam, RE_Set_Specific_Handler) + or else + Is_RTE (Nam, RE_Specific_Handler) + then + Check_Restriction (No_Specific_Termination_Handlers, N); + + elsif Is_RTE (Nam, RE_Abort_Task) then + Check_Potentially_Blocking_Operation (N); + end if; + -- All done, evaluate call and deal with elaboration issues Eval_Call (N); *************** package body Sem_Res is *** 5244,5250 **** and then Comes_From_Source (E) and then No (Constant_Value (E)) and then Is_Frozen (Etype (E)) ! and then not In_Default_Expression and then not Is_Imported (E) then --- 5569,5575 ---- and then Comes_From_Source (E) and then No (Constant_Value (E)) and then Is_Frozen (Etype (E)) ! and then not In_Spec_Expression and then not Is_Imported (E) then *************** package body Sem_Res is *** 5805,5810 **** --- 6130,6136 ---- (Corresponding_Equality (Entity (N))) then Eval_Relational_Op (N); + elsif Nkind (N) = N_Op_Ne and then Is_Abstract_Subprogram (Entity (N)) then *************** package body Sem_Res is *** 6011,6017 **** end if; -- If name was overloaded, set component type correctly now ! -- If a misplaced call to an entry family (which has no index typs) -- return. Error will be diagnosed from calling context. if Is_Array_Type (Array_Type) then --- 6337,6343 ---- end if; -- If name was overloaded, set component type correctly now ! -- If a misplaced call to an entry family (which has no index types) -- return. Error will be diagnosed from calling context. if Is_Array_Type (Array_Type) then *************** package body Sem_Res is *** 6255,6262 **** procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is pragma Warnings (Off, Typ); ! L : constant Node_Id := Left_Opnd (N); ! R : constant Node_Id := Right_Opnd (N); T : Entity_Id; begin --- 6581,6588 ---- procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is pragma Warnings (Off, Typ); ! L : constant Node_Id := Left_Opnd (N); ! R : constant Node_Id := Right_Opnd (N); T : Entity_Id; begin *************** package body Sem_Res is *** 6321,6329 **** ------------------ procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is begin -- Handle restriction against anonymous null access values This ! -- restriction can be turned off using -gnatdh. -- Ada 2005 (AI-231): Remove restriction --- 6647,6657 ---- ------------------ procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + begin -- Handle restriction against anonymous null access values This ! -- restriction can be turned off using -gnatdj. -- Ada 2005 (AI-231): Remove restriction *************** package body Sem_Res is *** 6333,6343 **** and then Comes_From_Source (N) then -- In the common case of a call which uses an explicitly null ! -- value for an access parameter, give specialized error msg ! if Nkind (Parent (N)) = N_Procedure_Call_Statement ! or else ! Nkind (Parent (N)) = N_Function_Call then Error_Msg_N ("null is not allowed as argument for an access parameter", N); --- 6661,6670 ---- and then Comes_From_Source (N) then -- In the common case of a call which uses an explicitly null ! -- value for an access parameter, give specialized error message. ! if Nkind_In (Parent (N), N_Procedure_Call_Statement, ! N_Function_Call) then Error_Msg_N ("null is not allowed as argument for an access parameter", N); *************** package body Sem_Res is *** 6350,6355 **** --- 6677,6702 ---- end if; end if; + -- Ada 2005 (AI-231): Generate the null-excluding check in case of + -- assignment to a null-excluding object + + if Ada_Version >= Ada_05 + and then Can_Never_Be_Null (Typ) + and then Nkind (Parent (N)) = N_Assignment_Statement + then + if not Inside_Init_Proc then + Insert_Action + (Compile_Time_Constraint_Error (N, + "(Ada 2005) null not allowed in null-excluding objects?"), + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)); + else + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)); + end if; + end if; + -- In a distributed context, null for a remote access to subprogram -- may need to be replaced with a special record aggregate. In this -- case, return after having done the transformation. *************** package body Sem_Res is *** 6595,6601 **** B_Typ : constant Entity_Id := Base_Type (Typ); begin ! -- Catch attempts to do fixed-point exponentation with universal -- operands, which is a case where the illegality is not caught during -- normal operator analysis. --- 6942,6948 ---- B_Typ : constant Entity_Id := Base_Type (Typ); begin ! -- Catch attempts to do fixed-point exponentiation with universal -- operands, which is a case where the illegality is not caught during -- normal operator analysis. *************** package body Sem_Res is *** 6702,6708 **** B_Typ := Base_Type (Typ); end if; ! -- Straigtforward case of incorrect arguments if not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid operand type for operator&", N); --- 7049,7055 ---- B_Typ := Base_Type (Typ); end if; ! -- Straightforward case of incorrect arguments if not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid operand type for operator&", N); *************** package body Sem_Res is *** 6738,6743 **** --- 7085,7103 ---- Error_Msg_N ("?not expression should be parenthesized here!", N); end if; + -- Warn on double negation if checking redundant constructs + + if Warn_On_Redundant_Constructs + and then Comes_From_Source (N) + and then Comes_From_Source (Right_Opnd (N)) + and then Root_Type (Typ) = Standard_Boolean + and then Nkind (Right_Opnd (N)) = N_Op_Not + then + Error_Msg_N ("redundant double negation?", N); + end if; + + -- Complete resolution and evaluation of NOT + Resolve (Right_Opnd (N), B_Typ); Check_Unset_Reference (Right_Opnd (N)); Set_Etype (N, B_Typ); *************** package body Sem_Res is *** 6952,6958 **** -- sequences that otherwise fail to notice the modification. if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then ! Note_Possible_Modification (P); end if; end Resolve_Reference; --- 7312,7318 ---- -- sequences that otherwise fail to notice the modification. if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then ! Note_Possible_Modification (P, Sure => False); end if; end Resolve_Reference; *************** package body Sem_Res is *** 7176,7183 **** Resolve (L, B_Typ); Resolve (R, B_Typ); ! -- Check for issuing warning for always False assert, this happens ! -- when assertions are turned off, in which case the pragma Assert -- was transformed into: -- if False and then then ... --- 7536,7543 ---- Resolve (L, B_Typ); Resolve (R, B_Typ); ! -- Check for issuing warning for always False assert/check, this happens ! -- when assertions are turned off, in which case the pragma Assert/Check -- was transformed into: -- if False and then then ... *************** package body Sem_Res is *** 7194,7202 **** then declare Orig : constant Node_Id := Original_Node (Parent (N)); begin if Nkind (Orig) = N_Pragma ! and then Chars (Orig) = Name_Assert then -- Don't want to warn if original condition is explicit False --- 7554,7563 ---- then declare Orig : constant Node_Id := Original_Node (Parent (N)); + begin if Nkind (Orig) = N_Pragma ! and then Pragma_Name (Orig) = Name_Assert then -- Don't want to warn if original condition is explicit False *************** package body Sem_Res is *** 7222,7227 **** --- 7583,7611 ---- Error_Msg_N ("?assertion would fail at run-time", Orig); end if; end; + + -- Similar processing for Check pragma + + elsif Nkind (Orig) = N_Pragma + and then Pragma_Name (Orig) = Name_Check + then + -- Don't want to warn if original condition is explicit False + + declare + Expr : constant Node_Id := + Original_Node + (Expression + (Next (First + (Pragma_Argument_Associations (Orig))))); + begin + if Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_False + then + null; + else + Error_Msg_N ("?check would fail at run-time", Orig); + end if; + end; end if; end; end if; *************** package body Sem_Res is *** 7430,7445 **** elsif Nkind (Parent (N)) = N_Op_Concat and then not Need_Check ! and then Nkind (Original_Node (N)) /= N_Character_Literal ! and then Nkind (Original_Node (N)) /= N_Attribute_Reference ! and then Nkind (Original_Node (N)) /= N_Qualified_Expression ! and then Nkind (Original_Node (N)) /= N_Type_Conversion then Subtype_Id := Typ; -- Otherwise we must create a string literal subtype. Note that the -- whole idea of string literal subtypes is simply to avoid the need -- for building a full fledged array subtype for each literal. else Set_String_Literal_Subtype (N, Typ); Subtype_Id := Etype (N); --- 7814,7830 ---- elsif Nkind (Parent (N)) = N_Op_Concat and then not Need_Check ! and then not Nkind_In (Original_Node (N), N_Character_Literal, ! N_Attribute_Reference, ! N_Qualified_Expression, ! N_Type_Conversion) then Subtype_Id := Typ; -- Otherwise we must create a string literal subtype. Note that the -- whole idea of string literal subtypes is simply to avoid the need -- for building a full fledged array subtype for each literal. + else Set_String_Literal_Subtype (N, Typ); Subtype_Id := Etype (N); *************** package body Sem_Res is *** 7473,7480 **** elsif R_Typ = Any_Character then return; ! -- If the type is bit-packed, then we always tranform the string literal ! -- into a full fledged aggregate. elsif Is_Bit_Packed_Array (Typ) then null; --- 7858,7865 ---- elsif R_Typ = Any_Character then return; ! -- If the type is bit-packed, then we always transform the string ! -- literal into a full fledged aggregate. elsif Is_Bit_Packed_Array (Typ) then null; *************** package body Sem_Res is *** 7560,7569 **** -- corresponding character aggregate and let the aggregate -- code do the checking. ! if R_Typ = Standard_Character ! or else R_Typ = Standard_Wide_Character ! or else R_Typ = Standard_Wide_Wide_Character ! then -- Check for the case of full range, where we are definitely OK if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then --- 7945,7952 ---- -- corresponding character aggregate and let the aggregate -- code do the checking. ! if Is_Standard_Character_Type (R_Typ) then ! -- Check for the case of full range, where we are definitely OK if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then *************** package body Sem_Res is *** 7683,7692 **** Set_Etype (Operand, Universal_Real); elsif Is_Numeric_Type (Typ) ! and then (Nkind (Operand) = N_Op_Multiply ! or else Nkind (Operand) = N_Op_Divide) and then (Etype (Right_Opnd (Operand)) = Universal_Real ! or else Etype (Left_Opnd (Operand)) = Universal_Real) then -- Return if expression is ambiguous --- 8066,8075 ---- Set_Etype (Operand, Universal_Real); elsif Is_Numeric_Type (Typ) ! and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide) and then (Etype (Right_Opnd (Operand)) = Universal_Real ! or else ! Etype (Left_Opnd (Operand)) = Universal_Real) then -- Return if expression is ambiguous *************** package body Sem_Res is *** 7992,8006 **** Rorig := Original_Node (Right_Opnd (Norig)); -- We are looking for cases where the right operand is not ! -- parenthesized, and is a bianry operator, multiply, divide, or -- mod. These are the cases where the grouping can affect results. if Paren_Count (Rorig) = 0 ! and then (Nkind (Rorig) = N_Op_Mod ! or else ! Nkind (Rorig) = N_Op_Multiply ! or else ! Nkind (Rorig) = N_Op_Divide) then -- For mod, we always give the warning, since the value is -- affected by the parenthesization (e.g. (-5) mod 315 /= --- 8375,8385 ---- Rorig := Original_Node (Right_Opnd (Norig)); -- We are looking for cases where the right operand is not ! -- parenthesized, and is a binary operator, multiply, divide, or -- mod. These are the cases where the grouping can affect results. if Paren_Count (Rorig) = 0 ! and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide) then -- For mod, we always give the warning, since the value is -- affected by the parenthesization (e.g. (-5) mod 315 /= *************** package body Sem_Res is *** 8082,8090 **** -- overflow is impossible (divisor > 1) or we have a case of -- division by zero in any case. ! if (Nkind (Rorig) = N_Op_Divide ! or else ! Nkind (Rorig) = N_Op_Rem) and then Compile_Time_Known_Value (Right_Opnd (Rorig)) and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1 then --- 8461,8467 ---- -- overflow is impossible (divisor > 1) or we have a case of -- division by zero in any case. ! if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem) and then Compile_Time_Known_Value (Right_Opnd (Rorig)) and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1 then *************** package body Sem_Res is *** 8287,8293 **** Set_First_Index (Slice_Subtype, Index); Set_Etype (Slice_Subtype, Base_Type (Etype (N))); Set_Is_Constrained (Slice_Subtype, True); - Init_Size_Align (Slice_Subtype); Check_Compile_Time_Size (Slice_Subtype); --- 8664,8669 ---- *************** package body Sem_Res is *** 8302,8308 **** -- call to Check_Compile_Time_Size could be eliminated, which would -- be nice, because then that routine could be made private to Freeze. ! if Is_Packed (Slice_Subtype) and not In_Default_Expression then Freeze_Itype (Slice_Subtype, N); end if; --- 8678,8686 ---- -- call to Check_Compile_Time_Size could be eliminated, which would -- be nice, because then that routine could be made private to Freeze. ! -- Why the test for In_Spec_Expression here ??? ! ! if Is_Packed (Slice_Subtype) and not In_Spec_Expression then Freeze_Itype (Slice_Subtype, N); end if; *************** package body Sem_Res is *** 8388,8394 **** Set_First_Index (Array_Subtype, Index); Set_Etype (Array_Subtype, Base_Type (Typ)); Set_Is_Constrained (Array_Subtype, True); - Init_Size_Align (Array_Subtype); Rewrite (N, Make_Unchecked_Type_Conversion (Loc, --- 8766,8771 ---- *************** package body Sem_Res is *** 8526,8532 **** if Nkind (N) = N_Real_Literal then Error_Msg_NE ("?real literal interpreted as }!", N, T1); - else Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1); end if; --- 8903,8908 ---- *************** package body Sem_Res is *** 8689,8699 **** return False; end if; ! -- Check that component subtypes statically match ! if Is_Constrained (Target_Comp_Type) /= ! Is_Constrained (Opnd_Comp_Type) ! or else not Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) then Error_Msg_N --- 9065,9076 ---- return False; end if; ! -- Check that component subtypes statically match. For numeric ! -- types this means that both must be either constrained or ! -- unconstrained. For enumeration types the bounds must match. ! -- All of this is checked in Subtypes_Statically_Match. ! if not Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) then Error_Msg_N *************** package body Sem_Res is *** 8866,8872 **** -- Also no need to check when in an instance or inlined body, because -- the legality has been established when the template was analyzed. -- Furthermore, numeric conversions may occur where only a private ! -- view of the operand type is visible at the instanciation point. -- This results in a spurious error if we check that the operand type -- is a numeric type. --- 9243,9249 ---- -- Also no need to check when in an instance or inlined body, because -- the legality has been established when the template was analyzed. -- Furthermore, numeric conversions may occur where only a private ! -- view of the operand type is visible at the instantiation point. -- This results in a spurious error if we check that the operand type -- is a numeric type. *************** package body Sem_Res is *** 8946,8952 **** if Nkind (Operand) = N_Selected_Component and then Object_Access_Level (Operand) > ! Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we -- know will fail, so generate an appropriate warning. --- 9323,9329 ---- if Nkind (Operand) = N_Selected_Component and then Object_Access_Level (Operand) > ! Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we -- know will fail, so generate an appropriate warning. *************** package body Sem_Res is *** 8969,8975 **** -- The case of a reference to an access discriminant from -- within a limited type declaration (which will appear as -- a discriminal) is always illegal because the level of the ! -- discriminant is considered to be deeper than any (namable) -- access type. if Is_Entity_Name (Operand) --- 9346,9352 ---- -- The case of a reference to an access discriminant from -- within a limited type declaration (which will appear as -- a discriminal) is always illegal because the level of the ! -- discriminant is considered to be deeper than any (nameable) -- access type. if Is_Entity_Name (Operand) *************** package body Sem_Res is *** 9055,9062 **** -- handles checking the prefix of the operand for this case.) if Nkind (Operand) = N_Selected_Component ! and then Object_Access_Level (Operand) ! > Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we -- know will fail, so generate an appropriate warning. --- 9432,9439 ---- -- handles checking the prefix of the operand for this case.) if Nkind (Operand) = N_Selected_Component ! and then Object_Access_Level (Operand) > ! Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we -- know will fail, so generate an appropriate warning. *************** package body Sem_Res is *** 9081,9087 **** -- The case of a reference to an access discriminant from -- within a limited type declaration (which will appear as -- a discriminal) is always illegal because the level of the ! -- discriminant is considered to be deeper than any (namable) -- access type. if Is_Entity_Name (Operand) --- 9458,9464 ---- -- The case of a reference to an access discriminant from -- within a limited type declaration (which will appear as -- a discriminal) is always illegal because the level of the ! -- discriminant is considered to be deeper than any (nameable) -- access type. if Is_Entity_Name (Operand) *************** package body Sem_Res is *** 9147,9153 **** (not Is_Constrained (Opnd) or else not Is_Constrained (Target))) then ! return True; else Error_Msg_NE --- 9524,9550 ---- (not Is_Constrained (Opnd) or else not Is_Constrained (Target))) then ! -- Special case, if Value_Size has been used to make the ! -- sizes different, the conversion is not allowed even ! -- though the subtypes statically match. ! ! if Known_Static_RM_Size (Target) ! and then Known_Static_RM_Size (Opnd) ! and then RM_Size (Target) /= RM_Size (Opnd) ! then ! Error_Msg_NE ! ("target designated subtype not compatible with }", ! N, Opnd); ! Error_Msg_NE ! ("\because sizes of the two designated subtypes differ", ! N, Opnd); ! return False; ! ! -- Normal case where conversion is allowed ! ! else ! return True; ! end if; else Error_Msg_NE *************** package body Sem_Res is *** 9158,9172 **** end if; end; ! -- Subprogram access types ! elsif (Ekind (Target_Type) = E_Access_Subprogram_Type ! or else ! Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type) and then No (Corresponding_Remote_Type (Opnd_Type)) then ! if ! Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type then Error_Msg_N ("illegal attempt to store anonymous access to subprogram", --- 9555,9577 ---- end if; end; ! -- Access to subprogram types. If the operand is an access parameter, ! -- the type has a deeper accessibility that any master, and cannot ! -- be assigned. We must make an exception if the conversion is part ! -- of an assignment and the target is the return object of an extended ! -- return statement, because in that case the accessibility check ! -- takes place after the return. ! elsif Is_Access_Subprogram_Type (Target_Type) and then No (Corresponding_Remote_Type (Opnd_Type)) then ! if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type ! and then Is_Entity_Name (Operand) ! and then Ekind (Entity (Operand)) = E_In_Parameter ! and then ! (Nkind (Parent (N)) /= N_Assignment_Statement ! or else not Is_Entity_Name (Name (Parent (N))) ! or else not Is_Return_Object (Entity (Name (Parent (N))))) then Error_Msg_N ("illegal attempt to store anonymous access to subprogram", *************** package body Sem_Res is *** 9176,9188 **** "(RM 3.10.2 (13))", Operand); ! if Is_Entity_Name (Operand) ! and then Ekind (Entity (Operand)) = E_In_Parameter ! then ! Error_Msg_NE ! ("\use named access type for& instead of access parameter", ! Operand, Entity (Operand)); ! end if; end if; -- Check that the designated types are subtype conformant --- 9581,9589 ---- "(RM 3.10.2 (13))", Operand); ! Error_Msg_NE ! ("\use named access type for& instead of access parameter", ! Operand, Entity (Operand)); end if; -- Check that the designated types are subtype conformant diff -Nrcpad gcc-4.3.3/gcc/ada/sem_res.ads gcc-4.4.0/gcc/ada/sem_res.ads *** gcc-4.3.3/gcc/ada/sem_res.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sem_res.ads Sun Apr 13 17:41:15 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Sem_Res is *** 103,109 **** -- Several forms of names can denote calls to entities without para- -- meters. The context determines whether the name denotes the entity -- or a call to it. When it is a call, the node must be rebuilt ! -- accordingly and renalyzed to obtain possible interpretations. -- -- The name may be that of an overloadable construct, or it can be an -- explicit dereference of a prefix that denotes an access to subprogram. --- 103,109 ---- -- Several forms of names can denote calls to entities without para- -- meters. The context determines whether the name denotes the entity -- or a call to it. When it is a call, the node must be rebuilt ! -- accordingly and reanalyzed to obtain possible interpretations. -- -- The name may be that of an overloadable construct, or it can be an -- explicit dereference of a prefix that denotes an access to subprogram. *************** package Sem_Res is *** 113,125 **** -- -- The parameter T is the Typ for the corresponding resolve call. ! procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id); ! -- Performs a pre-analysis of expression node N. During pre-analysis -- N is analyzed and then resolved against type T, but no expansion -- is carried out for N or its children. For more info on pre-analysis -- read the spec of Sem. ! procedure Pre_Analyze_And_Resolve (N : Node_Id); -- Same, but use type of node because context does not impose a single type private --- 113,125 ---- -- -- The parameter T is the Typ for the corresponding resolve call. ! procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id); ! -- Performs a pre-analysis of expression node N. During pre-analysis, -- N is analyzed and then resolved against type T, but no expansion -- is carried out for N or its children. For more info on pre-analysis -- read the spec of Sem. ! procedure Preanalyze_And_Resolve (N : Node_Id); -- Same, but use type of node because context does not impose a single type private diff -Nrcpad gcc-4.3.3/gcc/ada/sem_type.adb gcc-4.4.0/gcc/ada/sem_type.adb *** gcc-4.3.3/gcc/ada/sem_type.adb Thu Dec 13 10:32:34 2007 --- gcc-4.4.0/gcc/ada/sem_type.adb Wed Aug 20 12:06:35 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Sem_Ch6; use Sem_Ch6; *** 39,44 **** --- 39,45 ---- with Sem_Ch8; use Sem_Ch8; with Sem_Ch12; use Sem_Ch12; with Sem_Disp; use Sem_Disp; + with Sem_Dist; use Sem_Dist; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; *************** package body Sem_Type is *** 403,412 **** return; end if; ! -- In an instance, an abstract non-dispatching operation cannot ! -- be a candidate interpretation, because it could not have been ! -- one in the generic (it may be a spurious overloading in the ! -- instance). elsif In_Instance and then Is_Overloadable (E) --- 404,412 ---- return; end if; ! -- In an instance, an abstract non-dispatching operation cannot be a ! -- candidate interpretation, because it could not have been one in the ! -- generic (it may be a spurious overloading in the instance). elsif In_Instance and then Is_Overloadable (E) *************** package body Sem_Type is *** 415,427 **** then return; ! -- An inherited interface operation that is implemented by some ! -- derived type does not participate in overload resolution, only ! -- the implementation operation does. elsif Is_Hidden (E) and then Is_Subprogram (E) ! and then Present (Abstract_Interface_Alias (E)) then -- Ada 2005 (AI-251): If this primitive operation corresponds with -- an immediate ancestor interface there is no need to add it to the --- 415,427 ---- then return; ! -- An inherited interface operation that is implemented by some derived ! -- type does not participate in overload resolution, only the ! -- implementation operation does. elsif Is_Hidden (E) and then Is_Subprogram (E) ! and then Present (Interface_Alias (E)) then -- Ada 2005 (AI-251): If this primitive operation corresponds with -- an immediate ancestor interface there is no need to add it to the *************** package body Sem_Type is *** 431,443 **** -- subprograms which are in fact the same. if not Is_Ancestor ! (Find_Dispatching_Type (Abstract_Interface_Alias (E)), Find_Dispatching_Type (E)) then ! Add_One_Interp (N, Abstract_Interface_Alias (E), T); end if; return; end if; -- If this is the first interpretation of N, N has type Any_Type. --- 431,449 ---- -- subprograms which are in fact the same. if not Is_Ancestor ! (Find_Dispatching_Type (Interface_Alias (E)), Find_Dispatching_Type (E)) then ! Add_One_Interp (N, Interface_Alias (E), T); end if; return; + + -- Calling stubs for an RACW operation never participate in resolution, + -- they are executed only through dispatching calls. + + elsif Is_RACW_Stub_Type_Operation (E) then + return; end if; -- If this is the first interpretation of N, N has type Any_Type. *************** package body Sem_Type is *** 681,689 **** if All_Interp.Last = First_Interp + 1 then ! -- The original interpretation is in fact not overloaded Set_Is_Overloaded (N, False); end if; end Collect_Interps; --- 687,701 ---- if All_Interp.Last = First_Interp + 1 then ! -- The final interpretation is in fact not overloaded. Note that the ! -- unique legal interpretation may or may not be the original one, ! -- so we need to update N's entity and etype now, because once N ! -- is marked as not overloaded it is also expected to carry the ! -- proper interpretation. Set_Is_Overloaded (N, False); + Set_Entity (N, All_Interp.Table (First_Interp).Nam); + Set_Etype (N, All_Interp.Table (First_Interp).Typ); end if; end Collect_Interps; *************** package body Sem_Type is *** 754,760 **** if T1 = T2 then return True; ! elsif BT1 = BT2 or else BT1 = T2 or else BT2 = T1 then --- 766,772 ---- if T1 = T2 then return True; ! elsif BT1 = BT2 or else BT1 = T2 or else BT2 = T1 then *************** package body Sem_Type is *** 771,777 **** -- Literals are compatible with types in a given "class" ! elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) or else (T2 = Universal_Real and then Is_Real_Type (T1)) or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) --- 783,789 ---- -- Literals are compatible with types in a given "class" ! elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) or else (T2 = Universal_Real and then Is_Real_Type (T1)) or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) *************** package body Sem_Type is *** 837,845 **** -- Note: test for presence of E is defense against previous error. if Present (E) ! and then Present (Abstract_Interfaces (E)) then ! Elmt := First_Elmt (Abstract_Interfaces (E)); while Present (Elmt) loop if Is_Ancestor (Etype (T1), Node (Elmt)) then return True; --- 849,857 ---- -- Note: test for presence of E is defense against previous error. if Present (E) ! and then Present (Interfaces (E)) then ! Elmt := First_Elmt (Interfaces (E)); while Present (Elmt) loop if Is_Ancestor (Etype (T1), Node (Elmt)) then return True; *************** package body Sem_Type is *** 932,938 **** -- The context can be a remote access type, and the expression the -- corresponding source type declared in a categorized package, or ! -- viceversa. elsif Is_Record_Type (T1) and then (Is_Remote_Call_Interface (T1) --- 944,950 ---- -- The context can be a remote access type, and the expression the -- corresponding source type declared in a categorized package, or ! -- vice versa. elsif Is_Record_Type (T1) and then (Is_Remote_Call_Interface (T1) *************** package body Sem_Type is *** 1020,1026 **** return True; elsif Is_Type (T1) ! and then Is_Generic_Actual_Type (T1) and then Full_View_Covers (T2, T1) then return True; --- 1032,1038 ---- return True; elsif Is_Type (T1) ! and then Is_Generic_Actual_Type (T1) and then Full_View_Covers (T2, T1) then return True; *************** package body Sem_Type is *** 1515,1522 **** end if; -- Check for overloaded CIL convention stuff because the CIL libraries ! -- do sick things like Console.WriteLine where it matches ! -- two different overloads, so just pick the first ??? if Convention (Nam1) = Convention_CIL and then Convention (Nam2) = Convention_CIL --- 1527,1534 ---- end if; -- Check for overloaded CIL convention stuff because the CIL libraries ! -- do sick things like Console.Write_Line where it matches two different ! -- overloads, so just pick the first ??? if Convention (Nam1) = Convention_CIL and then Convention (Nam2) = Convention_CIL *************** package body Sem_Type is *** 2089,2104 **** return Covers (Typ, Etype (N)) ! -- Ada 2005 (AI-345) The context may be a synchronized interface. -- If the type is already frozen use the corresponding_record -- to check whether it is a proper descendant. or else ! (Is_Concurrent_Type (Etype (N)) and then Present (Corresponding_Record_Type (Etype (N))) and then Covers (Typ, Corresponding_Record_Type (Etype (N)))) or else (not Is_Tagged_Type (Typ) and then Ekind (Typ) /= E_Anonymous_Access_Type and then Covers (Etype (N), Typ)); --- 2101,2123 ---- return Covers (Typ, Etype (N)) ! -- Ada 2005 (AI-345): The context may be a synchronized interface. -- If the type is already frozen use the corresponding_record -- to check whether it is a proper descendant. or else ! (Is_Record_Type (Typ) ! and then Is_Concurrent_Type (Etype (N)) and then Present (Corresponding_Record_Type (Etype (N))) and then Covers (Typ, Corresponding_Record_Type (Etype (N)))) or else + (Is_Concurrent_Type (Typ) + and then Is_Record_Type (Etype (N)) + and then Present (Corresponding_Record_Type (Typ)) + and then Covers (Corresponding_Record_Type (Typ), Etype (N))) + + or else (not Is_Tagged_Type (Typ) and then Ekind (Typ) /= E_Anonymous_Access_Type and then Covers (Etype (N), Typ)); *************** package body Sem_Type is *** 2239,2249 **** end if; loop ! if Present (Abstract_Interfaces (E)) ! and then Present (Abstract_Interfaces (E)) ! and then not Is_Empty_Elmt_List (Abstract_Interfaces (E)) then ! Elmt := First_Elmt (Abstract_Interfaces (E)); while Present (Elmt) loop AI := Node (Elmt); --- 2258,2268 ---- end if; loop ! if Present (Interfaces (E)) ! and then Present (Interfaces (E)) ! and then not Is_Empty_Elmt_List (Interfaces (E)) then ! Elmt := First_Elmt (Interfaces (E)); while Present (Elmt) loop AI := Node (Elmt); *************** package body Sem_Type is *** 2322,2328 **** if Etype (AI) = Iface_Typ then return True; ! elsif Present (Abstract_Interfaces (Etype (AI))) and then Iface_Present_In_Ancestor (Etype (AI)) then return True; --- 2341,2347 ---- if Etype (AI) = Iface_Typ then return True; ! elsif Present (Interfaces (Etype (AI))) and then Iface_Present_In_Ancestor (Etype (AI)) then return True; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_util.adb gcc-4.4.0/gcc/ada/sem_util.adb *** gcc-4.3.3/gcc/ada/sem_util.adb Wed Dec 19 16:22:02 2007 --- gcc-4.4.0/gcc/ada/sem_util.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Checks; use Checks; *** 29,34 **** --- 29,35 ---- with Debug; use Debug; with Errout; use Errout; with Elists; use Elists; + with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; *************** with Scans; use Scans; *** 43,49 **** with Scn; use Scn; with Sem; use Sem; with Sem_Attr; use Sem_Attr; - with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; --- 44,49 ---- *************** package body Sem_Util is *** 99,104 **** --- 99,108 ---- Nod := Parent (Base_Type (Typ)); + if Nkind (Nod) = N_Full_Type_Declaration then + return Empty_List; + end if; + elsif Ekind (Typ) = E_Record_Type_With_Private then if Nkind (Parent (Typ)) = N_Full_Type_Declaration then Nod := Type_Definition (Parent (Typ)); *************** package body Sem_Util is *** 205,212 **** Rep : Boolean := True; Warn : Boolean := False) is ! Stat : constant Boolean := Is_Static_Expression (N); ! Rtyp : Entity_Id; begin if No (Typ) then --- 209,218 ---- Rep : Boolean := True; Warn : Boolean := False) is ! Stat : constant Boolean := Is_Static_Expression (N); ! R_Stat : constant Node_Id := ! Make_Raise_Constraint_Error (Sloc (N), Reason => Reason); ! Rtyp : Entity_Id; begin if No (Typ) then *************** package body Sem_Util is *** 225,234 **** -- Now we replace the node by an N_Raise_Constraint_Error node -- This does not need reanalyzing, so set it as analyzed now. ! Rewrite (N, ! Make_Raise_Constraint_Error (Sloc (N), ! Reason => Reason)); Set_Analyzed (N, True); Set_Etype (N, Rtyp); Set_Raises_Constraint_Error (N); --- 231,239 ---- -- Now we replace the node by an N_Raise_Constraint_Error node -- This does not need reanalyzing, so set it as analyzed now. ! Rewrite (N, R_Stat); Set_Analyzed (N, True); + Set_Etype (N, Rtyp); Set_Raises_Constraint_Error (N); *************** package body Sem_Util is *** 486,494 **** -- Start of processing for Build_Actual_Subtype_Of_Component begin ! if In_Default_Expression then return Empty; elsif Nkind (N) = N_Explicit_Dereference then if Is_Composite_Type (T) and then not Is_Constrained (T) --- 491,503 ---- -- Start of processing for Build_Actual_Subtype_Of_Component begin ! -- Why the test for Spec_Expression mode here??? ! ! if In_Spec_Expression then return Empty; + -- More comments for the rest of this body would be good ??? + elsif Nkind (N) = N_Explicit_Dereference then if Is_Composite_Type (T) and then not Is_Constrained (T) *************** package body Sem_Util is *** 1010,1020 **** ("premature usage of incomplete}", N, First_Subtype (T)); end if; elsif Has_Private_Component (T) and then not Is_Generic_Type (Root_Type (T)) ! and then not In_Default_Expression then - -- Special case: if T is the anonymous type created for a single -- task or protected object, use the name of the source object. --- 1019,1030 ---- ("premature usage of incomplete}", N, First_Subtype (T)); end if; + -- Need comments for these tests ??? + elsif Has_Private_Component (T) and then not Is_Generic_Type (Root_Type (T)) ! and then not In_Spec_Expression then -- Special case: if T is the anonymous type created for a single -- task or protected object, use the name of the source object. *************** package body Sem_Util is *** 1045,1050 **** --- 1055,1062 ---- -- Currently only enabled for VM back-ends for efficiency, should we -- enable it more systematically ??? + -- Check for Is_Imported needs commenting below ??? + if VM_Target /= No_VM and then (Ekind (Ent) = E_Variable or else *************** package body Sem_Util is *** 1053,1058 **** --- 1065,1071 ---- Ekind (Ent) = E_Loop_Parameter) and then Scope (Ent) /= Empty and then not Is_Library_Level_Entity (Ent) + and then not Is_Imported (Ent) then if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) *************** package body Sem_Util is *** 1103,1108 **** --- 1116,1232 ---- end loop; end Check_Potentially_Blocking_Operation; + ------------------------------ + -- Check_Unprotected_Access -- + ------------------------------ + + procedure Check_Unprotected_Access + (Context : Node_Id; + Expr : Node_Id) + is + Cont_Encl_Typ : Entity_Id; + Pref_Encl_Typ : Entity_Id; + + function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id; + -- Check whether Obj is a private component of a protected object. + -- Return the protected type where the component resides, Empty + -- otherwise. + + function Is_Public_Operation return Boolean; + -- Verify that the enclosing operation is callable from outside the + -- protected object, to minimize false positives. + + ------------------------------ + -- Enclosing_Protected_Type -- + ------------------------------ + + function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is + begin + if Is_Entity_Name (Obj) then + declare + Ent : Entity_Id := Entity (Obj); + + begin + -- The object can be a renaming of a private component, use + -- the original record component. + + if Is_Prival (Ent) then + Ent := Prival_Link (Ent); + end if; + + if Is_Protected_Type (Scope (Ent)) then + return Scope (Ent); + end if; + end; + end if; + + -- For indexed and selected components, recursively check the prefix + + if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then + return Enclosing_Protected_Type (Prefix (Obj)); + + -- The object does not denote a protected component + + else + return Empty; + end if; + end Enclosing_Protected_Type; + + ------------------------- + -- Is_Public_Operation -- + ------------------------- + + function Is_Public_Operation return Boolean is + S : Entity_Id; + E : Entity_Id; + + begin + S := Current_Scope; + while Present (S) + and then S /= Pref_Encl_Typ + loop + if Scope (S) = Pref_Encl_Typ then + E := First_Entity (Pref_Encl_Typ); + while Present (E) + and then E /= First_Private_Entity (Pref_Encl_Typ) + loop + if E = S then + return True; + end if; + Next_Entity (E); + end loop; + end if; + + S := Scope (S); + end loop; + + return False; + end Is_Public_Operation; + + -- Start of processing for Check_Unprotected_Access + + begin + if Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Unchecked_Access + then + Cont_Encl_Typ := Enclosing_Protected_Type (Context); + Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr)); + + -- Check whether we are trying to export a protected component to a + -- context with an equal or lower access level. + + if Present (Pref_Encl_Typ) + and then No (Cont_Encl_Typ) + and then Is_Public_Operation + and then Scope_Depth (Pref_Encl_Typ) >= + Object_Access_Level (Context) + then + Error_Msg_N + ("?possible unprotected access to protected data", Expr); + end if; + end if; + end Check_Unprotected_Access; + --------------- -- Check_VMS -- --------------- *************** package body Sem_Util is *** 1115,1162 **** end if; end Check_VMS; ! --------------------------------- ! -- Collect_Abstract_Interfaces -- ! --------------------------------- ! procedure Collect_Abstract_Interfaces ! (T : Entity_Id; ! Ifaces_List : out Elist_Id; ! Exclude_Parent_Interfaces : Boolean := False; ! Use_Full_View : Boolean := True) is - procedure Add_Interface (Iface : Entity_Id); - -- Add the interface it if is not already in the list - procedure Collect (Typ : Entity_Id); -- Subsidiary subprogram used to traverse the whole list -- of directly and indirectly implemented interfaces - function Interface_Present_In_Parent - (Typ : Entity_Id; - Iface : Entity_Id) return Boolean; - -- Typ must be a tagged record type/subtype and Iface must be an - -- abstract interface type. This function is used to check if Typ - -- or some parent of Typ implements Iface. - - ------------------- - -- Add_Interface -- - ------------------- - - procedure Add_Interface (Iface : Entity_Id) is - Elmt : Elmt_Id; - - begin - Elmt := First_Elmt (Ifaces_List); - while Present (Elmt) and then Node (Elmt) /= Iface loop - Next_Elmt (Elmt); - end loop; - - if No (Elmt) then - Append_Elmt (Iface, Ifaces_List); - end if; - end Add_Interface; - ------------- -- Collect -- ------------- --- 1239,1258 ---- end if; end Check_VMS; ! ------------------------ ! -- Collect_Interfaces -- ! ------------------------ ! procedure Collect_Interfaces ! (T : Entity_Id; ! Ifaces_List : out Elist_Id; ! Exclude_Parents : Boolean := False; ! Use_Full_View : Boolean := True) is procedure Collect (Typ : Entity_Id); -- Subsidiary subprogram used to traverse the whole list -- of directly and indirectly implemented interfaces ------------- -- Collect -- ------------- *************** package body Sem_Util is *** 1164,1170 **** procedure Collect (Typ : Entity_Id) is Ancestor : Entity_Id; Full_T : Entity_Id; - Iface_List : List_Id; Id : Node_Id; Iface : Entity_Id; --- 1260,1265 ---- *************** package body Sem_Util is *** 1180,1206 **** Full_T := Full_View (Typ); end if; - Iface_List := Abstract_Interface_List (Full_T); - -- Include the ancestor if we are generating the whole list of -- abstract interfaces. ! -- In concurrent types the ancestor interface (if any) is the ! -- first element of the list of interface types. ! ! if Is_Concurrent_Type (Full_T) ! or else Is_Concurrent_Record_Type (Full_T) ! then ! if Is_Non_Empty_List (Iface_List) then ! Ancestor := Etype (First (Iface_List)); ! Collect (Ancestor); ! ! if not Exclude_Parent_Interfaces then ! Add_Interface (Ancestor); ! end if; ! end if; ! ! elsif Etype (Full_T) /= Typ -- Protect the frontend against wrong sources. For example: --- 1275,1284 ---- Full_T := Full_View (Typ); end if; -- Include the ancestor if we are generating the whole list of -- abstract interfaces. ! if Etype (Full_T) /= Typ -- Protect the frontend against wrong sources. For example: *************** package body Sem_Util is *** 1219,1245 **** Collect (Ancestor); if Is_Interface (Ancestor) ! and then not Exclude_Parent_Interfaces then ! Add_Interface (Ancestor); end if; end if; -- Traverse the graph of ancestor interfaces ! if Is_Non_Empty_List (Iface_List) then ! Id := First (Iface_List); ! ! -- In concurrent types the ancestor interface (if any) is the ! -- first element of the list of interface types and we have ! -- already processed them while climbing to the root type. ! ! if Is_Concurrent_Type (Full_T) ! or else Is_Concurrent_Record_Type (Full_T) ! then ! Next (Id); ! end if; ! while Present (Id) loop Iface := Etype (Id); --- 1297,1312 ---- Collect (Ancestor); if Is_Interface (Ancestor) ! and then not Exclude_Parents then ! Append_Unique_Elmt (Ancestor, Ifaces_List); end if; end if; -- Traverse the graph of ancestor interfaces ! if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then ! Id := First (Abstract_Interface_List (Full_T)); while Present (Id) loop Iface := Etype (Id); *************** package body Sem_Util is *** 1249,1261 **** -- type Wrong is new I and O with null record; -- ERROR if Is_Interface (Iface) then ! if Exclude_Parent_Interfaces ! and then Interface_Present_In_Parent (T, Iface) then null; else ! Collect (Iface); ! Add_Interface (Iface); end if; end if; --- 1316,1329 ---- -- type Wrong is new I and O with null record; -- ERROR if Is_Interface (Iface) then ! if Exclude_Parents ! and then Etype (T) /= T ! and then Interface_Present_In_Ancestor (Etype (T), Iface) then null; else ! Collect (Iface); ! Append_Unique_Elmt (Iface, Ifaces_List); end if; end if; *************** package body Sem_Util is *** 1264,1303 **** end if; end Collect; ! --------------------------------- ! -- Interface_Present_In_Parent -- ! --------------------------------- ! ! function Interface_Present_In_Parent ! (Typ : Entity_Id; ! Iface : Entity_Id) return Boolean ! is ! Aux : Entity_Id := Typ; ! Iface_List : List_Id; ! ! begin ! if Is_Concurrent_Type (Typ) ! or else Is_Concurrent_Record_Type (Typ) ! then ! Iface_List := Abstract_Interface_List (Typ); ! ! if Is_Non_Empty_List (Iface_List) then ! Aux := Etype (First (Iface_List)); ! else ! return False; ! end if; ! end if; ! ! return Interface_Present_In_Ancestor (Aux, Iface); ! end Interface_Present_In_Parent; ! ! -- Start of processing for Collect_Abstract_Interfaces begin pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); Ifaces_List := New_Elmt_List; Collect (T); ! end Collect_Abstract_Interfaces; ---------------------------------- -- Collect_Interface_Components -- --- 1332,1344 ---- end if; end Collect; ! -- Start of processing for Collect_Interfaces begin pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); Ifaces_List := New_Elmt_List; Collect (T); ! end Collect_Interfaces; ---------------------------------- -- Collect_Interface_Components -- *************** package body Sem_Util is *** 1386,1397 **** ADT : Elmt_Id; begin ! ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); while Present (ADT) and then Ekind (Node (ADT)) = E_Constant and then Related_Type (Node (ADT)) /= Iface loop ! -- Skip the two secondary dispatch tables of Iface Next_Elmt (ADT); Next_Elmt (ADT); end loop; --- 1427,1441 ---- ADT : Elmt_Id; begin ! ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); while Present (ADT) and then Ekind (Node (ADT)) = E_Constant and then Related_Type (Node (ADT)) /= Iface loop ! -- Skip the secondary dispatch tables of Iface ! ! Next_Elmt (ADT); ! Next_Elmt (ADT); Next_Elmt (ADT); Next_Elmt (ADT); end loop; *************** package body Sem_Util is *** 1403,1409 **** -- Start of processing for Collect_Interfaces_Info begin ! Collect_Abstract_Interfaces (T, Ifaces_List); Collect_Interface_Components (T, Comps_List); -- Search for the record component and tag associated with each --- 1447,1453 ---- -- Start of processing for Collect_Interfaces_Info begin ! Collect_Interfaces (T, Ifaces_List); Collect_Interface_Components (T, Comps_List); -- Search for the record component and tag associated with each *************** package body Sem_Util is *** 1419,1425 **** -- Associate the primary tag component and the primary dispatch table -- with all the interfaces that are parents of T ! if Is_Parent (Iface, T) then Append_Elmt (First_Tag_Component (T), Components_List); Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); --- 1463,1469 ---- -- Associate the primary tag component and the primary dispatch table -- with all the interfaces that are parents of T ! if Is_Ancestor (Iface, T) then Append_Elmt (First_Tag_Component (T), Components_List); Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); *************** package body Sem_Util is *** 1432,1438 **** Comp_Iface := Related_Type (Node (Comp_Elmt)); if Comp_Iface = Iface ! or else Is_Parent (Iface, Comp_Iface) then Append_Elmt (Node (Comp_Elmt), Components_List); Append_Elmt (Search_Tag (Comp_Iface), Tags_List); --- 1476,1482 ---- Comp_Iface := Related_Type (Node (Comp_Elmt)); if Comp_Iface = Iface ! or else Is_Ancestor (Iface, Comp_Iface) then Append_Elmt (Node (Comp_Elmt), Components_List); Append_Elmt (Search_Tag (Comp_Iface), Tags_List); *************** package body Sem_Util is *** 1769,1774 **** --- 1813,1854 ---- end if; end Conditional_Delay; + ------------------------- + -- Copy_Parameter_List -- + ------------------------- + + function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Subp_Id); + Plist : List_Id; + Formal : Entity_Id; + + begin + if No (First_Formal (Subp_Id)) then + return No_List; + else + Plist := New_List; + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + Append + (Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal)), + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Parameter_Type => + New_Reference_To (Etype (Formal), Loc), + Expression => + New_Copy_Tree (Expression (Parent (Formal)))), + Plist); + + Next_Formal (Formal); + end loop; + end if; + + return Plist; + end Copy_Parameter_List; + -------------------- -- Current_Entity -- -------------------- *************** package body Sem_Util is *** 1833,1839 **** function Current_Subprogram return Entity_Id is Scop : constant Entity_Id := Current_Scope; - begin if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then return Scop; --- 1913,1918 ---- *************** package body Sem_Util is *** 1984,1989 **** --- 2063,2077 ---- end Denotes_Discriminant; + ---------------------- + -- Denotes_Variable -- + ---------------------- + + function Denotes_Variable (N : Node_Id) return Boolean is + begin + return Is_Variable (N) and then Paren_Count (N) = 0; + end Denotes_Variable; + ----------------------------- -- Depends_On_Discriminant -- ----------------------------- *************** package body Sem_Util is *** 2256,2281 **** E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); S : constant Entity_Id := Current_Scope; - function Is_Private_Component_Renaming (N : Node_Id) return Boolean; - -- Recognize a renaming declaration that is introduced for private - -- components of a protected type. We treat these as weak declarations - -- so that they are overridden by entities with the same name that - -- come from source, such as formals or local variables of a given - -- protected declaration. - - ----------------------------------- - -- Is_Private_Component_Renaming -- - ----------------------------------- - - function Is_Private_Component_Renaming (N : Node_Id) return Boolean is - begin - return not Comes_From_Source (N) - and then not Comes_From_Source (Current_Scope) - and then Nkind (N) = N_Object_Renaming_Declaration; - end Is_Private_Component_Renaming; - - -- Start of processing for Enter_Name - begin Generate_Definition (Def_Id); --- 2344,2349 ---- *************** package body Sem_Util is *** 2399,2405 **** then return; ! elsif Is_Private_Component_Renaming (Parent (Def_Id)) then return; -- In the body or private part of an instance, a type extension --- 2467,2495 ---- then return; ! -- If the homograph is a protected component renaming, it should not ! -- be hiding the current entity. Such renamings are treated as weak ! -- declarations. ! ! elsif Is_Prival (E) then ! Set_Is_Immediately_Visible (E, False); ! ! -- In this case the current entity is a protected component renaming. ! -- Perform minimal decoration by setting the scope and return since ! -- the prival should not be hiding other visible entities. ! ! elsif Is_Prival (Def_Id) then ! Set_Scope (Def_Id, Current_Scope); ! return; ! ! -- Analogous to privals, the discriminal generated for an entry ! -- index parameter acts as a weak declaration. Perform minimal ! -- decoration to avoid bogus errors. ! ! elsif Is_Discriminal (Def_Id) ! and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter ! then ! Set_Scope (Def_Id, Current_Scope); return; -- In the body or private part of an instance, a type extension *************** package body Sem_Util is *** 2408,2414 **** -- of the full type with two components of the same name are not -- clear at this point ??? ! elsif In_Instance_Not_Visible then null; -- When compiling a package body, some child units may have become --- 2498,2504 ---- -- of the full type with two components of the same name are not -- clear at this point ??? ! elsif In_Instance_Not_Visible then null; -- When compiling a package body, some child units may have become *************** package body Sem_Util is *** 2443,2463 **** and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration then Error_Msg_N ! ("incomplete type cannot be completed" & ! " with a private declaration", ! Parent (Def_Id)); Set_Is_Immediately_Visible (E, False); Set_Full_View (E, Def_Id); elsif Ekind (E) = E_Discriminant and then Present (Scope (Def_Id)) and then Scope (Def_Id) /= Current_Scope then - -- An inherited component of a record conflicts with - -- a new discriminant. The discriminant is inserted first - -- in the scope, but the error should be posted on it, not - -- on the component. - Error_Msg_Sloc := Sloc (Def_Id); Error_Msg_N ("& conflicts with declaration#", E); return; --- 2533,2551 ---- and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration then Error_Msg_N ! ("incomplete type cannot be completed with a private " & ! "declaration", Parent (Def_Id)); Set_Is_Immediately_Visible (E, False); Set_Full_View (E, Def_Id); + -- An inherited component of a record conflicts with a new + -- discriminant. The discriminant is inserted first in the scope, + -- but the error should be posted on it, not on the component. + elsif Ekind (E) = E_Discriminant and then Present (Scope (Def_Id)) and then Scope (Def_Id) /= Current_Scope then Error_Msg_Sloc := Sloc (Def_Id); Error_Msg_N ("& conflicts with declaration#", E); return; *************** package body Sem_Util is *** 2487,2494 **** end if; end if; ! if Nkind (Parent (Parent (Def_Id))) ! = N_Generic_Subprogram_Declaration and then Def_Id = Defining_Entity (Specification (Parent (Parent (Def_Id)))) then --- 2575,2582 ---- end if; end if; ! if Nkind (Parent (Parent (Def_Id))) = ! N_Generic_Subprogram_Declaration and then Def_Id = Defining_Entity (Specification (Parent (Parent (Def_Id)))) then *************** package body Sem_Util is *** 2572,2578 **** and then Length_Of_Name (Chars (C)) /= 1 ! -- Don't warn for non-source eneities and then Comes_From_Source (C) and then Comes_From_Source (Def_Id) --- 2660,2666 ---- and then Length_Of_Name (Chars (C)) /= 1 ! -- Don't warn for non-source entities and then Comes_From_Source (C) and then Comes_From_Source (Def_Id) *************** package body Sem_Util is *** 2816,3119 **** return Empty; end Find_Overlaid_Object; - -------------------------------------------- - -- Find_Overridden_Synchronized_Primitive -- - -------------------------------------------- - - function Find_Overridden_Synchronized_Primitive - (Def_Id : Entity_Id; - First_Hom : Entity_Id; - Ifaces_List : Elist_Id; - In_Scope : Boolean) return Entity_Id - is - Candidate : Entity_Id := Empty; - Hom : Entity_Id := Empty; - Iface_Typ : Entity_Id; - Subp : Entity_Id := Empty; - Tag_Typ : Entity_Id; - - function Has_Correct_Formal_Mode (Subp : Entity_Id) return Boolean; - -- For an overridden subprogram Subp, check whether the mode of its - -- first parameter is correct depending on the kind of Tag_Typ. - - function Matches_Prefixed_View_Profile - (Prim_Params : List_Id; - Iface_Params : List_Id) return Boolean; - -- Determine whether a subprogram's parameter profile Prim_Params - -- matches that of a potentially overriden interface subprogram - -- Iface_Params. Also determine if the type of first parameter of - -- Iface_Params is an implemented interface. - - ----------------------------- - -- Has_Correct_Formal_Mode -- - ----------------------------- - - function Has_Correct_Formal_Mode (Subp : Entity_Id) return Boolean is - Param : Node_Id; - - begin - Param := First_Formal (Subp); - - -- In order for an entry or a protected procedure to override, the - -- first parameter of the overridden routine must be of mode "out", - -- "in out" or access-to-variable. - - if (Ekind (Subp) = E_Entry - or else Ekind (Subp) = E_Procedure) - and then Is_Protected_Type (Tag_Typ) - and then Ekind (Param) /= E_In_Out_Parameter - and then Ekind (Param) /= E_Out_Parameter - and then Nkind (Parameter_Type (Parent (Param))) /= - N_Access_Definition - then - return False; - end if; - - -- All other cases are OK since a task entry or routine does not - -- have a restriction on the mode of the first parameter of the - -- overridden interface routine. - - return True; - end Has_Correct_Formal_Mode; - - ----------------------------------- - -- Matches_Prefixed_View_Profile -- - ----------------------------------- - - function Matches_Prefixed_View_Profile - (Prim_Params : List_Id; - Iface_Params : List_Id) return Boolean - is - Iface_Id : Entity_Id; - Iface_Param : Node_Id; - Iface_Typ : Entity_Id; - Prim_Id : Entity_Id; - Prim_Param : Node_Id; - Prim_Typ : Entity_Id; - - function Is_Implemented (Iface : Entity_Id) return Boolean; - -- Determine if Iface is implemented by the current task or - -- protected type. - - -------------------- - -- Is_Implemented -- - -------------------- - - function Is_Implemented (Iface : Entity_Id) return Boolean is - Iface_Elmt : Elmt_Id; - - begin - Iface_Elmt := First_Elmt (Ifaces_List); - while Present (Iface_Elmt) loop - if Node (Iface_Elmt) = Iface then - return True; - end if; - - Next_Elmt (Iface_Elmt); - end loop; - - return False; - end Is_Implemented; - - -- Start of processing for Matches_Prefixed_View_Profile - - begin - Iface_Param := First (Iface_Params); - Iface_Typ := Find_Parameter_Type (Iface_Param); - Prim_Param := First (Prim_Params); - - -- The first parameter of the potentially overriden subprogram - -- must be an interface implemented by Prim. - - if not Is_Interface (Iface_Typ) - or else not Is_Implemented (Iface_Typ) - then - return False; - end if; - - -- The checks on the object parameters are done, move onto the rest - -- of the parameters. - - if not In_Scope then - Prim_Param := Next (Prim_Param); - end if; - - Iface_Param := Next (Iface_Param); - while Present (Iface_Param) and then Present (Prim_Param) loop - Iface_Id := Defining_Identifier (Iface_Param); - Iface_Typ := Find_Parameter_Type (Iface_Param); - Prim_Id := Defining_Identifier (Prim_Param); - Prim_Typ := Find_Parameter_Type (Prim_Param); - - -- Case of multiple interface types inside a parameter profile - - -- (Obj_Param : in out Iface; ...; Param : Iface) - - -- If the interface type is implemented, then the matching type - -- in the primitive should be the implementing record type. - - if Ekind (Iface_Typ) = E_Record_Type - and then Is_Interface (Iface_Typ) - and then Is_Implemented (Iface_Typ) - then - if Prim_Typ /= Tag_Typ then - return False; - end if; - - -- The two parameters must be both mode and subtype conformant - - elsif Ekind (Iface_Id) /= Ekind (Prim_Id) - or else - not Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant) - then - return False; - end if; - - Next (Iface_Param); - Next (Prim_Param); - end loop; - - -- One of the two lists contains more parameters than the other - - if Present (Iface_Param) or else Present (Prim_Param) then - return False; - end if; - - return True; - end Matches_Prefixed_View_Profile; - - -- Start of processing for Find_Overridden_Synchronized_Primitive - - begin - -- At this point the caller should have collected the interfaces - -- implemented by the synchronized type. - - pragma Assert (Present (Ifaces_List)); - - -- Find the tagged type to which subprogram Def_Id is primitive. If the - -- subprogram was declared within a protected or a task type, the type - -- is the scope itself, otherwise it is the type of the first parameter. - - if In_Scope then - Tag_Typ := Scope (Def_Id); - - elsif Present (First_Formal (Def_Id)) then - Tag_Typ := Find_Parameter_Type (Parent (First_Formal (Def_Id))); - - -- A parameterless subprogram which is declared outside a synchronized - -- type cannot act as a primitive, thus it cannot override anything. - - else - return Empty; - end if; - - -- Traverse the homonym chain, looking at a potentially overriden - -- subprogram that belongs to an implemented interface. - - Hom := First_Hom; - while Present (Hom) loop - Subp := Hom; - - -- Entries can override abstract or null interface procedures - - if Ekind (Def_Id) = E_Entry - and then Ekind (Subp) = E_Procedure - and then Nkind (Parent (Subp)) = N_Procedure_Specification - and then (Is_Abstract_Subprogram (Subp) - or else Null_Present (Parent (Subp))) - then - while Present (Alias (Subp)) loop - Subp := Alias (Subp); - end loop; - - if Matches_Prefixed_View_Profile - (Parameter_Specifications (Parent (Def_Id)), - Parameter_Specifications (Parent (Subp))) - then - Candidate := Subp; - - -- Absolute match - - if Has_Correct_Formal_Mode (Candidate) then - return Candidate; - end if; - end if; - - -- Procedures can override abstract or null interface procedures - - elsif Ekind (Def_Id) = E_Procedure - and then Ekind (Subp) = E_Procedure - and then Nkind (Parent (Subp)) = N_Procedure_Specification - and then (Is_Abstract_Subprogram (Subp) - or else Null_Present (Parent (Subp))) - and then Matches_Prefixed_View_Profile - (Parameter_Specifications (Parent (Def_Id)), - Parameter_Specifications (Parent (Subp))) - then - Candidate := Subp; - - -- Absolute match - - if Has_Correct_Formal_Mode (Candidate) then - return Candidate; - end if; - - -- Functions can override abstract interface functions - - elsif Ekind (Def_Id) = E_Function - and then Ekind (Subp) = E_Function - and then Nkind (Parent (Subp)) = N_Function_Specification - and then Is_Abstract_Subprogram (Subp) - and then Matches_Prefixed_View_Profile - (Parameter_Specifications (Parent (Def_Id)), - Parameter_Specifications (Parent (Subp))) - and then Etype (Result_Definition (Parent (Def_Id))) = - Etype (Result_Definition (Parent (Subp))) - then - return Subp; - end if; - - Hom := Homonym (Hom); - end loop; - - -- After examining all candidates for overriding, we are left with - -- the best match which is a mode incompatible interface routine. - -- Do not emit an error if the Expander is active since this error - -- will be detected later on after all concurrent types are expanded - -- and all wrappers are built. This check is meant for spec-only - -- compilations. - - if Present (Candidate) - and then not Expander_Active - then - Iface_Typ := Find_Parameter_Type (Parent (First_Formal (Candidate))); - - -- Def_Id is primitive of a protected type, declared inside the type, - -- and the candidate is primitive of a limited or synchronized - -- interface. - - if In_Scope - and then Is_Protected_Type (Tag_Typ) - and then - (Is_Limited_Interface (Iface_Typ) - or else Is_Protected_Interface (Iface_Typ) - or else Is_Synchronized_Interface (Iface_Typ) - or else Is_Task_Interface (Iface_Typ)) - then - -- Must reword this message, comma before to in -gnatj mode ??? - - Error_Msg_NE - ("first formal of & must be of mode `OUT`, `IN OUT` or " & - "access-to-variable", Tag_Typ, Candidate); - Error_Msg_N - ("\to be overridden by protected procedure or entry " & - "(RM 9.4(11.9/2))", Tag_Typ); - end if; - end if; - - return Candidate; - end Find_Overridden_Synchronized_Primitive; - ------------------------- -- Find_Parameter_Type -- ------------------------- --- 2904,2909 ---- *************** package body Sem_Util is *** 3123,3130 **** if Nkind (Param) /= N_Parameter_Specification then return Empty; elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then ! return Etype (Subtype_Mark (Parameter_Type (Param))); else return Etype (Parameter_Type (Param)); --- 2913,2924 ---- if Nkind (Param) /= N_Parameter_Specification then return Empty; + -- For an access parameter, obtain the type from the formal entity + -- itself, because access to subprogram nodes do not carry a type. + -- Shouldn't we always use the formal entity ??? + elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then ! return Etype (Defining_Identifier (Param)); else return Etype (Parameter_Type (Param)); *************** package body Sem_Util is *** 3290,3296 **** begin Res := Internal_Full_Qualified_Name (E); ! Store_String_Char (Get_Char_Code (ASCII.nul)); return End_String; end Full_Qualified_Name; --- 3084,3090 ---- begin Res := Internal_Full_Qualified_Name (E); ! Store_String_Char (Get_Char_Code (ASCII.NUL)); return End_String; end Full_Qualified_Name; *************** package body Sem_Util is *** 3538,3546 **** and then not Has_Unknown_Discriminants (Utyp) and then not (Ekind (Utyp) = E_String_Literal_Subtype) then ! -- Nothing to do if in default expression ! if In_Default_Expression then return Typ; elsif Is_Private_Type (Typ) --- 3332,3340 ---- and then not Has_Unknown_Discriminants (Utyp) and then not (Ekind (Utyp) = E_String_Literal_Subtype) then ! -- Nothing to do if in spec expression (why not???) ! if In_Spec_Expression then return Typ; elsif Is_Private_Type (Typ) *************** package body Sem_Util is *** 3658,3667 **** -- literals to search. Instead, an N_Character_Literal node is created -- with the appropriate Char_Code and Chars fields. ! if Root_Type (T) = Standard_Character ! or else Root_Type (T) = Standard_Wide_Character ! or else Root_Type (T) = Standard_Wide_Wide_Character ! then Set_Character_Literal_Name (UI_To_CC (Pos)); return Make_Character_Literal (Loc, --- 3452,3458 ---- -- literals to search. Instead, an N_Character_Literal node is created -- with the appropriate Char_Code and Chars fields. ! if Is_Standard_Character_Type (T) then Set_Character_Literal_Name (UI_To_CC (Pos)); return Make_Character_Literal (Loc, *************** package body Sem_Util is *** 3769,3774 **** --- 3560,3574 ---- return Entity_Id (Get_Name_Table_Info (Id)); end Get_Name_Entity_Id; + ------------------- + -- Get_Pragma_Id -- + ------------------- + + function Get_Pragma_Id (N : Node_Id) return Pragma_Id is + begin + return Get_Pragma_Id (Pragma_Name (N)); + end Get_Pragma_Id; + --------------------------- -- Get_Referenced_Object -- --------------------------- *************** package body Sem_Util is *** 3890,3896 **** function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is begin -- Note: A task type may be the completion of a private type with ! -- discriminants. when performing elaboration checks on a task -- declaration, the current view of the type may be the private one, -- and the procedure that holds the body of the task is held in its -- underlying type. --- 3690,3696 ---- function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is begin -- Note: A task type may be the completion of a private type with ! -- discriminants. When performing elaboration checks on a task -- declaration, the current view of the type may be the private one, -- and the procedure that holds the body of the task is held in its -- underlying type. *************** package body Sem_Util is *** 3901,3972 **** return Task_Body_Procedure (Underlying_Type (Root_Type (E))); end Get_Task_Body_Procedure; - ----------------------------- - -- Has_Abstract_Interfaces -- - ----------------------------- - - function Has_Abstract_Interfaces - (Tagged_Type : Entity_Id; - Use_Full_View : Boolean := True) return Boolean - is - Typ : Entity_Id; - - begin - pragma Assert (Is_Record_Type (Tagged_Type) - and then Is_Tagged_Type (Tagged_Type)); - - -- Handle concurrent record types - - if Is_Concurrent_Record_Type (Tagged_Type) - and then Is_Non_Empty_List (Abstract_Interface_List (Tagged_Type)) - then - return True; - end if; - - Typ := Tagged_Type; - - -- Handle private types - - if Use_Full_View - and then Present (Full_View (Tagged_Type)) - then - Typ := Full_View (Tagged_Type); - end if; - - loop - if Is_Interface (Typ) - or else - (Is_Record_Type (Typ) - and then Present (Abstract_Interfaces (Typ)) - and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) - then - return True; - end if; - - exit when Etype (Typ) = Typ - - -- Handle private types - - or else (Present (Full_View (Etype (Typ))) - and then Full_View (Etype (Typ)) = Typ) - - -- Protect the frontend against wrong source with cyclic - -- derivations - - or else Etype (Typ) = Tagged_Type; - - -- Climb to the ancestor type handling private types - - if Present (Full_View (Etype (Typ))) then - Typ := Full_View (Etype (Typ)); - else - Typ := Etype (Typ); - end if; - end loop; - - return False; - end Has_Abstract_Interfaces; - ----------------------- -- Has_Access_Values -- ----------------------- --- 3701,3706 ---- *************** package body Sem_Util is *** 3995,4003 **** Comp : Entity_Id; begin Comp := First_Component_Or_Discriminant (Typ); while Present (Comp) loop ! if Has_Access_Values (Etype (Comp)) then return True; end if; --- 3729,3745 ---- Comp : Entity_Id; begin + -- Loop to Check components + Comp := First_Component_Or_Discriminant (Typ); while Present (Comp) loop ! ! -- Check for access component, tag field does not count, even ! -- though it is implemented internally using an access type. ! ! if Has_Access_Values (Etype (Comp)) ! and then Chars (Comp) /= Name_uTag ! then return True; end if; *************** package body Sem_Util is *** 4277,4283 **** Set_Result (Unknown); -- Now check size of Expr object. Any size that is not an ! -- even multiple of Maxiumum_Alignment is also worrisome -- since it may cause the alignment of the object to be less -- than the alignment of the type. --- 4019,4025 ---- Set_Result (Unknown); -- Now check size of Expr object. Any size that is not an ! -- even multiple of Maximum_Alignment is also worrisome -- since it may cause the alignment of the object to be less -- than the alignment of the type. *************** package body Sem_Util is *** 4413,4418 **** --- 4155,4236 ---- and then Includes_Infinities (Scalar_Range (E)); end Has_Infinities; + -------------------- + -- Has_Interfaces -- + -------------------- + + function Has_Interfaces + (T : Entity_Id; + Use_Full_View : Boolean := True) return Boolean + is + Typ : Entity_Id; + + begin + -- Handle concurrent types + + if Is_Concurrent_Type (T) then + Typ := Corresponding_Record_Type (T); + else + Typ := T; + end if; + + if not Present (Typ) + or else not Is_Record_Type (Typ) + or else not Is_Tagged_Type (Typ) + then + return False; + end if; + + -- Handle private types + + if Use_Full_View + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; + + -- Handle concurrent record types + + if Is_Concurrent_Record_Type (Typ) + and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) + then + return True; + end if; + + loop + if Is_Interface (Typ) + or else + (Is_Record_Type (Typ) + and then Present (Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Interfaces (Typ))) + then + return True; + end if; + + exit when Etype (Typ) = Typ + + -- Handle private types + + or else (Present (Full_View (Etype (Typ))) + and then Full_View (Etype (Typ)) = Typ) + + -- Protect the frontend against wrong source with cyclic + -- derivations + + or else Etype (Typ) = T; + + -- Climb to the ancestor type handling private types + + if Present (Full_View (Etype (Typ))) then + Typ := Full_View (Etype (Typ)); + else + Typ := Etype (Typ); + end if; + end loop; + + return False; + end Has_Interfaces; + ------------------------ -- Has_Null_Exclusion -- ------------------------ *************** package body Sem_Util is *** 4503,4508 **** --- 4321,4379 ---- end if; end Has_Null_Extension; + ------------------------------- + -- Has_Overriding_Initialize -- + ------------------------------- + + function Has_Overriding_Initialize (T : Entity_Id) return Boolean is + BT : constant Entity_Id := Base_Type (T); + Comp : Entity_Id; + P : Elmt_Id; + + begin + if Is_Controlled (BT) then + + -- For derived types, check immediate ancestor, excluding + -- Controlled itself. + + if Is_Derived_Type (BT) + and then not In_Predefined_Unit (Etype (BT)) + and then Has_Overriding_Initialize (Etype (BT)) + then + return True; + + elsif Present (Primitive_Operations (BT)) then + P := First_Elmt (Primitive_Operations (BT)); + while Present (P) loop + if Chars (Node (P)) = Name_Initialize + and then Comes_From_Source (Node (P)) + then + return True; + end if; + + Next_Elmt (P); + end loop; + end if; + + return False; + + elsif Has_Controlled_Component (BT) then + Comp := First_Component (BT); + while Present (Comp) loop + if Has_Overriding_Initialize (Etype (Comp)) then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + + else + return False; + end if; + end Has_Overriding_Initialize; + -------------------------------------- -- Has_Preelaborable_Initialization -- -------------------------------------- *************** package body Sem_Util is *** 4694,4700 **** then -- Get default expression if any. If there is no declaration -- node, it means we have an internal entity. The parent and ! -- tag fields are examples of such entitires. For these cases, -- we just test the type of the entity. if Present (Declaration_Node (Ent)) then --- 4565,4571 ---- then -- Get default expression if any. If there is no declaration -- node, it means we have an internal entity. The parent and ! -- tag fields are examples of such entities. For these cases, -- we just test the type of the entity. if Present (Declaration_Node (Ent)) then *************** package body Sem_Util is *** 4745,4758 **** return Has_Preelaborable_Initialization (Base_Type (E)); end if; - -- Other private types never have preelaborable initialization - - if Is_Private_Type (E) then - return False; - end if; - - -- Here for all non-private view - -- All elementary types have preelaborable initialization if Is_Elementary_Type (E) then --- 4616,4621 ---- *************** package body Sem_Util is *** 4772,4777 **** --- 4635,4647 ---- elsif Is_Derived_Type (E) then + -- If the derived type is a private extension then it doesn't have + -- preelaborable initialization. + + if Ekind (Base_Type (E)) = E_Record_Type_With_Private then + return False; + end if; + -- First check whether ancestor type has preelaborable initialization Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); *************** package body Sem_Util is *** 4787,4811 **** if Has_PE and then Is_Controlled (E) ! and then Present (Primitive_Operations (E)) then ! declare ! P : Elmt_Id; ! begin ! P := First_Elmt (Primitive_Operations (E)); ! while Present (P) loop ! if Chars (Node (P)) = Name_Initialize ! and then Comes_From_Source (Node (P)) ! then ! Has_PE := False; ! exit; ! end if; ! Next_Elmt (P); ! end loop; ! end; ! end if; -- Record type has PI if it is non private and all components have PI --- 4657,4673 ---- if Has_PE and then Is_Controlled (E) ! and then Has_Overriding_Initialize (E) then ! Has_PE := False; ! end if; ! -- Private types not derived from a type having preelaborable init and ! -- that are not marked with pragma Preelaborable_Initialization do not ! -- have preelaborable initialization. ! elsif Is_Private_Type (E) then ! return False; -- Record type has PI if it is non private and all components have PI *************** package body Sem_Util is *** 4978,4983 **** --- 4840,4895 ---- end if; end Has_Tagged_Component; + -------------------------- + -- Implements_Interface -- + -------------------------- + + function Implements_Interface + (Typ_Ent : Entity_Id; + Iface_Ent : Entity_Id; + Exclude_Parents : Boolean := False) return Boolean + is + Ifaces_List : Elist_Id; + Elmt : Elmt_Id; + Iface : Entity_Id; + Typ : Entity_Id; + + begin + if Is_Class_Wide_Type (Typ_Ent) then + Typ := Etype (Typ_Ent); + else + Typ := Typ_Ent; + end if; + + if Is_Class_Wide_Type (Iface_Ent) then + Iface := Etype (Iface_Ent); + else + Iface := Iface_Ent; + end if; + + if not Has_Interfaces (Typ) then + return False; + end if; + + Collect_Interfaces (Typ, Ifaces_List); + + Elmt := First_Elmt (Ifaces_List); + while Present (Elmt) loop + if Is_Ancestor (Node (Elmt), Typ) + and then Exclude_Parents + then + null; + + elsif Node (Elmt) = Iface then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + + return False; + end Implements_Interface; + ----------------- -- In_Instance -- ----------------- *************** package body Sem_Util is *** 5108,5116 **** return False; end In_Instance_Visible_Part; ! ---------------------- ! -- In_Packiage_Body -- ! ---------------------- function In_Package_Body return Boolean is S : Entity_Id; --- 5020,5028 ---- return False; end In_Instance_Visible_Part; ! --------------------- ! -- In_Package_Body -- ! --------------------- function In_Package_Body return Boolean is S : Entity_Id; *************** package body Sem_Util is *** 5132,5137 **** --- 5044,5069 ---- return False; end In_Package_Body; + -------------------------------- + -- In_Parameter_Specification -- + -------------------------------- + + function In_Parameter_Specification (N : Node_Id) return Boolean is + PN : Node_Id; + + begin + PN := Parent (N); + while Present (PN) loop + if Nkind (PN) = N_Parameter_Specification then + return True; + end if; + + PN := Parent (PN); + end loop; + + return False; + end In_Parameter_Specification; + -------------------------------------- -- In_Subprogram_Or_Concurrent_Unit -- -------------------------------------- *************** package body Sem_Util is *** 5248,5253 **** --- 5180,5220 ---- end if; end Insert_Explicit_Dereference; + ------------------------------------------ + -- Inspect_Deferred_Constant_Completion -- + ------------------------------------------ + + procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is + Decl : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) loop + + -- Deferred constant signature + + if Nkind (Decl) = N_Object_Declaration + and then Constant_Present (Decl) + and then No (Expression (Decl)) + + -- No need to check internally generated constants + + and then Comes_From_Source (Decl) + + -- The constant is not completed. A full object declaration + -- or a pragma Import complete a deferred constant. + + and then not Has_Completion (Defining_Identifier (Decl)) + then + Error_Msg_N + ("constant declaration requires initialization expression", + Defining_Identifier (Decl)); + end if; + + Decl := Next (Decl); + end loop; + end Inspect_Deferred_Constant_Completion; + ------------------- -- Is_AAMP_Float -- ------------------- *************** package body Sem_Util is *** 5734,5741 **** T := Base_Type (Etyp); end loop; end if; - - raise Program_Error; end Is_Descendent_Of; -------------- --- 5701,5706 ---- *************** package body Sem_Util is *** 5897,5909 **** or else No (Expression (Parent (Ent)))) and then not Is_Fully_Initialized_Type (Etype (Ent)) ! -- Special VM case for uTag component, which needs to be ! -- defined in this case, but is never initialized as VMs -- are using other dispatching mechanisms. Ignore this ! -- uninitialized case. ! and then (VM_Target = No_VM ! or else Chars (Ent) /= Name_uTag) then return False; end if; --- 5862,5874 ---- or else No (Expression (Parent (Ent)))) and then not Is_Fully_Initialized_Type (Etype (Ent)) ! -- Special VM case for tag components, which need to be ! -- defined in this case, but are never initialized as VMs -- are using other dispatching mechanisms. Ignore this ! -- uninitialized case. Note that this applies both to the ! -- uTag entry and the main vtable pointer (CPP_Class case). ! and then (VM_Target = No_VM or else not Is_Tag (Ent)) then return False; end if; *************** package body Sem_Util is *** 6153,6159 **** function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is begin ! Note_Possible_Modification (AV); -- We must reject parenthesized variable names. The check for -- Comes_From_Source is present because there are currently --- 6118,6124 ---- function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is begin ! Note_Possible_Modification (AV, Sure => True); -- We must reject parenthesized variable names. The check for -- Comes_From_Source is present because there are currently *************** package body Sem_Util is *** 6197,6203 **** if Is_Variable (Expression (AV)) and then Paren_Count (Expression (AV)) = 0 then ! Note_Possible_Modification (Expression (AV)); return True; -- We also allow a non-parenthesized expression that raises --- 6162,6168 ---- if Is_Variable (Expression (AV)) and then Paren_Count (Expression (AV)) = 0 then ! Note_Possible_Modification (Expression (AV), Sure => True); return True; -- We also allow a non-parenthesized expression that raises *************** package body Sem_Util is *** 6230,6262 **** end if; end Is_OK_Variable_For_Out_Formal; - --------------- - -- Is_Parent -- - --------------- - - function Is_Parent - (E1 : Entity_Id; - E2 : Entity_Id) return Boolean - is - Iface_List : List_Id; - T : Entity_Id := E2; - - begin - if Is_Concurrent_Type (T) - or else Is_Concurrent_Record_Type (T) - then - Iface_List := Abstract_Interface_List (E2); - - if Is_Empty_List (Iface_List) then - return False; - end if; - - T := Etype (First (Iface_List)); - end if; - - return Is_Ancestor (E1, T); - end Is_Parent; - ----------------------------------- -- Is_Partially_Initialized_Type -- ----------------------------------- --- 6195,6200 ---- *************** package body Sem_Util is *** 6385,6391 **** Indx : Node_Id; begin ! -- For private type, test corrresponding full type if Is_Private_Type (T) then return Is_Potentially_Persistent_Type (Full_View (T)); --- 6323,6329 ---- Indx : Node_Id; begin ! -- For private type, test corresponding full type if Is_Private_Type (T) then return Is_Potentially_Persistent_Type (Full_View (T)); *************** package body Sem_Util is *** 6440,6445 **** --- 6378,6419 ---- end if; end Is_Potentially_Persistent_Type; + --------------------------------- + -- Is_Protected_Self_Reference -- + --------------------------------- + + function Is_Protected_Self_Reference (N : Node_Id) return Boolean + is + function In_Access_Definition (N : Node_Id) return Boolean; + -- Returns true if N belongs to an access definition + + -------------------------- + -- In_Access_Definition -- + -------------------------- + + function In_Access_Definition (N : Node_Id) return Boolean + is + P : Node_Id := Parent (N); + begin + while Present (P) loop + if Nkind (P) = N_Access_Definition then + return True; + end if; + P := Parent (P); + end loop; + return False; + end In_Access_Definition; + + -- Start of processing for Is_Protected_Self_Reference + + begin + return Ada_Version >= Ada_05 + and then Is_Entity_Name (N) + and then Is_Protected_Type (Entity (N)) + and then In_Open_Scopes (Entity (N)) + and then not In_Access_Definition (N); + end Is_Protected_Self_Reference; + ----------------------------- -- Is_RCI_Pkg_Spec_Or_Body -- ----------------------------- *************** package body Sem_Util is *** 6480,6539 **** function Is_Remote_Access_To_Class_Wide_Type (E : Entity_Id) return Boolean is - D : Entity_Id; - - function Comes_From_Limited_Private_Type_Declaration - (E : Entity_Id) return Boolean; - -- Check that the type is declared by a limited type declaration, - -- or else is derived from a Remote_Type ancestor through private - -- extensions. - - ------------------------------------------------- - -- Comes_From_Limited_Private_Type_Declaration -- - ------------------------------------------------- - - function Comes_From_Limited_Private_Type_Declaration - (E : Entity_Id) return Boolean - is - N : constant Node_Id := Declaration_Node (E); - - begin - if Nkind (N) = N_Private_Type_Declaration - and then Limited_Present (N) - then - return True; - end if; - - if Nkind (N) = N_Private_Extension_Declaration then - return - Comes_From_Limited_Private_Type_Declaration (Etype (E)) - or else - (Is_Remote_Types (Etype (E)) - and then Is_Limited_Record (Etype (E)) - and then Has_Private_Declaration (Etype (E))); - end if; - - return False; - end Comes_From_Limited_Private_Type_Declaration; - - -- Start of processing for Is_Remote_Access_To_Class_Wide_Type - begin ! if not (Is_Remote_Call_Interface (E) ! or else Is_Remote_Types (E)) ! or else Ekind (E) /= E_General_Access_Type ! then ! return False; ! end if; ! ! D := Designated_Type (E); ! ! if Ekind (D) /= E_Class_Wide_Type then ! return False; ! end if; ! return Comes_From_Limited_Private_Type_Declaration ! (Defining_Identifier (Parent (D))); end Is_Remote_Access_To_Class_Wide_Type; ----------------------------------------- --- 6454,6466 ---- function Is_Remote_Access_To_Class_Wide_Type (E : Entity_Id) return Boolean is begin ! -- A remote access to class-wide type is a general access to object type ! -- declared in the visible part of a Remote_Types or Remote_Call_ ! -- Interface unit. ! return Ekind (E) = E_General_Access_Type ! and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); end Is_Remote_Access_To_Class_Wide_Type; ----------------------------------------- *************** package body Sem_Util is *** 6547,6554 **** return (Ekind (E) = E_Access_Subprogram_Type or else (Ekind (E) = E_Record_Type and then Present (Corresponding_Remote_Type (E)))) ! and then (Is_Remote_Call_Interface (E) ! or else Is_Remote_Types (E)); end Is_Remote_Access_To_Subprogram_Type; -------------------- --- 6474,6480 ---- return (Ekind (E) = E_Access_Subprogram_Type or else (Ekind (E) = E_Record_Type and then Present (Corresponding_Remote_Type (E)))) ! and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); end Is_Remote_Access_To_Subprogram_Type; -------------------- *************** package body Sem_Util is *** 6603,6610 **** Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); function Is_Entry (Nam : Node_Id) return Boolean; ! -- Determine whether Nam is an entry. Traverse selectors ! -- if there are nested selected components. -------------- -- Is_Entry -- --- 6529,6536 ---- Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); function Is_Entry (Nam : Node_Id) return Boolean; ! -- Determine whether Nam is an entry. Traverse selectors if there are ! -- nested selected components. -------------- -- Is_Entry -- *************** package body Sem_Util is *** 7111,7121 **** -- If scope is a package, also clear current values of all -- private entities in the scope. ! if Ekind (S) = E_Package ! or else ! Ekind (S) = E_Generic_Package ! or else ! Is_Concurrent_Type (S) then Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); end if; --- 7037,7044 ---- -- If scope is a package, also clear current values of all -- private entities in the scope. ! if Is_Package_Or_Generic_Package (S) ! or else Is_Concurrent_Type (S) then Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); end if; *************** package body Sem_Util is *** 7251,7257 **** when N_Type_Conversion => return Known_To_Be_Assigned (P); ! -- All other references are definitely not knwon to be modifications when others => return False; --- 7174,7180 ---- when N_Type_Conversion => return Known_To_Be_Assigned (P); ! -- All other references are definitely not known to be modifications when others => return False; *************** package body Sem_Util is *** 7380,7386 **** when N_Type_Conversion => return May_Be_Lvalue (P); ! -- Test for appearence in object renaming declaration when N_Object_Renaming_Declaration => return True; --- 7303,7309 ---- when N_Type_Conversion => return May_Be_Lvalue (P); ! -- Test for appearance in object renaming declaration when N_Object_Renaming_Declaration => return True; *************** package body Sem_Util is *** 7854,7860 **** -- Note_Possible_Modification -- -------------------------------- ! procedure Note_Possible_Modification (N : Node_Id) is Modification_Comes_From_Source : constant Boolean := Comes_From_Source (Parent (N)); --- 7777,7783 ---- -- Note_Possible_Modification -- -------------------------------- ! procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is Modification_Comes_From_Source : constant Boolean := Comes_From_Source (Parent (N)); *************** package body Sem_Util is *** 7970,7975 **** --- 7893,7927 ---- end if; Kill_Checks (Ent); + + -- If we are sure this is a modification from source, and we know + -- this modifies a constant, then give an appropriate warning. + + if Overlays_Constant (Ent) + and then Modification_Comes_From_Source + and then Sure + then + declare + A : constant Node_Id := Address_Clause (Ent); + begin + if Present (A) then + declare + Exp : constant Node_Id := Expression (A); + begin + if Nkind (Exp) = N_Attribute_Reference + and then Attribute_Name (Exp) = Name_Address + and then Is_Entity_Name (Prefix (Exp)) + then + Error_Msg_Sloc := Sloc (A); + Error_Msg_NE + ("constant& may be modified via address clause#?", + N, Entity (Prefix (Exp))); + end if; + end; + end if; + end; + end if; + return; end if; end loop; *************** package body Sem_Util is *** 8022,8027 **** --- 7974,7983 ---- if Is_Entity_Name (Obj) then E := Entity (Obj); + if Is_Prival (E) then + E := Prival_Link (E); + end if; + -- If E is a type then it denotes a current instance. For this case -- we add one to the normal accessibility level of the type to ensure -- that current instances are treated as always being deeper than *************** package body Sem_Util is *** 8097,8103 **** return Object_Access_Level (Expression (Obj)); -- Function results are objects, so we get either the access level of ! -- the function or, in the case of an indirect call, the level of of the -- access-to-subprogram type. elsif Nkind (Obj) = N_Function_Call then --- 8053,8059 ---- return Object_Access_Level (Expression (Obj)); -- Function results are objects, so we get either the access level of ! -- the function or, in the case of an indirect call, the level of the -- access-to-subprogram type. elsif Nkind (Obj) = N_Function_Call then *************** package body Sem_Util is *** 8215,8220 **** --- 8171,8218 ---- return Trace_Components (Type_Id, False); end Private_Component; + --------------------------- + -- Primitive_Names_Match -- + --------------------------- + + function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is + + function Non_Internal_Name (E : Entity_Id) return Name_Id; + -- Given an internal name, returns the corresponding non-internal name + + ------------------------ + -- Non_Internal_Name -- + ------------------------ + + function Non_Internal_Name (E : Entity_Id) return Name_Id is + begin + Get_Name_String (Chars (E)); + Name_Len := Name_Len - 1; + return Name_Find; + end Non_Internal_Name; + + -- Start of processing for Primitive_Names_Match + + begin + pragma Assert (Present (E1) and then Present (E2)); + + return Chars (E1) = Chars (E2) + or else + (not Is_Internal_Name (Chars (E1)) + and then Is_Internal_Name (Chars (E2)) + and then Non_Internal_Name (E2) = Chars (E1)) + or else + (not Is_Internal_Name (Chars (E2)) + and then Is_Internal_Name (Chars (E1)) + and then Non_Internal_Name (E1) = Chars (E2)) + or else + (Is_Predefined_Dispatching_Operation (E1) + and then Is_Predefined_Dispatching_Operation (E2) + and then Same_TSS (E1, E2)) + or else + (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); + end Primitive_Names_Match; + ----------------------- -- Process_End_Label -- ----------------------- *************** package body Sem_Util is *** 8424,8429 **** --- 8422,8453 ---- return Token_Node; end Real_Convert; + -------------------- + -- Remove_Homonym -- + -------------------- + + procedure Remove_Homonym (E : Entity_Id) is + Prev : Entity_Id := Empty; + H : Entity_Id; + + begin + if E = Current_Entity (E) then + if Present (Homonym (E)) then + Set_Current_Entity (Homonym (E)); + else + Set_Name_Entity_Id (Chars (E), Empty); + end if; + else + H := Current_Entity (E); + while Present (H) and then H /= E loop + Prev := H; + H := Homonym (H); + end loop; + + Set_Homonym (Prev, Homonym (E)); + end if; + end Remove_Homonym; + --------------------- -- Rep_To_Pos_Flag -- --------------------- *************** package body Sem_Util is *** 8555,8561 **** function Clear_Analyzed (N : Node_Id) return Traverse_Result; -- Function used to reset Analyzed flags in tree. Note that we do -- not reset Analyzed flags in entities, since there is no need to ! -- renalalyze entities, and indeed, it is wrong to do so, since it -- can result in generating auxiliary stuff more than once. -------------------- --- 8579,8585 ---- function Clear_Analyzed (N : Node_Id) return Traverse_Result; -- Function used to reset Analyzed flags in tree. Note that we do -- not reset Analyzed flags in entities, since there is no need to ! -- reanalyze entities, and indeed, it is wrong to do so, since it -- can result in generating auxiliary stuff more than once. -------------------- *************** package body Sem_Util is *** 8858,8864 **** -- Scope_Is_Transient -- ------------------------ ! function Scope_Is_Transient return Boolean is begin return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; end Scope_Is_Transient; --- 8882,8888 ---- -- Scope_Is_Transient -- ------------------------ ! function Scope_Is_Transient return Boolean is begin return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; end Scope_Is_Transient; *************** package body Sem_Util is *** 8910,8917 **** procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is begin Basic_Set_Convention (E, Val); if Is_Type (E) ! and then Ekind (Base_Type (E)) in Access_Subprogram_Type_Kind and then Has_Foreign_Convention (E) then Set_Can_Use_Internal_Rep (E, False); --- 8934,8942 ---- procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is begin Basic_Set_Convention (E, Val); + if Is_Type (E) ! and then Is_Access_Subprogram_Type (Base_Type (E)) and then Has_Foreign_Convention (E) then Set_Can_Use_Internal_Rep (E, False); *************** package body Sem_Util is *** 8932,8937 **** --- 8957,9059 ---- Set_Name_Entity_Id (Chars (E), E); end Set_Current_Entity; + --------------------------- + -- Set_Debug_Info_Needed -- + --------------------------- + + procedure Set_Debug_Info_Needed (T : Entity_Id) is + + procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); + pragma Inline (Set_Debug_Info_Needed_If_Not_Set); + -- Used to set debug info in a related node if not set already + + -------------------------------------- + -- Set_Debug_Info_Needed_If_Not_Set -- + -------------------------------------- + + procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is + begin + if Present (E) + and then not Needs_Debug_Info (E) + then + Set_Debug_Info_Needed (E); + + -- For a private type, indicate that the full view also needs + -- debug information. + + if Is_Type (E) + and then Is_Private_Type (E) + and then Present (Full_View (E)) + then + Set_Debug_Info_Needed (Full_View (E)); + end if; + end if; + end Set_Debug_Info_Needed_If_Not_Set; + + -- Start of processing for Set_Debug_Info_Needed + + begin + -- Nothing to do if argument is Empty or has Debug_Info_Off set, which + -- indicates that Debug_Info_Needed is never required for the entity. + + if No (T) + or else Debug_Info_Off (T) + then + return; + end if; + + -- Set flag in entity itself. Note that we will go through the following + -- circuitry even if the flag is already set on T. That's intentional, + -- it makes sure that the flag will be set in subsidiary entities. + + Set_Needs_Debug_Info (T); + + -- Set flag on subsidiary entities if not set already + + if Is_Object (T) then + Set_Debug_Info_Needed_If_Not_Set (Etype (T)); + + elsif Is_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Etype (T)); + + if Is_Record_Type (T) then + declare + Ent : Entity_Id := First_Entity (T); + begin + while Present (Ent) loop + Set_Debug_Info_Needed_If_Not_Set (Ent); + Next_Entity (Ent); + end loop; + end; + + elsif Is_Array_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); + + declare + Indx : Node_Id := First_Index (T); + begin + while Present (Indx) loop + Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); + Indx := Next_Index (Indx); + end loop; + end; + + if Is_Packed (T) then + Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T)); + end if; + + elsif Is_Access_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); + + elsif Is_Private_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Full_View (T)); + + elsif Is_Protected_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); + end if; + end if; + end Set_Debug_Info_Needed; + --------------------------------- -- Set_Entity_With_Style_Check -- --------------------------------- *************** package body Sem_Util is *** 9002,9007 **** --- 9124,9142 ---- end if; end Set_Next_Actual; + ---------------------------------- + -- Set_Optimize_Alignment_Flags -- + ---------------------------------- + + procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is + begin + if Optimize_Alignment = 'S' then + Set_Optimize_Alignment_Space (E); + elsif Optimize_Alignment = 'T' then + Set_Optimize_Alignment_Time (E); + end if; + end Set_Optimize_Alignment_Flags; + ----------------------- -- Set_Public_Status -- ----------------------- *************** package body Sem_Util is *** 9009,9014 **** --- 9144,9177 ---- procedure Set_Public_Status (Id : Entity_Id) is S : constant Entity_Id := Current_Scope; + function Within_HSS_Or_If (E : Entity_Id) return Boolean; + -- Determines if E is defined within handled statement sequence or + -- an if statement, returns True if so, False otherwise. + + ---------------------- + -- Within_HSS_Or_If -- + ---------------------- + + function Within_HSS_Or_If (E : Entity_Id) return Boolean is + N : Node_Id; + begin + N := Declaration_Node (E); + loop + N := Parent (N); + + if No (N) then + return False; + + elsif Nkind_In (N, N_Handled_Sequence_Of_Statements, + N_If_Statement) + then + return True; + end if; + end loop; + end Within_HSS_Or_If; + + -- Start of processing for Set_Public_Status + begin -- Everything in the scope of Standard is public *************** package body Sem_Util is *** 9020,9033 **** elsif not Is_Public (S) then return; ! -- An object declaration that occurs in a handled sequence of statements ! -- is the declaration for a temporary object generated by the expander. ! -- It never needs to be made public and furthermore, making it public ! -- can cause back end problems if it is of variable size. ! elsif Nkind (Parent (Id)) = N_Object_Declaration ! and then ! Nkind (Parent (Parent (Id))) = N_Handled_Sequence_Of_Statements then return; --- 9183,9197 ---- elsif not Is_Public (S) then return; ! -- An object or function declaration that occurs in a handled sequence ! -- of statements or within an if statement is the declaration for a ! -- temporary object or local subprogram generated by the expander. It ! -- never needs to be made public and furthermore, making it public can ! -- cause back end problems. ! elsif Nkind_In (Parent (Id), N_Object_Declaration, ! N_Function_Specification) ! and then Within_HSS_Or_If (Id) then return; *************** package body Sem_Util is *** 9313,9319 **** Btyp := Root_Type (Btyp); ! -- The accessibility level of anonymous acccess types associated with -- discriminants is that of the current instance of the type, and -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). --- 9477,9483 ---- Btyp := Root_Type (Btyp); ! -- The accessibility level of anonymous access types associated with -- discriminants is that of the current instance of the type, and -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). *************** package body Sem_Util is *** 9336,9341 **** --- 9500,9521 ---- return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); end Type_Access_Level; + -------------------- + -- Ultimate_Alias -- + -------------------- + -- To do: add occurrences calling this new subprogram + + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is + E : Entity_Id := Prim; + + begin + while Present (Alias (E)) loop + E := Alias (E); + end loop; + + return E; + end Ultimate_Alias; + -------------------------- -- Unit_Declaration_Node -- -------------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/sem_util.ads gcc-4.4.0/gcc/ada/sem_util.ads *** gcc-4.3.3/gcc/ada/sem_util.ads Thu Dec 13 10:32:45 2007 --- gcc-4.4.0/gcc/ada/sem_util.ads Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Sem_Util is *** 139,158 **** -- N is one of the statement forms that is a potentially blocking -- operation. If it appears within a protected action, emit warning. procedure Check_VMS (Construct : Node_Id); -- Check that this the target is OpenVMS, and if so, return with -- no effect, otherwise post an error noting this can only be used -- with OpenVMS ports. The argument is the construct in question -- and is used to post the error message. ! procedure Collect_Abstract_Interfaces ! (T : Entity_Id; ! Ifaces_List : out Elist_Id; ! Exclude_Parent_Interfaces : Boolean := False; ! Use_Full_View : Boolean := True); -- Ada 2005 (AI-251): Collect whole list of abstract interfaces that are ! -- directly or indirectly implemented by T. Exclude_Parent_Interfaces is ! -- used to avoid addition of inherited interfaces to the generated list. -- Use_Full_View is used to collect the interfaces using the full-view -- (if available). --- 139,165 ---- -- N is one of the statement forms that is a potentially blocking -- operation. If it appears within a protected action, emit warning. + procedure Check_Unprotected_Access + (Context : Node_Id; + Expr : Node_Id); + -- Check whether the expression is a pointer to a protected component, + -- and the context is external to the protected operation, to warn against + -- a possible unlocked access to data. + procedure Check_VMS (Construct : Node_Id); -- Check that this the target is OpenVMS, and if so, return with -- no effect, otherwise post an error noting this can only be used -- with OpenVMS ports. The argument is the construct in question -- and is used to post the error message. ! procedure Collect_Interfaces ! (T : Entity_Id; ! Ifaces_List : out Elist_Id; ! Exclude_Parents : Boolean := False; ! Use_Full_View : Boolean := True); -- Ada 2005 (AI-251): Collect whole list of abstract interfaces that are ! -- directly or indirectly implemented by T. Exclude_Parents is used to ! -- avoid the addition of inherited interfaces to the generated list. -- Use_Full_View is used to collect the interfaces using the full-view -- (if available). *************** package Sem_Util is *** 196,201 **** --- 203,214 ---- -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag -- of Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false); + function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id; + -- Utility to create a parameter profile for a new subprogram spec, + -- when the subprogram has a body that acts as spec. This is done for + -- some cases of inlining, and for private protected ops. Also used + -- to create bodies for stubbed subprograms. + function Current_Entity (N : Node_Id) return Entity_Id; -- Find the currently visible definition for a given identifier, that is to -- say the first entry in the visibility chain for the Chars of N. *************** package Sem_Util is *** 232,237 **** --- 245,253 ---- -- components of protected types, and constraint checks on entry -- families constrained by discriminants. + function Denotes_Variable (N : Node_Id) return Boolean; + -- Returns True if node N denotes a single variable without parentheses + function Depends_On_Discriminant (N : Node_Id) return Boolean; -- Returns True if N denotes a discriminant or if N is a range, a subtype -- indication or a scalar subtype where one of the bounds is a *************** package Sem_Util is *** 311,328 **** -- not an address representation clause, or if it is not possible to -- determine that the address is of this form, then Empty is returned. - function Find_Overridden_Synchronized_Primitive - (Def_Id : Entity_Id; - First_Hom : Entity_Id; - Ifaces_List : Elist_Id; - In_Scope : Boolean) return Entity_Id; - -- Determine whether entry or subprogram Def_Id overrides a primitive - -- operation that belongs to one of the interfaces in Ifaces_List. A - -- specific homonym chain can be specified by setting First_Hom. Flag - -- In_Scope is used to designate whether the entry or subprogram was - -- declared inside the scope of the synchronized type or after. Return - -- the overridden entity or Empty. - function Find_Parameter_Type (Param : Node_Id) return Entity_Id; -- Return the type of formal parameter Param as determined by its -- specification. --- 327,332 ---- *************** package Sem_Util is *** 425,431 **** Pos : Uint; Loc : Source_Ptr) return Entity_Id; -- This function obtains the E_Enumeration_Literal entity for the ! -- specified value from the enumneration type or subtype T. The -- second argument is the Pos value, which is assumed to be in range. -- The third argument supplies a source location for constructed -- nodes returned by this function. --- 429,435 ---- Pos : Uint; Loc : Source_Ptr) return Entity_Id; -- This function obtains the E_Enumeration_Literal entity for the ! -- specified value from the enumeration type or subtype T. The -- second argument is the Pos value, which is assumed to be in range. -- The third argument supplies a source location for constructed -- nodes returned by this function. *************** package Sem_Util is *** 440,450 **** -- which is the innermost visible entity with the given name. See the -- body of Sem_Ch8 for further details on handling of entity visibility. function Get_Renamed_Entity (E : Entity_Id) return Entity_Id; -- Given an entity for an exception, package, subprogram or generic unit, -- returns the ultimately renamed entity if this is a renaming. If this is -- not a renamed entity, returns its argument. It is an error to call this ! -- with any any other kind of entity. function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id; -- Nod is either a procedure call statement, or a function call, or --- 444,463 ---- -- which is the innermost visible entity with the given name. See the -- body of Sem_Ch8 for further details on handling of entity visibility. + function Get_Pragma_Id (N : Node_Id) return Pragma_Id; + pragma Inline (Get_Pragma_Id); + -- Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N) + + function Get_Referenced_Object (N : Node_Id) return Node_Id; + -- Given a node, return the renamed object if the node represents a renamed + -- object, otherwise return the node unchanged. The node may represent an + -- arbitrary expression. + function Get_Renamed_Entity (E : Entity_Id) return Entity_Id; -- Given an entity for an exception, package, subprogram or generic unit, -- returns the ultimately renamed entity if this is a renaming. If this is -- not a renamed entity, returns its argument. It is an error to call this ! -- with any other kind of entity. function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id; -- Nod is either a procedure call statement, or a function call, or *************** package Sem_Util is *** 452,462 **** -- related subprogram or entry and returns it, or if no subprogram can -- be found, returns Empty. - function Get_Referenced_Object (N : Node_Id) return Node_Id; - -- Given a node, return the renamed object if the node represents - -- a renamed object, otherwise return the node unchanged. The node - -- may represent an arbitrary expression. - function Get_Subprogram_Body (E : Entity_Id) return Node_Id; -- Given the entity for a subprogram (E_Function or E_Procedure), -- return the corresponding N_Subprogram_Body node. If the corresponding --- 465,470 ---- *************** package Sem_Util is *** 470,492 **** -- declaration. function Has_Access_Values (T : Entity_Id) return Boolean; ! -- Returns true if type or subtype T is an access type, or has a ! -- component (at any recursive level) that is an access type. This ! -- is a conservative predicate, if it is not known whether or not ! -- T contains access values (happens for generic formals in some ! -- cases), then False is returned. type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible); -- Result of Has_Compatible_Alignment test, description found below. Note -- that the values are arranged in increasing order of problematicness. - function Has_Abstract_Interfaces - (Tagged_Type : Entity_Id; - Use_Full_View : Boolean := True) return Boolean; - -- Returns true if Tagged_Type implements some abstract interface. In case - -- private types the argument Use_Full_View controls if the check is done - -- using its full view (if available). - function Has_Compatible_Alignment (Obj : Entity_Id; Expr : Node_Id) return Alignment_Result; --- 478,495 ---- -- declaration. function Has_Access_Values (T : Entity_Id) return Boolean; ! -- Returns true if type or subtype T is an access type, or has a component ! -- (at any recursive level) that is an access type. This is a conservative ! -- predicate, if it is not known whether or not T contains access values ! -- (happens for generic formals in some cases), then False is returned. ! -- Note that tagged types return False. Even though the tag is implemented ! -- as an access type internally, this function tests only for access types ! -- known to the programmer. See also Has_Tagged_Component. type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible); -- Result of Has_Compatible_Alignment test, description found below. Note -- that the values are arranged in increasing order of problematicness. function Has_Compatible_Alignment (Obj : Entity_Id; Expr : Node_Id) return Alignment_Result; *************** package Sem_Util is *** 519,529 **** -- Determines if the range of the floating-point type E includes -- infinities. Returns False if E is not a floating-point type. function Has_Null_Exclusion (N : Node_Id) return Boolean; -- Determine whether node N has a null exclusion function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean; ! -- Return True iff type E has preelaborable initialiation as defined in -- Ada 2005 (see AI-161 for details of the definition of this attribute). function Has_Private_Component (Type_Id : Entity_Id) return Boolean; --- 522,544 ---- -- Determines if the range of the floating-point type E includes -- infinities. Returns False if E is not a floating-point type. + function Has_Interfaces + (T : Entity_Id; + Use_Full_View : Boolean := True) return Boolean; + -- Where T is a concurrent type or a record type, returns true if T covers + -- any abstract interface types. In case of private types the argument + -- Use_Full_View controls if the check is done using its full view (if + -- available). + function Has_Null_Exclusion (N : Node_Id) return Boolean; -- Determine whether node N has a null exclusion + function Has_Overriding_Initialize (T : Entity_Id) return Boolean; + -- Predicate to determine whether a controlled type has a user-defined + -- Initialize primitive, which makes the type not preelaborable. + function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean; ! -- Return True iff type E has preelaborable initialization as defined in -- Ada 2005 (see AI-161 for details of the definition of this attribute). function Has_Private_Component (Type_Id : Entity_Id) return Boolean; *************** package Sem_Util is *** 539,546 **** -- if there is no underlying type). function Has_Tagged_Component (Typ : Entity_Id) return Boolean; ! -- Typ must be a composite type (array or record). This function is used ! -- to check if '=' has to be expanded into a bunch component comparaisons. function In_Instance return Boolean; -- Returns True if the current scope is within a generic instance --- 554,570 ---- -- if there is no underlying type). function Has_Tagged_Component (Typ : Entity_Id) return Boolean; ! -- Returns True if Typ is a composite type (array or record) which is ! -- either itself a tagged type, or has a component (recursively) which is ! -- a tagged type. Returns False for non-composite type, or if no tagged ! -- component is present. This function is used to check if '=' has to be ! -- expanded into a bunch component comparisons. ! ! function Implements_Interface ! (Typ_Ent : Entity_Id; ! Iface_Ent : Entity_Id; ! Exclude_Parents : Boolean := False) return Boolean; ! -- Returns true if the Typ implements interface Iface function In_Instance return Boolean; -- Returns True if the current scope is within a generic instance *************** package Sem_Util is *** 560,565 **** --- 584,592 ---- function In_Package_Body return Boolean; -- Returns True if current scope is within a package body + function In_Parameter_Specification (N : Node_Id) return Boolean; + -- Returns True if node N belongs to a parameter specification + function In_Subprogram_Or_Concurrent_Unit return Boolean; -- Determines if the current scope is within a subprogram compilation -- unit (inside a subprogram declaration, subprogram body, or generic *************** package Sem_Util is *** 578,583 **** --- 605,615 ---- -- N (which is the prefix, e.g. of an indexed component) as an -- explicit dereference. + procedure Inspect_Deferred_Constant_Completion (Decls : List_Id); + -- Examine all deferred constants in the declaration list Decls and check + -- whether they have been completed by a full constant declaration or an + -- Import pragma. Emit the error message if that is not the case. + function Is_AAMP_Float (E : Entity_Id) return Boolean; -- Defined for all type entities. Returns True only for the base type -- of float types with AAMP format. The particular format is determined *************** package Sem_Util is *** 663,669 **** -- i.e. a library unit or an entity declared in a library package. function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean; ! -- Determines whether Expr is a refeference to a variable or IN OUT -- mode parameter of the current enclosing subprogram. -- Why are OUT parameters not considered here ??? --- 695,701 ---- -- i.e. a library unit or an entity declared in a library package. function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean; ! -- Determines whether Expr is a reference to a variable or IN OUT -- mode parameter of the current enclosing subprogram. -- Why are OUT parameters not considered here ??? *************** package Sem_Util is *** 678,690 **** -- is a variable (in the Is_Variable sense) with a non-tagged type -- target are considered view conversions and hence variables. - function Is_Parent - (E1 : Entity_Id; - E2 : Entity_Id) return Boolean; - -- Determine whether E1 is a parent of E2. For a concurrent type, the - -- parent is the first element of its list of interface types; for other - -- types, this function provides the same result as Is_Ancestor. - function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean; -- Typ is a type entity. This function returns true if this type is -- partly initialized, meaning that an object of the type is at least --- 710,715 ---- *************** package Sem_Util is *** 701,706 **** --- 726,735 ---- -- persistent. A private type is potentially persistent if the full type -- is potentially persistent. + function Is_Protected_Self_Reference (N : Node_Id) return Boolean; + -- Return True if node N denotes a protected type name which represents + -- the current instance of a protected object according to RM 9.4(21/2). + function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean; -- Return True if a compilation unit is the specification or the -- body of a remote call interface package. *************** package Sem_Util is *** 720,726 **** function Is_Selector_Name (N : Node_Id) return Boolean; -- Given an N_Identifier node N, determines if it is a Selector_Name. -- As described in Sinfo, Selector_Names are special because they ! -- represent use of the N_Identifier node for a true identifer, when -- normally such nodes represent a direct name. function Is_Statement (N : Node_Id) return Boolean; --- 749,755 ---- function Is_Selector_Name (N : Node_Id) return Boolean; -- Given an N_Identifier node N, determines if it is a Selector_Name. -- As described in Sinfo, Selector_Names are special because they ! -- represent use of the N_Identifier node for a true identifier, when -- normally such nodes represent a direct name. function Is_Statement (N : Node_Id) return Boolean; *************** package Sem_Util is *** 768,781 **** -- entities in the current scope and in any parent scopes if the current -- scope is a block or a package (and that recursion continues to the top -- scope that is not a block or a package). This is used when the ! -- sequential flow-of-control assumption is violated (occurence of a label, ! -- head of a loop, or start of an exception handler). The effect of the ! -- call is to clear the Constant_Value field (but we do not need to clear ! -- the Is_True_Constant flag, since that only gets reset if there really is ! -- an assignment somewhere in the entity scope). This procedure also calls ! -- Kill_All_Checks, since this is a special case of needing to forget saved ! -- values. This procedure also clears Is_Known_Non_Null flags in variables, ! -- constants or parameters since these are also not known to be valid. -- -- The Last_Assignment_Only flag is set True to clear only Last_Assignment -- fields and leave other fields unchanged. This is used when we encounter --- 797,811 ---- -- entities in the current scope and in any parent scopes if the current -- scope is a block or a package (and that recursion continues to the top -- scope that is not a block or a package). This is used when the ! -- sequential flow-of-control assumption is violated (occurrence of a ! -- label, head of a loop, or start of an exception handler). The effect of ! -- the call is to clear the Constant_Value field (but we do not need to ! -- clear the Is_True_Constant flag, since that only gets reset if there ! -- really is an assignment somewhere in the entity scope). This procedure ! -- also calls Kill_All_Checks, since this is a special case of needing to ! -- forget saved values. This procedure also clears Is_Known_Non_Null flags ! -- in variables, constants or parameters since these are also not known to ! -- be valid. -- -- The Last_Assignment_Only flag is set True to clear only Last_Assignment -- fields and leave other fields unchanged. This is used when we encounter *************** package Sem_Util is *** 796,805 **** -- set if you want to clear only the Last_Assignment field (see above). procedure Kill_Size_Check_Code (E : Entity_Id); ! -- Called when an address clause or pragma Import is applied to an ! -- entity. If the entity is a variable or a constant, and size check ! -- code is present, this size check code is killed, since the object ! -- will not be allocated by the program. function Known_To_Be_Assigned (N : Node_Id) return Boolean; -- The node N is an entity reference. This function determines whether the --- 826,835 ---- -- set if you want to clear only the Last_Assignment field (see above). procedure Kill_Size_Check_Code (E : Entity_Id); ! -- Called when an address clause or pragma Import is applied to an entity. ! -- If the entity is a variable or a constant, and size check code is ! -- present, this size check code is killed, since the object will not ! -- be allocated by the program. function Known_To_Be_Assigned (N : Node_Id) return Boolean; -- The node N is an entity reference. This function determines whether the *************** package Sem_Util is *** 884,890 **** -- next entry of the Parameter_Associations list. The argument is an -- actual previously returned by a call to First_Actual or Next_Actual. -- Note that the result produced is always an expression, not a parameter ! -- assciation node, even if named notation was used. procedure Normalize_Actuals (N : Node_Id; --- 914,920 ---- -- next entry of the Parameter_Associations list. The argument is an -- actual previously returned by a call to First_Actual or Next_Actual. -- Note that the result produced is always an expression, not a parameter ! -- association node, even if named notation was used. procedure Normalize_Actuals (N : Node_Id; *************** package Sem_Util is *** 892,913 **** Report : Boolean; Success : out Boolean); -- Reorders lists of actuals according to names of formals, value returned ! -- in Success indicates sucess of reordering. For more details, see body. -- Errors are reported only if Report is set to True. ! procedure Note_Possible_Modification (N : Node_Id); -- This routine is called if the sub-expression N maybe the target of -- an assignment (e.g. it is the left side of an assignment, used as -- an out parameters, or used as prefixes of access attributes). It -- sets May_Be_Modified in the associated entity if there is one, -- taking into account the rule that in the case of renamed objects, -- it is the flag in the renamed object that must be set. function Object_Access_Level (Obj : Node_Id) return Uint; -- Return the accessibility level of the view of the object Obj. -- For convenience, qualified expressions applied to object names -- are also allowed as actuals for this function. function Private_Component (Type_Id : Entity_Id) return Entity_Id; -- Returns some private component (if any) of the given Type_Id. -- Used to enforce the rules on visibility of operations on composite --- 922,954 ---- Report : Boolean; Success : out Boolean); -- Reorders lists of actuals according to names of formals, value returned ! -- in Success indicates success of reordering. For more details, see body. -- Errors are reported only if Report is set to True. ! procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean); -- This routine is called if the sub-expression N maybe the target of -- an assignment (e.g. it is the left side of an assignment, used as -- an out parameters, or used as prefixes of access attributes). It -- sets May_Be_Modified in the associated entity if there is one, -- taking into account the rule that in the case of renamed objects, -- it is the flag in the renamed object that must be set. + -- + -- The parameter Sure is set True if the modification is sure to occur + -- (e.g. target of assignment, or out parameter), and to False if the + -- modification is only potential (e.g. address of entity taken). function Object_Access_Level (Obj : Node_Id) return Uint; -- Return the accessibility level of the view of the object Obj. -- For convenience, qualified expressions applied to object names -- are also allowed as actuals for this function. + function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean; + -- Returns True if the names of both entities correspond with matching + -- primitives. This routine includes support for the case in which one + -- or both entities correspond with entities built by Derive_Subprogram + -- with a special name to avoid being overridden (i.e. return true in case + -- of entities with names "nameP" and "name" or vice versa). + function Private_Component (Type_Id : Entity_Id) return Entity_Id; -- Returns some private component (if any) of the given Type_Id. -- Used to enforce the rules on visibility of operations on composite *************** package Sem_Util is *** 931,936 **** --- 972,980 ---- -- S is a possibly signed syntactically valid real literal. The result -- returned is an N_Real_Literal node representing the literal value. + procedure Remove_Homonym (E : Entity_Id); + -- Removes E from the homonym chain + function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id; -- This is used to construct the second argument in a call to Rep_To_Pos -- which is Standard_True if range checks are enabled (E is an entity to *************** package Sem_Util is *** 988,994 **** function Same_Object (Node1, Node2 : Node_Id) return Boolean; -- Determine if Node1 and Node2 are known to designate the same object. ! -- This is a semantic test and both nodesmust be fully analyzed. A result -- of True is decisively correct. A result of False does not necessarily -- mean that different objects are designated, just that this could not -- be reliably determined at compile time. --- 1032,1038 ---- function Same_Object (Node1, Node2 : Node_Id) return Boolean; -- Determine if Node1 and Node2 are known to designate the same object. ! -- This is a semantic test and both nodes must be fully analyzed. A result -- of True is decisively correct. A result of False does not necessarily -- mean that different objects are designated, just that this could not -- be reliably determined at compile time. *************** package Sem_Util is *** 1028,1033 **** --- 1072,1085 ---- -- Establish the entity E as the currently visible definition of its -- associated name (i.e. the Node_Id associated with its name) + procedure Set_Debug_Info_Needed (T : Entity_Id); + -- Sets the Debug_Info_Needed flag on entity T , and also on any entities + -- that are needed by T (for an object, the type of the object is needed, + -- and for a type, various subsidiary types are needed -- see body for + -- details). Never has any effect on T if the Debug_Info_Off flag is set. + -- This routine should always be used instead of Set_Needs_Debug_Info to + -- ensure that subsidiary entities are properly handled. + procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id); -- This procedure has the same calling sequence as Set_Entity, but -- if Style_Check is set, then it calls a style checking routine which *************** package Sem_Util is *** 1044,1049 **** --- 1096,1105 ---- -- parameters are already members of a list, and do not need to be -- chained separately. See also First_Actual and Next_Actual. + procedure Set_Optimize_Alignment_Flags (E : Entity_Id); + pragma Inline (Set_Optimize_Alignment_Flags); + -- Sets Optimize_Alignment_Space/Time flags in E from current settings + procedure Set_Public_Status (Id : Entity_Id); -- If an entity (visible or otherwise) is defined in a library -- package, or a package that is itself public, then this subprogram *************** package Sem_Util is *** 1092,1097 **** --- 1148,1157 ---- function Type_Access_Level (Typ : Entity_Id) return Uint; -- Return the accessibility level of Typ + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id; + -- Return the last entity in the chain of aliased entities of Prim. + -- If Prim has no alias return Prim. + function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id; -- Unit_Id is the simple name of a program unit, this function returns the -- corresponding xxx_Declaration node for the entity. Also applies to the diff -Nrcpad gcc-4.3.3/gcc/ada/sem_warn.adb gcc-4.4.0/gcc/ada/sem_warn.adb *** gcc-4.3.3/gcc/ada/sem_warn.adb Wed Dec 19 16:22:02 2007 --- gcc-4.4.0/gcc/ada/sem_warn.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2008, 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- -- *************** *** 23,29 **** -- -- ------------------------------------------------------------------------------ - with Alloc; with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; --- 23,28 ---- *************** with Opt; use Opt; *** 37,42 **** --- 36,42 ---- with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; + with Sem_Aux; use Sem_Aux; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; *************** with Sinput; use Sinput; *** 44,50 **** with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; - with Table; with Uintp; use Uintp; package body Sem_Warn is --- 44,49 ---- *************** package body Sem_Warn is *** 63,75 **** -- The following table collects potential warnings for IN OUT parameters -- that are referenced but not modified. These warnings are processed when ! -- the front end calls the procedure Output_Non_Modifed_In_Out_Warnings. -- The reason that we defer output of these messages is that we want to -- detect the case where the relevant procedure is used as a generic actual ! -- in an instantation, since we suppress the warnings in this case. The ! -- flag Used_As_Generic_Actual will be set in this case, but will not be ! -- set till later. Similarly, we suppress the message if the address of ! -- the procedure is taken, where the flag Address_Taken may be set later. package In_Out_Warnings is new Table.Table ( Table_Component_Type => Entity_Id, --- 62,74 ---- -- The following table collects potential warnings for IN OUT parameters -- that are referenced but not modified. These warnings are processed when ! -- the front end calls the procedure Output_Non_Modified_In_Out_Warnings. -- The reason that we defer output of these messages is that we want to -- detect the case where the relevant procedure is used as a generic actual ! -- in an instantiation, since we suppress the warnings in this case. The ! -- flag Used_As_Generic_Actual will be set in this case, but only at the ! -- point of usage. Similarly, we suppress the message if the address of the ! -- procedure is taken, where the flag Address_Taken may be set later. package In_Out_Warnings is new Table.Table ( Table_Component_Type => Entity_Id, *************** package body Sem_Warn is *** 79,84 **** --- 78,116 ---- Table_Increment => Alloc.In_Out_Warnings_Increment, Table_Name => "In_Out_Warnings"); + -------------------------------------------------------- + -- Handling of Warnings Off, Unmodified, Unreferenced -- + -------------------------------------------------------- + + -- The functions Has_Warnings_Off, Has_Unmodified, Has_Unreferenced must + -- generally be used instead of Warnings_Off, Has_Pragma_Unmodified and + -- Has_Pragma_Unreferenced, as noted in the specs in Einfo. + + -- In order to avoid losing warnings in -gnatw.w (warn on unnecessary + -- warnings off pragma) mode, i.e. to avoid false negatives, the code + -- must follow some important rules. + + -- Call these functions as late as possible, after completing all other + -- tests, just before the warnings is given. For example, don't write: + + -- if not Has_Warnings_Off (E) + -- and then some-other-predicate-on-E then .. + + -- Instead the following is preferred + + -- if some-other-predicate-on-E + -- and then Has_Warnings_Off (E) + + -- This way if some-other-predicate is false, we avoid a false indication + -- that a Warnings (Off,E) pragma was useful in preventing a warning. + + -- The second rule is that if both Has_Unmodified and Has_Warnings_Off, or + -- Has_Unreferenced and Has_Warnings_Off are called, make sure that the + -- call to Has_Unmodified/Has_Unreferenced comes first, this way we record + -- that the Warnings (Off) could have been Unreferenced or Unmodified. In + -- fact Has_Unmodified/Has_Unreferenced includes a test for Warnings Off, + -- and so a subsequent test is not needed anyway (though it is harmless). + ----------------------- -- Local Subprograms -- ----------------------- *************** package body Sem_Warn is *** 145,150 **** --- 177,186 ---- -- accept statement, and the message is posted on Body_E. In all other -- cases, Body_E is ignored and must be Empty. + function Warnings_Off_Check_Spec (E : Entity_Id) return Boolean; + -- Returns True if Warnings_Off is set for the entity E or (in the case + -- where there is a Spec_Entity), Warnings_Off is set for the Spec_Entity. + -------------------------- -- Check_Code_Statement -- -------------------------- *************** package body Sem_Warn is *** 275,289 **** if not Is_Entity_Name (Name (N)) then return; ! -- Forget it if warnings are suppressed on function entity ! elsif Warnings_Off (Entity (Name (N))) then return; ! -- Forget it if function name is suspicious. A strange test ! -- but warning generation is in the heuristics business! ! elsif Is_Suspicious_Function_Name (Entity (Name (N))) then return; end if; --- 311,325 ---- if not Is_Entity_Name (Name (N)) then return; ! -- Forget it if function name is suspicious. A strange test ! -- but warning generation is in the heuristics business! ! elsif Is_Suspicious_Function_Name (Entity (Name (N))) then return; ! -- Forget it if warnings are suppressed on function entity ! elsif Has_Warnings_Off (Entity (Name (N))) then return; end if; *************** package body Sem_Warn is *** 575,581 **** (E : Entity_Id; Accept_Statement : Node_Id) return Entity_Id; -- For an entry formal entity from an entry declaration, find the ! -- corrsesponding body formal from the given accept statement. function Missing_Subunits return Boolean; -- We suppress warnings when there are missing subunits, because this --- 611,617 ---- (E : Entity_Id; Accept_Statement : Node_Id) return Entity_Id; -- For an entry formal entity from an entry declaration, find the ! -- corresponding body formal from the given accept statement. function Missing_Subunits return Boolean; -- We suppress warnings when there are missing subunits, because this *************** package body Sem_Warn is *** 592,597 **** --- 628,667 ---- -- from another unit. This is true for entities in packages that are at -- the library level. + function Warnings_Off_E1 return Boolean; + -- Return True if Warnings_Off is set for E1, or for its Etype (E1T), + -- or for the base type of E1T. + + ----------------- + -- Body_Formal -- + ----------------- + + function Body_Formal + (E : Entity_Id; + Accept_Statement : Node_Id) return Entity_Id + is + Body_Param : Node_Id; + Body_E : Entity_Id; + + begin + -- Loop to find matching parameter in accept statement + + Body_Param := First (Parameter_Specifications (Accept_Statement)); + while Present (Body_Param) loop + Body_E := Defining_Identifier (Body_Param); + + if Chars (Body_E) = Chars (E) then + return Body_E; + end if; + + Next (Body_Param); + end loop; + + -- Should never fall through, should always find a match + + raise Program_Error; + end Body_Formal; + ---------------------- -- Missing_Subunits -- ---------------------- *************** package body Sem_Warn is *** 634,669 **** end if; end Missing_Subunits; - ----------------- - -- Body_Formal -- - ----------------- - - function Body_Formal - (E : Entity_Id; - Accept_Statement : Node_Id) return Entity_Id - is - Body_Param : Node_Id; - Body_E : Entity_Id; - - begin - -- Loop to find matching parameter in accept statement - - Body_Param := First (Parameter_Specifications (Accept_Statement)); - while Present (Body_Param) loop - Body_E := Defining_Identifier (Body_Param); - - if Chars (Body_E) = Chars (E) then - return Body_E; - end if; - - Next (Body_Param); - end loop; - - -- Should never fall through, should always find a match - - raise Program_Error; - end Body_Formal; - ---------------------------- -- Output_Reference_Error -- ---------------------------- --- 704,709 ---- *************** package body Sem_Warn is *** 790,795 **** --- 830,846 ---- end loop; end Publicly_Referenceable; + --------------------- + -- Warnings_Off_E1 -- + --------------------- + + function Warnings_Off_E1 return Boolean is + begin + return Has_Warnings_Off (E1T) + or else Has_Warnings_Off (Base_Type (E1T)) + or else Warnings_Off_Check_Spec (E1); + end Warnings_Off_E1; + -- Start of processing for Check_References begin *************** package body Sem_Warn is *** 817,831 **** while Present (E1) loop E1T := Etype (E1); ! -- We only look at source entities with warning flag on. We also ! -- ignore objects whose type or base type has warnings suppressed. ! -- We also don't issue warnings within instances, since the proper ! -- place for such warnings is on the template when it is compiled. if Comes_From_Source (E1) - and then not Warnings_Off (E1) - and then not Warnings_Off (E1T) - and then not Warnings_Off (Base_Type (E1T)) and then Instantiation_Location (Sloc (E1)) = No_Location then -- We are interested in variables and out/in-out parameters, but --- 868,878 ---- while Present (E1) loop E1T := Etype (E1); ! -- We are only interested in source entities. We also don't issue ! -- warnings within instances, since the proper place for such ! -- warnings is on the template when it is compiled. if Comes_From_Source (E1) and then Instantiation_Location (Sloc (E1)) = No_Location then -- We are interested in variables and out/in-out parameters, but *************** package body Sem_Warn is *** 850,867 **** UR := Unset_Reference (E1); end if; - -- If the entity is an out parameter of the current subprogram - -- body, check the warning status of the parameter in the spec. - - if Is_Formal (E1) - and then Present (Spec_Entity (E1)) - and then Warnings_Off (Spec_Entity (E1)) - then - null; - -- Special processing for access types ! elsif Present (UR) and then Is_Access_Type (E1T) then -- For access types, the only time we made a UR entry was --- 897,905 ---- UR := Unset_Reference (E1); end if; -- Special processing for access types ! if Present (UR) and then Is_Access_Type (E1T) then -- For access types, the only time we made a UR entry was *************** package body Sem_Warn is *** 872,878 **** -- assignment of a pointer involving discriminant check -- on the designated object). ! Error_Msg_NE ("?& may be null!", UR, E1); goto Continue; -- Case of variable that could be a constant. Note that we --- 910,919 ---- -- assignment of a pointer involving discriminant check -- on the designated object). ! if not Warnings_Off_E1 then ! Error_Msg_NE ("?& may be null!", UR, E1); ! end if; ! goto Continue; -- Case of variable that could be a constant. Note that we *************** package body Sem_Warn is *** 916,925 **** and then not Has_Pragma_Unreferenced_Check_Spec (E1) and then not Has_Pragma_Unmodified_Check_Spec (E1) then ! Error_Msg_N ! ("?& is not modified, " ! & "could be declared constant!", ! E1); end if; end if; end if; --- 957,968 ---- and then not Has_Pragma_Unreferenced_Check_Spec (E1) and then not Has_Pragma_Unmodified_Check_Spec (E1) then ! if not Warnings_Off_E1 then ! Error_Msg_N ! ("?& is not modified, " ! & "could be declared constant!", ! E1); ! end if; end if; end if; end if; *************** package body Sem_Warn is *** 959,970 **** or else not Is_Fully_Initialized_Type (E1T)) then -- Do not output complaint about never being assigned a ! -- value if a pragma Unreferenced applies to the variable -- we are examining, or if it is a parameter, if there is ! -- a pragma Unreferenced for the corresponding spec. ! if Has_Pragma_Unreferenced_Check_Spec (E1) ! or else Has_Pragma_Unreferenced_Objects (E1T) then null; --- 1002,1016 ---- or else not Is_Fully_Initialized_Type (E1T)) then -- Do not output complaint about never being assigned a ! -- value if a pragma Unmodified applies to the variable -- we are examining, or if it is a parameter, if there is ! -- a pragma Unreferenced for the corresponding spec, of ! -- if the type is marked as having unreferenced objects. ! -- The last is a little peculiar, but better too few than ! -- too many warnings in this situation. ! if Has_Pragma_Unreferenced_Objects (E1T) ! or else Has_Pragma_Unmodified_Check_Spec (E1) then null; *************** package body Sem_Warn is *** 979,991 **** -- Suppress warning if private type, and the procedure -- has a separate declaration in a different unit. This -- is the case where the client of a package sees only ! -- the private type, and it it may be quite reasonable -- for the logical view to be in out, even if the -- implementation ends up using access types or some -- other method to achieve the local effect of a -- modification. On the other hand if the spec and body -- are in the same unit, we are in the package body and ! -- there we less excuse for a junk IN OUT parameter. if Has_Private_Declaration (E1T) and then Present (Spec_Entity (E1)) --- 1025,1037 ---- -- Suppress warning if private type, and the procedure -- has a separate declaration in a different unit. This -- is the case where the client of a package sees only ! -- the private type, and it may be quite reasonable -- for the logical view to be in out, even if the -- implementation ends up using access types or some -- other method to achieve the local effect of a -- modification. On the other hand if the spec and body -- are in the same unit, we are in the package body and ! -- there we have less excuse for a junk IN OUT parameter. if Has_Private_Declaration (E1T) and then Present (Spec_Entity (E1)) *************** package body Sem_Warn is *** 996,1003 **** -- Suppress warning for any parameter of a dispatching -- operation, since it is quite reasonable to have an -- operation that is overridden, and for some subclasses ! -- needs to be IN OUT and for others the parameter does ! -- not happen to be assigned. elsif Is_Dispatching_Operation (Scope (Goto_Spec_Entity (E1))) --- 1042,1049 ---- -- Suppress warning for any parameter of a dispatching -- operation, since it is quite reasonable to have an -- operation that is overridden, and for some subclasses ! -- needs the formal to be IN OUT and for others happens ! -- not to assign it. elsif Is_Dispatching_Operation (Scope (Goto_Spec_Entity (E1))) *************** package body Sem_Warn is *** 1021,1027 **** -- actual, or its address/access is taken. In these two -- cases, we suppress the warning because the context may -- force use of IN OUT, even if in this particular case ! -- the formal is not modifed. else In_Out_Warnings.Append (E1); --- 1067,1073 ---- -- actual, or its address/access is taken. In these two -- cases, we suppress the warning because the context may -- force use of IN OUT, even if in this particular case ! -- the formal is not modified. else In_Out_Warnings.Append (E1); *************** package body Sem_Warn is *** 1030,1054 **** -- Other cases of formals elsif Is_Formal (E1) then ! if Referenced_Check_Spec (E1) then ! if not Has_Pragma_Unmodified_Check_Spec (E1) then Output_Reference_Error ! ("?formal parameter& is read but " ! & "never assigned!"); end if; - - else - Output_Reference_Error - ("?formal parameter& is not referenced!"); end if; -- Case of variable else if Referenced (E1) then ! Output_Reference_Error ! ("?variable& is read but never assigned!"); ! else Output_Reference_Error ("?variable& is never read and never assigned!"); end if; --- 1076,1113 ---- -- Other cases of formals elsif Is_Formal (E1) then ! if not Is_Trivial_Subprogram (Scope (E1)) then ! if Referenced_Check_Spec (E1) then ! if not Has_Pragma_Unmodified_Check_Spec (E1) ! and then not Warnings_Off_E1 ! then ! Output_Reference_Error ! ("?formal parameter& is read but " ! & "never assigned!"); ! end if; ! ! elsif not Has_Pragma_Unreferenced_Check_Spec (E1) ! and then not Warnings_Off_E1 ! then Output_Reference_Error ! ("?formal parameter& is not referenced!"); end if; end if; -- Case of variable else if Referenced (E1) then ! if not Has_Unmodified (E1) ! and then not Warnings_Off_E1 ! then ! Output_Reference_Error ! ("?variable& is read but never assigned!"); ! end if; ! ! elsif not Has_Unreferenced (E1) ! and then not Warnings_Off_E1 ! then Output_Reference_Error ("?variable& is never read and never assigned!"); end if; *************** package body Sem_Warn is *** 1058,1063 **** --- 1117,1123 ---- if Ekind (E1) = E_Variable and then Present (Hiding_Loop_Variable (E1)) + and then not Warnings_Off_E1 then Error_Msg_N ("?for loop implicitly declares loop variable!", *************** package body Sem_Warn is *** 1100,1161 **** -- are only for functions, and functions do not allow OUT -- parameters.) ! if Nkind (UR) = N_Simple_Return_Statement ! and then not Has_Pragma_Unmodified_Check_Spec (E1) ! then ! Error_Msg_NE ! ("?OUT parameter& not set before return", UR, E1); ! -- If the unset reference is prefix of a selected component ! -- that comes from source, mention the component as well. If ! -- the selected component comes from expansion, all we know ! -- is that the entity is not fully initialized at the point ! -- of the reference. Locate an unintialized component to get ! -- a better error message. ! elsif Nkind (Parent (UR)) = N_Selected_Component then ! Error_Msg_Node_2 := Selector_Name (Parent (UR)); ! if not Comes_From_Source (Parent (UR)) then ! declare ! Comp : Entity_Id; ! begin ! Comp := First_Entity (E1T); ! while Present (Comp) loop ! if Ekind (Comp) = E_Component ! and then Nkind (Parent (Comp)) = ! N_Component_Declaration ! and then No (Expression (Parent (Comp))) ! then ! Error_Msg_Node_2 := Comp; ! exit; ! end if; ! Next_Entity (Comp); ! end loop; ! end; ! end if; ! -- Issue proper warning. This is a case of referencing ! -- a variable before it has been explicitly assigned. ! -- For access types, UR was only set for dereferences, ! -- so the issue is that the value may be null. ! if Is_Access_Type (Etype (Parent (UR))) then ! Error_Msg_N ("?`&.&` may be null!", UR); ! else Error_Msg_N ! ("?`&.&` may be referenced before it has a value!", UR); end if; - - -- All other cases of unset reference active - - else - Error_Msg_N - ("?& may be referenced before it has a value!", - UR); end if; goto Continue; --- 1160,1229 ---- -- are only for functions, and functions do not allow OUT -- parameters.) ! if not Is_Trivial_Subprogram (Scope (E1)) then ! if Nkind (UR) = N_Simple_Return_Statement ! and then not Has_Pragma_Unmodified_Check_Spec (E1) ! then ! if not Warnings_Off_E1 then ! Error_Msg_NE ! ("?OUT parameter& not set before return", UR, E1); ! end if; ! -- If the unset reference is a selected component ! -- prefix from source, mention the component as well. ! -- If the selected component comes from expansion, all ! -- we know is that the entity is not fully initialized ! -- at the point of the reference. Locate a random ! -- uninitialized component to get a better message. ! elsif Nkind (Parent (UR)) = N_Selected_Component then ! Error_Msg_Node_2 := Selector_Name (Parent (UR)); ! if not Comes_From_Source (Parent (UR)) then ! declare ! Comp : Entity_Id; ! begin ! Comp := First_Entity (E1T); ! while Present (Comp) loop ! if Ekind (Comp) = E_Component ! and then Nkind (Parent (Comp)) = ! N_Component_Declaration ! and then No (Expression (Parent (Comp))) ! then ! Error_Msg_Node_2 := Comp; ! exit; ! end if; ! Next_Entity (Comp); ! end loop; ! end; ! end if; ! -- Issue proper warning. This is a case of referencing ! -- a variable before it has been explicitly assigned. ! -- For access types, UR was only set for dereferences, ! -- so the issue is that the value may be null. ! if not Is_Trivial_Subprogram (Scope (E1)) then ! if not Warnings_Off_E1 then ! if Is_Access_Type (Etype (Parent (UR))) then ! Error_Msg_N ("?`&.&` may be null!", UR); ! else ! Error_Msg_N ! ("?`&.&` may be referenced before " ! & "it has a value!", UR); ! end if; ! end if; ! end if; ! ! -- All other cases of unset reference active ! ! elsif not Warnings_Off_E1 then Error_Msg_N ! ("?& may be referenced before it has a value!", UR); end if; end if; goto Continue; *************** package body Sem_Warn is *** 1163,1174 **** end if; -- Then check for unreferenced entities. Note that we are only ! -- interested in entities which do not have the Referenced flag ! -- set. The Referenced_As_LHS flag is interesting only if the ! -- Referenced flag is not set. if not Referenced_Check_Spec (E1) -- Check that warnings on unreferenced entities are enabled and then --- 1231,1247 ---- end if; -- Then check for unreferenced entities. Note that we are only ! -- interested in entities whose Referenced flag is not set. if not Referenced_Check_Spec (E1) + -- If Referenced_As_LHS is set, then that's still interesting + -- (potential "assigned but never read" case), but not if we + -- have pragma Unreferenced, which cancels this error. + + and then (not Referenced_As_LHS_Check_Spec (E1) + or else not Has_Unreferenced (E1)) + -- Check that warnings on unreferenced entities are enabled and then *************** package body Sem_Warn is *** 1221,1231 **** or else (Ekind (E1) = E_Package and then ! Ekind (Cunit_Entity (Current_Sem_Unit)) /= ! E_Package ! and then ! Ekind (Cunit_Entity (Current_Sem_Unit)) /= ! E_Generic_Package)) -- Exclude instantiations, since there is no reason why every -- entity in an instantiation should be referenced. --- 1294,1301 ---- or else (Ekind (E1) = E_Package and then ! not Is_Package_Or_Generic_Package ! (Cunit_Entity (Current_Sem_Unit)))) -- Exclude instantiations, since there is no reason why every -- entity in an instantiation should be referenced. *************** package body Sem_Warn is *** 1324,1333 **** -- The unreferenced entity is E1, but post the warning -- on the body entity for this accept statement. ! Warn_On_Unreferenced_Entity ! (E1, Body_Formal (E1, Accept_Statement => Anod)); ! else Unreferenced_Entities.Append (E1); end if; end if; --- 1394,1405 ---- -- The unreferenced entity is E1, but post the warning -- on the body entity for this accept statement. ! if not Warnings_Off_E1 then ! Warn_On_Unreferenced_Entity ! (E1, Body_Formal (E1, Accept_Statement => Anod)); ! end if; ! elsif not Warnings_Off_E1 then Unreferenced_Entities.Append (E1); end if; end if; *************** package body Sem_Warn is *** 1343,1361 **** and then Instantiation_Depth (Sloc (E1)) = 0 and then Warn_On_Redundant_Constructs then ! Unreferenced_Entities.Append (E1); -- Force warning on entity ! Set_Referenced (E1, False); end if; end if; -- Recurse into nested package or block. Do not recurse into a ! -- formal package, because the correponding body is not analyzed. <> ! if ((Ekind (E1) = E_Package or else Ekind (E1) = E_Generic_Package) and then Nkind (Parent (E1)) = N_Package_Specification and then Nkind (Original_Node (Unit_Declaration_Node (E1))) --- 1415,1435 ---- and then Instantiation_Depth (Sloc (E1)) = 0 and then Warn_On_Redundant_Constructs then ! if not Warnings_Off_E1 then ! Unreferenced_Entities.Append (E1); -- Force warning on entity ! Set_Referenced (E1, False); ! end if; end if; end if; -- Recurse into nested package or block. Do not recurse into a ! -- formal package, because the corresponding body is not analyzed. <> ! if (Is_Package_Or_Generic_Package (E1) and then Nkind (Parent (E1)) = N_Package_Specification and then Nkind (Original_Node (Unit_Declaration_Node (E1))) *************** package body Sem_Warn is *** 1462,1468 **** case Nkind (N) is ! -- For identifier or exanded name, examine the entity involved when N_Identifier | N_Expanded_Name => declare --- 1536,1542 ---- case Nkind (N) is ! -- For identifier or expanded name, examine the entity involved when N_Identifier | N_Expanded_Name => declare *************** package body Sem_Warn is *** 1478,1484 **** or else Earlier_In_Extended_Unit (Sloc (N), Sloc (Unset_Reference (E)))) ! and then not Warnings_Off (E) then -- We may have an unset reference. The first test is whether -- this is an access to a discriminant of a record or a --- 1552,1559 ---- or else Earlier_In_Extended_Unit (Sloc (N), Sloc (Unset_Reference (E)))) ! and then not Has_Pragma_Unmodified_Check_Spec (E) ! and then not Warnings_Off_Check_Spec (E) then -- We may have an unset reference. The first test is whether -- this is an access to a discriminant of a record or a *************** package body Sem_Warn is *** 1558,1564 **** function Process (N : Node_Id) return Traverse_Result; ! -- Process function for instantation of Traverse -- below. Checks if N contains reference to other -- than a dereference. --- 1633,1639 ---- function Process (N : Node_Id) return Traverse_Result; ! -- Process function for instantiation of Traverse -- below. Checks if N contains reference to other -- than a dereference. *************** package body Sem_Warn is *** 1804,1810 **** -- The only reference to a context unit may be in a renaming -- declaration. If this renaming declares a visible entity, do -- not warn that the context clause could be moved to the body, ! -- because the renaming may be intented to re-export the unit. ------------------------- -- Check_Inner_Package -- --- 1879,1885 ---- -- The only reference to a context unit may be in a renaming -- declaration. If this renaming declares a visible entity, do -- not warn that the context clause could be moved to the body, ! -- because the renaming may be intended to re-export the unit. ------------------------- -- Check_Inner_Package -- *************** package body Sem_Warn is *** 1967,1973 **** -- is explicitly marked by a pragma Unreferenced). if not Referenced (Lunit) ! and then not Has_Pragma_Unreferenced (Lunit) then -- Suppress warnings in internal units if not in -gnatg mode -- (these would be junk warnings for an application program, --- 2042,2048 ---- -- is explicitly marked by a pragma Unreferenced). if not Referenced (Lunit) ! and then not Has_Unreferenced (Lunit) then -- Suppress warnings in internal units if not in -gnatg mode -- (these would be junk warnings for an application program, *************** package body Sem_Warn is *** 2060,2067 **** -- Else give the warning else ! if not Has_Pragma_Unreferenced ! (Entity (Name (Item))) then Error_Msg_N ("?no entities of & are referenced!", --- 2135,2142 ---- -- Else give the warning else ! if not ! Has_Unreferenced (Entity (Name (Item))) then Error_Msg_N ("?no entities of & are referenced!", *************** package body Sem_Warn is *** 2076,2083 **** Pack := Find_Package_Renaming (Munite, Lunit); if Present (Pack) ! and then not Warnings_Off (Lunit) ! and then not Has_Pragma_Unreferenced (Pack) then Error_Msg_NE ("?no entities of & are referenced!", --- 2151,2158 ---- Pack := Find_Package_Renaming (Munite, Lunit); if Present (Pack) ! and then not Has_Warnings_Off (Lunit) ! and then not Has_Unreferenced (Pack) then Error_Msg_NE ("?no entities of & are referenced!", *************** package body Sem_Warn is *** 2276,2286 **** is begin if Is_Formal (E) and then Present (Spec_Entity (E)) then ! return Has_Pragma_Unmodified (E) ! or else ! Has_Pragma_Unmodified (Spec_Entity (E)); else ! return Has_Pragma_Unmodified (E); end if; end Has_Pragma_Unmodified_Check_Spec; --- 2351,2366 ---- is begin if Is_Formal (E) and then Present (Spec_Entity (E)) then ! ! -- Note: use of OR instead of OR ELSE here is deliberate, we want ! -- to mess with Unmodified flags on both body and spec entities. ! ! return Has_Unmodified (E) ! or ! Has_Unmodified (Spec_Entity (E)); ! else ! return Has_Unmodified (E); end if; end Has_Pragma_Unmodified_Check_Spec; *************** package body Sem_Warn is *** 2293,2306 **** is begin if Is_Formal (E) and then Present (Spec_Entity (E)) then ! return Has_Pragma_Unreferenced (E) ! or else ! Has_Pragma_Unreferenced (Spec_Entity (E)); else ! return Has_Pragma_Unreferenced (E); end if; end Has_Pragma_Unreferenced_Check_Spec; ------------------------------------ -- Never_Set_In_Source_Check_Spec -- ------------------------------------ --- 2373,2402 ---- is begin if Is_Formal (E) and then Present (Spec_Entity (E)) then ! ! -- Note: use of OR here instead of OR ELSE is deliberate, we want ! -- to mess with flags on both entities. ! ! return Has_Unreferenced (E) ! or ! Has_Unreferenced (Spec_Entity (E)); ! else ! return Has_Unreferenced (E); end if; end Has_Pragma_Unreferenced_Check_Spec; + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Warnings_Off_Pragmas.Init; + Unreferenced_Entities.Init; + In_Out_Warnings.Init; + end Initialize; + ------------------------------------ -- Never_Set_In_Source_Check_Spec -- ------------------------------------ *************** package body Sem_Warn is *** 2341,2347 **** begin if Nkind (R) in N_Has_Entity and then Present (Entity (R)) ! and then Warnings_Off (Entity (R)) then return Abandon; else --- 2437,2443 ---- begin if Nkind (R) in N_Has_Entity and then Present (Entity (R)) ! and then Has_Warnings_Off (Entity (R)) then return Abandon; else *************** package body Sem_Warn is *** 2383,2404 **** ----------------------- function No_Warn_On_In_Out (E : Entity_Id) return Boolean is ! S : constant Entity_Id := Scope (E); begin ! if Warnings_Off (S) then return True; ! elsif Address_Taken (S) then return True; ! elsif Used_As_Generic_Actual (S) then return True; ! elsif Present (Spec_Entity (E)) then ! return No_Warn_On_In_Out (Spec_Entity (E)); else return False; end if; end No_Warn_On_In_Out; ! -- Start of processing for Output_Non_Modifed_In_Out_Warnings begin -- Loop through entities for which a warning may be needed --- 2479,2517 ---- ----------------------- function No_Warn_On_In_Out (E : Entity_Id) return Boolean is ! S : constant Entity_Id := Scope (E); ! SE : constant Entity_Id := Spec_Entity (E); ! begin ! -- Do not warn if address is taken, since funny business may be going ! -- on in treating the parameter indirectly as IN OUT. ! ! if Address_Taken (S) ! or else (Present (SE) and then Address_Taken (Scope (SE))) ! then return True; ! ! -- Do not warn if used as a generic actual, since the generic may be ! -- what is forcing the use of an "unnecessary" IN OUT. ! ! elsif Used_As_Generic_Actual (S) ! or else (Present (SE) and then Used_As_Generic_Actual (Scope (SE))) ! then return True; ! ! -- Else test warnings off ! ! elsif Warnings_Off_Check_Spec (S) then return True; ! ! -- All tests for suppressing warning failed ! else return False; end if; end No_Warn_On_In_Out; ! -- Start of processing for Output_Non_Modified_In_Out_Warnings begin -- Loop through entities for which a warning may be needed *************** package body Sem_Warn is *** 2411,2418 **** -- Suppress warning in specific cases (see details in comments for -- No_Warn_On_In_Out), or if there is a pragma Unmodified. ! if No_Warn_On_In_Out (E1) ! or else Has_Pragma_Unmodified_Check_Spec (E1) then null; --- 2524,2531 ---- -- Suppress warning in specific cases (see details in comments for -- No_Warn_On_In_Out), or if there is a pragma Unmodified. ! if Has_Pragma_Unmodified_Check_Spec (E1) ! or else No_Warn_On_In_Out (E1) then null; *************** package body Sem_Warn is *** 2421,2438 **** else -- If -gnatwc is set then output message that we could be IN ! if Warn_On_Constant then ! Error_Msg_N ("?formal parameter & is not modified!", E1); ! Error_Msg_N ("\?mode could be IN instead of `IN OUT`!", E1); ! -- We do not generate warnings for IN OUT parameters unless we ! -- have at least -gnatwu. This is deliberately inconsistent ! -- with the treatment of variables, but otherwise we get too ! -- many unexpected warnings in default mode. ! elsif Check_Unreferenced then ! Error_Msg_N ("?formal parameter& is read but " ! & "never assigned!", E1); end if; -- Kill any other warnings on this entity, since this is the --- 2534,2556 ---- else -- If -gnatwc is set then output message that we could be IN ! if not Is_Trivial_Subprogram (Scope (E1)) then ! if Warn_On_Constant then ! Error_Msg_N ! ("?formal parameter & is not modified!", E1); ! Error_Msg_N ! ("\?mode could be IN instead of `IN OUT`!", E1); ! -- We do not generate warnings for IN OUT parameters ! -- unless we have at least -gnatwu. This is deliberately ! -- inconsistent with the treatment of variables, but ! -- otherwise we get too many unexpected warnings in ! -- default mode. ! elsif Check_Unreferenced then ! Error_Msg_N ("?formal parameter& is read but " ! & "never assigned!", E1); ! end if; end if; -- Kill any other warnings on this entity, since this is the *************** package body Sem_Warn is *** 2560,2590 **** -- Output additional warning if present ! declare ! W : constant Node_Id := Obsolescent_Warning (E); ! ! begin ! if Present (W) then ! ! -- This is a warning continuation to start on a new line ! Name_Buffer (1) := '\'; ! Name_Buffer (2) := '\'; ! Name_Buffer (3) := '?'; ! Name_Len := 3; ! ! -- Add characters to message, and output message. Note that ! -- we quote every character of the message since we don't ! -- want to process any insertions. ! ! for J in 1 .. String_Length (Strval (W)) loop ! Add_Char_To_Name_Buffer ('''); ! Add_Char_To_Name_Buffer ! (Get_Character (Get_String_Char (Strval (W), J))); ! end loop; ! ! Error_Msg_N (Name_Buffer (1 .. Name_Len), N); end if; ! end; end Output_Obsolescent_Entity_Warnings; ---------------------------------- --- 2678,2692 ---- -- Output additional warning if present ! for J in Obsolescent_Warnings.First .. Obsolescent_Warnings.Last loop ! if Obsolescent_Warnings.Table (J).Ent = E then ! String_To_Name_Buffer (Obsolescent_Warnings.Table (J).Msg); ! Error_Msg_Strlen := Name_Len; ! Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); ! Error_Msg_N ("\\?~", N); ! exit; end if; ! end loop; end Output_Obsolescent_Entity_Warnings; ---------------------------------- *************** package body Sem_Warn is *** 2600,2605 **** --- 2702,2763 ---- end loop; end Output_Unreferenced_Messages; + ----------------------------------------- + -- Output_Unused_Warnings_Off_Warnings -- + ----------------------------------------- + + procedure Output_Unused_Warnings_Off_Warnings is + begin + for J in Warnings_Off_Pragmas.First .. Warnings_Off_Pragmas.Last loop + declare + Wentry : Warnings_Off_Entry renames Warnings_Off_Pragmas.Table (J); + N : Node_Id renames Wentry.N; + E : Node_Id renames Wentry.E; + + begin + -- Turn off Warnings_Off, or we won't get the warning! + + Set_Warnings_Off (E, False); + + -- Nothing to do if pragma was used to suppress a general warning + + if Warnings_Off_Used (E) then + null; + + -- If pragma was used both in unmodified and unreferenced contexts + -- then that's as good as the general case, no warning. + + elsif Warnings_Off_Used_Unmodified (E) + and + Warnings_Off_Used_Unreferenced (E) + then + null; + + -- Used only in context where Unmodified would have worked + + elsif Warnings_Off_Used_Unmodified (E) then + Error_Msg_NE + ("?could use Unmodified instead of " + & "Warnings Off for &", Pragma_Identifier (N), E); + + -- Used only in context where Unreferenced would have worked + + elsif Warnings_Off_Used_Unreferenced (E) then + Error_Msg_NE + ("?could use Unreferenced instead of " + & "Warnings Off for &", Pragma_Identifier (N), E); + + -- Not used at all + + else + Error_Msg_NE + ("?pragma Warnings Off for & unused, " + & "could be omitted", N, E); + end if; + end; + end loop; + end Output_Unused_Warnings_Off_Warnings; + --------------------------- -- Referenced_Check_Spec -- --------------------------- *************** package body Sem_Warn is *** 2656,2679 **** --- 2814,2887 ---- when 'A' => Warn_On_Assertion_Failure := False; + when 'b' => + Warn_On_Biased_Representation := True; + + when 'B' => + Warn_On_Biased_Representation := False; + when 'c' => Warn_On_Unrepped_Components := True; when 'C' => Warn_On_Unrepped_Components := False; + when 'e' => + Address_Clause_Overlay_Warnings := True; + Check_Unreferenced := True; + Check_Unreferenced_Formals := True; + Check_Withs := True; + Constant_Condition_Warnings := True; + Elab_Warnings := True; + Implementation_Unit_Warnings := True; + Ineffective_Inline_Warnings := True; + Warn_On_Ada_2005_Compatibility := True; + Warn_On_All_Unread_Out_Parameters := True; + Warn_On_Assertion_Failure := True; + Warn_On_Assumed_Low_Bound := True; + Warn_On_Bad_Fixed_Value := True; + Warn_On_Biased_Representation := True; + Warn_On_Constant := True; + Warn_On_Deleted_Code := True; + Warn_On_Dereference := True; + Warn_On_Export_Import := True; + Warn_On_Hiding := True; + Warn_On_Modified_Unread := True; + Warn_On_No_Value_Assigned := True; + Warn_On_Non_Local_Exception := True; + Warn_On_Object_Renames_Function := True; + Warn_On_Obsolescent_Feature := True; + Warn_On_Questionable_Missing_Parens := True; + Warn_On_Redundant_Constructs := True; + Warn_On_Unchecked_Conversion := True; + Warn_On_Unrecognized_Pragma := True; + Warn_On_Unrepped_Components := True; + Warn_On_Warnings_Off := True; + when 'o' => Warn_On_All_Unread_Out_Parameters := True; when 'O' => Warn_On_All_Unread_Out_Parameters := False; + when 'p' => + Warn_On_Parameter_Order := True; + + when 'P' => + Warn_On_Parameter_Order := False; + when 'r' => Warn_On_Object_Renames_Function := True; when 'R' => Warn_On_Object_Renames_Function := False; + when 'w' => + Warn_On_Warnings_Off := True; + + when 'W' => + Warn_On_Warnings_Off := False; + when 'x' => Warn_On_Non_Local_Exception := True; *************** package body Sem_Warn is *** 2705,2719 **** Warn_On_Assertion_Failure := True; Warn_On_Assumed_Low_Bound := True; Warn_On_Bad_Fixed_Value := True; Warn_On_Constant := True; Warn_On_Export_Import := True; Warn_On_Modified_Unread := True; Warn_On_No_Value_Assigned := True; Warn_On_Non_Local_Exception := True; Warn_On_Obsolescent_Feature := True; Warn_On_Questionable_Missing_Parens := True; Warn_On_Redundant_Constructs := True; - Warn_On_Object_Renames_Function := True; Warn_On_Unchecked_Conversion := True; Warn_On_Unrecognized_Pragma := True; Warn_On_Unrepped_Components := True; --- 2913,2929 ---- Warn_On_Assertion_Failure := True; Warn_On_Assumed_Low_Bound := True; Warn_On_Bad_Fixed_Value := True; + Warn_On_Biased_Representation := True; Warn_On_Constant := True; Warn_On_Export_Import := True; Warn_On_Modified_Unread := True; Warn_On_No_Value_Assigned := True; Warn_On_Non_Local_Exception := True; + Warn_On_Object_Renames_Function := True; Warn_On_Obsolescent_Feature := True; + Warn_On_Parameter_Order := True; Warn_On_Questionable_Missing_Parens := True; Warn_On_Redundant_Constructs := True; Warn_On_Unchecked_Conversion := True; Warn_On_Unrecognized_Pragma := True; Warn_On_Unrepped_Components := True; *************** package body Sem_Warn is *** 2730,2735 **** --- 2940,2946 ---- Warn_On_Assertion_Failure := False; Warn_On_Assumed_Low_Bound := False; Warn_On_Bad_Fixed_Value := False; + Warn_On_Biased_Representation := False; Warn_On_Constant := False; Warn_On_Deleted_Code := False; Warn_On_Dereference := False; *************** package body Sem_Warn is *** 2740,2751 **** --- 2951,2964 ---- Warn_On_Non_Local_Exception := False; Warn_On_Obsolescent_Feature := False; Warn_On_All_Unread_Out_Parameters := False; + Warn_On_Parameter_Order := False; Warn_On_Questionable_Missing_Parens := False; Warn_On_Redundant_Constructs := False; Warn_On_Object_Renames_Function := False; Warn_On_Unchecked_Conversion := False; Warn_On_Unrecognized_Pragma := False; Warn_On_Unrepped_Components := False; + Warn_On_Warnings_Off := False; when 'b' => Warn_On_Bad_Fixed_Value := True; *************** package body Sem_Warn is *** 2991,3003 **** then return; ! -- Don't warn in assert pragma, since presumably tests in such ! -- a context are very definitely intended, and might well be -- known at compile time. Note that we have to test the original -- node, since assert pragmas get rewritten at analysis time. elsif Nkind (Original_Node (P)) = N_Pragma ! and then Chars (Original_Node (P)) = Name_Assert then return; end if; --- 3204,3218 ---- then return; ! -- Don't warn in assert or check pragma, since presumably tests in ! -- such a context are very definitely intended, and might well be -- known at compile time. Note that we have to test the original -- node, since assert pragmas get rewritten at analysis time. elsif Nkind (Original_Node (P)) = N_Pragma ! and then (Pragma_Name (Original_Node (P)) = Name_Assert ! or else ! Pragma_Name (Original_Node (P)) = Name_Check) then return; end if; *************** package body Sem_Warn is *** 3082,3088 **** -- to this lower bound. If not, False is returned, and Low_Bound is -- undefined on return. -- ! -- For now, we limite this to standard string types, so any other -- unconstrained types return False. We may change our minds on this -- later on, but strings seem the most important case. --- 3297,3303 ---- -- to this lower bound. If not, False is returned, and Low_Bound is -- undefined on return. -- ! -- For now, we limit this to standard string types, so any other -- unconstrained types return False. We may change our minds on this -- later on, but strings seem the most important case. *************** package body Sem_Warn is *** 3100,3111 **** if Is_Array_Type (Typ) and then not Is_Constrained (Typ) and then Number_Dimensions (Typ) = 1 - and then not Warnings_Off (Typ) and then (Root_Type (Typ) = Standard_String or else Root_Type (Typ) = Standard_Wide_String or else Root_Type (Typ) = Standard_Wide_Wide_String) then LB := Type_Low_Bound (Etype (First_Index (Typ))); --- 3315,3326 ---- if Is_Array_Type (Typ) and then not Is_Constrained (Typ) and then Number_Dimensions (Typ) = 1 and then (Root_Type (Typ) = Standard_String or else Root_Type (Typ) = Standard_Wide_String or else Root_Type (Typ) = Standard_Wide_Wide_String) + and then not Has_Warnings_Off (Typ) then LB := Type_Low_Bound (Etype (First_Index (Typ))); *************** package body Sem_Warn is *** 3159,3165 **** begin -- Nothing to do if subscript does not come from source (we don't -- want to give garbage warnings on compiler expanded code, e.g. the ! -- loops generated for slice assignments. Sucb junk warnings would -- be placed on source constructs with no subscript in sight!) if not Comes_From_Source (Original_Node (X)) then --- 3374,3380 ---- begin -- Nothing to do if subscript does not come from source (we don't -- want to give garbage warnings on compiler expanded code, e.g. the ! -- loops generated for slice assignments. Such junk warnings would -- be placed on source constructs with no subscript in sight!) if not Comes_From_Source (Original_Node (X)) then *************** package body Sem_Warn is *** 3201,3207 **** -- Tref (Sref) is used to scan the subscript Pctr : Natural; ! -- Paretheses counter when scanning subscript begin -- Tref (Sref) points to start of subscript --- 3416,3422 ---- -- Tref (Sref) is used to scan the subscript Pctr : Natural; ! -- Parentheses counter when scanning subscript begin -- Tref (Sref) points to start of subscript *************** package body Sem_Warn is *** 3392,3398 **** Next_Formal (Form2); end loop; ! -- Here all conditionas are met, record possible unset reference Set_Unset_Reference (Form, Return_Node); end if; --- 3607,3613 ---- Next_Formal (Form2); end loop; ! -- Here all conditions are met, record possible unset reference Set_Unset_Reference (Form, Return_Node); end if; *************** package body Sem_Warn is *** 3412,3424 **** E : Entity_Id := Spec_E; begin ! if not Referenced_Check_Spec (E) and then not Warnings_Off (E) then case Ekind (E) is when E_Variable => -- Case of variable that is assigned but not read. We suppress -- the message if the variable is volatile, has an address ! -- clause, is aliasied, or is a renaming, or is imported. if Referenced_As_LHS_Check_Spec (E) and then No (Address_Clause (E)) --- 3627,3642 ---- E : Entity_Id := Spec_E; begin ! if not Referenced_Check_Spec (E) ! and then not Has_Pragma_Unreferenced_Check_Spec (E) ! and then not Warnings_Off_Check_Spec (E) ! then case Ekind (E) is when E_Variable => -- Case of variable that is assigned but not read. We suppress -- the message if the variable is volatile, has an address ! -- clause, is aliased, or is a renaming, or is imported. if Referenced_As_LHS_Check_Spec (E) and then No (Address_Clause (E)) *************** package body Sem_Warn is *** 3494,3501 **** if Present (Body_E) then E := Body_E; end if; ! Error_Msg_NE ! ("?formal parameter & is not referenced!", E, Spec_E); end if; end if; --- 3712,3723 ---- if Present (Body_E) then E := Body_E; end if; ! ! if not Is_Trivial_Subprogram (Scope (E)) then ! Error_Msg_NE ! ("?formal parameter & is not referenced!", ! E, Spec_E); ! end if; end if; end if; *************** package body Sem_Warn is *** 3585,3604 **** if Is_Assignable (Ent) and then not Is_Return_Object (Ent) and then Present (Last_Assignment (Ent)) - and then not Warnings_Off (Ent) - and then not Has_Pragma_Unreferenced_Check_Spec (Ent) and then not Is_Imported (Ent) and then not Is_Exported (Ent) and then Safe_To_Capture_Value (N, Ent) then -- Before we issue the message, check covering exception handlers. ! -- Search up tree for enclosing statement sequences and handlers P := Parent (Last_Assignment (Ent)); while Present (P) loop ! -- Something is really wrong if we don't find a handled ! -- statement sequence, so just suppress the warning. if No (P) then Set_Last_Assignment (Ent, Empty); --- 3807,3825 ---- if Is_Assignable (Ent) and then not Is_Return_Object (Ent) and then Present (Last_Assignment (Ent)) and then not Is_Imported (Ent) and then not Is_Exported (Ent) and then Safe_To_Capture_Value (N, Ent) + and then not Has_Pragma_Unreferenced_Check_Spec (Ent) then -- Before we issue the message, check covering exception handlers. ! -- Search up tree for enclosing statement sequences and handlers. P := Parent (Last_Assignment (Ent)); while Present (P) loop ! -- Something is really wrong if we don't find a handled statement ! -- sequence, so just suppress the warning. if No (P) then Set_Last_Assignment (Ent, Empty); *************** package body Sem_Warn is *** 3663,3669 **** -- If we are not at the top level, we regard an inner -- exception handler as a decisive indicator that we should -- not generate the warning, since the variable in question ! -- may be acceessed after an exception in the outer block. if Nkind (Parent (P)) /= N_Subprogram_Body and then Nkind (Parent (P)) /= N_Package_Body --- 3884,3890 ---- -- If we are not at the top level, we regard an inner -- exception handler as a decisive indicator that we should -- not generate the warning, since the variable in question ! -- may be accessed after an exception in the outer block. if Nkind (Parent (P)) /= N_Subprogram_Body and then Nkind (Parent (P)) /= N_Package_Body *************** package body Sem_Warn is *** 3712,3715 **** --- 3933,3956 ---- end if; end Warn_On_Useless_Assignments; + ----------------------------- + -- Warnings_Off_Check_Spec -- + ----------------------------- + + function Warnings_Off_Check_Spec (E : Entity_Id) return Boolean is + begin + if Is_Formal (E) and then Present (Spec_Entity (E)) then + + -- Note: use of OR here instead of OR ELSE is deliberate, we want + -- to mess with flags on both entities. + + return Has_Warnings_Off (E) + or + Has_Warnings_Off (Spec_Entity (E)); + + else + return Has_Warnings_Off (E); + end if; + end Warnings_Off_Check_Spec; + end Sem_Warn; diff -Nrcpad gcc-4.3.3/gcc/ada/sem_warn.ads gcc-4.4.0/gcc/ada/sem_warn.ads *** gcc-4.3.3/gcc/ada/sem_warn.ads Thu Dec 13 10:19:43 2007 --- gcc-4.4.0/gcc/ada/sem_warn.ads Sun Apr 13 17:41:15 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2008, 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- -- *************** *** 27,40 **** --- 27,70 ---- -- about uses of uninitialized variables and unused with's. It also has -- some unrelated routines related to the generation of warnings. + with Alloc; use Alloc; + with Table; with Types; use Types; package Sem_Warn is + ------------------------ + -- Warnings Off Table -- + ------------------------ + + type Warnings_Off_Entry is record + N : Node_Id; + -- A pragma Warnings (Off, ent) node + + E : Entity_Id; + -- The entity involved + end record; + + -- An entry is made in the following table for any valid Pragma Warnings + -- (Off, entity) encountered while Opt.Warn_On_Warnings_Off is True. It + -- is used to generate warnings on any of these pragmas that turn out not + -- to be needed, or that could be replaced by Unmodified/Unreferenced. + + package Warnings_Off_Pragmas is new Table.Table ( + Table_Component_Type => Warnings_Off_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Warnings_Off_Pragmas_Initial, + Table_Increment => Alloc.Warnings_Off_Pragmas_Increment, + Table_Name => "Name_Warnings_Off_Pragmas"); + -------------------- -- Initialization -- -------------------- + procedure Initialize; + -- Initialize this package for new compilation + function Set_Warning_Switch (C : Character) return Boolean; -- This function sets the warning switch or switches corresponding to the -- given character. It is used to process a -gnatw switch on the command *************** package Sem_Warn is *** 121,126 **** --- 151,162 ---- -- the compilation process (see Check_Unset_Reference for further -- details). This procedure outputs waiting warnings, if any. + procedure Output_Unused_Warnings_Off_Warnings; + -- Warnings about pragma Warnings (Off, ent) statements that are unused, + -- or could be replaced by Unmodified/Unreferenced pragmas, are collected + -- till the end of the compilation process. This procedure outputs waiting + -- warnings if any. + ---------------------------- -- Other Warning Routines -- ---------------------------- *************** package Sem_Warn is *** 133,139 **** -- should be given for a possible infinite loop, and if so issues it. procedure Warn_On_Known_Condition (C : Node_Id); ! -- C is a node for a boolean expression resluting from a relational -- or membership operation. If the expression has a compile time known -- value, then a warning is output if all the following conditions hold: -- --- 169,175 ---- -- should be given for a possible infinite loop, and if so issues it. procedure Warn_On_Known_Condition (C : Node_Id); ! -- C is a node for a boolean expression resulting from a relational -- or membership operation. If the expression has a compile time known -- value, then a warning is output if all the following conditions hold: -- diff -Nrcpad gcc-4.3.3/gcc/ada/sequenio.ads gcc-4.4.0/gcc/ada/sequenio.ads *** gcc-4.3.3/gcc/ada/sequenio.ads Fri Apr 6 09:13:42 2007 --- gcc-4.4.0/gcc/ada/sequenio.ads Fri Aug 1 10:33:45 2008 *************** *** 15,23 **** pragma Ada_2005; -- Explicit setting of Ada 2005 mode is required here, since we want to with a ! -- child unit (not possible in Ada 83 mode), and Text_IO is not considered to ! -- be an internal unit that is automatically compiled in Ada 2005 mode (since ! -- a user is allowed to redeclare Sequential_IO). with Ada.Sequential_IO; --- 15,23 ---- pragma Ada_2005; -- Explicit setting of Ada 2005 mode is required here, since we want to with a ! -- child unit (not possible in Ada 83 mode), and Sequential_IO is not ! -- considered to be an internal unit that is automatically compiled in Ada ! -- 2005 mode (since a user is allowed to redeclare Sequential_IO). with Ada.Sequential_IO; diff -Nrcpad gcc-4.3.3/gcc/ada/sfn_scan.adb gcc-4.4.0/gcc/ada/sfn_scan.adb *** gcc-4.3.3/gcc/ada/sfn_scan.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/sfn_scan.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body SFN_Scan is *** 40,46 **** EOF : constant Character := ASCII.SUB; -- The character SUB (16#1A#) is used in DOS and other systems derived ! -- from DOS (OS/2, NT etc) to signal the end of a text file. If this -- character appears as the last character of a file scanned by a call -- to Scan_SFN_Pragmas, then it is ignored, otherwise it is treated as -- an illegal character. --- 38,44 ---- EOF : constant Character := ASCII.SUB; -- The character SUB (16#1A#) is used in DOS and other systems derived ! -- from DOS (OS/2, NT etc.) to signal the end of a text file. If this -- character appears as the last character of a file scanned by a call -- to Scan_SFN_Pragmas, then it is ignored, otherwise it is treated as -- an illegal character. *************** package body SFN_Scan is *** 601,607 **** end if; end loop Skip_Loop; ! -- We successfuly skipped to semicolon, so skip past it P := P + 1; end if; --- 599,605 ---- end if; end loop Skip_Loop; ! -- We successfully skipped to semicolon, so skip past it P := P + 1; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/sfn_scan.ads gcc-4.4.0/gcc/ada/sfn_scan.ads *** gcc-4.3.3/gcc/ada/sfn_scan.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sfn_scan.ads Sun Apr 13 18:03:09 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2008, 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- -- *************** *** 29,40 **** -- overhead of the full compiler scanner and parser. -- Note that neither the package spec, nor the package body, of this ! -- unit contains any with statements at all. This is a compeltely -- independent package, suitable for incorporation into tools that do -- not access any other units in the GNAT compiler or tools sources. -- This package is NOT task safe, so multiple tasks that may call the ! -- Scan_SFN_Pragmas procedure at the same time are responsibible for -- avoiding such multiple calls by appropriate synchronization. package SFN_Scan is --- 29,40 ---- -- overhead of the full compiler scanner and parser. -- Note that neither the package spec, nor the package body, of this ! -- unit contains any with statements at all. This is a completely -- independent package, suitable for incorporation into tools that do -- not access any other units in the GNAT compiler or tools sources. -- This package is NOT task safe, so multiple tasks that may call the ! -- Scan_SFN_Pragmas procedure at the same time are responsible for -- avoiding such multiple calls by appropriate synchronization. package SFN_Scan is *************** package SFN_Scan is *** 91,96 **** -- that includes only pragmas and comments. It does not do a full -- syntax correctness scan by any means, but if it does find anything -- that it can tell is wrong it will immediately raise the exception ! -- to indicate the aproximate location of the error end SFN_Scan; --- 91,96 ---- -- that includes only pragmas and comments. It does not do a full -- syntax correctness scan by any means, but if it does find anything -- that it can tell is wrong it will immediately raise the exception ! -- to indicate the approximate location of the error end SFN_Scan; diff -Nrcpad gcc-4.3.3/gcc/ada/sinfo-cn.adb gcc-4.4.0/gcc/ada/sinfo-cn.adb *** gcc-4.3.3/gcc/ada/sinfo-cn.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sinfo-cn.adb Wed Aug 20 13:55:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** *** 29,35 **** -- record discriminant part, such alterations cannot be permitted in a -- general manner, but in some specific cases, the fields of related nodes -- have been deliberately layed out in a manner that permits such alteration. - -- that determin with Atree; use Atree; --- 29,34 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/sinfo.adb gcc-4.4.0/gcc/ada/sinfo.adb *** gcc-4.3.3/gcc/ada/sinfo.adb Thu Dec 13 10:22:06 2007 --- gcc-4.4.0/gcc/ada/sinfo.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Sinfo is *** 1264,1269 **** --- 1262,1275 ---- return Flag5 (N); end Forwards_OK; + function From_At_End + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Raise_Statement); + return Flag4 (N); + end From_At_End; + function From_At_Mod (N : Node_Id) return Boolean is begin *************** package body Sinfo is *** 1407,1412 **** --- 1413,1427 ---- return Flag11 (N); end Has_Private_View; + function Has_Relative_Deadline_Pragma + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Definition); + return Flag9 (N); + end Has_Relative_Deadline_Pragma; + function Has_Self_Reference (N : Node_Id) return Boolean is begin *************** package body Sinfo is *** 1972,1977 **** --- 1987,2000 ---- return Node4 (N); end Next_Named_Actual; + function Next_Pragma + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Node1 (N); + end Next_Pragma; + function Next_Rep_Item (N : Node_Id) return Node_Id is begin *************** package body Sinfo is *** 2176,2181 **** --- 2199,2212 ---- return Node4 (N); end Parent_Spec; + function PPC_Enabled + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Flag5 (N); + end PPC_Enabled; + function Position (N : Node_Id) return Node_Id is begin *************** package body Sinfo is *** 3995,4000 **** --- 4026,4039 ---- Set_Flag5 (N, Val); end Set_Forwards_OK; + procedure Set_From_At_End + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Raise_Statement); + Set_Flag4 (N, Val); + end Set_From_At_End; + procedure Set_From_At_Mod (N : Node_Id; Val : Boolean := True) is begin *************** package body Sinfo is *** 4138,4143 **** --- 4177,4191 ---- Set_Flag11 (N, Val); end Set_Has_Private_View; + procedure Set_Has_Relative_Deadline_Pragma + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Definition); + Set_Flag9 (N, Val); + end Set_Has_Relative_Deadline_Pragma; + procedure Set_Has_Self_Reference (N : Node_Id; Val : Boolean := True) is begin *************** package body Sinfo is *** 4703,4708 **** --- 4751,4764 ---- Set_Node4 (N, Val); -- semantic field, no parent set end Set_Next_Named_Actual; + procedure Set_Next_Pragma + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Node1 (N, Val); -- semantic field, no parent set + end Set_Next_Pragma; + procedure Set_Next_Rep_Item (N : Node_Id; Val : Node_Id) is begin *************** package body Sinfo is *** 4907,4912 **** --- 4963,4976 ---- Set_Node4 (N, Val); -- semantic field, no parent set end Set_Parent_Spec; + procedure Set_PPC_Enabled + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Flag5 (N, Val); + end Set_PPC_Enabled; + procedure Set_Position (N : Node_Id; Val : Node_Id) is begin *************** package body Sinfo is *** 5574,5582 **** UI_From_Int (Int (S) - Int (Sloc (N)))); end Set_End_Location; ! -------------------------------- ! -- Node_Kind Membership Tests -- ! -------------------------------- function Nkind_In (T : Node_Kind; --- 5638,5646 ---- UI_From_Int (Int (S) - Int (Sloc (N)))); end Set_End_Location; ! -------------- ! -- Nkind_In -- ! -------------- function Nkind_In (T : Node_Kind; *************** package body Sinfo is *** 5690,5693 **** --- 5754,5766 ---- T = V8; end Nkind_In; + ----------------- + -- Pragma_Name -- + ----------------- + + function Pragma_Name (N : Node_Id) return Name_Id is + begin + return Chars (Pragma_Identifier (N)); + end Pragma_Name; + end Sinfo; diff -Nrcpad gcc-4.3.3/gcc/ada/sinfo.ads gcc-4.4.0/gcc/ada/sinfo.ads *** gcc-4.3.3/gcc/ada/sinfo.ads Thu Dec 13 10:22:06 2007 --- gcc-4.4.0/gcc/ada/sinfo.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Sinfo is *** 384,390 **** -- In the following node definitions, all fields, both syntactic and -- semantic, are documented. The one exception is in the case of entities ! -- (defining indentifiers, character literals and operator symbols), where -- the usage of the fields depends on the entity kind. Entity fields are -- fully documented in the separate package Einfo. --- 382,388 ---- -- In the following node definitions, all fields, both syntactic and -- semantic, are documented. The one exception is in the case of entities ! -- (defining identifiers, character literals and operator symbols), where -- the usage of the fields depends on the entity kind. Entity fields are -- fully documented in the separate package Einfo. *************** package Sinfo is *** 525,531 **** -- Present in N_Freeze_Entity nodes for Incomplete or private types. -- Contains the list of access types which may require specific treatment -- when the nature of the type completion is completely known. An example ! -- of such treatement is the generation of the associated_final_chain. -- Actions (List1-Sem) -- This field contains a sequence of actions that are associated with the --- 523,529 ---- -- Present in N_Freeze_Entity nodes for Incomplete or private types. -- Contains the list of access types which may require specific treatment -- when the nature of the type completion is completely known. An example ! -- of such treatment is the generation of the associated_final_chain. -- Actions (List1-Sem) -- This field contains a sequence of actions that are associated with the *************** package Sinfo is *** 581,627 **** -- elements. -- All_Others (Flag11-Sem) ! -- Present in an N_Others_Choice node. This flag is set in the case of an ! -- others exception where all exceptions are to be caught, even those ! -- that are not normally handled (in particular the tasking abort ! -- signal). This is used for translation of the at end handler into a ! -- normal exception handler. -- Assignment_OK (Flag15-Sem) -- This flag is set in a subexpression node for an object, indicating -- that the associated object can be modified, even if this would not -- normally be permissible (either by direct assignment, or by being -- passed as an out or in-out parameter). This is used by the expander ! -- for a number of purposes, including initialzation of constants and -- limited type objects (such as tasks), setting discriminant fields, -- setting tag values, etc. N_Object_Declaration nodes also have this -- flag defined. Here it is used to indicate that an initialization ! -- expression is valid, even where it would normally not be allowed (e.g. ! -- where the type involved is limited). -- Associated_Node (Node4-Sem) -- Present in nodes that can denote an entity: identifiers, character -- literals, operator symbols, expanded names, operator nodes, and ! -- attribute reference nodes (all these nodes have an Entity field). This ! -- field is also present in N_Aggregate, N_Selected_Component, and -- N_Extension_Aggregate nodes. This field is used in generic processing ! -- to create links between the generic template and the generic copy. See ! -- Sem_Ch12.Get_Associated_Node for full details. Note that this field ! -- overlaps Entity, which is fine, since, as explained in Sem_Ch12, the ! -- normal function of Entity is not required at the point where the -- Associated_Node is set. Note also, that in generic templates, this -- means that the Entity field does not necessarily point to an Entity. -- Since the back end is expected to ignore generic templates, this is -- harmless. -- At_End_Proc (Node1) ! -- This field is present in an N_Handled_Sequence_Of_Statements node. It ! -- contains an identifier reference for the cleanup procedure to be -- called. See description of this node for further details. -- Backwards_OK (Flag6-Sem) ! -- A flag present in the N_Assignment_Statement node. It is used only if ! -- the type being assigned is an array type, and is set if analysis -- determines that it is definitely safe to do the copy backwards, i.e. -- starting at the highest addressed element. Note that if neither of the -- flags Forwards_OK or Backwards_OK is set, it means that the front end --- 579,625 ---- -- elements. -- All_Others (Flag11-Sem) ! -- Present in an N_Others_Choice node. This flag is set for an others ! -- exception where all exceptions are to be caught, even those that are ! -- not normally handled (in particular the tasking abort signal). This ! -- is used for translation of the at end handler into a normal exception ! -- handler. -- Assignment_OK (Flag15-Sem) -- This flag is set in a subexpression node for an object, indicating -- that the associated object can be modified, even if this would not -- normally be permissible (either by direct assignment, or by being -- passed as an out or in-out parameter). This is used by the expander ! -- for a number of purposes, including initialization of constants and -- limited type objects (such as tasks), setting discriminant fields, -- setting tag values, etc. N_Object_Declaration nodes also have this -- flag defined. Here it is used to indicate that an initialization ! -- expression is valid, even where it would normally not be allowed ! -- (e.g. where the type involved is limited). -- Associated_Node (Node4-Sem) -- Present in nodes that can denote an entity: identifiers, character -- literals, operator symbols, expanded names, operator nodes, and ! -- attribute reference nodes (all these nodes have an Entity field). ! -- This field is also present in N_Aggregate, N_Selected_Component, and -- N_Extension_Aggregate nodes. This field is used in generic processing ! -- to create links between the generic template and the generic copy. ! -- See Sem_Ch12.Get_Associated_Node for full details. Note that this ! -- field overlaps Entity, which is fine, since, as explained in Sem_Ch12, ! -- the normal function of Entity is not required at the point where the -- Associated_Node is set. Note also, that in generic templates, this -- means that the Entity field does not necessarily point to an Entity. -- Since the back end is expected to ignore generic templates, this is -- harmless. -- At_End_Proc (Node1) ! -- This field is present in an N_Handled_Sequence_Of_Statements node. ! -- It contains an identifier reference for the cleanup procedure to be -- called. See description of this node for further details. -- Backwards_OK (Flag6-Sem) ! -- A flag present in the N_Assignment_Statement node. It is used only ! -- if the type being assigned is an array type, and is set if analysis -- determines that it is definitely safe to do the copy backwards, i.e. -- starting at the highest addressed element. Note that if neither of the -- flags Forwards_OK or Backwards_OK is set, it means that the front end *************** package Sinfo is *** 637,644 **** -- which is used directly in later calls to the original subprogram. -- Body_Required (Flag13-Sem) ! -- A flag that appears in the N_Compilation_Unit node indicating that the ! -- corresponding unit requires a body. For the package case, this -- indicates that a completion is required. In Ada 95, if the flag is not -- set for the package case, then a body may not be present. In Ada 83, -- if the flag is not set for the package case, then body is optional. --- 635,642 ---- -- which is used directly in later calls to the original subprogram. -- Body_Required (Flag13-Sem) ! -- A flag that appears in the N_Compilation_Unit node indicating that ! -- the corresponding unit requires a body. For the package case, this -- indicates that a completion is required. In Ada 95, if the flag is not -- set for the package case, then a body may not be present. In Ada 83, -- if the flag is not set for the package case, then body is optional. *************** package Sinfo is *** 647,656 **** -- permitted (in Ada 83 or Ada 95). -- By_Ref (Flag5-Sem) ! -- A flag present in N_Simple_Return_Statement and ! -- N_Extended_Return_Statement. ! -- It is set when the returned expression is already allocated on the ! -- secondary stack and thus the result is passed by reference rather -- than copied another time. -- Check_Address_Alignment (Flag11-Sem) --- 645,653 ---- -- permitted (in Ada 83 or Ada 95). -- By_Ref (Flag5-Sem) ! -- Present in N_Simple_Return_Statement and N_Extended_Return_Statement, ! -- this flag is set when the returned expression is already allocated on ! -- the secondary stack and thus the result is passed by reference rather -- than copied another time. -- Check_Address_Alignment (Flag11-Sem) *************** package Sinfo is *** 668,675 **** -- Comes_From_Extended_Return_Statement (Flag18-Sem) -- Present in N_Simple_Return_Statement nodes. True if this node was ! -- constructed as part of the expansion of an ! -- N_Extended_Return_Statement. -- Compile_Time_Known_Aggregate (Flag18-Sem) -- Present in N_Aggregate nodes. Set for aggregates which can be fully --- 665,672 ---- -- Comes_From_Extended_Return_Statement (Flag18-Sem) -- Present in N_Simple_Return_Statement nodes. True if this node was ! -- constructed as part of the N_Extended_Return_Statement expansion. ! -- . -- Compile_Time_Known_Aggregate (Flag18-Sem) -- Present in N_Aggregate nodes. Set for aggregates which can be fully *************** package Sinfo is *** 681,708 **** -- Condition_Actions (List3-Sem) -- This field appears in else-if nodes and in the iteration scheme node -- for while loops. This field is only used during semantic processing to ! -- temporarily hold actions inserted into the tree. In the tree passed to ! -- gigi, the condition actions field is always set to No_List. For -- details on how this field is used, see the routine Insert_Actions in -- package Exp_Util, and also the expansion routines for the relevant -- nodes. -- Controlling_Argument (Node1-Sem) ! -- This field is set in procedure and function call nodes if the call is ! -- a dispatching call (it is Empty for a non-dispatching call). It -- indicates the source of the call's controlling tag. For procedure -- calls, the Controlling_Argument is one of the actuals. For function -- that has a dispatching result, it is an entity in the context of the ! -- call that can provide a tag, or else it is the tag of the root type of ! -- the class. It can also specify a tag directly rather than being a -- tagged object. The latter is needed by the implementations of AI-239 -- and AI-260. -- Conversion_OK (Flag14-Sem) ! -- A flag set on type conversion nodes to indicate that the conversion is ! -- to be considered as being valid, even though it is the case that the ! -- conversion is not valid Ada. This is used for Enum_Rep, Fixed_Value ! -- and Integer_Value attributes, for internal conversions done for -- fixed-point operations, and for certain conversions for calls to -- initialization procedures. If Conversion_OK is set, then Etype must be -- set (the analyzer assumes that Etype has been set). For the case of --- 678,705 ---- -- Condition_Actions (List3-Sem) -- This field appears in else-if nodes and in the iteration scheme node -- for while loops. This field is only used during semantic processing to ! -- temporarily hold actions inserted into the tree. In the tree passed ! -- to gigi, the condition actions field is always set to No_List. For -- details on how this field is used, see the routine Insert_Actions in -- package Exp_Util, and also the expansion routines for the relevant -- nodes. -- Controlling_Argument (Node1-Sem) ! -- This field is set in procedure and function call nodes if the call ! -- is a dispatching call (it is Empty for a non-dispatching call). It -- indicates the source of the call's controlling tag. For procedure -- calls, the Controlling_Argument is one of the actuals. For function -- that has a dispatching result, it is an entity in the context of the ! -- call that can provide a tag, or else it is the tag of the root type ! -- of the class. It can also specify a tag directly rather than being a -- tagged object. The latter is needed by the implementations of AI-239 -- and AI-260. -- Conversion_OK (Flag14-Sem) ! -- A flag set on type conversion nodes to indicate that the conversion ! -- is to be considered as being valid, even though it is the case that ! -- the conversion is not valid Ada. This is used for attributes Enum_Rep, ! -- Fixed_Value and Integer_Value, for internal conversions done for -- fixed-point operations, and for certain conversions for calls to -- initialization procedures. If Conversion_OK is set, then Etype must be -- set (the analyzer assumes that Etype has been set). For the case of *************** package Sinfo is *** 740,754 **** -- Corresponding_Spec (Node5-Sem) -- This field is set in subprogram, package, task, and protected body -- nodes, where it points to the defining entity in the corresponding ! -- spec. The attribute is also set in N_With_Clause nodes, where it ! -- points to the defining entity for the with'ed spec, and in a ! -- subprogram renaming declaration when it is a Renaming_As_Body. The ! -- field is Empty if there is no corresponding spec, as in the case of a ! -- subprogram body that serves as its own spec. -- Corresponding_Stub (Node3-Sem) -- This field is present in an N_Subunit node. It holds the node in ! -- the parent unit that is the stub declaration for the subunit. it is -- set when analysis of the stub forces loading of the proper body. If -- expansion of the proper body creates new declarative nodes, they are -- inserted at the point of the corresponding_stub. --- 737,751 ---- -- Corresponding_Spec (Node5-Sem) -- This field is set in subprogram, package, task, and protected body -- nodes, where it points to the defining entity in the corresponding ! -- spec. The attribute is also set in N_With_Clause nodes where it points ! -- to the defining entity for the with'ed spec, and in a subprogram ! -- renaming declaration when it is a Renaming_As_Body. The field is Empty ! -- if there is no corresponding spec, as in the case of a subprogram body ! -- that serves as its own spec. -- Corresponding_Stub (Node3-Sem) -- This field is present in an N_Subunit node. It holds the node in ! -- the parent unit that is the stub declaration for the subunit. It is -- set when analysis of the stub forces loading of the proper body. If -- expansion of the proper body creates new declarative nodes, they are -- inserted at the point of the corresponding_stub. *************** package Sinfo is *** 812,821 **** -- range. -- Do_Range_Check (Flag9-Sem) ! -- This flag is set on an expression which appears in a context where ! -- a range check is required. The target type is clear from the ! -- context. The contexts in which this flag can appear are limited to ! -- the following. -- Right side of an assignment. In this case the target type is -- taken from the left side of the assignment, which is referenced --- 809,817 ---- -- range. -- Do_Range_Check (Flag9-Sem) ! -- This flag is set on an expression which appears in a context where a ! -- range check is required. The target type is clear from the context. ! -- The contexts in which this flag can appear are the following: -- Right side of an assignment. In this case the target type is -- taken from the left side of the assignment, which is referenced *************** package Sinfo is *** 885,895 **** -- desirable for correct elaboration for this unit. -- Elaboration_Boolean (Node2-Sem) ! -- This field is present in function and procedure specification ! -- nodes. If set, it points to the entity for a Boolean flag that ! -- must be tested for certain calls to check for access before ! -- elaboration. See body of Sem_Elab for further details. This ! -- field is Empty if no elaboration boolean is required. -- Else_Actions (List3-Sem) -- This field is present in conditional expression nodes. During code --- 881,891 ---- -- desirable for correct elaboration for this unit. -- Elaboration_Boolean (Node2-Sem) ! -- This field is present in function and procedure specification nodes. ! -- If set, it points to the entity for a Boolean flag that must be tested ! -- for certain calls to check for access before elaboration. See body of ! -- Sem_Elab for further details. This field is Empty if no elaboration ! -- boolean is required. -- Else_Actions (List3-Sem) -- This field is present in conditional expression nodes. During code *************** package Sinfo is *** 903,912 **** -- always set to No_List. -- Enclosing_Variant (Node2-Sem) ! -- This field is present in the N_Variant node and identifies the ! -- Node_Id corresponding to the immediately enclosing variant when ! -- the variant is nested, and N_Empty otherwise. Set during semantic ! -- processing of the variant part of a record type. -- Entity (Node4-Sem) -- Appears in all direct names (identifiers, character literals, and --- 899,908 ---- -- always set to No_List. -- Enclosing_Variant (Node2-Sem) ! -- This field is present in the N_Variant node and identifies the Node_Id ! -- corresponding to the immediately enclosing variant when the variant is ! -- nested, and N_Empty otherwise. Set during semantic processing of the ! -- variant part of a record type. -- Entity (Node4-Sem) -- Appears in all direct names (identifiers, character literals, and *************** package Sinfo is *** 989,999 **** -- left-hand side of individual assignment to each sub-component. -- First_Inlined_Subprogram (Node3-Sem) ! -- Present in the N_Compilation_Unit node for the main program. Points to ! -- a chain of entities for subprograms that are to be inlined. The -- Next_Inlined_Subprogram field of these entities is used as a link ! -- pointer with Empty marking the end of the list. This field is Empty if ! -- there are no inlined subprograms or inlining is not active. -- First_Named_Actual (Node4-Sem) -- Present in procedure call statement and function call nodes, and also --- 985,995 ---- -- left-hand side of individual assignment to each sub-component. -- First_Inlined_Subprogram (Node3-Sem) ! -- Present in the N_Compilation_Unit node for the main program. Points ! -- to a chain of entities for subprograms that are to be inlined. The -- Next_Inlined_Subprogram field of these entities is used as a link ! -- pointer with Empty marking the end of the list. This field is Empty ! -- if there are no inlined subprograms or inlining is not active. -- First_Named_Actual (Node4-Sem) -- Present in procedure call statement and function call nodes, and also *************** package Sinfo is *** 1014,1021 **** -- First_Subtype_Link (Node5-Sem) -- Present in N_Freeze_Entity node for an anonymous base type that is ! -- implicitly created by the declaration of a first subtype. It points to ! -- the entity for the first subtype. -- Float_Truncate (Flag11-Sem) -- A flag present in type conversion nodes. This is used for float to --- 1010,1017 ---- -- First_Subtype_Link (Node5-Sem) -- Present in N_Freeze_Entity node for an anonymous base type that is ! -- implicitly created by the declaration of a first subtype. It points ! -- to the entity for the first subtype. -- Float_Truncate (Flag11-Sem) -- A flag present in type conversion nodes. This is used for float to *************** package Sinfo is *** 1024,1037 **** -- with rounding (see Expand_N_Type_Conversion). -- Forwards_OK (Flag5-Sem) ! -- A flag present in the N_Assignment_Statement node. It is used only if ! -- the type being assigned is an array type, and is set if analysis -- determines that it is definitely safe to do the copy forwards, i.e. -- starting at the lowest addressed element. Note that if neither of the -- flags Forwards_OK or Backwards_OK is set, it means that the front end -- could not determine that either direction is definitely safe, and a -- runtime check is required. -- From_At_Mod (Flag4-Sem) -- This flag is set on the attribute definition clause node that is -- generated by a transformation of an at mod phrase in a record --- 1020,1040 ---- -- with rounding (see Expand_N_Type_Conversion). -- Forwards_OK (Flag5-Sem) ! -- A flag present in the N_Assignment_Statement node. It is used only ! -- if the type being assigned is an array type, and is set if analysis -- determines that it is definitely safe to do the copy forwards, i.e. -- starting at the lowest addressed element. Note that if neither of the -- flags Forwards_OK or Backwards_OK is set, it means that the front end -- could not determine that either direction is definitely safe, and a -- runtime check is required. + -- From_At_End (Flag4-Sem) + -- This flag is set on an N_Raise_Statement node if it corresponds to + -- the reraise statement generated as the last statement of an AT END + -- handler when SJLJ exception handling is active. It is used to stop + -- a bogus violation of restriction (No_Exception_Propagation), bogus + -- because if the restriction is set, the reraise is not generated. + -- From_At_Mod (Flag4-Sem) -- This flag is set on the attribute definition clause node that is -- generated by a transformation of an at mod phrase in a record *************** package Sinfo is *** 1096,1101 **** --- 1099,1108 ---- -- declarations if the visibility at instantiation is different from the -- visibility at generic definition. + -- Has_Relative_Deadline_Pragma (Flag9-Sem) + -- A flag present in N_Subprogram_Body and N_Task_Definition nodes to + -- flag the presence of a pragma Relative_Deadline. + -- Has_Self_Reference (Flag13-Sem) -- Present in N_Aggregate and N_Extension_Aggregate. Indicates that one -- of the expressions contains an access attribute reference to the *************** package Sinfo is *** 1133,1139 **** -- Includes_Infinities (Flag11-Sem) -- This flag is present in N_Range nodes. It is set for the range of -- unconstrained float types defined in Standard, which include not only ! -- the given range of values, but also legtitimately can include infinite -- values. This flag is false for any float type for which an explicit -- range is given by the programmer, even if that range is identical to -- the range for Float. --- 1140,1146 ---- -- Includes_Infinities (Flag11-Sem) -- This flag is present in N_Range nodes. It is set for the range of -- unconstrained float types defined in Standard, which include not only ! -- the given range of values, but also legitimately can include infinite -- values. This flag is false for any float type for which an explicit -- range is given by the programmer, even if that range is identical to -- the range for Float. *************** package Sinfo is *** 1182,1188 **** -- that the reference occurs within a discriminant check. The -- significance is that optimizations based on assuming that the -- discriminant check has a correct value cannot be performed in this ! -- case (or the disriminant check may be optimized away!) -- Is_Machine_Number (Flag11-Sem) -- This flag is set in an N_Real_Literal node to indicate that the value --- 1189,1195 ---- -- that the reference occurs within a discriminant check. The -- significance is that optimizations based on assuming that the -- discriminant check has a correct value cannot be performed in this ! -- case (or the discriminant check may be optimized away!) -- Is_Machine_Number (Flag11-Sem) -- This flag is set in an N_Real_Literal node to indicate that the value *************** package Sinfo is *** 1202,1208 **** -- Is_Power_Of_2_For_Shift (Flag13-Sem) -- A flag present only in N_Op_Expon nodes. It is set when the ! -- exponentiation is of the forma 2 ** N, where the type of N is an -- unsigned integral subtype whose size does not exceed the size of -- Standard_Integer (i.e. a type that can be safely converted to -- Natural), and the exponentiation appears as the right operand of an --- 1209,1215 ---- -- Is_Power_Of_2_For_Shift (Flag13-Sem) -- A flag present only in N_Op_Expon nodes. It is set when the ! -- exponentiation is of the form 2 ** N, where the type of N is an -- unsigned integral subtype whose size does not exceed the size of -- Standard_Integer (i.e. a type that can be safely converted to -- Natural), and the exponentiation appears as the right operand of an *************** package Sinfo is *** 1214,1220 **** -- Is_Protected_Subprogram_Body (Flag7-Sem) -- A flag set in a Subprogram_Body block to indicate that it is the ! -- implemenation of a protected subprogram. Such a body needs cleanup -- handler to make sure that the associated protected object is unlocked -- when the subprogram completes. --- 1221,1227 ---- -- Is_Protected_Subprogram_Body (Flag7-Sem) -- A flag set in a Subprogram_Body block to indicate that it is the ! -- implementation of a protected subprogram. Such a body needs cleanup -- handler to make sure that the associated protected object is unlocked -- when the subprogram completes. *************** package Sinfo is *** 1235,1241 **** -- A flag set in a Block_Statement node to indicate that it is the -- expansion of a task allocator, or the allocator of an object -- containing tasks. Such a block requires a cleanup handler to call ! -- Expunge_Unactivted_Tasks to complete any tasks that have been -- allocated but not activated when the allocator completes abnormally. -- Is_Task_Master (Flag5-Sem) --- 1242,1248 ---- -- A flag set in a Block_Statement node to indicate that it is the -- expansion of a task allocator, or the allocator of an object -- containing tasks. Such a block requires a cleanup handler to call ! -- Expunge_Unactivated_Tasks to complete any tasks that have been -- allocated but not activated when the allocator completes abnormally. -- Is_Task_Master (Flag5-Sem) *************** package Sinfo is *** 1358,1363 **** --- 1365,1381 ---- -- points to the explicit actual parameter itself, not to the -- N_Parameter_Association node (its parent). + -- Next_Pragma (Node1-Sem) + -- Present in N_Pragma nodes. Used to create a linked list of pragma + -- nodes. Currently used for two purposes: + -- + -- Create a list of linked Check_Policy pragmas. The head of this list + -- is stored in Opt.Check_Policy_List (which has further details). + -- + -- Used by processing for Pre/Postcondition pragmas to store a list of + -- pragmas associated with the spec of a subprogram (see Sem_Prag for + -- details). + -- Next_Rep_Item (Node5-Sem) -- Present in pragma nodes and attribute definition nodes. Used to link -- representation items that apply to an entity. See description of *************** package Sinfo is *** 1372,1379 **** -- is undefined and should not be read). -- No_Ctrl_Actions (Flag7-Sem) ! -- Present in N_Assignment_Statement to indicate that no finalize nor nor ! -- adjust should take place on this assignment eventhough the rhs is -- controlled. This is used in init procs and aggregate expansions where -- the generated assignments are more initialisations than real -- assignments. --- 1390,1397 ---- -- is undefined and should not be read). -- No_Ctrl_Actions (Flag7-Sem) ! -- Present in N_Assignment_Statement to indicate that no finalize nor ! -- adjust should take place on this assignment even though the rhs is -- controlled. This is used in init procs and aggregate expansions where -- the generated assignments are more initialisations than real -- assignments. *************** package Sinfo is *** 1394,1405 **** -- full details) -- No_Initialization (Flag13-Sem) ! -- Present in N_Object_Declaration & N_Allocator to indicate that the -- object must not be initialized (by Initialize or call to an init -- proc). This is needed for controlled aggregates. When the Object -- declaration has an expression, this flag means that this expression -- should not be taken into account (needed for in place initialization ! -- with aggregates) -- No_Truncation (Flag17-Sem) -- Present in N_Unchecked_Type_Conversion node. This flag has an effect --- 1412,1423 ---- -- full details) -- No_Initialization (Flag13-Sem) ! -- Present in N_Object_Declaration and N_Allocator to indicate that the -- object must not be initialized (by Initialize or call to an init -- proc). This is needed for controlled aggregates. When the Object -- declaration has an expression, this flag means that this expression -- should not be taken into account (needed for in place initialization ! -- with aggregates). -- No_Truncation (Flag17-Sem) -- Present in N_Unchecked_Type_Conversion node. This flag has an effect *************** package Sinfo is *** 1460,1465 **** --- 1478,1488 ---- -- package specification. This field is Empty for library bodies (the -- parent spec in this case can be found from the corresponding spec). + -- PPC_Enabled (Flag5-Sem) + -- Present in N_Pragma nodes. This flag is relevant only for precondition + -- and postcondition nodes. It is true if the check corresponding to the + -- pragma type is enabled at the point where the pragma appears. + -- Present_Expr (Uint3-Sem) -- Present in an N_Variant node. This has a meaningful value only after -- Gigi has back annotated the tree with representation information. At *************** package Sinfo is *** 1567,1573 **** -- and N_Extended_Return_Statement nodes. References the entity for the -- storage pool to be used for the allocate or free call or for the -- allocation of the returned value from function. Empty indicates that ! -- the global default default pool is to be used. Note that in the case -- of a return statement, this field is set only if the function returns -- value of a type whose size is not known at compile time on the -- secondary stack. --- 1590,1596 ---- -- and N_Extended_Return_Statement nodes. References the entity for the -- storage pool to be used for the allocate or free call or for the -- allocation of the returned value from function. Empty indicates that ! -- the global default pool is to be used. Note that in the case -- of a return statement, this field is set only if the function returns -- value of a type whose size is not known at compile time on the -- secondary stack. *************** package Sinfo is *** 1593,1602 **** -- on fixed-point operands. It indicates that the operands are to be -- treated as integer values, ignoring small values. This flag is only -- set as a result of expansion of fixed-point operations. Typically a ! -- fixed-point multplication in the source generates subsidiary -- multiplication and division operations that work with the underlying -- integer values and have this flag set. Note that this flag is not ! -- needed on other arithmetic operations (add, neg, subtract etc) since -- in these cases it is always the case that fixed is treated as integer. -- The Etype field MUST be set if this flag is set. The analyzer knows to -- leave such nodes alone, and whoever makes them must set the correct --- 1616,1625 ---- -- on fixed-point operands. It indicates that the operands are to be -- treated as integer values, ignoring small values. This flag is only -- set as a result of expansion of fixed-point operations. Typically a ! -- fixed-point multiplication in the source generates subsidiary -- multiplication and division operations that work with the underlying -- integer values and have this flag set. Note that this flag is not ! -- needed on other arithmetic operations (add, neg, subtract etc.) since -- in these cases it is always the case that fixed is treated as integer. -- The Etype field MUST be set if this flag is set. The analyzer knows to -- leave such nodes alone, and whoever makes them must set the correct *************** package Sinfo is *** 1627,1633 **** -- Zero_Cost_Handling (Flag5-Sem) -- This flag is set in all handled sequence of statement and exception ! -- handler nodes if eceptions are to be handled using the zero-cost -- mechanism (see Ada.Exceptions and System.Exceptions in files -- a-except.ads/adb and s-except.ads for full details). What gigi needs -- to do for such a handler is simply to put the code in the handler --- 1650,1656 ---- -- Zero_Cost_Handling (Flag5-Sem) -- This flag is set in all handled sequence of statement and exception ! -- handler nodes if exceptions are to be handled using the zero-cost -- mechanism (see Ada.Exceptions and System.Exceptions in files -- a-except.ads/adb and s-except.ads for full details). What gigi needs -- to do for such a handler is simply to put the code in the handler *************** package Sinfo is *** 1876,1898 **** -- N_Pragma -- Sloc points to pragma identifier ! -- Chars (Name1) identifier name from pragma identifier -- Pragma_Argument_Associations (List2) (set to No_List if none) -- Debug_Statement (Node3) (set to Empty if not Debug, Assert) -- Pragma_Identifier (Node4) -- Next_Rep_Item (Node5-Sem) -- Note: we should have a section on what pragmas are passed on to -- the back end to be processed. This section should note that pragma -- Psect_Object is always converted to Common_Object, but there are -- undoubtedly many other similar notes required ??? ! -- Note: we don't really need the Chars field, since it can trivially ! -- be obtained as Chars (Pragma_Identifier (Node)). However, it is ! -- convenient to have this directly available, and historically the ! -- Chars field has been around for ever, whereas the Pragma_Identifier ! -- field was added much later (when we found the need to be able to get ! -- the Sloc of the pragma identifier). -------------------------------------- -- 2.8 Pragma Argument Association -- --- 1899,1918 ---- -- N_Pragma -- Sloc points to pragma identifier ! -- Next_Pragma (Node1-Sem) -- Pragma_Argument_Associations (List2) (set to No_List if none) -- Debug_Statement (Node3) (set to Empty if not Debug, Assert) -- Pragma_Identifier (Node4) -- Next_Rep_Item (Node5-Sem) + -- PPC_Enabled (Flag5-Sem) -- Note: we should have a section on what pragmas are passed on to -- the back end to be processed. This section should note that pragma -- Psect_Object is always converted to Common_Object, but there are -- undoubtedly many other similar notes required ??? ! -- Note: a utility function Pragma_Name may be applied to pragma nodes ! -- to conveniently obtain the Chars field of the Pragma_Identifier. -------------------------------------- -- 2.8 Pragma Argument Association -- *************** package Sinfo is *** 2121,2127 **** -- the Expression may not have the form of an aggregate (since this -- might cause the back end to generate separate assignments). It -- also cannot be a reference to an object marked as a true constant ! -- (Is_True_Constant flag set), where the object is itself initalized -- with an aggregate. If necessary the front end must generate an -- extra temporary (with Is_True_Constant set False), and initialize -- this temporary as required (the temporary itself is not atomic). --- 2141,2147 ---- -- the Expression may not have the form of an aggregate (since this -- might cause the back end to generate separate assignments). It -- also cannot be a reference to an object marked as a true constant ! -- (Is_True_Constant flag set), where the object is itself initialized -- with an aggregate. If necessary the front end must generate an -- extra temporary (with Is_True_Constant set False), and initialize -- this temporary as required (the temporary itself is not atomic). *************** package Sinfo is *** 3091,3097 **** -- limited types for which no stream routines exist officially. In such -- case, the result is to use the stream attribute for the underlying -- full type, or in the case of a protected type, the components ! -- (including any disriminants) are merely streamed in order. -- See Exp_Attr for a complete description of which attributes are -- passed onto Gigi, and which are handled entirely by the front end. --- 3111,3117 ---- -- limited types for which no stream routines exist officially. In such -- case, the result is to use the stream attribute for the underlying -- full type, or in the case of a protected type, the components ! -- (including any discriminants) are merely streamed in order. -- See Exp_Attr for a complete description of which attributes are -- passed onto Gigi, and which are handled entirely by the front end. *************** package Sinfo is *** 3243,3251 **** -- node (which appears as a singleton list). Box_Present gives support -- to Ada 2005 (AI-287). ! ----------------------------------- ! -- 4.3.1 Commponent Choice List -- ! ----------------------------------- -- COMPONENT_CHOICE_LIST ::= -- component_SELECTOR_NAME {| component_SELECTOR_NAME} --- 3263,3271 ---- -- node (which appears as a singleton list). Box_Present gives support -- to Ada 2005 (AI-287). ! ---------------------------------- ! -- 4.3.1 Component Choice List -- ! ---------------------------------- -- COMPONENT_CHOICE_LIST ::= -- component_SELECTOR_NAME {| component_SELECTOR_NAME} *************** package Sinfo is *** 3340,3346 **** -- No nodes are generated for any of these constructs. Instead, the -- node for the operator appears directly. When we refer to an -- expression in this description, we mean any of the possible ! -- consistuent components of an expression (e.g. identifier is -- an example of an expression). ------------------ --- 3360,3366 ---- -- No nodes are generated for any of these constructs. Instead, the -- node for the operator appears directly. When we refer to an -- expression in this description, we mean any of the possible ! -- constituent components of an expression (e.g. identifier is -- an example of an expression). ------------------ *************** package Sinfo is *** 3372,3379 **** -- subexpression node (it is actually present in all nodes, but only -- used in subexpression nodes). This count records the number of -- levels of parentheses. If the number of levels in the source exceeds ! -- the maximum accomodated by this count, then the count is simply left ! -- at the maximum value. This means that there are some pathalogical -- cases of failure to detect conformance failures (e.g. an expression -- with 500 levels of parens will conform with one with 501 levels), -- but we do not need to lose sleep over this. --- 3392,3399 ---- -- subexpression node (it is actually present in all nodes, but only -- used in subexpression nodes). This count records the number of -- levels of parentheses. If the number of levels in the source exceeds ! -- the maximum accommodated by this count, then the count is simply left ! -- at the maximum value. This means that there are some pathological -- cases of failure to detect conformance failures (e.g. an expression -- with 500 levels of parens will conform with one with 501 levels), -- but we do not need to lose sleep over this. *************** package Sinfo is *** 3710,3716 **** -- Note: Although the parser will not accept a declaration as a -- statement, the semantic analyzer may insert declarations (e.g. -- declarations of implicit types needed for execution of other ! -- statements) into a sequence of statements, so the code genmerator -- should be prepared to accept a declaration where a statement is -- expected. Note also that pragmas can appear as statements. --- 3730,3736 ---- -- Note: Although the parser will not accept a declaration as a -- statement, the semantic analyzer may insert declarations (e.g. -- declarations of implicit types needed for execution of other ! -- statements) into a sequence of statements, so the code generator -- should be prepared to accept a declaration where a statement is -- expected. Note also that pragmas can appear as statements. *************** package Sinfo is *** 3778,3784 **** -- 5.1 Statement Identifier -- ------------------------------- ! -- STATEMENT_INDENTIFIER ::= DIRECT_NAME -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier -- (not an OPERATOR_SYMBOL) --- 3798,3804 ---- -- 5.1 Statement Identifier -- ------------------------------- ! -- STATEMENT_IDENTIFIER ::= DIRECT_NAME -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier -- (not an OPERATOR_SYMBOL) *************** package Sinfo is *** 3809,3815 **** -- the Expression may not have the form of an aggregate (since this -- might cause the back end to generate separate assignments). It -- also cannot be a reference to an object marked as a true constant ! -- (Is_True_Constant flag set), where the object is itself initalized -- with an aggregate. If necessary the front end must generate an -- extra temporary (with Is_True_Constant set False), and initialize -- this temporary as required (the temporary itself is not atomic). --- 3829,3835 ---- -- the Expression may not have the form of an aggregate (since this -- might cause the back end to generate separate assignments). It -- also cannot be a reference to an object marked as a true constant ! -- (Is_True_Constant flag set), where the object is itself initialized -- with an aggregate. If necessary the front end must generate an -- extra temporary (with Is_True_Constant set False), and initialize -- this temporary as required (the temporary itself is not atomic). *************** package Sinfo is *** 4272,4277 **** --- 4292,4298 ---- -- Is_Entry_Barrier_Function (Flag8-Sem) -- Is_Task_Master (Flag5-Sem) -- Was_Originally_Stub (Flag13-Sem) + -- Has_Relative_Deadline_Pragma (Flag9-Sem) ----------------------------------- -- 6.4 Procedure Call Statement -- *************** package Sinfo is *** 4681,4687 **** -- TASK_TYPE_DECLARATION ::= -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] ! -- [is [new INTERFACE_LIST with] TASK_DEFINITITION]; -- N_Task_Type_Declaration -- Sloc points to TASK --- 4702,4708 ---- -- TASK_TYPE_DECLARATION ::= -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] ! -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; -- N_Task_Type_Declaration -- Sloc points to TASK *************** package Sinfo is *** 4698,4704 **** -- SINGLE_TASK_DECLARATION ::= -- task DEFINING_IDENTIFIER ! -- [is [new INTERFACE_LIST with] TASK_DEFINITITION]; -- N_Single_Task_Declaration -- Sloc points to TASK --- 4719,4725 ---- -- SINGLE_TASK_DECLARATION ::= -- task DEFINING_IDENTIFIER ! -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; -- N_Single_Task_Declaration -- Sloc points to TASK *************** package Sinfo is *** 4728,4733 **** --- 4749,4755 ---- -- Has_Storage_Size_Pragma (Flag5-Sem) -- Has_Task_Info_Pragma (Flag7-Sem) -- Has_Task_Name_Pragma (Flag8-Sem) + -- Has_Relative_Deadline_Pragma (Flag9-Sem) -------------------- -- 9.1 Task Item -- *************** package Sinfo is *** 5086,5092 **** -- GUARD ::= when CONDITION => -- As noted above, the CONDITION that is part of a GUARD is included ! -- in the node for the select alernative for convenience. ------------------------------- -- 9.7.1 Select Alternative -- --- 5108,5114 ---- -- GUARD ::= when CONDITION => -- As noted above, the CONDITION that is part of a GUARD is included ! -- in the node for the select alternative for convenience. ------------------------------- -- 9.7.1 Select Alternative -- *************** package Sinfo is *** 5282,5288 **** -- CONTEXT_CLAUSE LIBRARY_ITEM -- | CONTEXT_CLAUSE SUBUNIT ! -- The N_Compilation_Unit node itself respresents the above syntax. -- However, there are two additional items not reflected in the above -- syntax. First we have the global declarations that are added by the -- code generator. These are outer level declarations (so they cannot --- 5304,5310 ---- -- CONTEXT_CLAUSE LIBRARY_ITEM -- | CONTEXT_CLAUSE SUBUNIT ! -- The N_Compilation_Unit node itself represents the above syntax. -- However, there are two additional items not reflected in the above -- syntax. First we have the global declarations that are added by the -- code generator. These are outer level declarations (so they cannot *************** package Sinfo is *** 5344,5360 **** -- the declaration or body, and the flag for private if present, -- appear in the N_Compilation_Unit clause. ! ---------------------------------------- ! -- 10.1.1 Library Unit Declararation -- ! ---------------------------------------- -- LIBRARY_UNIT_DECLARATION ::= -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION ! ------------------------------------------------- ! -- 10.1.1 Library Unit Renaming Declararation -- ! ------------------------------------------------- -- LIBRARY_UNIT_RENAMING_DECLARATION ::= -- PACKAGE_RENAMING_DECLARATION --- 5366,5382 ---- -- the declaration or body, and the flag for private if present, -- appear in the N_Compilation_Unit clause. ! -------------------------------------- ! -- 10.1.1 Library Unit Declaration -- ! -------------------------------------- -- LIBRARY_UNIT_DECLARATION ::= -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION ! ----------------------------------------------- ! -- 10.1.1 Library Unit Renaming Declaration -- ! ----------------------------------------------- -- LIBRARY_UNIT_RENAMING_DECLARATION ::= -- PACKAGE_RENAMING_DECLARATION *************** package Sinfo is *** 5523,5532 **** -- EXCEPTION_DECLARATION ::= DEFINING_IDENTIFIER_LIST : exception; ! -- For consistency with object declarations etc, the parser converts -- the case of multiple identifiers being declared to a series of -- declarations in which the expression is copied, using the More_Ids ! -- and Prev_Ids flags to remember the souce form as described in the -- section on "Handling of Defining Identifier Lists". -- N_Exception_Declaration --- 5545,5554 ---- -- EXCEPTION_DECLARATION ::= DEFINING_IDENTIFIER_LIST : exception; ! -- For consistency with object declarations etc., the parser converts -- the case of multiple identifiers being declared to a series of -- declarations in which the expression is copied, using the More_Ids ! -- and Prev_Ids flags to remember the source form as described in the -- section on "Handling of Defining Identifier Lists". -- N_Exception_Declaration *************** package Sinfo is *** 5660,5665 **** --- 5682,5688 ---- -- Sloc points to RAISE -- Name (Node2) (set to Empty if no exception name present) -- Expression (Node3) (set to Empty if no expression present) + -- From_At_End (Flag4-Sem) ------------------------------- -- 12.1 Generic Declaration -- *************** package Sinfo is *** 5772,5780 **** -- Note: overriding indicator is an Ada 2005 feature ! ------------------------------ ! -- 12.3 Generic Actual Part -- ! ------------------------------ -- GENERIC_ACTUAL_PART ::= -- (GENERIC_ASSOCIATION {, GENERIC_ASSOCIATION}) --- 5795,5803 ---- -- Note: overriding indicator is an Ada 2005 feature ! ------------------------------- ! -- 12.3 Generic Actual Part -- ! ------------------------------- -- GENERIC_ACTUAL_PART ::= -- (GENERIC_ASSOCIATION {, GENERIC_ASSOCIATION}) *************** package Sinfo is *** 5787,5795 **** -- [generic_formal_parameter_SELECTOR_NAME =>] -- Note: unlike the procedure call case, a generic association node ! -- is generated for every association, even if no formal is present. ! -- In this case the parser will leave the Selector_Name field set ! -- to Empty, to be filled in later by the semantic pass. -- In Ada 2005, a formal may be associated with a box, if the -- association is part of the list of actuals for a formal package. --- 5810,5819 ---- -- [generic_formal_parameter_SELECTOR_NAME =>] -- Note: unlike the procedure call case, a generic association node ! -- is generated for every association, even if no formal parameter ! -- selector name is present. In this case the parser will leave the ! -- Selector_Name field set to Empty, to be filled in later by the ! -- semantic pass. -- In Ada 2005, a formal may be associated with a box, if the -- association is part of the list of actuals for a formal package. *************** package Sinfo is *** 6579,6585 **** -- the exception to be raised (i.e. it is equivalent to a raise -- statement that raises the corresponding exception). This use -- is distinguished by the fact that the Etype in this case is ! -- Standard_Void_Type, In the subexprssion case, the Etype is the -- same as the type of the subexpression which it replaces. -- If Condition is empty, then the raise is unconditional. If the --- 6603,6609 ---- -- the exception to be raised (i.e. it is equivalent to a raise -- statement that raises the corresponding exception). This use -- is distinguished by the fact that the Etype in this case is ! -- Standard_Void_Type, In the subexpression case, the Etype is the -- same as the type of the subexpression which it replaces. -- If Condition is empty, then the raise is unconditional. If the *************** package Sinfo is *** 6864,6870 **** -- The following is the definition of the Node_Kind type. As previously -- discussed, this is separated off to allow rearrangement of the order ! -- to facilitiate definition of subtype ranges. The comments show the -- subtype classes which apply to each set of node kinds. The first -- entry in the comment characterizes the following list of nodes. --- 6888,6894 ---- -- The following is the definition of the Node_Kind type. As previously -- discussed, this is separated off to allow rearrangement of the order ! -- to facilitate definition of subtype ranges. The comments show the -- subtype classes which apply to each set of node kinds. The first -- entry in the comment characterizes the following list of nodes. *************** package Sinfo is *** 6886,6892 **** -- N_Has_Chars N_Empty, - N_Pragma, N_Pragma_Argument_Association, -- N_Has_Etype --- 6910,6915 ---- *************** package Sinfo is *** 6983,6992 **** N_Conditional_Expression, N_Explicit_Dereference, N_Function_Call, - N_Indexed_Component, N_Integer_Literal, - N_Null, N_Or_Else, N_Procedure_Call_Statement, --- 7006,7013 ---- *************** package Sinfo is *** 7130,7136 **** N_Null_Statement, N_Raise_Statement, N_Requeue_Statement, ! N_Return_Statement, -- renamed as N_Simple_Return_Statement in Sem_Util N_Extended_Return_Statement, N_Selective_Accept, N_Timed_Entry_Call, --- 7151,7157 ---- N_Null_Statement, N_Raise_Statement, N_Requeue_Statement, ! N_Return_Statement, -- renamed as N_Simple_Return_Statement below N_Extended_Return_Statement, N_Selective_Accept, N_Timed_Entry_Call, *************** package Sinfo is *** 7215,7220 **** --- 7236,7242 ---- N_Package_Specification, N_Parameter_Association, N_Parameter_Specification, + N_Pragma, N_Protected_Definition, N_Range_Constraint, N_Real_Range_Specification, *************** package Sinfo is *** 7796,7801 **** --- 7818,7826 ---- function Forwards_OK (N : Node_Id) return Boolean; -- Flag5 + function From_At_End + (N : Node_Id) return Boolean; -- Flag4 + function From_At_Mod (N : Node_Id) return Boolean; -- Flag4 *************** package Sinfo is *** 7844,7849 **** --- 7869,7877 ---- function Has_Private_View (N : Node_Id) return Boolean; -- Flag11 + function Has_Relative_Deadline_Pragma + (N : Node_Id) return Boolean; -- Flag9 + function Has_Self_Reference (N : Node_Id) return Boolean; -- Flag13 *************** package Sinfo is *** 8024,8029 **** --- 8052,8060 ---- function Next_Named_Actual (N : Node_Id) return Node_Id; -- Node4 + function Next_Pragma + (N : Node_Id) return Node_Id; -- Node1 + function Next_Rep_Item (N : Node_Id) return Node_Id; -- Node5 *************** package Sinfo is *** 8084,8089 **** --- 8115,8123 ---- function Parent_Spec (N : Node_Id) return Node_Id; -- Node4 + function PPC_Enabled + (N : Node_Id) return Boolean; -- Flag5 + function Position (N : Node_Id) return Node_Id; -- Node2 *************** package Sinfo is *** 8666,8671 **** --- 8700,8708 ---- procedure Set_From_At_Mod (N : Node_Id; Val : Boolean := True); -- Flag4 + procedure Set_From_At_End + (N : Node_Id; Val : Boolean := True); -- Flag4 + procedure Set_From_Default (N : Node_Id; Val : Boolean := True); -- Flag6 *************** package Sinfo is *** 8711,8716 **** --- 8748,8756 ---- procedure Set_Has_Private_View (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Has_Relative_Deadline_Pragma + (N : Node_Id; Val : Boolean := True); -- Flag9 + procedure Set_Has_Self_Reference (N : Node_Id; Val : Boolean := True); -- Flag13 *************** package Sinfo is *** 8891,8896 **** --- 8931,8939 ---- procedure Set_Next_Named_Actual (N : Node_Id; Val : Node_Id); -- Node4 + procedure Set_Next_Pragma + (N : Node_Id; Val : Node_Id); -- Node1 + procedure Set_Next_Rep_Item (N : Node_Id; Val : Node_Id); -- Node5 *************** package Sinfo is *** 8951,8956 **** --- 8994,9002 ---- procedure Set_Parent_Spec (N : Node_Id; Val : Node_Id); -- Node4 + procedure Set_PPC_Enabled + (N : Node_Id; Val : Boolean := True); -- Flag5 + procedure Set_Position (N : Node_Id; Val : Node_Id); -- Node2 *************** package Sinfo is *** 9173,9179 **** -- Node_Kind Membership Tests -- -------------------------------- ! -- The following functions allow a convenient notation for testing wheter -- a Node_Kind value matches any one of a list of possible values. In each -- case True is returned if the given T argument is equal to any of the V -- arguments. Note that there is a similar set of functions defined in --- 9219,9225 ---- -- Node_Kind Membership Tests -- -------------------------------- ! -- The following functions allow a convenient notation for testing whether -- a Node_Kind value matches any one of a list of possible values. In each -- case True is returned if the given T argument is equal to any of the V -- arguments. Note that there is a similar set of functions defined in *************** package Sinfo is *** 9238,9243 **** --- 9284,9297 ---- pragma Inline (Nkind_In); -- Inline all above functions + ----------------------- + -- Utility Functions -- + ----------------------- + + function Pragma_Name (N : Node_Id) return Name_Id; + pragma Inline (Pragma_Name); + -- Convenient function to obtain Chars field of Pragma_Identifier + ----------------------------- -- Syntactic Parent Tables -- ----------------------------- *************** package Sinfo is *** 9289,9295 **** 5 => False), -- Etype (Node5-Sem) N_Pragma => ! (1 => True, -- Chars (Name1) 2 => True, -- Pragma_Argument_Associations (List2) 3 => True, -- Debug_Statement (Node3) 4 => True, -- Pragma_Identifier (Node4) --- 9343,9349 ---- 5 => False), -- Etype (Node5-Sem) N_Pragma => ! (1 => False, -- Next_Pragma (Node1-Sem) 2 => True, -- Pragma_Argument_Associations (List2) 3 => True, -- Debug_Statement (Node3) 4 => True, -- Pragma_Identifier (Node4) *************** package Sinfo is *** 10908,10913 **** --- 10962,10968 ---- pragma Inline (Float_Truncate); pragma Inline (Formal_Type_Definition); pragma Inline (Forwards_OK); + pragma Inline (From_At_End); pragma Inline (From_At_Mod); pragma Inline (From_Default); pragma Inline (Generic_Associations); *************** package Sinfo is *** 10925,10930 **** --- 10980,10986 ---- pragma Inline (Has_No_Elaboration_Code); pragma Inline (Has_Priority_Pragma); pragma Inline (Has_Private_View); + pragma Inline (Has_Relative_Deadline_Pragma); pragma Inline (Has_Storage_Size_Pragma); pragma Inline (Has_Task_Info_Pragma); pragma Inline (Has_Task_Name_Pragma); *************** package Sinfo is *** 10984,10989 **** --- 11040,11046 ---- pragma Inline (Names); pragma Inline (Next_Entity); pragma Inline (Next_Named_Actual); + pragma Inline (Next_Pragma); pragma Inline (Next_Rep_Item); pragma Inline (Next_Use_Clause); pragma Inline (No_Ctrl_Actions); *************** package Sinfo is *** 11004,11009 **** --- 11061,11067 ---- pragma Inline (Parameter_List_Truncated); pragma Inline (Parameter_Type); pragma Inline (Parent_Spec); + pragma Inline (PPC_Enabled); pragma Inline (Position); pragma Inline (Pragma_Argument_Associations); pragma Inline (Pragma_Identifier); *************** package Sinfo is *** 11194,11199 **** --- 11252,11258 ---- pragma Inline (Set_Float_Truncate); pragma Inline (Set_Formal_Type_Definition); pragma Inline (Set_Forwards_OK); + pragma Inline (Set_From_At_End); pragma Inline (Set_From_At_Mod); pragma Inline (Set_From_Default); pragma Inline (Set_Generic_Associations); *************** package Sinfo is *** 11210,11215 **** --- 11269,11275 ---- pragma Inline (Set_Has_No_Elaboration_Code); pragma Inline (Set_Has_Priority_Pragma); pragma Inline (Set_Has_Private_View); + pragma Inline (Set_Has_Relative_Deadline_Pragma); pragma Inline (Set_Has_Storage_Size_Pragma); pragma Inline (Set_Has_Task_Info_Pragma); pragma Inline (Set_Has_Task_Name_Pragma); *************** package Sinfo is *** 11270,11275 **** --- 11330,11337 ---- pragma Inline (Set_Names); pragma Inline (Set_Next_Entity); pragma Inline (Set_Next_Named_Actual); + pragma Inline (Set_Next_Pragma); + pragma Inline (Set_Next_Rep_Item); pragma Inline (Set_Next_Use_Clause); pragma Inline (Set_No_Ctrl_Actions); pragma Inline (Set_No_Elaboration_Check); *************** package Sinfo is *** 11289,11294 **** --- 11351,11357 ---- pragma Inline (Set_Parameter_List_Truncated); pragma Inline (Set_Parameter_Type); pragma Inline (Set_Parent_Spec); + pragma Inline (Set_PPC_Enabled); pragma Inline (Set_Position); pragma Inline (Set_Pragma_Argument_Associations); pragma Inline (Set_Pragma_Identifier); diff -Nrcpad gcc-4.3.3/gcc/ada/sinput-d.ads gcc-4.4.0/gcc/ada/sinput-d.ads *** gcc-4.3.3/gcc/ada/sinput-d.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sinput-d.ads Sun Apr 13 18:03:09 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package Sinput.D is *** 48,54 **** -- an end of line character). On entry Loc is the Sloc value previously -- returned by Create_Debug_Source or Write_Debug_Line, and on exit, -- Sloc is updated to point to the start of the next line to be written, ! -- taking into account the length of the ternminator that was written by -- Write_Debug_Info. procedure Close_Debug_Source; --- 48,54 ---- -- an end of line character). On entry Loc is the Sloc value previously -- returned by Create_Debug_Source or Write_Debug_Line, and on exit, -- Sloc is updated to point to the start of the next line to be written, ! -- taking into account the length of the terminator that was written by -- Write_Debug_Info. procedure Close_Debug_Source; diff -Nrcpad gcc-4.3.3/gcc/ada/sinput-l.adb gcc-4.4.0/gcc/ada/sinput-l.adb *** gcc-4.3.3/gcc/ada/sinput-l.adb Thu Dec 13 10:33:25 2007 --- gcc-4.4.0/gcc/ada/sinput-l.adb Mon Aug 4 09:17:44 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Atree; use Atree; *** 28,33 **** --- 28,35 ---- with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; + with Fname; use Fname; + with Hostparm; with Opt; use Opt; with Osint; use Osint; with Output; use Output; *************** with Sinfo; use Sinfo; *** 39,44 **** --- 41,48 ---- with Snames; use Snames; with System; use System; + with System.OS_Lib; use System.OS_Lib; + with Unchecked_Conversion; package body Sinput.L is *************** package body Sinput.L is *** 55,61 **** -- When a file is to be preprocessed and the options to list symbols -- has been selected (switch -s), Prep.List_Symbols is called with a ! -- "foreword", a single line indicationg what source the symbols apply to. -- The following two constant String are the start and the end of this -- foreword. --- 59,65 ---- -- When a file is to be preprocessed and the options to list symbols -- has been selected (switch -s), Prep.List_Symbols is called with a ! -- "foreword", a single line indicating what source the symbols apply to. -- The following two constant String are the start and the end of this -- foreword. *************** package body Sinput.L is *** 319,325 **** -- source will be the last created, and we will be able to replace it -- and modify Hi without stepping on another buffer. ! if T = Osint.Source then Prepare_To_Preprocess (Source => N, Preprocessing_Needed => Preprocessing_Needed); end if; --- 323,329 ---- -- source will be the last created, and we will be able to replace it -- and modify Hi without stepping on another buffer. ! if T = Osint.Source and then not Is_Internal_File_Name (N) then Prepare_To_Preprocess (Source => N, Preprocessing_Needed => Preprocessing_Needed); end if; *************** package body Sinput.L is *** 475,480 **** --- 479,486 ---- -- Saved state of the Style_Check flag (which needs to be -- temporarily set to False during preprocessing, see below). + Modified : Boolean; + begin -- If this is the first time we preprocess a source, allocate -- the preprocessing buffer. *************** package body Sinput.L is *** 512,518 **** Save_Style_Check := Opt.Style_Check; Opt.Style_Check := False; ! Preprocess; -- Reset the scanner to its standard behavior, and restore the -- Style_Checks flag. --- 518,524 ---- Save_Style_Check := Opt.Style_Check; Opt.Style_Check := False; ! Preprocess (Modified); -- Reset the scanner to its standard behavior, and restore the -- Style_Checks flag. *************** package body Sinput.L is *** 531,536 **** --- 537,590 ---- return No_Source_File; else + -- Output the result of the preprocessing, if requested and + -- the source has been modified by the preprocessing. + + if Generate_Processed_File and then Modified then + declare + FD : File_Descriptor; + NB : Integer; + Status : Boolean; + + begin + Get_Name_String (N); + + if Hostparm.OpenVMS then + Add_Str_To_Name_Buffer ("_prep"); + else + Add_Str_To_Name_Buffer (".prep"); + end if; + + Delete_File (Name_Buffer (1 .. Name_Len), Status); + + FD := + Create_New_File (Name_Buffer (1 .. Name_Len), Text); + + Status := FD /= Invalid_FD; + + if Status then + NB := + Write + (FD, + Prep_Buffer (1)'Address, + Integer (Prep_Buffer_Last)); + Status := NB = Integer (Prep_Buffer_Last); + end if; + + if Status then + Close (FD, Status); + end if; + + if not Status then + Errout.Error_Msg + ("could not write processed file """ & + Name_Buffer (1 .. Name_Len) & '"', + Lo); + return No_Source_File; + end if; + end; + end if; + -- Set the new value of Hi Hi := Lo + Source_Ptr (Prep_Buffer_Last); *************** package body Sinput.L is *** 581,587 **** Source_File.Table (X).Source_Last := Hi; -- Reset Last_Line to 1, because the lines do not ! -- have neccessarily the same starts and lengths. Source_File.Table (X).Last_Source_Line := 1; end; --- 635,641 ---- Source_File.Table (X).Source_Last := Hi; -- Reset Last_Line to 1, because the lines do not ! -- have necessarily the same starts and lengths. Source_File.Table (X).Last_Source_Line := 1; end; diff -Nrcpad gcc-4.3.3/gcc/ada/sinput-l.ads gcc-4.4.0/gcc/ada/sinput-l.ads *** gcc-4.3.3/gcc/ada/sinput-l.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sinput-l.ads Sun Apr 13 18:03:09 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Sinput.L is *** 94,100 **** -- Inst_Node is the instantiation node, and Template_Id is the defining -- identifier of the generic declaration or body unit as appropriate. -- A is set to an adjustment factor to be used in subsequent calls to ! -- Adjust_Instantiation_Sloc. The instantiation mechnaism is also used -- for inlined function and procedure calls. The parameter Inlined_Body -- is set to True in such cases, and False for a generic instantiation. -- This is used for generating error messages that distinguish these --- 94,100 ---- -- Inst_Node is the instantiation node, and Template_Id is the defining -- identifier of the generic declaration or body unit as appropriate. -- A is set to an adjustment factor to be used in subsequent calls to ! -- Adjust_Instantiation_Sloc. The instantiation mechanism is also used -- for inlined function and procedure calls. The parameter Inlined_Body -- is set to True in such cases, and False for a generic instantiation. -- This is used for generating error messages that distinguish these diff -Nrcpad gcc-4.3.3/gcc/ada/sinput-p.adb gcc-4.4.0/gcc/ada/sinput-p.adb *** gcc-4.3.3/gcc/ada/sinput-p.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sinput-p.adb Wed May 28 15:55:52 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Sinput.P is *** 95,100 **** --- 95,105 ---- begin Prj.Err.Scanner.Initialize_Scanner (X); + -- No error for special characters that are used for preprocessing + + Prj.Err.Scanner.Set_Special_Character ('#'); + Prj.Err.Scanner.Set_Special_Character ('$'); + -- We scan past junk to the first interesting compilation unit -- token, to see if it is SEPARATE. We ignore WITH keywords during -- this and also PRIVATE. The reason for ignoring PRIVATE is that *************** package body Sinput.P is *** 108,113 **** --- 113,120 ---- Prj.Err.Scanner.Scan; end loop; + Prj.Err.Scanner.Reset_Special_Characters; + return Token = Tok_Separate; end Source_File_Is_Subunit; diff -Nrcpad gcc-4.3.3/gcc/ada/sinput-p.ads gcc-4.4.0/gcc/ada/sinput-p.ads *** gcc-4.3.3/gcc/ada/sinput-p.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sinput-p.ads Thu May 29 08:06:21 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Scans; use Scans; *** 32,39 **** package Sinput.P is function Load_Project_File (Path : String) return Source_File_Index; ! -- Load into memory the source of a project source file. ! -- Initialize the Scans state. procedure Reset_First; -- Indicate that the next project loaded should be considered as the first --- 32,39 ---- package Sinput.P is function Load_Project_File (Path : String) return Source_File_Index; ! -- Load the source of a project source file into memory and initialize the ! -- Scans state. procedure Reset_First; -- Indicate that the next project loaded should be considered as the first *************** package Sinput.P is *** 41,53 **** -- is to get the correct number of lines when error finalization is called. function Source_File_Is_Subunit (X : Source_File_Index) return Boolean; ! -- This function determines if a source file represents a subunit. It ! -- works by scanning for the first compilation unit token, and returning ! -- True if it is the token SEPARATE. It will return False otherwise, ! -- meaning that the file cannot possibly be a legal subunit. This ! -- function does NOT do a complete parse of the file, or build a ! -- tree. It is used in gnatmake to decide if a body without a spec ! -- in a project file needs to be compiled or not. type Saved_Project_Scan_State is limited private; -- Used to save project scan state in following two routines --- 41,53 ---- -- is to get the correct number of lines when error finalization is called. function Source_File_Is_Subunit (X : Source_File_Index) return Boolean; ! -- This function determines if a source file represents a subunit. It works ! -- by scanning for the first compilation unit token, and returning True if ! -- it is the token SEPARATE. It will return False otherwise, meaning that ! -- the file cannot possibly be a legal subunit. This function does NOT do a ! -- complete parse of the file, or build a tree. It is used in gnatmake and ! -- gprbuild to decide if a body without a spec in a project file needs to ! -- be compiled or not. type Saved_Project_Scan_State is limited private; -- Used to save project scan state in following two routines *************** package Sinput.P is *** 55,68 **** procedure Save_Project_Scan_State (Saved_State : out Saved_Project_Scan_State); pragma Inline (Save_Project_Scan_State); ! -- Save the Scans state, as well as the values of ! -- Source and Current_Source_File. procedure Restore_Project_Scan_State (Saved_State : Saved_Project_Scan_State); pragma Inline (Restore_Project_Scan_State); ! -- Restore the Scans state and the values of ! -- Source and Current_Source_File. private --- 55,68 ---- procedure Save_Project_Scan_State (Saved_State : out Saved_Project_Scan_State); pragma Inline (Save_Project_Scan_State); ! -- Save the Scans state, as well as the values of Source and ! -- Current_Source_File. procedure Restore_Project_Scan_State (Saved_State : Saved_Project_Scan_State); pragma Inline (Restore_Project_Scan_State); ! -- Restore the Scans state and the values of Source and ! -- Current_Source_File. private diff -Nrcpad gcc-4.3.3/gcc/ada/sinput.adb gcc-4.4.0/gcc/ada/sinput.adb *** gcc-4.3.3/gcc/ada/sinput.adb Thu Dec 13 10:32:56 2007 --- gcc-4.4.0/gcc/ada/sinput.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Sinput is *** 221,228 **** Ptr : Source_Ptr; begin - Name_Len := 0; - -- Loop through instantiations Ptr := Loc; --- 219,224 ---- *************** package body Sinput is *** 651,657 **** Chr : constant Character := Source (P); begin ! if Chr = CR then if Source (P + 1) = LF then P := P + 2; else --- 647,653 ---- Chr : constant Character := Source (P); begin ! if Chr = CR then if Source (P + 1) = LF then P := P + 2; else *************** package body Sinput is *** 659,665 **** end if; elsif Chr = LF then ! if Source (P) = CR then P := P + 2; else P := P + 1; --- 655,661 ---- end if; elsif Chr = LF then ! if Source (P + 1) = CR then P := P + 2; else P := P + 1; *************** package body Sinput is *** 765,781 **** null; else -- We have to recreate a proper pointer to the actual array -- from the zero origin pointer stored in the source table. Tmp1 := To_Source_Buffer_Ptr (S.Source_Text (S.Source_First)'Address); Free_Ptr (Tmp1); ! ! -- Note: we are using free here, because we used malloc ! -- or realloc directly to allocate the tables. That is ! -- because we were playing the big array trick. if S.Lines_Table /= null then Memory.Free (To_Address (S.Lines_Table)); --- 761,780 ---- null; else + -- Free the buffer, we use Free here, because we used malloc + -- or realloc directly to allocate the tables. That is + -- because we were playing the big array trick. We need to + -- suppress the warning for freeing from an empty pool! + -- We have to recreate a proper pointer to the actual array -- from the zero origin pointer stored in the source table. Tmp1 := To_Source_Buffer_Ptr (S.Source_Text (S.Source_First)'Address); + pragma Warnings (Off); Free_Ptr (Tmp1); ! pragma Warnings (On); if S.Lines_Table /= null then Memory.Free (To_Address (S.Lines_Table)); diff -Nrcpad gcc-4.3.3/gcc/ada/sinput.ads gcc-4.4.0/gcc/ada/sinput.ads *** gcc-4.3.3/gcc/ada/sinput.ads Wed Jun 6 10:23:26 2007 --- gcc-4.4.0/gcc/ada/sinput.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 60,66 **** -- reasonable to include this case for consistency. In addition, we recognize -- any of these sequences in any of the operating systems, for better -- behavior in treating foreign files (e.g. a Unix file with LF terminators ! -- transferred to a DOS system). Finally, wide character codes in cagtegories -- Separator, Line and Separator, Paragraph are considered to be physical -- line terminators. --- 58,64 ---- -- reasonable to include this case for consistency. In addition, we recognize -- any of these sequences in any of the operating systems, for better -- behavior in treating foreign files (e.g. a Unix file with LF terminators ! -- transferred to a DOS system). Finally, wide character codes in categories -- Separator, Line and Separator, Paragraph are considered to be physical -- line terminators. *************** package Sinput is *** 162,168 **** -- Note: fields marked read-only are set by Sinput or one of its child -- packages when a source file table entry is created, and cannot be ! -- subsqently modified, or alternatively are set only by very special -- circumstances, documented in the comments. -- File_Name : File_Name_Type (read-only) --- 160,166 ---- -- Note: fields marked read-only are set by Sinput or one of its child -- packages when a source file table entry is created, and cannot be ! -- subsequently modified, or alternatively are set only by very special -- circumstances, documented in the comments. -- File_Name : File_Name_Type (read-only) *************** package Sinput is *** 236,242 **** -- later on in this spec for a description of the checksum algorithm. -- Last_Source_Line : Physical_Line_Number; ! -- Physical line number of last source line. Whlie a file is being -- read, this refers to the last line scanned. Once a file has been -- completely scanned, it is the number of the last line in the file, -- and hence also gives the number of source lines in the file. --- 234,240 ---- -- later on in this spec for a description of the checksum algorithm. -- Last_Source_Line : Physical_Line_Number; ! -- Physical line number of last source line. While a file is being -- read, this refers to the last line scanned. Once a file has been -- completely scanned, it is the number of the last line in the file, -- and hence also gives the number of source lines in the file. *************** package Sinput is *** 465,477 **** -- that there definitely is a previous line in the source buffer. procedure Build_Location_String (Loc : Source_Ptr); ! -- This function builds a string literal of the form "name:line", ! -- where name is the file name corresponding to Loc, and line is ! -- the line number. In the event that instantiations are involved, ! -- additional suffixes of the same form are appended after the ! -- separating string " instantiated at ". The returned string is ! -- stored in Name_Buffer, terminated by ASCII.Nul, with Name_Length ! -- indicating the length not including the terminating Nul. function Get_Column_Number (P : Source_Ptr) return Column_Number; -- The ones-origin column number of the specified Source_Ptr value is --- 463,475 ---- -- that there definitely is a previous line in the source buffer. procedure Build_Location_String (Loc : Source_Ptr); ! -- This function builds a string literal of the form "name:line", where ! -- name is the file name corresponding to Loc, and line is the line number. ! -- In the event that instantiations are involved, additional suffixes of ! -- the same form are appended after the separating string " instantiated at ! -- ". The returned string is appended to the Name_Buffer, terminated by ! -- ASCII.NUL, with Name_Length indicating the length not including the ! -- terminating Nul. function Get_Column_Number (P : Source_Ptr) return Column_Number; -- The ones-origin column number of the specified Source_Ptr value is *************** package Sinput is *** 517,523 **** function Num_Source_Lines (S : Source_File_Index) return Nat; -- Returns the number of source lines (this is equivalent to reading ! -- the value of Last_Source_Line, but returns Nat rathern than a -- physical line number. procedure Register_Source_Ref_Pragma --- 515,521 ---- function Num_Source_Lines (S : Source_File_Index) return Nat; -- Returns the number of source lines (this is equivalent to reading ! -- the value of Last_Source_Line, but returns Nat rather than a -- physical line number. procedure Register_Source_Ref_Pragma *************** package Sinput is *** 565,576 **** procedure Skip_Line_Terminators (P : in out Source_Ptr; Physical : out Boolean); ! -- On entry, P points to a line terminator that has been encountered, ! -- which is one of FF,LF,VT,CR or a wide character sequence whose value is ! -- in category Separator,Line or Separator,Paragraph. The purpose of this ! -- P points just past the character that was scanned. The purpose of this ! -- routine is to distinguish physical and logical line endings. A physical ! -- line ending is one of: -- -- CR on its own (MAC System 7) -- LF on its own (Unix and unix-like systems) --- 563,574 ---- procedure Skip_Line_Terminators (P : in out Source_Ptr; Physical : out Boolean); ! -- On entry, P points to a line terminator that has been encountered, which ! -- is one of FF,LF,VT,CR or a wide character sequence whose value is in ! -- category Separator,Line or Separator,Paragraph. P points just past the ! -- character that was scanned. The purpose of this routine is to ! -- distinguish physical and logical line endings. A physical line ending is ! -- one of: -- -- CR on its own (MAC System 7) -- LF on its own (Unix and unix-like systems) *************** private *** 703,709 **** Sloc_Adjust : Source_Ptr; -- A value to be added to Sloc values for this file to reference the -- corresponding lines table. This is zero for the non-instantiation ! -- case, and set so that the adition references the ultimate template -- for the instantiation case. See Sinput-L for further details. Lines_Table : Lines_Table_Ptr; --- 701,707 ---- Sloc_Adjust : Source_Ptr; -- A value to be added to Sloc values for this file to reference the -- corresponding lines table. This is zero for the non-instantiation ! -- case, and set so that the addition references the ultimate template -- for the instantiation case. See Sinput-L for further details. Lines_Table : Lines_Table_Ptr; diff -Nrcpad gcc-4.3.3/gcc/ada/snames.adb gcc-4.4.0/gcc/ada/snames.adb *** gcc-4.3.3/gcc/ada/snames.adb Wed Dec 19 16:22:02 2007 --- gcc-4.4.0/gcc/ada/snames.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Snames is *** 78,85 **** --- 76,86 ---- "_local_final_list#" & "_master#" & "_object#" & + "_postconditions#" & "_priority#" & "_process_atsd#" & + "_relative_deadline#" & + "_result#" & "_secondary_stack#" & "_service#" & "_size#" & *************** package body Snames is *** 101,109 **** "finalize#" & "next#" & "prev#" & - "_typecode#" & - "_from_any#" & - "_to_any#" & "allocate#" & "deallocate#" & "dereference#" & --- 102,107 ---- *************** package body Snames is *** 145,151 **** "_call#" & "rci_name#" & "receiver#" & - "result#" & "rpc#" & "subp_id#" & "operation#" & --- 143,148 ---- *************** package body Snames is *** 180,187 **** --- 177,186 ---- "ada_05#" & "ada_2005#" & "assertion_policy#" & + "assume_no_invalid_values#" & "c_pass_by_copy#" & "check_name#" & + "check_policy#" & "compile_time_error#" & "compile_time_warning#" & "compiler_unit#" & *************** package body Snames is *** 206,213 **** "no_run_time#" & "no_strict_aliasing#" & "normalize_scalars#" & ! "polling#" & "persistent_bss#" & "priority_specific_dispatching#" & "profile#" & "profile_warnings#" & --- 205,213 ---- "no_run_time#" & "no_strict_aliasing#" & "normalize_scalars#" & ! "optimize_alignment#" & "persistent_bss#" & + "polling#" & "priority_specific_dispatching#" & "profile#" & "profile_warnings#" & *************** package body Snames is *** 238,243 **** --- 238,244 ---- "atomic#" & "atomic_components#" & "attach_handler#" & + "check#" & "cil_constructor#" & "comment#" & "common_object#" & *************** package body Snames is *** 298,303 **** --- 299,306 ---- "pack#" & "page#" & "passive#" & + "postcondition#" & + "precondition#" & "preelaborable_initialization#" & "preelaborate#" & "preelaborate_05#" & *************** package body Snames is *** 305,310 **** --- 308,314 ---- "pure#" & "pure_05#" & "pure_function#" & + "relative_deadline#" & "remote_call_interface#" & "remote_types#" & "share_generic#" & *************** package body Snames is *** 350,359 **** "dll#" & "win32#" & "as_is#" & "attribute_name#" & "body_file_name#" & "boolean_entry_barriers#" & - "check#" & "casing#" & "code#" & "component#" & --- 354,363 ---- "dll#" & "win32#" & "as_is#" & + "assertion#" & "attribute_name#" & "body_file_name#" & "boolean_entry_barriers#" & "casing#" & "code#" & "component#" & *************** package body Snames is *** 406,411 **** --- 410,416 ---- "secondary_stack_size#" & "section#" & "semaphore#" & + "short_descriptor#" & "simple_barriers#" & "spec_file_name#" & "state#" & *************** package body Snames is *** 457,462 **** --- 462,468 ---- "emax#" & "enabled#" & "enum_rep#" & + "enum_val#" & "epsilon#" & "exponent#" & "external_tag#" & *************** package body Snames is *** 467,475 **** --- 473,483 ---- "fore#" & "has_access_values#" & "has_discriminants#" & + "has_tagged_values#" & "identity#" & "img#" & "integer_value#" & + "invalid_value#" & "large#" & "last#" & "last_bit#" & *************** package body Snames is *** 495,500 **** --- 503,509 ---- "modulus#" & "null_parameter#" & "object_size#" & + "old#" & "partition_id#" & "passed_by_reference#" & "pool_address#" & *************** package body Snames is *** 503,508 **** --- 512,518 ---- "priority#" & "range#" & "range_length#" & + "result#" & "round#" & "safe_emax#" & "safe_first#" & *************** package body Snames is *** 543,548 **** --- 553,559 ---- "copy_sign#" & "floor#" & "fraction#" & + "from_any#" & "image#" & "input#" & "machine#" & *************** package body Snames is *** 553,559 **** --- 564,572 ---- "remainder#" & "rounding#" & "succ#" & + "to_any#" & "truncation#" & + "typecode#" & "value#" & "wide_image#" & "wide_wide_image#" & *************** package body Snames is *** 574,579 **** --- 587,593 ---- "priority_queuing#" & "edf_across_priorities#" & "fifo_within_priorities#" & + "non_preemptive_within_priorities#" & "round_robin_within_priorities#" & "access_check#" & "accessibility_check#" & *************** package body Snames is *** 677,683 **** --- 691,699 ---- "tagged#" & "raise_exception#" & "ada_roots#" & + "aggregate#" & "archive_builder#" & + "archive_builder_append_option#" & "archive_indexer#" & "archive_suffix#" & "binder#" & *************** package body Snames is *** 693,698 **** --- 709,715 ---- "config_file_unique#" & "config_spec_file_name#" & "config_spec_file_name_pattern#" & + "configuration#" & "cross_reference#" & "default_language#" & "default_switches#" & *************** package body Snames is *** 702,713 **** --- 719,732 ---- "driver#" & "excluded_source_dirs#" & "excluded_source_files#" & + "excluded_source_list_file#" & "exec_dir#" & "executable#" & "executable_suffix#" & "extends#" & "externally_built#" & "finder#" & + "global_compilation_switches#" & "global_configuration_pragmas#" & "global_config_file#" & "gnatls#" & *************** package body Snames is *** 718,726 **** --- 737,747 ---- "include_switches#" & "include_path#" & "include_path_file#" & + "inherit_source_path#" & "language_kind#" & "language_processing#" & "languages#" & + "library#" & "library_ali_dir#" & "library_auto_init#" & "library_auto_init_supported#" & *************** package body Snames is *** 747,760 **** --- 768,785 ---- "local_config_file#" & "local_configuration_pragmas#" & "locally_removed_files#" & + "map_file_option#" & "mapping_file_switches#" & "mapping_spec_suffix#" & "mapping_body_suffix#" & "metrics#" & "naming#" & + "object_generated#" & + "objects_linked#" & "objects_path#" & "objects_path_file#" & "object_dir#" & + "path_syntax#" & "pic_option#" & "pretty_printer#" & "prefix#" & *************** package body Snames is *** 778,783 **** --- 803,810 ---- "stack#" & "switches#" & "symbolic_link_supported#" & + "sync#" & + "synchronize#" & "toolchain_description#" & "toolchain_version#" & "runtime_library_dir#" & *************** package body Snames is *** 937,942 **** --- 964,971 ---- return Pragma_Interface; elsif N = Name_Priority then return Pragma_Priority; + elsif N = Name_Relative_Deadline then + return Pragma_Relative_Deadline; elsif N = Name_Storage_Size then return Pragma_Storage_Size; elsif N = Name_Storage_Unit then *************** package body Snames is *** 1126,1131 **** --- 1155,1161 ---- or else N = Name_AST_Entry or else N = Name_Fast_Math or else N = Name_Interface + or else N = Name_Relative_Deadline or else N = Name_Priority or else N = Name_Storage_Size or else N = Name_Storage_Unit; diff -Nrcpad gcc-4.3.3/gcc/ada/snames.ads gcc-4.4.0/gcc/ada/snames.ads *** gcc-4.3.3/gcc/ada/snames.ads Wed Dec 19 16:22:02 2007 --- gcc-4.4.0/gcc/ada/snames.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Snames is *** 40,46 **** -- the definitions of some enumeration types whose definitions are tied to -- the order of these preset names. ! -- WARNING: There is a C file, a-snames.h which duplicates some of the -- definitions in this file and must be kept properly synchronized. -- If you change this package, you should run xsnames. --- 38,44 ---- -- the definitions of some enumeration types whose definitions are tied to -- the order of these preset names. ! -- WARNING: There is a C file, snames.h which duplicates some of the -- definitions in this file and must be kept properly synchronized. -- If you change this package, you should run xsnames. *************** package Snames is *** 161,206 **** Name_uLocal_Final_List : constant Name_Id := N + 017; Name_uMaster : constant Name_Id := N + 018; Name_uObject : constant Name_Id := N + 019; ! Name_uPriority : constant Name_Id := N + 020; ! Name_uProcess_ATSD : constant Name_Id := N + 021; ! Name_uSecondary_Stack : constant Name_Id := N + 022; ! Name_uService : constant Name_Id := N + 023; ! Name_uSize : constant Name_Id := N + 024; ! Name_uStack : constant Name_Id := N + 025; ! Name_uTags : constant Name_Id := N + 026; ! Name_uTask : constant Name_Id := N + 027; ! Name_uTask_Id : constant Name_Id := N + 028; ! Name_uTask_Info : constant Name_Id := N + 029; ! Name_uTask_Name : constant Name_Id := N + 030; ! Name_uTrace_Sp : constant Name_Id := N + 031; -- Names of predefined primitives used in the expansion of dispatching -- requeue and select statements, Abort, 'Callable and 'Terminated. ! Name_uDisp_Asynchronous_Select : constant Name_Id := N + 032; ! Name_uDisp_Conditional_Select : constant Name_Id := N + 033; ! Name_uDisp_Get_Prim_Op_Kind : constant Name_Id := N + 034; ! Name_uDisp_Get_Task_Id : constant Name_Id := N + 035; ! Name_uDisp_Requeue : constant Name_Id := N + 036; ! Name_uDisp_Timed_Select : constant Name_Id := N + 037; -- Names of routines in Ada.Finalization, needed by expander ! Name_Initialize : constant Name_Id := N + 038; ! Name_Adjust : constant Name_Id := N + 039; ! Name_Finalize : constant Name_Id := N + 040; -- Names of fields declared in System.Finalization_Implementation, -- needed by the expander when generating code for finalization. ! Name_Next : constant Name_Id := N + 041; ! Name_Prev : constant Name_Id := N + 042; ! ! -- Names of TSS routines for implementation of DSA over PolyORB ! ! Name_uTypeCode : constant Name_Id := N + 043; ! Name_uFrom_Any : constant Name_Id := N + 044; ! Name_uTo_Any : constant Name_Id := N + 045; -- Names of allocation routines, also needed by expander --- 159,201 ---- Name_uLocal_Final_List : constant Name_Id := N + 017; Name_uMaster : constant Name_Id := N + 018; Name_uObject : constant Name_Id := N + 019; ! Name_uPostconditions : constant Name_Id := N + 020; ! Name_uPriority : constant Name_Id := N + 021; ! Name_uProcess_ATSD : constant Name_Id := N + 022; ! Name_uRelative_Deadline : constant Name_Id := N + 023; ! Name_uResult : constant Name_Id := N + 024; ! Name_uSecondary_Stack : constant Name_Id := N + 025; ! Name_uService : constant Name_Id := N + 026; ! Name_uSize : constant Name_Id := N + 027; ! Name_uStack : constant Name_Id := N + 028; ! Name_uTags : constant Name_Id := N + 029; ! Name_uTask : constant Name_Id := N + 030; ! Name_uTask_Id : constant Name_Id := N + 031; ! Name_uTask_Info : constant Name_Id := N + 032; ! Name_uTask_Name : constant Name_Id := N + 033; ! Name_uTrace_Sp : constant Name_Id := N + 034; -- Names of predefined primitives used in the expansion of dispatching -- requeue and select statements, Abort, 'Callable and 'Terminated. ! Name_uDisp_Asynchronous_Select : constant Name_Id := N + 035; ! Name_uDisp_Conditional_Select : constant Name_Id := N + 036; ! Name_uDisp_Get_Prim_Op_Kind : constant Name_Id := N + 037; ! Name_uDisp_Get_Task_Id : constant Name_Id := N + 038; ! Name_uDisp_Requeue : constant Name_Id := N + 039; ! Name_uDisp_Timed_Select : constant Name_Id := N + 040; -- Names of routines in Ada.Finalization, needed by expander ! Name_Initialize : constant Name_Id := N + 041; ! Name_Adjust : constant Name_Id := N + 042; ! Name_Finalize : constant Name_Id := N + 043; -- Names of fields declared in System.Finalization_Implementation, -- needed by the expander when generating code for finalization. ! Name_Next : constant Name_Id := N + 044; ! Name_Prev : constant Name_Id := N + 045; -- Names of allocation routines, also needed by expander *************** package Snames is *** 270,312 **** Name_uCall : constant Name_Id := N + 084; Name_RCI_Name : constant Name_Id := N + 085; Name_Receiver : constant Name_Id := N + 086; ! Name_Result : constant Name_Id := N + 087; ! Name_Rpc : constant Name_Id := N + 088; ! Name_Subp_Id : constant Name_Id := N + 089; ! Name_Operation : constant Name_Id := N + 090; ! Name_Argument : constant Name_Id := N + 091; ! Name_Arg_Modes : constant Name_Id := N + 092; ! Name_Handler : constant Name_Id := N + 093; ! Name_Target : constant Name_Id := N + 094; ! Name_Req : constant Name_Id := N + 095; ! Name_Obj_TypeCode : constant Name_Id := N + 096; ! Name_Stub : constant Name_Id := N + 097; -- Operator Symbol entries. The actual names have an upper case O at -- the start in place of the Op_ prefix (e.g. the actual name that -- corresponds to Name_Op_Abs is "Oabs". ! First_Operator_Name : constant Name_Id := N + 098; ! Name_Op_Abs : constant Name_Id := N + 098; -- "abs" ! Name_Op_And : constant Name_Id := N + 099; -- "and" ! Name_Op_Mod : constant Name_Id := N + 100; -- "mod" ! Name_Op_Not : constant Name_Id := N + 101; -- "not" ! Name_Op_Or : constant Name_Id := N + 102; -- "or" ! Name_Op_Rem : constant Name_Id := N + 103; -- "rem" ! Name_Op_Xor : constant Name_Id := N + 104; -- "xor" ! Name_Op_Eq : constant Name_Id := N + 105; -- "=" ! Name_Op_Ne : constant Name_Id := N + 106; -- "/=" ! Name_Op_Lt : constant Name_Id := N + 107; -- "<" ! Name_Op_Le : constant Name_Id := N + 108; -- "<=" ! Name_Op_Gt : constant Name_Id := N + 109; -- ">" ! Name_Op_Ge : constant Name_Id := N + 110; -- ">=" ! Name_Op_Add : constant Name_Id := N + 111; -- "+" ! Name_Op_Subtract : constant Name_Id := N + 112; -- "-" ! Name_Op_Concat : constant Name_Id := N + 113; -- "&" ! Name_Op_Multiply : constant Name_Id := N + 114; -- "*" ! Name_Op_Divide : constant Name_Id := N + 115; -- "/" ! Name_Op_Expon : constant Name_Id := N + 116; -- "**" ! Last_Operator_Name : constant Name_Id := N + 116; -- Names for all pragmas recognized by GNAT. The entries with the comment -- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95. --- 265,306 ---- Name_uCall : constant Name_Id := N + 084; Name_RCI_Name : constant Name_Id := N + 085; Name_Receiver : constant Name_Id := N + 086; ! Name_Rpc : constant Name_Id := N + 087; ! Name_Subp_Id : constant Name_Id := N + 088; ! Name_Operation : constant Name_Id := N + 089; ! Name_Argument : constant Name_Id := N + 090; ! Name_Arg_Modes : constant Name_Id := N + 091; ! Name_Handler : constant Name_Id := N + 092; ! Name_Target : constant Name_Id := N + 093; ! Name_Req : constant Name_Id := N + 094; ! Name_Obj_TypeCode : constant Name_Id := N + 095; ! Name_Stub : constant Name_Id := N + 096; -- Operator Symbol entries. The actual names have an upper case O at -- the start in place of the Op_ prefix (e.g. the actual name that -- corresponds to Name_Op_Abs is "Oabs". ! First_Operator_Name : constant Name_Id := N + 097; ! Name_Op_Abs : constant Name_Id := N + 097; -- "abs" ! Name_Op_And : constant Name_Id := N + 098; -- "and" ! Name_Op_Mod : constant Name_Id := N + 099; -- "mod" ! Name_Op_Not : constant Name_Id := N + 100; -- "not" ! Name_Op_Or : constant Name_Id := N + 101; -- "or" ! Name_Op_Rem : constant Name_Id := N + 102; -- "rem" ! Name_Op_Xor : constant Name_Id := N + 103; -- "xor" ! Name_Op_Eq : constant Name_Id := N + 104; -- "=" ! Name_Op_Ne : constant Name_Id := N + 105; -- "/=" ! Name_Op_Lt : constant Name_Id := N + 106; -- "<" ! Name_Op_Le : constant Name_Id := N + 107; -- "<=" ! Name_Op_Gt : constant Name_Id := N + 108; -- ">" ! Name_Op_Ge : constant Name_Id := N + 109; -- ">=" ! Name_Op_Add : constant Name_Id := N + 110; -- "+" ! Name_Op_Subtract : constant Name_Id := N + 111; -- "-" ! Name_Op_Concat : constant Name_Id := N + 112; -- "&" ! Name_Op_Multiply : constant Name_Id := N + 113; -- "*" ! Name_Op_Divide : constant Name_Id := N + 114; -- "/" ! Name_Op_Expon : constant Name_Id := N + 115; -- "**" ! Last_Operator_Name : constant Name_Id := N + 115; -- Names for all pragmas recognized by GNAT. The entries with the comment -- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95. *************** package Snames is *** 329,359 **** -- only in GNAT for the AAMP. They are ignored in other versions with -- appropriate warnings. ! First_Pragma_Name : constant Name_Id := N + 117; -- Configuration pragmas are grouped at start ! Name_Ada_83 : constant Name_Id := N + 117; -- GNAT ! Name_Ada_95 : constant Name_Id := N + 118; -- GNAT ! Name_Ada_05 : constant Name_Id := N + 119; -- GNAT ! Name_Ada_2005 : constant Name_Id := N + 120; -- GNAT ! Name_Assertion_Policy : constant Name_Id := N + 121; -- Ada 05 Name_C_Pass_By_Copy : constant Name_Id := N + 122; -- GNAT Name_Check_Name : constant Name_Id := N + 123; -- GNAT ! Name_Compile_Time_Error : constant Name_Id := N + 124; -- GNAT ! Name_Compile_Time_Warning : constant Name_Id := N + 125; -- GNAT ! Name_Compiler_Unit : constant Name_Id := N + 126; -- GNAT ! Name_Component_Alignment : constant Name_Id := N + 127; -- GNAT ! Name_Convention_Identifier : constant Name_Id := N + 128; -- GNAT ! Name_Debug_Policy : constant Name_Id := N + 129; -- GNAT ! Name_Detect_Blocking : constant Name_Id := N + 130; -- Ada 05 ! Name_Discard_Names : constant Name_Id := N + 131; ! Name_Elaboration_Checks : constant Name_Id := N + 132; -- GNAT ! Name_Eliminate : constant Name_Id := N + 133; -- GNAT ! Name_Extend_System : constant Name_Id := N + 134; -- GNAT ! Name_Extensions_Allowed : constant Name_Id := N + 135; -- GNAT ! Name_External_Name_Casing : constant Name_Id := N + 136; -- GNAT ! Name_Favor_Top_Level : constant Name_Id := N + 137; -- GNAT -- Note: Fast_Math is not in this list because its name matches -- GNAT -- the name of the corresponding attribute. However, it is --- 323,354 ---- -- only in GNAT for the AAMP. They are ignored in other versions with -- appropriate warnings. ! First_Pragma_Name : constant Name_Id := N + 116; -- Configuration pragmas are grouped at start ! Name_Ada_83 : constant Name_Id := N + 116; -- GNAT ! Name_Ada_95 : constant Name_Id := N + 117; -- GNAT ! Name_Ada_05 : constant Name_Id := N + 118; -- GNAT ! Name_Ada_2005 : constant Name_Id := N + 119; -- GNAT ! Name_Assertion_Policy : constant Name_Id := N + 120; -- Ada 05 ! Name_Assume_No_Invalid_Values : constant Name_Id := N + 121; -- GNAT Name_C_Pass_By_Copy : constant Name_Id := N + 122; -- GNAT Name_Check_Name : constant Name_Id := N + 123; -- GNAT ! Name_Check_Policy : constant Name_Id := N + 124; -- GNAT ! Name_Compile_Time_Error : constant Name_Id := N + 125; -- GNAT ! Name_Compile_Time_Warning : constant Name_Id := N + 126; -- GNAT ! Name_Compiler_Unit : constant Name_Id := N + 127; -- GNAT ! Name_Component_Alignment : constant Name_Id := N + 128; -- GNAT ! Name_Convention_Identifier : constant Name_Id := N + 129; -- GNAT ! Name_Debug_Policy : constant Name_Id := N + 130; -- GNAT ! Name_Detect_Blocking : constant Name_Id := N + 131; -- Ada 05 ! Name_Discard_Names : constant Name_Id := N + 132; ! Name_Elaboration_Checks : constant Name_Id := N + 133; -- GNAT ! Name_Eliminate : constant Name_Id := N + 134; -- GNAT ! Name_Extend_System : constant Name_Id := N + 135; -- GNAT ! Name_Extensions_Allowed : constant Name_Id := N + 136; -- GNAT ! Name_External_Name_Casing : constant Name_Id := N + 137; -- GNAT -- Note: Fast_Math is not in this list because its name matches -- GNAT -- the name of the corresponding attribute. However, it is *************** package Snames is *** 361,407 **** -- functions Get_Pragma_Id, Is_[Configuration_]Pragma_Id, and -- correctly recognize and process Fast_Math. ! Name_Float_Representation : constant Name_Id := N + 138; -- GNAT ! Name_Implicit_Packing : constant Name_Id := N + 139; -- GNAT ! Name_Initialize_Scalars : constant Name_Id := N + 140; -- GNAT ! Name_Interrupt_State : constant Name_Id := N + 141; -- GNAT ! Name_License : constant Name_Id := N + 142; -- GNAT ! Name_Locking_Policy : constant Name_Id := N + 143; ! Name_Long_Float : constant Name_Id := N + 144; -- VMS ! Name_No_Run_Time : constant Name_Id := N + 145; -- GNAT ! Name_No_Strict_Aliasing : constant Name_Id := N + 146; -- GNAT ! Name_Normalize_Scalars : constant Name_Id := N + 147; ! Name_Polling : constant Name_Id := N + 148; -- GNAT ! Name_Persistent_BSS : constant Name_Id := N + 149; -- GNAT ! Name_Priority_Specific_Dispatching : constant Name_Id := N + 150; -- Ada 05 ! Name_Profile : constant Name_Id := N + 151; -- Ada 05 ! Name_Profile_Warnings : constant Name_Id := N + 152; -- GNAT ! Name_Propagate_Exceptions : constant Name_Id := N + 153; -- GNAT ! Name_Queuing_Policy : constant Name_Id := N + 154; ! Name_Ravenscar : constant Name_Id := N + 155; -- GNAT ! Name_Restricted_Run_Time : constant Name_Id := N + 156; -- GNAT ! Name_Restrictions : constant Name_Id := N + 157; ! Name_Restriction_Warnings : constant Name_Id := N + 158; -- GNAT ! Name_Reviewable : constant Name_Id := N + 159; ! Name_Source_File_Name : constant Name_Id := N + 160; -- GNAT ! Name_Source_File_Name_Project : constant Name_Id := N + 161; -- GNAT ! Name_Style_Checks : constant Name_Id := N + 162; -- GNAT ! Name_Suppress : constant Name_Id := N + 163; ! Name_Suppress_Exception_Locations : constant Name_Id := N + 164; -- GNAT ! Name_Task_Dispatching_Policy : constant Name_Id := N + 165; ! Name_Universal_Data : constant Name_Id := N + 166; -- AAMP ! Name_Unsuppress : constant Name_Id := N + 167; -- GNAT ! Name_Use_VADS_Size : constant Name_Id := N + 168; -- GNAT ! Name_Validity_Checks : constant Name_Id := N + 169; -- GNAT ! Name_Warnings : constant Name_Id := N + 170; -- GNAT ! Name_Wide_Character_Encoding : constant Name_Id := N + 171; -- GNAT ! Last_Configuration_Pragma_Name : constant Name_Id := N + 171; -- Remaining pragma names ! Name_Abort_Defer : constant Name_Id := N + 172; -- GNAT ! Name_All_Calls_Remote : constant Name_Id := N + 173; ! Name_Annotate : constant Name_Id := N + 174; -- GNAT -- Note: AST_Entry is not in this list because its name matches -- VMS -- the name of the corresponding attribute. However, it is --- 356,404 ---- -- functions Get_Pragma_Id, Is_[Configuration_]Pragma_Id, and -- correctly recognize and process Fast_Math. ! Name_Favor_Top_Level : constant Name_Id := N + 138; -- GNAT ! Name_Float_Representation : constant Name_Id := N + 139; -- GNAT ! Name_Implicit_Packing : constant Name_Id := N + 140; -- GNAT ! Name_Initialize_Scalars : constant Name_Id := N + 141; -- GNAT ! Name_Interrupt_State : constant Name_Id := N + 142; -- GNAT ! Name_License : constant Name_Id := N + 143; -- GNAT ! Name_Locking_Policy : constant Name_Id := N + 144; ! Name_Long_Float : constant Name_Id := N + 145; -- VMS ! Name_No_Run_Time : constant Name_Id := N + 146; -- GNAT ! Name_No_Strict_Aliasing : constant Name_Id := N + 147; -- GNAT ! Name_Normalize_Scalars : constant Name_Id := N + 148; ! Name_Optimize_Alignment : constant Name_Id := N + 149; -- GNAT ! Name_Persistent_BSS : constant Name_Id := N + 150; -- GNAT ! Name_Polling : constant Name_Id := N + 151; -- GNAT ! Name_Priority_Specific_Dispatching : constant Name_Id := N + 152; -- Ada 05 ! Name_Profile : constant Name_Id := N + 153; -- Ada 05 ! Name_Profile_Warnings : constant Name_Id := N + 154; -- GNAT ! Name_Propagate_Exceptions : constant Name_Id := N + 155; -- GNAT ! Name_Queuing_Policy : constant Name_Id := N + 156; ! Name_Ravenscar : constant Name_Id := N + 157; -- GNAT ! Name_Restricted_Run_Time : constant Name_Id := N + 158; -- GNAT ! Name_Restrictions : constant Name_Id := N + 159; ! Name_Restriction_Warnings : constant Name_Id := N + 160; -- GNAT ! Name_Reviewable : constant Name_Id := N + 161; ! Name_Source_File_Name : constant Name_Id := N + 162; -- GNAT ! Name_Source_File_Name_Project : constant Name_Id := N + 163; -- GNAT ! Name_Style_Checks : constant Name_Id := N + 164; -- GNAT ! Name_Suppress : constant Name_Id := N + 165; ! Name_Suppress_Exception_Locations : constant Name_Id := N + 166; -- GNAT ! Name_Task_Dispatching_Policy : constant Name_Id := N + 167; ! Name_Universal_Data : constant Name_Id := N + 168; -- AAMP ! Name_Unsuppress : constant Name_Id := N + 169; -- Ada 05 ! Name_Use_VADS_Size : constant Name_Id := N + 170; -- GNAT ! Name_Validity_Checks : constant Name_Id := N + 171; -- GNAT ! Name_Warnings : constant Name_Id := N + 172; -- GNAT ! Name_Wide_Character_Encoding : constant Name_Id := N + 173; -- GNAT ! Last_Configuration_Pragma_Name : constant Name_Id := N + 173; -- Remaining pragma names ! Name_Abort_Defer : constant Name_Id := N + 174; -- GNAT ! Name_All_Calls_Remote : constant Name_Id := N + 175; ! Name_Annotate : constant Name_Id := N + 176; -- GNAT -- Note: AST_Entry is not in this list because its name matches -- VMS -- the name of the corresponding attribute. However, it is *************** package Snames is *** 409,482 **** -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize -- and process Name_AST_Entry. ! Name_Assert : constant Name_Id := N + 175; -- Ada 05 ! Name_Asynchronous : constant Name_Id := N + 176; ! Name_Atomic : constant Name_Id := N + 177; ! Name_Atomic_Components : constant Name_Id := N + 178; ! Name_Attach_Handler : constant Name_Id := N + 179; ! Name_CIL_Constructor : constant Name_Id := N + 180; -- GNAT ! Name_Comment : constant Name_Id := N + 181; -- GNAT ! Name_Common_Object : constant Name_Id := N + 182; -- GNAT ! Name_Complete_Representation : constant Name_Id := N + 183; -- GNAT ! Name_Complex_Representation : constant Name_Id := N + 184; -- GNAT ! Name_Controlled : constant Name_Id := N + 185; ! Name_Convention : constant Name_Id := N + 186; ! Name_CPP_Class : constant Name_Id := N + 187; -- GNAT ! Name_CPP_Constructor : constant Name_Id := N + 188; -- GNAT ! Name_CPP_Virtual : constant Name_Id := N + 189; -- GNAT ! Name_CPP_Vtable : constant Name_Id := N + 190; -- GNAT ! Name_Debug : constant Name_Id := N + 191; -- GNAT ! Name_Elaborate : constant Name_Id := N + 192; -- Ada 83 ! Name_Elaborate_All : constant Name_Id := N + 193; ! Name_Elaborate_Body : constant Name_Id := N + 194; ! Name_Export : constant Name_Id := N + 195; ! Name_Export_Exception : constant Name_Id := N + 196; -- VMS ! Name_Export_Function : constant Name_Id := N + 197; -- GNAT ! Name_Export_Object : constant Name_Id := N + 198; -- GNAT ! Name_Export_Procedure : constant Name_Id := N + 199; -- GNAT ! Name_Export_Value : constant Name_Id := N + 200; -- GNAT ! Name_Export_Valued_Procedure : constant Name_Id := N + 201; -- GNAT ! Name_External : constant Name_Id := N + 202; -- GNAT ! Name_Finalize_Storage_Only : constant Name_Id := N + 203; -- GNAT ! Name_Ident : constant Name_Id := N + 204; -- VMS ! Name_Implemented_By_Entry : constant Name_Id := N + 205; -- Ada 05 ! Name_Import : constant Name_Id := N + 206; ! Name_Import_Exception : constant Name_Id := N + 207; -- VMS ! Name_Import_Function : constant Name_Id := N + 208; -- GNAT ! Name_Import_Object : constant Name_Id := N + 209; -- GNAT ! Name_Import_Procedure : constant Name_Id := N + 210; -- GNAT ! Name_Import_Valued_Procedure : constant Name_Id := N + 211; -- GNAT ! Name_Inline : constant Name_Id := N + 212; ! Name_Inline_Always : constant Name_Id := N + 213; -- GNAT ! Name_Inline_Generic : constant Name_Id := N + 214; -- GNAT ! Name_Inspection_Point : constant Name_Id := N + 215; ! Name_Interface_Name : constant Name_Id := N + 216; -- GNAT ! Name_Interrupt_Handler : constant Name_Id := N + 217; ! Name_Interrupt_Priority : constant Name_Id := N + 218; ! Name_Java_Constructor : constant Name_Id := N + 219; -- GNAT ! Name_Java_Interface : constant Name_Id := N + 220; -- GNAT ! Name_Keep_Names : constant Name_Id := N + 221; -- GNAT ! Name_Link_With : constant Name_Id := N + 222; -- GNAT ! Name_Linker_Alias : constant Name_Id := N + 223; -- GNAT ! Name_Linker_Constructor : constant Name_Id := N + 224; -- GNAT ! Name_Linker_Destructor : constant Name_Id := N + 225; -- GNAT ! Name_Linker_Options : constant Name_Id := N + 226; ! Name_Linker_Section : constant Name_Id := N + 227; -- GNAT ! Name_List : constant Name_Id := N + 228; ! Name_Machine_Attribute : constant Name_Id := N + 229; -- GNAT ! Name_Main : constant Name_Id := N + 230; -- GNAT ! Name_Main_Storage : constant Name_Id := N + 231; -- GNAT ! Name_Memory_Size : constant Name_Id := N + 232; -- Ada 83 ! Name_No_Body : constant Name_Id := N + 233; -- GNAT ! Name_No_Return : constant Name_Id := N + 234; -- GNAT ! Name_Obsolescent : constant Name_Id := N + 235; -- GNAT ! Name_Optimize : constant Name_Id := N + 236; ! Name_Pack : constant Name_Id := N + 237; ! Name_Page : constant Name_Id := N + 238; ! Name_Passive : constant Name_Id := N + 239; -- GNAT ! Name_Preelaborable_Initialization : constant Name_Id := N + 240; -- Ada 05 ! Name_Preelaborate : constant Name_Id := N + 241; ! Name_Preelaborate_05 : constant Name_Id := N + 242; -- GNAT -- Note: Priority is not in this list because its name matches -- the name of the corresponding attribute. However, it is --- 406,488 ---- -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize -- and process Name_AST_Entry. ! Name_Assert : constant Name_Id := N + 177; -- Ada 05 ! Name_Asynchronous : constant Name_Id := N + 178; ! Name_Atomic : constant Name_Id := N + 179; ! Name_Atomic_Components : constant Name_Id := N + 180; ! Name_Attach_Handler : constant Name_Id := N + 181; ! Name_Check : constant Name_Id := N + 182; -- GNAT ! Name_CIL_Constructor : constant Name_Id := N + 183; -- GNAT ! Name_Comment : constant Name_Id := N + 184; -- GNAT ! Name_Common_Object : constant Name_Id := N + 185; -- GNAT ! Name_Complete_Representation : constant Name_Id := N + 186; -- GNAT ! Name_Complex_Representation : constant Name_Id := N + 187; -- GNAT ! Name_Controlled : constant Name_Id := N + 188; ! Name_Convention : constant Name_Id := N + 189; ! Name_CPP_Class : constant Name_Id := N + 190; -- GNAT ! Name_CPP_Constructor : constant Name_Id := N + 191; -- GNAT ! Name_CPP_Virtual : constant Name_Id := N + 192; -- GNAT ! Name_CPP_Vtable : constant Name_Id := N + 193; -- GNAT ! Name_Debug : constant Name_Id := N + 194; -- GNAT ! Name_Elaborate : constant Name_Id := N + 195; -- Ada 83 ! Name_Elaborate_All : constant Name_Id := N + 196; ! Name_Elaborate_Body : constant Name_Id := N + 197; ! Name_Export : constant Name_Id := N + 198; ! Name_Export_Exception : constant Name_Id := N + 199; -- VMS ! Name_Export_Function : constant Name_Id := N + 200; -- GNAT ! Name_Export_Object : constant Name_Id := N + 201; -- GNAT ! Name_Export_Procedure : constant Name_Id := N + 202; -- GNAT ! Name_Export_Value : constant Name_Id := N + 203; -- GNAT ! Name_Export_Valued_Procedure : constant Name_Id := N + 204; -- GNAT ! Name_External : constant Name_Id := N + 205; -- GNAT ! Name_Finalize_Storage_Only : constant Name_Id := N + 206; -- GNAT ! Name_Ident : constant Name_Id := N + 207; -- VMS ! Name_Implemented_By_Entry : constant Name_Id := N + 208; -- Ada 05 ! Name_Import : constant Name_Id := N + 209; ! Name_Import_Exception : constant Name_Id := N + 210; -- VMS ! Name_Import_Function : constant Name_Id := N + 211; -- GNAT ! Name_Import_Object : constant Name_Id := N + 212; -- GNAT ! Name_Import_Procedure : constant Name_Id := N + 213; -- GNAT ! Name_Import_Valued_Procedure : constant Name_Id := N + 214; -- GNAT ! Name_Inline : constant Name_Id := N + 215; ! Name_Inline_Always : constant Name_Id := N + 216; -- GNAT ! Name_Inline_Generic : constant Name_Id := N + 217; -- GNAT ! Name_Inspection_Point : constant Name_Id := N + 218; ! ! -- Note: Interface is not in this list because its name matches -- GNAT ! -- an Ada 2005 keyword. However it is included in the definition ! -- of the type Attribute_Id, and the functions Get_Pragma_Id and ! -- Is_Pragma_Id correctly recognize and process Name_Storage_Size. ! ! Name_Interface_Name : constant Name_Id := N + 219; -- GNAT ! Name_Interrupt_Handler : constant Name_Id := N + 220; ! Name_Interrupt_Priority : constant Name_Id := N + 221; ! Name_Java_Constructor : constant Name_Id := N + 222; -- GNAT ! Name_Java_Interface : constant Name_Id := N + 223; -- GNAT ! Name_Keep_Names : constant Name_Id := N + 224; -- GNAT ! Name_Link_With : constant Name_Id := N + 225; -- GNAT ! Name_Linker_Alias : constant Name_Id := N + 226; -- GNAT ! Name_Linker_Constructor : constant Name_Id := N + 227; -- GNAT ! Name_Linker_Destructor : constant Name_Id := N + 228; -- GNAT ! Name_Linker_Options : constant Name_Id := N + 229; ! Name_Linker_Section : constant Name_Id := N + 230; -- GNAT ! Name_List : constant Name_Id := N + 231; ! Name_Machine_Attribute : constant Name_Id := N + 232; -- GNAT ! Name_Main : constant Name_Id := N + 233; -- GNAT ! Name_Main_Storage : constant Name_Id := N + 234; -- GNAT ! Name_Memory_Size : constant Name_Id := N + 235; -- Ada 83 ! Name_No_Body : constant Name_Id := N + 236; -- GNAT ! Name_No_Return : constant Name_Id := N + 237; -- GNAT ! Name_Obsolescent : constant Name_Id := N + 238; -- GNAT ! Name_Optimize : constant Name_Id := N + 239; ! Name_Pack : constant Name_Id := N + 240; ! Name_Page : constant Name_Id := N + 241; ! Name_Passive : constant Name_Id := N + 242; -- GNAT ! Name_Postcondition : constant Name_Id := N + 243; -- GNAT ! Name_Precondition : constant Name_Id := N + 244; -- GNAT ! Name_Preelaborable_Initialization : constant Name_Id := N + 245; -- Ada 05 ! Name_Preelaborate : constant Name_Id := N + 246; ! Name_Preelaborate_05 : constant Name_Id := N + 247; -- GNAT -- Note: Priority is not in this list because its name matches -- the name of the corresponding attribute. However, it is *************** package Snames is *** 484,498 **** -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize -- and process Priority. Priority is a standard Ada 95 pragma. ! Name_Psect_Object : constant Name_Id := N + 243; -- VMS ! Name_Pure : constant Name_Id := N + 244; ! Name_Pure_05 : constant Name_Id := N + 245; -- GNAT ! Name_Pure_Function : constant Name_Id := N + 246; -- GNAT ! Name_Remote_Call_Interface : constant Name_Id := N + 247; ! Name_Remote_Types : constant Name_Id := N + 248; ! Name_Share_Generic : constant Name_Id := N + 249; -- GNAT ! Name_Shared : constant Name_Id := N + 250; -- Ada 83 ! Name_Shared_Passive : constant Name_Id := N + 251; -- Note: Storage_Size is not in this list because its name -- matches the name of the corresponding attribute. However, --- 490,505 ---- -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize -- and process Priority. Priority is a standard Ada 95 pragma. ! Name_Psect_Object : constant Name_Id := N + 248; -- VMS ! Name_Pure : constant Name_Id := N + 249; ! Name_Pure_05 : constant Name_Id := N + 250; -- GNAT ! Name_Pure_Function : constant Name_Id := N + 251; -- GNAT ! Name_Relative_Deadline : constant Name_Id := N + 252; -- Ada 05 ! Name_Remote_Call_Interface : constant Name_Id := N + 253; ! Name_Remote_Types : constant Name_Id := N + 254; ! Name_Share_Generic : constant Name_Id := N + 255; -- GNAT ! Name_Shared : constant Name_Id := N + 256; -- Ada 83 ! Name_Shared_Passive : constant Name_Id := N + 257; -- Note: Storage_Size is not in this list because its name -- matches the name of the corresponding attribute. However, *************** package Snames is *** 503,532 **** -- Note: Storage_Unit is also omitted from the list because -- of a clash with an attribute name, and is treated similarly. ! Name_Source_Reference : constant Name_Id := N + 252; -- GNAT ! Name_Static_Elaboration_Desired : constant Name_Id := N + 253; -- GNAT ! Name_Stream_Convert : constant Name_Id := N + 254; -- GNAT ! Name_Subtitle : constant Name_Id := N + 255; -- GNAT ! Name_Suppress_All : constant Name_Id := N + 256; -- GNAT ! Name_Suppress_Debug_Info : constant Name_Id := N + 257; -- GNAT ! Name_Suppress_Initialization : constant Name_Id := N + 258; -- GNAT ! Name_System_Name : constant Name_Id := N + 259; -- Ada 83 ! Name_Task_Info : constant Name_Id := N + 260; -- GNAT ! Name_Task_Name : constant Name_Id := N + 261; -- GNAT ! Name_Task_Storage : constant Name_Id := N + 262; -- VMS ! Name_Time_Slice : constant Name_Id := N + 263; -- GNAT ! Name_Title : constant Name_Id := N + 264; -- GNAT ! Name_Unchecked_Union : constant Name_Id := N + 265; -- GNAT ! Name_Unimplemented_Unit : constant Name_Id := N + 266; -- GNAT ! Name_Universal_Aliasing : constant Name_Id := N + 267; -- GNAT ! Name_Unmodified : constant Name_Id := N + 268; -- GNAT ! Name_Unreferenced : constant Name_Id := N + 269; -- GNAT ! Name_Unreferenced_Objects : constant Name_Id := N + 270; -- GNAT ! Name_Unreserve_All_Interrupts : constant Name_Id := N + 271; -- GNAT ! Name_Volatile : constant Name_Id := N + 272; ! Name_Volatile_Components : constant Name_Id := N + 273; ! Name_Weak_External : constant Name_Id := N + 274; -- GNAT ! Last_Pragma_Name : constant Name_Id := N + 274; -- Language convention names for pragma Convention/Export/Import/Interface -- Note that Name_C is not included in this list, since it was already --- 510,539 ---- -- Note: Storage_Unit is also omitted from the list because -- of a clash with an attribute name, and is treated similarly. ! Name_Source_Reference : constant Name_Id := N + 258; -- GNAT ! Name_Static_Elaboration_Desired : constant Name_Id := N + 259; -- GNAT ! Name_Stream_Convert : constant Name_Id := N + 260; -- GNAT ! Name_Subtitle : constant Name_Id := N + 261; -- GNAT ! Name_Suppress_All : constant Name_Id := N + 262; -- GNAT ! Name_Suppress_Debug_Info : constant Name_Id := N + 263; -- GNAT ! Name_Suppress_Initialization : constant Name_Id := N + 264; -- GNAT ! Name_System_Name : constant Name_Id := N + 265; -- Ada 83 ! Name_Task_Info : constant Name_Id := N + 266; -- GNAT ! Name_Task_Name : constant Name_Id := N + 267; -- GNAT ! Name_Task_Storage : constant Name_Id := N + 268; -- VMS ! Name_Time_Slice : constant Name_Id := N + 269; -- GNAT ! Name_Title : constant Name_Id := N + 270; -- GNAT ! Name_Unchecked_Union : constant Name_Id := N + 271; -- Ada 05 ! Name_Unimplemented_Unit : constant Name_Id := N + 272; -- GNAT ! Name_Universal_Aliasing : constant Name_Id := N + 273; -- GNAT ! Name_Unmodified : constant Name_Id := N + 274; -- GNAT ! Name_Unreferenced : constant Name_Id := N + 275; -- GNAT ! Name_Unreferenced_Objects : constant Name_Id := N + 276; -- GNAT ! Name_Unreserve_All_Interrupts : constant Name_Id := N + 277; -- GNAT ! Name_Volatile : constant Name_Id := N + 278; ! Name_Volatile_Components : constant Name_Id := N + 279; ! Name_Weak_External : constant Name_Id := N + 280; -- GNAT ! Last_Pragma_Name : constant Name_Id := N + 280; -- Language convention names for pragma Convention/Export/Import/Interface -- Note that Name_C is not included in this list, since it was already *************** package Snames is *** 537,655 **** -- Entry and Protected, this is because these conventions cannot be -- specified by a pragma. ! First_Convention_Name : constant Name_Id := N + 275; ! Name_Ada : constant Name_Id := N + 275; ! Name_Assembler : constant Name_Id := N + 276; ! Name_CIL : constant Name_Id := N + 277; ! Name_COBOL : constant Name_Id := N + 278; ! Name_CPP : constant Name_Id := N + 279; ! Name_Fortran : constant Name_Id := N + 280; ! Name_Intrinsic : constant Name_Id := N + 281; ! Name_Java : constant Name_Id := N + 282; ! Name_Stdcall : constant Name_Id := N + 283; ! Name_Stubbed : constant Name_Id := N + 284; ! Last_Convention_Name : constant Name_Id := N + 284; -- The following names are preset as synonyms for Assembler ! Name_Asm : constant Name_Id := N + 285; ! Name_Assembly : constant Name_Id := N + 286; -- The following names are preset as synonyms for C ! Name_Default : constant Name_Id := N + 287; ! -- Name_Exernal (previously defined as pragma) -- The following names are preset as synonyms for CPP ! Name_C_Plus_Plus : constant Name_Id := N + 288; -- The following names are present as synonyms for Stdcall ! Name_DLL : constant Name_Id := N + 289; ! Name_Win32 : constant Name_Id := N + 290; -- Other special names used in processing pragmas ! Name_As_Is : constant Name_Id := N + 291; ! Name_Attribute_Name : constant Name_Id := N + 292; ! Name_Body_File_Name : constant Name_Id := N + 293; ! Name_Boolean_Entry_Barriers : constant Name_Id := N + 294; ! Name_Check : constant Name_Id := N + 295; ! Name_Casing : constant Name_Id := N + 296; ! Name_Code : constant Name_Id := N + 297; ! Name_Component : constant Name_Id := N + 298; ! Name_Component_Size_4 : constant Name_Id := N + 299; ! Name_Copy : constant Name_Id := N + 300; ! Name_D_Float : constant Name_Id := N + 301; ! Name_Descriptor : constant Name_Id := N + 302; ! Name_Dot_Replacement : constant Name_Id := N + 303; ! Name_Dynamic : constant Name_Id := N + 304; ! Name_Entity : constant Name_Id := N + 305; ! Name_Entry_Count : constant Name_Id := N + 306; ! Name_External_Name : constant Name_Id := N + 307; ! Name_First_Optional_Parameter : constant Name_Id := N + 308; ! Name_Form : constant Name_Id := N + 309; ! Name_G_Float : constant Name_Id := N + 310; ! Name_Gcc : constant Name_Id := N + 311; ! Name_Gnat : constant Name_Id := N + 312; ! Name_GPL : constant Name_Id := N + 313; ! Name_IEEE_Float : constant Name_Id := N + 314; ! Name_Ignore : constant Name_Id := N + 315; ! Name_Info : constant Name_Id := N + 316; ! Name_Internal : constant Name_Id := N + 317; ! Name_Link_Name : constant Name_Id := N + 318; ! Name_Lowercase : constant Name_Id := N + 319; ! Name_Max_Entry_Queue_Depth : constant Name_Id := N + 320; ! Name_Max_Entry_Queue_Length : constant Name_Id := N + 321; ! Name_Max_Size : constant Name_Id := N + 322; ! Name_Mechanism : constant Name_Id := N + 323; ! Name_Message : constant Name_Id := N + 324; ! Name_Mixedcase : constant Name_Id := N + 325; ! Name_Modified_GPL : constant Name_Id := N + 326; ! Name_Name : constant Name_Id := N + 327; ! Name_NCA : constant Name_Id := N + 328; ! Name_No : constant Name_Id := N + 329; ! Name_No_Dependence : constant Name_Id := N + 330; ! Name_No_Dynamic_Attachment : constant Name_Id := N + 331; ! Name_No_Dynamic_Interrupts : constant Name_Id := N + 332; ! Name_No_Requeue : constant Name_Id := N + 333; ! Name_No_Requeue_Statements : constant Name_Id := N + 334; ! Name_No_Task_Attributes : constant Name_Id := N + 335; ! Name_No_Task_Attributes_Package : constant Name_Id := N + 336; ! Name_On : constant Name_Id := N + 337; ! Name_Parameter_Types : constant Name_Id := N + 338; ! Name_Reference : constant Name_Id := N + 339; ! Name_Restricted : constant Name_Id := N + 340; ! Name_Result_Mechanism : constant Name_Id := N + 341; ! Name_Result_Type : constant Name_Id := N + 342; ! Name_Runtime : constant Name_Id := N + 343; ! Name_SB : constant Name_Id := N + 344; ! Name_Secondary_Stack_Size : constant Name_Id := N + 345; ! Name_Section : constant Name_Id := N + 346; ! Name_Semaphore : constant Name_Id := N + 347; ! Name_Simple_Barriers : constant Name_Id := N + 348; ! Name_Spec_File_Name : constant Name_Id := N + 349; ! Name_State : constant Name_Id := N + 350; ! Name_Static : constant Name_Id := N + 351; ! Name_Stack_Size : constant Name_Id := N + 352; ! Name_Subunit_File_Name : constant Name_Id := N + 353; ! Name_Task_Stack_Size_Default : constant Name_Id := N + 354; ! Name_Task_Type : constant Name_Id := N + 355; ! Name_Time_Slicing_Enabled : constant Name_Id := N + 356; ! Name_Top_Guard : constant Name_Id := N + 357; ! Name_UBA : constant Name_Id := N + 358; ! Name_UBS : constant Name_Id := N + 359; ! Name_UBSB : constant Name_Id := N + 360; ! Name_Unit_Name : constant Name_Id := N + 361; ! Name_Unknown : constant Name_Id := N + 362; ! Name_Unrestricted : constant Name_Id := N + 363; ! Name_Uppercase : constant Name_Id := N + 364; ! Name_User : constant Name_Id := N + 365; ! Name_VAX_Float : constant Name_Id := N + 366; ! Name_VMS : constant Name_Id := N + 367; ! Name_Vtable_Ptr : constant Name_Id := N + 368; ! Name_Working_Storage : constant Name_Id := N + 369; -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 95. These --- 544,663 ---- -- Entry and Protected, this is because these conventions cannot be -- specified by a pragma. ! First_Convention_Name : constant Name_Id := N + 281; ! Name_Ada : constant Name_Id := N + 281; ! Name_Assembler : constant Name_Id := N + 282; ! Name_CIL : constant Name_Id := N + 283; ! Name_COBOL : constant Name_Id := N + 284; ! Name_CPP : constant Name_Id := N + 285; ! Name_Fortran : constant Name_Id := N + 286; ! Name_Intrinsic : constant Name_Id := N + 287; ! Name_Java : constant Name_Id := N + 288; ! Name_Stdcall : constant Name_Id := N + 289; ! Name_Stubbed : constant Name_Id := N + 290; ! Last_Convention_Name : constant Name_Id := N + 290; -- The following names are preset as synonyms for Assembler ! Name_Asm : constant Name_Id := N + 291; ! Name_Assembly : constant Name_Id := N + 292; -- The following names are preset as synonyms for C ! Name_Default : constant Name_Id := N + 293; ! -- Name_External (previously defined as pragma) -- The following names are preset as synonyms for CPP ! Name_C_Plus_Plus : constant Name_Id := N + 294; -- The following names are present as synonyms for Stdcall ! Name_DLL : constant Name_Id := N + 295; ! Name_Win32 : constant Name_Id := N + 296; -- Other special names used in processing pragmas ! Name_As_Is : constant Name_Id := N + 297; ! Name_Assertion : constant Name_Id := N + 298; ! Name_Attribute_Name : constant Name_Id := N + 299; ! Name_Body_File_Name : constant Name_Id := N + 300; ! Name_Boolean_Entry_Barriers : constant Name_Id := N + 301; ! Name_Casing : constant Name_Id := N + 302; ! Name_Code : constant Name_Id := N + 303; ! Name_Component : constant Name_Id := N + 304; ! Name_Component_Size_4 : constant Name_Id := N + 305; ! Name_Copy : constant Name_Id := N + 306; ! Name_D_Float : constant Name_Id := N + 307; ! Name_Descriptor : constant Name_Id := N + 308; ! Name_Dot_Replacement : constant Name_Id := N + 309; ! Name_Dynamic : constant Name_Id := N + 310; ! Name_Entity : constant Name_Id := N + 311; ! Name_Entry_Count : constant Name_Id := N + 312; ! Name_External_Name : constant Name_Id := N + 313; ! Name_First_Optional_Parameter : constant Name_Id := N + 314; ! Name_Form : constant Name_Id := N + 315; ! Name_G_Float : constant Name_Id := N + 316; ! Name_Gcc : constant Name_Id := N + 317; ! Name_Gnat : constant Name_Id := N + 318; ! Name_GPL : constant Name_Id := N + 319; ! Name_IEEE_Float : constant Name_Id := N + 320; ! Name_Ignore : constant Name_Id := N + 321; ! Name_Info : constant Name_Id := N + 322; ! Name_Internal : constant Name_Id := N + 323; ! Name_Link_Name : constant Name_Id := N + 324; ! Name_Lowercase : constant Name_Id := N + 325; ! Name_Max_Entry_Queue_Depth : constant Name_Id := N + 326; ! Name_Max_Entry_Queue_Length : constant Name_Id := N + 327; ! Name_Max_Size : constant Name_Id := N + 328; ! Name_Mechanism : constant Name_Id := N + 329; ! Name_Message : constant Name_Id := N + 330; ! Name_Mixedcase : constant Name_Id := N + 331; ! Name_Modified_GPL : constant Name_Id := N + 332; ! Name_Name : constant Name_Id := N + 333; ! Name_NCA : constant Name_Id := N + 334; ! Name_No : constant Name_Id := N + 335; ! Name_No_Dependence : constant Name_Id := N + 336; ! Name_No_Dynamic_Attachment : constant Name_Id := N + 337; ! Name_No_Dynamic_Interrupts : constant Name_Id := N + 338; ! Name_No_Requeue : constant Name_Id := N + 339; ! Name_No_Requeue_Statements : constant Name_Id := N + 340; ! Name_No_Task_Attributes : constant Name_Id := N + 341; ! Name_No_Task_Attributes_Package : constant Name_Id := N + 342; ! Name_On : constant Name_Id := N + 343; ! Name_Parameter_Types : constant Name_Id := N + 344; ! Name_Reference : constant Name_Id := N + 345; ! Name_Restricted : constant Name_Id := N + 346; ! Name_Result_Mechanism : constant Name_Id := N + 347; ! Name_Result_Type : constant Name_Id := N + 348; ! Name_Runtime : constant Name_Id := N + 349; ! Name_SB : constant Name_Id := N + 350; ! Name_Secondary_Stack_Size : constant Name_Id := N + 351; ! Name_Section : constant Name_Id := N + 352; ! Name_Semaphore : constant Name_Id := N + 353; ! Name_Short_Descriptor : constant Name_Id := N + 354; ! Name_Simple_Barriers : constant Name_Id := N + 355; ! Name_Spec_File_Name : constant Name_Id := N + 356; ! Name_State : constant Name_Id := N + 357; ! Name_Static : constant Name_Id := N + 358; ! Name_Stack_Size : constant Name_Id := N + 359; ! Name_Subunit_File_Name : constant Name_Id := N + 360; ! Name_Task_Stack_Size_Default : constant Name_Id := N + 361; ! Name_Task_Type : constant Name_Id := N + 362; ! Name_Time_Slicing_Enabled : constant Name_Id := N + 363; ! Name_Top_Guard : constant Name_Id := N + 364; ! Name_UBA : constant Name_Id := N + 365; ! Name_UBS : constant Name_Id := N + 366; ! Name_UBSB : constant Name_Id := N + 367; ! Name_Unit_Name : constant Name_Id := N + 368; ! Name_Unknown : constant Name_Id := N + 369; ! Name_Unrestricted : constant Name_Id := N + 370; ! Name_Uppercase : constant Name_Id := N + 371; ! Name_User : constant Name_Id := N + 372; ! Name_VAX_Float : constant Name_Id := N + 373; ! Name_VMS : constant Name_Id := N + 374; ! Name_Vtable_Ptr : constant Name_Id := N + 375; ! Name_Working_Storage : constant Name_Id := N + 376; -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 95. These *************** package Snames is *** 663,832 **** -- The entries marked VMS are recognized only in OpenVMS implementations -- of GNAT, and are treated as illegal in all other contexts. ! First_Attribute_Name : constant Name_Id := N + 370; ! Name_Abort_Signal : constant Name_Id := N + 370; -- GNAT ! Name_Access : constant Name_Id := N + 371; ! Name_Address : constant Name_Id := N + 372; ! Name_Address_Size : constant Name_Id := N + 373; -- GNAT ! Name_Aft : constant Name_Id := N + 374; ! Name_Alignment : constant Name_Id := N + 375; ! Name_Asm_Input : constant Name_Id := N + 376; -- GNAT ! Name_Asm_Output : constant Name_Id := N + 377; -- GNAT ! Name_AST_Entry : constant Name_Id := N + 378; -- VMS ! Name_Bit : constant Name_Id := N + 379; -- GNAT ! Name_Bit_Order : constant Name_Id := N + 380; ! Name_Bit_Position : constant Name_Id := N + 381; -- GNAT ! Name_Body_Version : constant Name_Id := N + 382; ! Name_Callable : constant Name_Id := N + 383; ! Name_Caller : constant Name_Id := N + 384; ! Name_Code_Address : constant Name_Id := N + 385; -- GNAT ! Name_Component_Size : constant Name_Id := N + 386; ! Name_Compose : constant Name_Id := N + 387; ! Name_Constrained : constant Name_Id := N + 388; ! Name_Count : constant Name_Id := N + 389; ! Name_Default_Bit_Order : constant Name_Id := N + 390; -- GNAT ! Name_Definite : constant Name_Id := N + 391; ! Name_Delta : constant Name_Id := N + 392; ! Name_Denorm : constant Name_Id := N + 393; ! Name_Digits : constant Name_Id := N + 394; ! Name_Elaborated : constant Name_Id := N + 395; -- GNAT ! Name_Emax : constant Name_Id := N + 396; -- Ada 83 ! Name_Enabled : constant Name_Id := N + 397; -- GNAT ! Name_Enum_Rep : constant Name_Id := N + 398; -- GNAT ! Name_Epsilon : constant Name_Id := N + 399; -- Ada 83 ! Name_Exponent : constant Name_Id := N + 400; ! Name_External_Tag : constant Name_Id := N + 401; ! Name_Fast_Math : constant Name_Id := N + 402; -- GNAT ! Name_First : constant Name_Id := N + 403; ! Name_First_Bit : constant Name_Id := N + 404; ! Name_Fixed_Value : constant Name_Id := N + 405; -- GNAT ! Name_Fore : constant Name_Id := N + 406; ! Name_Has_Access_Values : constant Name_Id := N + 407; -- GNAT ! Name_Has_Discriminants : constant Name_Id := N + 408; -- GNAT ! Name_Identity : constant Name_Id := N + 409; ! Name_Img : constant Name_Id := N + 410; -- GNAT ! Name_Integer_Value : constant Name_Id := N + 411; -- GNAT ! Name_Large : constant Name_Id := N + 412; -- Ada 83 ! Name_Last : constant Name_Id := N + 413; ! Name_Last_Bit : constant Name_Id := N + 414; ! Name_Leading_Part : constant Name_Id := N + 415; ! Name_Length : constant Name_Id := N + 416; ! Name_Machine_Emax : constant Name_Id := N + 417; ! Name_Machine_Emin : constant Name_Id := N + 418; ! Name_Machine_Mantissa : constant Name_Id := N + 419; ! Name_Machine_Overflows : constant Name_Id := N + 420; ! Name_Machine_Radix : constant Name_Id := N + 421; ! Name_Machine_Rounding : constant Name_Id := N + 422; -- Ada 05 ! Name_Machine_Rounds : constant Name_Id := N + 423; ! Name_Machine_Size : constant Name_Id := N + 424; -- GNAT ! Name_Mantissa : constant Name_Id := N + 425; -- Ada 83 ! Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 426; ! Name_Maximum_Alignment : constant Name_Id := N + 427; -- GNAT ! Name_Mechanism_Code : constant Name_Id := N + 428; -- GNAT ! Name_Mod : constant Name_Id := N + 429; -- Ada 05 ! Name_Model_Emin : constant Name_Id := N + 430; ! Name_Model_Epsilon : constant Name_Id := N + 431; ! Name_Model_Mantissa : constant Name_Id := N + 432; ! Name_Model_Small : constant Name_Id := N + 433; ! Name_Modulus : constant Name_Id := N + 434; ! Name_Null_Parameter : constant Name_Id := N + 435; -- GNAT ! Name_Object_Size : constant Name_Id := N + 436; -- GNAT ! Name_Partition_ID : constant Name_Id := N + 437; ! Name_Passed_By_Reference : constant Name_Id := N + 438; -- GNAT ! Name_Pool_Address : constant Name_Id := N + 439; ! Name_Pos : constant Name_Id := N + 440; ! Name_Position : constant Name_Id := N + 441; ! Name_Priority : constant Name_Id := N + 442; -- Ada 05 ! Name_Range : constant Name_Id := N + 443; ! Name_Range_Length : constant Name_Id := N + 444; -- GNAT ! Name_Round : constant Name_Id := N + 445; ! Name_Safe_Emax : constant Name_Id := N + 446; -- Ada 83 ! Name_Safe_First : constant Name_Id := N + 447; ! Name_Safe_Large : constant Name_Id := N + 448; -- Ada 83 ! Name_Safe_Last : constant Name_Id := N + 449; ! Name_Safe_Small : constant Name_Id := N + 450; -- Ada 83 ! Name_Scale : constant Name_Id := N + 451; ! Name_Scaling : constant Name_Id := N + 452; ! Name_Signed_Zeros : constant Name_Id := N + 453; ! Name_Size : constant Name_Id := N + 454; ! Name_Small : constant Name_Id := N + 455; ! Name_Storage_Size : constant Name_Id := N + 456; ! Name_Storage_Unit : constant Name_Id := N + 457; -- GNAT ! Name_Stream_Size : constant Name_Id := N + 458; -- Ada 05 ! Name_Tag : constant Name_Id := N + 459; ! Name_Target_Name : constant Name_Id := N + 460; -- GNAT ! Name_Terminated : constant Name_Id := N + 461; ! Name_To_Address : constant Name_Id := N + 462; -- GNAT ! Name_Type_Class : constant Name_Id := N + 463; -- GNAT ! Name_UET_Address : constant Name_Id := N + 464; -- GNAT ! Name_Unbiased_Rounding : constant Name_Id := N + 465; ! Name_Unchecked_Access : constant Name_Id := N + 466; ! Name_Unconstrained_Array : constant Name_Id := N + 467; ! Name_Universal_Literal_String : constant Name_Id := N + 468; -- GNAT ! Name_Unrestricted_Access : constant Name_Id := N + 469; -- GNAT ! Name_VADS_Size : constant Name_Id := N + 470; -- GNAT ! Name_Val : constant Name_Id := N + 471; ! Name_Valid : constant Name_Id := N + 472; ! Name_Value_Size : constant Name_Id := N + 473; -- GNAT ! Name_Version : constant Name_Id := N + 474; ! Name_Wchar_T_Size : constant Name_Id := N + 475; -- GNAT ! Name_Wide_Wide_Width : constant Name_Id := N + 476; -- Ada 05 ! Name_Wide_Width : constant Name_Id := N + 477; ! Name_Width : constant Name_Id := N + 478; ! Name_Word_Size : constant Name_Id := N + 479; -- GNAT -- Attributes that designate attributes returning renamable functions, -- i.e. functions that return other than a universal value and that -- have non-universal arguments. ! First_Renamable_Function_Attribute : constant Name_Id := N + 480; ! Name_Adjacent : constant Name_Id := N + 480; ! Name_Ceiling : constant Name_Id := N + 481; ! Name_Copy_Sign : constant Name_Id := N + 482; ! Name_Floor : constant Name_Id := N + 483; ! Name_Fraction : constant Name_Id := N + 484; ! Name_Image : constant Name_Id := N + 485; ! Name_Input : constant Name_Id := N + 486; ! Name_Machine : constant Name_Id := N + 487; ! Name_Max : constant Name_Id := N + 488; ! Name_Min : constant Name_Id := N + 489; ! Name_Model : constant Name_Id := N + 490; ! Name_Pred : constant Name_Id := N + 491; ! Name_Remainder : constant Name_Id := N + 492; ! Name_Rounding : constant Name_Id := N + 493; ! Name_Succ : constant Name_Id := N + 494; ! Name_Truncation : constant Name_Id := N + 495; ! Name_Value : constant Name_Id := N + 496; ! Name_Wide_Image : constant Name_Id := N + 497; ! Name_Wide_Wide_Image : constant Name_Id := N + 498; ! Name_Wide_Value : constant Name_Id := N + 499; ! Name_Wide_Wide_Value : constant Name_Id := N + 500; ! Last_Renamable_Function_Attribute : constant Name_Id := N + 500; -- Attributes that designate procedures ! First_Procedure_Attribute : constant Name_Id := N + 501; ! Name_Output : constant Name_Id := N + 501; ! Name_Read : constant Name_Id := N + 502; ! Name_Write : constant Name_Id := N + 503; ! Last_Procedure_Attribute : constant Name_Id := N + 503; -- Remaining attributes are ones that return entities ! First_Entity_Attribute_Name : constant Name_Id := N + 504; ! Name_Elab_Body : constant Name_Id := N + 504; -- GNAT ! Name_Elab_Spec : constant Name_Id := N + 505; -- GNAT ! Name_Storage_Pool : constant Name_Id := N + 506; -- These attributes are the ones that return types ! First_Type_Attribute_Name : constant Name_Id := N + 507; ! Name_Base : constant Name_Id := N + 507; ! Name_Class : constant Name_Id := N + 508; ! Name_Stub_Type : constant Name_Id := N + 509; ! Last_Type_Attribute_Name : constant Name_Id := N + 509; ! Last_Entity_Attribute_Name : constant Name_Id := N + 509; ! Last_Attribute_Name : constant Name_Id := N + 509; -- Names of recognized locking policy identifiers --- 671,848 ---- -- The entries marked VMS are recognized only in OpenVMS implementations -- of GNAT, and are treated as illegal in all other contexts. ! First_Attribute_Name : constant Name_Id := N + 377; ! Name_Abort_Signal : constant Name_Id := N + 377; -- GNAT ! Name_Access : constant Name_Id := N + 378; ! Name_Address : constant Name_Id := N + 379; ! Name_Address_Size : constant Name_Id := N + 380; -- GNAT ! Name_Aft : constant Name_Id := N + 381; ! Name_Alignment : constant Name_Id := N + 382; ! Name_Asm_Input : constant Name_Id := N + 383; -- GNAT ! Name_Asm_Output : constant Name_Id := N + 384; -- GNAT ! Name_AST_Entry : constant Name_Id := N + 385; -- VMS ! Name_Bit : constant Name_Id := N + 386; -- GNAT ! Name_Bit_Order : constant Name_Id := N + 387; ! Name_Bit_Position : constant Name_Id := N + 388; -- GNAT ! Name_Body_Version : constant Name_Id := N + 389; ! Name_Callable : constant Name_Id := N + 390; ! Name_Caller : constant Name_Id := N + 391; ! Name_Code_Address : constant Name_Id := N + 392; -- GNAT ! Name_Component_Size : constant Name_Id := N + 393; ! Name_Compose : constant Name_Id := N + 394; ! Name_Constrained : constant Name_Id := N + 395; ! Name_Count : constant Name_Id := N + 396; ! Name_Default_Bit_Order : constant Name_Id := N + 397; -- GNAT ! Name_Definite : constant Name_Id := N + 398; ! Name_Delta : constant Name_Id := N + 399; ! Name_Denorm : constant Name_Id := N + 400; ! Name_Digits : constant Name_Id := N + 401; ! Name_Elaborated : constant Name_Id := N + 402; -- GNAT ! Name_Emax : constant Name_Id := N + 403; -- Ada 83 ! Name_Enabled : constant Name_Id := N + 404; -- GNAT ! Name_Enum_Rep : constant Name_Id := N + 405; -- GNAT ! Name_Enum_Val : constant Name_Id := N + 406; -- GNAT ! Name_Epsilon : constant Name_Id := N + 407; -- Ada 83 ! Name_Exponent : constant Name_Id := N + 408; ! Name_External_Tag : constant Name_Id := N + 409; ! Name_Fast_Math : constant Name_Id := N + 410; -- GNAT ! Name_First : constant Name_Id := N + 411; ! Name_First_Bit : constant Name_Id := N + 412; ! Name_Fixed_Value : constant Name_Id := N + 413; -- GNAT ! Name_Fore : constant Name_Id := N + 414; ! Name_Has_Access_Values : constant Name_Id := N + 415; -- GNAT ! Name_Has_Discriminants : constant Name_Id := N + 416; -- GNAT ! Name_Has_Tagged_Values : constant Name_Id := N + 417; -- GNAT ! Name_Identity : constant Name_Id := N + 418; ! Name_Img : constant Name_Id := N + 419; -- GNAT ! Name_Integer_Value : constant Name_Id := N + 420; -- GNAT ! Name_Invalid_Value : constant Name_Id := N + 421; -- GNAT ! Name_Large : constant Name_Id := N + 422; -- Ada 83 ! Name_Last : constant Name_Id := N + 423; ! Name_Last_Bit : constant Name_Id := N + 424; ! Name_Leading_Part : constant Name_Id := N + 425; ! Name_Length : constant Name_Id := N + 426; ! Name_Machine_Emax : constant Name_Id := N + 427; ! Name_Machine_Emin : constant Name_Id := N + 428; ! Name_Machine_Mantissa : constant Name_Id := N + 429; ! Name_Machine_Overflows : constant Name_Id := N + 430; ! Name_Machine_Radix : constant Name_Id := N + 431; ! Name_Machine_Rounding : constant Name_Id := N + 432; -- Ada 05 ! Name_Machine_Rounds : constant Name_Id := N + 433; ! Name_Machine_Size : constant Name_Id := N + 434; -- GNAT ! Name_Mantissa : constant Name_Id := N + 435; -- Ada 83 ! Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 436; ! Name_Maximum_Alignment : constant Name_Id := N + 437; -- GNAT ! Name_Mechanism_Code : constant Name_Id := N + 438; -- GNAT ! Name_Mod : constant Name_Id := N + 439; -- Ada 05 ! Name_Model_Emin : constant Name_Id := N + 440; ! Name_Model_Epsilon : constant Name_Id := N + 441; ! Name_Model_Mantissa : constant Name_Id := N + 442; ! Name_Model_Small : constant Name_Id := N + 443; ! Name_Modulus : constant Name_Id := N + 444; ! Name_Null_Parameter : constant Name_Id := N + 445; -- GNAT ! Name_Object_Size : constant Name_Id := N + 446; -- GNAT ! Name_Old : constant Name_Id := N + 447; -- GNAT ! Name_Partition_ID : constant Name_Id := N + 448; ! Name_Passed_By_Reference : constant Name_Id := N + 449; -- GNAT ! Name_Pool_Address : constant Name_Id := N + 450; ! Name_Pos : constant Name_Id := N + 451; ! Name_Position : constant Name_Id := N + 452; ! Name_Priority : constant Name_Id := N + 453; -- Ada 05 ! Name_Range : constant Name_Id := N + 454; ! Name_Range_Length : constant Name_Id := N + 455; -- GNAT ! Name_Result : constant Name_Id := N + 456; -- GNAT ! Name_Round : constant Name_Id := N + 457; ! Name_Safe_Emax : constant Name_Id := N + 458; -- Ada 83 ! Name_Safe_First : constant Name_Id := N + 459; ! Name_Safe_Large : constant Name_Id := N + 460; -- Ada 83 ! Name_Safe_Last : constant Name_Id := N + 461; ! Name_Safe_Small : constant Name_Id := N + 462; -- Ada 83 ! Name_Scale : constant Name_Id := N + 463; ! Name_Scaling : constant Name_Id := N + 464; ! Name_Signed_Zeros : constant Name_Id := N + 465; ! Name_Size : constant Name_Id := N + 466; ! Name_Small : constant Name_Id := N + 467; ! Name_Storage_Size : constant Name_Id := N + 468; ! Name_Storage_Unit : constant Name_Id := N + 469; -- GNAT ! Name_Stream_Size : constant Name_Id := N + 470; -- Ada 05 ! Name_Tag : constant Name_Id := N + 471; ! Name_Target_Name : constant Name_Id := N + 472; -- GNAT ! Name_Terminated : constant Name_Id := N + 473; ! Name_To_Address : constant Name_Id := N + 474; -- GNAT ! Name_Type_Class : constant Name_Id := N + 475; -- GNAT ! Name_UET_Address : constant Name_Id := N + 476; -- GNAT ! Name_Unbiased_Rounding : constant Name_Id := N + 477; ! Name_Unchecked_Access : constant Name_Id := N + 478; ! Name_Unconstrained_Array : constant Name_Id := N + 479; ! Name_Universal_Literal_String : constant Name_Id := N + 480; -- GNAT ! Name_Unrestricted_Access : constant Name_Id := N + 481; -- GNAT ! Name_VADS_Size : constant Name_Id := N + 482; -- GNAT ! Name_Val : constant Name_Id := N + 483; ! Name_Valid : constant Name_Id := N + 484; ! Name_Value_Size : constant Name_Id := N + 485; -- GNAT ! Name_Version : constant Name_Id := N + 486; ! Name_Wchar_T_Size : constant Name_Id := N + 487; -- GNAT ! Name_Wide_Wide_Width : constant Name_Id := N + 488; -- Ada 05 ! Name_Wide_Width : constant Name_Id := N + 489; ! Name_Width : constant Name_Id := N + 490; ! Name_Word_Size : constant Name_Id := N + 491; -- GNAT -- Attributes that designate attributes returning renamable functions, -- i.e. functions that return other than a universal value and that -- have non-universal arguments. ! First_Renamable_Function_Attribute : constant Name_Id := N + 492; ! Name_Adjacent : constant Name_Id := N + 492; ! Name_Ceiling : constant Name_Id := N + 493; ! Name_Copy_Sign : constant Name_Id := N + 494; ! Name_Floor : constant Name_Id := N + 495; ! Name_Fraction : constant Name_Id := N + 496; ! Name_From_Any : constant Name_Id := N + 497; -- GNAT ! Name_Image : constant Name_Id := N + 498; ! Name_Input : constant Name_Id := N + 499; ! Name_Machine : constant Name_Id := N + 500; ! Name_Max : constant Name_Id := N + 501; ! Name_Min : constant Name_Id := N + 502; ! Name_Model : constant Name_Id := N + 503; ! Name_Pred : constant Name_Id := N + 504; ! Name_Remainder : constant Name_Id := N + 505; ! Name_Rounding : constant Name_Id := N + 506; ! Name_Succ : constant Name_Id := N + 507; ! Name_To_Any : constant Name_Id := N + 508; -- GNAT ! Name_Truncation : constant Name_Id := N + 509; ! Name_TypeCode : constant Name_Id := N + 510; -- GNAT ! Name_Value : constant Name_Id := N + 511; ! Name_Wide_Image : constant Name_Id := N + 512; ! Name_Wide_Wide_Image : constant Name_Id := N + 513; ! Name_Wide_Value : constant Name_Id := N + 514; ! Name_Wide_Wide_Value : constant Name_Id := N + 515; ! Last_Renamable_Function_Attribute : constant Name_Id := N + 515; -- Attributes that designate procedures ! First_Procedure_Attribute : constant Name_Id := N + 516; ! Name_Output : constant Name_Id := N + 516; ! Name_Read : constant Name_Id := N + 517; ! Name_Write : constant Name_Id := N + 518; ! Last_Procedure_Attribute : constant Name_Id := N + 518; -- Remaining attributes are ones that return entities ! First_Entity_Attribute_Name : constant Name_Id := N + 519; ! Name_Elab_Body : constant Name_Id := N + 519; -- GNAT ! Name_Elab_Spec : constant Name_Id := N + 520; -- GNAT ! Name_Storage_Pool : constant Name_Id := N + 521; -- These attributes are the ones that return types ! First_Type_Attribute_Name : constant Name_Id := N + 522; ! Name_Base : constant Name_Id := N + 522; ! Name_Class : constant Name_Id := N + 523; ! Name_Stub_Type : constant Name_Id := N + 524; ! Last_Type_Attribute_Name : constant Name_Id := N + 524; ! Last_Entity_Attribute_Name : constant Name_Id := N + 524; ! Last_Attribute_Name : constant Name_Id := N + 524; -- Names of recognized locking policy identifiers *************** package Snames is *** 834,843 **** -- name (e.g. C for Ceiling_Locking). If new policy names are added, -- the first character must be distinct. ! First_Locking_Policy_Name : constant Name_Id := N + 510; ! Name_Ceiling_Locking : constant Name_Id := N + 510; ! Name_Inheritance_Locking : constant Name_Id := N + 511; ! Last_Locking_Policy_Name : constant Name_Id := N + 511; -- Names of recognized queuing policy identifiers --- 850,859 ---- -- name (e.g. C for Ceiling_Locking). If new policy names are added, -- the first character must be distinct. ! First_Locking_Policy_Name : constant Name_Id := N + 525; ! Name_Ceiling_Locking : constant Name_Id := N + 525; ! Name_Inheritance_Locking : constant Name_Id := N + 526; ! Last_Locking_Policy_Name : constant Name_Id := N + 526; -- Names of recognized queuing policy identifiers *************** package Snames is *** 845,854 **** -- name (e.g. F for FIFO_Queuing). If new policy names are added, -- the first character must be distinct. ! First_Queuing_Policy_Name : constant Name_Id := N + 512; ! Name_FIFO_Queuing : constant Name_Id := N + 512; ! Name_Priority_Queuing : constant Name_Id := N + 513; ! Last_Queuing_Policy_Name : constant Name_Id := N + 513; -- Names of recognized task dispatching policy identifiers --- 861,870 ---- -- name (e.g. F for FIFO_Queuing). If new policy names are added, -- the first character must be distinct. ! First_Queuing_Policy_Name : constant Name_Id := N + 527; ! Name_FIFO_Queuing : constant Name_Id := N + 527; ! Name_Priority_Queuing : constant Name_Id := N + 528; ! Last_Queuing_Policy_Name : constant Name_Id := N + 528; -- Names of recognized task dispatching policy identifiers *************** package Snames is *** 856,1128 **** -- name (e.g. F for FIFO_Within_Priorities). If new policy names -- are added, the first character must be distinct. ! First_Task_Dispatching_Policy_Name : constant Name_Id := N + 514; ! Name_EDF_Across_Priorities : constant Name_Id := N + 514; ! Name_FIFO_Within_Priorities : constant Name_Id := N + 515; ! Name_Non_Preemptive_Within_Priorities ! : constant Name_Id := N + 513; ! Name_Round_Robin_Within_Priorities : constant Name_Id := N + 516; ! Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 516; -- Names of recognized checks for pragma Suppress ! First_Check_Name : constant Name_Id := N + 517; ! Name_Access_Check : constant Name_Id := N + 517; ! Name_Accessibility_Check : constant Name_Id := N + 518; ! Name_Alignment_Check : constant Name_Id := N + 519; -- GNAT ! Name_Discriminant_Check : constant Name_Id := N + 520; ! Name_Division_Check : constant Name_Id := N + 521; ! Name_Elaboration_Check : constant Name_Id := N + 522; ! Name_Index_Check : constant Name_Id := N + 523; ! Name_Length_Check : constant Name_Id := N + 524; ! Name_Overflow_Check : constant Name_Id := N + 525; ! Name_Range_Check : constant Name_Id := N + 526; ! Name_Storage_Check : constant Name_Id := N + 527; ! Name_Tag_Check : constant Name_Id := N + 528; ! Name_Validity_Check : constant Name_Id := N + 529; -- GNAT ! Name_All_Checks : constant Name_Id := N + 530; ! Last_Check_Name : constant Name_Id := N + 530; -- Names corresponding to reserved keywords, excluding those already -- declared in the attribute list (Access, Delta, Digits, Mod, Range). ! Name_Abort : constant Name_Id := N + 531; ! Name_Abs : constant Name_Id := N + 532; ! Name_Accept : constant Name_Id := N + 533; ! Name_And : constant Name_Id := N + 534; ! Name_All : constant Name_Id := N + 535; ! Name_Array : constant Name_Id := N + 536; ! Name_At : constant Name_Id := N + 537; ! Name_Begin : constant Name_Id := N + 538; ! Name_Body : constant Name_Id := N + 539; ! Name_Case : constant Name_Id := N + 540; ! Name_Constant : constant Name_Id := N + 541; ! Name_Declare : constant Name_Id := N + 542; ! Name_Delay : constant Name_Id := N + 543; ! Name_Do : constant Name_Id := N + 544; ! Name_Else : constant Name_Id := N + 545; ! Name_Elsif : constant Name_Id := N + 546; ! Name_End : constant Name_Id := N + 547; ! Name_Entry : constant Name_Id := N + 548; ! Name_Exception : constant Name_Id := N + 549; ! Name_Exit : constant Name_Id := N + 550; ! Name_For : constant Name_Id := N + 551; ! Name_Function : constant Name_Id := N + 552; ! Name_Generic : constant Name_Id := N + 553; ! Name_Goto : constant Name_Id := N + 554; ! Name_If : constant Name_Id := N + 555; ! Name_In : constant Name_Id := N + 556; ! Name_Is : constant Name_Id := N + 557; ! Name_Limited : constant Name_Id := N + 558; ! Name_Loop : constant Name_Id := N + 559; ! Name_New : constant Name_Id := N + 560; ! Name_Not : constant Name_Id := N + 561; ! Name_Null : constant Name_Id := N + 562; ! Name_Of : constant Name_Id := N + 563; ! Name_Or : constant Name_Id := N + 564; ! Name_Others : constant Name_Id := N + 565; ! Name_Out : constant Name_Id := N + 566; ! Name_Package : constant Name_Id := N + 567; ! Name_Pragma : constant Name_Id := N + 568; ! Name_Private : constant Name_Id := N + 569; ! Name_Procedure : constant Name_Id := N + 570; ! Name_Raise : constant Name_Id := N + 571; ! Name_Record : constant Name_Id := N + 572; ! Name_Rem : constant Name_Id := N + 573; ! Name_Renames : constant Name_Id := N + 574; ! Name_Return : constant Name_Id := N + 575; ! Name_Reverse : constant Name_Id := N + 576; ! Name_Select : constant Name_Id := N + 577; ! Name_Separate : constant Name_Id := N + 578; ! Name_Subtype : constant Name_Id := N + 579; ! Name_Task : constant Name_Id := N + 580; ! Name_Terminate : constant Name_Id := N + 581; ! Name_Then : constant Name_Id := N + 582; ! Name_Type : constant Name_Id := N + 583; ! Name_Use : constant Name_Id := N + 584; ! Name_When : constant Name_Id := N + 585; ! Name_While : constant Name_Id := N + 586; ! Name_With : constant Name_Id := N + 587; ! Name_Xor : constant Name_Id := N + 588; -- Names of intrinsic subprograms -- Note: Asm is missing from this list, since Asm is a legitimate ! -- convention name. So is To_Adress, which is a GNAT attribute. ! First_Intrinsic_Name : constant Name_Id := N + 589; ! Name_Divide : constant Name_Id := N + 589; ! Name_Enclosing_Entity : constant Name_Id := N + 590; ! Name_Exception_Information : constant Name_Id := N + 591; ! Name_Exception_Message : constant Name_Id := N + 592; ! Name_Exception_Name : constant Name_Id := N + 593; ! Name_File : constant Name_Id := N + 594; ! Name_Generic_Dispatching_Constructor : constant Name_Id := N + 595; ! Name_Import_Address : constant Name_Id := N + 596; ! Name_Import_Largest_Value : constant Name_Id := N + 597; ! Name_Import_Value : constant Name_Id := N + 598; ! Name_Is_Negative : constant Name_Id := N + 599; ! Name_Line : constant Name_Id := N + 600; ! Name_Rotate_Left : constant Name_Id := N + 601; ! Name_Rotate_Right : constant Name_Id := N + 602; ! Name_Shift_Left : constant Name_Id := N + 603; ! Name_Shift_Right : constant Name_Id := N + 604; ! Name_Shift_Right_Arithmetic : constant Name_Id := N + 605; ! Name_Source_Location : constant Name_Id := N + 606; ! Name_Unchecked_Conversion : constant Name_Id := N + 607; ! Name_Unchecked_Deallocation : constant Name_Id := N + 608; ! Name_To_Pointer : constant Name_Id := N + 609; ! Last_Intrinsic_Name : constant Name_Id := N + 609; -- Names used in processing intrinsic calls ! Name_Free : constant Name_Id := N + 610; -- Reserved words used only in Ada 95 ! First_95_Reserved_Word : constant Name_Id := N + 611; ! Name_Abstract : constant Name_Id := N + 611; ! Name_Aliased : constant Name_Id := N + 612; ! Name_Protected : constant Name_Id := N + 613; ! Name_Until : constant Name_Id := N + 614; ! Name_Requeue : constant Name_Id := N + 615; ! Name_Tagged : constant Name_Id := N + 616; ! Last_95_Reserved_Word : constant Name_Id := N + 616; subtype Ada_95_Reserved_Words is Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word; -- Miscellaneous names used in semantic checking ! Name_Raise_Exception : constant Name_Id := N + 617; -- Additional reserved words and identifiers used in GNAT Project Files -- Note that Name_External is already previously declared ! Name_Ada_Roots : constant Name_Id := N + 618; ! Name_Archive_Builder : constant Name_Id := N + 619; ! Name_Archive_Indexer : constant Name_Id := N + 620; ! Name_Archive_Suffix : constant Name_Id := N + 621; ! Name_Binder : constant Name_Id := N + 622; ! Name_Binder_Prefix : constant Name_Id := N + 623; ! Name_Body_Suffix : constant Name_Id := N + 624; ! Name_Builder : constant Name_Id := N + 625; ! Name_Builder_Switches : constant Name_Id := N + 626; ! Name_Compiler : constant Name_Id := N + 627; ! Name_Compiler_Kind : constant Name_Id := N + 628; ! Name_Config_Body_File_Name : constant Name_Id := N + 629; ! Name_Config_Body_File_Name_Pattern : constant Name_Id := N + 630; ! Name_Config_File_Switches : constant Name_Id := N + 631; ! Name_Config_File_Unique : constant Name_Id := N + 632; ! Name_Config_Spec_File_Name : constant Name_Id := N + 633; ! Name_Config_Spec_File_Name_Pattern : constant Name_Id := N + 634; ! Name_Cross_Reference : constant Name_Id := N + 635; ! Name_Default_Language : constant Name_Id := N + 636; ! Name_Default_Switches : constant Name_Id := N + 637; ! Name_Dependency_Driver : constant Name_Id := N + 638; ! Name_Dependency_File_Kind : constant Name_Id := N + 639; ! Name_Dependency_Switches : constant Name_Id := N + 640; ! Name_Driver : constant Name_Id := N + 641; ! Name_Excluded_Source_Dirs : constant Name_Id := N + 642; ! Name_Excluded_Source_Files : constant Name_Id := N + 643; ! Name_Exec_Dir : constant Name_Id := N + 644; ! Name_Executable : constant Name_Id := N + 645; ! Name_Executable_Suffix : constant Name_Id := N + 646; ! Name_Extends : constant Name_Id := N + 647; ! Name_Externally_Built : constant Name_Id := N + 648; ! Name_Finder : constant Name_Id := N + 649; ! Name_Global_Configuration_Pragmas : constant Name_Id := N + 650; ! Name_Global_Config_File : constant Name_Id := N + 651; ! Name_Gnatls : constant Name_Id := N + 652; ! Name_Gnatstub : constant Name_Id := N + 653; ! Name_Implementation : constant Name_Id := N + 654; ! Name_Implementation_Exceptions : constant Name_Id := N + 655; ! Name_Implementation_Suffix : constant Name_Id := N + 656; ! Name_Include_Switches : constant Name_Id := N + 657; ! Name_Include_Path : constant Name_Id := N + 658; ! Name_Include_Path_File : constant Name_Id := N + 659; ! Name_Language_Kind : constant Name_Id := N + 660; ! Name_Language_Processing : constant Name_Id := N + 661; ! Name_Languages : constant Name_Id := N + 662; ! Name_Library_Ali_Dir : constant Name_Id := N + 663; ! Name_Library_Auto_Init : constant Name_Id := N + 664; ! Name_Library_Auto_Init_Supported : constant Name_Id := N + 665; ! Name_Library_Builder : constant Name_Id := N + 666; ! Name_Library_Dir : constant Name_Id := N + 667; ! Name_Library_GCC : constant Name_Id := N + 668; ! Name_Library_Interface : constant Name_Id := N + 669; ! Name_Library_Kind : constant Name_Id := N + 670; ! Name_Library_Name : constant Name_Id := N + 671; ! Name_Library_Major_Minor_Id_Supported : constant Name_Id := N + 672; ! Name_Library_Options : constant Name_Id := N + 673; ! Name_Library_Partial_Linker : constant Name_Id := N + 674; ! Name_Library_Reference_Symbol_File : constant Name_Id := N + 675; ! Name_Library_Src_Dir : constant Name_Id := N + 676; ! Name_Library_Support : constant Name_Id := N + 677; ! Name_Library_Symbol_File : constant Name_Id := N + 678; ! Name_Library_Symbol_Policy : constant Name_Id := N + 679; ! Name_Library_Version : constant Name_Id := N + 680; ! Name_Library_Version_Switches : constant Name_Id := N + 681; ! Name_Linker : constant Name_Id := N + 682; ! Name_Linker_Executable_Option : constant Name_Id := N + 683; ! Name_Linker_Lib_Dir_Option : constant Name_Id := N + 684; ! Name_Linker_Lib_Name_Option : constant Name_Id := N + 685; ! Name_Local_Config_File : constant Name_Id := N + 686; ! Name_Local_Configuration_Pragmas : constant Name_Id := N + 687; ! Name_Locally_Removed_Files : constant Name_Id := N + 688; ! Name_Mapping_File_Switches : constant Name_Id := N + 689; ! Name_Mapping_Spec_Suffix : constant Name_Id := N + 690; ! Name_Mapping_Body_Suffix : constant Name_Id := N + 691; ! Name_Metrics : constant Name_Id := N + 692; ! Name_Naming : constant Name_Id := N + 693; ! Name_Objects_Path : constant Name_Id := N + 694; ! Name_Objects_Path_File : constant Name_Id := N + 695; ! Name_Object_Dir : constant Name_Id := N + 696; ! Name_Pic_Option : constant Name_Id := N + 697; ! Name_Pretty_Printer : constant Name_Id := N + 698; ! Name_Prefix : constant Name_Id := N + 699; ! Name_Project : constant Name_Id := N + 700; ! Name_Roots : constant Name_Id := N + 701; ! Name_Required_Switches : constant Name_Id := N + 702; ! Name_Run_Path_Option : constant Name_Id := N + 703; ! Name_Runtime_Project : constant Name_Id := N + 704; ! Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 705; ! Name_Shared_Library_Prefix : constant Name_Id := N + 706; ! Name_Shared_Library_Suffix : constant Name_Id := N + 707; ! Name_Separate_Suffix : constant Name_Id := N + 708; ! Name_Source_Dirs : constant Name_Id := N + 709; ! Name_Source_Files : constant Name_Id := N + 710; ! Name_Source_List_File : constant Name_Id := N + 711; ! Name_Spec : constant Name_Id := N + 712; ! Name_Spec_Suffix : constant Name_Id := N + 713; ! Name_Specification : constant Name_Id := N + 714; ! Name_Specification_Exceptions : constant Name_Id := N + 715; ! Name_Specification_Suffix : constant Name_Id := N + 716; ! Name_Stack : constant Name_Id := N + 717; ! Name_Switches : constant Name_Id := N + 718; ! Name_Symbolic_Link_Supported : constant Name_Id := N + 719; ! Name_Toolchain_Description : constant Name_Id := N + 720; ! Name_Toolchain_Version : constant Name_Id := N + 721; ! Name_Runtime_Library_Dir : constant Name_Id := N + 722; -- Other miscellaneous names used in front end ! Name_Unaligned_Valid : constant Name_Id := N + 723; -- Ada 2005 reserved words ! First_2005_Reserved_Word : constant Name_Id := N + 724; ! Name_Interface : constant Name_Id := N + 724; ! Name_Overriding : constant Name_Id := N + 725; ! Name_Synchronized : constant Name_Id := N + 726; ! Last_2005_Reserved_Word : constant Name_Id := N + 726; subtype Ada_2005_Reserved_Words is Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word; -- Mark last defined name for consistency check in Snames body ! Last_Predefined_Name : constant Name_Id := N + 726; --------------------------------------- -- Subtypes Defining Name Categories -- --- 872,1156 ---- -- name (e.g. F for FIFO_Within_Priorities). If new policy names -- are added, the first character must be distinct. ! First_Task_Dispatching_Policy_Name : constant Name_Id := N + 529; ! Name_EDF_Across_Priorities : constant Name_Id := N + 529; ! Name_FIFO_Within_Priorities : constant Name_Id := N + 530; ! Name_Non_Preemptive_Within_Priorities : constant Name_Id := N + 531; ! Name_Round_Robin_Within_Priorities : constant Name_Id := N + 532; ! Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 532; -- Names of recognized checks for pragma Suppress ! First_Check_Name : constant Name_Id := N + 533; ! Name_Access_Check : constant Name_Id := N + 533; ! Name_Accessibility_Check : constant Name_Id := N + 534; ! Name_Alignment_Check : constant Name_Id := N + 535; -- GNAT ! Name_Discriminant_Check : constant Name_Id := N + 536; ! Name_Division_Check : constant Name_Id := N + 537; ! Name_Elaboration_Check : constant Name_Id := N + 538; ! Name_Index_Check : constant Name_Id := N + 539; ! Name_Length_Check : constant Name_Id := N + 540; ! Name_Overflow_Check : constant Name_Id := N + 541; ! Name_Range_Check : constant Name_Id := N + 542; ! Name_Storage_Check : constant Name_Id := N + 543; ! Name_Tag_Check : constant Name_Id := N + 544; ! Name_Validity_Check : constant Name_Id := N + 545; -- GNAT ! Name_All_Checks : constant Name_Id := N + 546; ! Last_Check_Name : constant Name_Id := N + 546; -- Names corresponding to reserved keywords, excluding those already -- declared in the attribute list (Access, Delta, Digits, Mod, Range). ! Name_Abort : constant Name_Id := N + 547; ! Name_Abs : constant Name_Id := N + 548; ! Name_Accept : constant Name_Id := N + 549; ! Name_And : constant Name_Id := N + 550; ! Name_All : constant Name_Id := N + 551; ! Name_Array : constant Name_Id := N + 552; ! Name_At : constant Name_Id := N + 553; ! Name_Begin : constant Name_Id := N + 554; ! Name_Body : constant Name_Id := N + 555; ! Name_Case : constant Name_Id := N + 556; ! Name_Constant : constant Name_Id := N + 557; ! Name_Declare : constant Name_Id := N + 558; ! Name_Delay : constant Name_Id := N + 559; ! Name_Do : constant Name_Id := N + 560; ! Name_Else : constant Name_Id := N + 561; ! Name_Elsif : constant Name_Id := N + 562; ! Name_End : constant Name_Id := N + 563; ! Name_Entry : constant Name_Id := N + 564; ! Name_Exception : constant Name_Id := N + 565; ! Name_Exit : constant Name_Id := N + 566; ! Name_For : constant Name_Id := N + 567; ! Name_Function : constant Name_Id := N + 568; ! Name_Generic : constant Name_Id := N + 569; ! Name_Goto : constant Name_Id := N + 570; ! Name_If : constant Name_Id := N + 571; ! Name_In : constant Name_Id := N + 572; ! Name_Is : constant Name_Id := N + 573; ! Name_Limited : constant Name_Id := N + 574; ! Name_Loop : constant Name_Id := N + 575; ! Name_New : constant Name_Id := N + 576; ! Name_Not : constant Name_Id := N + 577; ! Name_Null : constant Name_Id := N + 578; ! Name_Of : constant Name_Id := N + 579; ! Name_Or : constant Name_Id := N + 580; ! Name_Others : constant Name_Id := N + 581; ! Name_Out : constant Name_Id := N + 582; ! Name_Package : constant Name_Id := N + 583; ! Name_Pragma : constant Name_Id := N + 584; ! Name_Private : constant Name_Id := N + 585; ! Name_Procedure : constant Name_Id := N + 586; ! Name_Raise : constant Name_Id := N + 587; ! Name_Record : constant Name_Id := N + 588; ! Name_Rem : constant Name_Id := N + 589; ! Name_Renames : constant Name_Id := N + 590; ! Name_Return : constant Name_Id := N + 591; ! Name_Reverse : constant Name_Id := N + 592; ! Name_Select : constant Name_Id := N + 593; ! Name_Separate : constant Name_Id := N + 594; ! Name_Subtype : constant Name_Id := N + 595; ! Name_Task : constant Name_Id := N + 596; ! Name_Terminate : constant Name_Id := N + 597; ! Name_Then : constant Name_Id := N + 598; ! Name_Type : constant Name_Id := N + 599; ! Name_Use : constant Name_Id := N + 600; ! Name_When : constant Name_Id := N + 601; ! Name_While : constant Name_Id := N + 602; ! Name_With : constant Name_Id := N + 603; ! Name_Xor : constant Name_Id := N + 604; -- Names of intrinsic subprograms -- Note: Asm is missing from this list, since Asm is a legitimate ! -- convention name. So is To_Address, which is a GNAT attribute. ! First_Intrinsic_Name : constant Name_Id := N + 605; ! Name_Divide : constant Name_Id := N + 605; ! Name_Enclosing_Entity : constant Name_Id := N + 606; ! Name_Exception_Information : constant Name_Id := N + 607; ! Name_Exception_Message : constant Name_Id := N + 608; ! Name_Exception_Name : constant Name_Id := N + 609; ! Name_File : constant Name_Id := N + 610; ! Name_Generic_Dispatching_Constructor : constant Name_Id := N + 611; ! Name_Import_Address : constant Name_Id := N + 612; ! Name_Import_Largest_Value : constant Name_Id := N + 613; ! Name_Import_Value : constant Name_Id := N + 614; ! Name_Is_Negative : constant Name_Id := N + 615; ! Name_Line : constant Name_Id := N + 616; ! Name_Rotate_Left : constant Name_Id := N + 617; ! Name_Rotate_Right : constant Name_Id := N + 618; ! Name_Shift_Left : constant Name_Id := N + 619; ! Name_Shift_Right : constant Name_Id := N + 620; ! Name_Shift_Right_Arithmetic : constant Name_Id := N + 621; ! Name_Source_Location : constant Name_Id := N + 622; ! Name_Unchecked_Conversion : constant Name_Id := N + 623; ! Name_Unchecked_Deallocation : constant Name_Id := N + 624; ! Name_To_Pointer : constant Name_Id := N + 625; ! Last_Intrinsic_Name : constant Name_Id := N + 625; -- Names used in processing intrinsic calls ! Name_Free : constant Name_Id := N + 626; -- Reserved words used only in Ada 95 ! First_95_Reserved_Word : constant Name_Id := N + 627; ! Name_Abstract : constant Name_Id := N + 627; ! Name_Aliased : constant Name_Id := N + 628; ! Name_Protected : constant Name_Id := N + 629; ! Name_Until : constant Name_Id := N + 630; ! Name_Requeue : constant Name_Id := N + 631; ! Name_Tagged : constant Name_Id := N + 632; ! Last_95_Reserved_Word : constant Name_Id := N + 632; subtype Ada_95_Reserved_Words is Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word; -- Miscellaneous names used in semantic checking ! Name_Raise_Exception : constant Name_Id := N + 633; -- Additional reserved words and identifiers used in GNAT Project Files -- Note that Name_External is already previously declared ! Name_Ada_Roots : constant Name_Id := N + 634; ! Name_Aggregate : constant Name_Id := N + 635; ! Name_Archive_Builder : constant Name_Id := N + 636; ! Name_Archive_Builder_Append_Option : constant Name_Id := N + 637; ! Name_Archive_Indexer : constant Name_Id := N + 638; ! Name_Archive_Suffix : constant Name_Id := N + 639; ! Name_Binder : constant Name_Id := N + 640; ! Name_Binder_Prefix : constant Name_Id := N + 641; ! Name_Body_Suffix : constant Name_Id := N + 642; ! Name_Builder : constant Name_Id := N + 643; ! Name_Builder_Switches : constant Name_Id := N + 644; ! Name_Compiler : constant Name_Id := N + 645; ! Name_Compiler_Kind : constant Name_Id := N + 646; ! Name_Config_Body_File_Name : constant Name_Id := N + 647; ! Name_Config_Body_File_Name_Pattern : constant Name_Id := N + 648; ! Name_Config_File_Switches : constant Name_Id := N + 649; ! Name_Config_File_Unique : constant Name_Id := N + 650; ! Name_Config_Spec_File_Name : constant Name_Id := N + 651; ! Name_Config_Spec_File_Name_Pattern : constant Name_Id := N + 652; ! Name_Configuration : constant Name_Id := N + 653; ! Name_Cross_Reference : constant Name_Id := N + 654; ! Name_Default_Language : constant Name_Id := N + 655; ! Name_Default_Switches : constant Name_Id := N + 656; ! Name_Dependency_Driver : constant Name_Id := N + 657; ! Name_Dependency_File_Kind : constant Name_Id := N + 658; ! Name_Dependency_Switches : constant Name_Id := N + 659; ! Name_Driver : constant Name_Id := N + 660; ! Name_Excluded_Source_Dirs : constant Name_Id := N + 661; ! Name_Excluded_Source_Files : constant Name_Id := N + 662; ! Name_Excluded_Source_List_File : constant Name_Id := N + 663; ! Name_Exec_Dir : constant Name_Id := N + 664; ! Name_Executable : constant Name_Id := N + 665; ! Name_Executable_Suffix : constant Name_Id := N + 666; ! Name_Extends : constant Name_Id := N + 667; ! Name_Externally_Built : constant Name_Id := N + 668; ! Name_Finder : constant Name_Id := N + 669; ! Name_Global_Compilation_Switches : constant Name_Id := N + 670; ! Name_Global_Configuration_Pragmas : constant Name_Id := N + 671; ! Name_Global_Config_File : constant Name_Id := N + 672; ! Name_Gnatls : constant Name_Id := N + 673; ! Name_Gnatstub : constant Name_Id := N + 674; ! Name_Implementation : constant Name_Id := N + 675; ! Name_Implementation_Exceptions : constant Name_Id := N + 676; ! Name_Implementation_Suffix : constant Name_Id := N + 677; ! Name_Include_Switches : constant Name_Id := N + 678; ! Name_Include_Path : constant Name_Id := N + 679; ! Name_Include_Path_File : constant Name_Id := N + 680; ! Name_Inherit_Source_Path : constant Name_Id := N + 681; ! Name_Language_Kind : constant Name_Id := N + 682; ! Name_Language_Processing : constant Name_Id := N + 683; ! Name_Languages : constant Name_Id := N + 684; ! Name_Library : constant Name_Id := N + 685; ! Name_Library_Ali_Dir : constant Name_Id := N + 686; ! Name_Library_Auto_Init : constant Name_Id := N + 687; ! Name_Library_Auto_Init_Supported : constant Name_Id := N + 688; ! Name_Library_Builder : constant Name_Id := N + 689; ! Name_Library_Dir : constant Name_Id := N + 690; ! Name_Library_GCC : constant Name_Id := N + 691; ! Name_Library_Interface : constant Name_Id := N + 692; ! Name_Library_Kind : constant Name_Id := N + 693; ! Name_Library_Name : constant Name_Id := N + 694; ! Name_Library_Major_Minor_Id_Supported : constant Name_Id := N + 695; ! Name_Library_Options : constant Name_Id := N + 696; ! Name_Library_Partial_Linker : constant Name_Id := N + 697; ! Name_Library_Reference_Symbol_File : constant Name_Id := N + 698; ! Name_Library_Src_Dir : constant Name_Id := N + 699; ! Name_Library_Support : constant Name_Id := N + 700; ! Name_Library_Symbol_File : constant Name_Id := N + 701; ! Name_Library_Symbol_Policy : constant Name_Id := N + 702; ! Name_Library_Version : constant Name_Id := N + 703; ! Name_Library_Version_Switches : constant Name_Id := N + 704; ! Name_Linker : constant Name_Id := N + 705; ! Name_Linker_Executable_Option : constant Name_Id := N + 706; ! Name_Linker_Lib_Dir_Option : constant Name_Id := N + 707; ! Name_Linker_Lib_Name_Option : constant Name_Id := N + 708; ! Name_Local_Config_File : constant Name_Id := N + 709; ! Name_Local_Configuration_Pragmas : constant Name_Id := N + 710; ! Name_Locally_Removed_Files : constant Name_Id := N + 711; ! Name_Map_File_Option : constant Name_Id := N + 712; ! Name_Mapping_File_Switches : constant Name_Id := N + 713; ! Name_Mapping_Spec_Suffix : constant Name_Id := N + 714; ! Name_Mapping_Body_Suffix : constant Name_Id := N + 715; ! Name_Metrics : constant Name_Id := N + 716; ! Name_Naming : constant Name_Id := N + 717; ! Name_Object_Generated : constant Name_Id := N + 718; ! Name_Objects_Linked : constant Name_Id := N + 719; ! Name_Objects_Path : constant Name_Id := N + 720; ! Name_Objects_Path_File : constant Name_Id := N + 721; ! Name_Object_Dir : constant Name_Id := N + 722; ! Name_Path_Syntax : constant Name_Id := N + 723; ! Name_Pic_Option : constant Name_Id := N + 724; ! Name_Pretty_Printer : constant Name_Id := N + 725; ! Name_Prefix : constant Name_Id := N + 726; ! Name_Project : constant Name_Id := N + 727; ! Name_Roots : constant Name_Id := N + 728; ! Name_Required_Switches : constant Name_Id := N + 729; ! Name_Run_Path_Option : constant Name_Id := N + 730; ! Name_Runtime_Project : constant Name_Id := N + 731; ! Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 732; ! Name_Shared_Library_Prefix : constant Name_Id := N + 733; ! Name_Shared_Library_Suffix : constant Name_Id := N + 734; ! Name_Separate_Suffix : constant Name_Id := N + 735; ! Name_Source_Dirs : constant Name_Id := N + 736; ! Name_Source_Files : constant Name_Id := N + 737; ! Name_Source_List_File : constant Name_Id := N + 738; ! Name_Spec : constant Name_Id := N + 739; ! Name_Spec_Suffix : constant Name_Id := N + 740; ! Name_Specification : constant Name_Id := N + 741; ! Name_Specification_Exceptions : constant Name_Id := N + 742; ! Name_Specification_Suffix : constant Name_Id := N + 743; ! Name_Stack : constant Name_Id := N + 744; ! Name_Switches : constant Name_Id := N + 745; ! Name_Symbolic_Link_Supported : constant Name_Id := N + 746; ! Name_Sync : constant Name_Id := N + 747; ! Name_Synchronize : constant Name_Id := N + 748; ! Name_Toolchain_Description : constant Name_Id := N + 749; ! Name_Toolchain_Version : constant Name_Id := N + 750; ! Name_Runtime_Library_Dir : constant Name_Id := N + 751; -- Other miscellaneous names used in front end ! Name_Unaligned_Valid : constant Name_Id := N + 752; -- Ada 2005 reserved words ! First_2005_Reserved_Word : constant Name_Id := N + 753; ! Name_Interface : constant Name_Id := N + 753; ! Name_Overriding : constant Name_Id := N + 754; ! Name_Synchronized : constant Name_Id := N + 755; ! Last_2005_Reserved_Word : constant Name_Id := N + 755; subtype Ada_2005_Reserved_Words is Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word; -- Mark last defined name for consistency check in Snames body ! Last_Predefined_Name : constant Name_Id := N + 755; --------------------------------------- -- Subtypes Defining Name Categories -- *************** package Snames is *** 1168,1173 **** --- 1196,1202 ---- Attribute_Emax, Attribute_Enabled, Attribute_Enum_Rep, + Attribute_Enum_Val, Attribute_Epsilon, Attribute_Exponent, Attribute_External_Tag, *************** package Snames is *** 1178,1186 **** --- 1207,1217 ---- Attribute_Fore, Attribute_Has_Access_Values, Attribute_Has_Discriminants, + Attribute_Has_Tagged_Values, Attribute_Identity, Attribute_Img, Attribute_Integer_Value, + Attribute_Invalid_Value, Attribute_Large, Attribute_Last, Attribute_Last_Bit, *************** package Snames is *** 1206,1211 **** --- 1237,1243 ---- Attribute_Modulus, Attribute_Null_Parameter, Attribute_Object_Size, + Attribute_Old, Attribute_Partition_ID, Attribute_Passed_By_Reference, Attribute_Pool_Address, *************** package Snames is *** 1214,1219 **** --- 1246,1252 ---- Attribute_Priority, Attribute_Range, Attribute_Range_Length, + Attribute_Result, Attribute_Round, Attribute_Safe_Emax, Attribute_Safe_First, *************** package Snames is *** 1257,1262 **** --- 1290,1296 ---- Attribute_Copy_Sign, Attribute_Floor, Attribute_Fraction, + Attribute_From_Any, Attribute_Image, Attribute_Input, Attribute_Machine, *************** package Snames is *** 1267,1273 **** --- 1301,1309 ---- Attribute_Remainder, Attribute_Rounding, Attribute_Succ, + Attribute_To_Any, Attribute_Truncation, + Attribute_TypeCode, Attribute_Value, Attribute_Wide_Image, Attribute_Wide_Wide_Image, *************** package Snames is *** 1292,1297 **** --- 1328,1336 ---- Attribute_Class, Attribute_Stub_Type); + type Attribute_Class_Array is array (Attribute_Id) of Boolean; + -- Type used to build attribute classification flag arrays + ------------------------------------ -- Convention Name ID Definitions -- ------------------------------------ *************** package Snames is *** 1320,1326 **** -- Note: Convention C_Pass_By_Copy is allowed only for record -- types (where it is treated like C except that the appropriate ! -- flag is set in the record type). Recognizion of this convention -- is specially handled in Sem_Prag. for Convention_Id'Size use 8; --- 1359,1365 ---- -- Note: Convention C_Pass_By_Copy is allowed only for record -- types (where it is treated like C except that the appropriate ! -- flag is set in the record type). Recognizing this convention -- is specially handled in Sem_Prag. for Convention_Id'Size use 8; *************** package Snames is *** 1345,1357 **** --- 1384,1402 ---- -- Configuration pragmas + -- Note: This list is in the GNAT users guide, so be sure that if any + -- additions or deletions are made to the following list, they are + -- properly reflected in the users guide. + Pragma_Ada_83, Pragma_Ada_95, Pragma_Ada_05, Pragma_Ada_2005, Pragma_Assertion_Policy, + Pragma_Assume_No_Invalid_Values, Pragma_C_Pass_By_Copy, Pragma_Check_Name, + Pragma_Check_Policy, Pragma_Compile_Time_Error, Pragma_Compile_Time_Warning, Pragma_Compiler_Unit, *************** package Snames is *** 1376,1383 **** Pragma_No_Run_Time, Pragma_No_Strict_Aliasing, Pragma_Normalize_Scalars, ! Pragma_Polling, Pragma_Persistent_BSS, Pragma_Priority_Specific_Dispatching, Pragma_Profile, Pragma_Profile_Warnings, --- 1421,1429 ---- Pragma_No_Run_Time, Pragma_No_Strict_Aliasing, Pragma_Normalize_Scalars, ! Pragma_Optimize_Alignment, Pragma_Persistent_BSS, + Pragma_Polling, Pragma_Priority_Specific_Dispatching, Pragma_Profile, Pragma_Profile_Warnings, *************** package Snames is *** 1411,1416 **** --- 1457,1463 ---- Pragma_Atomic, Pragma_Atomic_Components, Pragma_Attach_Handler, + Pragma_Check, Pragma_CIL_Constructor, Pragma_Comment, Pragma_Common_Object, *************** package Snames is *** 1471,1476 **** --- 1518,1525 ---- Pragma_Pack, Pragma_Page, Pragma_Passive, + Pragma_Postcondition, + Pragma_Precondition, Pragma_Preelaborable_Initialization, Pragma_Preelaborate, Pragma_Preelaborate_05, *************** package Snames is *** 1478,1483 **** --- 1527,1533 ---- Pragma_Pure, Pragma_Pure_05, Pragma_Pure_Function, + Pragma_Relative_Deadline, Pragma_Remote_Call_Interface, Pragma_Remote_Types, Pragma_Share_Generic, *************** package Snames is *** 1538,1550 **** Task_Dispatching_FIFO_Within_Priorities); -- Id values used to identify task dispatching policies - ------------------ - -- Helper types -- - ------------------ - - type Attribute_Class_Array is array (Attribute_Id) of Boolean; - -- Type used to build attribute classification flag arrays - ----------------- -- Subprograms -- ----------------- --- 1588,1593 ---- *************** package Snames is *** 1567,1573 **** -- Test to see if the name N is the name of a recognized attribute -- that designates a renameable function, and can therefore appear in -- a renaming statement. Note that not all attributes designating ! -- functions are renamable, in particular, thos returning a universal -- value cannot be renamed. function Is_Type_Attribute_Name (N : Name_Id) return Boolean; --- 1610,1616 ---- -- Test to see if the name N is the name of a recognized attribute -- that designates a renameable function, and can therefore appear in -- a renaming statement. Note that not all attributes designating ! -- functions are renamable, in particular, those returning a universal -- value cannot be renamed. function Is_Type_Attribute_Name (N : Name_Id) return Boolean; *************** package Snames is *** 1625,1631 **** -- or one previously given in a call to Record_Convention_Identifier. function Get_Convention_Name (C : Convention_Id) return Name_Id; ! -- Returns the name of language convention correspoding to given -- convention id. function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id; --- 1668,1674 ---- -- or one previously given in a call to Record_Convention_Identifier. function Get_Convention_Name (C : Convention_Id) return Name_Id; ! -- Returns the name of language convention corresponding to given -- convention id. function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id; diff -Nrcpad gcc-4.3.3/gcc/ada/snames.h gcc-4.4.0/gcc/ada/snames.h *** gcc-4.3.3/gcc/ada/snames.h Wed Dec 19 16:22:02 2007 --- gcc-4.4.0/gcc/ada/snames.h Fri Aug 22 15:07:34 2008 *************** *** 6,12 **** * * * C Header File * * * ! * Copyright (C) 1992-2007, 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- * --- 6,12 ---- * * * C Header File * * * ! * Copyright (C) 1992-2008, 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- * *************** extern unsigned char Get_Attribute_Id (i *** 73,189 **** #define Attr_Emax 26 #define Attr_Enabled 27 #define Attr_Enum_Rep 28 ! #define Attr_Epsilon 29 ! #define Attr_Exponent 30 ! #define Attr_External_Tag 31 ! #define Attr_Fast_Math 32 ! #define Attr_First 33 ! #define Attr_First_Bit 34 ! #define Attr_Fixed_Value 35 ! #define Attr_Fore 36 ! #define Attr_Has_Access_Values 37 ! #define Attr_Has_Discriminants 38 ! #define Attr_Identity 39 ! #define Attr_Img 40 ! #define Attr_Integer_Value 41 ! #define Attr_Large 42 ! #define Attr_Last 43 ! #define Attr_Last_Bit 44 ! #define Attr_Leading_Part 45 ! #define Attr_Length 46 ! #define Attr_Machine_Emax 47 ! #define Attr_Machine_Emin 48 ! #define Attr_Machine_Mantissa 49 ! #define Attr_Machine_Overflows 50 ! #define Attr_Machine_Radix 51 ! #define Attr_Machine_Rounding 52 ! #define Attr_Machine_Rounds 53 ! #define Attr_Machine_Size 54 ! #define Attr_Mantissa 55 ! #define Attr_Max_Size_In_Storage_Elements 56 ! #define Attr_Maximum_Alignment 57 ! #define Attr_Mechanism_Code 58 ! #define Attr_Mod 59 ! #define Attr_Model_Emin 60 ! #define Attr_Model_Epsilon 61 ! #define Attr_Model_Mantissa 62 ! #define Attr_Model_Small 63 ! #define Attr_Modulus 64 ! #define Attr_Null_Parameter 65 ! #define Attr_Object_Size 66 ! #define Attr_Partition_ID 67 ! #define Attr_Passed_By_Reference 68 ! #define Attr_Pool_Address 69 ! #define Attr_Pos 70 ! #define Attr_Position 71 ! #define Attr_Priority 72 ! #define Attr_Range 73 ! #define Attr_Range_Length 74 ! #define Attr_Round 75 ! #define Attr_Safe_Emax 76 ! #define Attr_Safe_First 77 ! #define Attr_Safe_Large 78 ! #define Attr_Safe_Last 79 ! #define Attr_Safe_Small 80 ! #define Attr_Scale 81 ! #define Attr_Scaling 82 ! #define Attr_Signed_Zeros 83 ! #define Attr_Size 84 ! #define Attr_Small 85 ! #define Attr_Storage_Size 86 ! #define Attr_Storage_Unit 87 ! #define Attr_Stream_Size 88 ! #define Attr_Tag 89 ! #define Attr_Target_Name 90 ! #define Attr_Terminated 91 ! #define Attr_To_Address 92 ! #define Attr_Type_Class 93 ! #define Attr_UET_Address 94 ! #define Attr_Unbiased_Rounding 95 ! #define Attr_Unchecked_Access 96 ! #define Attr_Unconstrained_Array 97 ! #define Attr_Universal_Literal_String 98 ! #define Attr_Unrestricted_Access 99 ! #define Attr_VADS_Size 100 ! #define Attr_Val 101 ! #define Attr_Valid 102 ! #define Attr_Value_Size 103 ! #define Attr_Version 104 ! #define Attr_Wchar_T_Size 105 ! #define Attr_Wide_Wide_Width 106 ! #define Attr_Wide_Width 107 ! #define Attr_Width 108 ! #define Attr_Word_Size 109 ! #define Attr_Adjacent 110 ! #define Attr_Ceiling 111 ! #define Attr_Copy_Sign 112 ! #define Attr_Floor 113 ! #define Attr_Fraction 114 ! #define Attr_Image 115 ! #define Attr_Input 116 ! #define Attr_Machine 117 ! #define Attr_Max 118 ! #define Attr_Min 119 ! #define Attr_Model 120 ! #define Attr_Pred 121 ! #define Attr_Remainder 122 ! #define Attr_Rounding 123 ! #define Attr_Succ 124 ! #define Attr_Truncation 125 ! #define Attr_Value 126 ! #define Attr_Wide_Image 127 ! #define Attr_Wide_Wide_Image 128 ! #define Attr_Wide_Value 129 ! #define Attr_Wide_Wide_Value 130 ! #define Attr_Output 131 ! #define Attr_Read 132 ! #define Attr_Write 133 ! #define Attr_Elab_Body 134 ! #define Attr_Elab_Spec 135 ! #define Attr_Storage_Pool 136 ! #define Attr_Base 137 ! #define Attr_Class 138 ! #define Attr_Stub_Type 139 /* Define the numeric values for the conventions. */ --- 73,197 ---- #define Attr_Emax 26 #define Attr_Enabled 27 #define Attr_Enum_Rep 28 ! #define Attr_Enum_Val 29 ! #define Attr_Epsilon 30 ! #define Attr_Exponent 31 ! #define Attr_External_Tag 32 ! #define Attr_Fast_Math 33 ! #define Attr_First 34 ! #define Attr_First_Bit 35 ! #define Attr_Fixed_Value 36 ! #define Attr_Fore 37 ! #define Attr_Has_Access_Values 38 ! #define Attr_Has_Discriminants 39 ! #define Attr_Has_Tagged_Values 40 ! #define Attr_Identity 41 ! #define Attr_Img 42 ! #define Attr_Integer_Value 43 ! #define Attr_Invalid_Value 44 ! #define Attr_Large 45 ! #define Attr_Last 46 ! #define Attr_Last_Bit 47 ! #define Attr_Leading_Part 48 ! #define Attr_Length 49 ! #define Attr_Machine_Emax 50 ! #define Attr_Machine_Emin 51 ! #define Attr_Machine_Mantissa 52 ! #define Attr_Machine_Overflows 53 ! #define Attr_Machine_Radix 54 ! #define Attr_Machine_Rounding 55 ! #define Attr_Machine_Rounds 56 ! #define Attr_Machine_Size 57 ! #define Attr_Mantissa 58 ! #define Attr_Max_Size_In_Storage_Elements 59 ! #define Attr_Maximum_Alignment 60 ! #define Attr_Mechanism_Code 61 ! #define Attr_Mod 62 ! #define Attr_Model_Emin 63 ! #define Attr_Model_Epsilon 64 ! #define Attr_Model_Mantissa 65 ! #define Attr_Model_Small 66 ! #define Attr_Modulus 67 ! #define Attr_Null_Parameter 68 ! #define Attr_Object_Size 69 ! #define Attr_Old 70 ! #define Attr_Partition_ID 71 ! #define Attr_Passed_By_Reference 72 ! #define Attr_Pool_Address 73 ! #define Attr_Pos 74 ! #define Attr_Position 75 ! #define Attr_Priority 76 ! #define Attr_Range 77 ! #define Attr_Range_Length 78 ! #define Attr_Result 79 ! #define Attr_Round 80 ! #define Attr_Safe_Emax 81 ! #define Attr_Safe_First 82 ! #define Attr_Safe_Large 83 ! #define Attr_Safe_Last 84 ! #define Attr_Safe_Small 85 ! #define Attr_Scale 86 ! #define Attr_Scaling 87 ! #define Attr_Signed_Zeros 88 ! #define Attr_Size 89 ! #define Attr_Small 90 ! #define Attr_Storage_Size 91 ! #define Attr_Storage_Unit 92 ! #define Attr_Stream_Size 93 ! #define Attr_Tag 94 ! #define Attr_Target_Name 95 ! #define Attr_Terminated 96 ! #define Attr_To_Address 97 ! #define Attr_Type_Class 98 ! #define Attr_UET_Address 99 ! #define Attr_Unbiased_Rounding 100 ! #define Attr_Unchecked_Access 101 ! #define Attr_Unconstrained_Array 102 ! #define Attr_Universal_Literal_String 103 ! #define Attr_Unrestricted_Access 104 ! #define Attr_VADS_Size 105 ! #define Attr_Val 106 ! #define Attr_Valid 107 ! #define Attr_Value_Size 108 ! #define Attr_Version 109 ! #define Attr_Wchar_T_Size 110 ! #define Attr_Wide_Wide_Width 111 ! #define Attr_Wide_Width 112 ! #define Attr_Width 113 ! #define Attr_Word_Size 114 ! #define Attr_Adjacent 115 ! #define Attr_Ceiling 116 ! #define Attr_Copy_Sign 117 ! #define Attr_Floor 118 ! #define Attr_Fraction 119 ! #define Attr_From_Any 120 ! #define Attr_Image 121 ! #define Attr_Input 122 ! #define Attr_Machine 123 ! #define Attr_Max 124 ! #define Attr_Min 125 ! #define Attr_Model 126 ! #define Attr_Pred 127 ! #define Attr_Remainder 128 ! #define Attr_Rounding 129 ! #define Attr_Succ 130 ! #define Attr_To_Any 131 ! #define Attr_Truncation 132 ! #define Attr_TypeCode 133 ! #define Attr_Value 134 ! #define Attr_Wide_Image 135 ! #define Attr_Wide_Wide_Image 136 ! #define Attr_Wide_Value 137 ! #define Attr_Wide_Wide_Value 138 ! #define Attr_Output 139 ! #define Attr_Read 140 ! #define Attr_Write 141 ! #define Attr_Elab_Body 142 ! #define Attr_Elab_Spec 143 ! #define Attr_Storage_Pool 144 ! #define Attr_Base 145 ! #define Attr_Class 146 ! #define Attr_Stub_Type 147 /* Define the numeric values for the conventions. */ *************** extern unsigned char Get_Pragma_Id (int) *** 221,384 **** #define Pragma_Ada_05 2 #define Pragma_Ada_2005 3 #define Pragma_Assertion_Policy 4 ! #define Pragma_C_Pass_By_Copy 5 ! #define Pragma_Check_Name 6 ! #define Pragma_Compile_Time_Error 7 ! #define Pragma_Compile_Time_Warning 8 ! #define Pragma_Compiler_Unit 9 ! #define Pragma_Component_Alignment 10 ! #define Pragma_Convention_Identifier 11 ! #define Pragma_Debug_Policy 12 ! #define Pragma_Detect_Blocking 13 ! #define Pragma_Discard_Names 14 ! #define Pragma_Elaboration_Checks 15 ! #define Pragma_Eliminate 16 ! #define Pragma_Extend_System 17 ! #define Pragma_Extensions_Allowed 18 ! #define Pragma_External_Name_Casing 19 ! #define Pragma_Favor_Top_Level 20 ! #define Pragma_Float_Representation 21 ! #define Pragma_Implicit_Packing 22 ! #define Pragma_Initialize_Scalars 23 ! #define Pragma_Interrupt_State 24 ! #define Pragma_License 25 ! #define Pragma_Locking_Policy 26 ! #define Pragma_Long_Float 27 ! #define Pragma_No_Run_Time 28 ! #define Pragma_No_Strict_Aliasing 29 ! #define Pragma_Normalize_Scalars 30 ! #define Pragma_Polling 31 ! #define Pragma_Persistent_BSS 32 ! #define Pragma_Priority_Specific_Dispatching 33 ! #define Pragma_Profile 34 ! #define Pragma_Profile_Warnings 35 ! #define Pragma_Propagate_Exceptions 36 ! #define Pragma_Queuing_Policy 37 ! #define Pragma_Ravenscar 38 ! #define Pragma_Restricted_Run_Time 39 ! #define Pragma_Restrictions 40 ! #define Pragma_Restriction_Warnings 41 ! #define Pragma_Reviewable 42 ! #define Pragma_Source_File_Name 43 ! #define Pragma_Source_File_Name_Project 44 ! #define Pragma_Style_Checks 45 ! #define Pragma_Suppress 46 ! #define Pragma_Suppress_Exception_Locations 47 ! #define Pragma_Task_Dispatching_Policy 48 ! #define Pragma_Universal_Data 49 ! #define Pragma_Unsuppress 50 ! #define Pragma_Use_VADS_Size 51 ! #define Pragma_Validity_Checks 52 ! #define Pragma_Warnings 53 ! #define Pragma_Wide_Character_Encoding 54 ! #define Pragma_Abort_Defer 55 ! #define Pragma_All_Calls_Remote 56 ! #define Pragma_Annotate 57 ! #define Pragma_Assert 58 ! #define Pragma_Asynchronous 59 ! #define Pragma_Atomic 60 ! #define Pragma_Atomic_Components 61 ! #define Pragma_Attach_Handler 62 ! #define Pragma_CIL_Constructor 63 ! #define Pragma_Comment 64 ! #define Pragma_Common_Object 65 ! #define Pragma_Complete_Representation 66 ! #define Pragma_Complex_Representation 67 ! #define Pragma_Controlled 68 ! #define Pragma_Convention 69 ! #define Pragma_CPP_Class 70 ! #define Pragma_CPP_Constructor 71 ! #define Pragma_CPP_Virtual 72 ! #define Pragma_CPP_Vtable 73 ! #define Pragma_Debug 74 ! #define Pragma_Elaborate 75 ! #define Pragma_Elaborate_All 76 ! #define Pragma_Elaborate_Body 77 ! #define Pragma_Export 78 ! #define Pragma_Export_Exception 79 ! #define Pragma_Export_Function 80 ! #define Pragma_Export_Object 81 ! #define Pragma_Export_Procedure 82 ! #define Pragma_Export_Value 83 ! #define Pragma_Export_Valued_Procedure 84 ! #define Pragma_External 85 ! #define Pragma_Finalize_Storage_Only 86 ! #define Pragma_Ident 87 ! #define Pragma_Implemented_By_Entry 88 ! #define Pragma_Import 89 ! #define Pragma_Import_Exception 90 ! #define Pragma_Import_Function 91 ! #define Pragma_Import_Object 92 ! #define Pragma_Import_Procedure 93 ! #define Pragma_Import_Valued_Procedure 94 ! #define Pragma_Inline 95 ! #define Pragma_Inline_Always 96 ! #define Pragma_Inline_Generic 97 ! #define Pragma_Inspection_Point 98 ! #define Pragma_Interface_Name 99 ! #define Pragma_Interrupt_Handler 100 ! #define Pragma_Interrupt_Priority 101 ! #define Pragma_Java_Constructor 102 ! #define Pragma_Java_Interface 103 ! #define Pragma_Keep_Names 104 ! #define Pragma_Link_With 105 ! #define Pragma_Linker_Alias 106 ! #define Pragma_Linker_Constructor 107 ! #define Pragma_Linker_Destructor 108 ! #define Pragma_Linker_Options 109 ! #define Pragma_Linker_Section 110 ! #define Pragma_List 111 ! #define Pragma_Machine_Attribute 112 ! #define Pragma_Main 113 ! #define Pragma_Main_Storage 114 ! #define Pragma_Memory_Size 115 ! #define Pragma_No_Body 116 ! #define Pragma_No_Return 117 ! #define Pragma_Obsolescent 118 ! #define Pragma_Optimize 119 ! #define Pragma_Pack 120 ! #define Pragma_Page 121 ! #define Pragma_Passive 122 ! #define Pragma_Preelaborable_Initialization 123 ! #define Pragma_Preelaborate 124 ! #define Pragma_Preelaborate_05 125 ! #define Pragma_Psect_Object 126 ! #define Pragma_Pure 127 ! #define Pragma_Pure_05 128 ! #define Pragma_Pure_Function 129 ! #define Pragma_Remote_Call_Interface 130 ! #define Pragma_Remote_Types 131 ! #define Pragma_Share_Generic 132 ! #define Pragma_Shared 133 ! #define Pragma_Shared_Passive 134 ! #define Pragma_Source_Reference 135 ! #define Pragma_Static_Elaboration_Desired 136 ! #define Pragma_Stream_Convert 137 ! #define Pragma_Subtitle 138 ! #define Pragma_Suppress_All 139 ! #define Pragma_Suppress_Debug_Info 140 ! #define Pragma_Suppress_Initialization 141 ! #define Pragma_System_Name 142 ! #define Pragma_Task_Info 143 ! #define Pragma_Task_Name 144 ! #define Pragma_Task_Storage 145 ! #define Pragma_Time_Slice 146 ! #define Pragma_Title 147 ! #define Pragma_Unchecked_Union 148 ! #define Pragma_Unimplemented_Unit 149 ! #define Pragma_Universal_Aliasing 150 ! #define Pragma_Unmodified 151 ! #define Pragma_Unreferenced 152 ! #define Pragma_Unreferenced_Objects 153 ! #define Pragma_Unreserve_All_Interrupts 154 ! #define Pragma_Volatile 155 ! #define Pragma_Volatile_Components 156 ! #define Pragma_Weak_External 157 ! #define Pragma_AST_Entry 158 ! #define Pragma_Fast_Math 159 ! #define Pragma_Interface 160 ! #define Pragma_Priority 161 ! #define Pragma_Storage_Size 162 ! #define Pragma_Storage_Unit 163 /* End of snames.h (C version of Snames package spec) */ --- 229,399 ---- #define Pragma_Ada_05 2 #define Pragma_Ada_2005 3 #define Pragma_Assertion_Policy 4 ! #define Pragma_Assume_No_Invalid_Values 5 ! #define Pragma_C_Pass_By_Copy 6 ! #define Pragma_Check_Name 7 ! #define Pragma_Check_Policy 8 ! #define Pragma_Compile_Time_Error 9 ! #define Pragma_Compile_Time_Warning 10 ! #define Pragma_Compiler_Unit 11 ! #define Pragma_Component_Alignment 12 ! #define Pragma_Convention_Identifier 13 ! #define Pragma_Debug_Policy 14 ! #define Pragma_Detect_Blocking 15 ! #define Pragma_Discard_Names 16 ! #define Pragma_Elaboration_Checks 17 ! #define Pragma_Eliminate 18 ! #define Pragma_Extend_System 19 ! #define Pragma_Extensions_Allowed 20 ! #define Pragma_External_Name_Casing 21 ! #define Pragma_Favor_Top_Level 22 ! #define Pragma_Float_Representation 23 ! #define Pragma_Implicit_Packing 24 ! #define Pragma_Initialize_Scalars 25 ! #define Pragma_Interrupt_State 26 ! #define Pragma_License 27 ! #define Pragma_Locking_Policy 28 ! #define Pragma_Long_Float 29 ! #define Pragma_No_Run_Time 30 ! #define Pragma_No_Strict_Aliasing 31 ! #define Pragma_Normalize_Scalars 32 ! #define Pragma_Optimize_Alignment 33 ! #define Pragma_Persistent_BSS 34 ! #define Pragma_Polling 35 ! #define Pragma_Priority_Specific_Dispatching 36 ! #define Pragma_Profile 37 ! #define Pragma_Profile_Warnings 38 ! #define Pragma_Propagate_Exceptions 39 ! #define Pragma_Queuing_Policy 40 ! #define Pragma_Ravenscar 41 ! #define Pragma_Restricted_Run_Time 42 ! #define Pragma_Restrictions 43 ! #define Pragma_Restriction_Warnings 44 ! #define Pragma_Reviewable 45 ! #define Pragma_Source_File_Name 46 ! #define Pragma_Source_File_Name_Project 47 ! #define Pragma_Style_Checks 48 ! #define Pragma_Suppress 49 ! #define Pragma_Suppress_Exception_Locations 50 ! #define Pragma_Task_Dispatching_Policy 51 ! #define Pragma_Universal_Data 52 ! #define Pragma_Unsuppress 53 ! #define Pragma_Use_VADS_Size 54 ! #define Pragma_Validity_Checks 55 ! #define Pragma_Warnings 56 ! #define Pragma_Wide_Character_Encoding 57 ! #define Pragma_Abort_Defer 58 ! #define Pragma_All_Calls_Remote 59 ! #define Pragma_Annotate 60 ! #define Pragma_Assert 61 ! #define Pragma_Asynchronous 62 ! #define Pragma_Atomic 63 ! #define Pragma_Atomic_Components 64 ! #define Pragma_Attach_Handler 65 ! #define Pragma_Check 66 ! #define Pragma_CIL_Constructor 67 ! #define Pragma_Comment 68 ! #define Pragma_Common_Object 69 ! #define Pragma_Complete_Representation 70 ! #define Pragma_Complex_Representation 71 ! #define Pragma_Controlled 72 ! #define Pragma_Convention 73 ! #define Pragma_CPP_Class 74 ! #define Pragma_CPP_Constructor 75 ! #define Pragma_CPP_Virtual 76 ! #define Pragma_CPP_Vtable 77 ! #define Pragma_Debug 78 ! #define Pragma_Elaborate 79 ! #define Pragma_Elaborate_All 80 ! #define Pragma_Elaborate_Body 81 ! #define Pragma_Export 82 ! #define Pragma_Export_Exception 83 ! #define Pragma_Export_Function 84 ! #define Pragma_Export_Object 85 ! #define Pragma_Export_Procedure 86 ! #define Pragma_Export_Value 87 ! #define Pragma_Export_Valued_Procedure 88 ! #define Pragma_External 89 ! #define Pragma_Finalize_Storage_Only 90 ! #define Pragma_Ident 91 ! #define Pragma_Implemented_By_Entry 92 ! #define Pragma_Import 93 ! #define Pragma_Import_Exception 94 ! #define Pragma_Import_Function 95 ! #define Pragma_Import_Object 96 ! #define Pragma_Import_Procedure 97 ! #define Pragma_Import_Valued_Procedure 98 ! #define Pragma_Inline 99 ! #define Pragma_Inline_Always 100 ! #define Pragma_Inline_Generic 101 ! #define Pragma_Inspection_Point 102 ! #define Pragma_Interface_Name 103 ! #define Pragma_Interrupt_Handler 104 ! #define Pragma_Interrupt_Priority 105 ! #define Pragma_Java_Constructor 106 ! #define Pragma_Java_Interface 107 ! #define Pragma_Keep_Names 108 ! #define Pragma_Link_With 109 ! #define Pragma_Linker_Alias 110 ! #define Pragma_Linker_Constructor 111 ! #define Pragma_Linker_Destructor 112 ! #define Pragma_Linker_Options 113 ! #define Pragma_Linker_Section 114 ! #define Pragma_List 115 ! #define Pragma_Machine_Attribute 116 ! #define Pragma_Main 117 ! #define Pragma_Main_Storage 118 ! #define Pragma_Memory_Size 119 ! #define Pragma_No_Body 120 ! #define Pragma_No_Return 121 ! #define Pragma_Obsolescent 122 ! #define Pragma_Optimize 123 ! #define Pragma_Pack 124 ! #define Pragma_Page 125 ! #define Pragma_Passive 126 ! #define Pragma_Postcondition 127 ! #define Pragma_Precondition 128 ! #define Pragma_Preelaborable_Initialization 129 ! #define Pragma_Preelaborate 130 ! #define Pragma_Preelaborate_05 131 ! #define Pragma_Psect_Object 132 ! #define Pragma_Pure 133 ! #define Pragma_Pure_05 134 ! #define Pragma_Pure_Function 135 ! #define Pragma_Relative_Deadline 136 ! #define Pragma_Remote_Call_Interface 137 ! #define Pragma_Remote_Types 138 ! #define Pragma_Share_Generic 139 ! #define Pragma_Shared 140 ! #define Pragma_Shared_Passive 141 ! #define Pragma_Source_Reference 142 ! #define Pragma_Static_Elaboration_Desired 143 ! #define Pragma_Stream_Convert 144 ! #define Pragma_Subtitle 145 ! #define Pragma_Suppress_All 146 ! #define Pragma_Suppress_Debug_Info 147 ! #define Pragma_Suppress_Initialization 148 ! #define Pragma_System_Name 149 ! #define Pragma_Task_Info 150 ! #define Pragma_Task_Name 151 ! #define Pragma_Task_Storage 152 ! #define Pragma_Time_Slice 153 ! #define Pragma_Title 154 ! #define Pragma_Unchecked_Union 155 ! #define Pragma_Unimplemented_Unit 156 ! #define Pragma_Universal_Aliasing 157 ! #define Pragma_Unmodified 158 ! #define Pragma_Unreferenced 159 ! #define Pragma_Unreferenced_Objects 160 ! #define Pragma_Unreserve_All_Interrupts 161 ! #define Pragma_Volatile 162 ! #define Pragma_Volatile_Components 163 ! #define Pragma_Weak_External 164 ! #define Pragma_AST_Entry 165 ! #define Pragma_Fast_Math 166 ! #define Pragma_Interface 167 ! #define Pragma_Priority 168 ! #define Pragma_Storage_Size 169 ! #define Pragma_Storage_Unit 170 /* End of snames.h (C version of Snames package spec) */ diff -Nrcpad gcc-4.3.3/gcc/ada/socket.c gcc-4.4.0/gcc/ada/socket.c *** gcc-4.3.3/gcc/ada/socket.c Mon Oct 15 13:54:02 2007 --- gcc-4.4.0/gcc/ada/socket.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 2003-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 2003-2009, 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** *** 31,43 **** ****************************************************************************/ /* This file provides a portable binding to the sockets API */ ! #if defined (__nucleus__) ! /* ??? Need proper implementation */ ! #warning Sockets not yet supported on Nucleus ! #else #include "gsocket.h" /* Include all the necessary system-specific headers and define the ! necessary macros (shared with gen-soccon). */ #if !defined(SO_NOSIGPIPE) && !defined (MSG_NOSIGNAL) #include --- 30,43 ---- ****************************************************************************/ /* This file provides a portable binding to the sockets API */ ! #include "gsocket.h" + + #if defined(HAVE_SOCKETS) + /* Include all the necessary system-specific headers and define the ! * necessary macros (shared with gen-oscons). ! */ #if !defined(SO_NOSIGPIPE) && !defined (MSG_NOSIGNAL) #include *************** __gnat_safe_gethostbyname (const char *n *** 206,212 **** struct hostent *rh; int ri; ! #ifdef __linux__ (void) gethostbyname_r (name, ret, buf, buflen, &rh, h_errnop); #else rh = gethostbyname_r (name, ret, buf, buflen, h_errnop); --- 206,212 ---- struct hostent *rh; int ri; ! #if defined(__linux__) || defined(__GLIBC__) (void) gethostbyname_r (name, ret, buf, buflen, &rh, h_errnop); #else rh = gethostbyname_r (name, ret, buf, buflen, h_errnop); *************** __gnat_safe_gethostbyaddr (const char *a *** 223,229 **** struct hostent *rh; int ri; ! #ifdef __linux__ (void) gethostbyaddr_r (addr, len, type, ret, buf, buflen, &rh, h_errnop); #else rh = gethostbyaddr_r (addr, len, type, ret, buf, buflen, h_errnop); --- 223,229 ---- struct hostent *rh; int ri; ! #if defined(__linux__) || defined(__GLIBC__) (void) gethostbyaddr_r (addr, len, type, ret, buf, buflen, &rh, h_errnop); #else rh = gethostbyaddr_r (addr, len, type, ret, buf, buflen, h_errnop); *************** __gnat_safe_getservbyname (const char *n *** 239,245 **** struct servent *rh; int ri; ! #ifdef __linux__ (void) getservbyname_r (name, proto, ret, buf, buflen, &rh); #else rh = getservbyname_r (name, proto, ret, buf, buflen); --- 239,245 ---- struct servent *rh; int ri; ! #if defined(__linux__) || defined(__GLIBC__) || defined(__rtems__) (void) getservbyname_r (name, proto, ret, buf, buflen, &rh); #else rh = getservbyname_r (name, proto, ret, buf, buflen); *************** __gnat_safe_getservbyport (int port, con *** 255,261 **** struct servent *rh; int ri; ! #ifdef __linux__ (void) getservbyport_r (port, proto, ret, buf, buflen, &rh); #else rh = getservbyport_r (port, proto, ret, buf, buflen); --- 255,261 ---- struct servent *rh; int ri; ! #if defined(__linux__) || defined(__GLIBC__) || defined(__rtems__) (void) getservbyport_r (port, proto, ret, buf, buflen, &rh); #else rh = getservbyport_r (port, proto, ret, buf, buflen); *************** __gnat_new_socket_set (fd_set *set) *** 340,346 **** --- 340,351 ---- { fd_set *new; + #ifdef VMS + extern void *__gnat_malloc32 (__SIZE_TYPE__); + new = (fd_set *) __gnat_malloc32 (sizeof (fd_set)); + #else new = (fd_set *) __gnat_malloc (sizeof (fd_set)); + #endif if (set) memcpy (new, set, sizeof (fd_set)); *************** __gnat_get_h_errno (void) { *** 411,414 **** return h_errno; #endif } ! #endif /* __nucleus__ */ --- 416,422 ---- return h_errno; #endif } ! ! #else ! #warning Sockets are not supported on this platform ! #endif /* defined(HAVE_SOCKETS) */ diff -Nrcpad gcc-4.3.3/gcc/ada/sprint.adb gcc-4.4.0/gcc/ada/sprint.adb *** gcc-4.3.3/gcc/ada/sprint.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/sprint.adb Mon Aug 4 15:33:55 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Nlists; use Nlists; *** 35,40 **** --- 35,41 ---- with Opt; use Opt; with Output; use Output; with Rtsfind; use Rtsfind; + with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; with Sinput.D; use Sinput.D; *************** package body Sprint is *** 229,235 **** -- then output all source lines up to this matching line. procedure Write_Discr_Specs (N : Node_Id); ! -- Ouput discriminant specification for node, which is any of the type -- declarations that can have discriminants. procedure Write_Ekind (E : Entity_Id); --- 230,236 ---- -- then output all source lines up to this matching line. procedure Write_Discr_Specs (N : Node_Id); ! -- Output discriminant specification for node, which is any of the type -- declarations that can have discriminants. procedure Write_Ekind (E : Entity_Id); *************** package body Sprint is *** 268,274 **** function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean; -- Like Write_Indent_Identifiers except that in Debug_Generated_Code ! -- mode, the Sloc of the current debug node is set to point ot the -- first output identifier. procedure Write_Indent_Str (S : String); --- 269,275 ---- function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean; -- Like Write_Indent_Identifiers except that in Debug_Generated_Code ! -- mode, the Sloc of the current debug node is set to point to the -- first output identifier. procedure Write_Indent_Str (S : String); *************** package body Sprint is *** 327,333 **** -- initial Write_Indent (to get new line) if current line is too full. procedure Write_Str_With_Col_Check_Sloc (S : String); ! -- Like Write_Str_WIth_Col_Check, but sets debug Sloc of current debug -- node to first non-blank character if a current debug node is active. procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format); --- 328,334 ---- -- initial Write_Indent (to get new line) if current line is too full. procedure Write_Str_With_Col_Check_Sloc (S : String); ! -- Like Write_Str_With_Col_Check, but sets debug Sloc of current debug -- node to first non-blank character if a current debug node is active. procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format); *************** package body Sprint is *** 1040,1046 **** Indent_End; -- Note: let the printing of Abortable_Part handle outputting ! -- the ABORT keyword, so that the Slco can be set correctly. Write_Indent_Str ("then "); Sprint_Node (Abortable_Part (Node)); --- 1041,1047 ---- Indent_End; -- Note: let the printing of Abortable_Part handle outputting ! -- the ABORT keyword, so that the Sloc can be set correctly. Write_Indent_Str ("then "); Sprint_Node (Abortable_Part (Node)); *************** package body Sprint is *** 1331,1336 **** --- 1332,1338 ---- Sprint_Node (Subtype_Indication (Node)); if Present (Interface_List (Node)) then + Write_Str_With_Col_Check (" and "); Sprint_And_List (Interface_List (Node)); Write_Str_With_Col_Check (" with "); end if; *************** package body Sprint is *** 1575,1580 **** --- 1577,1587 ---- Write_Str_With_Col_Check_Sloc ("new "); Sprint_Node (Subtype_Mark (Node)); + if Present (Interface_List (Node)) then + Write_Str_With_Col_Check (" and "); + Sprint_And_List (Interface_List (Node)); + end if; + if Private_Present (Node) then Write_Str_With_Col_Check (" with private"); end if; *************** package body Sprint is *** 2327,2336 **** Write_Str_With_Col_Check ("out "); end if; ! -- Ada 2005 (AI-231) parameter specification may carry ! -- null exclusion. Do not print it now if this is an ! -- access parameter, it is emitted when the access ! -- definition is displayed. if Null_Exclusion_Present (Node) and then Nkind (Parameter_Type (Node)) --- 2334,2342 ---- Write_Str_With_Col_Check ("out "); end if; ! -- Ada 2005 (AI-231): Parameter specification may carry null ! -- exclusion. Do not print it now if this is an access formal, ! -- it is emitted when the access definition is displayed. if Null_Exclusion_Present (Node) and then Nkind (Parameter_Type (Node)) *************** package body Sprint is *** 2387,2393 **** when N_Pragma => Write_Indent_Str_Sloc ("pragma "); ! Write_Name_With_Col_Check (Chars (Node)); if Present (Pragma_Argument_Associations (Node)) then Sprint_Opt_Paren_Comma_List --- 2393,2399 ---- when N_Pragma => Write_Indent_Str_Sloc ("pragma "); ! Write_Name_With_Col_Check (Pragma_Name (Node)); if Present (Pragma_Argument_Associations (Node)) then Sprint_Opt_Paren_Comma_List *************** package body Sprint is *** 2440,2445 **** --- 2446,2457 ---- Write_Str_With_Col_Check (" is new "); Sprint_Node (Subtype_Indication (Node)); + + if Present (Interface_List (Node)) then + Write_Str_With_Col_Check (" and "); + Sprint_And_List (Interface_List (Node)); + end if; + Write_Str_With_Col_Check (" with private;"); when N_Procedure_Call_Statement => *************** package body Sprint is *** 3664,3673 **** Write_Char (' '); end loop; ! -- If we have a constructed declaration, print it ! ! if Present (P) and then Nkind (P) in N_Declaration then -- We must set Itype_Printed true before the recursive call to -- print the node, otherwise we get an infinite recursion! --- 3676,3687 ---- Write_Char (' '); end loop; ! -- If we have a constructed declaration for the itype, print it + if Present (P) + and then Nkind (P) in N_Declaration + and then Defining_Entity (P) = Typ + then -- We must set Itype_Printed true before the recursive call to -- print the node, otherwise we get an infinite recursion! *************** package body Sprint is *** 3728,3734 **** end loop; Write_Str (") of "); ! Sprint_Node (Component_Type (Typ)); -- Array subtypes and string subtypes --- 3742,3755 ---- end loop; Write_Str (") of "); ! X := Component_Type (Typ); ! ! -- Preserve sloc of component type, which is defined ! -- elsewhere than the itype (see comment above). ! ! Old_Sloc := Sloc (X); ! Sprint_Node (X); ! Set_Sloc (X, Old_Sloc); -- Array subtypes and string subtypes diff -Nrcpad gcc-4.3.3/gcc/ada/stand.adb gcc-4.4.0/gcc/ada/stand.adb *** gcc-4.3.3/gcc/ada/stand.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/stand.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992,1993,1994,1995 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992,1993,1994,1995,2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/stand.ads gcc-4.4.0/gcc/ada/stand.ads *** gcc-4.3.3/gcc/ada/stand.ads Fri Aug 31 10:25:05 2007 --- gcc-4.4.0/gcc/ada/stand.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Stand is *** 54,69 **** S_Standard, S_ASCII, ! -- Types defined in package Standard S_Boolean, - S_Character, - S_Wide_Character, - S_Wide_Wide_Character, - S_String, - S_Wide_String, - S_Wide_Wide_String, - S_Duration, S_Short_Short_Integer, S_Short_Integer, --- 52,62 ---- S_Standard, S_ASCII, ! -- Types and subtypes defined in package Standard (in the order in which ! -- they appear in the RM, so that the declarations are in the right ! -- order for the purposes of ASIS traversals S_Boolean, S_Short_Short_Integer, S_Short_Integer, *************** package Stand is *** 71,91 **** S_Long_Integer, S_Long_Long_Integer, S_Short_Float, S_Float, S_Long_Float, S_Long_Long_Float, -- Enumeration literals for type Boolean S_False, S_True, - -- Subtypes declared in package Standard - - S_Natural, - S_Positive, - -- Exceptions declared in package Standard S_Constraint_Error, --- 64,92 ---- S_Long_Integer, S_Long_Long_Integer, + S_Natural, + S_Positive, + S_Short_Float, S_Float, S_Long_Float, S_Long_Long_Float, + S_Character, + S_Wide_Character, + S_Wide_Wide_Character, + + S_String, + S_Wide_String, + S_Wide_Wide_String, + + S_Duration, + -- Enumeration literals for type Boolean S_False, S_True, -- Exceptions declared in package Standard S_Constraint_Error, *************** package Stand is *** 218,224 **** S_DEL); -- 16#7F# subtype S_Types is ! Standard_Entity_Type range S_Boolean .. S_Long_Long_Float; subtype S_Exceptions is Standard_Entity_Type range S_Constraint_Error .. S_Tasking_Error; --- 219,225 ---- S_DEL); -- 16#7F# subtype S_Types is ! Standard_Entity_Type range S_Boolean .. S_Duration; subtype S_Exceptions is Standard_Entity_Type range S_Constraint_Error .. S_Tasking_Error; *************** package Stand is *** 361,367 **** Any_Type : Entity_Id; -- Used to represent some unknown type. Plays an important role in ! -- avoiding cascaded errors, since any node that remains labaled with -- this type corresponds to an already issued error message. Any_Type -- is propagated to avoid cascaded errors from a single type error. --- 362,368 ---- Any_Type : Entity_Id; -- Used to represent some unknown type. Plays an important role in ! -- avoiding cascaded errors, since any node that remains labeled with -- this type corresponds to an already issued error message. Any_Type -- is propagated to avoid cascaded errors from a single type error. diff -Nrcpad gcc-4.3.3/gcc/ada/stringt.adb gcc-4.4.0/gcc/ada/stringt.adb *** gcc-4.3.3/gcc/ada/stringt.adb Fri Aug 31 10:23:37 2007 --- gcc-4.4.0/gcc/ada/stringt.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Stringt is *** 428,436 **** for J in 1 .. String_Length (Id) loop C := Get_String_Char (Id, J); ! if Character'Val (C) = '"' then Write_Str (""""""); - else Write_Char_Code (C); end if; --- 426,433 ---- for J in 1 .. String_Length (Id) loop C := Get_String_Char (Id, J); ! if C = Character'Pos ('"') then Write_Str (""""""); else Write_Char_Code (C); end if; diff -Nrcpad gcc-4.3.3/gcc/ada/stringt.ads gcc-4.4.0/gcc/ada/stringt.ads *** gcc-4.3.3/gcc/ada/stringt.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/stringt.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Stringt is *** 75,81 **** -- new string is initialized to be a copy of the given string. A test is -- made to see if S is the last created string, and if so it is shared, -- rather than copied, this can be particularly helpful for the case of ! -- a continued concatenaion of string constants. procedure Store_String_Char (C : Char_Code); procedure Store_String_Char (C : Character); --- 73,79 ---- -- new string is initialized to be a copy of the given string. A test is -- made to see if S is the last created string, and if so it is shared, -- rather than copied, this can be particularly helpful for the case of ! -- a continued concatenation of string constants. procedure Store_String_Char (C : Char_Code); procedure Store_String_Char (C : Character); diff -Nrcpad gcc-4.3.3/gcc/ada/style.ads gcc-4.4.0/gcc/ada/style.ads *** gcc-4.3.3/gcc/ada/style.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/style.ads Wed Aug 20 15:43:11 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Style is *** 187,192 **** --- 187,197 ---- -- Called after scanning a conditional expression that has at least one -- level of parentheses around the entire expression. + procedure Missing_Overriding (N : Node_Id; E : Entity_Id) + renames Style_C_Inst.Missing_Overriding; + -- Called where N is the declaration or body of an overriding operation of + -- a tagged type, and does not have an overriding_indicator. + function Mode_In_Check return Boolean renames Style_Inst.Mode_In_Check; -- Determines whether style checking is active and the Mode_In_Check is diff -Nrcpad gcc-4.3.3/gcc/ada/styleg-c.adb gcc-4.4.0/gcc/ada/styleg-c.adb *** gcc-4.3.3/gcc/ada/styleg-c.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/styleg-c.adb Wed Aug 20 15:43:11 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Styleg.C is *** 175,182 **** -- Case of definition in package Standard ! elsif Sdef = Standard_Location then ! -- Check case of identifiers in Standard if Style_Check_Standard then --- 175,184 ---- -- Case of definition in package Standard ! elsif Sdef = Standard_Location ! or else ! Sdef = Standard_ASCII_Location ! then -- Check case of identifiers in Standard if Style_Check_Standard then *************** package body Styleg.C is *** 190,208 **** -- Otherwise determine required casing of Standard entity else ! -- ASCII entities are in all upper case if Entity (Ref) = Standard_ASCII then Cas := All_Upper_Case; -- Special names in ASCII are also all upper case ! elsif Entity (Ref) in SE (S_LC_A) .. SE (S_LC_Z) ! or else ! Entity (Ref) in SE (S_NUL) .. SE (S_US) ! or else ! Entity (Ref) = SE (S_DEL) ! then Cas := All_Upper_Case; -- All other entities are in mixed case --- 192,205 ---- -- Otherwise determine required casing of Standard entity else ! -- ASCII is all upper case if Entity (Ref) = Standard_ASCII then Cas := All_Upper_Case; -- Special names in ASCII are also all upper case ! elsif Sdef = Standard_ASCII_Location then Cas := All_Upper_Case; -- All other entities are in mixed case *************** package body Styleg.C is *** 233,238 **** --- 230,252 ---- end if; end Check_Identifier; + ------------------------ + -- Missing_Overriding -- + ------------------------ + + procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is + begin + if Style_Check_Missing_Overriding and then Comes_From_Source (N) then + if Nkind (N) = N_Subprogram_Body then + Error_Msg_N + ("(style) missing OVERRIDING indicator in body of&", E); + else + Error_Msg_N + ("(style) missing OVERRIDING indicator in declaration of&", E); + end if; + end if; + end Missing_Overriding; + ----------------------------------- -- Subprogram_Not_In_Alpha_Order -- ----------------------------------- diff -Nrcpad gcc-4.3.3/gcc/ada/styleg-c.ads gcc-4.4.0/gcc/ada/styleg-c.ads *** gcc-4.3.3/gcc/ada/styleg-c.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/styleg-c.ads Wed Aug 20 15:43:11 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Styleg.C is *** 53,58 **** --- 53,62 ---- -- spelling is to be checked against the Chars spelling in identifier node -- Def (which may be either an N_Identifier, or N_Defining_Identifier node) + procedure Missing_Overriding (N : Node_Id; E : Entity_Id); + -- Called where N is the declaration or body of an overriding operation, + -- and the node does not have an overriding_indicator. + procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id); -- Called if Name is the name of a subprogram body in a package body -- that is not in alphabetical order. diff -Nrcpad gcc-4.3.3/gcc/ada/styleg.adb gcc-4.4.0/gcc/ada/styleg.adb *** gcc-4.3.3/gcc/ada/styleg.adb Thu Dec 13 10:36:06 2007 --- gcc-4.4.0/gcc/ada/styleg.adb Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Styleg is *** 238,244 **** -- 1. Any comment that is not at the start of a line, i.e. where the -- initial minuses are not the first non-blank characters on the ! -- line must have at least one blank after the second minus. -- 2. A row of all minuses of any length is permitted (see procedure -- box above in the source of this routine). --- 238,245 ---- -- 1. Any comment that is not at the start of a line, i.e. where the -- initial minuses are not the first non-blank characters on the ! -- line must have at least one blank after the second minus or a ! -- special character as defined in rule 5. -- 2. A row of all minuses of any length is permitted (see procedure -- box above in the source of this routine). *************** package body Styleg is *** 274,281 **** -- Returns True if the last two characters on the line are -- which -- characterizes a box comment (as for example follows this spec). function Same_Column_As_Next_Non_Blank_Line return Boolean; ! -- Called for a full line comment. If the indentation of this commment -- matches that of the next non-blank line in the source, then True is -- returned, otherwise False. --- 275,285 ---- -- Returns True if the last two characters on the line are -- which -- characterizes a box comment (as for example follows this spec). + function Is_Special_Character (C : Character) return Boolean; + -- Determines if C is a special character (see rule 5 above) + function Same_Column_As_Next_Non_Blank_Line return Boolean; ! -- Called for a full line comment. If the indentation of this comment -- matches that of the next non-blank line in the source, then True is -- returned, otherwise False. *************** package body Styleg is *** 297,302 **** --- 301,322 ---- return Source (S - 1) = '-' and then Source (S - 2) = '-'; end Is_Box_Comment; + -------------------------- + -- Is_Special_Character -- + -------------------------- + + function Is_Special_Character (C : Character) return Boolean is + begin + if GNAT_Mode then + return C = '!'; + else + return + Character'Pos (C) in 16#21# .. 16#2F# + or else + Character'Pos (C) in 16#3A# .. 16#3F#; + end if; + end Is_Special_Character; + ---------------------------------------- -- Same_Column_As_Next_Non_Blank_Line -- ---------------------------------------- *************** package body Styleg is *** 338,348 **** -- For a comment that is not at the start of the line, the only -- requirement is that we cannot have a non-blank character after ! -- the second minus sign. if Scan_Ptr /= First_Non_Blank_Location then if Style_Check_Comments then ! if Source (Scan_Ptr + 2) > ' ' then Error_Msg ("(style) space required", Scan_Ptr + 2); end if; end if; --- 358,370 ---- -- For a comment that is not at the start of the line, the only -- requirement is that we cannot have a non-blank character after ! -- the second minus sign or a special character. if Scan_Ptr /= First_Non_Blank_Location then if Style_Check_Comments then ! if Source (Scan_Ptr + 2) > ' ' ! and then not Is_Special_Character (Source (Scan_Ptr + 2)) ! then Error_Msg ("(style) space required", Scan_Ptr + 2); end if; end if; *************** package body Styleg is *** 386,403 **** -- This is not permitted in internal GNAT implementation units -- except for the case of --! as used by gnatprep output. ! if GNAT_Mode then ! if C = '!' then ! return; ! end if; ! ! else ! if Character'Pos (C) in 16#21# .. 16#2F# ! or else ! Character'Pos (C) in 16#3A# .. 16#3F# ! then ! return; ! end if; end if; -- The only other case in which we allow a character after --- 408,415 ---- -- This is not permitted in internal GNAT implementation units -- except for the case of --! as used by gnatprep output. ! if Is_Special_Character (C) then ! return; end if; -- The only other case in which we allow a character after *************** package body Styleg is *** 505,511 **** -- In check indentation mode (-gnatyn for n a digit), a new statement or -- declaration is required to start in a column that is a multiple of the ! -- indentiation amount. procedure Check_Indentation is begin --- 517,523 ---- -- In check indentation mode (-gnatyn for n a digit), a new statement or -- declaration is required to start in a column that is a multiple of the ! -- indentation amount. procedure Check_Indentation is begin *************** package body Styleg is *** 841,847 **** -- Check_Unary_Plus_Or_Minus -- ------------------------------- ! -- In check tokem mode (-gnatyt), unary plus or minus must not be -- followed by a space. procedure Check_Unary_Plus_Or_Minus is --- 853,859 ---- -- Check_Unary_Plus_Or_Minus -- ------------------------------- ! -- In check token mode (-gnatyt), unary plus or minus must not be -- followed by a space. procedure Check_Unary_Plus_Or_Minus is *************** package body Styleg is *** 955,961 **** -- Non_Lower_Case_Keyword -- ---------------------------- ! -- In check casing mode (-gnatyk), reserved keywords must be be spelled -- in all lower case (excluding keywords range, access, delta and digits -- used as attribute designators). --- 967,973 ---- -- Non_Lower_Case_Keyword -- ---------------------------- ! -- In check casing mode (-gnatyk), reserved keywords must be spelled -- in all lower case (excluding keywords range, access, delta and digits -- used as attribute designators). diff -Nrcpad gcc-4.3.3/gcc/ada/styleg.ads gcc-4.4.0/gcc/ada/styleg.ads *** gcc-4.3.3/gcc/ada/styleg.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/styleg.ads Sun Apr 13 18:03:09 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Styleg is *** 136,142 **** pragma Inline (Check_Separate_Stmt_Lines); -- Called after scanning THEN (not preceded by AND) or ELSE (not preceded -- by OR). Used to check that no tokens follow on the same line (which ! -- would intefere with coverage testing). Handles case of THEN ABORT as -- an exception, as well as PRAGMA after ELSE. procedure Check_Unary_Plus_Or_Minus; --- 136,142 ---- pragma Inline (Check_Separate_Stmt_Lines); -- Called after scanning THEN (not preceded by AND) or ELSE (not preceded -- by OR). Used to check that no tokens follow on the same line (which ! -- would interfere with coverage testing). Handles case of THEN ABORT as -- an exception, as well as PRAGMA after ELSE. procedure Check_Unary_Plus_Or_Minus; diff -Nrcpad gcc-4.3.3/gcc/ada/stylesw.adb gcc-4.4.0/gcc/ada/stylesw.adb *** gcc-4.3.3/gcc/ada/stylesw.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/stylesw.adb Wed Aug 20 15:43:11 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Stylesw is *** 49,54 **** --- 49,55 ---- Style_Check_Layout := False; Style_Check_Max_Line_Length := False; Style_Check_Max_Nesting_Level := False; + Style_Check_Missing_Overriding := False; Style_Check_Mode_In := False; Style_Check_Order_Subprograms := False; Style_Check_Pragma_Casing := False; *************** package body Stylesw is *** 123,128 **** --- 124,130 ---- Add ('l', Style_Check_Layout); Add ('n', Style_Check_Standard); Add ('o', Style_Check_Order_Subprograms); + Add ('O', Style_Check_Missing_Overriding); Add ('p', Style_Check_Pragma_Casing); Add ('r', Style_Check_References); Add ('s', Style_Check_Specs); *************** package body Stylesw is *** 168,174 **** procedure Set_GNAT_Style_Check_Options is begin Reset_Style_Check_Options; ! Set_Style_Check_Options ("3aAbcdefhiklmnprsStux"); end Set_GNAT_Style_Check_Options; ----------------------------- --- 170,176 ---- procedure Set_GNAT_Style_Check_Options is begin Reset_Style_Check_Options; ! Set_Style_Check_Options ("3aAbcdefhiIklmnprsStux"); end Set_GNAT_Style_Check_Options; ----------------------------- *************** package body Stylesw is *** 195,205 **** is C : Character; procedure Add_Img (N : Natural); -- Concatenates image of N at end of Style_Msg_Buf procedure Bad_Style_Switch (Msg : String); ! -- Called if bad style switch found. Msg is mset in Style_Msg_Buf and -- Style_Msg_Len. OK is set False. ------------- --- 197,214 ---- is C : Character; + On : Boolean := True; + -- Set to False if minus encountered + -- Set to True if plus encountered + + Last_Option : Character := ' '; + -- Set to last character encountered + procedure Add_Img (N : Natural); -- Concatenates image of N at end of Style_Msg_Buf procedure Bad_Style_Switch (Msg : String); ! -- Called if bad style switch found. Msg is set in Style_Msg_Buf and -- Style_Msg_Len. OK is set False. ------------- *************** package body Stylesw is *** 234,243 **** Err_Col := Options'First; while Err_Col <= Options'Last loop C := Options (Err_Col); Err_Col := Err_Col + 1; ! case C is ! when '1' .. '9' => Style_Check_Indentation := Character'Pos (C) - Character'Pos ('0'); --- 243,263 ---- Err_Col := Options'First; while Err_Col <= Options'Last loop C := Options (Err_Col); + Last_Option := C; Err_Col := Err_Col + 1; ! -- Turning switches on ! ! if On then ! case C is ! ! when '+' => ! null; ! ! when '-' => ! On := False; ! ! when '0' .. '9' => Style_Check_Indentation := Character'Pos (C) - Character'Pos ('0'); *************** package body Stylesw is *** 352,357 **** --- 372,380 ---- when 'o' => Style_Check_Order_Subprograms := True; + when 'O' => + Style_Check_Missing_Overriding := True; + when 'p' => Style_Check_Pragma_Casing := True; *************** package body Stylesw is *** 373,392 **** when 'x' => Style_Check_Xtra_Parens := True; when ' ' => null; when others => Err_Col := Err_Col - 1; ! Style_Msg_Buf (1 .. 22) := "invalid style switch: "; ! Style_Msg_Len := 23; ! Style_Msg_Buf (Style_Msg_Len) := C; ! OK := False; return; ! end case; end loop; ! Style_Check := True; OK := True; end Set_Style_Check_Options; end Stylesw; --- 396,517 ---- when 'x' => Style_Check_Xtra_Parens := True; + when 'y' => + Set_Default_Style_Check_Options; + when ' ' => null; when others => Err_Col := Err_Col - 1; ! Bad_Style_Switch ("invalid style switch: " & C); return; ! end case; ! ! -- Turning switches off ! ! else ! case C is ! ! when '+' => ! On := True; ! ! when '-' => ! null; ! ! when '0' .. '9' => ! Style_Check_Indentation := 0; ! ! when 'a' => ! Style_Check_Attribute_Casing := False; ! ! when 'A' => ! Style_Check_Array_Attribute_Index := False; ! ! when 'b' => ! Style_Check_Blanks_At_End := False; ! ! when 'c' => ! Style_Check_Comments := False; ! ! when 'd' => ! Style_Check_DOS_Line_Terminator := False; ! ! when 'e' => ! Style_Check_End_Labels := False; ! ! when 'f' => ! Style_Check_Form_Feeds := False; ! ! when 'g' => ! Reset_Style_Check_Options; ! ! when 'h' => ! Style_Check_Horizontal_Tabs := False; ! ! when 'i' => ! Style_Check_If_Then_Layout := False; ! ! when 'I' => ! Style_Check_Mode_In := False; ! ! when 'k' => ! Style_Check_Keyword_Casing := False; ! ! when 'l' => ! Style_Check_Layout := False; ! ! when 'L' => ! Style_Max_Nesting_Level := 0; ! ! when 'm' => ! Style_Check_Max_Line_Length := False; ! ! when 'M' => ! Style_Max_Line_Length := 0; ! Style_Check_Max_Line_Length := False; ! ! when 'n' => ! Style_Check_Standard := False; ! ! when 'o' => ! Style_Check_Order_Subprograms := False; ! ! when 'p' => ! Style_Check_Pragma_Casing := False; ! ! when 'r' => ! Style_Check_References := False; ! ! when 's' => ! Style_Check_Specs := False; ! ! when 'S' => ! Style_Check_Separate_Stmt_Lines := False; ! ! when 't' => ! Style_Check_Tokens := False; ! ! when 'u' => ! Style_Check_Blank_Lines := False; ! ! when 'x' => ! Style_Check_Xtra_Parens := False; ! ! when ' ' => ! null; ! ! when others => ! Err_Col := Err_Col - 1; ! Bad_Style_Switch ("invalid style switch: " & C); ! return; ! end case; ! end if; end loop; ! -- Turn on style checking if other than N at end of string ! ! Style_Check := (Last_Option /= 'N'); OK := True; end Set_Style_Check_Options; end Stylesw; diff -Nrcpad gcc-4.3.3/gcc/ada/stylesw.ads gcc-4.4.0/gcc/ada/stylesw.ads *** gcc-4.3.3/gcc/ada/stylesw.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/stylesw.ads Wed Aug 20 15:51:15 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Stylesw is *** 77,83 **** -- For a comment that is not at the start of a line, the only requirement -- is that a space follow the comment characters. -- ! -- For a coment that is at the start of the line, one of the following -- conditions must hold: -- -- The comment characters are the only non-blank characters on the line --- 77,83 ---- -- For a comment that is not at the start of a line, the only requirement -- is that a space follow the comment characters. -- ! -- For a comment that is at the start of the line, one of the following -- conditions must hold: -- -- The comment characters are the only non-blank characters on the line *************** package Stylesw is *** 142,148 **** -- indicated indentation value. A value of zero turns off checking. The -- requirement is that any new statement, line comment, declaration or -- keyword such as END, start on a column that is a multiple of the ! -- indentiation value. Style_Check_Keyword_Casing : Boolean := False; -- This can be set True by using the -gnatg or -gnatyk switches. If it is --- 142,148 ---- -- indicated indentation value. A value of zero turns off checking. The -- requirement is that any new statement, line comment, declaration or -- keyword such as END, start on a column that is a multiple of the ! -- indentation value. Style_Check_Keyword_Casing : Boolean := False; -- This can be set True by using the -gnatg or -gnatyk switches. If it is *************** package Stylesw is *** 156,163 **** -- with the IF keyword. Style_Check_Max_Line_Length : Boolean := False; ! -- This can be set True by using the -gnatg or -gnatym/M switches. If ! -- it is True, it activates checking for a maximum line length of -- Style_Max_Line_Length characters. Style_Check_Max_Nesting_Level : Boolean := False; --- 156,163 ---- -- with the IF keyword. Style_Check_Max_Line_Length : Boolean := False; ! -- This can be set True by using the -gnatg or -gnatym/M switches. ! -- If it is True, it activates checking for a maximum line length of -- Style_Max_Line_Length characters. Style_Check_Max_Nesting_Level : Boolean := False; *************** package Stylesw is *** 165,170 **** --- 165,175 ---- -- (a value of zero resets it to False). If True, it activates checking -- the maximum nesting level against Style_Max_Nesting_Level. + Style_Check_Missing_Overriding : Boolean := False; + -- This can be set True by using the -gnatyO switch. If it is True, then + -- "[not] overriding" is required in subprogram declarations and bodies + -- where appropriate. + Style_Check_Mode_In : Boolean := False; -- This can be set True by using -gnatyI. If True, it activates checking -- that mode IN is not used on its own (since it is the default). *************** package Stylesw is *** 269,275 **** procedure Set_Default_Style_Check_Options; -- This procedure is called to set the default style checking options in ! -- response to a -gnaty switch with no suboptions. procedure Set_GNAT_Style_Check_Options; -- This procedure is called to set the default style checking options for --- 274,280 ---- procedure Set_Default_Style_Check_Options; -- This procedure is called to set the default style checking options in ! -- response to a -gnaty switch with no suboptions or from -gnatyy. procedure Set_GNAT_Style_Check_Options; -- This procedure is called to set the default style checking options for *************** package Stylesw is *** 286,292 **** -- This procedure is called to set the style check options that correspond -- to the characters in the given Options string. If all options are valid, -- they are set in an additive manner: any previous options are retained ! -- unless overridden. -- -- If all options given are valid, then OK is True, Err_Col is set to -- Options'Last + 1, and Style_Msg_Buf/Style_Msg_Len are unchanged. --- 291,298 ---- -- This procedure is called to set the style check options that correspond -- to the characters in the given Options string. If all options are valid, -- they are set in an additive manner: any previous options are retained ! -- unless overridden, unless a minus is encountered, and then subsequent ! -- style switches are subtracted from the current set. -- -- If all options given are valid, then OK is True, Err_Col is set to -- Options'Last + 1, and Style_Msg_Buf/Style_Msg_Len are unchanged. *************** package Stylesw is *** 298,304 **** procedure Set_Style_Check_Options (Options : String); -- Like the above procedure, but used when the Options string is known to ! -- be valid. This is for example appopriate for calls where the string == -- was obtained by Save_Style_Check_Options. procedure Reset_Style_Check_Options; --- 304,310 ---- procedure Set_Style_Check_Options (Options : String); -- Like the above procedure, but used when the Options string is known to ! -- be valid. This is for example appropriate for calls where the string == -- was obtained by Save_Style_Check_Options. procedure Reset_Style_Check_Options; diff -Nrcpad gcc-4.3.3/gcc/ada/switch-c.adb gcc-4.4.0/gcc/ada/switch-c.adb *** gcc-4.3.3/gcc/ada/switch-c.adb Sat Nov 15 16:15:00 2008 --- gcc-4.4.0/gcc/ada/switch-c.adb Fri Nov 7 10:46:18 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package body Switch.C is *** 212,217 **** --- 212,223 ---- Ptr := Ptr + 1; Brief_Output := True; + -- Processing for B switch + + when 'B' => + Ptr := Ptr + 1; + Assume_No_Invalid_Values := True; + -- Processing for c switch when 'c' => *************** package body Switch.C is *** 376,381 **** --- 382,397 ---- Full_Path_Name_For_Brief_Errors := True; return; + -- -gnateG (save preprocessor output) + + when 'G' => + if Ptr < Max then + Bad_Switch (Switch_Chars); + end if; + + Generate_Processed_File := True; + Ptr := Ptr + 1; + -- -gnateI (index of unit in multi-unit source) when 'I' => *************** package body Switch.C is *** 665,677 **** Ptr := Ptr + 1; Try_Semantics := True; ! -- Processing for q switch when 'Q' => Ptr := Ptr + 1; Force_ALI_Tree_File := True; Try_Semantics := True; -- Processing for R switch when 'R' => --- 681,699 ---- Ptr := Ptr + 1; Try_Semantics := True; ! -- Processing for Q switch when 'Q' => Ptr := Ptr + 1; Force_ALI_Tree_File := True; Try_Semantics := True; + -- Processing for r switch + + when 'r' => + Ptr := Ptr + 1; + Treat_Restrictions_As_Warnings := True; + -- Processing for R switch when 'R' => diff -Nrcpad gcc-4.3.3/gcc/ada/switch-m.adb gcc-4.4.0/gcc/ada/switch-m.adb *** gcc-4.3.3/gcc/ada/switch-m.adb Thu Dec 13 10:28:39 2007 --- gcc-4.4.0/gcc/ada/switch-m.adb Mon Aug 4 09:17:44 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** *** 26,31 **** --- 26,32 ---- with Debug; use Debug; with Osint; use Osint; with Opt; use Opt; + with Prj; use Prj; with Prj.Ext; use Prj.Ext; with Table; *************** package body Switch.M is *** 150,169 **** when False => -- All switches that don't start with -gnat stay as is, ! -- except -v, -E and -pg ! if Switch_Chars = "-pg" then -- The gcc driver converts -pg to -p, so that is what -- is stored in the ALI file. Add_Switch_Component ("-p"); ! -- Do not take into account switches that are not transmitted ! -- to gnat1 by the gcc driver. ! elsif C /= 'v' and then C /= 'E' then Add_Switch_Component (Switch_Chars); end if; return; --- 151,209 ---- when False => -- All switches that don't start with -gnat stay as is, ! -- except -pg, -Wall, -k8, -w ! if Switch_Chars = "-pg" or else Switch_Chars = "-p" then -- The gcc driver converts -pg to -p, so that is what -- is stored in the ALI file. Add_Switch_Component ("-p"); ! elsif Switch_Chars = "-Wall" then ! -- The gcc driver adds -gnatwa when -Wall is used ! ! Add_Switch_Component ("-gnatwa"); ! Add_Switch_Component ("-Wall"); ! ! elsif Switch_Chars = "-k8" then ! ! -- The gcc driver transforms -k8 into -gnatk8 ! ! Add_Switch_Component ("-gnatk8"); ! ! elsif Switch_Chars = "-w" then ! ! -- The gcc driver adds -gnatws when -w is used ! ! Add_Switch_Component ("-gnatws"); ! Add_Switch_Component ("-w"); ! ! elsif Switch_Chars'Length > 6 ! and then ! Switch_Chars (Switch_Chars'First .. Switch_Chars'First + 5) ! = "--RTS=" ! then Add_Switch_Component (Switch_Chars); + + -- When --RTS=mtp is used, the gcc driver adds -mrtp + + if Switch_Chars = "--RTS=mtp" then + Add_Switch_Component ("-mrtp"); + end if; + + -- Take only into account switches that are transmitted to + -- gnat1 by the gcc driver and stored by gnat1 in the ALI file. + + else + case C is + when 'O' | 'W' | 'w' | 'f' | 'd' | 'g' | 'm' => + Add_Switch_Component (Switch_Chars); + + when others => + null; + end case; end if; return; *************** package body Switch.M is *** 227,240 **** when 'e' => ! -- Only -gnateD and -gnatep= need storing in ALI file Storing (First_Stored) := 'e'; Ptr := Ptr + 1; if Ptr > Max or else (Switch_Chars (Ptr) /= 'D' ! and then Switch_Chars (Ptr) /= 'p') then Last := 0; return; --- 267,282 ---- when 'e' => ! -- Store -gnateD, -gnatep= and -gnateG in the ALI file. ! -- The other -gnate switches do not need to be stored. Storing (First_Stored) := 'e'; Ptr := Ptr + 1; if Ptr > Max or else (Switch_Chars (Ptr) /= 'D' ! and then Switch_Chars (Ptr) /= 'G' ! and then Switch_Chars (Ptr) /= 'p') then Last := 0; return; *************** package body Switch.M is *** 252,258 **** -- Processing for -gnatep= ! else Ptr := Ptr + 1; if Ptr = Max then --- 294,300 ---- -- Processing for -gnatep= ! elsif Switch_Chars (Ptr) = 'p' then Ptr := Ptr + 1; if Ptr = Max then *************** package body Switch.M is *** 276,281 **** --- 318,326 ---- Switch_Chars (Ptr .. Max); Add_Switch_Component (To_Store); end; + + elsif Switch_Chars (Ptr) = 'G' then + Add_Switch_Component ("-gnateG"); end if; return; *************** package body Switch.M is *** 332,338 **** Ptr := Ptr + 1; if Ptr <= Max ! and then Switch_Chars (Ptr) = 's' then Last_Stored := Last_Stored + 1; Storing (Last_Stored) := 's'; Ptr := Ptr + 1; --- 377,384 ---- Ptr := Ptr + 1; if Ptr <= Max ! and then Switch_Chars (Ptr) = 's' ! then Last_Stored := Last_Stored + 1; Storing (Last_Stored) := 's'; Ptr := Ptr + 1; *************** package body Switch.M is *** 366,377 **** -- -gnatyMxxx ! if C = 'M' and then ! Storing (First_Stored) = 'y' ! then Last_Stored := First_Stored + 1; Storing (Last_Stored) := 'M'; - while Ptr <= Max loop C := Switch_Chars (Ptr); exit when C not in '0' .. '9'; --- 412,420 ---- -- -gnatyMxxx ! if C = 'M' and then Storing (First_Stored) = 'y' then Last_Stored := First_Stored + 1; Storing (Last_Stored) := 'M'; while Ptr <= Max loop C := Switch_Chars (Ptr); exit when C not in '0' .. '9'; *************** package body Switch.M is *** 517,524 **** if Switch_Chars = "--create-missing-dirs" then Setup_Projects := True; ! elsif Switch_Chars'Length > 3 and then ! Switch_Chars (Ptr .. Ptr + 1) = "aP" then Add_Search_Project_Directory (Switch_Chars (Ptr + 2 .. Switch_Chars'Last)); --- 560,583 ---- if Switch_Chars = "--create-missing-dirs" then Setup_Projects := True; ! elsif Switch_Chars'Length > Subdirs_Option'Length ! and then ! Switch_Chars ! (Switch_Chars'First .. ! Switch_Chars'First + Subdirs_Option'Length - 1) = ! Subdirs_Option ! then ! Subdirs := ! new String' ! (Switch_Chars ! (Switch_Chars'First + Subdirs_Option'Length .. ! Switch_Chars'Last)); ! ! elsif Switch_Chars (Ptr) = '-' then ! Bad_Switch (Switch_Chars); ! ! elsif Switch_Chars'Length > 3 ! and then Switch_Chars (Ptr .. Ptr + 1) = "aP" then Add_Search_Project_Directory (Switch_Chars (Ptr + 2 .. Switch_Chars'Last)); diff -Nrcpad gcc-4.3.3/gcc/ada/switch.ads gcc-4.4.0/gcc/ada/switch.ads *** gcc-4.3.3/gcc/ada/switch.ads Thu Dec 13 10:23:29 2007 --- gcc-4.4.0/gcc/ada/switch.ads Sun Apr 13 18:03:09 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** *** 24,30 **** ------------------------------------------------------------------------------ -- This package together with a child package appropriate to the client tool ! -- scans switches. Note that the body of the appropraite Usage package must be -- coordinated with the switches that are recognized by this package. These -- Usage packages also act as the official documentation for the switches -- that are recognized. In addition, package Debug documents the otherwise --- 24,30 ---- ------------------------------------------------------------------------------ -- This package together with a child package appropriate to the client tool ! -- scans switches. Note that the body of the appropriate Usage package must be -- coordinated with the switches that are recognized by this package. These -- Usage packages also act as the official documentation for the switches -- that are recognized. In addition, package Debug documents the otherwise diff -Nrcpad gcc-4.3.3/gcc/ada/sysdep.c gcc-4.4.0/gcc/ada/sysdep.c *** gcc-4.3.3/gcc/ada/sysdep.c Thu Jan 3 09:35:04 2008 --- gcc-4.4.0/gcc/ada/sysdep.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 1992-2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2009 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * *************** *** 35,43 **** --- 34,47 ---- #ifdef __vxworks #include "ioLib.h" + #include "dosFsLib.h" + #ifndef __RTP__ + # include "nfsLib.h" + #endif #include "selectLib.h" #include "vxWorks.h" #endif + #ifdef IN_RTS #define POSIX #include "tconfig.h" *************** *** 53,58 **** --- 57,63 ---- #endif #include + #include #if defined (sun) && defined (__SVR4) && !defined (__vxworks) /* The declaration is present in but conditionalized *************** __gnat_ttyname (int filedes) *** 342,348 **** || (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \ || defined (__MACHTEN__) || defined (__hpux__) || defined (_AIX) \ || (defined (__svr4__) && defined (i386)) || defined (__Lynx__) \ ! || defined (__CYGWIN__) || defined (__FreeBSD__) || defined (__OpenBSD__) #ifdef __MINGW32__ #if OLD_MINGW --- 347,354 ---- || (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \ || defined (__MACHTEN__) || defined (__hpux__) || defined (_AIX) \ || (defined (__svr4__) && defined (i386)) || defined (__Lynx__) \ ! || defined (__CYGWIN__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ ! || defined (__GLIBC__) #ifdef __MINGW32__ #if OLD_MINGW *************** getc_immediate_common (FILE *stream, *** 399,405 **** || (defined (__osf__) && ! defined (__alpha_vxworks)) \ || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ ! || defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) char c; int nread; int good_one = 0; --- 405,412 ---- || (defined (__osf__) && ! defined (__alpha_vxworks)) \ || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ ! || defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ ! || defined (__GLIBC__) char c; int nread; int good_one = 0; *************** getc_immediate_common (FILE *stream, *** 418,424 **** #if defined(linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ || defined (__osf__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ ! || defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) eof_ch = termios_rec.c_cc[VEOF]; /* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for --- 425,432 ---- #if defined(linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ || defined (__osf__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ ! || defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ ! || defined (__GLIBC__) eof_ch = termios_rec.c_cc[VEOF]; /* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for *************** get_gmtoff (void) *** 708,714 **** long __gnat_invalid_tzoff = 259273; ! /* Definition of __gnat_locatime_r used by a-calend.adb */ #if defined (__EMX__) || defined (__MINGW32__) --- 716,722 ---- long __gnat_invalid_tzoff = 259273; ! /* Definition of __gnat_localtime_r used by a-calend.adb */ #if defined (__EMX__) || defined (__MINGW32__) *************** __gnat_localtime_tzoff (const time_t *ti *** 845,851 **** /* Darwin, Free BSD, Linux, Tru64, where there exists a component tm_gmtoff in struct tm */ #elif defined (__APPLE__) || defined (__FreeBSD__) || defined (linux) ||\ ! (defined (__alpha__) && defined (__osf__)) *off = tp->tm_gmtoff; /* All other platforms: Treat all time values in GMT */ --- 853,859 ---- /* Darwin, Free BSD, Linux, Tru64, where there exists a component tm_gmtoff in struct tm */ #elif defined (__APPLE__) || defined (__FreeBSD__) || defined (linux) ||\ ! (defined (__alpha__) && defined (__osf__)) || defined (__GLIBC__) *off = tp->tm_gmtoff; /* All other platforms: Treat all time values in GMT */ *************** __gnat_get_task_options (void) *** 890,892 **** --- 898,920 ---- } #endif + + int + __gnat_is_file_not_found_error (int errno_val) { + switch (errno_val) { + case ENOENT: + #ifdef __vxworks + /* In the case of VxWorks, we also have to take into account various + * filesystem-specific variants of this error. + */ + case S_dosFsLib_FILE_NOT_FOUND: + #ifndef __RTP__ + case S_nfsLib_NFSERR_NOENT: + #endif + #endif + return 1; + + default: + return 0; + } + } diff -Nrcpad gcc-4.3.3/gcc/ada/system-aix.ads gcc-4.4.0/gcc/ada/system-aix.ads *** gcc-4.3.3/gcc/ada/system-aix.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-aix.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (AIX/PPC Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (AIX/PPC Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-darwin-ppc.ads gcc-4.4.0/gcc/ada/system-darwin-ppc.ads *** gcc-4.3.3/gcc/ada/system-darwin-ppc.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-darwin-ppc.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (Darwin/PPC Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (Darwin/PPC Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 164,170 **** Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; --- 162,168 ---- Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff -Nrcpad gcc-4.3.3/gcc/ada/system-darwin-x86.ads gcc-4.4.0/gcc/ada/system-darwin-x86.ads *** gcc-4.3.3/gcc/ada/system-darwin-x86.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-darwin-x86.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (Darwin/x86 Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (Darwin/x86 Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package System is *** 51,57 **** Max_Int : constant := Long_Long_Integer'Last; Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; ! Max_Nonbinary_Modulus : constant := Integer'Last; Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; --- 49,55 ---- Max_Int : constant := Long_Long_Integer'Last; Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; ! Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; *************** private *** 164,170 **** Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; --- 162,168 ---- Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff -Nrcpad gcc-4.3.3/gcc/ada/system-darwin-x86_64.ads gcc-4.4.0/gcc/ada/system-darwin-x86_64.ads *** gcc-4.3.3/gcc/ada/system-darwin-x86_64.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/system-darwin-x86_64.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,171 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (Darwin/x86_64 Version) -- + -- -- + -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- + -- -- + -- This specification is derived from the Ada Reference Manual for use with -- + -- GNAT. The copyright notice above, and the license provisions that follow -- + -- apply solely to the contents of the part following the private keyword. -- + -- -- + -- 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- The values defined here are derived from the following Darwin + -- sources: + -- + -- Libc/pthreads/pthread.c + -- pthread_init calls host_info to retrieve the HOST_PRIORITY_INFO. + -- This file includes "pthread_internals". + -- Libc/pthreads/pthread_internals.h + -- This file includes . + -- xnu/osfmk/mach/mach.h + -- This file includes . + -- xnu/osfmk/mach/mach_types.h + -- This file includes . + -- xnu/osfmk/mach/host_info.h + -- This file contains the definition of the host_info_t data structure + -- and the function prototype for host_info. + -- xnu/osfmk/kern/host.c + -- This file defines the function host_info which sets the + -- priority_info field of struct host_info_t. This file includes + -- . + -- xnu/osfmk/kern/processor.h + -- This file includes . + -- xnu/osfmk/kern/sched.h + -- This file defines the values for each level of priority. + + Max_Interrupt_Priority : constant Positive := 63; + Max_Priority : constant Positive := Max_Interrupt_Priority - 1; + + subtype Any_Priority is Integer range 0 .. Max_Interrupt_Priority; + subtype Priority is Any_Priority range 0 .. Max_Priority; + subtype Interrupt_Priority is Any_Priority + range Priority'Last + 1 .. Max_Interrupt_Priority; + + Default_Priority : constant Priority := + (Priority'Last - Priority'First) / 2; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + + end System; diff -Nrcpad gcc-4.3.3/gcc/ada/system-freebsd-x86.ads gcc-4.4.0/gcc/ada/system-freebsd-x86.ads *** gcc-4.3.3/gcc/ada/system-freebsd-x86.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-freebsd-x86.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (FreeBSD/x86 Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (FreeBSD/x86 Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 138,144 **** Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; --- 136,142 ---- Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff -Nrcpad gcc-4.3.3/gcc/ada/system-hpux-ia64.ads gcc-4.4.0/gcc/ada/system-hpux-ia64.ads *** gcc-4.3.3/gcc/ada/system-hpux-ia64.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-hpux-ia64.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (HP-UX/ia64 Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (HP-UX/ia64 Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-hpux.ads gcc-4.4.0/gcc/ada/system-hpux.ads *** gcc-4.3.3/gcc/ada/system-hpux.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-hpux.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (HP-UX Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (HP-UX Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-irix-n32.ads gcc-4.4.0/gcc/ada/system-irix-n32.ads *** gcc-4.3.3/gcc/ada/system-irix-n32.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-irix-n32.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (SGI Irix, n32 ABI) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (SGI Irix, n32 ABI) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-irix-n64.ads gcc-4.4.0/gcc/ada/system-irix-n64.ads *** gcc-4.3.3/gcc/ada/system-irix-n64.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/system-irix-n64.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,160 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (SGI Irix, n64 ABI) -- + -- -- + -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- + -- -- + -- This specification is derived from the Ada Reference Manual for use with -- + -- GNAT. The copyright notice above, and the license provisions that follow -- + -- apply solely to the contents of the part following the private keyword. -- + -- -- + -- 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- IRIX priorities as defined by realtime(5): + -- + -- 255 is for system-level interrupts + -- 240 - 254 are suggested for hard real-time threads + -- 200 - 239 are used by system device driver interrupt threads + -- 110 - 199 are suggested for interactive real-time applications + -- 90 - 109 are used by system daemon threads + -- 0 - 89 are suggested for soft real-time applications + -- + -- We don't express the full range of IRIX priorities. For now, we + -- handle only the subset for soft real-time applications. + + Max_Priority : constant Positive := 88; + Max_Interrupt_Priority : constant Positive := 89; + + subtype Any_Priority is Integer range 0 .. 89; + subtype Priority is Any_Priority range 0 .. 88; + subtype Interrupt_Priority is Any_Priority range 89 .. 89; + + Default_Priority : constant Priority := 44; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := False; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + + -- Note: Denorm is False because denormals are not supported on the + -- R10000, and we want the code to be valid for this processor. + + end System; diff -Nrcpad gcc-4.3.3/gcc/ada/system-irix-o32.ads gcc-4.4.0/gcc/ada/system-irix-o32.ads *** gcc-4.3.3/gcc/ada/system-irix-o32.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-irix-o32.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (SGI Irix, o32 ABI) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (SGI Irix, o32 ABI) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-alpha.ads gcc-4.4.0/gcc/ada/system-linux-alpha.ads *** gcc-4.3.3/gcc/ada/system-linux-alpha.ads Tue Apr 17 15:59:24 2007 --- gcc-4.4.0/gcc/ada/system-linux-alpha.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (GNU-Linux/alpha Version) -- -- -- ! -- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (GNU-Linux/alpha Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 126,132 **** Exit_Status_Supported : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; - Functions_Return_By_DSP : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; --- 124,129 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-hppa.ads gcc-4.4.0/gcc/ada/system-linux-hppa.ads *** gcc-4.3.3/gcc/ada/system-linux-hppa.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-linux-hppa.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (GNU/Linux-HPPA Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (GNU/Linux-HPPA Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-ia64.ads gcc-4.4.0/gcc/ada/system-linux-ia64.ads *** gcc-4.3.3/gcc/ada/system-linux-ia64.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-linux-ia64.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (GNU-Linux/ia64 Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (GNU-Linux/ia64 Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-mips.ads gcc-4.4.0/gcc/ada/system-linux-mips.ads *** gcc-4.3.3/gcc/ada/system-linux-mips.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/system-linux-mips.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,151 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (GNU-Linux/MIPS Version) -- + -- -- + -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- + -- -- + -- This specification is derived from the Ada Reference Manual for use with -- + -- GNAT. The copyright notice above, and the license provisions that follow -- + -- apply solely to the contents of the part following the private keyword. -- + -- -- + -- 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Compiler_System_Version : constant Boolean := False; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + + end System; diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-mipsel.ads gcc-4.4.0/gcc/ada/system-linux-mipsel.ads *** gcc-4.3.3/gcc/ada/system-linux-mipsel.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/system-linux-mipsel.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,151 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (GNU-Linux/MIPSEL Version) -- + -- -- + -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- + -- -- + -- This specification is derived from the Ada Reference Manual for use with -- + -- GNAT. The copyright notice above, and the license provisions that follow -- + -- apply solely to the contents of the part following the private keyword. -- + -- -- + -- 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Compiler_System_Version : constant Boolean := False; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + + end System; diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-ppc.ads gcc-4.4.0/gcc/ada/system-linux-ppc.ads *** gcc-4.3.3/gcc/ada/system-linux-ppc.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-linux-ppc.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (GNU-Linux/PPC Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (GNU-Linux/PPC Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 139,152 **** Preallocated_Stacks : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; ! Stack_Check_Probes : constant Boolean := False; Stack_Check_Limits : constant Boolean := False; Support_64_Bit_Divides : constant Boolean := True; Support_Aggregates : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; --- 137,150 ---- Preallocated_Stacks : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; ! Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_64_Bit_Divides : constant Boolean := True; Support_Aggregates : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-ppc64.ads gcc-4.4.0/gcc/ada/system-linux-ppc64.ads *** gcc-4.3.3/gcc/ada/system-linux-ppc64.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/system-linux-ppc64.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,153 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (GNU-Linux/PPC64 Version) -- + -- -- + -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- + -- -- + -- This specification is derived from the Ada Reference Manual for use with -- + -- GNAT. The copyright notice above, and the license provisions that follow -- + -- apply solely to the contents of the part following the private keyword. -- + -- -- + -- 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- 0 .. 98 corresponds to the system priority range 1 .. 99. + -- + -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use + -- of the entire range provided by the system. + -- + -- If the scheduling policy is SCHED_OTHER the only valid system priority + -- is 1 and other values are simply ignored. + + Max_Priority : constant Positive := 97; + Max_Interrupt_Priority : constant Positive := 98; + + subtype Any_Priority is Integer range 0 .. 98; + subtype Priority is Any_Priority range 0 .. 97; + subtype Interrupt_Priority is Any_Priority range 98 .. 98; + + Default_Priority : constant Priority := 48; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + + end System; diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-s390.ads gcc-4.4.0/gcc/ada/system-linux-s390.ads *** gcc-4.3.3/gcc/ada/system-linux-s390.ads Tue Apr 17 15:59:24 2007 --- gcc-4.4.0/gcc/ada/system-linux-s390.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (GNU-Linux/s390 Version) -- -- -- ! -- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (GNU-Linux/s390 Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 126,132 **** Exit_Status_Supported : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; - Functions_Return_By_DSP : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; --- 124,129 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-s390x.ads gcc-4.4.0/gcc/ada/system-linux-s390x.ads *** gcc-4.3.3/gcc/ada/system-linux-s390x.ads Tue Apr 17 15:59:24 2007 --- gcc-4.4.0/gcc/ada/system-linux-s390x.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (GNU-Linux/s390x Version) -- -- -- ! -- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (GNU-Linux/s390x Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 126,132 **** Exit_Status_Supported : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; - Functions_Return_By_DSP : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; --- 124,129 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-sh4.ads gcc-4.4.0/gcc/ada/system-linux-sh4.ads *** gcc-4.3.3/gcc/ada/system-linux-sh4.ads Sun Dec 2 18:29:04 2007 --- gcc-4.4.0/gcc/ada/system-linux-sh4.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (GNU-Linux/sh4 Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (GNU-Linux/sh4 Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-sparc.ads gcc-4.4.0/gcc/ada/system-linux-sparc.ads *** gcc-4.3.3/gcc/ada/system-linux-sparc.ads Tue Apr 17 15:59:24 2007 --- gcc-4.4.0/gcc/ada/system-linux-sparc.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (GNU/Linux-SPARC Version) -- -- -- ! -- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (GNU/Linux-SPARC Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 126,132 **** Exit_Status_Supported : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; - Functions_Return_By_DSP : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; --- 124,129 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-sparcv9.ads gcc-4.4.0/gcc/ada/system-linux-sparcv9.ads *** gcc-4.3.3/gcc/ada/system-linux-sparcv9.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/system-linux-sparcv9.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,150 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (GNU/Linux-SPARCV9 Version) -- + -- -- + -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- + -- -- + -- This specification is derived from the Ada Reference Manual for use with -- + -- GNAT. The copyright notice above, and the license provisions that follow -- + -- apply solely to the contents of the part following the private keyword. -- + -- -- + -- 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure (System); + -- Note that we take advantage of the implementation permission to + -- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Compiler_System_Version : constant Boolean := False; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + + end System; diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-x86.ads gcc-4.4.0/gcc/ada/system-linux-x86.ads *** gcc-4.3.3/gcc/ada/system-linux-x86.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-linux-x86.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (GNU-Linux/x86 Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (GNU-Linux/x86 Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 139,152 **** Preallocated_Stacks : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; ! Stack_Check_Probes : constant Boolean := False; Stack_Check_Limits : constant Boolean := False; Support_64_Bit_Divides : constant Boolean := True; Support_Aggregates : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; --- 137,150 ---- Preallocated_Stacks : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; ! Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_64_Bit_Divides : constant Boolean := True; Support_Aggregates : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff -Nrcpad gcc-4.3.3/gcc/ada/system-linux-x86_64.ads gcc-4.4.0/gcc/ada/system-linux-x86_64.ads *** gcc-4.3.3/gcc/ada/system-linux-x86_64.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-linux-x86_64.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (GNU-Linux/x86-64 Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (GNU-Linux/x86-64 Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 139,152 **** Preallocated_Stacks : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; ! Stack_Check_Probes : constant Boolean := False; Stack_Check_Limits : constant Boolean := False; Support_64_Bit_Divides : constant Boolean := True; Support_Aggregates : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; --- 137,150 ---- Preallocated_Stacks : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; ! Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_64_Bit_Divides : constant Boolean := True; Support_Aggregates : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff -Nrcpad gcc-4.3.3/gcc/ada/system-lynxos-ppc.ads gcc-4.4.0/gcc/ada/system-lynxos-ppc.ads *** gcc-4.3.3/gcc/ada/system-lynxos-ppc.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-lynxos-ppc.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (LynxOS PPC Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (LynxOS PPC Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 152,158 **** Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; --- 150,156 ---- Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; diff -Nrcpad gcc-4.3.3/gcc/ada/system-lynxos-x86.ads gcc-4.4.0/gcc/ada/system-lynxos-x86.ads *** gcc-4.3.3/gcc/ada/system-lynxos-x86.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-lynxos-x86.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (LynxOS x86 Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (LynxOS x86 Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 152,158 **** Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; --- 150,156 ---- Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; diff -Nrcpad gcc-4.3.3/gcc/ada/system-mingw-x86_64.ads gcc-4.4.0/gcc/ada/system-mingw-x86_64.ads *** gcc-4.3.3/gcc/ada/system-mingw-x86_64.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/system-mingw-x86_64.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,197 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (Windows Version) -- + -- -- + -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- + -- -- + -- This specification is derived from the Ada Reference Manual for use with -- + -- GNAT. The copyright notice above, and the license provisions that follow -- + -- apply solely to the contents of the part following the private keyword. -- + -- -- + -- 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + + --------------------------- + -- Underlying Priorities -- + --------------------------- + + -- Important note: this section of the file must come AFTER the + -- definition of the system implementation parameters to ensure + -- that the value of these parameters is available for analysis + -- of the declarations here (using Rtsfind at compile time). + + -- The underlying priorities table provides a generalized mechanism + -- for mapping from Ada priorities to system priorities. In some + -- cases a 1-1 mapping is not the convenient or optimal choice. + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + Underlying_Priorities : constant Priorities_Mapping := + (Priority'First .. + Default_Priority - 8 => -15, + Default_Priority - 7 => -7, + Default_Priority - 6 => -6, + Default_Priority - 5 => -5, + Default_Priority - 4 => -4, + Default_Priority - 3 => -3, + Default_Priority - 2 => -2, + Default_Priority - 1 => -1, + Default_Priority => 0, + Default_Priority + 1 => 1, + Default_Priority + 2 => 2, + Default_Priority + 3 => 3, + Default_Priority + 4 => 4, + Default_Priority + 5 => 5, + Default_Priority + 6 .. + Priority'Last => 6, + Interrupt_Priority => 15); + -- The default mapping preserves the standard 31 priorities of the Ada + -- model, but maps them using compression onto the 7 priority levels + -- available in NT and on the 16 priority levels available in 2000/XP. + + -- To replace the default values of the Underlying_Priorities mapping, + -- copy this source file into your build directory, edit the file to + -- reflect your desired behavior, and recompile using Makefile.adalib + -- which can be found under the adalib directory of your gnat installation + + pragma Linker_Options ("-Wl,--stack=0x2000000"); + -- This is used to change the default stack (32 MB) size for non tasking + -- programs. We change this value for GNAT on Windows here because the + -- binutils on this platform have switched to a too low value for Ada + -- programs. Note that we also set the stack size for tasking programs in + -- System.Task_Primitives.Operations. + + end System; diff -Nrcpad gcc-4.3.3/gcc/ada/system-mingw.ads gcc-4.4.0/gcc/ada/system-mingw.ads *** gcc-4.3.3/gcc/ada/system-mingw.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-mingw.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (Windows Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (Windows Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 138,144 **** Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; --- 136,142 ---- Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; diff -Nrcpad gcc-4.3.3/gcc/ada/system-rtems.ads gcc-4.4.0/gcc/ada/system-rtems.ads *** gcc-4.3.3/gcc/ada/system-rtems.ads Wed Feb 13 19:04:53 2008 --- gcc-4.4.0/gcc/ada/system-rtems.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (Compiler Version) -- -- -- ! -- Copyright (C) 1992-2008 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (Compiler Version) -- -- -- ! -- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-solaris-sparc.ads gcc-4.4.0/gcc/ada/system-solaris-sparc.ads *** gcc-4.3.3/gcc/ada/system-solaris-sparc.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-solaris-sparc.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (SUN Solaris Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (SUN Solaris Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 138,144 **** Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; --- 136,142 ---- Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff -Nrcpad gcc-4.3.3/gcc/ada/system-solaris-sparcv9.ads gcc-4.4.0/gcc/ada/system-solaris-sparcv9.ads *** gcc-4.3.3/gcc/ada/system-solaris-sparcv9.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-solaris-sparcv9.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (Solaris Sparcv9 Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (Solaris Sparcv9 Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 138,144 **** Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; --- 136,142 ---- Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff -Nrcpad gcc-4.3.3/gcc/ada/system-solaris-x86.ads gcc-4.4.0/gcc/ada/system-solaris-x86.ads *** gcc-4.3.3/gcc/ada/system-solaris-x86.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-solaris-x86.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (x86 Solaris Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (x86 Solaris Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 138,144 **** Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; --- 136,142 ---- Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; ! Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff -Nrcpad gcc-4.3.3/gcc/ada/system-solaris-x86_64.ads gcc-4.4.0/gcc/ada/system-solaris-x86_64.ads *** gcc-4.3.3/gcc/ada/system-solaris-x86_64.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/system-solaris-x86_64.ads Thu Apr 9 23:23:07 2009 *************** *** 0 **** --- 1,145 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (x86-64 Solaris Version) -- + -- -- + -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- + -- -- + -- This specification is derived from the Ada Reference Manual for use with -- + -- GNAT. The copyright notice above, and the license provisions that follow -- + -- apply solely to the contents of the part following the private keyword. -- + -- -- + -- 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + + end System; diff -Nrcpad gcc-4.3.3/gcc/ada/system-tru64.ads gcc-4.4.0/gcc/ada/system-tru64.ads *** gcc-4.3.3/gcc/ada/system-tru64.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-tru64.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (DEC Unix Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (DEC Unix Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-vms-ia64.ads gcc-4.4.0/gcc/ada/system-vms-ia64.ads *** gcc-4.3.3/gcc/ada/system-vms-ia64.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-vms-ia64.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 250,256 **** ADA_GNAT : constant Boolean := True; pragma Export_Object (ADA_GNAT, "ADA$GNAT"); ! -- Uniquitous global symbol identifing a GNAT compiled image to VMS Debug. -- Do not remove! end System; --- 248,254 ---- ADA_GNAT : constant Boolean := True; pragma Export_Object (ADA_GNAT, "ADA$GNAT"); ! -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. -- Do not remove! end System; diff -Nrcpad gcc-4.3.3/gcc/ada/system-vms-zcx.ads gcc-4.4.0/gcc/ada/system-vms-zcx.ads *** gcc-4.3.3/gcc/ada/system-vms-zcx.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-vms-zcx.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (OpenVMS GCC_ZCX DEC Threads Version) -- -- -- ! -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (OpenVMS GCC_ZCX DEC Threads Version) -- -- -- ! -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-vms.ads gcc-4.4.0/gcc/ada/system-vms.ads *** gcc-4.3.3/gcc/ada/system-vms.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-vms.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (OpenVMS DEC Threads Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (OpenVMS DEC Threads Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 233,239 **** ADA_GNAT : constant Boolean := True; pragma Export_Object (ADA_GNAT, "ADA$GNAT"); ! -- Uniquitous global symbol identifing a GNAT compiled image to VMS Debug. -- Do not remove! end System; --- 231,237 ---- ADA_GNAT : constant Boolean := True; pragma Export_Object (ADA_GNAT, "ADA$GNAT"); ! -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. -- Do not remove! end System; diff -Nrcpad gcc-4.3.3/gcc/ada/system-vms_64.ads gcc-4.4.0/gcc/ada/system-vms_64.ads *** gcc-4.3.3/gcc/ada/system-vms_64.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-vms_64.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (OpenVMS 64bit GCC_ZCX DEC Threads Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (OpenVMS 64bit GCC_ZCX DEC Threads Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** private *** 250,256 **** ADA_GNAT : constant Boolean := True; pragma Export_Object (ADA_GNAT, "ADA$GNAT"); ! -- Uniquitous global symbol identifing a GNAT compiled image to VMS Debug. -- Do not remove! end System; --- 248,254 ---- ADA_GNAT : constant Boolean := True; pragma Export_Object (ADA_GNAT, "ADA$GNAT"); ! -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. -- Do not remove! end System; diff -Nrcpad gcc-4.3.3/gcc/ada/system-vxworks-arm.ads gcc-4.4.0/gcc/ada/system-vxworks-arm.ads *** gcc-4.3.3/gcc/ada/system-vxworks-arm.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-vxworks-arm.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (VxWorks Version ARM) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (VxWorks Version ARM) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-vxworks-m68k.ads gcc-4.4.0/gcc/ada/system-vxworks-m68k.ads *** gcc-4.3.3/gcc/ada/system-vxworks-m68k.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-vxworks-m68k.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (VxWorks version M68K) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (VxWorks version M68K) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-vxworks-mips.ads gcc-4.4.0/gcc/ada/system-vxworks-mips.ads *** gcc-4.3.3/gcc/ada/system-vxworks-mips.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-vxworks-mips.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (VxWorks Version Mips) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (VxWorks Version Mips) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-vxworks-ppc.ads gcc-4.4.0/gcc/ada/system-vxworks-ppc.ads *** gcc-4.3.3/gcc/ada/system-vxworks-ppc.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-vxworks-ppc.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (VxWorks Version PPC) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (VxWorks Version PPC) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-vxworks-sparcv9.ads gcc-4.4.0/gcc/ada/system-vxworks-sparcv9.ads *** gcc-4.3.3/gcc/ada/system-vxworks-sparcv9.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-vxworks-sparcv9.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (VxWorks Version Sparc/64) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (VxWorks Version Sparc/64) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system-vxworks-x86.ads gcc-4.4.0/gcc/ada/system-vxworks-x86.ads *** gcc-4.3.3/gcc/ada/system-vxworks-x86.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system-vxworks-x86.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (VxWorks Version x86) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (VxWorks Version x86) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/system.ads gcc-4.4.0/gcc/ada/system.ads *** gcc-4.3.3/gcc/ada/system.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/system.ads Thu Apr 9 23:23:07 2009 *************** *** 7,13 **** -- S p e c -- -- (Compiler Version) -- -- -- ! -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (Compiler Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** *** 15,35 **** -- -- -- 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 15,33 ---- -- -- -- 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/table.adb gcc-4.4.0/gcc/ada/table.adb *** gcc-4.3.3/gcc/ada/table.adb Thu Aug 16 12:19:02 2007 --- gcc-4.4.0/gcc/ada/table.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Table is *** 295,301 **** -- allocation). Range checks are suppressed because this unit -- uses direct calls to System.Memory for allocation, and this can -- yield misaligned storage (and we cannot rely on the bootstrap ! -- compiler supporting specifically disabling alignment cheks, so we -- need to suppress all range checks). It is safe to suppress this -- check here because we know that a (possibly misaligned) object -- of that type does actually exist at that address. --- 293,299 ---- -- allocation). Range checks are suppressed because this unit -- uses direct calls to System.Memory for allocation, and this can -- yield misaligned storage (and we cannot rely on the bootstrap ! -- compiler supporting specifically disabling alignment checks, so we -- need to suppress all range checks). It is safe to suppress this -- check here because we know that a (possibly misaligned) object -- of that type does actually exist at that address. *************** package body Table is *** 307,313 **** -- involve moving table contents around). begin ! -- If we're going to reallocate, check wheter Item references an -- element of the currently allocated table. if Need_Realloc --- 305,311 ---- -- involve moving table contents around). begin ! -- If we're going to reallocate, check whether Item references an -- element of the currently allocated table. if Need_Realloc diff -Nrcpad gcc-4.3.3/gcc/ada/table.ads gcc-4.4.0/gcc/ada/table.ads *** gcc-4.3.3/gcc/ada/table.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/table.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Table is *** 89,95 **** -- chunks controlled by the allocation parameters). -- Note: We do not make the table components aliased, since this would ! -- restict the use of table for discriminated types. If it is necessary -- to take the access of a table element, use Unrestricted_Access. -- WARNING: On HPPA, the virtual addressing approach used in this unit --- 87,93 ---- -- chunks controlled by the allocation parameters). -- Note: We do not make the table components aliased, since this would ! -- restrict the use of table for discriminated types. If it is necessary -- to take the access of a table element, use Unrestricted_Access. -- WARNING: On HPPA, the virtual addressing approach used in this unit *************** package Table is *** 117,122 **** --- 115,121 ---- -- safety is not compromised by this approach. type Table_Ptr is access all Big_Table_Type; + for Table_Ptr'Storage_Size use 0; -- The table is actually represented as a pointer to allow reallocation Table : aliased Table_Ptr := null; diff -Nrcpad gcc-4.3.3/gcc/ada/targext.c gcc-4.4.0/gcc/ada/targext.c *** gcc-4.3.3/gcc/ada/targext.c Fri Dec 9 17:14:34 2005 --- gcc-4.4.0/gcc/ada/targext.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 2005, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 2005-2009 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * diff -Nrcpad gcc-4.3.3/gcc/ada/targparm.adb gcc-4.4.0/gcc/ada/targparm.adb *** gcc-4.3.3/gcc/ada/targparm.adb Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/targparm.adb Wed Jul 30 13:03:32 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2008, 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- -- *************** package body Targparm is *** 54,59 **** --- 54,60 ---- MOV, -- Machine_Overflows MRN, -- Machine_Rounds PAS, -- Preallocated_Stacks + RTX, -- RTX_RTSS_Kernel_Module S64, -- Support_64_Bit_Divides SAG, -- Support_Aggregates SCA, -- Support_Composite_Assign *************** package body Targparm is *** 90,95 **** --- 91,97 ---- MOV_Str : aliased constant Source_Buffer := "Machine_Overflows"; MRN_Str : aliased constant Source_Buffer := "Machine_Rounds"; PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks"; + RTX_Str : aliased constant Source_Buffer := "RTX_RTSS_Kernel_Module"; S64_Str : aliased constant Source_Buffer := "Support_64_Bit_Divides"; SAG_Str : aliased constant Source_Buffer := "Support_Aggregates"; SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign"; *************** package body Targparm is *** 126,131 **** --- 128,134 ---- MOV_Str'Access, MRN_Str'Access, PAS_Str'Access, + RTX_Str'Access, S64_Str'Access, SAG_Str'Access, SCA_Str'Access, *************** package body Targparm is *** 573,578 **** --- 576,582 ---- when MOV => Machine_Overflows_On_Target := Result; when MRN => Machine_Rounds_On_Target := Result; when PAS => Preallocated_Stacks_On_Target := Result; + when RTX => RTX_RTSS_Kernel_Module_On_Target := Result; when S64 => Support_64_Bit_Divides_On_Target := Result; when SAG => Support_Aggregates_On_Target := Result; when SCA => Support_Composite_Assign_On_Target := Result; diff -Nrcpad gcc-4.3.3/gcc/ada/targparm.ads gcc-4.4.0/gcc/ada/targparm.ads *** gcc-4.3.3/gcc/ada/targparm.ads Wed Dec 19 16:22:26 2007 --- gcc-4.4.0/gcc/ada/targparm.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2009, 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 72,81 **** -- 3. Identification information. This is an optional string constant -- that gives the name of the run-time library configuration. This ! -- line may be ommitted for a version of system.ads to be used with -- the full Ada 95 run time. ! -- 4. Other characterisitics of package System. At the current time the -- only item in this category is whether type Address is private. with Rident; use Rident; --- 70,79 ---- -- 3. Identification information. This is an optional string constant -- that gives the name of the run-time library configuration. This ! -- line may be omitted for a version of system.ads to be used with -- the full Ada 95 run time. ! -- 4. Other characteristics of package System. At the current time the -- only item in this category is whether type Address is private. with Rident; use Rident; *************** package Targparm is *** 216,224 **** --- 214,226 ---- OpenVMS_On_Target : Boolean := False; -- Set to True if target is OpenVMS + RTX_RTSS_Kernel_Module_On_Target : Boolean := False; + -- Set to True if target is RTSS module for RTX + type Virtual_Machine_Kind is (No_VM, JVM_Target, CLI_Target); VM_Target : Virtual_Machine_Kind := No_VM; -- Kind of virtual machine targetted + -- Needs comments, don't depend on names ??? ------------------------------- -- Backend Arithmetic Checks -- *************** package Targparm is *** 257,263 **** -- The generation of the setjmp and longjmp calls is handled by -- the front end of the compiler (this includes gigi in the case -- of the standard GCC back end). It does not use any back end ! -- suport (such as the GCC3 exception handling mechanism). When -- this approach is used, the compiler generates special exception -- handlers for handling cleanups when an exception is raised. --- 259,265 ---- -- The generation of the setjmp and longjmp calls is handled by -- the front end of the compiler (this includes gigi in the case -- of the standard GCC back end). It does not use any back end ! -- support (such as the GCC3 exception handling mechanism). When -- this approach is used, the compiler generates special exception -- handlers for handling cleanups when an exception is raised. diff -Nrcpad gcc-4.3.3/gcc/ada/targtyps.c gcc-4.4.0/gcc/ada/targtyps.c *** gcc-4.3.3/gcc/ada/targtyps.c Tue Aug 14 08:40:11 2007 --- gcc-4.4.0/gcc/ada/targtyps.c Thu Jan 1 00:00:00 1970 *************** *** 1,234 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * T A R G T Y P S * - * * - * Body * - * * - * Copyright (C) 1992-2007, 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- * - * ware Foundation; either version 2, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License distributed with GNAT; see file COPYING. If not, write * - * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * - * Boston, MA 02110-1301, USA. * - * * - * As a special exception, if you link this file with other files to * - * produce an executable, this file does not by itself cause the resulting * - * executable to be covered by the GNU General Public License. This except- * - * ion does not however invalidate any other reasons why the executable * - * file might be covered by the GNU Public License. * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - /* Functions for retrieving target types. See Ada package Get_Targ */ - - #include "config.h" - #include "system.h" - #include "coretypes.h" - #include "tm.h" - #include "tree.h" - #include "real.h" - #include "rtl.h" - #include "ada.h" - #include "types.h" - #include "atree.h" - #include "elists.h" - #include "namet.h" - #include "nlists.h" - #include "snames.h" - #include "stringt.h" - #include "uintp.h" - #include "urealp.h" - #include "fe.h" - #include "sinfo.h" - #include "einfo.h" - #include "ada-tree.h" - #include "gigi.h" - - /* If we don't have a specific size for Ada's equivalent of `long', use that - of C. */ - #ifndef ADA_LONG_TYPE_SIZE - #define ADA_LONG_TYPE_SIZE LONG_TYPE_SIZE - #endif - - #ifndef WIDEST_HARDWARE_FP_SIZE - #define WIDEST_HARDWARE_FP_SIZE LONG_DOUBLE_TYPE_SIZE - #endif - - /* The following provide a functional interface for the front end Ada code - to determine the sizes that are used for various C types. */ - - Pos - get_target_bits_per_unit (void) - { - return BITS_PER_UNIT; - } - - Pos - get_target_bits_per_word (void) - { - return BITS_PER_WORD; - } - - Pos - get_target_char_size (void) - { - return CHAR_TYPE_SIZE; - } - - Pos - get_target_wchar_t_size (void) - { - /* We never want wide characters less than "short" in Ada. */ - return MAX (SHORT_TYPE_SIZE, WCHAR_TYPE_SIZE); - } - - Pos - get_target_short_size (void) - { - return SHORT_TYPE_SIZE; - } - - Pos - get_target_int_size (void) - { - return INT_TYPE_SIZE; - } - - Pos - get_target_long_size (void) - { - return ADA_LONG_TYPE_SIZE; - } - - Pos - get_target_long_long_size (void) - { - return LONG_LONG_TYPE_SIZE; - } - - Pos - get_target_float_size (void) - { - return fp_prec_to_size (FLOAT_TYPE_SIZE); - } - - Pos - get_target_double_size (void) - { - return fp_prec_to_size (DOUBLE_TYPE_SIZE); - } - - Pos - get_target_long_double_size (void) - { - return fp_prec_to_size (WIDEST_HARDWARE_FP_SIZE); - } - - - Pos - get_target_pointer_size (void) - { - return POINTER_SIZE; - } - - /* Alignment related values, mapped to attributes for functional and - documentation purposes. */ - - /* Standard'Maximum_Default_Alignment. Maximum alignment that the compiler - might choose by default for a type or object. - - Stricter alignment requests trigger gigi's aligning_type circuitry for - stack objects or objects allocated by the default allocator. */ - - Pos - get_target_maximum_default_alignment (void) - { - return BIGGEST_ALIGNMENT / BITS_PER_UNIT; - } - - /* Standard'Default_Allocator_Alignment. Alignment guaranteed to be honored - by the default allocator (System.Memory.Alloc or malloc if we have no - run-time library at hand). - - Stricter alignment requests trigger gigi's aligning_type circuitry for - objects allocated by the default allocator. */ - - #ifndef MALLOC_ALIGNMENT - #define MALLOC_ALIGNMENT BIGGEST_ALIGNMENT - #endif - - Pos - get_target_default_allocator_alignment (void) - { - /* ??? Need a way to get info about __gnat_malloc from here (whether - it is handy and what alignment it honors). */ - - return MALLOC_ALIGNMENT / BITS_PER_UNIT; - } - - /* Standard'Maximum_Allowed_Alignment. Maximum alignment that we may - accept for any type or object. */ - - #ifndef MAX_OFILE_ALIGNMENT - #define MAX_OFILE_ALIGNMENT BIGGEST_ALIGNMENT - #endif - - Pos - get_target_maximum_allowed_alignment (void) - { - return MAX_OFILE_ALIGNMENT / BITS_PER_UNIT; - } - - /* Standard'Maximum_Alignment. The single attribute initially made - available, now a synonym of Standard'Maximum_Default_Alignment. */ - - Pos - get_target_maximum_alignment (void) - { - return get_target_maximum_default_alignment (); - } - - #ifndef FLOAT_WORDS_BIG_ENDIAN - #define FLOAT_WORDS_BIG_ENDIAN WORDS_BIG_ENDIAN - #endif - - Nat - get_float_words_be (void) - { - return FLOAT_WORDS_BIG_ENDIAN; - } - - Nat - get_words_be (void) - { - return WORDS_BIG_ENDIAN; - } - - Nat - get_bytes_be (void) - { - return BYTES_BIG_ENDIAN; - } - - Nat - get_bits_be (void) - { - return BITS_BIG_ENDIAN; - } - - Nat - get_strict_alignment (void) - { - return STRICT_ALIGNMENT; - } --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/tb-gcc.c gcc-4.4.0/gcc/ada/tb-gcc.c *** gcc-4.3.3/gcc/ada/tb-gcc.c Thu Dec 13 10:43:33 2007 --- gcc-4.4.0/gcc/ada/tb-gcc.c Sun Apr 13 18:03:09 2008 *************** *** 7,12 **** --- 7,13 ---- * C Implementation File * * * * Copyright (C) 2004-2007, AdaCore * + * Copyright (C) 2008, 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,43 **** #include /* The implementation boils down to a call to _Unwind_Backtrace with a ! tailored callback and carried-on datastructure to keep track of the input parameters we got as well as of the basic processing state. */ /****************** --- 38,44 ---- #include /* The implementation boils down to a call to _Unwind_Backtrace with a ! tailored callback and carried-on data structure to keep track of the input parameters we got as well as of the basic processing state. */ /****************** diff -Nrcpad gcc-4.3.3/gcc/ada/tbuild.adb gcc-4.4.0/gcc/ada/tbuild.adb *** gcc-4.3.3/gcc/ada/tbuild.adb Thu Dec 13 10:37:00 2007 --- gcc-4.4.0/gcc/ada/tbuild.adb Mon Aug 4 09:50:09 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Tbuild is *** 360,366 **** begin return Make_Pragma (Sloc, - Chars => Chars, Pragma_Argument_Associations => Pragma_Argument_Associations, Debug_Statement => Debug_Statement, Pragma_Identifier => Make_Identifier (Sloc, Chars)); --- 360,365 ---- *************** package body Tbuild is *** 499,505 **** Get_Name_String (Related_Id); if Prefix /= ' ' then ! pragma Assert (Is_OK_Internal_Letter (Prefix)); for J in reverse 1 .. Name_Len loop Name_Buffer (J + 1) := Name_Buffer (J); --- 498,504 ---- Get_Name_String (Related_Id); if Prefix /= ' ' then ! pragma Assert (Is_OK_Internal_Letter (Prefix) or else Prefix = '_'); for J in reverse 1 .. Name_Len loop Name_Buffer (J + 1) := Name_Buffer (J); diff -Nrcpad gcc-4.3.3/gcc/ada/tbuild.ads gcc-4.4.0/gcc/ada/tbuild.ads *** gcc-4.3.3/gcc/ada/tbuild.ads Thu Dec 13 10:37:00 2007 --- gcc-4.4.0/gcc/ada/tbuild.ads Wed Aug 20 12:32:51 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package Tbuild is *** 57,63 **** pragma Inline (Discard_List); -- This is a dummy procedure that simply returns and does nothing. It is -- used when a function returning a Node_Id value is called for its side ! -- effect (e.g. a call to the pareser to parse a list of compilation -- units), but the List_Id value is not required. function Make_Byte_Aligned_Attribute_Reference --- 57,63 ---- pragma Inline (Discard_List); -- This is a dummy procedure that simply returns and does nothing. It is -- used when a function returning a Node_Id value is called for its side ! -- effect (e.g. a call to the parser to parse a list of compilation -- units), but the List_Id value is not required. function Make_Byte_Aligned_Attribute_Reference *************** package Tbuild is *** 82,89 **** pragma Inline (Make_Implicit_Exception_Handler); -- This is just like Make_Exception_Handler, except that it also sets the -- Local_Raise_Statements field to No_Elist, ensuring that it is properly ! -- initialized. This should always be used when creating exception handlers ! -- as part of the expansion. function Make_Implicit_If_Statement (Node : Node_Id; --- 82,90 ---- pragma Inline (Make_Implicit_Exception_Handler); -- This is just like Make_Exception_Handler, except that it also sets the -- Local_Raise_Statements field to No_Elist, ensuring that it is properly ! -- initialized. This should always be used when creating implicit exception ! -- handlers during expansion (i.e. handlers that do not correspond to user ! -- source program exception handlers). function Make_Implicit_If_Statement (Node : Node_Id; *************** package Tbuild is *** 103,109 **** (Loc : Source_Ptr; Defining_Identifier : Node_Id; Label_Construct : Node_Id) return Node_Id; ! -- Used to contruct an implicit label declaration node, including setting -- the proper Label_Construct field (since Label_Construct is a semantic -- field, the normal call to Make_Implicit_Label_Declaration does not -- set this field). --- 104,110 ---- (Loc : Source_Ptr; Defining_Identifier : Node_Id; Label_Construct : Node_Id) return Node_Id; ! -- Used to construct an implicit label declaration node, including setting -- the proper Label_Construct field (since Label_Construct is a semantic -- field, the normal call to Make_Implicit_Label_Declaration does not -- set this field). *************** package Tbuild is *** 202,212 **** -- -- Prefix is prepended only if Prefix is non-blank (in which case it -- must be an upper case letter other than O,Q,U,W (which are used for ! -- identifier encoding, see Namet), and T is reserved for use by implicit ! -- types. and X is reserved for use by debug type encoding (see package ! -- Exp_Dbug). Note: the reason that Prefix is last is that it is almost ! -- always omitted. The notable case of Prefix being non-null is when ! -- it is 'T' for an implicit type. -- Suffix_Index'Image is appended only if the value of Suffix_Index is -- positive, or if Suffix_Index is negative 1, then a unique serialized --- 203,213 ---- -- -- Prefix is prepended only if Prefix is non-blank (in which case it -- must be an upper case letter other than O,Q,U,W (which are used for ! -- identifier encoding, see Namet), or an underscore, and T is reserved for ! -- use by implicit types, and X is reserved for use by debug type encoding ! -- (see package Exp_Dbug). Note: the reason that Prefix is last is that it ! -- is almost always omitted. The notable case of Prefix being non-null is ! -- when it is 'T' for an implicit type. -- Suffix_Index'Image is appended only if the value of Suffix_Index is -- positive, or if Suffix_Index is negative 1, then a unique serialized *************** package Tbuild is *** 214,220 **** -- Suffix is also a single upper case letter other than O,Q,U,W,X and is a -- required parameter (T is permitted). The constructed name is stored ! -- using Find_Name so that it can be located using a subsequent Find_Name -- operation (i.e. it is properly hashed into the names table). The upper -- case letter given as the Suffix argument ensures that the name does -- not clash with any Ada identifier name. These generated names are --- 215,221 ---- -- Suffix is also a single upper case letter other than O,Q,U,W,X and is a -- required parameter (T is permitted). The constructed name is stored ! -- using Name_Find so that it can be located using a subsequent Name_Find -- operation (i.e. it is properly hashed into the names table). The upper -- case letter given as the Suffix argument ensures that the name does -- not clash with any Ada identifier name. These generated names are *************** package Tbuild is *** 228,234 **** -- Suffix & Suffix_Index'Image -- where Suffix is a single upper case letter other than O,Q,U,W,X and is -- a required parameter (T is permitted). The constructed name is stored ! -- using Find_Name so that it can be located using a subsequent Find_Name -- operation (i.e. it is properly hashed into the names table). The upper -- case letter given as the Suffix argument ensures that the name does -- not clash with any Ada identifier name. These generated names are --- 229,235 ---- -- Suffix & Suffix_Index'Image -- where Suffix is a single upper case letter other than O,Q,U,W,X and is -- a required parameter (T is permitted). The constructed name is stored ! -- using Name_Find so that it can be located using a subsequent Name_Find -- operation (i.e. it is properly hashed into the names table). The upper -- case letter given as the Suffix argument ensures that the name does -- not clash with any Ada identifier name. These generated names are diff -Nrcpad gcc-4.3.3/gcc/ada/tracebak.c gcc-4.4.0/gcc/ada/tracebak.c *** gcc-4.3.3/gcc/ada/tracebak.c Wed Nov 7 14:51:05 2007 --- gcc-4.4.0/gcc/ada/tracebak.c Tue May 20 12:47:13 2008 *************** *** 6,12 **** * * * C Implementation File * * * ! * Copyright (C) 2000-2007, AdaCore * * * * 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- * --- 6,12 ---- * * * C Implementation File * * * ! * Copyright (C) 2000-2008, AdaCore * * * * 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- * *************** extern void (*Unlock_Task) (void); *** 147,153 **** of a call instruction), which is what we want in the output array, and the associated return address, which is what we retrieve from the stack. ! o STOP_FRAME, to decide wether we reached the top of the call chain, and thus if the process shall stop. : --- 147,153 ---- of a call instruction), which is what we want in the output array, and the associated return address, which is what we retrieve from the stack. ! o STOP_FRAME, to decide whether we reached the top of the call chain, and thus if the process shall stop. : *************** struct layout *** 229,237 **** #define BASE_SKIP 1 ! /*---------------------------- PPC VxWorks------------------------------*/ ! #elif defined (_ARCH_PPC) && defined (__vxworks) #define USE_GENERIC_UNWINDER --- 229,238 ---- #define BASE_SKIP 1 ! /*-------------------- PPC ELF (GNU/Linux & VxWorks) ---------------------*/ ! #elif (defined (_ARCH_PPC) && defined (__vxworks)) || \ ! (defined (linux) && defined (__powerpc__)) #define USE_GENERIC_UNWINDER diff -Nrcpad gcc-4.3.3/gcc/ada/trans.c gcc-4.4.0/gcc/ada/trans.c *** gcc-4.3.3/gcc/ada/trans.c Sat May 24 11:52:29 2008 --- gcc-4.4.0/gcc/ada/trans.c Thu Jan 1 00:00:00 1970 *************** *** 1,6905 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * T R A N S * - * * - * C Implementation File * - * * - * Copyright (C) 1992-2008, 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- * - * ware Foundation; either version 2, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License distributed with GNAT; see file COPYING. If not, write * - * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * - * Boston, MA 02110-1301, USA. * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - #include "config.h" - #include "system.h" - #include "coretypes.h" - #include "tm.h" - #include "tree.h" - #include "real.h" - #include "flags.h" - #include "toplev.h" - #include "rtl.h" - #include "expr.h" - #include "ggc.h" - #include "cgraph.h" - #include "function.h" - #include "except.h" - #include "debug.h" - #include "output.h" - #include "tree-gimple.h" - #include "ada.h" - #include "types.h" - #include "atree.h" - #include "elists.h" - #include "namet.h" - #include "nlists.h" - #include "snames.h" - #include "stringt.h" - #include "uintp.h" - #include "urealp.h" - #include "fe.h" - #include "sinfo.h" - #include "einfo.h" - #include "ada-tree.h" - #include "gigi.h" - - /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca, - for fear of running out of stack space. If we need more, we use xmalloc - instead. */ - #define ALLOCA_THRESHOLD 1000 - - /* Let code below know whether we are targetting VMS without need of - intrusive preprocessor directives. */ - #ifndef TARGET_ABI_OPEN_VMS - #define TARGET_ABI_OPEN_VMS 0 - #endif - - extern char *__gnat_to_canonical_file_spec (char *); - - int max_gnat_nodes; - int number_names; - int number_files; - struct Node *Nodes_Ptr; - Node_Id *Next_Node_Ptr; - Node_Id *Prev_Node_Ptr; - struct Elist_Header *Elists_Ptr; - struct Elmt_Item *Elmts_Ptr; - struct String_Entry *Strings_Ptr; - Char_Code *String_Chars_Ptr; - struct List_Header *List_Headers_Ptr; - - /* Current filename without path. */ - const char *ref_filename; - - /* If true, then gigi is being called on an analyzed but unexpanded - tree, and the only purpose of the call is to properly annotate - types with representation information. */ - bool type_annotate_only; - - /* When not optimizing, we cache the 'First, 'Last and 'Length attributes - of unconstrained array IN parameters to avoid emitting a great deal of - redundant instructions to recompute them each time. */ - struct parm_attr GTY (()) - { - int id; /* GTY doesn't like Entity_Id. */ - int dim; - tree first; - tree last; - tree length; - }; - - typedef struct parm_attr *parm_attr; - - DEF_VEC_P(parm_attr); - DEF_VEC_ALLOC_P(parm_attr,gc); - - struct language_function GTY(()) - { - VEC(parm_attr,gc) *parm_attr_cache; - }; - - #define f_parm_attr_cache \ - DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache - - /* A structure used to gather together information about a statement group. - We use this to gather related statements, for example the "then" part - of a IF. In the case where it represents a lexical scope, we may also - have a BLOCK node corresponding to it and/or cleanups. */ - - struct stmt_group GTY((chain_next ("%h.previous"))) { - struct stmt_group *previous; /* Previous code group. */ - tree stmt_list; /* List of statements for this code group. */ - tree block; /* BLOCK for this code group, if any. */ - tree cleanups; /* Cleanups for this code group, if any. */ - }; - - static GTY(()) struct stmt_group *current_stmt_group; - - /* List of unused struct stmt_group nodes. */ - static GTY((deletable)) struct stmt_group *stmt_group_free_list; - - /* A structure used to record information on elaboration procedures - we've made and need to process. - - ??? gnat_node should be Node_Id, but gengtype gets confused. */ - - struct elab_info GTY((chain_next ("%h.next"))) { - struct elab_info *next; /* Pointer to next in chain. */ - tree elab_proc; /* Elaboration procedure. */ - int gnat_node; /* The N_Compilation_Unit. */ - }; - - static GTY(()) struct elab_info *elab_info_list; - - /* Free list of TREE_LIST nodes used for stacks. */ - static GTY((deletable)) tree gnu_stack_free_list; - - /* List of TREE_LIST nodes representing a stack of exception pointer - variables. TREE_VALUE is the VAR_DECL that stores the address of - the raised exception. Nonzero means we are in an exception - handler. Not used in the zero-cost case. */ - static GTY(()) tree gnu_except_ptr_stack; - - /* List of TREE_LIST nodes used to store the current elaboration procedure - decl. TREE_VALUE is the decl. */ - static GTY(()) tree gnu_elab_proc_stack; - - /* Variable that stores a list of labels to be used as a goto target instead of - a return in some functions. See processing for N_Subprogram_Body. */ - static GTY(()) tree gnu_return_label_stack; - - /* List of TREE_LIST nodes representing a stack of LOOP_STMT nodes. - TREE_VALUE of each entry is the label of the corresponding LOOP_STMT. */ - static GTY(()) tree gnu_loop_label_stack; - - /* List of TREE_LIST nodes representing labels for switch statements. - TREE_VALUE of each entry is the label at the end of the switch. */ - static GTY(()) tree gnu_switch_label_stack; - - /* List of TREE_LIST nodes containing the stacks for N_{Push,Pop}_*_Label. */ - static GTY(()) tree gnu_constraint_error_label_stack; - static GTY(()) tree gnu_storage_error_label_stack; - static GTY(()) tree gnu_program_error_label_stack; - - /* Map GNAT tree codes to GCC tree codes for simple expressions. */ - static enum tree_code gnu_codes[Number_Node_Kinds]; - - /* Current node being treated, in case abort called. */ - Node_Id error_gnat_node; - - static void init_code_table (void); - static void Compilation_Unit_to_gnu (Node_Id); - static void record_code_position (Node_Id); - static void insert_code_for (Node_Id); - static void add_cleanup (tree, Node_Id); - static tree mark_visited (tree *, int *, void *); - static tree unshare_save_expr (tree *, int *, void *); - static void add_stmt_list (List_Id); - static void push_exception_label_stack (tree *, Entity_Id); - static tree build_stmt_group (List_Id, bool); - static void push_stack (tree *, tree, tree); - static void pop_stack (tree *); - static enum gimplify_status gnat_gimplify_stmt (tree *); - static void elaborate_all_entities (Node_Id); - static void process_freeze_entity (Node_Id); - static void process_inlined_subprograms (Node_Id); - static void process_decls (List_Id, List_Id, Node_Id, bool, bool); - static tree emit_range_check (tree, Node_Id); - static tree emit_index_check (tree, tree, tree, tree); - static tree emit_check (tree, tree, int); - static tree convert_with_check (Entity_Id, tree, bool, bool, bool); - static bool addressable_p (tree); - static tree assoc_to_constructor (Entity_Id, Node_Id, tree); - static tree extract_values (tree, tree); - static tree pos_to_constructor (Node_Id, tree, Entity_Id); - static tree maybe_implicit_deref (tree); - static tree gnat_stabilize_reference (tree, bool); - static tree gnat_stabilize_reference_1 (tree, bool); - static void set_expr_location_from_node (tree, Node_Id); - static int lvalue_required_p (Node_Id, tree, int); - - /* This is the main program of the back-end. It sets up all the table - structures and then generates code. */ - - void - gigi (Node_Id gnat_root, int max_gnat_node, int number_name, - struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr, - struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr, - struct String_Entry *strings_ptr, Char_Code *string_chars_ptr, - struct List_Header *list_headers_ptr, Nat number_file, - struct File_Info_Type *file_info_ptr ATTRIBUTE_UNUSED, - Entity_Id standard_integer, Entity_Id standard_long_long_float, - Entity_Id standard_exception_type, Int gigi_operating_mode) - { - tree gnu_standard_long_long_float; - tree gnu_standard_exception_type; - struct elab_info *info; - int i ATTRIBUTE_UNUSED; - - max_gnat_nodes = max_gnat_node; - number_names = number_name; - number_files = number_file; - Nodes_Ptr = nodes_ptr; - Next_Node_Ptr = next_node_ptr; - Prev_Node_Ptr = prev_node_ptr; - Elists_Ptr = elists_ptr; - Elmts_Ptr = elmts_ptr; - Strings_Ptr = strings_ptr; - String_Chars_Ptr = string_chars_ptr; - List_Headers_Ptr = list_headers_ptr; - - type_annotate_only = (gigi_operating_mode == 1); - - #ifdef USE_MAPPED_LOCATION - for (i = 0; i < number_files; i++) - { - /* Use the identifier table to make a permanent copy of the filename as - the name table gets reallocated after Gigi returns but before all the - debugging information is output. The __gnat_to_canonical_file_spec - call translates filenames from pragmas Source_Reference that contain - host style syntax not understood by gdb. */ - const char *filename - = IDENTIFIER_POINTER - (get_identifier - (__gnat_to_canonical_file_spec - (Get_Name_String (file_info_ptr[i].File_Name)))); - - /* We rely on the order isomorphism between files and line maps. */ - gcc_assert ((int) line_table->used == i); - - /* We create the line map for a source file at once, with a fixed number - of columns chosen to avoid jumping over the next power of 2. */ - linemap_add (line_table, LC_ENTER, 0, filename, 1); - linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252); - linemap_position_for_column (line_table, 252 - 1); - linemap_add (line_table, LC_LEAVE, 0, NULL, 0); - } - #endif - - /* Initialize ourselves. */ - init_code_table (); - init_gnat_to_gnu (); - gnat_compute_largest_alignment (); - init_dummy_type (); - - /* If we are just annotating types, give VOID_TYPE zero sizes to avoid - errors. */ - if (type_annotate_only) - { - TYPE_SIZE (void_type_node) = bitsize_zero_node; - TYPE_SIZE_UNIT (void_type_node) = size_zero_node; - } - - /* Enable GNAT stack checking method if needed */ - if (!Stack_Check_Probes_On_Target) - set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode, "_gnat_stack_check")); - - /* Give names and make TYPE_DECLs for common types. */ - create_type_decl (get_identifier (SIZE_TYPE), sizetype, - NULL, false, true, Empty); - create_type_decl (get_identifier ("integer"), integer_type_node, - NULL, false, true, Empty); - create_type_decl (get_identifier ("unsigned char"), char_type_node, - NULL, false, true, Empty); - create_type_decl (get_identifier ("long integer"), long_integer_type_node, - NULL, false, true, Empty); - - /* Save the type we made for integer as the type for Standard.Integer. - Then make the rest of the standard types. Note that some of these - may be subtypes. */ - save_gnu_tree (Base_Type (standard_integer), TYPE_NAME (integer_type_node), - false); - - gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); - gnu_constraint_error_label_stack - = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); - gnu_storage_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); - gnu_program_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); - - gnu_standard_long_long_float - = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0); - gnu_standard_exception_type - = gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0); - - init_gigi_decls (gnu_standard_long_long_float, gnu_standard_exception_type); - - /* Process any Pragma Ident for the main unit. */ - #ifdef ASM_OUTPUT_IDENT - if (Present (Ident_String (Main_Unit))) - ASM_OUTPUT_IDENT - (asm_out_file, - TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit)))); - #endif - - /* If we are using the GCC exception mechanism, let GCC know. */ - if (Exception_Mechanism == Back_End_Exceptions) - gnat_init_gcc_eh (); - - gcc_assert (Nkind (gnat_root) == N_Compilation_Unit); - start_stmt_group (); - Compilation_Unit_to_gnu (gnat_root); - - /* Now see if we have any elaboration procedures to deal with. */ - for (info = elab_info_list; info; info = info->next) - { - tree gnu_body = DECL_SAVED_TREE (info->elab_proc); - tree gnu_stmts; - - /* Unshare SAVE_EXPRs between subprograms. These are not unshared by - the gimplifier for obvious reasons, but it turns out that we need to - unshare them for the global level because of SAVE_EXPRs made around - checks for global objects and around allocators for global objects - of variable size, in order to prevent node sharing in the underlying - expression. Note that this implicitly assumes that the SAVE_EXPR - nodes themselves are not shared between subprograms, which would be - an upstream bug for which we would not change the outcome. */ - walk_tree_without_duplicates (&gnu_body, unshare_save_expr, NULL); - - /* Set the current function to be the elaboration procedure and gimplify - what we have. */ - current_function_decl = info->elab_proc; - gimplify_body (&gnu_body, info->elab_proc, true); - - /* We should have a BIND_EXPR, but it may or may not have any statements - in it. If it doesn't have any, we have nothing to do. */ - gnu_stmts = gnu_body; - if (TREE_CODE (gnu_stmts) == BIND_EXPR) - gnu_stmts = BIND_EXPR_BODY (gnu_stmts); - - /* If there are no statements, there is no elaboration code. */ - if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts)) - { - Set_Has_No_Elaboration_Code (info->gnat_node, 1); - cgraph_remove_node (cgraph_node (info->elab_proc)); - } - else - { - /* Otherwise, compile the function. Note that we'll be gimplifying - it twice, but that's fine for the nodes we use. */ - begin_subprog_body (info->elab_proc); - end_subprog_body (gnu_body); - } - } - - /* We cannot track the location of errors past this point. */ - error_gnat_node = Empty; - } - - /* Return a positive value if an lvalue is required for GNAT_NODE. - GNU_TYPE is the type that will be used for GNAT_NODE in the - translated GNU tree. ALIASED indicates whether the underlying - object represented by GNAT_NODE is aliased in the Ada sense. - - The function climbs up the GNAT tree starting from the node and - returns 1 upon encountering a node that effectively requires an - lvalue downstream. It returns int instead of bool to facilitate - usage in non purely binary logic contexts. */ - - static int - lvalue_required_p (Node_Id gnat_node, tree gnu_type, int aliased) - { - Node_Id gnat_parent = Parent (gnat_node), gnat_temp; - - switch (Nkind (gnat_parent)) - { - case N_Reference: - return 1; - - case N_Attribute_Reference: - { - unsigned char id = Get_Attribute_Id (Attribute_Name (gnat_parent)); - return id == Attr_Address - || id == Attr_Access - || id == Attr_Unchecked_Access - || id == Attr_Unrestricted_Access; - } - - case N_Parameter_Association: - case N_Function_Call: - case N_Procedure_Call_Statement: - return (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type)); - - case N_Indexed_Component: - /* Only the array expression can require an lvalue. */ - if (Prefix (gnat_parent) != gnat_node) - return 0; - - /* ??? Consider that referencing an indexed component with a - non-constant index forces the whole aggregate to memory. - Note that N_Integer_Literal is conservative, any static - expression in the RM sense could probably be accepted. */ - for (gnat_temp = First (Expressions (gnat_parent)); - Present (gnat_temp); - gnat_temp = Next (gnat_temp)) - if (Nkind (gnat_temp) != N_Integer_Literal) - return 1; - - /* ... fall through ... */ - - case N_Slice: - /* Only the array expression can require an lvalue. */ - if (Prefix (gnat_parent) != gnat_node) - return 0; - - aliased |= Has_Aliased_Components (Etype (gnat_node)); - return lvalue_required_p (gnat_parent, gnu_type, aliased); - - case N_Selected_Component: - aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent))); - return lvalue_required_p (gnat_parent, gnu_type, aliased); - - case N_Object_Renaming_Declaration: - /* We need to make a real renaming only if the constant object is - aliased or if we may use a renaming pointer; otherwise we can - optimize and return the rvalue. We make an exception if the object - is an identifier since in this case the rvalue can be propagated - attached to the CONST_DECL. */ - return (aliased != 0 - /* This should match the constant case of the renaming code. */ - || Is_Composite_Type (Etype (Name (gnat_parent))) - || Nkind (Name (gnat_parent)) == N_Identifier); - - default: - return 0; - } - - gcc_unreachable (); - } - - /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier, - to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer - to where we should place the result type. */ - - static tree - Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) - { - Node_Id gnat_temp, gnat_temp_type; - tree gnu_result, gnu_result_type; - - /* Whether we should require an lvalue for GNAT_NODE. Needed in - specific circumstances only, so evaluated lazily. < 0 means - unknown, > 0 means known true, 0 means known false. */ - int require_lvalue = -1; - - /* If GNAT_NODE is a constant, whether we should use the initialization - value instead of the constant entity, typically for scalars with an - address clause when the parent doesn't require an lvalue. */ - bool use_constant_initializer = false; - - /* If the Etype of this node does not equal the Etype of the Entity, - something is wrong with the entity map, probably in generic - instantiation. However, this does not apply to types. Since we sometime - have strange Ekind's, just do this test for objects. Also, if the Etype of - the Entity is private, the Etype of the N_Identifier is allowed to be the - full type and also we consider a packed array type to be the same as the - original type. Similarly, a class-wide type is equivalent to a subtype of - itself. Finally, if the types are Itypes, one may be a copy of the other, - which is also legal. */ - gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier - ? gnat_node : Entity (gnat_node)); - gnat_temp_type = Etype (gnat_temp); - - gcc_assert (Etype (gnat_node) == gnat_temp_type - || (Is_Packed (gnat_temp_type) - && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type)) - || (Is_Class_Wide_Type (Etype (gnat_node))) - || (IN (Ekind (gnat_temp_type), Private_Kind) - && Present (Full_View (gnat_temp_type)) - && ((Etype (gnat_node) == Full_View (gnat_temp_type)) - || (Is_Packed (Full_View (gnat_temp_type)) - && (Etype (gnat_node) - == Packed_Array_Type (Full_View - (gnat_temp_type)))))) - || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type)) - || !(Ekind (gnat_temp) == E_Variable - || Ekind (gnat_temp) == E_Component - || Ekind (gnat_temp) == E_Constant - || Ekind (gnat_temp) == E_Loop_Parameter - || IN (Ekind (gnat_temp), Formal_Kind))); - - /* If this is a reference to a deferred constant whose partial view is an - unconstrained private type, the proper type is on the full view of the - constant, not on the full view of the type, which may be unconstrained. - - This may be a reference to a type, for example in the prefix of the - attribute Position, generated for dispatching code (see Make_DT in - exp_disp,adb). In that case we need the type itself, not is parent, - in particular if it is a derived type */ - if (Is_Private_Type (gnat_temp_type) - && Has_Unknown_Discriminants (gnat_temp_type) - && Ekind (gnat_temp) == E_Constant - && Present (Full_View (gnat_temp))) - { - gnat_temp = Full_View (gnat_temp); - gnat_temp_type = Etype (gnat_temp); - } - else - { - /* We want to use the Actual_Subtype if it has already been elaborated, - otherwise the Etype. Avoid using Actual_Subtype for packed arrays to - simplify things. */ - if ((Ekind (gnat_temp) == E_Constant - || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp)) - && !(Is_Array_Type (Etype (gnat_temp)) - && Present (Packed_Array_Type (Etype (gnat_temp)))) - && Present (Actual_Subtype (gnat_temp)) - && present_gnu_tree (Actual_Subtype (gnat_temp))) - gnat_temp_type = Actual_Subtype (gnat_temp); - else - gnat_temp_type = Etype (gnat_node); - } - - /* Expand the type of this identifier first, in case it is an enumeral - literal, which only get made when the type is expanded. There is no - order-of-elaboration issue here. */ - gnu_result_type = get_unpadded_type (gnat_temp_type); - - /* If this is a non-imported scalar constant with an address clause, - retrieve the value instead of a pointer to be dereferenced unless - an lvalue is required. This is generally more efficient and actually - required if this is a static expression because it might be used - in a context where a dereference is inappropriate, such as a case - statement alternative or a record discriminant. There is no possible - volatile-ness shortciruit here since Volatile constants must be imported - per C.6. */ - if (Ekind (gnat_temp) == E_Constant && Is_Scalar_Type (gnat_temp_type) - && !Is_Imported (gnat_temp) - && Present (Address_Clause (gnat_temp))) - { - require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, - Is_Aliased (gnat_temp)); - use_constant_initializer = !require_lvalue; - } - - if (use_constant_initializer) - { - /* If this is a deferred constant, the initializer is attached to the - the full view. */ - if (Present (Full_View (gnat_temp))) - gnat_temp = Full_View (gnat_temp); - - gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp))); - } - else - gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0); - - /* If we are in an exception handler, force this variable into memory to - ensure optimization does not remove stores that appear redundant but are - actually needed in case an exception occurs. - - ??? Note that we need not do this if the variable is declared within the - handler, only if it is referenced in the handler and declared in an - enclosing block, but we have no way of testing that right now. - - ??? We used to essentially set the TREE_ADDRESSABLE flag on the variable - here, but it can now be removed by the Tree aliasing machinery if the - address of the variable is never taken. All we can do is to make the - variable volatile, which might incur the generation of temporaries just - to access the memory in some circumstances. This can be avoided for - variables of non-constant size because they are automatically allocated - to memory. There might be no way of allocating a proper temporary for - them in any case. We only do this for SJLJ though. */ - if (TREE_VALUE (gnu_except_ptr_stack) - && TREE_CODE (gnu_result) == VAR_DECL - && TREE_CODE (DECL_SIZE_UNIT (gnu_result)) == INTEGER_CST) - TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1; - - /* Some objects (such as parameters passed by reference, globals of - variable size, and renamed objects) actually represent the address - of the object. In that case, we must do the dereference. Likewise, - deal with parameters to foreign convention subprograms. */ - if (DECL_P (gnu_result) - && (DECL_BY_REF_P (gnu_result) - || (TREE_CODE (gnu_result) == PARM_DECL - && DECL_BY_COMPONENT_PTR_P (gnu_result)))) - { - bool ro = DECL_POINTS_TO_READONLY_P (gnu_result); - tree renamed_obj; - - if (TREE_CODE (gnu_result) == PARM_DECL - && DECL_BY_COMPONENT_PTR_P (gnu_result)) - gnu_result - = build_unary_op (INDIRECT_REF, NULL_TREE, - convert (build_pointer_type (gnu_result_type), - gnu_result)); - - /* If it's a renaming pointer and we are at the right binding level, - we can reference the renamed object directly, since the renamed - expression has been protected against multiple evaluations. */ - else if (TREE_CODE (gnu_result) == VAR_DECL - && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) != 0 - && (! DECL_RENAMING_GLOBAL_P (gnu_result) - || global_bindings_p ())) - gnu_result = renamed_obj; - - /* Return the underlying CST for a CONST_DECL like a few lines below, - after dereferencing in this case. */ - else if (TREE_CODE (gnu_result) == CONST_DECL) - gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, - DECL_INITIAL (gnu_result)); - - else - gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); - - TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro; - } - - /* The GNAT tree has the type of a function as the type of its result. Also - use the type of the result if the Etype is a subtype which is nominally - unconstrained. But remove any padding from the resulting type. */ - if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE - || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)) - { - gnu_result_type = TREE_TYPE (gnu_result); - if (TREE_CODE (gnu_result_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_result_type)) - gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type)); - } - - /* If we have a constant declaration and its initializer at hand, - try to return the latter to avoid the need to call fold in lots - of places and the need of elaboration code if this Id is used as - an initializer itself. */ - if (TREE_CONSTANT (gnu_result) - && DECL_P (gnu_result) - && DECL_INITIAL (gnu_result)) - { - tree object - = (TREE_CODE (gnu_result) == CONST_DECL - ? DECL_CONST_CORRESPONDING_VAR (gnu_result) : gnu_result); - - /* If there is a corresponding variable, we only want to return - the CST value if an lvalue is not required. Evaluate this - now if we have not already done so. */ - if (object && require_lvalue < 0) - require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, - Is_Aliased (gnat_temp)); - - if (!object || !require_lvalue) - gnu_result = unshare_expr (DECL_INITIAL (gnu_result)); - } - - *gnu_result_type_p = gnu_result_type; - return gnu_result; - } - - /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return - any statements we generate. */ - - static tree - Pragma_to_gnu (Node_Id gnat_node) - { - Node_Id gnat_temp; - tree gnu_result = alloc_stmt_list (); - - /* Check for (and ignore) unrecognized pragma and do nothing if we are just - annotating types. */ - if (type_annotate_only || !Is_Pragma_Name (Chars (gnat_node))) - return gnu_result; - - switch (Get_Pragma_Id (Chars (gnat_node))) - { - case Pragma_Inspection_Point: - /* Do nothing at top level: all such variables are already viewable. */ - if (global_bindings_p ()) - break; - - for (gnat_temp = First (Pragma_Argument_Associations (gnat_node)); - Present (gnat_temp); - gnat_temp = Next (gnat_temp)) - { - Node_Id gnat_expr = Expression (gnat_temp); - tree gnu_expr = gnat_to_gnu (gnat_expr); - int use_address; - enum machine_mode mode; - tree asm_constraint = NULL_TREE; - #ifdef ASM_COMMENT_START - char *comment; - #endif - - if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF) - gnu_expr = TREE_OPERAND (gnu_expr, 0); - - /* Use the value only if it fits into a normal register, - otherwise use the address. */ - mode = TYPE_MODE (TREE_TYPE (gnu_expr)); - use_address = ((GET_MODE_CLASS (mode) != MODE_INT - && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT) - || GET_MODE_SIZE (mode) > UNITS_PER_WORD); - - if (use_address) - gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); - - #ifdef ASM_COMMENT_START - comment = concat (ASM_COMMENT_START, - " inspection point: ", - Get_Name_String (Chars (gnat_expr)), - use_address ? " address" : "", - " is in %0", - NULL); - asm_constraint = build_string (strlen (comment), comment); - free (comment); - #endif - gnu_expr = build4 (ASM_EXPR, void_type_node, - asm_constraint, - NULL_TREE, - tree_cons - (build_tree_list (NULL_TREE, - build_string (1, "g")), - gnu_expr, NULL_TREE), - NULL_TREE); - ASM_VOLATILE_P (gnu_expr) = 1; - set_expr_location_from_node (gnu_expr, gnat_node); - append_to_statement_list (gnu_expr, &gnu_result); - } - break; - - case Pragma_Optimize: - switch (Chars (Expression - (First (Pragma_Argument_Associations (gnat_node))))) - { - case Name_Time: case Name_Space: - if (optimize == 0) - post_error ("insufficient -O value?", gnat_node); - break; - - case Name_Off: - if (optimize != 0) - post_error ("must specify -O0?", gnat_node); - break; - - default: - gcc_unreachable (); - } - break; - - case Pragma_Reviewable: - if (write_symbols == NO_DEBUG) - post_error ("must specify -g?", gnat_node); - break; - } - - return gnu_result; - } - /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Attribute, - to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to - where we should place the result type. ATTRIBUTE is the attribute ID. */ - - static tree - Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) - { - tree gnu_result = error_mark_node; - tree gnu_result_type; - tree gnu_expr; - bool prefix_unused = false; - tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); - tree gnu_type = TREE_TYPE (gnu_prefix); - - /* If the input is a NULL_EXPR, make a new one. */ - if (TREE_CODE (gnu_prefix) == NULL_EXPR) - { - *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); - return build1 (NULL_EXPR, *gnu_result_type_p, - TREE_OPERAND (gnu_prefix, 0)); - } - - switch (attribute) - { - case Attr_Pos: - case Attr_Val: - /* These are just conversions until since representation clauses for - enumerations are handled in the front end. */ - { - bool checkp = Do_Range_Check (First (Expressions (gnat_node))); - - gnu_result = gnat_to_gnu (First (Expressions (gnat_node))); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = convert_with_check (Etype (gnat_node), gnu_result, - checkp, checkp, true); - } - break; - - case Attr_Pred: - case Attr_Succ: - /* These just add or subject the constant 1. Representation clauses for - enumerations are handled in the front-end. */ - gnu_expr = gnat_to_gnu (First (Expressions (gnat_node))); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - if (Do_Range_Check (First (Expressions (gnat_node)))) - { - gnu_expr = protect_multiple_eval (gnu_expr); - gnu_expr - = emit_check - (build_binary_op (EQ_EXPR, integer_type_node, - gnu_expr, - attribute == Attr_Pred - ? TYPE_MIN_VALUE (gnu_result_type) - : TYPE_MAX_VALUE (gnu_result_type)), - gnu_expr, CE_Range_Check_Failed); - } - - gnu_result - = build_binary_op (attribute == Attr_Pred - ? MINUS_EXPR : PLUS_EXPR, - gnu_result_type, gnu_expr, - convert (gnu_result_type, integer_one_node)); - break; - - case Attr_Address: - case Attr_Unrestricted_Access: - /* Conversions don't change something's address but can cause us to miss - the COMPONENT_REF case below, so strip them off. */ - gnu_prefix = remove_conversions (gnu_prefix, - !Must_Be_Byte_Aligned (gnat_node)); - - /* If we are taking 'Address of an unconstrained object, this is the - pointer to the underlying array. */ - if (attribute == Attr_Address) - gnu_prefix = maybe_unconstrained_array (gnu_prefix); - - /* ... fall through ... */ - - case Attr_Access: - case Attr_Unchecked_Access: - case Attr_Code_Address: - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result - = build_unary_op (((attribute == Attr_Address - || attribute == Attr_Unrestricted_Access) - && !Must_Be_Byte_Aligned (gnat_node)) - ? ATTR_ADDR_EXPR : ADDR_EXPR, - gnu_result_type, gnu_prefix); - - /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we - don't try to build a trampoline. */ - if (attribute == Attr_Code_Address) - { - for (gnu_expr = gnu_result; - TREE_CODE (gnu_expr) == NOP_EXPR - || TREE_CODE (gnu_expr) == CONVERT_EXPR; - gnu_expr = TREE_OPERAND (gnu_expr, 0)) - TREE_CONSTANT (gnu_expr) = 1; - - if (TREE_CODE (gnu_expr) == ADDR_EXPR) - TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1; - } - - /* For other address attributes applied to a nested function, - find an inner ADDR_EXPR and annotate it so that we can issue - a useful warning with -Wtrampolines. */ - else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE) - { - for (gnu_expr = gnu_result; - TREE_CODE (gnu_expr) == NOP_EXPR - || TREE_CODE (gnu_expr) == CONVERT_EXPR; - gnu_expr = TREE_OPERAND (gnu_expr, 0)) - ; - - if (TREE_CODE (gnu_expr) == ADDR_EXPR - && decl_function_context (TREE_OPERAND (gnu_expr, 0))) - { - set_expr_location_from_node (gnu_expr, gnat_node); - - /* Check that we're not violating the No_Implicit_Dynamic_Code - restriction. Be conservative if we don't know anything - about the trampoline strategy for the target. */ - Check_Implicit_Dynamic_Code_Allowed (gnat_node); - } - } - break; - - case Attr_Pool_Address: - { - tree gnu_obj_type; - tree gnu_ptr = gnu_prefix; - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - /* If this is an unconstrained array, we know the object must have been - allocated with the template in front of the object. So compute the - template address.*/ - if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) - gnu_ptr - = convert (build_pointer_type - (TYPE_OBJECT_RECORD_TYPE - (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))), - gnu_ptr); - - gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr)); - if (TREE_CODE (gnu_obj_type) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type)) - { - tree gnu_char_ptr_type = build_pointer_type (char_type_node); - tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type)); - tree gnu_byte_offset - = convert (sizetype, - size_diffop (size_zero_node, gnu_pos)); - gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset); - - gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr); - gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type, - gnu_ptr, gnu_byte_offset); - } - - gnu_result = convert (gnu_result_type, gnu_ptr); - } - break; - - case Attr_Size: - case Attr_Object_Size: - case Attr_Value_Size: - case Attr_Max_Size_In_Storage_Elements: - gnu_expr = gnu_prefix; - - /* Remove NOPS from gnu_expr and conversions from gnu_prefix. - We only use GNU_EXPR to see if a COMPONENT_REF was involved. */ - while (TREE_CODE (gnu_expr) == NOP_EXPR) - gnu_expr = TREE_OPERAND (gnu_expr, 0) - ; - - gnu_prefix = remove_conversions (gnu_prefix, true); - prefix_unused = true; - gnu_type = TREE_TYPE (gnu_prefix); - - /* Replace an unconstrained array type with the type of the underlying - array. We can't do this with a call to maybe_unconstrained_array - since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements, - use the record type that will be used to allocate the object and its - template. */ - if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) - { - gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type); - if (attribute != Attr_Max_Size_In_Storage_Elements) - gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); - } - - /* If we're looking for the size of a field, return the field size. - Otherwise, if the prefix is an object, or if 'Object_Size or - 'Max_Size_In_Storage_Elements has been specified, the result is the - GCC size of the type. Otherwise, the result is the RM_Size of the - type. */ - if (TREE_CODE (gnu_prefix) == COMPONENT_REF) - gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1)); - else if (TREE_CODE (gnu_prefix) != TYPE_DECL - || attribute == Attr_Object_Size - || attribute == Attr_Max_Size_In_Storage_Elements) - { - /* If this is a padded type, the GCC size isn't relevant to the - programmer. Normally, what we want is the RM_Size, which was set - from the specified size, but if it was not set, we want the size - of the relevant field. Using the MAX of those two produces the - right result in all case. Don't use the size of the field if it's - a self-referential type, since that's never what's wanted. */ - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_type) - && TREE_CODE (gnu_expr) == COMPONENT_REF) - { - gnu_result = rm_size (gnu_type); - if (!(CONTAINS_PLACEHOLDER_P - (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))) - gnu_result - = size_binop (MAX_EXPR, gnu_result, - DECL_SIZE (TREE_OPERAND (gnu_expr, 1))); - } - else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference) - { - Node_Id gnat_deref = Prefix (gnat_node); - Node_Id gnat_actual_subtype = Actual_Designated_Subtype (gnat_deref); - tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref))); - if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type) - && Present (gnat_actual_subtype)) - { - tree gnu_actual_obj_type = gnat_to_gnu_type (gnat_actual_subtype); - gnu_type = build_unc_object_type_from_ptr (gnu_ptr_type, - gnu_actual_obj_type, get_identifier ("SIZE")); - } - - gnu_result = TYPE_SIZE (gnu_type); - } - else - gnu_result = TYPE_SIZE (gnu_type); - } - else - gnu_result = rm_size (gnu_type); - - gcc_assert (gnu_result); - - /* Deal with a self-referential size by returning the maximum size for a - type and by qualifying the size with the object for 'Size of an - object. */ - if (CONTAINS_PLACEHOLDER_P (gnu_result)) - { - if (TREE_CODE (gnu_prefix) != TYPE_DECL) - gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr); - else - gnu_result = max_size (gnu_result, true); - } - - /* If the type contains a template, subtract its size. */ - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) - gnu_result = size_binop (MINUS_EXPR, gnu_result, - DECL_SIZE (TYPE_FIELDS (gnu_type))); - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - /* Always perform division using unsigned arithmetic as the size cannot - be negative, but may be an overflowed positive value. This provides - correct results for sizes up to 512 MB. - - ??? Size should be calculated in storage elements directly. */ - - if (attribute == Attr_Max_Size_In_Storage_Elements) - gnu_result = convert (sizetype, - fold_build2 (CEIL_DIV_EXPR, bitsizetype, - gnu_result, bitsize_unit_node)); - break; - - case Attr_Alignment: - if (TREE_CODE (gnu_prefix) == COMPONENT_REF - && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) - gnu_prefix = TREE_OPERAND (gnu_prefix, 0); - - gnu_type = TREE_TYPE (gnu_prefix); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - prefix_unused = true; - - gnu_result = size_int ((TREE_CODE (gnu_prefix) == COMPONENT_REF - ? DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) - : TYPE_ALIGN (gnu_type)) / BITS_PER_UNIT); - break; - - case Attr_First: - case Attr_Last: - case Attr_Range_Length: - prefix_unused = true; - - if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE) - { - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - if (attribute == Attr_First) - gnu_result = TYPE_MIN_VALUE (gnu_type); - else if (attribute == Attr_Last) - gnu_result = TYPE_MAX_VALUE (gnu_type); - else - gnu_result - = build_binary_op - (MAX_EXPR, get_base_type (gnu_result_type), - build_binary_op - (PLUS_EXPR, get_base_type (gnu_result_type), - build_binary_op (MINUS_EXPR, - get_base_type (gnu_result_type), - convert (gnu_result_type, - TYPE_MAX_VALUE (gnu_type)), - convert (gnu_result_type, - TYPE_MIN_VALUE (gnu_type))), - convert (gnu_result_type, integer_one_node)), - convert (gnu_result_type, integer_zero_node)); - - break; - } - - /* ... fall through ... */ - - case Attr_Length: - { - int Dimension = (Present (Expressions (gnat_node)) - ? UI_To_Int (Intval (First (Expressions (gnat_node)))) - : 1), i; - struct parm_attr *pa = NULL; - Entity_Id gnat_param = Empty; - - /* Make sure any implicit dereference gets done. */ - gnu_prefix = maybe_implicit_deref (gnu_prefix); - gnu_prefix = maybe_unconstrained_array (gnu_prefix); - /* We treat unconstrained array In parameters specially. */ - if (Nkind (Prefix (gnat_node)) == N_Identifier - && !Is_Constrained (Etype (Prefix (gnat_node))) - && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter) - gnat_param = Entity (Prefix (gnat_node)); - gnu_type = TREE_TYPE (gnu_prefix); - prefix_unused = true; - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - if (TYPE_CONVENTION_FORTRAN_P (gnu_type)) - { - int ndim; - tree gnu_type_temp; - - for (ndim = 1, gnu_type_temp = gnu_type; - TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp)); - ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp)) - ; - - Dimension = ndim + 1 - Dimension; - } - - for (i = 1; i < Dimension; i++) - gnu_type = TREE_TYPE (gnu_type); - - gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); - - /* When not optimizing, look up the slot associated with the parameter - and the dimension in the cache and create a new one on failure. */ - if (!optimize && Present (gnat_param)) - { - for (i = 0; VEC_iterate (parm_attr, f_parm_attr_cache, i, pa); i++) - if (pa->id == gnat_param && pa->dim == Dimension) - break; - - if (!pa) - { - pa = GGC_CNEW (struct parm_attr); - pa->id = gnat_param; - pa->dim = Dimension; - VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa); - } - } - - /* Return the cached expression or build a new one. */ - if (attribute == Attr_First) - { - if (pa && pa->first) - { - gnu_result = pa->first; - break; - } - - gnu_result - = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); - } - - else if (attribute == Attr_Last) - { - if (pa && pa->last) - { - gnu_result = pa->last; - break; - } - - gnu_result - = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); - } - - else /* attribute == Attr_Range_Length || attribute == Attr_Length */ - { - tree gnu_compute_type; - - if (pa && pa->length) - { - gnu_result = pa->length; - break; - } - - gnu_compute_type - = signed_or_unsigned_type_for (0, - get_base_type (gnu_result_type)); - - gnu_result - = build_binary_op - (MAX_EXPR, gnu_compute_type, - build_binary_op - (PLUS_EXPR, gnu_compute_type, - build_binary_op - (MINUS_EXPR, gnu_compute_type, - convert (gnu_compute_type, - TYPE_MAX_VALUE - (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))), - convert (gnu_compute_type, - TYPE_MIN_VALUE - (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))))), - convert (gnu_compute_type, integer_one_node)), - convert (gnu_compute_type, integer_zero_node)); - } - - /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are - handling. Note that these attributes could not have been used on - an unconstrained array type. */ - gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, - gnu_prefix); - - /* Cache the expression we have just computed. Since we want to do it - at runtime, we force the use of a SAVE_EXPR and let the gimplifier - create the temporary. */ - if (pa) - { - gnu_result - = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result); - TREE_SIDE_EFFECTS (gnu_result) = 1; - TREE_INVARIANT (gnu_result) = 1; - if (attribute == Attr_First) - pa->first = gnu_result; - else if (attribute == Attr_Last) - pa->last = gnu_result; - else - pa->length = gnu_result; - } - break; - } - - case Attr_Bit_Position: - case Attr_Position: - case Attr_First_Bit: - case Attr_Last_Bit: - case Attr_Bit: - { - HOST_WIDE_INT bitsize; - HOST_WIDE_INT bitpos; - tree gnu_offset; - tree gnu_field_bitpos; - tree gnu_field_offset; - tree gnu_inner; - enum machine_mode mode; - int unsignedp, volatilep; - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_prefix = remove_conversions (gnu_prefix, true); - prefix_unused = true; - - /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF, - the result is 0. Don't allow 'Bit on a bare component, though. */ - if (attribute == Attr_Bit - && TREE_CODE (gnu_prefix) != COMPONENT_REF - && TREE_CODE (gnu_prefix) != FIELD_DECL) - { - gnu_result = integer_zero_node; - break; - } - - else - gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF - || (attribute == Attr_Bit_Position - && TREE_CODE (gnu_prefix) == FIELD_DECL)); - - get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset, - &mode, &unsignedp, &volatilep, false); - - if (TREE_CODE (gnu_prefix) == COMPONENT_REF) - { - gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1)); - gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1)); - - for (gnu_inner = TREE_OPERAND (gnu_prefix, 0); - TREE_CODE (gnu_inner) == COMPONENT_REF - && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1)); - gnu_inner = TREE_OPERAND (gnu_inner, 0)) - { - gnu_field_bitpos - = size_binop (PLUS_EXPR, gnu_field_bitpos, - bit_position (TREE_OPERAND (gnu_inner, 1))); - gnu_field_offset - = size_binop (PLUS_EXPR, gnu_field_offset, - byte_position (TREE_OPERAND (gnu_inner, 1))); - } - } - else if (TREE_CODE (gnu_prefix) == FIELD_DECL) - { - gnu_field_bitpos = bit_position (gnu_prefix); - gnu_field_offset = byte_position (gnu_prefix); - } - else - { - gnu_field_bitpos = bitsize_zero_node; - gnu_field_offset = size_zero_node; - } - - switch (attribute) - { - case Attr_Position: - gnu_result = gnu_field_offset; - break; - - case Attr_First_Bit: - case Attr_Bit: - gnu_result = size_int (bitpos % BITS_PER_UNIT); - break; - - case Attr_Last_Bit: - gnu_result = bitsize_int (bitpos % BITS_PER_UNIT); - gnu_result = size_binop (PLUS_EXPR, gnu_result, - TYPE_SIZE (TREE_TYPE (gnu_prefix))); - gnu_result = size_binop (MINUS_EXPR, gnu_result, - bitsize_one_node); - break; - - case Attr_Bit_Position: - gnu_result = gnu_field_bitpos; - break; - } - - /* If this has a PLACEHOLDER_EXPR, qualify it by the object - we are handling. */ - gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); - break; - } - - case Attr_Min: - case Attr_Max: - { - tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node))); - tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node)))); - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = build_binary_op (attribute == Attr_Min - ? MIN_EXPR : MAX_EXPR, - gnu_result_type, gnu_lhs, gnu_rhs); - } - break; - - case Attr_Passed_By_Reference: - gnu_result = size_int (default_pass_by_ref (gnu_type) - || must_pass_by_ref (gnu_type)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - break; - - case Attr_Component_Size: - if (TREE_CODE (gnu_prefix) == COMPONENT_REF - && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) - gnu_prefix = TREE_OPERAND (gnu_prefix, 0); - - gnu_prefix = maybe_implicit_deref (gnu_prefix); - gnu_type = TREE_TYPE (gnu_prefix); - - if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) - gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type)))); - - while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) - gnu_type = TREE_TYPE (gnu_type); - - gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); - - /* Note this size cannot be self-referential. */ - gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - prefix_unused = true; - break; - - case Attr_Null_Parameter: - /* This is just a zero cast to the pointer type for - our prefix and dereferenced. */ - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result - = build_unary_op (INDIRECT_REF, NULL_TREE, - convert (build_pointer_type (gnu_result_type), - integer_zero_node)); - TREE_PRIVATE (gnu_result) = 1; - break; - - case Attr_Mechanism_Code: - { - int code; - Entity_Id gnat_obj = Entity (Prefix (gnat_node)); - - prefix_unused = true; - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - if (Present (Expressions (gnat_node))) - { - int i = UI_To_Int (Intval (First (Expressions (gnat_node)))); - - for (gnat_obj = First_Formal (gnat_obj); i > 1; - i--, gnat_obj = Next_Formal (gnat_obj)) - ; - } - - code = Mechanism (gnat_obj); - if (code == Default) - code = ((present_gnu_tree (gnat_obj) - && (DECL_BY_REF_P (get_gnu_tree (gnat_obj)) - || ((TREE_CODE (get_gnu_tree (gnat_obj)) - == PARM_DECL) - && (DECL_BY_COMPONENT_PTR_P - (get_gnu_tree (gnat_obj)))))) - ? By_Reference : By_Copy); - gnu_result = convert (gnu_result_type, size_int (- code)); - } - break; - - default: - /* Say we have an unimplemented attribute. Then set the value to be - returned to be a zero and hope that's something we can convert to the - type of this attribute. */ - post_error ("unimplemented attribute", gnat_node); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = integer_zero_node; - break; - } - - /* If this is an attribute where the prefix was unused, force a use of it if - it has a side-effect. But don't do it if the prefix is just an entity - name. However, if an access check is needed, we must do it. See second - example in AARM 11.6(5.e). */ - if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix) - && !Is_Entity_Name (Prefix (gnat_node))) - gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result), - gnu_prefix, gnu_result); - - *gnu_result_type_p = gnu_result_type; - return gnu_result; - } - - /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement, - to a GCC tree, which is returned. */ - - static tree - Case_Statement_to_gnu (Node_Id gnat_node) - { - tree gnu_result; - tree gnu_expr; - Node_Id gnat_when; - - gnu_expr = gnat_to_gnu (Expression (gnat_node)); - gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); - - /* The range of values in a case statement is determined by the rules in - RM 5.4(7-9). In almost all cases, this range is represented by the Etype - of the expression. One exception arises in the case of a simple name that - is parenthesized. This still has the Etype of the name, but since it is - not a name, para 7 does not apply, and we need to go to the base type. - This is the only case where parenthesization affects the dynamic - semantics (i.e. the range of possible values at runtime that is covered - by the others alternative. - - Another exception is if the subtype of the expression is non-static. In - that case, we also have to use the base type. */ - if (Paren_Count (Expression (gnat_node)) != 0 - || !Is_OK_Static_Subtype (Underlying_Type - (Etype (Expression (gnat_node))))) - gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); - - /* We build a SWITCH_EXPR that contains the code with interspersed - CASE_LABEL_EXPRs for each label. */ - - push_stack (&gnu_switch_label_stack, NULL_TREE, create_artificial_label ()); - start_stmt_group (); - for (gnat_when = First_Non_Pragma (Alternatives (gnat_node)); - Present (gnat_when); - gnat_when = Next_Non_Pragma (gnat_when)) - { - Node_Id gnat_choice; - int choices_added = 0; - - /* First compile all the different case choices for the current WHEN - alternative. */ - for (gnat_choice = First (Discrete_Choices (gnat_when)); - Present (gnat_choice); gnat_choice = Next (gnat_choice)) - { - tree gnu_low = NULL_TREE, gnu_high = NULL_TREE; - - switch (Nkind (gnat_choice)) - { - case N_Range: - gnu_low = gnat_to_gnu (Low_Bound (gnat_choice)); - gnu_high = gnat_to_gnu (High_Bound (gnat_choice)); - break; - - case N_Subtype_Indication: - gnu_low = gnat_to_gnu (Low_Bound (Range_Expression - (Constraint (gnat_choice)))); - gnu_high = gnat_to_gnu (High_Bound (Range_Expression - (Constraint (gnat_choice)))); - break; - - case N_Identifier: - case N_Expanded_Name: - /* This represents either a subtype range or a static value of - some kind; Ekind says which. */ - if (IN (Ekind (Entity (gnat_choice)), Type_Kind)) - { - tree gnu_type = get_unpadded_type (Entity (gnat_choice)); - - gnu_low = fold (TYPE_MIN_VALUE (gnu_type)); - gnu_high = fold (TYPE_MAX_VALUE (gnu_type)); - break; - } - - /* ... fall through ... */ - - case N_Character_Literal: - case N_Integer_Literal: - gnu_low = gnat_to_gnu (gnat_choice); - break; - - case N_Others_Choice: - break; - - default: - gcc_unreachable (); - } - - /* If the case value is a subtype that raises Constraint_Error at - run-time because of a wrong bound, then gnu_low or gnu_high - is not translated into an INTEGER_CST. In such a case, we need - to ensure that the when statement is not added in the tree, - otherwise it will crash the gimplifier. */ - if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST) - && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST)) - { - - add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node, - gnu_low, gnu_high, - create_artificial_label ()), - gnat_choice); - choices_added++; - } - } - - /* Push a binding level here in case variables are declared since we want - them to be local to this set of statements instead of the block - containing the Case statement. */ - - if (choices_added > 0) - { - add_stmt (build_stmt_group (Statements (gnat_when), true)); - add_stmt (build1 (GOTO_EXPR, void_type_node, - TREE_VALUE (gnu_switch_label_stack))); - } - } - - /* Now emit a definition of the label all the cases branched to. */ - add_stmt (build1 (LABEL_EXPR, void_type_node, - TREE_VALUE (gnu_switch_label_stack))); - gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr, - end_stmt_group (), NULL_TREE); - pop_stack (&gnu_switch_label_stack); - - return gnu_result; - } - - /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement, - to a GCC tree, which is returned. */ - - static tree - Loop_Statement_to_gnu (Node_Id gnat_node) - { - /* ??? It would be nice to use "build" here, but there's no build5. */ - tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, NULL_TREE); - tree gnu_loop_var = NULL_TREE; - Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node); - tree gnu_cond_expr = NULL_TREE; - tree gnu_result; - - TREE_TYPE (gnu_loop_stmt) = void_type_node; - TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1; - LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label (); - set_expr_location_from_node (gnu_loop_stmt, gnat_node); - - /* Save the end label of this LOOP_STMT in a stack so that the corresponding - N_Exit_Statement can find it. */ - push_stack (&gnu_loop_label_stack, NULL_TREE, - LOOP_STMT_LABEL (gnu_loop_stmt)); - - /* Set the condition that under which the loop should continue. - For "LOOP .... END LOOP;" the condition is always true. */ - if (No (gnat_iter_scheme)) - ; - /* The case "WHILE condition LOOP ..... END LOOP;" */ - else if (Present (Condition (gnat_iter_scheme))) - LOOP_STMT_TOP_COND (gnu_loop_stmt) - = gnat_to_gnu (Condition (gnat_iter_scheme)); - else - { - /* We have an iteration scheme. */ - Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme); - Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec); - Entity_Id gnat_type = Etype (gnat_loop_var); - tree gnu_type = get_unpadded_type (gnat_type); - tree gnu_low = TYPE_MIN_VALUE (gnu_type); - tree gnu_high = TYPE_MAX_VALUE (gnu_type); - bool reversep = Reverse_Present (gnat_loop_spec); - tree gnu_first = reversep ? gnu_high : gnu_low; - tree gnu_last = reversep ? gnu_low : gnu_high; - enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR; - tree gnu_base_type = get_base_type (gnu_type); - tree gnu_limit = (reversep ? TYPE_MIN_VALUE (gnu_base_type) - : TYPE_MAX_VALUE (gnu_base_type)); - - /* We know the loop variable will not overflow if GNU_LAST is a constant - and is not equal to GNU_LIMIT. If it might overflow, we have to move - the limit test to the end of the loop. In that case, we have to test - for an empty loop outside the loop. */ - if (TREE_CODE (gnu_last) != INTEGER_CST - || TREE_CODE (gnu_limit) != INTEGER_CST - || tree_int_cst_equal (gnu_last, gnu_limit)) - { - gnu_cond_expr - = build3 (COND_EXPR, void_type_node, - build_binary_op (LE_EXPR, integer_type_node, - gnu_low, gnu_high), - NULL_TREE, alloc_stmt_list ()); - set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec); - } - - /* Open a new nesting level that will surround the loop to declare the - loop index variable. */ - start_stmt_group (); - gnat_pushlevel (); - - /* Declare the loop index and set it to its initial value. */ - gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1); - if (DECL_BY_REF_P (gnu_loop_var)) - gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var); - - /* The loop variable might be a padded type, so use `convert' to get a - reference to the inner variable if so. */ - gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var); - - /* Set either the top or bottom exit condition as appropriate depending - on whether or not we know an overflow cannot occur. */ - if (gnu_cond_expr) - LOOP_STMT_BOT_COND (gnu_loop_stmt) - = build_binary_op (NE_EXPR, integer_type_node, - gnu_loop_var, gnu_last); - else - LOOP_STMT_TOP_COND (gnu_loop_stmt) - = build_binary_op (end_code, integer_type_node, - gnu_loop_var, gnu_last); - - LOOP_STMT_UPDATE (gnu_loop_stmt) - = build_binary_op (reversep ? PREDECREMENT_EXPR - : PREINCREMENT_EXPR, - TREE_TYPE (gnu_loop_var), - gnu_loop_var, - convert (TREE_TYPE (gnu_loop_var), - integer_one_node)); - set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt), - gnat_iter_scheme); - } - - /* If the loop was named, have the name point to this loop. In this case, - the association is not a ..._DECL node, but the end label from this - LOOP_STMT. */ - if (Present (Identifier (gnat_node))) - save_gnu_tree (Entity (Identifier (gnat_node)), - LOOP_STMT_LABEL (gnu_loop_stmt), true); - - /* Make the loop body into its own block, so any allocated storage will be - released every iteration. This is needed for stack allocation. */ - LOOP_STMT_BODY (gnu_loop_stmt) - = build_stmt_group (Statements (gnat_node), true); - - /* If we declared a variable, then we are in a statement group for that - declaration. Add the LOOP_STMT to it and make that the "loop". */ - if (gnu_loop_var) - { - add_stmt (gnu_loop_stmt); - gnat_poplevel (); - gnu_loop_stmt = end_stmt_group (); - } - - /* If we have an outer COND_EXPR, that's our result and this loop is its - "true" statement. Otherwise, the result is the LOOP_STMT. */ - if (gnu_cond_expr) - { - COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt; - gnu_result = gnu_cond_expr; - recalculate_side_effects (gnu_cond_expr); - } - else - gnu_result = gnu_loop_stmt; - - pop_stack (&gnu_loop_label_stack); - - return gnu_result; - } - - /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition - handler for the current function. */ - - /* This is implemented by issuing a call to the appropriate VMS specific - builtin. To avoid having VMS specific sections in the global gigi decls - array, we maintain the decls of interest here. We can't declare them - inside the function because we must mark them never to be GC'd, which we - can only do at the global level. */ - - static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE; - static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE; - - static void - establish_gnat_vms_condition_handler (void) - { - tree establish_stmt; - - /* Elaborate the required decls on the first call. Check on the decl for - the gnat condition handler to decide, as this is one we create so we are - sure that it will be non null on subsequent calls. The builtin decl is - looked up so remains null on targets where it is not implemented yet. */ - if (gnat_vms_condition_handler_decl == NULL_TREE) - { - vms_builtin_establish_handler_decl - = builtin_decl_for - (get_identifier ("__builtin_establish_vms_condition_handler")); - - gnat_vms_condition_handler_decl - = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"), - NULL_TREE, - build_function_type_list (integer_type_node, - ptr_void_type_node, - ptr_void_type_node, - NULL_TREE), - NULL_TREE, 0, 1, 1, 0, Empty); - } - - /* Do nothing if the establish builtin is not available, which might happen - on targets where the facility is not implemented. */ - if (vms_builtin_establish_handler_decl == NULL_TREE) - return; - - establish_stmt - = build_call_1_expr (vms_builtin_establish_handler_decl, - build_unary_op - (ADDR_EXPR, NULL_TREE, - gnat_vms_condition_handler_decl)); - - add_stmt (establish_stmt); - } - - /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We - don't return anything. */ - - static void - Subprogram_Body_to_gnu (Node_Id gnat_node) - { - /* Defining identifier of a parameter to the subprogram. */ - Entity_Id gnat_param; - /* The defining identifier for the subprogram body. Note that if a - specification has appeared before for this body, then the identifier - occurring in that specification will also be a defining identifier and all - the calls to this subprogram will point to that specification. */ - Entity_Id gnat_subprog_id - = (Present (Corresponding_Spec (gnat_node)) - ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node)); - /* The FUNCTION_DECL node corresponding to the subprogram spec. */ - tree gnu_subprog_decl; - /* The FUNCTION_TYPE node corresponding to the subprogram spec. */ - tree gnu_subprog_type; - tree gnu_cico_list; - tree gnu_result; - VEC(parm_attr,gc) *cache; - - /* If this is a generic object or if it has been eliminated, - ignore it. */ - if (Ekind (gnat_subprog_id) == E_Generic_Procedure - || Ekind (gnat_subprog_id) == E_Generic_Function - || Is_Eliminated (gnat_subprog_id)) - return; - - /* If this subprogram acts as its own spec, define it. Otherwise, just get - the already-elaborated tree node. However, if this subprogram had its - elaboration deferred, we will already have made a tree node for it. So - treat it as not being defined in that case. Such a subprogram cannot - have an address clause or a freeze node, so this test is safe, though it - does disable some otherwise-useful error checking. */ - gnu_subprog_decl - = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, - Acts_As_Spec (gnat_node) - && !present_gnu_tree (gnat_subprog_id)); - - gnu_subprog_type = TREE_TYPE (gnu_subprog_decl); - - /* Propagate the debug mode. */ - if (!Needs_Debug_Info (gnat_subprog_id)) - DECL_IGNORED_P (gnu_subprog_decl) = 1; - - /* Set the line number in the decl to correspond to that of the body so that - the line number notes are written correctly. */ - Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl)); - - /* Initialize the information structure for the function. */ - allocate_struct_function (gnu_subprog_decl, false); - DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language - = GGC_CNEW (struct language_function); - - begin_subprog_body (gnu_subprog_decl); - gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); - - /* If there are Out parameters, we need to ensure that the return statement - properly copies them out. We do this by making a new block and converting - any inner return into a goto to a label at the end of the block. */ - push_stack (&gnu_return_label_stack, NULL_TREE, - gnu_cico_list ? create_artificial_label () : NULL_TREE); - - /* Get a tree corresponding to the code for the subprogram. */ - start_stmt_group (); - gnat_pushlevel (); - - /* See if there are any parameters for which we don't yet have GCC entities. - These must be for Out parameters for which we will be making VAR_DECL - nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty - entry as well. We can match up the entries because TYPE_CI_CO_LIST is in - the order of the parameters. */ - for (gnat_param = First_Formal_With_Extras (gnat_subprog_id); - Present (gnat_param); - gnat_param = Next_Formal_With_Extras (gnat_param)) - if (!present_gnu_tree (gnat_param)) - { - /* Skip any entries that have been already filled in; they must - correspond to In Out parameters. */ - for (; gnu_cico_list && TREE_VALUE (gnu_cico_list); - gnu_cico_list = TREE_CHAIN (gnu_cico_list)) - ; - - /* Do any needed references for padded types. */ - TREE_VALUE (gnu_cico_list) - = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)), - gnat_to_gnu_entity (gnat_param, NULL_TREE, 1)); - } - - /* On VMS, establish our condition handler to possibly turn a condition into - the corresponding exception if the subprogram has a foreign convention or - is exported. - - To ensure proper execution of local finalizations on condition instances, - we must turn a condition into the corresponding exception even if there - is no applicable Ada handler, and need at least one condition handler per - possible call chain involving GNAT code. OTOH, establishing the handler - has a cost so we want to minimize the number of subprograms into which - this happens. The foreign or exported condition is expected to satisfy - all the constraints. */ - if (TARGET_ABI_OPEN_VMS - && (Has_Foreign_Convention (gnat_node) || Is_Exported (gnat_node))) - establish_gnat_vms_condition_handler (); - - process_decls (Declarations (gnat_node), Empty, Empty, true, true); - - /* Generate the code of the subprogram itself. A return statement will be - present and any Out parameters will be handled there. */ - add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); - gnat_poplevel (); - gnu_result = end_stmt_group (); - - /* If we populated the parameter attributes cache, we need to make sure - that the cached expressions are evaluated on all possible paths. */ - cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache; - if (cache) - { - struct parm_attr *pa; - int i; - - start_stmt_group (); - - for (i = 0; VEC_iterate (parm_attr, cache, i, pa); i++) - { - if (pa->first) - add_stmt (pa->first); - if (pa->last) - add_stmt (pa->last); - if (pa->length) - add_stmt (pa->length); - } - - add_stmt (gnu_result); - gnu_result = end_stmt_group (); - } - - /* If we made a special return label, we need to make a block that contains - the definition of that label and the copying to the return value. That - block first contains the function, then the label and copy statement. */ - if (TREE_VALUE (gnu_return_label_stack)) - { - tree gnu_retval; - - start_stmt_group (); - gnat_pushlevel (); - add_stmt (gnu_result); - add_stmt (build1 (LABEL_EXPR, void_type_node, - TREE_VALUE (gnu_return_label_stack))); - - gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); - if (list_length (gnu_cico_list) == 1) - gnu_retval = TREE_VALUE (gnu_cico_list); - else - gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type), - gnu_cico_list); - - if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval)) - gnu_retval = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval); - - add_stmt_with_node - (build_return_expr (DECL_RESULT (gnu_subprog_decl), gnu_retval), - gnat_node); - gnat_poplevel (); - gnu_result = end_stmt_group (); - } - - pop_stack (&gnu_return_label_stack); - - /* Set the end location. */ - Sloc_to_locus - ((Present (End_Label (Handled_Statement_Sequence (gnat_node))) - ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node))) - : Sloc (gnat_node)), - &DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus); - - end_subprog_body (gnu_result); - - /* Disconnect the trees for parameters that we made variables for from the - GNAT entities since these are unusable after we end the function. */ - for (gnat_param = First_Formal_With_Extras (gnat_subprog_id); - Present (gnat_param); - gnat_param = Next_Formal_With_Extras (gnat_param)) - if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL) - save_gnu_tree (gnat_param, NULL_TREE, false); - - if (DECL_FUNCTION_STUB (gnu_subprog_decl)) - build_function_stub (gnu_subprog_decl, gnat_subprog_id); - - mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node))); - } - - /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call - or an N_Procedure_Call_Statement, to a GCC tree, which is returned. - GNU_RESULT_TYPE_P is a pointer to where we should place the result type. - If GNU_TARGET is non-null, this must be a function call and the result - of the call is to be placed into that object. */ - - static tree - call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) - { - tree gnu_result; - /* The GCC node corresponding to the GNAT subprogram name. This can either - be a FUNCTION_DECL node if we are dealing with a standard subprogram call, - or an indirect reference expression (an INDIRECT_REF node) pointing to a - subprogram. */ - tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node)); - /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */ - tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node); - tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, - gnu_subprog_node); - Entity_Id gnat_formal; - Node_Id gnat_actual; - tree gnu_actual_list = NULL_TREE; - tree gnu_name_list = NULL_TREE; - tree gnu_before_list = NULL_TREE; - tree gnu_after_list = NULL_TREE; - tree gnu_subprog_call; - - switch (Nkind (Name (gnat_node))) - { - case N_Identifier: - case N_Operator_Symbol: - case N_Expanded_Name: - case N_Attribute_Reference: - if (Is_Eliminated (Entity (Name (gnat_node)))) - Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node))); - } - - gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE); - - /* If we are calling a stubbed function, make this into a raise of - Program_Error. Elaborate all our args first. */ - if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL - && DECL_STUBBED_P (gnu_subprog_node)) - { - for (gnat_actual = First_Actual (gnat_node); - Present (gnat_actual); - gnat_actual = Next_Actual (gnat_actual)) - add_stmt (gnat_to_gnu (gnat_actual)); - - { - tree call_expr - = build_call_raise (PE_Stubbed_Subprogram_Called, gnat_node, - N_Raise_Program_Error); - - if (Nkind (gnat_node) == N_Function_Call && !gnu_target) - { - *gnu_result_type_p = TREE_TYPE (gnu_subprog_type); - return build1 (NULL_EXPR, *gnu_result_type_p, call_expr); - } - else - return call_expr; - } - } - - /* If we are calling by supplying a pointer to a target, set up that - pointer as the first argument. Use GNU_TARGET if one was passed; - otherwise, make a target by building a variable of the maximum size - of the type. */ - if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)) - { - tree gnu_real_ret_type - = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type))); - - if (!gnu_target) - { - tree gnu_obj_type - = maybe_pad_type (gnu_real_ret_type, - max_size (TYPE_SIZE (gnu_real_ret_type), true), - 0, Etype (Name (gnat_node)), "PAD", false, - false, false); - - /* ??? We may be about to create a static temporary if we happen to - be at the global binding level. That's a regression from what - the 3.x back-end would generate in the same situation, but we - don't have a mechanism in Gigi for creating automatic variables - in the elaboration routines. */ - gnu_target - = create_var_decl (create_tmp_var_name ("LR"), NULL, gnu_obj_type, - NULL, false, false, false, false, NULL, - gnat_node); - } - - gnu_actual_list - = tree_cons (NULL_TREE, - build_unary_op (ADDR_EXPR, NULL_TREE, - unchecked_convert (gnu_real_ret_type, - gnu_target, - false)), - NULL_TREE); - - } - - /* The only way we can be making a call via an access type is if Name is an - explicit dereference. In that case, get the list of formal args from the - type the access type is pointing to. Otherwise, get the formals from - entity being called. */ - if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) - gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node))); - else if (Nkind (Name (gnat_node)) == N_Attribute_Reference) - /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */ - gnat_formal = 0; - else - gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node))); - - /* Create the list of the actual parameters as GCC expects it, namely a chain - of TREE_LIST nodes in which the TREE_VALUE field of each node is a - parameter-expression and the TREE_PURPOSE field is null. Skip Out - parameters not passed by reference and don't need to be copied in. */ - for (gnat_actual = First_Actual (gnat_node); - Present (gnat_actual); - gnat_formal = Next_Formal_With_Extras (gnat_formal), - gnat_actual = Next_Actual (gnat_actual)) - { - tree gnu_formal - = (present_gnu_tree (gnat_formal) - ? get_gnu_tree (gnat_formal) : NULL_TREE); - tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal)); - /* We must suppress conversions that can cause the creation of a - temporary in the Out or In Out case because we need the real - object in this case, either to pass its address if it's passed - by reference or as target of the back copy done after the call - if it uses the copy-in copy-out mechanism. We do it in the In - case too, except for an unchecked conversion because it alone - can cause the actual to be misaligned and the addressability - test is applied to the real object. */ - bool suppress_type_conversion - = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion - && Ekind (gnat_formal) != E_In_Parameter) - || (Nkind (gnat_actual) == N_Type_Conversion - && Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))); - Node_Id gnat_name = (suppress_type_conversion - ? Expression (gnat_actual) : gnat_actual); - tree gnu_name = gnat_to_gnu (gnat_name); - tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)); - tree gnu_actual; - - /* If it's possible we may need to use this expression twice, make sure - that any side-effects are handled via SAVE_EXPRs. Likewise if we need - to force side-effects before the call. - ??? This is more conservative than we need since we don't need to do - this for pass-by-ref with no conversion. */ - if (Ekind (gnat_formal) != E_In_Parameter) - gnu_name = gnat_stabilize_reference (gnu_name, true); - - /* If we are passing a non-addressable parameter by reference, pass the - address of a copy. In the Out or In Out case, set up to copy back - out after the call. */ - if (gnu_formal - && (DECL_BY_REF_P (gnu_formal) - || (TREE_CODE (gnu_formal) == PARM_DECL - && (DECL_BY_COMPONENT_PTR_P (gnu_formal) - || (DECL_BY_DESCRIPTOR_P (gnu_formal))))) - && !addressable_p (gnu_name)) - { - tree gnu_copy = gnu_name, gnu_temp; - - /* If the type is by_reference, a copy is not allowed. */ - if (Is_By_Reference_Type (Etype (gnat_formal))) - post_error - ("misaligned & cannot be passed by reference", gnat_actual); - - /* For users of Starlet we issue a warning because the - interface apparently assumes that by-ref parameters - outlive the procedure invocation. The code still - will not work as intended, but we cannot do much - better since other low-level parts of the back-end - would allocate temporaries at will because of the - misalignment if we did not do so here. */ - else if (Is_Valued_Procedure (Entity (Name (gnat_node)))) - { - post_error - ("?possible violation of implicit assumption", gnat_actual); - post_error_ne - ("?made by pragma Import_Valued_Procedure on &", gnat_actual, - Entity (Name (gnat_node))); - post_error_ne ("?because of misalignment of &", gnat_actual, - gnat_formal); - } - - /* Remove any unpadding and make a copy. But if it's a justified - modular type, just convert to it. */ - if (TREE_CODE (gnu_name) == COMPONENT_REF - && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P - (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))))) - gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0); - - else if (TREE_CODE (gnu_name_type) == RECORD_TYPE - && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type))) - gnu_name = convert (gnu_name_type, gnu_name); - - /* Make a SAVE_EXPR to both properly account for potential side - effects and handle the creation of a temporary copy. Special - code in gnat_gimplify_expr ensures that the same temporary is - used as the actual and copied back after the call if needed. */ - gnu_name = build1 (SAVE_EXPR, TREE_TYPE (gnu_name), gnu_name); - TREE_SIDE_EFFECTS (gnu_name) = 1; - TREE_INVARIANT (gnu_name) = 1; - - /* Set up to move the copy back to the original. */ - if (Ekind (gnat_formal) != E_In_Parameter) - { - gnu_temp = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_copy, - gnu_name); - set_expr_location_from_node (gnu_temp, gnat_actual); - append_to_statement_list (gnu_temp, &gnu_after_list); - } - } - - /* Start from the real object and build the actual. */ - gnu_actual = gnu_name; - - /* If this was a procedure call, we may not have removed any padding. - So do it here for the part we will use as an input, if any. */ - if (Ekind (gnat_formal) != E_Out_Parameter - && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))) - gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), - gnu_actual); - - /* Do any needed conversions for the actual and make sure that it is - in range of the formal's type. */ - if (suppress_type_conversion) - { - /* Put back the conversion we suppressed above in the computation - of the real object. Note that we treat a conversion between - aggregate types as if it is an unchecked conversion here. */ - gnu_actual - = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)), - gnu_actual, - (Nkind (gnat_actual) - == N_Unchecked_Type_Conversion) - && No_Truncation (gnat_actual)); - - if (Ekind (gnat_formal) != E_Out_Parameter - && Do_Range_Check (gnat_actual)) - gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal)); - } - else - { - if (Ekind (gnat_formal) != E_Out_Parameter - && Do_Range_Check (gnat_actual)) - gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal)); - - /* We may have suppressed a conversion to the Etype of the actual - since the parent is a procedure call. So put it back here. - ??? We use the reverse order compared to the case above because - of an awkward interaction with the check and actually don't put - back the conversion at all if a check is emitted. This is also - done for the conversion to the formal's type just below. */ - if (TREE_CODE (gnu_actual) != SAVE_EXPR) - gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)), - gnu_actual); - } - - if (TREE_CODE (gnu_actual) != SAVE_EXPR) - gnu_actual = convert (gnu_formal_type, gnu_actual); - - /* Unless this is an In parameter, we must remove any justified modular - building from GNU_NAME to get an lvalue. */ - if (Ekind (gnat_formal) != E_In_Parameter - && TREE_CODE (gnu_name) == CONSTRUCTOR - && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name))) - gnu_name = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), - gnu_name); - - /* If we have not saved a GCC object for the formal, it means it is an - Out parameter not passed by reference and that does not need to be - copied in. Otherwise, look at the PARM_DECL to see if it is passed by - reference. */ - if (gnu_formal - && TREE_CODE (gnu_formal) == PARM_DECL - && DECL_BY_REF_P (gnu_formal)) - { - if (Ekind (gnat_formal) != E_In_Parameter) - { - /* In Out or Out parameters passed by reference don't use the - copy-in copy-out mechanism so the address of the real object - must be passed to the function. */ - gnu_actual = gnu_name; - - /* If we have a padded type, be sure we've removed padding. */ - if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)) - && TREE_CODE (gnu_actual) != SAVE_EXPR) - gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), - gnu_actual); - - /* If we have the constructed subtype of an aliased object - with an unconstrained nominal subtype, the type of the - actual includes the template, although it is formally - constrained. So we need to convert it back to the real - constructed subtype to retrieve the constrained part - and takes its address. */ - if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual)) - && TREE_CODE (gnu_actual) != SAVE_EXPR - && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual)) - && Is_Array_Type (Etype (gnat_actual))) - gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)), - gnu_actual); - } - - /* The symmetry of the paths to the type of an entity is broken here - since arguments don't know that they will be passed by ref. */ - gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); - gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); - } - else if (gnu_formal - && TREE_CODE (gnu_formal) == PARM_DECL - && DECL_BY_COMPONENT_PTR_P (gnu_formal)) - { - gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); - gnu_actual = maybe_implicit_deref (gnu_actual); - gnu_actual = maybe_unconstrained_array (gnu_actual); - - if (TREE_CODE (gnu_formal_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_formal_type)) - { - gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type)); - gnu_actual = convert (gnu_formal_type, gnu_actual); - } - - /* Take the address of the object and convert to the proper pointer - type. We'd like to actually compute the address of the beginning - of the array using an ADDR_EXPR of an ARRAY_REF, but there's a - possibility that the ARRAY_REF might return a constant and we'd be - getting the wrong address. Neither approach is exactly correct, - but this is the most likely to work in all cases. */ - gnu_actual = convert (gnu_formal_type, - build_unary_op (ADDR_EXPR, NULL_TREE, - gnu_actual)); - } - else if (gnu_formal - && TREE_CODE (gnu_formal) == PARM_DECL - && DECL_BY_DESCRIPTOR_P (gnu_formal)) - { - /* If arg is 'Null_Parameter, pass zero descriptor. */ - if ((TREE_CODE (gnu_actual) == INDIRECT_REF - || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF) - && TREE_PRIVATE (gnu_actual)) - gnu_actual = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)), - integer_zero_node); - else - gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE, - fill_vms_descriptor (gnu_actual, - gnat_formal)); - } - else - { - tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual)); - - if (Ekind (gnat_formal) != E_In_Parameter) - gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list); - - if (!gnu_formal || TREE_CODE (gnu_formal) != PARM_DECL) - continue; - - /* If this is 'Null_Parameter, pass a zero even though we are - dereferencing it. */ - else if (TREE_CODE (gnu_actual) == INDIRECT_REF - && TREE_PRIVATE (gnu_actual) - && host_integerp (gnu_actual_size, 1) - && 0 >= compare_tree_int (gnu_actual_size, - BITS_PER_WORD)) - gnu_actual - = unchecked_convert (DECL_ARG_TYPE (gnu_formal), - convert (gnat_type_for_size - (tree_low_cst (gnu_actual_size, 1), - 1), - integer_zero_node), - false); - else - gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual); - } - - gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list); - } - - gnu_subprog_call = build_call_list (TREE_TYPE (gnu_subprog_type), - gnu_subprog_addr, - nreverse (gnu_actual_list)); - set_expr_location_from_node (gnu_subprog_call, gnat_node); - - /* If we return by passing a target, the result is the target after the - call. We must not emit the call directly here because this might be - evaluated as part of an expression with conditions to control whether - the call should be emitted or not. */ - if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)) - { - /* Conceptually, what we need is a COMPOUND_EXPR with the call followed - by the target object converted to the proper type. Doing so would - potentially be very inefficient, however, as this expresssion might - end up wrapped into an outer SAVE_EXPR later on, which would incur a - pointless temporary copy of the whole object. - - What we do instead is build a COMPOUND_EXPR returning the address of - the target, and then dereference. Wrapping the COMPOUND_EXPR into a - SAVE_EXPR later on then only incurs a pointer copy. */ - - tree gnu_result_type - = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type))); - - /* Build and return - (result_type) *[gnu_subprog_call (&gnu_target, ...), &gnu_target] */ - - tree gnu_target_address - = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_target); - set_expr_location_from_node (gnu_target_address, gnat_node); - - gnu_result - = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_target_address), - gnu_subprog_call, gnu_target_address); - - gnu_result - = unchecked_convert (gnu_result_type, - build_unary_op (INDIRECT_REF, NULL_TREE, - gnu_result), - false); - - *gnu_result_type_p = gnu_result_type; - return gnu_result; - } - - /* If it is a function call, the result is the call expression unless - a target is specified, in which case we copy the result into the target - and return the assignment statement. */ - else if (Nkind (gnat_node) == N_Function_Call) - { - gnu_result = gnu_subprog_call; - - /* If the function returns an unconstrained array or by reference, - we have to de-dereference the pointer. */ - if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type) - || TYPE_RETURNS_BY_REF_P (gnu_subprog_type)) - gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); - - if (gnu_target) - gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, - gnu_target, gnu_result); - else - *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); - - return gnu_result; - } - - /* If this is the case where the GNAT tree contains a procedure call - but the Ada procedure has copy in copy out parameters, the special - parameter passing mechanism must be used. */ - else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE) - { - /* List of FIELD_DECLs associated with the PARM_DECLs of the copy - in copy out parameters. */ - tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type); - int length = list_length (scalar_return_list); - - if (length > 1) - { - tree gnu_name; - - gnu_subprog_call = save_expr (gnu_subprog_call); - gnu_name_list = nreverse (gnu_name_list); - - /* If any of the names had side-effects, ensure they are all - evaluated before the call. */ - for (gnu_name = gnu_name_list; gnu_name; - gnu_name = TREE_CHAIN (gnu_name)) - if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name))) - append_to_statement_list (TREE_VALUE (gnu_name), - &gnu_before_list); - } - - if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) - gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node))); - else - gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node))); - - for (gnat_actual = First_Actual (gnat_node); - Present (gnat_actual); - gnat_formal = Next_Formal_With_Extras (gnat_formal), - gnat_actual = Next_Actual (gnat_actual)) - /* If we are dealing with a copy in copy out parameter, we must - retrieve its value from the record returned in the call. */ - if (!(present_gnu_tree (gnat_formal) - && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL - && (DECL_BY_REF_P (get_gnu_tree (gnat_formal)) - || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL - && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)) - || (DECL_BY_DESCRIPTOR_P - (get_gnu_tree (gnat_formal)))))))) - && Ekind (gnat_formal) != E_In_Parameter) - { - /* Get the value to assign to this Out or In Out parameter. It is - either the result of the function if there is only a single such - parameter or the appropriate field from the record returned. */ - tree gnu_result - = length == 1 ? gnu_subprog_call - : build_component_ref (gnu_subprog_call, NULL_TREE, - TREE_PURPOSE (scalar_return_list), - false); - - /* If the actual is a conversion, get the inner expression, which - will be the real destination, and convert the result to the - type of the actual parameter. */ - tree gnu_actual - = maybe_unconstrained_array (TREE_VALUE (gnu_name_list)); - - /* If the result is a padded type, remove the padding. */ - if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) - gnu_result = convert (TREE_TYPE (TYPE_FIELDS - (TREE_TYPE (gnu_result))), - gnu_result); - - /* If the actual is a type conversion, the real target object is - denoted by the inner Expression and we need to convert the - result to the associated type. - We also need to convert our gnu assignment target to this type - if the corresponding GNU_NAME was constructed from the GNAT - conversion node and not from the inner Expression. */ - if (Nkind (gnat_actual) == N_Type_Conversion) - { - gnu_result - = convert_with_check - (Etype (Expression (gnat_actual)), gnu_result, - Do_Overflow_Check (gnat_actual), - Do_Range_Check (Expression (gnat_actual)), - Float_Truncate (gnat_actual)); - - if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))) - gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual); - } - - /* Unchecked conversions as actuals for Out parameters are not - allowed in user code because they are not variables, but do - occur in front-end expansions. The associated GNU_NAME is - always obtained from the inner expression in such cases. */ - else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion) - gnu_result = unchecked_convert (TREE_TYPE (gnu_actual), - gnu_result, - No_Truncation (gnat_actual)); - else - { - if (Do_Range_Check (gnat_actual)) - gnu_result = emit_range_check (gnu_result, - Etype (gnat_actual)); - - if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual))) - && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result))))) - gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result); - } - - gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, - gnu_actual, gnu_result); - set_expr_location_from_node (gnu_result, gnat_actual); - append_to_statement_list (gnu_result, &gnu_before_list); - scalar_return_list = TREE_CHAIN (scalar_return_list); - gnu_name_list = TREE_CHAIN (gnu_name_list); - } - } - else - append_to_statement_list (gnu_subprog_call, &gnu_before_list); - - append_to_statement_list (gnu_after_list, &gnu_before_list); - return gnu_before_list; - } - - /* Subroutine of gnat_to_gnu to translate gnat_node, an - N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */ - - static tree - Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) - { - tree gnu_jmpsave_decl = NULL_TREE; - tree gnu_jmpbuf_decl = NULL_TREE; - /* If just annotating, ignore all EH and cleanups. */ - bool gcc_zcx = (!type_annotate_only - && Present (Exception_Handlers (gnat_node)) - && Exception_Mechanism == Back_End_Exceptions); - bool setjmp_longjmp - = (!type_annotate_only && Present (Exception_Handlers (gnat_node)) - && Exception_Mechanism == Setjmp_Longjmp); - bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node)); - bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp); - tree gnu_inner_block; /* The statement(s) for the block itself. */ - tree gnu_result; - tree gnu_expr; - Node_Id gnat_temp; - - /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes - and we have our own SJLJ mechanism. To call the GCC mechanism, we call - add_cleanup, and when we leave the binding, end_stmt_group will create - the TRY_FINALLY_EXPR. - - ??? The region level calls down there have been specifically put in place - for a ZCX context and currently the order in which things are emitted - (region/handlers) is different from the SJLJ case. Instead of putting - other calls with different conditions at other places for the SJLJ case, - it seems cleaner to reorder things for the SJLJ case and generalize the - condition to make it not ZCX specific. - - If there are any exceptions or cleanup processing involved, we need an - outer statement group (for Setjmp_Longjmp) and binding level. */ - if (binding_for_block) - { - start_stmt_group (); - gnat_pushlevel (); - } - - /* If using setjmp_longjmp, make the variables for the setjmp buffer and save - area for address of previous buffer. Do this first since we need to have - the setjmp buf known for any decls in this block. */ - if (setjmp_longjmp) - { - gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"), - NULL_TREE, jmpbuf_ptr_type, - build_call_0_expr (get_jmpbuf_decl), - false, false, false, false, NULL, - gnat_node); - DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1; - - /* The __builtin_setjmp receivers will immediately reinstall it. Now - because of the unstructured form of EH used by setjmp_longjmp, there - might be forward edges going to __builtin_setjmp receivers on which - it is uninitialized, although they will never be actually taken. */ - TREE_NO_WARNING (gnu_jmpsave_decl) = 1; - gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"), - NULL_TREE, jmpbuf_type, - NULL_TREE, false, false, false, false, - NULL, gnat_node); - DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1; - - set_block_jmpbuf_decl (gnu_jmpbuf_decl); - - /* When we exit this block, restore the saved value. */ - add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl), - End_Label (gnat_node)); - } - - /* If we are to call a function when exiting this block, add a cleanup - to the binding level we made above. Note that add_cleanup is FIFO - so we must register this cleanup after the EH cleanup just above. */ - if (at_end) - add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))), - End_Label (gnat_node)); - - /* Now build the tree for the declarations and statements inside this block. - If this is SJLJ, set our jmp_buf as the current buffer. */ - start_stmt_group (); - - if (setjmp_longjmp) - add_stmt (build_call_1_expr (set_jmpbuf_decl, - build_unary_op (ADDR_EXPR, NULL_TREE, - gnu_jmpbuf_decl))); - - if (Present (First_Real_Statement (gnat_node))) - process_decls (Statements (gnat_node), Empty, - First_Real_Statement (gnat_node), true, true); - - /* Generate code for each statement in the block. */ - for (gnat_temp = (Present (First_Real_Statement (gnat_node)) - ? First_Real_Statement (gnat_node) - : First (Statements (gnat_node))); - Present (gnat_temp); gnat_temp = Next (gnat_temp)) - add_stmt (gnat_to_gnu (gnat_temp)); - gnu_inner_block = end_stmt_group (); - - /* Now generate code for the two exception models, if either is relevant for - this block. */ - if (setjmp_longjmp) - { - tree *gnu_else_ptr = 0; - tree gnu_handler; - - /* Make a binding level for the exception handling declarations and code - and set up gnu_except_ptr_stack for the handlers to use. */ - start_stmt_group (); - gnat_pushlevel (); - - push_stack (&gnu_except_ptr_stack, NULL_TREE, - create_var_decl (get_identifier ("EXCEPT_PTR"), - NULL_TREE, - build_pointer_type (except_type_node), - build_call_0_expr (get_excptr_decl), false, - false, false, false, NULL, gnat_node)); - - /* Generate code for each handler. The N_Exception_Handler case does the - real work and returns a COND_EXPR for each handler, which we chain - together here. */ - for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); - Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp)) - { - gnu_expr = gnat_to_gnu (gnat_temp); - - /* If this is the first one, set it as the outer one. Otherwise, - point the "else" part of the previous handler to us. Then point - to our "else" part. */ - if (!gnu_else_ptr) - add_stmt (gnu_expr); - else - *gnu_else_ptr = gnu_expr; - - gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr); - } - - /* If none of the exception handlers did anything, re-raise but do not - defer abortion. */ - gnu_expr = build_call_1_expr (raise_nodefer_decl, - TREE_VALUE (gnu_except_ptr_stack)); - set_expr_location_from_node (gnu_expr, gnat_node); - - if (gnu_else_ptr) - *gnu_else_ptr = gnu_expr; - else - add_stmt (gnu_expr); - - /* End the binding level dedicated to the exception handlers and get the - whole statement group. */ - pop_stack (&gnu_except_ptr_stack); - gnat_poplevel (); - gnu_handler = end_stmt_group (); - - /* If the setjmp returns 1, we restore our incoming longjmp value and - then check the handlers. */ - start_stmt_group (); - add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl, - gnu_jmpsave_decl), - gnat_node); - add_stmt (gnu_handler); - gnu_handler = end_stmt_group (); - - /* This block is now "if (setjmp) ... else ". */ - gnu_result = build3 (COND_EXPR, void_type_node, - (build_call_1_expr - (setjmp_decl, - build_unary_op (ADDR_EXPR, NULL_TREE, - gnu_jmpbuf_decl))), - gnu_handler, gnu_inner_block); - } - else if (gcc_zcx) - { - tree gnu_handlers; - - /* First make a block containing the handlers. */ - start_stmt_group (); - for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); - Present (gnat_temp); - gnat_temp = Next_Non_Pragma (gnat_temp)) - add_stmt (gnat_to_gnu (gnat_temp)); - gnu_handlers = end_stmt_group (); - - /* Now make the TRY_CATCH_EXPR for the block. */ - gnu_result = build2 (TRY_CATCH_EXPR, void_type_node, - gnu_inner_block, gnu_handlers); - } - else - gnu_result = gnu_inner_block; - - /* Now close our outer block, if we had to make one. */ - if (binding_for_block) - { - add_stmt (gnu_result); - gnat_poplevel (); - gnu_result = end_stmt_group (); - } - - return gnu_result; - } - - /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler, - to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp - exception handling. */ - - static tree - Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) - { - /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make - an "if" statement to select the proper exceptions. For "Others", exclude - exceptions where Handled_By_Others is nonzero unless the All_Others flag - is set. For "Non-ada", accept an exception if "Lang" is 'V'. */ - tree gnu_choice = integer_zero_node; - tree gnu_body = build_stmt_group (Statements (gnat_node), false); - Node_Id gnat_temp; - - for (gnat_temp = First (Exception_Choices (gnat_node)); - gnat_temp; gnat_temp = Next (gnat_temp)) - { - tree this_choice; - - if (Nkind (gnat_temp) == N_Others_Choice) - { - if (All_Others (gnat_temp)) - this_choice = integer_one_node; - else - this_choice - = build_binary_op - (EQ_EXPR, integer_type_node, - convert - (integer_type_node, - build_component_ref - (build_unary_op - (INDIRECT_REF, NULL_TREE, - TREE_VALUE (gnu_except_ptr_stack)), - get_identifier ("not_handled_by_others"), NULL_TREE, - false)), - integer_zero_node); - } - - else if (Nkind (gnat_temp) == N_Identifier - || Nkind (gnat_temp) == N_Expanded_Name) - { - Entity_Id gnat_ex_id = Entity (gnat_temp); - tree gnu_expr; - - /* Exception may be a renaming. Recover original exception which is - the one elaborated and registered. */ - if (Present (Renamed_Object (gnat_ex_id))) - gnat_ex_id = Renamed_Object (gnat_ex_id); - - gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0); - - this_choice - = build_binary_op - (EQ_EXPR, integer_type_node, TREE_VALUE (gnu_except_ptr_stack), - convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)), - build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr))); - - /* If this is the distinguished exception "Non_Ada_Error" (and we are - in VMS mode), also allow a non-Ada exception (a VMS condition) t - match. */ - if (Is_Non_Ada_Error (Entity (gnat_temp))) - { - tree gnu_comp - = build_component_ref - (build_unary_op (INDIRECT_REF, NULL_TREE, - TREE_VALUE (gnu_except_ptr_stack)), - get_identifier ("lang"), NULL_TREE, false); - - this_choice - = build_binary_op - (TRUTH_ORIF_EXPR, integer_type_node, - build_binary_op (EQ_EXPR, integer_type_node, gnu_comp, - build_int_cst (TREE_TYPE (gnu_comp), 'V')), - this_choice); - } - } - else - gcc_unreachable (); - - gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, - gnu_choice, this_choice); - } - - return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE); - } - - /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler, - to a GCC tree, which is returned. This is the variant for ZCX. */ - - static tree - Exception_Handler_to_gnu_zcx (Node_Id gnat_node) - { - tree gnu_etypes_list = NULL_TREE; - tree gnu_expr; - tree gnu_etype; - tree gnu_current_exc_ptr; - tree gnu_incoming_exc_ptr; - Node_Id gnat_temp; - - /* We build a TREE_LIST of nodes representing what exception types this - handler can catch, with special cases for others and all others cases. - - Each exception type is actually identified by a pointer to the exception - id, or to a dummy object for "others" and "all others". - - Care should be taken to ensure that the control flow impact of "others" - and "all others" is known to GCC. lang_eh_type_covers is doing the trick - currently. */ - for (gnat_temp = First (Exception_Choices (gnat_node)); - gnat_temp; gnat_temp = Next (gnat_temp)) - { - if (Nkind (gnat_temp) == N_Others_Choice) - { - tree gnu_expr - = All_Others (gnat_temp) ? all_others_decl : others_decl; - - gnu_etype - = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); - } - else if (Nkind (gnat_temp) == N_Identifier - || Nkind (gnat_temp) == N_Expanded_Name) - { - Entity_Id gnat_ex_id = Entity (gnat_temp); - - /* Exception may be a renaming. Recover original exception which is - the one elaborated and registered. */ - if (Present (Renamed_Object (gnat_ex_id))) - gnat_ex_id = Renamed_Object (gnat_ex_id); - - gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0); - gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); - - /* The Non_Ada_Error case for VMS exceptions is handled - by the personality routine. */ - } - else - gcc_unreachable (); - - /* The GCC interface expects NULL to be passed for catch all handlers, so - it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype - is integer_zero_node. It would not work, however, because GCC's - notion of "catch all" is stronger than our notion of "others". Until - we correctly use the cleanup interface as well, doing that would - prevent the "all others" handlers from being seen, because nothing - can be caught beyond a catch all from GCC's point of view. */ - gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list); - } - - start_stmt_group (); - gnat_pushlevel (); - - /* Expand a call to the begin_handler hook at the beginning of the handler, - and arrange for a call to the end_handler hook to occur on every possible - exit path. - - The hooks expect a pointer to the low level occurrence. This is required - for our stack management scheme because a raise inside the handler pushes - a new occurrence on top of the stack, which means that this top does not - necessarily match the occurrence this handler was dealing with. - - The EXC_PTR_EXPR object references the exception occurrence being - propagated. Upon handler entry, this is the exception for which the - handler is triggered. This might not be the case upon handler exit, - however, as we might have a new occurrence propagated by the handler's - body, and the end_handler hook called as a cleanup in this context. - - We use a local variable to retrieve the incoming value at handler entry - time, and reuse it to feed the end_handler hook's argument at exit. */ - gnu_current_exc_ptr = build0 (EXC_PTR_EXPR, ptr_type_node); - gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE, - ptr_type_node, gnu_current_exc_ptr, - false, false, false, false, NULL, - gnat_node); - - add_stmt_with_node (build_call_1_expr (begin_handler_decl, - gnu_incoming_exc_ptr), - gnat_node); - /* ??? We don't seem to have an End_Label at hand to set the location. */ - add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr), - Empty); - add_stmt_list (Statements (gnat_node)); - gnat_poplevel (); - - return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list, - end_stmt_group ()); - } - - /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */ - - static void - Compilation_Unit_to_gnu (Node_Id gnat_node) - { - /* Make the decl for the elaboration procedure. */ - bool body_p = (Defining_Entity (Unit (gnat_node)), - Nkind (Unit (gnat_node)) == N_Package_Body - || Nkind (Unit (gnat_node)) == N_Subprogram_Body); - Entity_Id gnat_unit_entity = Defining_Entity (Unit (gnat_node)); - tree gnu_elab_proc_decl - = create_subprog_decl - (create_concat_name (gnat_unit_entity, - body_p ? "elabb" : "elabs"), - NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL, - gnat_unit_entity); - struct elab_info *info; - - push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl); - - DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1; - allocate_struct_function (gnu_elab_proc_decl, false); - Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus); - set_cfun (NULL); - - /* For a body, first process the spec if there is one. */ - if (Nkind (Unit (gnat_node)) == N_Package_Body - || (Nkind (Unit (gnat_node)) == N_Subprogram_Body - && !Acts_As_Spec (gnat_node))) - { - add_stmt (gnat_to_gnu (Library_Unit (gnat_node))); - finalize_from_with_types (); - } - - process_inlined_subprograms (gnat_node); - - if (type_annotate_only && gnat_node == Cunit (Main_Unit)) - { - elaborate_all_entities (gnat_node); - - if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration - || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration - || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration) - return; - } - - process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty, - true, true); - add_stmt (gnat_to_gnu (Unit (gnat_node))); - - /* Process any pragmas and actions following the unit. */ - add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node))); - add_stmt_list (Actions (Aux_Decls_Node (gnat_node))); - finalize_from_with_types (); - - /* Save away what we've made so far and record this potential elaboration - procedure. */ - info = (struct elab_info *) ggc_alloc (sizeof (struct elab_info)); - set_current_block_context (gnu_elab_proc_decl); - gnat_poplevel (); - DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group (); - info->next = elab_info_list; - info->elab_proc = gnu_elab_proc_decl; - info->gnat_node = gnat_node; - elab_info_list = info; - - /* Generate elaboration code for this unit, if necessary, and say whether - we did or not. */ - pop_stack (&gnu_elab_proc_stack); - - /* Invalidate the global renaming pointers. This is necessary because - stabilization of the renamed entities may create SAVE_EXPRs which - have been tied to a specific elaboration routine just above. */ - invalidate_global_renaming_pointers (); - } - - /* This function is the driver of the GNAT to GCC tree transformation - process. It is the entry point of the tree transformer. GNAT_NODE is the - root of some GNAT tree. Return the root of the corresponding GCC tree. - If this is an expression, return the GCC equivalent of the expression. If - it is a statement, return the statement. In the case when called for a - statement, it may also add statements to the current statement group, in - which case anything it returns is to be interpreted as occurring after - anything `it already added. */ - - tree - gnat_to_gnu (Node_Id gnat_node) - { - bool went_into_elab_proc = false; - tree gnu_result = error_mark_node; /* Default to no value. */ - tree gnu_result_type = void_type_node; - tree gnu_expr; - tree gnu_lhs, gnu_rhs; - Node_Id gnat_temp; - - /* Save node number for error message and set location information. */ - error_gnat_node = gnat_node; - Sloc_to_locus (Sloc (gnat_node), &input_location); - - if (type_annotate_only - && IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)) - return alloc_stmt_list (); - - /* If this node is a non-static subexpression and we are only - annotating types, make this into a NULL_EXPR. */ - if (type_annotate_only - && IN (Nkind (gnat_node), N_Subexpr) - && Nkind (gnat_node) != N_Identifier - && !Compile_Time_Known_Value (gnat_node)) - return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)), - build_call_raise (CE_Range_Check_Failed, gnat_node, - N_Raise_Constraint_Error)); - - /* If this is a Statement and we are at top level, it must be part of the - elaboration procedure, so mark us as being in that procedure and push our - context. - - If we are in the elaboration procedure, check if we are violating a a - No_Elaboration_Code restriction by having a statement there. */ - if ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call) - && Nkind (gnat_node) != N_Null_Statement) - || Nkind (gnat_node) == N_Procedure_Call_Statement - || Nkind (gnat_node) == N_Label - || Nkind (gnat_node) == N_Implicit_Label_Declaration - || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements - || ((Nkind (gnat_node) == N_Raise_Constraint_Error - || Nkind (gnat_node) == N_Raise_Storage_Error - || Nkind (gnat_node) == N_Raise_Program_Error) - && (Ekind (Etype (gnat_node)) == E_Void))) - { - if (!current_function_decl) - { - current_function_decl = TREE_VALUE (gnu_elab_proc_stack); - start_stmt_group (); - gnat_pushlevel (); - went_into_elab_proc = true; - } - - /* Don't check for a possible No_Elaboration_Code restriction violation - on N_Handled_Sequence_Of_Statements, as we want to signal an error on - every nested real statement instead. This also avoids triggering - spurious errors on dummy (empty) sequences created by the front-end - for package bodies in some cases. */ - - if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack) - && Nkind (gnat_node) != N_Handled_Sequence_Of_Statements) - Check_Elaboration_Code_Allowed (gnat_node); - } - - switch (Nkind (gnat_node)) - { - /********************************/ - /* Chapter 2: Lexical Elements: */ - /********************************/ - - case N_Identifier: - case N_Expanded_Name: - case N_Operator_Symbol: - case N_Defining_Identifier: - gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type); - break; - - case N_Integer_Literal: - { - tree gnu_type; - - /* Get the type of the result, looking inside any padding and - justified modular types. Then get the value in that type. */ - gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (gnu_type)) - gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); - - gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type); - - /* If the result overflows (meaning it doesn't fit in its base type), - abort. We would like to check that the value is within the range - of the subtype, but that causes problems with subtypes whose usage - will raise Constraint_Error and with biased representation, so - we don't. */ - gcc_assert (!TREE_OVERFLOW (gnu_result)); - } - break; - - case N_Character_Literal: - /* If a Entity is present, it means that this was one of the - literals in a user-defined character type. In that case, - just return the value in the CONST_DECL. Otherwise, use the - character code. In that case, the base type should be an - INTEGER_TYPE, but we won't bother checking for that. */ - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - if (Present (Entity (gnat_node))) - gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node))); - else - gnu_result - = build_int_cst_type - (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node))); - break; - - case N_Real_Literal: - /* If this is of a fixed-point type, the value we want is the - value of the corresponding integer. */ - if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind)) - { - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node), - gnu_result_type); - gcc_assert (!TREE_OVERFLOW (gnu_result)); - } - - /* We should never see a Vax_Float type literal, since the front end - is supposed to transform these using appropriate conversions */ - else if (Vax_Float (Underlying_Type (Etype (gnat_node)))) - gcc_unreachable (); - - else - { - Ureal ur_realval = Realval (gnat_node); - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - /* If the real value is zero, so is the result. Otherwise, - convert it to a machine number if it isn't already. That - forces BASE to 0 or 2 and simplifies the rest of our logic. */ - if (UR_Is_Zero (ur_realval)) - gnu_result = convert (gnu_result_type, integer_zero_node); - else - { - if (!Is_Machine_Number (gnat_node)) - ur_realval - = Machine (Base_Type (Underlying_Type (Etype (gnat_node))), - ur_realval, Round_Even, gnat_node); - - gnu_result - = UI_To_gnu (Numerator (ur_realval), gnu_result_type); - - /* If we have a base of zero, divide by the denominator. - Otherwise, the base must be 2 and we scale the value, which - we know can fit in the mantissa of the type (hence the use - of that type above). */ - if (No (Rbase (ur_realval))) - gnu_result - = build_binary_op (RDIV_EXPR, - get_base_type (gnu_result_type), - gnu_result, - UI_To_gnu (Denominator (ur_realval), - gnu_result_type)); - else - { - REAL_VALUE_TYPE tmp; - - gcc_assert (Rbase (ur_realval) == 2); - real_ldexp (&tmp, &TREE_REAL_CST (gnu_result), - - UI_To_Int (Denominator (ur_realval))); - gnu_result = build_real (gnu_result_type, tmp); - } - } - - /* Now see if we need to negate the result. Do it this way to - properly handle -0. */ - if (UR_Is_Negative (Realval (gnat_node))) - gnu_result - = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type), - gnu_result); - } - - break; - - case N_String_Literal: - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR) - { - String_Id gnat_string = Strval (gnat_node); - int length = String_Length (gnat_string); - int i; - char *string; - if (length >= ALLOCA_THRESHOLD) - string = xmalloc (length + 1); /* in case of large strings */ - else - string = (char *) alloca (length + 1); - - /* Build the string with the characters in the literal. Note - that Ada strings are 1-origin. */ - for (i = 0; i < length; i++) - string[i] = Get_String_Char (gnat_string, i + 1); - - /* Put a null at the end of the string in case it's in a context - where GCC will want to treat it as a C string. */ - string[i] = 0; - - gnu_result = build_string (length, string); - - /* Strings in GCC don't normally have types, but we want - this to not be converted to the array type. */ - TREE_TYPE (gnu_result) = gnu_result_type; - - if (length >= ALLOCA_THRESHOLD) /* free if heap-allocated */ - free (string); - } - else - { - /* Build a list consisting of each character, then make - the aggregate. */ - String_Id gnat_string = Strval (gnat_node); - int length = String_Length (gnat_string); - int i; - tree gnu_list = NULL_TREE; - tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type)); - - for (i = 0; i < length; i++) - { - gnu_list - = tree_cons (gnu_idx, - build_int_cst (TREE_TYPE (gnu_result_type), - Get_String_Char (gnat_string, - i + 1)), - gnu_list); - - gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node, - 0); - } - - gnu_result - = gnat_build_constructor (gnu_result_type, nreverse (gnu_list)); - } - break; - - case N_Pragma: - gnu_result = Pragma_to_gnu (gnat_node); - break; - - /**************************************/ - /* Chapter 3: Declarations and Types: */ - /**************************************/ - - case N_Subtype_Declaration: - case N_Full_Type_Declaration: - case N_Incomplete_Type_Declaration: - case N_Private_Type_Declaration: - case N_Private_Extension_Declaration: - case N_Task_Type_Declaration: - process_type (Defining_Entity (gnat_node)); - gnu_result = alloc_stmt_list (); - break; - - case N_Object_Declaration: - case N_Exception_Declaration: - gnat_temp = Defining_Entity (gnat_node); - gnu_result = alloc_stmt_list (); - - /* If we are just annotating types and this object has an unconstrained - or task type, don't elaborate it. */ - if (type_annotate_only - && (((Is_Array_Type (Etype (gnat_temp)) - || Is_Record_Type (Etype (gnat_temp))) - && !Is_Constrained (Etype (gnat_temp))) - || Is_Concurrent_Type (Etype (gnat_temp)))) - break; - - if (Present (Expression (gnat_node)) - && !(Nkind (gnat_node) == N_Object_Declaration - && No_Initialization (gnat_node)) - && (!type_annotate_only - || Compile_Time_Known_Value (Expression (gnat_node)))) - { - gnu_expr = gnat_to_gnu (Expression (gnat_node)); - if (Do_Range_Check (Expression (gnat_node))) - gnu_expr = emit_range_check (gnu_expr, Etype (gnat_temp)); - - /* If this object has its elaboration delayed, we must force - evaluation of GNU_EXPR right now and save it for when the object - is frozen. */ - if (Present (Freeze_Node (gnat_temp))) - { - if ((Is_Public (gnat_temp) || global_bindings_p ()) - && !TREE_CONSTANT (gnu_expr)) - gnu_expr - = create_var_decl (create_concat_name (gnat_temp, "init"), - NULL_TREE, TREE_TYPE (gnu_expr), - gnu_expr, false, Is_Public (gnat_temp), - false, false, NULL, gnat_temp); - else - gnu_expr = maybe_variable (gnu_expr); - - save_gnu_tree (gnat_node, gnu_expr, true); - } - } - else - gnu_expr = NULL_TREE; - - if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK) - gnu_expr = NULL_TREE; - - if (No (Freeze_Node (gnat_temp))) - gnat_to_gnu_entity (gnat_temp, gnu_expr, 1); - break; - - case N_Object_Renaming_Declaration: - gnat_temp = Defining_Entity (gnat_node); - - /* Don't do anything if this renaming is handled by the front end or if - we are just annotating types and this object has a composite or task - type, don't elaborate it. We return the result in case it has any - SAVE_EXPRs in it that need to be evaluated here. */ - if (!Is_Renaming_Of_Object (gnat_temp) - && ! (type_annotate_only - && (Is_Array_Type (Etype (gnat_temp)) - || Is_Record_Type (Etype (gnat_temp)) - || Is_Concurrent_Type (Etype (gnat_temp))))) - gnu_result - = gnat_to_gnu_entity (gnat_temp, - gnat_to_gnu (Renamed_Object (gnat_temp)), 1); - else - gnu_result = alloc_stmt_list (); - break; - - case N_Implicit_Label_Declaration: - gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1); - gnu_result = alloc_stmt_list (); - break; - - case N_Exception_Renaming_Declaration: - case N_Number_Declaration: - case N_Package_Renaming_Declaration: - case N_Subprogram_Renaming_Declaration: - /* These are fully handled in the front end. */ - gnu_result = alloc_stmt_list (); - break; - - /*************************************/ - /* Chapter 4: Names and Expressions: */ - /*************************************/ - - case N_Explicit_Dereference: - gnu_result = gnat_to_gnu (Prefix (gnat_node)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); - break; - - case N_Indexed_Component: - { - tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node)); - tree gnu_type; - int ndim; - int i; - Node_Id *gnat_expr_array; - - gnu_array_object = maybe_implicit_deref (gnu_array_object); - gnu_array_object = maybe_unconstrained_array (gnu_array_object); - - /* If we got a padded type, remove it too. */ - if (TREE_CODE (TREE_TYPE (gnu_array_object)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object))) - gnu_array_object - = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))), - gnu_array_object); - - gnu_result = gnu_array_object; - - /* First compute the number of dimensions of the array, then - fill the expression array, the order depending on whether - this is a Convention_Fortran array or not. */ - for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object); - TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)); - ndim++, gnu_type = TREE_TYPE (gnu_type)) - ; - - gnat_expr_array = (Node_Id *) alloca (ndim * sizeof (Node_Id)); - - if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object))) - for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node)); - i >= 0; - i--, gnat_temp = Next (gnat_temp)) - gnat_expr_array[i] = gnat_temp; - else - for (i = 0, gnat_temp = First (Expressions (gnat_node)); - i < ndim; - i++, gnat_temp = Next (gnat_temp)) - gnat_expr_array[i] = gnat_temp; - - for (i = 0, gnu_type = TREE_TYPE (gnu_array_object); - i < ndim; i++, gnu_type = TREE_TYPE (gnu_type)) - { - gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); - gnat_temp = gnat_expr_array[i]; - gnu_expr = gnat_to_gnu (gnat_temp); - - if (Do_Range_Check (gnat_temp)) - gnu_expr - = emit_index_check - (gnu_array_object, gnu_expr, - TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))), - TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))); - - gnu_result = build_binary_op (ARRAY_REF, NULL_TREE, - gnu_result, gnu_expr); - } - } - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - break; - - case N_Slice: - { - tree gnu_type; - Node_Id gnat_range_node = Discrete_Range (gnat_node); - - gnu_result = gnat_to_gnu (Prefix (gnat_node)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - /* Do any implicit dereferences of the prefix and do any needed - range check. */ - gnu_result = maybe_implicit_deref (gnu_result); - gnu_result = maybe_unconstrained_array (gnu_result); - gnu_type = TREE_TYPE (gnu_result); - if (Do_Range_Check (gnat_range_node)) - { - /* Get the bounds of the slice. */ - tree gnu_index_type - = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type)); - tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type); - tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type); - /* Get the permitted bounds. */ - tree gnu_base_index_type - = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)); - tree gnu_base_min_expr = TYPE_MIN_VALUE (gnu_base_index_type); - tree gnu_base_max_expr = TYPE_MAX_VALUE (gnu_base_index_type); - tree gnu_expr_l, gnu_expr_h, gnu_expr_type; - - /* Check to see that the minimum slice value is in range. */ - gnu_expr_l = emit_index_check (gnu_result, - gnu_min_expr, - gnu_base_min_expr, - gnu_base_max_expr); - - /* Check to see that the maximum slice value is in range. */ - gnu_expr_h = emit_index_check (gnu_result, - gnu_max_expr, - gnu_base_min_expr, - gnu_base_max_expr); - - /* Derive a good type to convert everything to. */ - gnu_expr_type = get_base_type (TREE_TYPE (gnu_expr_l)); - - /* Build a compound expression that does the range checks and - returns the low bound. */ - gnu_expr = build_binary_op (COMPOUND_EXPR, gnu_expr_type, - convert (gnu_expr_type, gnu_expr_h), - convert (gnu_expr_type, gnu_expr_l)); - - /* Build a conditional expression that does the range check and - returns the low bound if the slice is not empty (max >= min), - and returns the naked low bound otherwise (max < min), unless - it is non-constant and the high bound is; this prevents VRP - from inferring bogus ranges on the unlikely path. */ - gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type, - build_binary_op (GE_EXPR, gnu_expr_type, - convert (gnu_expr_type, - gnu_max_expr), - convert (gnu_expr_type, - gnu_min_expr)), - gnu_expr, - TREE_CODE (gnu_min_expr) != INTEGER_CST - && TREE_CODE (gnu_max_expr) == INTEGER_CST - ? gnu_max_expr : gnu_min_expr); - } - else - /* Simply return the naked low bound. */ - gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type)); - - gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type, - gnu_result, gnu_expr); - } - break; - - case N_Selected_Component: - { - tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); - Entity_Id gnat_field = Entity (Selector_Name (gnat_node)); - Entity_Id gnat_pref_type = Etype (Prefix (gnat_node)); - tree gnu_field; - - while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind) - || IN (Ekind (gnat_pref_type), Access_Kind)) - { - if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)) - gnat_pref_type = Underlying_Type (gnat_pref_type); - else if (IN (Ekind (gnat_pref_type), Access_Kind)) - gnat_pref_type = Designated_Type (gnat_pref_type); - } - - gnu_prefix = maybe_implicit_deref (gnu_prefix); - - /* For discriminant references in tagged types always substitute the - corresponding discriminant as the actual selected component. */ - - if (Is_Tagged_Type (gnat_pref_type)) - while (Present (Corresponding_Discriminant (gnat_field))) - gnat_field = Corresponding_Discriminant (gnat_field); - - /* For discriminant references of untagged types always substitute the - corresponding stored discriminant. */ - - else if (Present (Corresponding_Discriminant (gnat_field))) - gnat_field = Original_Record_Component (gnat_field); - - /* Handle extracting the real or imaginary part of a complex. - The real part is the first field and the imaginary the last. */ - - if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE) - gnu_result = build_unary_op (Present (Next_Entity (gnat_field)) - ? REALPART_EXPR : IMAGPART_EXPR, - NULL_TREE, gnu_prefix); - else - { - gnu_field = gnat_to_gnu_field_decl (gnat_field); - - /* If there are discriminants, the prefix might be - evaluated more than once, which is a problem if it has - side-effects. */ - if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node))) - ? Designated_Type (Etype - (Prefix (gnat_node))) - : Etype (Prefix (gnat_node)))) - gnu_prefix = gnat_stabilize_reference (gnu_prefix, false); - - gnu_result - = build_component_ref (gnu_prefix, NULL_TREE, gnu_field, - (Nkind (Parent (gnat_node)) - == N_Attribute_Reference)); - } - - gcc_assert (gnu_result); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - } - break; - - case N_Attribute_Reference: - { - /* The attribute designator (like an enumeration value). */ - int attribute = Get_Attribute_Id (Attribute_Name (gnat_node)); - - /* The Elab_Spec and Elab_Body attributes are special in that - Prefix is a unit, not an object with a GCC equivalent. Similarly - for Elaborated, since that variable isn't otherwise known. */ - if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec) - return (create_subprog_decl - (create_concat_name (Entity (Prefix (gnat_node)), - attribute == Attr_Elab_Body - ? "elabb" : "elabs"), - NULL_TREE, void_ftype, NULL_TREE, false, true, true, NULL, - gnat_node)); - - gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attribute); - } - break; - - case N_Reference: - /* Like 'Access as far as we are concerned. */ - gnu_result = gnat_to_gnu (Prefix (gnat_node)); - gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - break; - - case N_Aggregate: - case N_Extension_Aggregate: - { - tree gnu_aggr_type; - - /* ??? It is wrong to evaluate the type now, but there doesn't - seem to be any other practical way of doing it. */ - - gcc_assert (!Expansion_Delayed (gnat_node)); - - gnu_aggr_type = gnu_result_type - = get_unpadded_type (Etype (gnat_node)); - - if (TREE_CODE (gnu_result_type) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type)) - gnu_aggr_type - = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type))); - - if (Null_Record_Present (gnat_node)) - gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE); - - else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE - || TREE_CODE (gnu_aggr_type) == UNION_TYPE) - gnu_result - = assoc_to_constructor (Etype (gnat_node), - First (Component_Associations (gnat_node)), - gnu_aggr_type); - else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE) - gnu_result = pos_to_constructor (First (Expressions (gnat_node)), - gnu_aggr_type, - Component_Type (Etype (gnat_node))); - else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE) - gnu_result - = build_binary_op - (COMPLEX_EXPR, gnu_aggr_type, - gnat_to_gnu (Expression (First - (Component_Associations (gnat_node)))), - gnat_to_gnu (Expression - (Next - (First (Component_Associations (gnat_node)))))); - else - gcc_unreachable (); - - gnu_result = convert (gnu_result_type, gnu_result); - } - break; - - case N_Null: - gnu_result = null_pointer_node; - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - break; - - case N_Type_Conversion: - case N_Qualified_Expression: - /* Get the operand expression. */ - gnu_result = gnat_to_gnu (Expression (gnat_node)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - gnu_result - = convert_with_check (Etype (gnat_node), gnu_result, - Do_Overflow_Check (gnat_node), - Do_Range_Check (Expression (gnat_node)), - Nkind (gnat_node) == N_Type_Conversion - && Float_Truncate (gnat_node)); - break; - - case N_Unchecked_Type_Conversion: - gnu_result = gnat_to_gnu (Expression (gnat_node)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - /* If the result is a pointer type, see if we are improperly - converting to a stricter alignment. */ - - if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type) - && IN (Ekind (Etype (gnat_node)), Access_Kind)) - { - unsigned int align = known_alignment (gnu_result); - tree gnu_obj_type = TREE_TYPE (gnu_result_type); - unsigned int oalign = TYPE_ALIGN (gnu_obj_type); - - if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type)) - post_error_ne_tree_2 - ("?source alignment (^) '< alignment of & (^)", - gnat_node, Designated_Type (Etype (gnat_node)), - size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT); - } - - gnu_result = unchecked_convert (gnu_result_type, gnu_result, - No_Truncation (gnat_node)); - break; - - case N_In: - case N_Not_In: - { - tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node)); - Node_Id gnat_range = Right_Opnd (gnat_node); - tree gnu_low; - tree gnu_high; - - /* GNAT_RANGE is either an N_Range node or an identifier - denoting a subtype. */ - if (Nkind (gnat_range) == N_Range) - { - gnu_low = gnat_to_gnu (Low_Bound (gnat_range)); - gnu_high = gnat_to_gnu (High_Bound (gnat_range)); - } - else if (Nkind (gnat_range) == N_Identifier - || Nkind (gnat_range) == N_Expanded_Name) - { - tree gnu_range_type = get_unpadded_type (Entity (gnat_range)); - - gnu_low = TYPE_MIN_VALUE (gnu_range_type); - gnu_high = TYPE_MAX_VALUE (gnu_range_type); - } - else - gcc_unreachable (); - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - /* If LOW and HIGH are identical, perform an equality test. - Otherwise, ensure that GNU_OBJECT is only evaluated once - and perform a full range test. */ - if (operand_equal_p (gnu_low, gnu_high, 0)) - gnu_result = build_binary_op (EQ_EXPR, gnu_result_type, - gnu_object, gnu_low); - else - { - gnu_object = protect_multiple_eval (gnu_object); - gnu_result - = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, - build_binary_op (GE_EXPR, gnu_result_type, - gnu_object, gnu_low), - build_binary_op (LE_EXPR, gnu_result_type, - gnu_object, gnu_high)); - } - - if (Nkind (gnat_node) == N_Not_In) - gnu_result = invert_truthvalue (gnu_result); - } - break; - - case N_Op_Divide: - gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node)); - gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type) - ? RDIV_EXPR - : (Rounded_Result (gnat_node) - ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR), - gnu_result_type, gnu_lhs, gnu_rhs); - break; - - case N_Op_Or: case N_Op_And: case N_Op_Xor: - /* These can either be operations on booleans or on modular types. - Fall through for boolean types since that's the way GNU_CODES is - set up. */ - if (IN (Ekind (Underlying_Type (Etype (gnat_node))), - Modular_Integer_Kind)) - { - enum tree_code code - = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR - : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR - : BIT_XOR_EXPR); - - gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node)); - gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = build_binary_op (code, gnu_result_type, - gnu_lhs, gnu_rhs); - break; - } - - /* ... fall through ... */ - - case N_Op_Eq: case N_Op_Ne: case N_Op_Lt: - case N_Op_Le: case N_Op_Gt: case N_Op_Ge: - case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply: - case N_Op_Mod: case N_Op_Rem: - case N_Op_Rotate_Left: - case N_Op_Rotate_Right: - case N_Op_Shift_Left: - case N_Op_Shift_Right: - case N_Op_Shift_Right_Arithmetic: - case N_And_Then: case N_Or_Else: - { - enum tree_code code = gnu_codes[Nkind (gnat_node)]; - bool ignore_lhs_overflow = false; - tree gnu_type; - - gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node)); - gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); - gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - /* If this is a comparison operator, convert any references to - an unconstrained array value into a reference to the - actual array. */ - if (TREE_CODE_CLASS (code) == tcc_comparison) - { - gnu_lhs = maybe_unconstrained_array (gnu_lhs); - gnu_rhs = maybe_unconstrained_array (gnu_rhs); - } - - /* If the result type is a private type, its full view may be a - numeric subtype. The representation we need is that of its base - type, given that it is the result of an arithmetic operation. */ - else if (Is_Private_Type (Etype (gnat_node))) - gnu_type = gnu_result_type - = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node)))); - - /* If this is a shift whose count is not guaranteed to be correct, - we need to adjust the shift count. */ - if (IN (Nkind (gnat_node), N_Op_Shift) - && !Shift_Count_OK (gnat_node)) - { - tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs)); - tree gnu_max_shift - = convert (gnu_count_type, TYPE_SIZE (gnu_type)); - - if (Nkind (gnat_node) == N_Op_Rotate_Left - || Nkind (gnat_node) == N_Op_Rotate_Right) - gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type, - gnu_rhs, gnu_max_shift); - else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic) - gnu_rhs - = build_binary_op - (MIN_EXPR, gnu_count_type, - build_binary_op (MINUS_EXPR, - gnu_count_type, - gnu_max_shift, - convert (gnu_count_type, - integer_one_node)), - gnu_rhs); - } - - /* For right shifts, the type says what kind of shift to do, - so we may need to choose a different type. In this case, - we have to ignore integer overflow lest it propagates all - the way down and causes a CE to be explicitly raised. */ - if (Nkind (gnat_node) == N_Op_Shift_Right - && !TYPE_UNSIGNED (gnu_type)) - { - gnu_type = gnat_unsigned_type (gnu_type); - ignore_lhs_overflow = true; - } - else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic - && TYPE_UNSIGNED (gnu_type)) - { - gnu_type = gnat_signed_type (gnu_type); - ignore_lhs_overflow = true; - } - - if (gnu_type != gnu_result_type) - { - tree gnu_old_lhs = gnu_lhs; - gnu_lhs = convert (gnu_type, gnu_lhs); - if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow) - TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs); - gnu_rhs = convert (gnu_type, gnu_rhs); - } - - gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs); - - /* If this is a logical shift with the shift count not verified, - we must return zero if it is too large. We cannot compensate - above in this case. */ - if ((Nkind (gnat_node) == N_Op_Shift_Left - || Nkind (gnat_node) == N_Op_Shift_Right) - && !Shift_Count_OK (gnat_node)) - gnu_result - = build_cond_expr - (gnu_type, - build_binary_op (GE_EXPR, integer_type_node, - gnu_rhs, - convert (TREE_TYPE (gnu_rhs), - TYPE_SIZE (gnu_type))), - convert (gnu_type, integer_zero_node), - gnu_result); - } - break; - - case N_Conditional_Expression: - { - tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node))); - tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node)))); - tree gnu_false - = gnat_to_gnu (Next (Next (First (Expressions (gnat_node))))); - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = build_cond_expr (gnu_result_type, - gnat_truthvalue_conversion (gnu_cond), - gnu_true, gnu_false); - } - break; - - case N_Op_Plus: - gnu_result = gnat_to_gnu (Right_Opnd (gnat_node)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - break; - - case N_Op_Not: - /* This case can apply to a boolean or a modular type. - Fall through for a boolean operand since GNU_CODES is set - up to handle this. */ - if (Is_Modular_Integer_Type (Etype (gnat_node)) - || (Ekind (Etype (gnat_node)) == E_Private_Type - && Is_Modular_Integer_Type (Full_View (Etype (gnat_node))))) - { - gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type, - gnu_expr); - break; - } - - /* ... fall through ... */ - - case N_Op_Minus: case N_Op_Abs: - gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node)); - - if (Ekind (Etype (gnat_node)) != E_Private_Type) - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - else - gnu_result_type = get_unpadded_type (Base_Type - (Full_View (Etype (gnat_node)))); - - gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)], - gnu_result_type, gnu_expr); - break; - - case N_Allocator: - { - tree gnu_init = 0; - tree gnu_type; - bool ignore_init_type = false; - - gnat_temp = Expression (gnat_node); - - /* The Expression operand can either be an N_Identifier or - Expanded_Name, which must represent a type, or a - N_Qualified_Expression, which contains both the object type and an - initial value for the object. */ - if (Nkind (gnat_temp) == N_Identifier - || Nkind (gnat_temp) == N_Expanded_Name) - gnu_type = gnat_to_gnu_type (Entity (gnat_temp)); - else if (Nkind (gnat_temp) == N_Qualified_Expression) - { - Entity_Id gnat_desig_type - = Designated_Type (Underlying_Type (Etype (gnat_node))); - - ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type); - gnu_init = gnat_to_gnu (Expression (gnat_temp)); - - gnu_init = maybe_unconstrained_array (gnu_init); - if (Do_Range_Check (Expression (gnat_temp))) - gnu_init = emit_range_check (gnu_init, gnat_desig_type); - - if (Is_Elementary_Type (gnat_desig_type) - || Is_Constrained (gnat_desig_type)) - { - gnu_type = gnat_to_gnu_type (gnat_desig_type); - gnu_init = convert (gnu_type, gnu_init); - } - else - { - gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp))); - if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) - gnu_type = TREE_TYPE (gnu_init); - - gnu_init = convert (gnu_type, gnu_init); - } - } - else - gcc_unreachable (); - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - return build_allocator (gnu_type, gnu_init, gnu_result_type, - Procedure_To_Call (gnat_node), - Storage_Pool (gnat_node), gnat_node, - ignore_init_type); - } - break; - - /***************************/ - /* Chapter 5: Statements: */ - /***************************/ - - case N_Label: - gnu_result = build1 (LABEL_EXPR, void_type_node, - gnat_to_gnu (Identifier (gnat_node))); - break; - - case N_Null_Statement: - gnu_result = alloc_stmt_list (); - break; - - case N_Assignment_Statement: - /* Get the LHS and RHS of the statement and convert any reference to an - unconstrained array into a reference to the underlying array. - If we are not to do range checking and the RHS is an N_Function_Call, - pass the LHS to the call function. */ - gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node))); - - /* If the type has a size that overflows, convert this into raise of - Storage_Error: execution shouldn't have gotten here anyway. */ - if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST - && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs)))) - gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node, - N_Raise_Storage_Error); - else if (Nkind (Expression (gnat_node)) == N_Function_Call - && !Do_Range_Check (Expression (gnat_node))) - gnu_result = call_to_gnu (Expression (gnat_node), - &gnu_result_type, gnu_lhs); - else - { - gnu_rhs - = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node))); - - /* If range check is needed, emit code to generate it */ - if (Do_Range_Check (Expression (gnat_node))) - gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node))); - - gnu_result - = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs); - } - break; - - case N_If_Statement: - { - tree *gnu_else_ptr; /* Point to put next "else if" or "else". */ - - /* Make the outer COND_EXPR. Avoid non-determinism. */ - gnu_result = build3 (COND_EXPR, void_type_node, - gnat_to_gnu (Condition (gnat_node)), - NULL_TREE, NULL_TREE); - COND_EXPR_THEN (gnu_result) - = build_stmt_group (Then_Statements (gnat_node), false); - TREE_SIDE_EFFECTS (gnu_result) = 1; - gnu_else_ptr = &COND_EXPR_ELSE (gnu_result); - - /* Now make a COND_EXPR for each of the "else if" parts. Put each - into the previous "else" part and point to where to put any - outer "else". Also avoid non-determinism. */ - if (Present (Elsif_Parts (gnat_node))) - for (gnat_temp = First (Elsif_Parts (gnat_node)); - Present (gnat_temp); gnat_temp = Next (gnat_temp)) - { - gnu_expr = build3 (COND_EXPR, void_type_node, - gnat_to_gnu (Condition (gnat_temp)), - NULL_TREE, NULL_TREE); - COND_EXPR_THEN (gnu_expr) - = build_stmt_group (Then_Statements (gnat_temp), false); - TREE_SIDE_EFFECTS (gnu_expr) = 1; - set_expr_location_from_node (gnu_expr, gnat_temp); - *gnu_else_ptr = gnu_expr; - gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr); - } - - *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false); - } - break; - - case N_Case_Statement: - gnu_result = Case_Statement_to_gnu (gnat_node); - break; - - case N_Loop_Statement: - gnu_result = Loop_Statement_to_gnu (gnat_node); - break; - - case N_Block_Statement: - start_stmt_group (); - gnat_pushlevel (); - process_decls (Declarations (gnat_node), Empty, Empty, true, true); - add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); - gnat_poplevel (); - gnu_result = end_stmt_group (); - - if (Present (Identifier (gnat_node))) - mark_out_of_scope (Entity (Identifier (gnat_node))); - break; - - case N_Exit_Statement: - gnu_result - = build2 (EXIT_STMT, void_type_node, - (Present (Condition (gnat_node)) - ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE), - (Present (Name (gnat_node)) - ? get_gnu_tree (Entity (Name (gnat_node))) - : TREE_VALUE (gnu_loop_label_stack))); - break; - - case N_Return_Statement: - { - /* The gnu function type of the subprogram currently processed. */ - tree gnu_subprog_type = TREE_TYPE (current_function_decl); - /* The return value from the subprogram. */ - tree gnu_ret_val = NULL_TREE; - /* The place to put the return value. */ - tree gnu_lhs; - - /* If we are dealing with a "return;" from an Ada procedure with - parameters passed by copy in copy out, we need to return a record - containing the final values of these parameters. If the list - contains only one entry, return just that entry. - - For a full description of the copy in copy out parameter mechanism, - see the part of the gnat_to_gnu_entity routine dealing with the - translation of subprograms. - - But if we have a return label defined, convert this into - a branch to that label. */ - - if (TREE_VALUE (gnu_return_label_stack)) - { - gnu_result = build1 (GOTO_EXPR, void_type_node, - TREE_VALUE (gnu_return_label_stack)); - break; - } - - else if (TYPE_CI_CO_LIST (gnu_subprog_type)) - { - gnu_lhs = DECL_RESULT (current_function_decl); - if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1) - gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type)); - else - gnu_ret_val - = gnat_build_constructor (TREE_TYPE (gnu_subprog_type), - TYPE_CI_CO_LIST (gnu_subprog_type)); - } - - /* If the Ada subprogram is a function, we just need to return the - expression. If the subprogram returns an unconstrained - array, we have to allocate a new version of the result and - return it. If we return by reference, return a pointer. */ - - else if (Present (Expression (gnat_node))) - { - /* If the current function returns by target pointer and we - are doing a call, pass that target to the call. */ - if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type) - && Nkind (Expression (gnat_node)) == N_Function_Call) - { - gnu_lhs - = build_unary_op (INDIRECT_REF, NULL_TREE, - DECL_ARGUMENTS (current_function_decl)); - gnu_result = call_to_gnu (Expression (gnat_node), - &gnu_result_type, gnu_lhs); - } - else - { - gnu_ret_val = gnat_to_gnu (Expression (gnat_node)); - - if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)) - /* The original return type was unconstrained so dereference - the TARGET pointer in the actual return value's type. */ - gnu_lhs - = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val), - DECL_ARGUMENTS (current_function_decl)); - else - gnu_lhs = DECL_RESULT (current_function_decl); - - /* Do not remove the padding from GNU_RET_VAL if the inner - type is self-referential since we want to allocate the fixed - size in that case. */ - if (TREE_CODE (gnu_ret_val) == COMPONENT_REF - && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P - (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))) - && (CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))) - gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0); - - if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type) - || By_Ref (gnat_node)) - gnu_ret_val - = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val); - - else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)) - { - gnu_ret_val = maybe_unconstrained_array (gnu_ret_val); - - /* We have two cases: either the function returns with - depressed stack or not. If not, we allocate on the - secondary stack. If so, we allocate in the stack frame. - if no copy is needed, the front end will set By_Ref, - which we handle in the case above. */ - if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type)) - gnu_ret_val - = build_allocator (TREE_TYPE (gnu_ret_val), - gnu_ret_val, - TREE_TYPE (gnu_subprog_type), - 0, -1, gnat_node, false); - else - gnu_ret_val - = build_allocator (TREE_TYPE (gnu_ret_val), - gnu_ret_val, - TREE_TYPE (gnu_subprog_type), - Procedure_To_Call (gnat_node), - Storage_Pool (gnat_node), - gnat_node, false); - } - } - } - else - /* If the Ada subprogram is a regular procedure, just return. */ - gnu_lhs = NULL_TREE; - - if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)) - { - if (gnu_ret_val) - gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, - gnu_lhs, gnu_ret_val); - add_stmt_with_node (gnu_result, gnat_node); - gnu_lhs = NULL_TREE; - } - - gnu_result = build_return_expr (gnu_lhs, gnu_ret_val); - } - break; - - case N_Goto_Statement: - gnu_result = build1 (GOTO_EXPR, void_type_node, - gnat_to_gnu (Name (gnat_node))); - break; - - /****************************/ - /* Chapter 6: Subprograms: */ - /****************************/ - - case N_Subprogram_Declaration: - /* Unless there is a freeze node, declare the subprogram. We consider - this a "definition" even though we're not generating code for - the subprogram because we will be making the corresponding GCC - node here. */ - - if (No (Freeze_Node (Defining_Entity (Specification (gnat_node))))) - gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)), - NULL_TREE, 1); - gnu_result = alloc_stmt_list (); - break; - - case N_Abstract_Subprogram_Declaration: - /* This subprogram doesn't exist for code generation purposes, but we - have to elaborate the types of any parameters and result, unless - they are imported types (nothing to generate in this case). */ - - /* Process the parameter types first. */ - - for (gnat_temp - = First_Formal_With_Extras - (Defining_Entity (Specification (gnat_node))); - Present (gnat_temp); - gnat_temp = Next_Formal_With_Extras (gnat_temp)) - if (Is_Itype (Etype (gnat_temp)) - && !From_With_Type (Etype (gnat_temp))) - gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); - - - /* Then the result type, set to Standard_Void_Type for procedures. */ - - { - Entity_Id gnat_temp_type - = Etype (Defining_Entity (Specification (gnat_node))); - - if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type)) - gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0); - } - - gnu_result = alloc_stmt_list (); - break; - - case N_Defining_Program_Unit_Name: - /* For a child unit identifier go up a level to get the - specification. We get this when we try to find the spec of - a child unit package that is the compilation unit being compiled. */ - gnu_result = gnat_to_gnu (Parent (gnat_node)); - break; - - case N_Subprogram_Body: - Subprogram_Body_to_gnu (gnat_node); - gnu_result = alloc_stmt_list (); - break; - - case N_Function_Call: - case N_Procedure_Call_Statement: - gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE); - break; - - /*************************/ - /* Chapter 7: Packages: */ - /*************************/ - - case N_Package_Declaration: - gnu_result = gnat_to_gnu (Specification (gnat_node)); - break; - - case N_Package_Specification: - - start_stmt_group (); - process_decls (Visible_Declarations (gnat_node), - Private_Declarations (gnat_node), Empty, true, true); - gnu_result = end_stmt_group (); - break; - - case N_Package_Body: - - /* If this is the body of a generic package - do nothing */ - if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package) - { - gnu_result = alloc_stmt_list (); - break; - } - - start_stmt_group (); - process_decls (Declarations (gnat_node), Empty, Empty, true, true); - - if (Present (Handled_Statement_Sequence (gnat_node))) - add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); - - gnu_result = end_stmt_group (); - break; - - /*********************************/ - /* Chapter 8: Visibility Rules: */ - /*********************************/ - - case N_Use_Package_Clause: - case N_Use_Type_Clause: - /* Nothing to do here - but these may appear in list of declarations */ - gnu_result = alloc_stmt_list (); - break; - - /***********************/ - /* Chapter 9: Tasks: */ - /***********************/ - - case N_Protected_Type_Declaration: - gnu_result = alloc_stmt_list (); - break; - - case N_Single_Task_Declaration: - gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1); - gnu_result = alloc_stmt_list (); - break; - - /***********************************************************/ - /* Chapter 10: Program Structure and Compilation Issues: */ - /***********************************************************/ - - case N_Compilation_Unit: - - /* This is not called for the main unit, which is handled in function - gigi above. */ - start_stmt_group (); - gnat_pushlevel (); - - Compilation_Unit_to_gnu (gnat_node); - gnu_result = alloc_stmt_list (); - break; - - case N_Subprogram_Body_Stub: - case N_Package_Body_Stub: - case N_Protected_Body_Stub: - case N_Task_Body_Stub: - /* Simply process whatever unit is being inserted. */ - gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node))); - break; - - case N_Subunit: - gnu_result = gnat_to_gnu (Proper_Body (gnat_node)); - break; - - /***************************/ - /* Chapter 11: Exceptions: */ - /***************************/ - - case N_Handled_Sequence_Of_Statements: - /* If there is an At_End procedure attached to this node, and the EH - mechanism is SJLJ, we must have at least a corresponding At_End - handler, unless the No_Exception_Handlers restriction is set. */ - gcc_assert (type_annotate_only - || Exception_Mechanism != Setjmp_Longjmp - || No (At_End_Proc (gnat_node)) - || Present (Exception_Handlers (gnat_node)) - || No_Exception_Handlers_Set ()); - - gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node); - break; - - case N_Exception_Handler: - if (Exception_Mechanism == Setjmp_Longjmp) - gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node); - else if (Exception_Mechanism == Back_End_Exceptions) - gnu_result = Exception_Handler_to_gnu_zcx (gnat_node); - else - gcc_unreachable (); - - break; - - case N_Push_Constraint_Error_Label: - push_exception_label_stack (&gnu_constraint_error_label_stack, - Exception_Label (gnat_node)); - break; - - case N_Push_Storage_Error_Label: - push_exception_label_stack (&gnu_storage_error_label_stack, - Exception_Label (gnat_node)); - break; - - case N_Push_Program_Error_Label: - push_exception_label_stack (&gnu_program_error_label_stack, - Exception_Label (gnat_node)); - break; - - case N_Pop_Constraint_Error_Label: - gnu_constraint_error_label_stack - = TREE_CHAIN (gnu_constraint_error_label_stack); - break; - - case N_Pop_Storage_Error_Label: - gnu_storage_error_label_stack - = TREE_CHAIN (gnu_storage_error_label_stack); - break; - - case N_Pop_Program_Error_Label: - gnu_program_error_label_stack - = TREE_CHAIN (gnu_program_error_label_stack); - break; - - /*******************************/ - /* Chapter 12: Generic Units: */ - /*******************************/ - - case N_Generic_Function_Renaming_Declaration: - case N_Generic_Package_Renaming_Declaration: - case N_Generic_Procedure_Renaming_Declaration: - case N_Generic_Package_Declaration: - case N_Generic_Subprogram_Declaration: - case N_Package_Instantiation: - case N_Procedure_Instantiation: - case N_Function_Instantiation: - /* These nodes can appear on a declaration list but there is nothing to - to be done with them. */ - gnu_result = alloc_stmt_list (); - break; - - /***************************************************/ - /* Chapter 13: Representation Clauses and */ - /* Implementation-Dependent Features: */ - /***************************************************/ - - case N_Attribute_Definition_Clause: - - gnu_result = alloc_stmt_list (); - - /* The only one we need deal with is for 'Address. For the others, SEM - puts the information elsewhere. We need only deal with 'Address - if the object has a Freeze_Node (which it never will currently). */ - if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address - || No (Freeze_Node (Entity (Name (gnat_node))))) - break; - - /* Get the value to use as the address and save it as the - equivalent for GNAT_TEMP. When the object is frozen, - gnat_to_gnu_entity will do the right thing. */ - save_gnu_tree (Entity (Name (gnat_node)), - gnat_to_gnu (Expression (gnat_node)), true); - break; - - case N_Enumeration_Representation_Clause: - case N_Record_Representation_Clause: - case N_At_Clause: - /* We do nothing with these. SEM puts the information elsewhere. */ - gnu_result = alloc_stmt_list (); - break; - - case N_Code_Statement: - if (!type_annotate_only) - { - tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node)); - tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE; - tree gnu_clobbers = NULL_TREE, tail; - bool allows_mem, allows_reg, fake; - int ninputs, noutputs, i; - const char **oconstraints; - const char *constraint; - char *clobber; - - /* First retrieve the 3 operand lists built by the front-end. */ - Setup_Asm_Outputs (gnat_node); - while (Present (gnat_temp = Asm_Output_Variable ())) - { - tree gnu_value = gnat_to_gnu (gnat_temp); - tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu - (Asm_Output_Constraint ())); - - gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs); - Next_Asm_Output (); - } - - Setup_Asm_Inputs (gnat_node); - while (Present (gnat_temp = Asm_Input_Value ())) - { - tree gnu_value = gnat_to_gnu (gnat_temp); - tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu - (Asm_Input_Constraint ())); - - gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs); - Next_Asm_Input (); - } - - Clobber_Setup (gnat_node); - while ((clobber = Clobber_Get_Next ())) - gnu_clobbers - = tree_cons (NULL_TREE, - build_string (strlen (clobber) + 1, clobber), - gnu_clobbers); - - /* Then perform some standard checking and processing on the - operands. In particular, mark them addressable if needed. */ - gnu_outputs = nreverse (gnu_outputs); - noutputs = list_length (gnu_outputs); - gnu_inputs = nreverse (gnu_inputs); - ninputs = list_length (gnu_inputs); - oconstraints - = (const char **) alloca (noutputs * sizeof (const char *)); - - for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail)) - { - tree output = TREE_VALUE (tail); - constraint - = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail))); - oconstraints[i] = constraint; - - if (parse_output_constraint (&constraint, i, ninputs, noutputs, - &allows_mem, &allows_reg, &fake)) - { - /* If the operand is going to end up in memory, - mark it addressable. Note that we don't test - allows_mem like in the input case below; this - is modelled on the C front-end. */ - if (!allows_reg - && !gnat_mark_addressable (output)) - output = error_mark_node; - } - else - output = error_mark_node; - - TREE_VALUE (tail) = output; - } - - for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail)) - { - tree input = TREE_VALUE (tail); - constraint - = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail))); - - if (parse_input_constraint (&constraint, i, ninputs, noutputs, - 0, oconstraints, - &allows_mem, &allows_reg)) - { - /* If the operand is going to end up in memory, - mark it addressable. */ - if (!allows_reg && allows_mem - && !gnat_mark_addressable (input)) - input = error_mark_node; - } - else - input = error_mark_node; - - TREE_VALUE (tail) = input; - } - - gnu_result = build4 (ASM_EXPR, void_type_node, - gnu_template, gnu_outputs, - gnu_inputs, gnu_clobbers); - ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node); - } - else - gnu_result = alloc_stmt_list (); - - break; - - /***************************************************/ - /* Added Nodes */ - /***************************************************/ - - case N_Freeze_Entity: - start_stmt_group (); - process_freeze_entity (gnat_node); - process_decls (Actions (gnat_node), Empty, Empty, true, true); - gnu_result = end_stmt_group (); - break; - - case N_Itype_Reference: - if (!present_gnu_tree (Itype (gnat_node))) - process_type (Itype (gnat_node)); - - gnu_result = alloc_stmt_list (); - break; - - case N_Free_Statement: - if (!type_annotate_only) - { - tree gnu_ptr = gnat_to_gnu (Expression (gnat_node)); - tree gnu_ptr_type = TREE_TYPE (gnu_ptr); - tree gnu_obj_type; - tree gnu_actual_obj_type = 0; - tree gnu_obj_size; - unsigned int align; - unsigned int default_allocator_alignment - = get_target_default_allocator_alignment () * BITS_PER_UNIT; - - /* If this is a thin pointer, we must dereference it to create - a fat pointer, then go back below to a thin pointer. The - reason for this is that we need a fat pointer someplace in - order to properly compute the size. */ - if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr))) - gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE, - build_unary_op (INDIRECT_REF, NULL_TREE, - gnu_ptr)); - - /* If this is an unconstrained array, we know the object must - have been allocated with the template in front of the object. - So pass the template address, but get the total size. Do this - by converting to a thin pointer. */ - if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) - gnu_ptr - = convert (build_pointer_type - (TYPE_OBJECT_RECORD_TYPE - (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))), - gnu_ptr); - - gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr)); - - if (Present (Actual_Designated_Subtype (gnat_node))) - { - gnu_actual_obj_type - = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node)); - - if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)) - gnu_actual_obj_type - = build_unc_object_type_from_ptr (gnu_ptr_type, - gnu_actual_obj_type, - get_identifier ("DEALLOC")); - } - else - gnu_actual_obj_type = gnu_obj_type; - - gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type); - align = TYPE_ALIGN (gnu_obj_type); - - if (TREE_CODE (gnu_obj_type) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type)) - { - tree gnu_char_ptr_type = build_pointer_type (char_type_node); - tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type)); - tree gnu_byte_offset - = convert (sizetype, - size_diffop (size_zero_node, gnu_pos)); - gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset); - - gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr); - gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type, - gnu_ptr, gnu_byte_offset); - } - - /* If the object was allocated from the default storage pool, the - alignement was greater than what the allocator provides, and this - is not a fat or thin pointer, what we have in gnu_ptr here is an - address dynamically adjusted to match the alignment requirement - (see build_allocator). What we need to pass to free is the - initial allocator's return value, which has been stored just in - front of the block we have. */ - - if (No (Procedure_To_Call (gnat_node)) - && align > default_allocator_alignment - && ! TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)) - { - /* We set GNU_PTR - as * (void **)((void *)GNU_PTR - (void *)sizeof(void *)) - in two steps: */ - - /* GNU_PTR (void *) - = (void *)GNU_PTR - (void *)sizeof (void *)) */ - gnu_ptr - = build_binary_op - (POINTER_PLUS_EXPR, ptr_void_type_node, - convert (ptr_void_type_node, gnu_ptr), - size_int (-POINTER_SIZE/BITS_PER_UNIT)); - - /* GNU_PTR (void *) = *(void **)GNU_PTR */ - gnu_ptr - = build_unary_op - (INDIRECT_REF, NULL_TREE, - convert (build_pointer_type (ptr_void_type_node), - gnu_ptr)); - } - - gnu_result = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align, - Procedure_To_Call (gnat_node), - Storage_Pool (gnat_node), - gnat_node); - } - break; - - case N_Raise_Constraint_Error: - case N_Raise_Program_Error: - case N_Raise_Storage_Error: - if (type_annotate_only) - { - gnu_result = alloc_stmt_list (); - break; - } - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result - = build_call_raise (UI_To_Int (Reason (gnat_node)), gnat_node, - Nkind (gnat_node)); - - /* If the type is VOID, this is a statement, so we need to - generate the code for the call. Handle a Condition, if there - is one. */ - if (TREE_CODE (gnu_result_type) == VOID_TYPE) - { - set_expr_location_from_node (gnu_result, gnat_node); - - if (Present (Condition (gnat_node))) - gnu_result = build3 (COND_EXPR, void_type_node, - gnat_to_gnu (Condition (gnat_node)), - gnu_result, alloc_stmt_list ()); - } - else - gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result); - break; - - case N_Validate_Unchecked_Conversion: - { - Entity_Id gnat_target_type = Target_Type (gnat_node); - tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node)); - tree gnu_target_type = gnat_to_gnu_type (gnat_target_type); - - /* No need for any warning in this case. */ - if (!flag_strict_aliasing) - ; - - /* If the result is a pointer type, see if we are either converting - from a non-pointer or from a pointer to a type with a different - alias set and warn if so. If the result is defined in the same - unit as this unchecked conversion, we can allow this because we - can know to make the pointer type behave properly. */ - else if (POINTER_TYPE_P (gnu_target_type) - && !In_Same_Source_Unit (gnat_target_type, gnat_node) - && !No_Strict_Aliasing (Underlying_Type (gnat_target_type))) - { - tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type) - ? TREE_TYPE (gnu_source_type) - : NULL_TREE; - tree gnu_target_desig_type = TREE_TYPE (gnu_target_type); - - if ((TYPE_DUMMY_P (gnu_target_desig_type) - || get_alias_set (gnu_target_desig_type) != 0) - && (!POINTER_TYPE_P (gnu_source_type) - || (TYPE_DUMMY_P (gnu_source_desig_type) - != TYPE_DUMMY_P (gnu_target_desig_type)) - || (TYPE_DUMMY_P (gnu_source_desig_type) - && gnu_source_desig_type != gnu_target_desig_type) - || (get_alias_set (gnu_source_desig_type) - != get_alias_set (gnu_target_desig_type)))) - { - post_error_ne - ("?possible aliasing problem for type&", - gnat_node, Target_Type (gnat_node)); - post_error - ("\\?use -fno-strict-aliasing switch for references", - gnat_node); - post_error_ne - ("\\?or use `pragma No_Strict_Aliasing (&);`", - gnat_node, Target_Type (gnat_node)); - } - } - - /* But if the result is a fat pointer type, we have no mechanism to - do that, so we unconditionally warn in problematic cases. */ - else if (TYPE_FAT_POINTER_P (gnu_target_type)) - { - tree gnu_source_array_type - = TYPE_FAT_POINTER_P (gnu_source_type) - ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type))) - : NULL_TREE; - tree gnu_target_array_type - = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type))); - - if ((TYPE_DUMMY_P (gnu_target_array_type) - || get_alias_set (gnu_target_array_type) != 0) - && (!TYPE_FAT_POINTER_P (gnu_source_type) - || (TYPE_DUMMY_P (gnu_source_array_type) - != TYPE_DUMMY_P (gnu_target_array_type)) - || (TYPE_DUMMY_P (gnu_source_array_type) - && gnu_source_array_type != gnu_target_array_type) - || (get_alias_set (gnu_source_array_type) - != get_alias_set (gnu_target_array_type)))) - { - post_error_ne - ("?possible aliasing problem for type&", - gnat_node, Target_Type (gnat_node)); - post_error - ("\\?use -fno-strict-aliasing switch for references", - gnat_node); - } - } - } - gnu_result = alloc_stmt_list (); - break; - - case N_Raise_Statement: - case N_Function_Specification: - case N_Procedure_Specification: - case N_Op_Concat: - case N_Component_Association: - case N_Task_Body: - default: - gcc_assert (type_annotate_only); - gnu_result = alloc_stmt_list (); - } - - /* If we pushed our level as part of processing the elaboration routine, - pop it back now. */ - if (went_into_elab_proc) - { - add_stmt (gnu_result); - gnat_poplevel (); - gnu_result = end_stmt_group (); - current_function_decl = NULL_TREE; - } - - /* Set the location information on the result if it is a real expression. - References can be reused for multiple GNAT nodes and they would get - the location information of their last use. Note that we may have - no result if we tried to build a CALL_EXPR node to a procedure with - no side-effects and optimization is enabled. */ - if (gnu_result && EXPR_P (gnu_result) && !REFERENCE_CLASS_P (gnu_result)) - set_expr_location_from_node (gnu_result, gnat_node); - - /* If we're supposed to return something of void_type, it means we have - something we're elaborating for effect, so just return. */ - if (TREE_CODE (gnu_result_type) == VOID_TYPE) - return gnu_result; - - /* If the result is a constant that overflows, raise constraint error. */ - else if (TREE_CODE (gnu_result) == INTEGER_CST - && TREE_OVERFLOW (gnu_result)) - { - post_error ("Constraint_Error will be raised at run-time?", gnat_node); - - gnu_result - = build1 (NULL_EXPR, gnu_result_type, - build_call_raise (CE_Overflow_Check_Failed, gnat_node, - N_Raise_Constraint_Error)); - } - - /* If our result has side-effects and is of an unconstrained type, - make a SAVE_EXPR so that we can be sure it will only be referenced - once. Note we must do this before any conversions. */ - if (TREE_SIDE_EFFECTS (gnu_result) - && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE - || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))) - gnu_result = gnat_stabilize_reference (gnu_result, false); - - /* Now convert the result to the proper type. If the type is void or if - we have no result, return error_mark_node to show we have no result. - If the type of the result is correct or if we have a label (which doesn't - have any well-defined type), return our result. Also don't do the - conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size - since those are the cases where the front end may have the type wrong due - to "instantiating" the unconstrained record with discriminant values - or if this is a FIELD_DECL. If this is the Name of an assignment - statement or a parameter of a procedure call, return what we have since - the RHS has to be converted to our type there in that case, unless - GNU_RESULT_TYPE has a simpler size. Similarly, if the two types are - record types with the same name, the expression type has integral mode, - and GNU_RESULT_TYPE BLKmode, don't convert. This will be the case when - we are converting from a packable type to its actual type and we need - those conversions to be NOPs in order for assignments into these types to - work properly if the inner object is a bitfield and hence can't have - its address taken. Finally, don't convert integral types that are the - operand of an unchecked conversion since we need to ignore those - conversions (for 'Valid). Otherwise, convert the result to the proper - type. */ - - if (Present (Parent (gnat_node)) - && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement - && Name (Parent (gnat_node)) == gnat_node) - || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement - && Name (Parent (gnat_node)) != gnat_node) - || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion - && !AGGREGATE_TYPE_P (gnu_result_type) - && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))) - || Nkind (Parent (gnat_node)) == N_Parameter_Association) - && !(TYPE_SIZE (gnu_result_type) - && TYPE_SIZE (TREE_TYPE (gnu_result)) - && (AGGREGATE_TYPE_P (gnu_result_type) - == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))) - && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST - && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result))) - != INTEGER_CST)) - || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST - && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)) - && (CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (gnu_result)))))) - && !(TREE_CODE (gnu_result_type) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type)))) - { - /* In this case remove padding only if the inner object type is the - same as gnu_result_type or is of self-referential size (in that later - case it must be an object of unconstrained type with a default - discriminant). We want to avoid copying too much data. */ - if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)) - && (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))) - == gnu_result_type - || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS - (TREE_TYPE (gnu_result))))))) - gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), - gnu_result); - } - - else if (TREE_CODE (gnu_result) == LABEL_DECL - || TREE_CODE (gnu_result) == FIELD_DECL - || TREE_CODE (gnu_result) == ERROR_MARK - || (TYPE_SIZE (gnu_result_type) - && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST - && TREE_CODE (gnu_result) != INDIRECT_REF - && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))) - || ((TYPE_NAME (gnu_result_type) - == TYPE_NAME (TREE_TYPE (gnu_result))) - && TREE_CODE (gnu_result_type) == RECORD_TYPE - && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE - && TYPE_MODE (gnu_result_type) == BLKmode - && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result))) - == MODE_INT))) - { - /* Remove any padding record, but do nothing more in this case. */ - if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) - gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), - gnu_result); - } - - else if (gnu_result == error_mark_node - || gnu_result_type == void_type_node) - gnu_result = error_mark_node; - else if (gnu_result_type != TREE_TYPE (gnu_result)) - gnu_result = convert (gnu_result_type, gnu_result); - - /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */ - while ((TREE_CODE (gnu_result) == NOP_EXPR - || TREE_CODE (gnu_result) == NON_LVALUE_EXPR) - && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result)) - gnu_result = TREE_OPERAND (gnu_result, 0); - - return gnu_result; - } - - /* Subroutine of above to push the exception label stack. GNU_STACK is - a pointer to the stack to update and GNAT_LABEL, if present, is the - label to push onto the stack. */ - - static void - push_exception_label_stack (tree *gnu_stack, Entity_Id gnat_label) - { - tree gnu_label = (Present (gnat_label) - ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0) - : NULL_TREE); - - *gnu_stack = tree_cons (NULL_TREE, gnu_label, *gnu_stack); - } - - /* Record the current code position in GNAT_NODE. */ - - static void - record_code_position (Node_Id gnat_node) - { - tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE); - - add_stmt_with_node (stmt_stmt, gnat_node); - save_gnu_tree (gnat_node, stmt_stmt, true); - } - - /* Insert the code for GNAT_NODE at the position saved for that node. */ - - static void - insert_code_for (Node_Id gnat_node) - { - STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node); - save_gnu_tree (gnat_node, NULL_TREE, true); - } - - /* Start a new statement group chained to the previous group. */ - - void - start_stmt_group (void) - { - struct stmt_group *group = stmt_group_free_list; - - /* First see if we can get one from the free list. */ - if (group) - stmt_group_free_list = group->previous; - else - group = (struct stmt_group *) ggc_alloc (sizeof (struct stmt_group)); - - group->previous = current_stmt_group; - group->stmt_list = group->block = group->cleanups = NULL_TREE; - current_stmt_group = group; - } - - /* Add GNU_STMT to the current statement group. */ - - void - add_stmt (tree gnu_stmt) - { - append_to_statement_list (gnu_stmt, ¤t_stmt_group->stmt_list); - } - - /* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */ - - void - add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node) - { - if (Present (gnat_node)) - set_expr_location_from_node (gnu_stmt, gnat_node); - add_stmt (gnu_stmt); - } - - /* Add a declaration statement for GNU_DECL to the current statement group. - Get SLOC from Entity_Id. */ - - void - add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) - { - tree type = TREE_TYPE (gnu_decl); - tree gnu_stmt, gnu_init, t; - - /* If this is a variable that Gigi is to ignore, we may have been given - an ERROR_MARK. So test for it. We also might have been given a - reference for a renaming. So only do something for a decl. Also - ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */ - if (!DECL_P (gnu_decl) - || (TREE_CODE (gnu_decl) == TYPE_DECL - && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)) - return; - - gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl); - - /* If we are global, we don't want to actually output the DECL_EXPR for - this decl since we already have evaluated the expressions in the - sizes and positions as globals and doing it again would be wrong. */ - if (global_bindings_p ()) - { - /* Mark everything as used to prevent node sharing with subprograms. - Note that walk_tree knows how to deal with TYPE_DECL, but neither - VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */ - walk_tree (&gnu_stmt, mark_visited, NULL, NULL); - if (TREE_CODE (gnu_decl) == VAR_DECL - || TREE_CODE (gnu_decl) == CONST_DECL) - { - walk_tree (&DECL_SIZE (gnu_decl), mark_visited, NULL, NULL); - walk_tree (&DECL_SIZE_UNIT (gnu_decl), mark_visited, NULL, NULL); - walk_tree (&DECL_INITIAL (gnu_decl), mark_visited, NULL, NULL); - } - /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */ - if (TREE_CODE (gnu_decl) == TYPE_DECL - && (TREE_CODE (type) == RECORD_TYPE - || TREE_CODE (type) == UNION_TYPE - || TREE_CODE (type) == QUAL_UNION_TYPE) - && (t = TYPE_ADA_SIZE (type))) - walk_tree (&t, mark_visited, NULL, NULL); - } - else - add_stmt_with_node (gnu_stmt, gnat_entity); - - /* If this is a variable and an initializer is attached to it, it must be - valid for the context. Similar to init_const in create_var_decl_1. */ - if (TREE_CODE (gnu_decl) == VAR_DECL - && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE - && (TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (TREE_TYPE (gnu_init)) - || (TREE_STATIC (gnu_decl) - && !initializer_constant_valid_p (gnu_init, - TREE_TYPE (gnu_init))))) - { - /* If GNU_DECL has a padded type, convert it to the unpadded - type so the assignment is done properly. */ - if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) - t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl); - else - t = gnu_decl; - - gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, t, gnu_init); - - DECL_INITIAL (gnu_decl) = NULL_TREE; - if (TREE_READONLY (gnu_decl)) - { - TREE_READONLY (gnu_decl) = 0; - DECL_READONLY_ONCE_ELAB (gnu_decl) = 1; - } - - add_stmt_with_node (gnu_stmt, gnat_entity); - } - } - - /* Utility function to mark nodes with TREE_VISITED and types as having their - sized gimplified. Called from walk_tree. We use this to indicate all - variable sizes and positions in global types may not be shared by any - subprogram. */ - - static tree - mark_visited (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) - { - if (TREE_VISITED (*tp)) - *walk_subtrees = 0; - - /* Don't mark a dummy type as visited because we want to mark its sizes - and fields once it's filled in. */ - else if (!TYPE_IS_DUMMY_P (*tp)) - TREE_VISITED (*tp) = 1; - - if (TYPE_P (*tp)) - TYPE_SIZES_GIMPLIFIED (*tp) = 1; - - return NULL_TREE; - } - - /* Utility function to unshare expressions wrapped up in a SAVE_EXPR. */ - - static tree - unshare_save_expr (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) - { - tree t = *tp; - - if (TREE_CODE (t) == SAVE_EXPR) - TREE_OPERAND (t, 0) = unshare_expr (TREE_OPERAND (t, 0)); - - return NULL_TREE; - } - - /* Add GNU_CLEANUP, a cleanup action, to the current code group and - set its location to that of GNAT_NODE if present. */ - - static void - add_cleanup (tree gnu_cleanup, Node_Id gnat_node) - { - if (Present (gnat_node)) - set_expr_location_from_node (gnu_cleanup, gnat_node); - append_to_statement_list (gnu_cleanup, ¤t_stmt_group->cleanups); - } - - /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */ - - void - set_block_for_group (tree gnu_block) - { - gcc_assert (!current_stmt_group->block); - current_stmt_group->block = gnu_block; - } - - /* Return code corresponding to the current code group. It is normally - a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if - BLOCK or cleanups were set. */ - - tree - end_stmt_group (void) - { - struct stmt_group *group = current_stmt_group; - tree gnu_retval = group->stmt_list; - - /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there - are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK, - make a BIND_EXPR. Note that we nest in that because the cleanup may - reference variables in the block. */ - if (gnu_retval == NULL_TREE) - gnu_retval = alloc_stmt_list (); - - if (group->cleanups) - gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval, - group->cleanups); - - if (current_stmt_group->block) - gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block), - gnu_retval, group->block); - - /* Remove this group from the stack and add it to the free list. */ - current_stmt_group = group->previous; - group->previous = stmt_group_free_list; - stmt_group_free_list = group; - - return gnu_retval; - } - - /* Add a list of statements from GNAT_LIST, a possibly-empty list of - statements.*/ - - static void - add_stmt_list (List_Id gnat_list) - { - Node_Id gnat_node; - - if (Present (gnat_list)) - for (gnat_node = First (gnat_list); Present (gnat_node); - gnat_node = Next (gnat_node)) - add_stmt (gnat_to_gnu (gnat_node)); - } - - /* Build a tree from GNAT_LIST, a possibly-empty list of statements. - If BINDING_P is true, push and pop a binding level around the list. */ - - static tree - build_stmt_group (List_Id gnat_list, bool binding_p) - { - start_stmt_group (); - if (binding_p) - gnat_pushlevel (); - - add_stmt_list (gnat_list); - if (binding_p) - gnat_poplevel (); - - return end_stmt_group (); - } - - /* Push and pop routines for stacks. We keep a free list around so we - don't waste tree nodes. */ - - static void - push_stack (tree *gnu_stack_ptr, tree gnu_purpose, tree gnu_value) - { - tree gnu_node = gnu_stack_free_list; - - if (gnu_node) - { - gnu_stack_free_list = TREE_CHAIN (gnu_node); - TREE_CHAIN (gnu_node) = *gnu_stack_ptr; - TREE_PURPOSE (gnu_node) = gnu_purpose; - TREE_VALUE (gnu_node) = gnu_value; - } - else - gnu_node = tree_cons (gnu_purpose, gnu_value, *gnu_stack_ptr); - - *gnu_stack_ptr = gnu_node; - } - - static void - pop_stack (tree *gnu_stack_ptr) - { - tree gnu_node = *gnu_stack_ptr; - - *gnu_stack_ptr = TREE_CHAIN (gnu_node); - TREE_CHAIN (gnu_node) = gnu_stack_free_list; - gnu_stack_free_list = gnu_node; - } - - /* Generate GIMPLE in place for the expression at *EXPR_P. */ - - int - gnat_gimplify_expr (tree *expr_p, tree *pre_p, tree *post_p ATTRIBUTE_UNUSED) - { - tree expr = *expr_p; - tree op; - - if (IS_ADA_STMT (expr)) - return gnat_gimplify_stmt (expr_p); - - switch (TREE_CODE (expr)) - { - case NULL_EXPR: - /* If this is for a scalar, just make a VAR_DECL for it. If for - an aggregate, get a null pointer of the appropriate type and - dereference it. */ - if (AGGREGATE_TYPE_P (TREE_TYPE (expr))) - *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr), - convert (build_pointer_type (TREE_TYPE (expr)), - integer_zero_node)); - else - { - *expr_p = create_tmp_var (TREE_TYPE (expr), NULL); - TREE_NO_WARNING (*expr_p) = 1; - } - - gimplify_and_add (TREE_OPERAND (expr, 0), pre_p); - return GS_OK; - - case UNCONSTRAINED_ARRAY_REF: - /* We should only do this if we are just elaborating for side-effects, - but we can't know that yet. */ - *expr_p = TREE_OPERAND (*expr_p, 0); - return GS_OK; - - case ADDR_EXPR: - op = TREE_OPERAND (expr, 0); - - /* If we're taking the address of a constant CONSTRUCTOR, force it to - be put into static memory. We know it's going to be readonly given - the semantics we have and it's required to be static memory in - the case when the reference is in an elaboration procedure. */ - if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op)) - { - tree new_var = create_tmp_var (TREE_TYPE (op), "C"); - - TREE_READONLY (new_var) = 1; - TREE_STATIC (new_var) = 1; - TREE_ADDRESSABLE (new_var) = 1; - DECL_INITIAL (new_var) = op; - - TREE_OPERAND (expr, 0) = new_var; - recompute_tree_invariant_for_addr_expr (expr); - return GS_ALL_DONE; - } - - /* If we are taking the address of a SAVE_EXPR, we are typically - processing a misaligned argument to be passed by reference in a - procedure call. We just mark the operand as addressable + not - readonly here and let the common gimplifier code perform the - temporary creation, initialization, and "instantiation" in place of - the SAVE_EXPR in further operands, in particular in the copy back - code inserted after the call. */ - else if (TREE_CODE (op) == SAVE_EXPR) - { - TREE_ADDRESSABLE (op) = 1; - TREE_READONLY (op) = 0; - } - - /* Otherwise, if we are taking the address of something that is neither - reference, declaration, or constant, make a variable for the operand - here and then take its address. If we don't do it this way, we may - confuse the gimplifier because it needs to know the variable is - addressable at this point. This duplicates code in - internal_get_tmp_var, which is unfortunate. */ - else if (TREE_CODE_CLASS (TREE_CODE (op)) != tcc_reference - && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_declaration - && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_constant) - { - tree new_var = create_tmp_var (TREE_TYPE (op), "A"); - tree mod = build2 (GIMPLE_MODIFY_STMT, TREE_TYPE (op), new_var, op); - - TREE_ADDRESSABLE (new_var) = 1; - - if (EXPR_HAS_LOCATION (op)) - SET_EXPR_LOCUS (mod, EXPR_LOCUS (op)); - - gimplify_and_add (mod, pre_p); - TREE_OPERAND (expr, 0) = new_var; - recompute_tree_invariant_for_addr_expr (expr); - return GS_ALL_DONE; - } - - /* ... fall through ... */ - - default: - return GS_UNHANDLED; - } - } - - /* Generate GIMPLE in place for the statement at *STMT_P. */ - - static enum gimplify_status - gnat_gimplify_stmt (tree *stmt_p) - { - tree stmt = *stmt_p; - - switch (TREE_CODE (stmt)) - { - case STMT_STMT: - *stmt_p = STMT_STMT_STMT (stmt); - return GS_OK; - - case LOOP_STMT: - { - tree gnu_start_label = create_artificial_label (); - tree gnu_end_label = LOOP_STMT_LABEL (stmt); - - /* Set to emit the statements of the loop. */ - *stmt_p = NULL_TREE; - - /* We first emit the start label and then a conditional jump to - the end label if there's a top condition, then the body of the - loop, then a conditional branch to the end label, then the update, - if any, and finally a jump to the start label and the definition - of the end label. */ - append_to_statement_list (build1 (LABEL_EXPR, void_type_node, - gnu_start_label), - stmt_p); - - if (LOOP_STMT_TOP_COND (stmt)) - append_to_statement_list (build3 (COND_EXPR, void_type_node, - LOOP_STMT_TOP_COND (stmt), - alloc_stmt_list (), - build1 (GOTO_EXPR, - void_type_node, - gnu_end_label)), - stmt_p); - - append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p); - - if (LOOP_STMT_BOT_COND (stmt)) - append_to_statement_list (build3 (COND_EXPR, void_type_node, - LOOP_STMT_BOT_COND (stmt), - alloc_stmt_list (), - build1 (GOTO_EXPR, - void_type_node, - gnu_end_label)), - stmt_p); - - if (LOOP_STMT_UPDATE (stmt)) - append_to_statement_list (LOOP_STMT_UPDATE (stmt), stmt_p); - - append_to_statement_list (build1 (GOTO_EXPR, void_type_node, - gnu_start_label), - stmt_p); - append_to_statement_list (build1 (LABEL_EXPR, void_type_node, - gnu_end_label), - stmt_p); - return GS_OK; - } - - case EXIT_STMT: - /* Build a statement to jump to the corresponding end label, then - see if it needs to be conditional. */ - *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt)); - if (EXIT_STMT_COND (stmt)) - *stmt_p = build3 (COND_EXPR, void_type_node, - EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ()); - return GS_OK; - - default: - gcc_unreachable (); - } - } - - /* Force references to each of the entities in packages withed by GNAT_NODE. - Operate recursively but check that we aren't elaborating something more - than once. - - This routine is exclusively called in type_annotate mode, to compute DDA - information for types in withed units, for ASIS use. */ - - static void - elaborate_all_entities (Node_Id gnat_node) - { - Entity_Id gnat_with_clause, gnat_entity; - - /* Process each unit only once. As we trace the context of all relevant - units transitively, including generic bodies, we may encounter the - same generic unit repeatedly. */ - if (!present_gnu_tree (gnat_node)) - save_gnu_tree (gnat_node, integer_zero_node, true); - - /* Save entities in all context units. A body may have an implicit_with - on its own spec, if the context includes a child unit, so don't save - the spec twice. */ - for (gnat_with_clause = First (Context_Items (gnat_node)); - Present (gnat_with_clause); - gnat_with_clause = Next (gnat_with_clause)) - if (Nkind (gnat_with_clause) == N_With_Clause - && !present_gnu_tree (Library_Unit (gnat_with_clause)) - && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit))) - { - elaborate_all_entities (Library_Unit (gnat_with_clause)); - - if (Ekind (Entity (Name (gnat_with_clause))) == E_Package) - { - for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause))); - Present (gnat_entity); - gnat_entity = Next_Entity (gnat_entity)) - if (Is_Public (gnat_entity) - && Convention (gnat_entity) != Convention_Intrinsic - && Ekind (gnat_entity) != E_Package - && Ekind (gnat_entity) != E_Package_Body - && Ekind (gnat_entity) != E_Operator - && !(IN (Ekind (gnat_entity), Type_Kind) - && !Is_Frozen (gnat_entity)) - && !((Ekind (gnat_entity) == E_Procedure - || Ekind (gnat_entity) == E_Function) - && Is_Intrinsic_Subprogram (gnat_entity)) - && !IN (Ekind (gnat_entity), Named_Kind) - && !IN (Ekind (gnat_entity), Generic_Unit_Kind)) - gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); - } - else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package) - { - Node_Id gnat_body - = Corresponding_Body (Unit (Library_Unit (gnat_with_clause))); - - /* Retrieve compilation unit node of generic body. */ - while (Present (gnat_body) - && Nkind (gnat_body) != N_Compilation_Unit) - gnat_body = Parent (gnat_body); - - /* If body is available, elaborate its context. */ - if (Present (gnat_body)) - elaborate_all_entities (gnat_body); - } - } - - if (Nkind (Unit (gnat_node)) == N_Package_Body) - elaborate_all_entities (Library_Unit (gnat_node)); - } - - /* Do the processing of N_Freeze_Entity, GNAT_NODE. */ - - static void - process_freeze_entity (Node_Id gnat_node) - { - Entity_Id gnat_entity = Entity (gnat_node); - tree gnu_old; - tree gnu_new; - tree gnu_init - = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration - && present_gnu_tree (Declaration_Node (gnat_entity))) - ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE; - - /* If this is a package, need to generate code for the package. */ - if (Ekind (gnat_entity) == E_Package) - { - insert_code_for - (Parent (Corresponding_Body - (Parent (Declaration_Node (gnat_entity))))); - return; - } - - /* Check for old definition after the above call. This Freeze_Node - might be for one its Itypes. */ - gnu_old - = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0; - - /* If this entity has an Address representation clause, GNU_OLD is the - address, so discard it here. */ - if (Present (Address_Clause (gnat_entity))) - gnu_old = 0; - - /* Don't do anything for class-wide types they are always - transformed into their root type. */ - if (Ekind (gnat_entity) == E_Class_Wide_Type - || (Ekind (gnat_entity) == E_Class_Wide_Subtype - && Present (Equivalent_Type (gnat_entity)))) - return; - - /* Don't do anything for subprograms that may have been elaborated before - their freeze nodes. This can happen, for example because of an inner call - in an instance body, or a previous compilation of a spec for inlining - purposes. */ - if (gnu_old - && ((TREE_CODE (gnu_old) == FUNCTION_DECL - && (Ekind (gnat_entity) == E_Function - || Ekind (gnat_entity) == E_Procedure)) - || (gnu_old - && TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE - && Ekind (gnat_entity) == E_Subprogram_Type))) - return; - - /* If we have a non-dummy type old tree, we have nothing to do, except - aborting if this is the public view of a private type whose full view was - not delayed, as this node was never delayed as it should have been. We - let this happen for concurrent types and their Corresponding_Record_Type, - however, because each might legitimately be elaborated before it's own - freeze node, e.g. while processing the other. */ - if (gnu_old - && !(TREE_CODE (gnu_old) == TYPE_DECL - && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))) - { - gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) - && Present (Full_View (gnat_entity)) - && No (Freeze_Node (Full_View (gnat_entity)))) - || Is_Concurrent_Type (gnat_entity) - || (IN (Ekind (gnat_entity), Record_Kind) - && Is_Concurrent_Record_Type (gnat_entity))); - return; - } - - /* Reset the saved tree, if any, and elaborate the object or type for real. - If there is a full declaration, elaborate it and copy the type to - GNAT_ENTITY. Likewise if this is the record subtype corresponding to - a class wide type or subtype. */ - if (gnu_old) - { - save_gnu_tree (gnat_entity, NULL_TREE, false); - if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) - && Present (Full_View (gnat_entity)) - && present_gnu_tree (Full_View (gnat_entity))) - save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false); - if (Present (Class_Wide_Type (gnat_entity)) - && Class_Wide_Type (gnat_entity) != gnat_entity) - save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false); - } - - if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) - && Present (Full_View (gnat_entity))) - { - gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1); - - /* Propagate back-annotations from full view to partial view. */ - if (Unknown_Alignment (gnat_entity)) - Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity))); - - if (Unknown_Esize (gnat_entity)) - Set_Esize (gnat_entity, Esize (Full_View (gnat_entity))); - - if (Unknown_RM_Size (gnat_entity)) - Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity))); - - /* The above call may have defined this entity (the simplest example - of this is when we have a private enumeral type since the bounds - will have the public view. */ - if (!present_gnu_tree (gnat_entity)) - save_gnu_tree (gnat_entity, gnu_new, false); - if (Present (Class_Wide_Type (gnat_entity)) - && Class_Wide_Type (gnat_entity) != gnat_entity) - save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false); - } - else - gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1); - - /* If we've made any pointers to the old version of this type, we - have to update them. */ - if (gnu_old) - update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)), - TREE_TYPE (gnu_new)); - } - - /* Process the list of inlined subprograms of GNAT_NODE, which is an - N_Compilation_Unit. */ - - static void - process_inlined_subprograms (Node_Id gnat_node) - { - Entity_Id gnat_entity; - Node_Id gnat_body; - - /* If we can inline, generate RTL for all the inlined subprograms. - Define the entity first so we set DECL_EXTERNAL. */ - if (optimize > 0 && !flag_really_no_inline) - for (gnat_entity = First_Inlined_Subprogram (gnat_node); - Present (gnat_entity); - gnat_entity = Next_Inlined_Subprogram (gnat_entity)) - { - gnat_body = Parent (Declaration_Node (gnat_entity)); - - if (Nkind (gnat_body) != N_Subprogram_Body) - { - /* ??? This really should always be Present. */ - if (No (Corresponding_Body (gnat_body))) - continue; - - gnat_body - = Parent (Declaration_Node (Corresponding_Body (gnat_body))); - } - - if (Present (gnat_body)) - { - gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); - add_stmt (gnat_to_gnu (gnat_body)); - } - } - } - - /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present. - We make two passes, one to elaborate anything other than bodies (but - we declare a function if there was no spec). The second pass - elaborates the bodies. - - GNAT_END_LIST gives the element in the list past the end. Normally, - this is Empty, but can be First_Real_Statement for a - Handled_Sequence_Of_Statements. - - We make a complete pass through both lists if PASS1P is true, then make - the second pass over both lists if PASS2P is true. The lists usually - correspond to the public and private parts of a package. */ - - static void - process_decls (List_Id gnat_decls, List_Id gnat_decls2, - Node_Id gnat_end_list, bool pass1p, bool pass2p) - { - List_Id gnat_decl_array[2]; - Node_Id gnat_decl; - int i; - - gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2; - - if (pass1p) - for (i = 0; i <= 1; i++) - if (Present (gnat_decl_array[i])) - for (gnat_decl = First (gnat_decl_array[i]); - gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl)) - { - /* For package specs, we recurse inside the declarations, - thus taking the two pass approach inside the boundary. */ - if (Nkind (gnat_decl) == N_Package_Declaration - && (Nkind (Specification (gnat_decl) - == N_Package_Specification))) - process_decls (Visible_Declarations (Specification (gnat_decl)), - Private_Declarations (Specification (gnat_decl)), - Empty, true, false); - - /* Similarly for any declarations in the actions of a - freeze node. */ - else if (Nkind (gnat_decl) == N_Freeze_Entity) - { - process_freeze_entity (gnat_decl); - process_decls (Actions (gnat_decl), Empty, Empty, true, false); - } - - /* Package bodies with freeze nodes get their elaboration deferred - until the freeze node, but the code must be placed in the right - place, so record the code position now. */ - else if (Nkind (gnat_decl) == N_Package_Body - && Present (Freeze_Node (Corresponding_Spec (gnat_decl)))) - record_code_position (gnat_decl); - - else if (Nkind (gnat_decl) == N_Package_Body_Stub - && Present (Library_Unit (gnat_decl)) - && Present (Freeze_Node - (Corresponding_Spec - (Proper_Body (Unit - (Library_Unit (gnat_decl))))))) - record_code_position - (Proper_Body (Unit (Library_Unit (gnat_decl)))); - - /* We defer most subprogram bodies to the second pass. */ - else if (Nkind (gnat_decl) == N_Subprogram_Body) - { - if (Acts_As_Spec (gnat_decl)) - { - Node_Id gnat_subprog_id = Defining_Entity (gnat_decl); - - if (Ekind (gnat_subprog_id) != E_Generic_Procedure - && Ekind (gnat_subprog_id) != E_Generic_Function) - gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1); - } - } - /* For bodies and stubs that act as their own specs, the entity - itself must be elaborated in the first pass, because it may - be used in other declarations. */ - else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub) - { - Node_Id gnat_subprog_id = - Defining_Entity (Specification (gnat_decl)); - - if (Ekind (gnat_subprog_id) != E_Subprogram_Body - && Ekind (gnat_subprog_id) != E_Generic_Procedure - && Ekind (gnat_subprog_id) != E_Generic_Function) - gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1); - } - - /* Concurrent stubs stand for the corresponding subprogram bodies, - which are deferred like other bodies. */ - else if (Nkind (gnat_decl) == N_Task_Body_Stub - || Nkind (gnat_decl) == N_Protected_Body_Stub) - ; - else - add_stmt (gnat_to_gnu (gnat_decl)); - } - - /* Here we elaborate everything we deferred above except for package bodies, - which are elaborated at their freeze nodes. Note that we must also - go inside things (package specs and freeze nodes) the first pass did. */ - if (pass2p) - for (i = 0; i <= 1; i++) - if (Present (gnat_decl_array[i])) - for (gnat_decl = First (gnat_decl_array[i]); - gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl)) - { - if (Nkind (gnat_decl) == N_Subprogram_Body - || Nkind (gnat_decl) == N_Subprogram_Body_Stub - || Nkind (gnat_decl) == N_Task_Body_Stub - || Nkind (gnat_decl) == N_Protected_Body_Stub) - add_stmt (gnat_to_gnu (gnat_decl)); - - else if (Nkind (gnat_decl) == N_Package_Declaration - && (Nkind (Specification (gnat_decl) - == N_Package_Specification))) - process_decls (Visible_Declarations (Specification (gnat_decl)), - Private_Declarations (Specification (gnat_decl)), - Empty, false, true); - - else if (Nkind (gnat_decl) == N_Freeze_Entity) - process_decls (Actions (gnat_decl), Empty, Empty, false, true); - } - } - - /* Emit code for a range check. GNU_EXPR is the expression to be checked, - GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against - which we have to check. */ - - static tree - emit_range_check (tree gnu_expr, Entity_Id gnat_range_type) - { - tree gnu_range_type = get_unpadded_type (gnat_range_type); - tree gnu_low = TYPE_MIN_VALUE (gnu_range_type); - tree gnu_high = TYPE_MAX_VALUE (gnu_range_type); - tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr)); - - /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE, - we can't do anything since we might be truncating the bounds. No - check is needed in this case. */ - if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr)) - && (TYPE_PRECISION (gnu_compare_type) - < TYPE_PRECISION (get_base_type (gnu_range_type)))) - return gnu_expr; - - /* Checked expressions must be evaluated only once. */ - gnu_expr = protect_multiple_eval (gnu_expr); - - /* There's no good type to use here, so we might as well use - integer_type_node. Note that the form of the check is - (not (expr >= lo)) or (not (expr <= hi)) - the reason for this slightly convoluted form is that NaN's - are not considered to be in range in the float case. */ - return emit_check - (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, - invert_truthvalue - (build_binary_op (GE_EXPR, integer_type_node, - convert (gnu_compare_type, gnu_expr), - convert (gnu_compare_type, gnu_low))), - invert_truthvalue - (build_binary_op (LE_EXPR, integer_type_node, - convert (gnu_compare_type, gnu_expr), - convert (gnu_compare_type, - gnu_high)))), - gnu_expr, CE_Range_Check_Failed); - } - - /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object - which we are about to index, GNU_EXPR is the index expression to be - checked, GNU_LOW and GNU_HIGH are the lower and upper bounds - against which GNU_EXPR has to be checked. Note that for index - checking we cannot use the emit_range_check function (although very - similar code needs to be generated in both cases) since for index - checking the array type against which we are checking the indeces - may be unconstrained and consequently we need to retrieve the - actual index bounds from the array object itself - (GNU_ARRAY_OBJECT). The place where we need to do that is in - subprograms having unconstrained array formal parameters */ - - static tree - emit_index_check (tree gnu_array_object, - tree gnu_expr, - tree gnu_low, - tree gnu_high) - { - tree gnu_expr_check; - - /* Checked expressions must be evaluated only once. */ - gnu_expr = protect_multiple_eval (gnu_expr); - - /* Must do this computation in the base type in case the expression's - type is an unsigned subtypes. */ - gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); - - /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by - the object we are handling. */ - gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object); - gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object); - - /* There's no good type to use here, so we might as well use - integer_type_node. */ - return emit_check - (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, - build_binary_op (LT_EXPR, integer_type_node, - gnu_expr_check, - convert (TREE_TYPE (gnu_expr_check), - gnu_low)), - build_binary_op (GT_EXPR, integer_type_node, - gnu_expr_check, - convert (TREE_TYPE (gnu_expr_check), - gnu_high))), - gnu_expr, CE_Index_Check_Failed); - } - - /* GNU_COND contains the condition corresponding to an access, discriminant or - range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if - GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true. - REASON is the code that says why the exception was raised. */ - - static tree - emit_check (tree gnu_cond, tree gnu_expr, int reason) - { - tree gnu_call; - tree gnu_result; - - gnu_call = build_call_raise (reason, Empty, N_Raise_Constraint_Error); - - /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated - in front of the comparison in case it ends up being a SAVE_EXPR. Put the - whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak - out. */ - gnu_result = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond, - build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), - gnu_call, gnu_expr), - gnu_expr); - - /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and - protect it. Otherwise, show GNU_RESULT has no side effects: we - don't need to evaluate it just for the check. */ - if (TREE_SIDE_EFFECTS (gnu_expr)) - gnu_result - = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result); - else - TREE_SIDE_EFFECTS (gnu_result) = 0; - - /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing, - we will repeatedly do the test. It would be nice if GCC was able - to optimize this and only do it once. */ - return save_expr (gnu_result); - } - - /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing - overflow checks if OVERFLOW_P is nonzero and range checks if - RANGE_P is nonzero. GNAT_TYPE is known to be an integral type. - If TRUNCATE_P is nonzero, do a float to integer conversion with - truncation; otherwise round. */ - - static tree - convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, - bool rangep, bool truncatep) - { - tree gnu_type = get_unpadded_type (gnat_type); - tree gnu_in_type = TREE_TYPE (gnu_expr); - tree gnu_in_basetype = get_base_type (gnu_in_type); - tree gnu_base_type = get_base_type (gnu_type); - tree gnu_result = gnu_expr; - - /* If we are not doing any checks, the output is an integral type, and - the input is not a floating type, just do the conversion. This - shortcut is required to avoid problems with packed array types - and simplifies code in all cases anyway. */ - if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type) - && !FLOAT_TYPE_P (gnu_in_type)) - return convert (gnu_type, gnu_expr); - - /* First convert the expression to its base type. This - will never generate code, but makes the tests below much simpler. - But don't do this if converting from an integer type to an unconstrained - array type since then we need to get the bounds from the original - (unpacked) type. */ - if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE) - gnu_result = convert (gnu_in_basetype, gnu_result); - - /* If overflow checks are requested, we need to be sure the result will - fit in the output base type. But don't do this if the input - is integer and the output floating-point. */ - if (overflowp - && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype))) - { - /* Ensure GNU_EXPR only gets evaluated once. */ - tree gnu_input = protect_multiple_eval (gnu_result); - tree gnu_cond = integer_zero_node; - tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype); - tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype); - tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type); - tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type); - - /* Convert the lower bounds to signed types, so we're sure we're - comparing them properly. Likewise, convert the upper bounds - to unsigned types. */ - if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype)) - gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb); - - if (INTEGRAL_TYPE_P (gnu_in_basetype) - && !TYPE_UNSIGNED (gnu_in_basetype)) - gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub); - - if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type)) - gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb); - - if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type)) - gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub); - - /* Check each bound separately and only if the result bound - is tighter than the bound on the input type. Note that all the - types are base types, so the bounds must be constant. Also, - the comparison is done in the base type of the input, which - always has the proper signedness. First check for input - integer (which means output integer), output float (which means - both float), or mixed, in which case we always compare. - Note that we have to do the comparison which would *fail* in the - case of an error since if it's an FP comparison and one of the - values is a NaN or Inf, the comparison will fail. */ - if (INTEGRAL_TYPE_P (gnu_in_basetype) - ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb) - : (FLOAT_TYPE_P (gnu_base_type) - ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb), - TREE_REAL_CST (gnu_out_lb)) - : 1)) - gnu_cond - = invert_truthvalue - (build_binary_op (GE_EXPR, integer_type_node, - gnu_input, convert (gnu_in_basetype, - gnu_out_lb))); - - if (INTEGRAL_TYPE_P (gnu_in_basetype) - ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub) - : (FLOAT_TYPE_P (gnu_base_type) - ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub), - TREE_REAL_CST (gnu_in_lb)) - : 1)) - gnu_cond - = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond, - invert_truthvalue - (build_binary_op (LE_EXPR, integer_type_node, - gnu_input, - convert (gnu_in_basetype, - gnu_out_ub)))); - - if (!integer_zerop (gnu_cond)) - gnu_result = emit_check (gnu_cond, gnu_input, - CE_Overflow_Check_Failed); - } - - /* Now convert to the result base type. If this is a non-truncating - float-to-integer conversion, round. */ - if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype) - && !truncatep) - { - REAL_VALUE_TYPE half_minus_pred_half, pred_half; - tree gnu_conv, gnu_zero, gnu_comp, gnu_saved_result, calc_type; - tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half; - const struct real_format *fmt; - - /* The following calculations depend on proper rounding to even - of each arithmetic operation. In order to prevent excess - precision from spoiling this property, use the widest hardware - floating-point type. - - FIXME: For maximum efficiency, this should only be done for machines - and types where intermediates may have extra precision. */ - - calc_type = longest_float_type_node; - /* FIXME: Should not have padding in the first place */ - if (TREE_CODE (calc_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (calc_type)) - calc_type = TREE_TYPE (TYPE_FIELDS (calc_type)); - - /* Compute the exact value calc_type'Pred (0.5) at compile time. */ - fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type)); - real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type)); - REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf, - half_minus_pred_half); - gnu_pred_half = build_real (calc_type, pred_half); - - /* If the input is strictly negative, subtract this value - and otherwise add it from the input. For 0.5, the result - is exactly between 1.0 and the machine number preceding 1.0 - (for calc_type). Since the last bit of 1.0 is even, this 0.5 - will round to 1.0, while all other number with an absolute - value less than 0.5 round to 0.0. For larger numbers exactly - halfway between integers, rounding will always be correct as - the true mathematical result will be closer to the higher - integer compared to the lower one. So, this constant works - for all floating-point numbers. - - The reason to use the same constant with subtract/add instead - of a positive and negative constant is to allow the comparison - to be scheduled in parallel with retrieval of the constant and - conversion of the input to the calc_type (if necessary). - */ - - gnu_zero = convert (gnu_in_basetype, integer_zero_node); - gnu_saved_result = save_expr (gnu_result); - gnu_conv = convert (calc_type, gnu_saved_result); - gnu_comp = build2 (GE_EXPR, integer_type_node, - gnu_saved_result, gnu_zero); - gnu_add_pred_half - = build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half); - gnu_subtract_pred_half - = build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half); - gnu_result = build3 (COND_EXPR, calc_type, gnu_comp, - gnu_add_pred_half, gnu_subtract_pred_half); - } - - if (TREE_CODE (gnu_base_type) == INTEGER_TYPE - && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type) - && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF) - gnu_result = unchecked_convert (gnu_base_type, gnu_result, false); - else - gnu_result = convert (gnu_base_type, gnu_result); - - /* Finally, do the range check if requested. Note that if the - result type is a modular type, the range check is actually - an overflow check. */ - - if (rangep - || (TREE_CODE (gnu_base_type) == INTEGER_TYPE - && TYPE_MODULAR_P (gnu_base_type) && overflowp)) - gnu_result = emit_range_check (gnu_result, gnat_type); - - return convert (gnu_type, gnu_result); - } - - /* Return 1 if GNU_EXPR can be directly addressed. This is the case unless - it is an expression involving computation or if it involves a reference - to a bitfield or to a field not sufficiently aligned for its type. */ - - static bool - addressable_p (tree gnu_expr) - { - switch (TREE_CODE (gnu_expr)) - { - case VAR_DECL: - case PARM_DECL: - case FUNCTION_DECL: - case RESULT_DECL: - /* All DECLs are addressable: if they are in a register, we can force - them to memory. */ - return true; - - case UNCONSTRAINED_ARRAY_REF: - case INDIRECT_REF: - case CONSTRUCTOR: - case STRING_CST: - case INTEGER_CST: - case NULL_EXPR: - case SAVE_EXPR: - case CALL_EXPR: - return true; - - case COMPONENT_REF: - return (!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1)) - && (!STRICT_ALIGNMENT - /* Even with DECL_BIT_FIELD cleared, we have to ensure that - the field is sufficiently aligned, in case it is subject - to a pragma Component_Alignment. But we don't need to - check the alignment of the containing record, as it is - guaranteed to be not smaller than that of its most - aligned field that is not a bit-field. */ - || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1)) - >= TYPE_ALIGN (TREE_TYPE (gnu_expr))) - && addressable_p (TREE_OPERAND (gnu_expr, 0))); - - case ARRAY_REF: case ARRAY_RANGE_REF: - case REALPART_EXPR: case IMAGPART_EXPR: - case NOP_EXPR: - return addressable_p (TREE_OPERAND (gnu_expr, 0)); - - case CONVERT_EXPR: - return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr)) - && addressable_p (TREE_OPERAND (gnu_expr, 0))); - - case VIEW_CONVERT_EXPR: - { - /* This is addressable if we can avoid a copy. */ - tree type = TREE_TYPE (gnu_expr); - tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0)); - - return (((TYPE_MODE (type) == TYPE_MODE (inner_type) - && (!STRICT_ALIGNMENT - || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type) - || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT)) - || ((TYPE_MODE (type) == BLKmode - || TYPE_MODE (inner_type) == BLKmode) - && (!STRICT_ALIGNMENT - || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type) - || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT - || TYPE_ALIGN_OK (type) - || TYPE_ALIGN_OK (inner_type)))) - && addressable_p (TREE_OPERAND (gnu_expr, 0))); - } - - default: - return false; - } - } - - /* Do the processing for the declaration of a GNAT_ENTITY, a type. If - a separate Freeze node exists, delay the bulk of the processing. Otherwise - make a GCC type for GNAT_ENTITY and set up the correspondence. */ - - void - process_type (Entity_Id gnat_entity) - { - tree gnu_old - = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0; - tree gnu_new; - - /* If we are to delay elaboration of this type, just do any - elaborations needed for expressions within the declaration and - make a dummy type entry for this node and its Full_View (if - any) in case something points to it. Don't do this if it - has already been done (the only way that can happen is if - the private completion is also delayed). */ - if (Present (Freeze_Node (gnat_entity)) - || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) - && Present (Full_View (gnat_entity)) - && Freeze_Node (Full_View (gnat_entity)) - && !present_gnu_tree (Full_View (gnat_entity)))) - { - elaborate_entity (gnat_entity); - - if (!gnu_old) - { - tree gnu_decl = create_type_decl (get_entity_name (gnat_entity), - make_dummy_type (gnat_entity), - NULL, false, false, gnat_entity); - - save_gnu_tree (gnat_entity, gnu_decl, false); - if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) - && Present (Full_View (gnat_entity))) - save_gnu_tree (Full_View (gnat_entity), gnu_decl, false); - } - - return; - } - - /* If we saved away a dummy type for this node it means that this - made the type that corresponds to the full type of an incomplete - type. Clear that type for now and then update the type in the - pointers. */ - if (gnu_old) - { - gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL - && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))); - - save_gnu_tree (gnat_entity, NULL_TREE, false); - } - - /* Now fully elaborate the type. */ - gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1); - gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL); - - /* If we have an old type and we've made pointers to this type, - update those pointers. */ - if (gnu_old) - update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)), - TREE_TYPE (gnu_new)); - - /* If this is a record type corresponding to a task or protected type - that is a completion of an incomplete type, perform a similar update - on the type. */ - /* ??? Including protected types here is a guess. */ - - if (IN (Ekind (gnat_entity), Record_Kind) - && Is_Concurrent_Record_Type (gnat_entity) - && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity))) - { - tree gnu_task_old - = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)); - - save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity), - NULL_TREE, false); - save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity), - gnu_new, false); - - update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)), - TREE_TYPE (gnu_new)); - } - } - - /* GNAT_ENTITY is the type of the resulting constructors, - GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate, - and GNU_TYPE is the GCC type of the corresponding record. - - Return a CONSTRUCTOR to build the record. */ - - static tree - assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type) - { - tree gnu_list, gnu_result; - - /* We test for GNU_FIELD being empty in the case where a variant - was the last thing since we don't take things off GNAT_ASSOC in - that case. We check GNAT_ASSOC in case we have a variant, but it - has no fields. */ - - for (gnu_list = NULL_TREE; Present (gnat_assoc); - gnat_assoc = Next (gnat_assoc)) - { - Node_Id gnat_field = First (Choices (gnat_assoc)); - tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field)); - tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc)); - - /* The expander is supposed to put a single component selector name - in every record component association */ - gcc_assert (No (Next (gnat_field))); - - /* Ignore fields that have Corresponding_Discriminants since we'll - be setting that field in the parent. */ - if (Present (Corresponding_Discriminant (Entity (gnat_field))) - && Is_Tagged_Type (Scope (Entity (gnat_field)))) - continue; - - /* Also ignore discriminants of Unchecked_Unions. */ - else if (Is_Unchecked_Union (gnat_entity) - && Ekind (Entity (gnat_field)) == E_Discriminant) - continue; - - /* Before assigning a value in an aggregate make sure range checks - are done if required. Then convert to the type of the field. */ - if (Do_Range_Check (Expression (gnat_assoc))) - gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field)); - - gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr); - - /* Add the field and expression to the list. */ - gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list); - } - - gnu_result = extract_values (gnu_list, gnu_type); - - #ifdef ENABLE_CHECKING - { - tree gnu_field; - - /* Verify every enty in GNU_LIST was used. */ - for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field)) - gcc_assert (TREE_ADDRESSABLE (gnu_field)); - } - #endif - - return gnu_result; - } - - /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR - is the first element of an array aggregate. It may itself be an - aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type - corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type - of the array component. It is needed for range checking. */ - - static tree - pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type, - Entity_Id gnat_component_type) - { - tree gnu_expr_list = NULL_TREE; - tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type)); - tree gnu_expr; - - for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr)) - { - /* If the expression is itself an array aggregate then first build the - innermost constructor if it is part of our array (multi-dimensional - case). */ - - if (Nkind (gnat_expr) == N_Aggregate - && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type))) - gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)), - TREE_TYPE (gnu_array_type), - gnat_component_type); - else - { - gnu_expr = gnat_to_gnu (gnat_expr); - - /* before assigning the element to the array make sure it is - in range */ - if (Do_Range_Check (gnat_expr)) - gnu_expr = emit_range_check (gnu_expr, gnat_component_type); - } - - gnu_expr_list - = tree_cons (gnu_index, convert (TREE_TYPE (gnu_array_type), gnu_expr), - gnu_expr_list); - - gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0); - } - - return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list)); - } - - /* Subroutine of assoc_to_constructor: VALUES is a list of field associations, - some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting - of the associations that are from RECORD_TYPE. If we see an internal - record, make a recursive call to fill it in as well. */ - - static tree - extract_values (tree values, tree record_type) - { - tree result = NULL_TREE; - tree field, tem; - - for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field)) - { - tree value = 0; - - /* _Parent is an internal field, but may have values in the aggregate, - so check for values first. */ - if ((tem = purpose_member (field, values))) - { - value = TREE_VALUE (tem); - TREE_ADDRESSABLE (tem) = 1; - } - - else if (DECL_INTERNAL_P (field)) - { - value = extract_values (values, TREE_TYPE (field)); - if (TREE_CODE (value) == CONSTRUCTOR - && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value))) - value = 0; - } - else - /* If we have a record subtype, the names will match, but not the - actual FIELD_DECLs. */ - for (tem = values; tem; tem = TREE_CHAIN (tem)) - if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field)) - { - value = convert (TREE_TYPE (field), TREE_VALUE (tem)); - TREE_ADDRESSABLE (tem) = 1; - } - - if (!value) - continue; - - result = tree_cons (field, value, result); - } - - return gnat_build_constructor (record_type, nreverse (result)); - } - - /* EXP is to be treated as an array or record. Handle the cases when it is - an access object and perform the required dereferences. */ - - static tree - maybe_implicit_deref (tree exp) - { - /* If the type is a pointer, dereference it. */ - - if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp))) - exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp); - - /* If we got a padded type, remove it too. */ - if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (exp))) - exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp); - - return exp; - } - - /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */ - - tree - protect_multiple_eval (tree exp) - { - tree type = TREE_TYPE (exp); - - /* If this has no side effects, we don't need to do anything. */ - if (!TREE_SIDE_EFFECTS (exp)) - return exp; - - /* If it is a conversion, protect what's inside the conversion. - Similarly, if we're indirectly referencing something, we only - actually need to protect the address since the data itself can't - change in these situations. */ - else if (TREE_CODE (exp) == NON_LVALUE_EXPR - || TREE_CODE (exp) == NOP_EXPR || TREE_CODE (exp) == CONVERT_EXPR - || TREE_CODE (exp) == VIEW_CONVERT_EXPR - || TREE_CODE (exp) == INDIRECT_REF - || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF) - return build1 (TREE_CODE (exp), type, - protect_multiple_eval (TREE_OPERAND (exp, 0))); - - /* If EXP is a fat pointer or something that can be placed into a register, - just make a SAVE_EXPR. */ - if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode) - return save_expr (exp); - - /* Otherwise, dereference, protect the address, and re-reference. */ - else - return - build_unary_op (INDIRECT_REF, type, - save_expr (build_unary_op (ADDR_EXPR, - build_reference_type (type), - exp))); - } - - /* This is equivalent to stabilize_reference in tree.c, but we know how to - handle our own nodes and we take extra arguments. FORCE says whether to - force evaluation of everything. We set SUCCESS to true unless we walk - through something we don't know how to stabilize. */ - - tree - maybe_stabilize_reference (tree ref, bool force, bool *success) - { - tree type = TREE_TYPE (ref); - enum tree_code code = TREE_CODE (ref); - tree result; - - /* Assume we'll success unless proven otherwise. */ - *success = true; - - switch (code) - { - case CONST_DECL: - case VAR_DECL: - case PARM_DECL: - case RESULT_DECL: - /* No action is needed in this case. */ - return ref; - - case ADDR_EXPR: - case NOP_EXPR: - case CONVERT_EXPR: - case FLOAT_EXPR: - case FIX_TRUNC_EXPR: - case VIEW_CONVERT_EXPR: - result - = build1 (code, type, - maybe_stabilize_reference (TREE_OPERAND (ref, 0), force, - success)); - break; - - case INDIRECT_REF: - case UNCONSTRAINED_ARRAY_REF: - result = build1 (code, type, - gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0), - force)); - break; - - case COMPONENT_REF: - result = build3 (COMPONENT_REF, type, - maybe_stabilize_reference (TREE_OPERAND (ref, 0), force, - success), - TREE_OPERAND (ref, 1), NULL_TREE); - break; - - case BIT_FIELD_REF: - result = build3 (BIT_FIELD_REF, type, - maybe_stabilize_reference (TREE_OPERAND (ref, 0), force, - success), - gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), - force), - gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2), - force)); - break; - - case ARRAY_REF: - case ARRAY_RANGE_REF: - result = build4 (code, type, - maybe_stabilize_reference (TREE_OPERAND (ref, 0), force, - success), - gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), - force), - NULL_TREE, NULL_TREE); - break; - - case COMPOUND_EXPR: - result = gnat_stabilize_reference_1 (ref, force); - break; - - case CALL_EXPR: - /* This generates better code than the scheme in protect_multiple_eval - because large objects will be returned via invisible reference in - most ABIs so the temporary will directly be filled by the callee. */ - result = gnat_stabilize_reference_1 (ref, force); - break; - - case CONSTRUCTOR: - /* Constructors with 1 element are used extensively to formally - convert objects to special wrapping types. */ - if (TREE_CODE (type) == RECORD_TYPE - && VEC_length (constructor_elt, CONSTRUCTOR_ELTS (ref)) == 1) - { - tree index - = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->index; - tree value - = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->value; - result - = build_constructor_single (type, index, - gnat_stabilize_reference_1 (value, - force)); - } - else - { - *success = false; - return ref; - } - break; - - case ERROR_MARK: - ref = error_mark_node; - - /* ... Fallthru to failure ... */ - - /* If arg isn't a kind of lvalue we recognize, make no change. - Caller should recognize the error for an invalid lvalue. */ - default: - *success = false; - return ref; - } - - TREE_READONLY (result) = TREE_READONLY (ref); - - /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS attached to the initial - expression may not be sustained across some paths, such as the way via - build1 for INDIRECT_REF. We re-populate those flags here for the general - case, which is consistent with the GCC version of this routine. - - Special care should be taken regarding TREE_SIDE_EFFECTS, because some - paths introduce side effects where there was none initially (e.g. calls - to save_expr), and we also want to keep track of that. */ - - TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref); - TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref); - - return result; - } - - /* Wrapper around maybe_stabilize_reference, for common uses without - lvalue restrictions and without need to examine the success - indication. */ - - static tree - gnat_stabilize_reference (tree ref, bool force) - { - bool dummy; - return maybe_stabilize_reference (ref, force, &dummy); - } - - /* Similar to stabilize_reference_1 in tree.c, but supports an extra - arg to force a SAVE_EXPR for everything. */ - - static tree - gnat_stabilize_reference_1 (tree e, bool force) - { - enum tree_code code = TREE_CODE (e); - tree type = TREE_TYPE (e); - tree result; - - /* We cannot ignore const expressions because it might be a reference - to a const array but whose index contains side-effects. But we can - ignore things that are actual constant or that already have been - handled by this function. */ - - if (TREE_CONSTANT (e) || code == SAVE_EXPR) - return e; - - switch (TREE_CODE_CLASS (code)) - { - case tcc_exceptional: - case tcc_type: - case tcc_declaration: - case tcc_comparison: - case tcc_statement: - case tcc_expression: - case tcc_reference: - case tcc_vl_exp: - /* If this is a COMPONENT_REF of a fat pointer, save the entire - fat pointer. This may be more efficient, but will also allow - us to more easily find the match for the PLACEHOLDER_EXPR. */ - if (code == COMPONENT_REF - && TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0)))) - result = build3 (COMPONENT_REF, type, - gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), - force), - TREE_OPERAND (e, 1), TREE_OPERAND (e, 2)); - else if (TREE_SIDE_EFFECTS (e) || force) - return save_expr (e); - else - return e; - break; - - case tcc_constant: - /* Constants need no processing. In fact, we should never reach - here. */ - return e; - - case tcc_binary: - /* Recursively stabilize each operand. */ - result = build2 (code, type, - gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force), - gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), - force)); - break; - - case tcc_unary: - /* Recursively stabilize each operand. */ - result = build1 (code, type, - gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), - force)); - break; - - default: - gcc_unreachable (); - } - - TREE_READONLY (result) = TREE_READONLY (e); - - TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e); - TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e); - return result; - } - - /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code - location and false if it doesn't. In the former case, set the Gigi global - variable REF_FILENAME to the simple debug file name as given by sinput. */ - - bool - Sloc_to_locus (Source_Ptr Sloc, location_t *locus) - { - if (Sloc == No_Location) - return false; - - if (Sloc <= Standard_Location) - #ifdef USE_MAPPED_LOCATION - { - if (*locus == UNKNOWN_LOCATION) - *locus = BUILTINS_LOCATION; - return false; - } - else - { - Source_File_Index file = Get_Source_File_Index (Sloc); - Logical_Line_Number line = Get_Logical_Line_Number (Sloc); - Column_Number column = Get_Column_Number (Sloc); - struct line_map *map = &line_table->maps[file - 1]; - - /* Translate the location according to the line-map.h formula. */ - *locus = map->start_location - + ((line - map->to_line) << map->column_bits) - + (column & ((1 << map->column_bits) - 1)); - } - #else - return false; - - /* Use the identifier table to make a hashed, permanent copy of the filename, - since the name table gets reallocated after Gigi returns but before all - the debugging information is output. The __gnat_to_canonical_file_spec - call translates filenames from pragmas Source_Reference that contain host - style syntax not understood by gdb. */ - locus->file - = IDENTIFIER_POINTER - (get_identifier - (__gnat_to_canonical_file_spec - (Get_Name_String (Full_Debug_Name (Get_Source_File_Index (Sloc)))))); - - locus->line = Get_Logical_Line_Number (Sloc); - #endif - - ref_filename - = IDENTIFIER_POINTER - (get_identifier - (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));; - - return true; - } - - /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and - don't do anything if it doesn't correspond to a source location. */ - - static void - set_expr_location_from_node (tree node, Node_Id gnat_node) - { - location_t locus; - - if (!Sloc_to_locus (Sloc (gnat_node), &locus)) - return; - - set_expr_location (node, locus); - } - - /* Post an error message. MSG is the error message, properly annotated. - NODE is the node at which to post the error and the node to use for the - "&" substitution. */ - - void - post_error (const char *msg, Node_Id node) - { - String_Template temp; - Fat_Pointer fp; - - temp.Low_Bound = 1, temp.High_Bound = strlen (msg); - fp.Array = msg, fp.Bounds = &temp; - if (Present (node)) - Error_Msg_N (fp, node); - } - - /* Similar, but NODE is the node at which to post the error and ENT - is the node to use for the "&" substitution. */ - - void - post_error_ne (const char *msg, Node_Id node, Entity_Id ent) - { - String_Template temp; - Fat_Pointer fp; - - temp.Low_Bound = 1, temp.High_Bound = strlen (msg); - fp.Array = msg, fp.Bounds = &temp; - if (Present (node)) - Error_Msg_NE (fp, node, ent); - } - - /* Similar, but NODE is the node at which to post the error, ENT is the node - to use for the "&" substitution, and N is the number to use for the ^. */ - - void - post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n) - { - String_Template temp; - Fat_Pointer fp; - - temp.Low_Bound = 1, temp.High_Bound = strlen (msg); - fp.Array = msg, fp.Bounds = &temp; - Error_Msg_Uint_1 = UI_From_Int (n); - - if (Present (node)) - Error_Msg_NE (fp, node, ent); - } - - /* Similar to post_error_ne_num, but T is a GCC tree representing the - number to write. If the tree represents a constant that fits within - a host integer, the text inside curly brackets in MSG will be output - (presumably including a '^'). Otherwise that text will not be output - and the text inside square brackets will be output instead. */ - - void - post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t) - { - char *newmsg = alloca (strlen (msg) + 1); - String_Template temp = {1, 0}; - Fat_Pointer fp; - char start_yes, end_yes, start_no, end_no; - const char *p; - char *q; - - fp.Array = newmsg, fp.Bounds = &temp; - - if (host_integerp (t, 1) - #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT - && - compare_tree_int - (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0 - #endif - ) - { - Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1)); - start_yes = '{', end_yes = '}', start_no = '[', end_no = ']'; - } - else - start_yes = '[', end_yes = ']', start_no = '{', end_no = '}'; - - for (p = msg, q = newmsg; *p; p++) - { - if (*p == start_yes) - for (p++; *p != end_yes; p++) - *q++ = *p; - else if (*p == start_no) - for (p++; *p != end_no; p++) - ; - else - *q++ = *p; - } - - *q = 0; - - temp.High_Bound = strlen (newmsg); - if (Present (node)) - Error_Msg_NE (fp, node, ent); - } - - /* Similar to post_error_ne_tree, except that NUM is a second - integer to write in the message. */ - - void - post_error_ne_tree_2 (const char *msg, - Node_Id node, - Entity_Id ent, - tree t, - int num) - { - Error_Msg_Uint_2 = UI_From_Int (num); - post_error_ne_tree (msg, node, ent, t); - } - - /* Initialize the table that maps GNAT codes to GCC codes for simple - binary and unary operations. */ - - static void - init_code_table (void) - { - gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR; - gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR; - - gnu_codes[N_Op_And] = TRUTH_AND_EXPR; - gnu_codes[N_Op_Or] = TRUTH_OR_EXPR; - gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR; - gnu_codes[N_Op_Eq] = EQ_EXPR; - gnu_codes[N_Op_Ne] = NE_EXPR; - gnu_codes[N_Op_Lt] = LT_EXPR; - gnu_codes[N_Op_Le] = LE_EXPR; - gnu_codes[N_Op_Gt] = GT_EXPR; - gnu_codes[N_Op_Ge] = GE_EXPR; - gnu_codes[N_Op_Add] = PLUS_EXPR; - gnu_codes[N_Op_Subtract] = MINUS_EXPR; - gnu_codes[N_Op_Multiply] = MULT_EXPR; - gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR; - gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR; - gnu_codes[N_Op_Minus] = NEGATE_EXPR; - gnu_codes[N_Op_Abs] = ABS_EXPR; - gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR; - gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR; - gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR; - gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR; - gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR; - gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR; - } - - /* Return a label to branch to for the exception type in KIND or NULL_TREE - if none. */ - - tree - get_exception_label (char kind) - { - if (kind == N_Raise_Constraint_Error) - return TREE_VALUE (gnu_constraint_error_label_stack); - else if (kind == N_Raise_Storage_Error) - return TREE_VALUE (gnu_storage_error_label_stack); - else if (kind == N_Raise_Program_Error) - return TREE_VALUE (gnu_program_error_label_stack); - else - return NULL_TREE; - } - - #include "gt-ada-trans.h" --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/tree_gen.adb gcc-4.4.0/gcc/ada/tree_gen.adb *** gcc-4.3.3/gcc/ada/tree_gen.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/tree_gen.adb Tue Apr 8 06:45:25 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Nlists; *** 32,43 **** --- 32,50 ---- with Opt; with Osint.C; with Repinfo; + with Sem_Aux; with Sinput; with Stand; with Stringt; with Uintp; with Urealp; + with Tree_In; + pragma Warnings (Off, Tree_In); + -- We do not use Tree_In in the compiler, but it is small, and worth including + -- so that we get the proper license check for Tree_In when the compiler is + -- built. This will avoid adding bad dependencies to Tree_In and blowing ASIS. + procedure Tree_Gen is begin if Opt.Tree_Output then *************** begin *** 49,54 **** --- 56,62 ---- Lib.Tree_Write; Namet.Tree_Write; Nlists.Tree_Write; + Sem_Aux.Tree_Write; Sinput.Tree_Write; Stand.Tree_Write; Stringt.Tree_Write; diff -Nrcpad gcc-4.3.3/gcc/ada/tree_in.adb gcc-4.4.0/gcc/ada/tree_in.adb *** gcc-4.3.3/gcc/ada/tree_in.adb Fri Jul 1 01:29:17 2005 --- gcc-4.4.0/gcc/ada/tree_in.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-1999, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** with Namet; *** 40,45 **** --- 38,44 ---- with Nlists; with Opt; with Repinfo; + with Sem_Aux; with Sinput; with Stand; with Stringt; *************** begin *** 57,62 **** --- 56,62 ---- Lib.Tree_Read; Namet.Tree_Read; Nlists.Tree_Read; + Sem_Aux.Tree_Read; Sinput.Tree_Read; Stand.Tree_Read; Stringt.Tree_Read; diff -Nrcpad gcc-4.3.3/gcc/ada/tree_in.ads gcc-4.4.0/gcc/ada/tree_in.ads *** gcc-4.3.3/gcc/ada/tree_in.ads Wed Jun 6 10:14:14 2007 --- gcc-4.4.0/gcc/ada/tree_in.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/tree_io.adb gcc-4.4.0/gcc/ada/tree_io.adb *** gcc-4.3.3/gcc/ada/tree_io.adb Wed Jun 6 10:52:32 2007 --- gcc-4.4.0/gcc/ada/tree_io.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Tree_IO is *** 107,113 **** ----------------------- procedure Read_Buffer; ! -- Reads data into buffer, setting Bufe appropriately function Read_Byte return Byte; pragma Inline (Read_Byte); --- 105,111 ---- ----------------------- procedure Read_Buffer; ! -- Reads data into buffer, setting Bufn appropriately function Read_Byte return Byte; pragma Inline (Read_Byte); diff -Nrcpad gcc-4.3.3/gcc/ada/tree_io.ads gcc-4.4.0/gcc/ada/tree_io.ads *** gcc-4.3.3/gcc/ada/tree_io.ads Wed Sep 26 10:42:09 2007 --- gcc-4.4.0/gcc/ada/tree_io.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Tree_IO is *** 46,57 **** Tree_Format_Error : exception; -- Raised if a format error is detected in the input file ! ASIS_Version_Number : constant := 21; -- ASIS Version. This is used to check for consistency between the compiler -- used to generate trees and an ASIS application that is reading the -- trees. It must be incremented whenever a change is made to the tree -- format that would result in the compiler being incompatible with an ! -- older version of ASIS, or vice versa. procedure Tree_Read_Initialize (Desc : File_Descriptor); -- Called to initialize reading of a tree file. This call must be made --- 44,55 ---- Tree_Format_Error : exception; -- Raised if a format error is detected in the input file ! ASIS_Version_Number : constant := 23; -- ASIS Version. This is used to check for consistency between the compiler -- used to generate trees and an ASIS application that is reading the -- trees. It must be incremented whenever a change is made to the tree -- format that would result in the compiler being incompatible with an ! -- older version of ASIS. procedure Tree_Read_Initialize (Desc : File_Descriptor); -- Called to initialize reading of a tree file. This call must be made diff -Nrcpad gcc-4.3.3/gcc/ada/treepr.adb gcc-4.4.0/gcc/ada/treepr.adb *** gcc-4.3.3/gcc/ada/treepr.adb Thu Dec 13 10:37:34 2007 --- gcc-4.4.0/gcc/ada/treepr.adb Fri Aug 1 07:56:20 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** package body Treepr is *** 531,547 **** begin case M is ! when Default_Mechanism => Write_Str ("Default"); ! when By_Copy => Write_Str ("By_Copy"); ! when By_Reference => Write_Str ("By_Reference"); ! when By_Descriptor => Write_Str ("By_Descriptor"); ! when By_Descriptor_UBS => Write_Str ("By_Descriptor_UBS"); ! when By_Descriptor_UBSB => Write_Str ("By_Descriptor_UBSB"); ! when By_Descriptor_UBA => Write_Str ("By_Descriptor_UBA"); ! when By_Descriptor_S => Write_Str ("By_Descriptor_S"); ! when By_Descriptor_SB => Write_Str ("By_Descriptor_SB"); ! when By_Descriptor_A => Write_Str ("By_Descriptor_A"); ! when By_Descriptor_NCA => Write_Str ("By_Descriptor_NCA"); when 1 .. Mechanism_Type'Last => Write_Str ("By_Copy if size <= "); --- 531,574 ---- begin case M is ! when Default_Mechanism ! => Write_Str ("Default"); ! when By_Copy ! => Write_Str ("By_Copy"); ! when By_Reference ! => Write_Str ("By_Reference"); ! when By_Descriptor ! => Write_Str ("By_Descriptor"); ! when By_Descriptor_UBS ! => Write_Str ("By_Descriptor_UBS"); ! when By_Descriptor_UBSB ! => Write_Str ("By_Descriptor_UBSB"); ! when By_Descriptor_UBA ! => Write_Str ("By_Descriptor_UBA"); ! when By_Descriptor_S ! => Write_Str ("By_Descriptor_S"); ! when By_Descriptor_SB ! => Write_Str ("By_Descriptor_SB"); ! when By_Descriptor_A ! => Write_Str ("By_Descriptor_A"); ! when By_Descriptor_NCA ! => Write_Str ("By_Descriptor_NCA"); ! when By_Short_Descriptor ! => Write_Str ("By_Short_Descriptor"); ! when By_Short_Descriptor_UBS ! => Write_Str ("By_Short_Descriptor_UBS"); ! when By_Short_Descriptor_UBSB ! => Write_Str ("By_Short_Descriptor_UBSB"); ! when By_Short_Descriptor_UBA ! => Write_Str ("By_Short_Descriptor_UBA"); ! when By_Short_Descriptor_S ! => Write_Str ("By_Short_Descriptor_S"); ! when By_Short_Descriptor_SB ! => Write_Str ("By_Short_Descriptor_SB"); ! when By_Short_Descriptor_A ! => Write_Str ("By_Short_Descriptor_A"); ! when By_Short_Descriptor_NCA ! => Write_Str ("By_Short_Descriptor_NCA"); when 1 .. Mechanism_Type'Last => Write_Str ("By_Copy if size <= "); *************** package body Treepr is *** 1654,1660 **** No_Indent : Boolean := False); -- This procedure tests the given value of one of the Fields referenced -- by the current node to determine whether to visit it recursively. ! -- Normally No_Indent is false, which means tha the visited node will -- be indented using New_Prefix. If No_Indent is set to True, then -- this indentation is skipped, and Prefix_Str is used for the call -- to print the descendent. No_Indent is effective only if the --- 1681,1687 ---- No_Indent : Boolean := False); -- This procedure tests the given value of one of the Fields referenced -- by the current node to determine whether to visit it recursively. ! -- Normally No_Indent is false, which means that the visited node will -- be indented using New_Prefix. If No_Indent is set to True, then -- this indentation is skipped, and Prefix_Str is used for the call -- to print the descendent. No_Indent is effective only if the diff -Nrcpad gcc-4.3.3/gcc/ada/types.adb gcc-4.4.0/gcc/ada/types.adb *** gcc-4.3.3/gcc/ada/types.adb Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/types.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Types is *** 83,90 **** -- Note that we do not bother to worry about shifts in the day. -- It seems unlikely that such shifts could ever occur in practice ! -- and even if they do we err on the safe side, ie we say that the time ! -- stamps are different. Sright := V (Right, 13) + 60 * (V (Right, 11) + 60 * V (Right, 09)); Sleft := V (Left, 13) + 60 * (V (Left, 11) + 60 * V (Left, 09)); --- 81,88 ---- -- Note that we do not bother to worry about shifts in the day. -- It seems unlikely that such shifts could ever occur in practice ! -- and even if they do we err on the safe side, i.e., we say that the ! -- time stamps are different. Sright := V (Right, 13) + 60 * (V (Right, 11) + 60 * V (Right, 09)); Sleft := V (Left, 13) + 60 * (V (Left, 11) + 60 * V (Left, 09)); diff -Nrcpad gcc-4.3.3/gcc/ada/types.ads gcc-4.4.0/gcc/ada/types.ads *** gcc-4.3.3/gcc/ada/types.ads Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/types.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** *** 47,52 **** --- 45,52 ---- -- 2s-complement. If there are any machines for which this is not a correct -- assumption, a significant number of changes will be required! + with System; + with Unchecked_Conversion; with Unchecked_Deallocation; package Types is *************** package Types is *** 123,128 **** --- 123,137 ---- procedure Free is new Unchecked_Deallocation (String, String_Ptr); -- Procedure for freeing dynamically allocated String values + subtype Big_String is String (Positive); + type Big_String_Ptr is access all Big_String; + for Big_String_Ptr'Storage_Size use 0; + -- Virtual type for handling imported big strings + + function To_Big_String_Ptr is + new Unchecked_Conversion (System.Address, Big_String_Ptr); + -- Used to obtain Big_String_Ptr values from external addresses + subtype Word_Hex_String is String (1 .. 8); -- Type used to represent Word value as 8 hex digits, with lower case -- letters for the alphabetic cases. *************** package Types is *** 191,196 **** --- 200,206 ---- -- type Source_Buffer_Ptr, see Osint.Read_Source_File for details. type Source_Buffer_Ptr is access all Big_Source_Buffer; + for Source_Buffer_Ptr'Storage_Size use 0; -- Pointer to source buffer. We use virtual origin addressing for source -- buffers, with thin pointers. The pointer points to a virtual instance -- of type Big_Source_Buffer, where the actual type is in fact of type *************** package Types is *** 200,206 **** subtype Source_Ptr is Text_Ptr; -- Type used to represent a source location, which is a subscript of a ! -- character in the source buffer. As noted above, diffferent source -- buffers have different ranges, so it is possible to tell from a -- Source_Ptr value which source it refers to. Note that negative numbers -- are allowed to accommodate the following special values. --- 210,216 ---- subtype Source_Ptr is Text_Ptr; -- Type used to represent a source location, which is a subscript of a ! -- character in the source buffer. As noted above, different source -- buffers have different ranges, so it is possible to tell from a -- Source_Ptr value which source it refers to. Note that negative numbers -- are allowed to accommodate the following special values. *************** package Types is *** 423,429 **** No_List : constant List_Id := List_High_Bound; -- Used to indicate absence of a list. Note that the value is zero, which ! -- is the same as Empty, which is helpful in intializing nodes where a -- value of zero can represent either an empty node or an empty list. Error_List : constant List_Id := List_Low_Bound; --- 433,439 ---- No_List : constant List_Id := List_High_Bound; -- Used to indicate absence of a list. Note that the value is zero, which ! -- is the same as Empty, which is helpful in initializing nodes where a -- value of zero can represent either an empty node or an empty list. Error_List : constant List_Id := List_Low_Bound; *************** package Types is *** 448,454 **** -- Type used to identify an element list (Elist header table subscript) No_Elist : constant Elist_Id := Elist_Low_Bound; ! -- Used to indicate absense of an element list. Note that this is not -- an actual Elist header, so element list operations on this value -- are not valid. --- 458,464 ---- -- Type used to identify an element list (Elist header table subscript) No_Elist : constant Elist_Id := Elist_Low_Bound; ! -- Used to indicate absence of an element list. Note that this is not -- an actual Elist header, so element list operations on this value -- are not valid. *************** package Types is *** 497,503 **** -- Each character literal in the source is interpreted as being one of the -- 16#8000_0000 possible Wide_Wide_Character codes, and a unique Integer -- Value is assigned, corresponding to the UTF_32 value, which also ! -- correspondds to the POS value in the Wide_Wide_Character type, and also -- corresponds to the POS value in the Wide_Character and Character types -- for values that are in appropriate range. String literals are similarly -- interpreted as a sequence of such codes. --- 507,513 ---- -- Each character literal in the source is interpreted as being one of the -- 16#8000_0000 possible Wide_Wide_Character codes, and a unique Integer -- Value is assigned, corresponding to the UTF_32 value, which also ! -- corresponds to the POS value in the Wide_Wide_Character type, and also -- corresponds to the POS value in the Wide_Character and Character types -- for values that are in appropriate range. String literals are similarly -- interpreted as a sequence of such codes. *************** package Types is *** 603,609 **** Dummy_Time_Stamp : constant Time_Stamp_Type := (others => '0'); -- This is used for dummy time stamp values used in the D lines for ! -- non-existant files, and is intended to be an impossible value. function "=" (Left, Right : Time_Stamp_Type) return Boolean; function "<=" (Left, Right : Time_Stamp_Type) return Boolean; --- 613,619 ---- Dummy_Time_Stamp : constant Time_Stamp_Type := (others => '0'); -- This is used for dummy time stamp values used in the D lines for ! -- non-existent files, and is intended to be an impossible value. function "=" (Left, Right : Time_Stamp_Type) return Boolean; function "<=" (Left, Right : Time_Stamp_Type) return Boolean; *************** package Types is *** 724,730 **** -- passing mechanism. See specification of Sem_Mech for full details. -- The following subtype is used to represent values of this type: ! subtype Mechanism_Type is Int range -10 .. Int'Last; -- Type used to represent a mechanism value. This is a subtype rather -- than a type to avoid some annoying processing problems with certain -- routines in Einfo (processing them to create the corresponding C). --- 734,740 ---- -- passing mechanism. See specification of Sem_Mech for full details. -- The following subtype is used to represent values of this type: ! subtype Mechanism_Type is Int range -18 .. Int'Last; -- Type used to represent a mechanism value. This is a subtype rather -- than a type to avoid some annoying processing problems with certain -- routines in Einfo (processing them to create the corresponding C). diff -Nrcpad gcc-4.3.3/gcc/ada/types.h gcc-4.4.0/gcc/ada/types.h *** gcc-4.3.3/gcc/ada/types.h Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/types.h Fri Aug 1 07:56:20 2008 *************** *** 6,12 **** * * * C Header File * * * ! * Copyright (C) 1992-2007, 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- * --- 6,12 ---- * * * C Header File * * * ! * Copyright (C) 1992-2008, 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- * *************** typedef Int Mechanism_Type; *** 328,333 **** --- 328,342 ---- #define By_Descriptor_A (-9) #define By_Descriptor_NCA (-10) #define By_Descriptor_Last (-10) + #define By_Short_Descriptor (-11) + #define By_Short_Descriptor_UBS (-12) + #define By_Short_Descriptor_UBSB (-13) + #define By_Short_Descriptor_UBA (-14) + #define By_Short_Descriptor_S (-15) + #define By_Short_Descriptor_SB (-16) + #define By_Short_Descriptor_A (-17) + #define By_Short_Descriptor_NCA (-18) + #define By_Short_Descriptor_Last (-18) /* Internal to Gigi. */ #define By_Copy_Return (-128) *************** typedef Int Mechanism_Type; *** 341,347 **** #define CE_Index_Check_Failed 5 #define CE_Invalid_Data 6 #define CE_Length_Check_Failed 7 ! #define CE_Null_Exception_Id 9 #define CE_Null_Not_Allowed 9 #define CE_Overflow_Check_Failed 10 #define CE_Partition_Check_Failed 11 --- 350,356 ---- #define CE_Index_Check_Failed 5 #define CE_Invalid_Data 6 #define CE_Length_Check_Failed 7 ! #define CE_Null_Exception_Id 8 #define CE_Null_Not_Allowed 9 #define CE_Overflow_Check_Failed 10 #define CE_Partition_Check_Failed 11 diff -Nrcpad gcc-4.3.3/gcc/ada/ug_words gcc-4.4.0/gcc/ada/ug_words *** gcc-4.3.3/gcc/ada/ug_words Thu Dec 13 10:26:56 2007 --- gcc-4.4.0/gcc/ada/ug_words Tue Aug 5 14:10:54 2008 *************** *** 1,5 **** b_ ^ B_ ! b~ ^ B$ cc1 ^ CC1 Cc1 ^ CC1 emacs ^ EMACS --- 1,5 ---- b_ ^ B_ ! b~ ^ B__ cc1 ^ CC1 Cc1 ^ CC1 emacs ^ EMACS *************** gcc -c ^ GNAT COMPILE *** 61,66 **** --- 61,67 ---- -gnatec ^ /CONFIGURATION_PRAGMAS_FILE -gnateD ^ /SYMBOL_PREPROCESSING -gnatef ^ /FULL_PATH_IN_BRIEF_MESSAGES + -gnateG ^ /GENERATE_PROCESSED_SOURCE -gnatem ^ /MAPPING_FILE -gnatep ^ /DATA_PREPROCESSING -gnatE ^ /CHECKS=ELABORATION *************** gcc -c ^ GNAT COMPILE *** 89,94 **** --- 90,96 ---- -gnatR3 ^ /REPRESENTATION_INFO=SYMBOLIC -gnatq ^ /TRY_SEMANTICS -gnatQ ^ /FORCE_ALI + -gnatr ^ /TREAT_RESTRICTIONS_AS_WARNINGS -gnats ^ /SYNTAX_ONLY -gnatS ^ /PRINT_STANDARD -gnatt ^ /TREE_OUTPUT *************** gcc -c ^ GNAT COMPILE *** 99,104 **** --- 101,108 ---- -gnatVa ^ /VALIDITY_CHECKING=ALL -gnatVc ^ /VALIDITY_CHECKING=COPIES -gnatVd ^ /VALIDITY_CHECKING=DEFAULT + -gnatVE ^ /VALIDITY_CHECKING=NOCOMPONENTS + -gnatVe ^ /VALIDITY_CHECKING=COMPONENTS -gnatVD ^ /VALIDITY_CHECKING=NODEFAULT -gnatVf ^ /VALIDITY_CHECKING=FLOATS -gnatVi ^ /VALIDITY_CHECKING=IN_PARAMS *************** gcc -c ^ GNAT COMPILE *** 116,121 **** --- 120,127 ---- -gnatw.A ^ /WARNINGS=NO_FAILING_ASSERTIONS -gnatwb ^ /WARNINGS=BAD_FIXED_VALUES -gnatwB ^ /WARNINGS=NO_BAD_FIXED_VALUES + -gnatw.b ^ /WARNINGS=BIASED_REPRESENTATION + -gnatw.B ^ /WARNINGS=NO_BIASED_REPRESENTATION -gnatwc ^ /WARNINGS=CONDITIONALS -gnatwC ^ /WARNINGS=NOCONDITIONALS -gnatw.c ^ /WARNINGS=MISSING_COMPONENT_CLAUSES *************** gcc -c ^ GNAT COMPILE *** 123,128 **** --- 129,135 ---- -gnatwd ^ /WARNINGS=IMPLICIT_DEREFERENCE -gnatwD ^ /WARNINGS=NOIMPLICIT_DEREFERENCE -gnatwe ^ /WARNINGS=ERRORS + -gnatw.e ^ /WARNINGS=EVERY -gnatwf ^ /WARNINGS=UNREFERENCED_FORMALS -gnatwF ^ /WARNINGS=NOUNREFERENCED_FORMALS -gnatwg ^ /WARNINGS=UNRECOGNIZED_PRAGMAS *************** gcc -c ^ GNAT COMPILE *** 146,151 **** --- 153,160 ---- -gnatw.O ^ /WARNINGS=NOOUT_PARAM_UNREF -gnatwp ^ /WARNINGS=INEFFECTIVE_INLINE -gnatwP ^ /WARNINGS=NOINEFFECTIVE_INLINE + -gnatw.p ^ /WARNINGS=PARAMETER_ORDER + -gnatw.P ^ /WARNINGS=NO_PARAMETER_ORDER -gnatwq ^ /WARNINGS=MISSING_PARENS -gnatwQ ^ /WARNINGS=NOMISSING_PARENS -gnatwr ^ /WARNINGS=REDUNDANT *************** gcc -c ^ GNAT COMPILE *** 159,164 **** --- 168,175 ---- -gnatwV ^ /WARNINGS=NOVARIABLES_UNINITIALIZED -gnatww ^ /WARNINGS=LOWBOUND_ASSUMED -gnatwW ^ /WARNINGS=NOLOWBOUND_ASSUMED + -gnatw.w ^ /WARNINGS=WARNINGS_OFF_PRAGMAS + -gnatw.W ^ /WARNINGS=NOWARNINGS_OFF_PRAGMAS -gnatwx ^ /WARNINGS=IMPORT_EXPORT_PRAGMAS -gnatwX ^ /WARNINGS=NOIMPORT_EXPORT_PRAGMAS -gnatw.x ^ /WARNINGS=LOCAL_RAISE_HANDLING *************** gcc -c ^ GNAT COMPILE *** 170,175 **** --- 181,187 ---- -gnatW8 ^ /WIDE_CHARACTER_ENCODING=UTF8 -gnatW? ^ /WIDE_CHARACTER_ENCODING=? -gnaty ^ /STYLE_CHECKS + -gnatyy ^ /STYLE_CHECKS=ALL_BUILTIN -gnatZ ^ /ZERO_COST_EXCEPTIONS -gnatzc ^ /DISTRIBUTION_STUBS=CALLER -gnatzr ^ /DISTRIBUTION_STUBS=RECEIVER diff -Nrcpad gcc-4.3.3/gcc/ada/uintp.adb gcc-4.4.0/gcc/ada/uintp.adb *** gcc-4.3.3/gcc/ada/uintp.adb Mon Oct 15 13:53:48 2007 --- gcc-4.4.0/gcc/ada/uintp.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Uintp is *** 72,78 **** Udigits_Min : Int; -- These values are used to make sure that the mark/release mechanism does -- not destroy values saved in the U_Power tables or in the hash table used ! -- by UI_From_Int. Whenever an entry is made in either of these tabls, -- Uints_Min and Udigits_Min are updated to protect the entry, and Release -- never cuts back beyond these minimum values. --- 70,76 ---- Udigits_Min : Int; -- These values are used to make sure that the mark/release mechanism does -- not destroy values saved in the U_Power tables or in the hash table used ! -- by UI_From_Int. Whenever an entry is made in either of these tables, -- Uints_Min and Udigits_Min are updated to protect the entry, and Release -- never cuts back beyond these minimum values. *************** package body Uintp is *** 142,148 **** -- is less than 2**15, the value returned is the input value, in this case -- the result may be negative. It is expected that any use will mask off -- unnecessary bits. This is used for finding Arg mod B where B is a power ! -- of two. Hence the actual base is irrelevent as long as it is a power of -- two. procedure Most_Sig_2_Digits --- 140,146 ---- -- is less than 2**15, the value returned is the input value, in this case -- the result may be negative. It is expected that any use will mask off -- unnecessary bits. This is used for finding Arg mod B where B is a power ! -- of two. Hence the actual base is irrelevant as long as it is a power of -- two. procedure Most_Sig_2_Digits *************** package body Uintp is *** 172,178 **** Remainder : out Uint; Discard_Quotient : Boolean; Discard_Remainder : Boolean); ! -- Compute euclidian division of Left by Right, and return Quotient and -- signed Remainder (Left rem Right). -- -- If Discard_Quotient is True, Quotient is left unchanged. --- 170,176 ---- Remainder : out Uint; Discard_Quotient : Boolean; Discard_Remainder : Boolean); ! -- Compute Euclidean division of Left by Right, and return Quotient and -- signed Remainder (Left rem Right). -- -- If Discard_Quotient is True, Quotient is left unchanged. *************** package body Uintp is *** 683,696 **** begin Release (M); ! Uints.Increment_Last; UI := Uints.Last; - Uints.Table (UI) := (UE_Len, Udigits.Last + 1); - for J in 1 .. UE_Len loop ! Udigits.Increment_Last; ! Udigits.Table (Udigits.Last) := UD (J); end loop; end; end if; --- 681,691 ---- begin Release (M); ! Uints.Append ((Length => UE_Len, Loc => Udigits.Last + 1)); UI := Uints.Last; for J in 1 .. UE_Len loop ! Udigits.Append (UD (J)); end loop; end; end if; *************** package body Uintp is *** 721,744 **** begin Release (M); ! Uints.Increment_Last; UI1 := Uints.Last; - Uints.Table (UI1) := (UE1_Len, Udigits.Last + 1); - for J in 1 .. UE1_Len loop ! Udigits.Increment_Last; ! Udigits.Table (Udigits.Last) := UD1 (J); end loop; ! Uints.Increment_Last; UI2 := Uints.Last; - Uints.Table (UI2) := (UE2_Len, Udigits.Last + 1); - for J in 1 .. UE2_Len loop ! Udigits.Increment_Last; ! Udigits.Table (Udigits.Last) := UD2 (J); end loop; end; end if; --- 716,733 ---- begin Release (M); ! Uints.Append ((Length => UE1_Len, Loc => Udigits.Last + 1)); UI1 := Uints.Last; for J in 1 .. UE1_Len loop ! Udigits.Append (UD1 (J)); end loop; ! Uints.Append ((Length => UE2_Len, Loc => Udigits.Last + 1)); UI2 := Uints.Last; for J in 1 .. UE2_Len loop ! Udigits.Append (UD2 (J)); end loop; end; end if; *************** package body Uintp is *** 750,756 **** -- This is done in one pass ! -- Mathematically: assume base congruent to 1 and compute an equivelent -- integer to Left. -- If Sign = -1 return the alternating sum of the "digits" --- 739,745 ---- -- This is done in one pass ! -- Mathematically: assume base congruent to 1 and compute an equivalent -- integer to Left. -- If Sign = -1 return the alternating sum of the "digits" *************** package body Uintp is *** 759,765 **** -- (where D1 is Least Significant Digit) ! -- Mathematically: assume base congruent to -1 and compute an equivelent -- integer to Left. -- This is used in Rem and Base is assumed to be 2 ** 15 --- 748,754 ---- -- (where D1 is Least Significant Digit) ! -- Mathematically: assume base congruent to -1 and compute an equivalent -- integer to Left. -- This is used in Rem and Base is assumed to be 2 ** 15 *************** package body Uintp is *** 1280,1285 **** --- 1269,1276 ---- Discard_Quotient : Boolean; Discard_Remainder : Boolean) is + pragma Warnings (Off, Quotient); + pragma Warnings (Off, Remainder); begin pragma Assert (Right /= Uint_0); *************** package body Uintp is *** 1839,1845 **** Den1 := V_Hat + C; Den2 := V_Hat + D; ! exit when (Den1 * Den2) = Int_0; -- Compute Q, the trial quotient --- 1830,1836 ---- Den1 := V_Hat + C; Den2 := V_Hat + D; ! exit when Den1 = Int_0 or else Den2 = Int_0; -- Compute Q, the trial quotient *************** package body Uintp is *** 1942,1948 **** function UI_Gt (Left : Uint; Right : Uint) return Boolean is begin ! return UI_Lt (Right, Left); end UI_Gt; --------------- --- 1933,1939 ---- function UI_Gt (Left : Uint; Right : Uint) return Boolean is begin ! return UI_Lt (Left => Right, Right => Left); end UI_Gt; --------------- *************** package body Uintp is *** 1988,1994 **** function UI_Le (Left : Uint; Right : Uint) return Boolean is begin ! return not UI_Lt (Right, Left); end UI_Le; ------------ --- 1979,1985 ---- function UI_Le (Left : Uint; Right : Uint) return Boolean is begin ! return not UI_Lt (Left => Right, Right => Left); end UI_Le; ------------ *************** package body Uintp is *** 2740,2763 **** -- The value is outside the direct representation range and must -- therefore be stored in the table. Expand the table to contain ! -- the count and tigis. The index of the new table entry will be -- returned as the result. ! Uints.Increment_Last; ! Uints.Table (Uints.Last).Length := Size; ! Uints.Table (Uints.Last).Loc := Udigits.Last + 1; ! ! Udigits.Increment_Last; if Negative then ! Udigits.Table (Udigits.Last) := -In_Vec (J); else ! Udigits.Table (Udigits.Last) := +In_Vec (J); end if; for K in 2 .. Size loop ! Udigits.Increment_Last; ! Udigits.Table (Udigits.Last) := In_Vec (J + K - 1); end loop; return Uints.Last; --- 2731,2751 ---- -- The value is outside the direct representation range and must -- therefore be stored in the table. Expand the table to contain ! -- the count and digits. The index of the new table entry will be -- returned as the result. ! Uints.Append ((Length => Size, Loc => Udigits.Last + 1)); if Negative then ! Val := -In_Vec (J); else ! Val := +In_Vec (J); end if; + Udigits.Append (Val); + for K in 2 .. Size loop ! Udigits.Append (In_Vec (J + K - 1)); end loop; return Uints.Last; diff -Nrcpad gcc-4.3.3/gcc/ada/uintp.ads gcc-4.4.0/gcc/ada/uintp.ads *** gcc-4.3.3/gcc/ada/uintp.ads Wed Jun 6 10:23:26 2007 --- gcc-4.4.0/gcc/ada/uintp.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Uintp is *** 233,239 **** function UI_Modular_Inverse (N : Uint; Modulo : Uint) return Uint; -- Compute the multiplicative inverse of N in modular arithmetics with the -- given Modulo (uses Euclid's algorithm). Note: the call is considered ! -- to be erroneous (and the behavior is undefined) if n is not inversible. function UI_From_Dint (Input : Dint) return Uint; -- Converts Dint value to universal integer form --- 231,237 ---- function UI_Modular_Inverse (N : Uint; Modulo : Uint) return Uint; -- Compute the multiplicative inverse of N in modular arithmetics with the -- given Modulo (uses Euclid's algorithm). Note: the call is considered ! -- to be erroneous (and the behavior is undefined) if n is not invertible. function UI_From_Dint (Input : Dint) return Uint; -- Converts Dint value to universal integer form diff -Nrcpad gcc-4.3.3/gcc/ada/uname.adb gcc-4.4.0/gcc/ada/uname.adb *** gcc-4.3.3/gcc/ada/uname.adb Wed Jun 6 10:19:40 2007 --- gcc-4.4.0/gcc/ada/uname.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/uname.ads gcc-4.4.0/gcc/ada/uname.ads *** gcc-4.3.3/gcc/ada/uname.ads Wed Jun 6 10:19:40 2007 --- gcc-4.4.0/gcc/ada/uname.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/urealp.adb gcc-4.4.0/gcc/ada/urealp.adb *** gcc-4.3.3/gcc/ada/urealp.adb Wed Jun 6 10:23:26 2007 --- gcc-4.4.0/gcc/ada/urealp.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Urealp is *** 441,448 **** function Store_Ureal (Val : Ureal_Entry) return Ureal is begin ! Ureals.Increment_Last; ! Ureals.Table (Ureals.Last) := Val; -- Normalize representation of signed values --- 439,445 ---- function Store_Ureal (Val : Ureal_Entry) return Ureal is begin ! Ureals.Append (Val); -- Normalize representation of signed values diff -Nrcpad gcc-4.3.3/gcc/ada/urealp.ads gcc-4.4.0/gcc/ada/urealp.ads *** gcc-4.3.3/gcc/ada/urealp.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/urealp.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff -Nrcpad gcc-4.3.3/gcc/ada/usage.adb gcc-4.4.0/gcc/ada/usage.adb *** gcc-4.3.3/gcc/ada/usage.adb Thu Dec 13 10:26:56 2007 --- gcc-4.4.0/gcc/ada/usage.adb Fri Aug 22 15:07:34 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** *** 23,28 **** --- 23,31 ---- -- -- ------------------------------------------------------------------------------ + -- Warning: the output of this usage for warnings is duplicated in the GNAT + -- reference manual. Be sure to update that if you change the warning list. + with Targparm; use Targparm; with Namet; use Namet; with Opt; use Opt; *************** begin *** 134,139 **** --- 137,147 ---- Write_Switch_Char ("b"); Write_Line ("Generate brief messages to stderr even if verbose mode set"); + -- Line for -gnatB switch + + Write_Switch_Char ("B"); + Write_Line ("Assume no bad (invalid) values except in 'Valid attribute"); + -- Line for -gnatc switch Write_Switch_Char ("c"); *************** begin *** 164,169 **** --- 172,182 ---- Write_Switch_Char ("ef"); Write_Line ("Full source path in brief error messages"); + -- Line for -gnateG switch + + Write_Switch_Char ("eG"); + Write_Line ("Generate preprocessed source"); + -- Line for -gnateI switch Write_Switch_Char ("eInn"); *************** begin *** 286,291 **** --- 299,309 ---- Write_Switch_Char ("Q"); Write_Line ("Don't quit, write ali/tree file even if compile errors"); + -- Line for -gnatr switch + + Write_Switch_Char ("r"); + Write_Line ("Treat pragma Restrictions as Restriction_Warnings"); + -- Lines for -gnatR switch Write_Switch_Char ("R?"); *************** begin *** 362,375 **** Write_Switch_Char ("wxx"); Write_Line ("Enable selected warning modes, xx = list of parameters:"); ! Write_Line (" a turn on all optional warnings (except d h l .o)"); Write_Line (" A turn off all optional warnings"); ! Write_Line (" .a* turn on warnings for failing assertions"); ! Write_Line (" .A turn off warnings for failing assertions"); Write_Line (" b turn on warnings for bad fixed value " & "(not multiple of small)"); Write_Line (" B* turn off warnings for bad fixed value " & "(not multiple of small)"); Write_Line (" c turn on warnings for constant conditional"); Write_Line (" C* turn off warnings for constant conditional"); Write_Line (" .c turn on warnings for unrepped components"); --- 380,396 ---- Write_Switch_Char ("wxx"); Write_Line ("Enable selected warning modes, xx = list of parameters:"); ! Write_Line (" a turn on all optional warnings " & ! "(except dhl.ot.w)"); Write_Line (" A turn off all optional warnings"); ! Write_Line (" .a* turn on warnings for failing assertion"); ! Write_Line (" .A turn off warnings for failing assertion"); Write_Line (" b turn on warnings for bad fixed value " & "(not multiple of small)"); Write_Line (" B* turn off warnings for bad fixed value " & "(not multiple of small)"); + Write_Line (" .b* turn on warnings for biased representation"); + Write_Line (" .B turn off warnings for biased representation"); Write_Line (" c turn on warnings for constant conditional"); Write_Line (" C* turn off warnings for constant conditional"); Write_Line (" .c turn on warnings for unrepped components"); *************** begin *** 377,387 **** Write_Line (" d turn on warnings for implicit dereference"); Write_Line (" D* turn off warnings for implicit dereference"); Write_Line (" e treat all warnings as errors"); Write_Line (" f turn on warnings for unreferenced formal"); Write_Line (" F* turn off warnings for unreferenced formal"); Write_Line (" g* turn on warnings for unrecognized pragma"); Write_Line (" G turn off warnings for unrecognized pragma"); ! Write_Line (" h turn on warnings for hiding variable "); Write_Line (" H* turn off warnings for hiding variable"); Write_Line (" i* turn on warnings for implementation unit"); Write_Line (" I turn off warnings for implementation unit"); --- 398,409 ---- Write_Line (" d turn on warnings for implicit dereference"); Write_Line (" D* turn off warnings for implicit dereference"); Write_Line (" e treat all warnings as errors"); + Write_Line (" .e turn on every optional warning (no exceptions)"); Write_Line (" f turn on warnings for unreferenced formal"); Write_Line (" F* turn off warnings for unreferenced formal"); Write_Line (" g* turn on warnings for unrecognized pragma"); Write_Line (" G turn off warnings for unrecognized pragma"); ! Write_Line (" h turn on warnings for hiding variable"); Write_Line (" H* turn off warnings for hiding variable"); Write_Line (" i* turn on warnings for implementation unit"); Write_Line (" I turn off warnings for implementation unit"); *************** begin *** 407,419 **** Write_Line (" .O* turn off warnings for out parameters assigned " & "but not read"); Write_Line (" p turn on warnings for ineffective pragma " & ! "Inline in frontend"); Write_Line (" P* turn off warnings for ineffective pragma " & ! "Inline in frontend"); Write_Line (" q* turn on warnings for questionable " & ! "missing parentheses"); Write_Line (" Q turn off warnings for questionable " & ! "missing parentheses"); Write_Line (" r turn on warnings for redundant construct"); Write_Line (" R* turn off warnings for redundant construct"); Write_Line (" .r turn on warnings for object renaming function"); --- 429,445 ---- Write_Line (" .O* turn off warnings for out parameters assigned " & "but not read"); Write_Line (" p turn on warnings for ineffective pragma " & ! "Inline in frontend"); Write_Line (" P* turn off warnings for ineffective pragma " & ! "Inline in frontend"); ! Write_Line (" .p turn on warnings for suspicious parameter " & ! "order"); ! Write_Line (" .P* turn off warnings for suspicious parameter " & ! "order"); Write_Line (" q* turn on warnings for questionable " & ! "missing parenthesis"); Write_Line (" Q turn off warnings for questionable " & ! "missing parenthesis"); Write_Line (" r turn on warnings for redundant construct"); Write_Line (" R* turn off warnings for redundant construct"); Write_Line (" .r turn on warnings for object renaming function"); *************** begin *** 428,442 **** Write_Line (" w* turn on warnings for wrong low bound assumption"); Write_Line (" W turn off warnings for wrong low bound " & "assumption"); Write_Line (" x* turn on warnings for export/import"); Write_Line (" X turn off warnings for export/import"); ! Write_Line (" .x turn on warnings for non-local exceptions"); ! Write_Line (" .X* turn off warnings for non-local exceptions"); Write_Line (" y* turn on warnings for Ada 2005 incompatibility"); Write_Line (" Y turn off warnings for Ada 2005 incompatibility"); ! Write_Line (" z* turn on convention/size/align warnings for " & "unchecked conversion"); ! Write_Line (" Z turn off convention/size/align warnings for " & "unchecked conversion"); Write_Line (" * indicates default in above list"); --- 454,470 ---- Write_Line (" w* turn on warnings for wrong low bound assumption"); Write_Line (" W turn off warnings for wrong low bound " & "assumption"); + Write_Line (" .w turn on warnings on pragma Warnings Off"); + Write_Line (" .w* turn off warnings on pragma Warnings Off"); Write_Line (" x* turn on warnings for export/import"); Write_Line (" X turn off warnings for export/import"); ! Write_Line (" .x turn on warnings for non-local exception"); ! Write_Line (" .X* turn off warnings for non-local exception"); Write_Line (" y* turn on warnings for Ada 2005 incompatibility"); Write_Line (" Y turn off warnings for Ada 2005 incompatibility"); ! Write_Line (" z* turn on warnings for suspicious " & "unchecked conversion"); ! Write_Line (" Z turn off warnings for suspicious " & "unchecked conversion"); Write_Line (" * indicates default in above list"); *************** begin *** 491,496 **** --- 519,525 ---- Write_Line (" m check line length <= 79 characters"); Write_Line (" n check casing of package Standard identifiers"); Write_Line (" Mnn check line length <= nn characters"); + Write_Line (" N turn off all checks"); Write_Line (" o check subprogram bodies in alphabetical order"); Write_Line (" p check pragma casing"); Write_Line (" r check casing for identifier references"); *************** begin *** 499,504 **** --- 528,536 ---- Write_Line (" t check token separation rules"); Write_Line (" u check no unnecessary blank lines"); Write_Line (" x check extra parentheses around conditionals"); + Write_Line (" y turn on default style checks"); + Write_Line (" - subtract (turn off) subsequent checks"); + Write_Line (" + add (turn on) subsequent checks"); -- Lines for -gnatyN switch diff -Nrcpad gcc-4.3.3/gcc/ada/utils.c gcc-4.4.0/gcc/ada/utils.c *** gcc-4.3.3/gcc/ada/utils.c Mon Oct 6 07:10:31 2008 --- gcc-4.4.0/gcc/ada/utils.c Thu Jan 1 00:00:00 1970 *************** *** 1,4177 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * U T I L S * - * * - * C Implementation File * - * * - * Copyright (C) 1992-2008, 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- * - * ware Foundation; either version 3, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License along with GCC; see the file COPYING3. If not see * - * . * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - #include "config.h" - #include "system.h" - #include "coretypes.h" - #include "tm.h" - #include "tree.h" - #include "flags.h" - #include "defaults.h" - #include "toplev.h" - #include "output.h" - #include "ggc.h" - #include "debug.h" - #include "convert.h" - #include "target.h" - #include "function.h" - #include "cgraph.h" - #include "tree-inline.h" - #include "tree-gimple.h" - #include "tree-dump.h" - #include "pointer-set.h" - - #include "ada.h" - #include "types.h" - #include "atree.h" - #include "elists.h" - #include "namet.h" - #include "nlists.h" - #include "stringt.h" - #include "uintp.h" - #include "fe.h" - #include "sinfo.h" - #include "einfo.h" - #include "ada-tree.h" - #include "gigi.h" - - #ifndef MAX_FIXED_MODE_SIZE - #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode) - #endif - - #ifndef MAX_BITS_PER_WORD - #define MAX_BITS_PER_WORD BITS_PER_WORD - #endif - - /* If nonzero, pretend we are allocating at global level. */ - int force_global; - - /* Tree nodes for the various types and decls we create. */ - tree gnat_std_decls[(int) ADT_LAST]; - - /* Functions to call for each of the possible raise reasons. */ - tree gnat_raise_decls[(int) LAST_REASON_CODE + 1]; - - /* Forward declarations for handlers of attributes. */ - static tree handle_const_attribute (tree *, tree, tree, int, bool *); - static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *); - - /* Table of machine-independent internal attributes for Ada. We support - this minimal set of attributes to accommodate the Alpha back-end which - unconditionally puts them on its builtins. */ - const struct attribute_spec gnat_internal_attribute_table[] = - { - /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler } */ - { "const", 0, 0, true, false, false, handle_const_attribute }, - { "nothrow", 0, 0, true, false, false, handle_nothrow_attribute }, - { NULL, 0, 0, false, false, false, NULL } - }; - - /* Associates a GNAT tree node to a GCC tree node. It is used in - `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation - of `save_gnu_tree' for more info. */ - static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu; - - #define GET_GNU_TREE(GNAT_ENTITY) \ - associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] - - #define SET_GNU_TREE(GNAT_ENTITY,VAL) \ - associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] = (VAL) - - #define PRESENT_GNU_TREE(GNAT_ENTITY) \ - (associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE) - - /* Associates a GNAT entity to a GCC tree node used as a dummy, if any. */ - static GTY((length ("max_gnat_nodes"))) tree *dummy_node_table; - - #define GET_DUMMY_NODE(GNAT_ENTITY) \ - dummy_node_table[(GNAT_ENTITY) - First_Node_Id] - - #define SET_DUMMY_NODE(GNAT_ENTITY,VAL) \ - dummy_node_table[(GNAT_ENTITY) - First_Node_Id] = (VAL) - - #define PRESENT_DUMMY_NODE(GNAT_ENTITY) \ - (dummy_node_table[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE) - - /* This variable keeps a table for types for each precision so that we only - allocate each of them once. Signed and unsigned types are kept separate. - - Note that these types are only used when fold-const requests something - special. Perhaps we should NOT share these types; we'll see how it - goes later. */ - static GTY(()) tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2]; - - /* Likewise for float types, but record these by mode. */ - static GTY(()) tree float_types[NUM_MACHINE_MODES]; - - /* For each binding contour we allocate a binding_level structure to indicate - the binding depth. */ - - struct gnat_binding_level GTY((chain_next ("%h.chain"))) - { - /* The binding level containing this one (the enclosing binding level). */ - struct gnat_binding_level *chain; - /* The BLOCK node for this level. */ - tree block; - /* If nonzero, the setjmp buffer that needs to be updated for any - variable-sized definition within this context. */ - tree jmpbuf_decl; - }; - - /* The binding level currently in effect. */ - static GTY(()) struct gnat_binding_level *current_binding_level; - - /* A chain of gnat_binding_level structures awaiting reuse. */ - static GTY((deletable)) struct gnat_binding_level *free_binding_level; - - /* An array of global declarations. */ - static GTY(()) VEC(tree,gc) *global_decls; - - /* An array of builtin declarations. */ - static GTY(()) VEC(tree,gc) *builtin_decls; - - /* An array of global renaming pointers. */ - static GTY(()) VEC(tree,gc) *global_renaming_pointers; - - /* A chain of unused BLOCK nodes. */ - static GTY((deletable)) tree free_block_chain; - - static void gnat_install_builtins (void); - static tree merge_sizes (tree, tree, tree, bool, bool); - static tree compute_related_constant (tree, tree); - static tree split_plus (tree, tree *); - static void gnat_gimplify_function (tree); - static tree float_type_for_precision (int, enum machine_mode); - static tree convert_to_fat_pointer (tree, tree); - static tree convert_to_thin_pointer (tree, tree); - static tree make_descriptor_field (const char *,tree, tree, tree); - static bool potential_alignment_gap (tree, tree, tree); - - /* Initialize the association of GNAT nodes to GCC trees. */ - - void - init_gnat_to_gnu (void) - { - associate_gnat_to_gnu - = (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree)); - } - - /* GNAT_ENTITY is a GNAT tree node for an entity. GNU_DECL is the GCC tree - which is to be associated with GNAT_ENTITY. Such GCC tree node is always - a ..._DECL node. If NO_CHECK is nonzero, the latter check is suppressed. - - If GNU_DECL is zero, a previous association is to be reset. */ - - void - save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, bool no_check) - { - /* Check that GNAT_ENTITY is not already defined and that it is being set - to something which is a decl. Raise gigi 401 if not. Usually, this - means GNAT_ENTITY is defined twice, but occasionally is due to some - Gigi problem. */ - gcc_assert (!(gnu_decl - && (PRESENT_GNU_TREE (gnat_entity) - || (!no_check && !DECL_P (gnu_decl))))); - - SET_GNU_TREE (gnat_entity, gnu_decl); - } - - /* GNAT_ENTITY is a GNAT tree node for a defining identifier. - Return the ..._DECL node that was associated with it. If there is no tree - node associated with GNAT_ENTITY, abort. - - In some cases, such as delayed elaboration or expressions that need to - be elaborated only once, GNAT_ENTITY is really not an entity. */ - - tree - get_gnu_tree (Entity_Id gnat_entity) - { - gcc_assert (PRESENT_GNU_TREE (gnat_entity)); - return GET_GNU_TREE (gnat_entity); - } - - /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */ - - bool - present_gnu_tree (Entity_Id gnat_entity) - { - return PRESENT_GNU_TREE (gnat_entity); - } - - /* Initialize the association of GNAT nodes to GCC trees as dummies. */ - - void - init_dummy_type (void) - { - dummy_node_table - = (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree)); - } - - /* Make a dummy type corresponding to GNAT_TYPE. */ - - tree - make_dummy_type (Entity_Id gnat_type) - { - Entity_Id gnat_underlying = Gigi_Equivalent_Type (gnat_type); - tree gnu_type; - - /* If there is an equivalent type, get its underlying type. */ - if (Present (gnat_underlying)) - gnat_underlying = Underlying_Type (gnat_underlying); - - /* If there was no equivalent type (can only happen when just annotating - types) or underlying type, go back to the original type. */ - if (No (gnat_underlying)) - gnat_underlying = gnat_type; - - /* If it there already a dummy type, use that one. Else make one. */ - if (PRESENT_DUMMY_NODE (gnat_underlying)) - return GET_DUMMY_NODE (gnat_underlying); - - /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make - an ENUMERAL_TYPE. */ - gnu_type = make_node (Is_Record_Type (gnat_underlying) - ? tree_code_for_record_type (gnat_underlying) - : ENUMERAL_TYPE); - TYPE_NAME (gnu_type) = get_entity_name (gnat_type); - TYPE_DUMMY_P (gnu_type) = 1; - if (AGGREGATE_TYPE_P (gnu_type)) - { - TYPE_STUB_DECL (gnu_type) = build_decl (TYPE_DECL, NULL_TREE, gnu_type); - TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_type); - } - - SET_DUMMY_NODE (gnat_underlying, gnu_type); - - return gnu_type; - } - - /* Return nonzero if we are currently in the global binding level. */ - - int - global_bindings_p (void) - { - return ((force_global || !current_function_decl) ? -1 : 0); - } - - /* Enter a new binding level. */ - - void - gnat_pushlevel () - { - struct gnat_binding_level *newlevel = NULL; - - /* Reuse a struct for this binding level, if there is one. */ - if (free_binding_level) - { - newlevel = free_binding_level; - free_binding_level = free_binding_level->chain; - } - else - newlevel - = (struct gnat_binding_level *) - ggc_alloc (sizeof (struct gnat_binding_level)); - - /* Use a free BLOCK, if any; otherwise, allocate one. */ - if (free_block_chain) - { - newlevel->block = free_block_chain; - free_block_chain = BLOCK_CHAIN (free_block_chain); - BLOCK_CHAIN (newlevel->block) = NULL_TREE; - } - else - newlevel->block = make_node (BLOCK); - - /* Point the BLOCK we just made to its parent. */ - if (current_binding_level) - BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block; - - BLOCK_VARS (newlevel->block) = BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE; - TREE_USED (newlevel->block) = 1; - - /* Add this level to the front of the chain (stack) of levels that are - active. */ - newlevel->chain = current_binding_level; - newlevel->jmpbuf_decl = NULL_TREE; - current_binding_level = newlevel; - } - - /* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL - and point FNDECL to this BLOCK. */ - - void - set_current_block_context (tree fndecl) - { - BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl; - DECL_INITIAL (fndecl) = current_binding_level->block; - } - - /* Set the jmpbuf_decl for the current binding level to DECL. */ - - void - set_block_jmpbuf_decl (tree decl) - { - current_binding_level->jmpbuf_decl = decl; - } - - /* Get the jmpbuf_decl, if any, for the current binding level. */ - - tree - get_block_jmpbuf_decl () - { - return current_binding_level->jmpbuf_decl; - } - - /* Exit a binding level. Set any BLOCK into the current code group. */ - - void - gnat_poplevel () - { - struct gnat_binding_level *level = current_binding_level; - tree block = level->block; - - BLOCK_VARS (block) = nreverse (BLOCK_VARS (block)); - BLOCK_SUBBLOCKS (block) = nreverse (BLOCK_SUBBLOCKS (block)); - - /* If this is a function-level BLOCK don't do anything. Otherwise, if there - are no variables free the block and merge its subblocks into those of its - parent block. Otherwise, add it to the list of its parent. */ - if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL) - ; - else if (BLOCK_VARS (block) == NULL_TREE) - { - BLOCK_SUBBLOCKS (level->chain->block) - = chainon (BLOCK_SUBBLOCKS (block), - BLOCK_SUBBLOCKS (level->chain->block)); - BLOCK_CHAIN (block) = free_block_chain; - free_block_chain = block; - } - else - { - BLOCK_CHAIN (block) = BLOCK_SUBBLOCKS (level->chain->block); - BLOCK_SUBBLOCKS (level->chain->block) = block; - TREE_USED (block) = 1; - set_block_for_group (block); - } - - /* Free this binding structure. */ - current_binding_level = level->chain; - level->chain = free_binding_level; - free_binding_level = level; - } - - /* Insert BLOCK at the end of the list of subblocks of the - current binding level. This is used when a BIND_EXPR is expanded, - to handle the BLOCK node inside the BIND_EXPR. */ - - void - insert_block (tree block) - { - TREE_USED (block) = 1; - TREE_CHAIN (block) = BLOCK_SUBBLOCKS (current_binding_level->block); - BLOCK_SUBBLOCKS (current_binding_level->block) = block; - } - - /* Records a ..._DECL node DECL as belonging to the current lexical scope - and uses GNAT_NODE for location information and propagating flags. */ - - void - gnat_pushdecl (tree decl, Node_Id gnat_node) - { - /* If at top level, there is no context. But PARM_DECLs always go in the - level of its function. */ - if (global_bindings_p () && TREE_CODE (decl) != PARM_DECL) - DECL_CONTEXT (decl) = 0; - else - { - DECL_CONTEXT (decl) = current_function_decl; - - /* Functions imported in another function are not really nested. */ - if (TREE_CODE (decl) == FUNCTION_DECL && TREE_PUBLIC (decl)) - DECL_NO_STATIC_CHAIN (decl) = 1; - } - - TREE_NO_WARNING (decl) = (gnat_node == Empty || Warnings_Off (gnat_node)); - - /* Set the location of DECL and emit a declaration for it. */ - if (Present (gnat_node)) - Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (decl)); - add_decl_expr (decl, gnat_node); - - /* Put the declaration on the list. The list of declarations is in reverse - order. The list will be reversed later. Put global variables in the - globals list and builtin functions in a dedicated list to speed up - further lookups. Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into - the list, as they will cause trouble with the debugger and aren't needed - anyway. */ - if (TREE_CODE (decl) != TYPE_DECL - || TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE) - { - if (global_bindings_p ()) - { - VEC_safe_push (tree, gc, global_decls, decl); - - if (TREE_CODE (decl) == FUNCTION_DECL && DECL_BUILT_IN (decl)) - VEC_safe_push (tree, gc, builtin_decls, decl); - } - else - { - TREE_CHAIN (decl) = BLOCK_VARS (current_binding_level->block); - BLOCK_VARS (current_binding_level->block) = decl; - } - } - - /* For the declaration of a type, set its name if it either is not already - set, was set to an IDENTIFIER_NODE, indicating an internal name, - or if the previous type name was not derived from a source name. - We'd rather have the type named with a real name and all the pointer - types to the same object have the same POINTER_TYPE node. Code in the - equivalent function of c-decl.c makes a copy of the type node here, but - that may cause us trouble with incomplete types. We make an exception - for fat pointer types because the compiler automatically builds them - for unconstrained array types and the debugger uses them to represent - both these and pointers to these. */ - if (TREE_CODE (decl) == TYPE_DECL && DECL_NAME (decl)) - { - tree t = TREE_TYPE (decl); - - if (!TYPE_NAME (t) || TREE_CODE (TYPE_NAME (t)) == IDENTIFIER_NODE) - TYPE_NAME (t) = decl; - else if (TYPE_FAT_POINTER_P (t)) - { - tree tt = build_variant_type_copy (t); - TYPE_NAME (tt) = decl; - TREE_USED (tt) = TREE_USED (t); - TREE_TYPE (decl) = tt; - DECL_ORIGINAL_TYPE (decl) = t; - } - else if (DECL_ARTIFICIAL (TYPE_NAME (t)) && !DECL_ARTIFICIAL (decl)) - TYPE_NAME (t) = decl; - } - } - - /* Do little here. Set up the standard declarations later after the - front end has been run. */ - - void - gnat_init_decl_processing (void) - { - /* Make the binding_level structure for global names. */ - current_function_decl = 0; - current_binding_level = 0; - free_binding_level = 0; - gnat_pushlevel (); - - build_common_tree_nodes (true, true); - - /* In Ada, we use a signed type for SIZETYPE. Use the signed type - corresponding to the size of Pmode. In most cases when ptr_mode and - Pmode differ, C will use the width of ptr_mode as sizetype. But we get - far better code using the width of Pmode. Make this here since we need - this before we can expand the GNAT types. */ - size_type_node = gnat_type_for_size (GET_MODE_BITSIZE (Pmode), 0); - set_sizetype (size_type_node); - build_common_tree_nodes_2 (0); - - ptr_void_type_node = build_pointer_type (void_type_node); - - gnat_install_builtins (); - } - - /* Install the builtin functions we might need. */ - - static void - gnat_install_builtins () - { - /* Builtins used by generic middle-end optimizers. */ - build_common_builtin_nodes (); - - /* Target specific builtins, such as the AltiVec family on ppc. */ - targetm.init_builtins (); - } - - /* Create the predefined scalar types such as `integer_type_node' needed - in the gcc back-end and initialize the global binding level. */ - - void - init_gigi_decls (tree long_long_float_type, tree exception_type) - { - tree endlink, decl; - unsigned int i; - - /* Set the types that GCC and Gigi use from the front end. We would like - to do this for char_type_node, but it needs to correspond to the C - char type. */ - if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE) - { - /* In this case, the builtin floating point types are VAX float, - so make up a type for use. */ - longest_float_type_node = make_node (REAL_TYPE); - TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE; - layout_type (longest_float_type_node); - create_type_decl (get_identifier ("longest float type"), - longest_float_type_node, NULL, false, true, Empty); - } - else - longest_float_type_node = TREE_TYPE (long_long_float_type); - - except_type_node = TREE_TYPE (exception_type); - - unsigned_type_node = gnat_type_for_size (INT_TYPE_SIZE, 1); - create_type_decl (get_identifier ("unsigned int"), unsigned_type_node, - NULL, false, true, Empty); - - void_type_decl_node = create_type_decl (get_identifier ("void"), - void_type_node, NULL, false, true, - Empty); - - void_ftype = build_function_type (void_type_node, NULL_TREE); - ptr_void_ftype = build_pointer_type (void_ftype); - - /* Now declare runtime functions. */ - endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE); - - /* malloc is a function declaration tree for a function to allocate - memory. */ - malloc_decl = create_subprog_decl (get_identifier ("__gnat_malloc"), - NULL_TREE, - build_function_type (ptr_void_type_node, - tree_cons (NULL_TREE, - sizetype, - endlink)), - NULL_TREE, false, true, true, NULL, - Empty); - DECL_IS_MALLOC (malloc_decl) = 1; - - /* free is a function declaration tree for a function to free memory. */ - free_decl - = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE, - build_function_type (void_type_node, - tree_cons (NULL_TREE, - ptr_void_type_node, - endlink)), - NULL_TREE, false, true, true, NULL, Empty); - - /* Make the types and functions used for exception processing. */ - jmpbuf_type - = build_array_type (gnat_type_for_mode (Pmode, 0), - build_index_type (build_int_cst (NULL_TREE, 5))); - create_type_decl (get_identifier ("JMPBUF_T"), jmpbuf_type, NULL, - true, true, Empty); - jmpbuf_ptr_type = build_pointer_type (jmpbuf_type); - - /* Functions to get and set the jumpbuf pointer for the current thread. */ - get_jmpbuf_decl - = create_subprog_decl - (get_identifier ("system__soft_links__get_jmpbuf_address_soft"), - NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE), - NULL_TREE, false, true, true, NULL, Empty); - /* Avoid creating superfluous edges to __builtin_setjmp receivers. */ - DECL_IS_PURE (get_jmpbuf_decl) = 1; - - set_jmpbuf_decl - = create_subprog_decl - (get_identifier ("system__soft_links__set_jmpbuf_address_soft"), - NULL_TREE, - build_function_type (void_type_node, - tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)), - NULL_TREE, false, true, true, NULL, Empty); - - /* Function to get the current exception. */ - get_excptr_decl - = create_subprog_decl - (get_identifier ("system__soft_links__get_gnat_exception"), - NULL_TREE, - build_function_type (build_pointer_type (except_type_node), NULL_TREE), - NULL_TREE, false, true, true, NULL, Empty); - /* Avoid creating superfluous edges to __builtin_setjmp receivers. */ - DECL_IS_PURE (get_excptr_decl) = 1; - - /* Functions that raise exceptions. */ - raise_nodefer_decl - = create_subprog_decl - (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE, - build_function_type (void_type_node, - tree_cons (NULL_TREE, - build_pointer_type (except_type_node), - endlink)), - NULL_TREE, false, true, true, NULL, Empty); - - /* Dummy objects to materialize "others" and "all others" in the exception - tables. These are exported by a-exexpr.adb, so see this unit for the - types to use. */ - - others_decl - = create_var_decl (get_identifier ("OTHERS"), - get_identifier ("__gnat_others_value"), - integer_type_node, 0, 1, 0, 1, 1, 0, Empty); - - all_others_decl - = create_var_decl (get_identifier ("ALL_OTHERS"), - get_identifier ("__gnat_all_others_value"), - integer_type_node, 0, 1, 0, 1, 1, 0, Empty); - - /* Hooks to call when entering/leaving an exception handler. */ - begin_handler_decl - = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE, - build_function_type (void_type_node, - tree_cons (NULL_TREE, - ptr_void_type_node, - endlink)), - NULL_TREE, false, true, true, NULL, Empty); - - end_handler_decl - = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE, - build_function_type (void_type_node, - tree_cons (NULL_TREE, - ptr_void_type_node, - endlink)), - NULL_TREE, false, true, true, NULL, Empty); - - /* If in no exception handlers mode, all raise statements are redirected to - __gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since - this procedure will never be called in this mode. */ - if (No_Exception_Handlers_Set ()) - { - decl - = create_subprog_decl - (get_identifier ("__gnat_last_chance_handler"), NULL_TREE, - build_function_type (void_type_node, - tree_cons (NULL_TREE, - build_pointer_type (char_type_node), - tree_cons (NULL_TREE, - integer_type_node, - endlink))), - NULL_TREE, false, true, true, NULL, Empty); - - for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++) - gnat_raise_decls[i] = decl; - } - else - /* Otherwise, make one decl for each exception reason. */ - for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++) - { - char name[17]; - - sprintf (name, "__gnat_rcheck_%.2d", i); - gnat_raise_decls[i] - = create_subprog_decl - (get_identifier (name), NULL_TREE, - build_function_type (void_type_node, - tree_cons (NULL_TREE, - build_pointer_type - (char_type_node), - tree_cons (NULL_TREE, - integer_type_node, - endlink))), - NULL_TREE, false, true, true, NULL, Empty); - } - - /* Indicate that these never return. */ - TREE_THIS_VOLATILE (raise_nodefer_decl) = 1; - TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1; - TREE_TYPE (raise_nodefer_decl) - = build_qualified_type (TREE_TYPE (raise_nodefer_decl), - TYPE_QUAL_VOLATILE); - - for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++) - { - TREE_THIS_VOLATILE (gnat_raise_decls[i]) = 1; - TREE_SIDE_EFFECTS (gnat_raise_decls[i]) = 1; - TREE_TYPE (gnat_raise_decls[i]) - = build_qualified_type (TREE_TYPE (gnat_raise_decls[i]), - TYPE_QUAL_VOLATILE); - } - - /* setjmp returns an integer and has one operand, which is a pointer to - a jmpbuf. */ - setjmp_decl - = create_subprog_decl - (get_identifier ("__builtin_setjmp"), NULL_TREE, - build_function_type (integer_type_node, - tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)), - NULL_TREE, false, true, true, NULL, Empty); - - DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL; - DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP; - - /* update_setjmp_buf updates a setjmp buffer from the current stack pointer - address. */ - update_setjmp_buf_decl - = create_subprog_decl - (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE, - build_function_type (void_type_node, - tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)), - NULL_TREE, false, true, true, NULL, Empty); - - DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL; - DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF; - - main_identifier_node = get_identifier ("main"); - } - - /* Given a record type RECORD_TYPE and a chain of FIELD_DECL nodes FIELDLIST, - finish constructing the record or union type. If REP_LEVEL is zero, this - record has no representation clause and so will be entirely laid out here. - If REP_LEVEL is one, this record has a representation clause and has been - laid out already; only set the sizes and alignment. If REP_LEVEL is two, - this record is derived from a parent record and thus inherits its layout; - only make a pass on the fields to finalize them. If DO_NOT_FINALIZE is - true, the record type is expected to be modified afterwards so it will - not be sent to the back-end for finalization. */ - - void - finish_record_type (tree record_type, tree fieldlist, int rep_level, - bool do_not_finalize) - { - enum tree_code code = TREE_CODE (record_type); - tree name = TYPE_NAME (record_type); - tree ada_size = bitsize_zero_node; - tree size = bitsize_zero_node; - bool var_size = false; - bool had_size = TYPE_SIZE (record_type) != 0; - bool had_size_unit = TYPE_SIZE_UNIT (record_type) != 0; - tree field; - - if (name && TREE_CODE (name) == TYPE_DECL) - name = DECL_NAME (name); - - TYPE_FIELDS (record_type) = fieldlist; - TYPE_STUB_DECL (record_type) = build_decl (TYPE_DECL, name, record_type); - - /* We don't need both the typedef name and the record name output in - the debugging information, since they are the same. */ - DECL_ARTIFICIAL (TYPE_STUB_DECL (record_type)) = 1; - - /* Globally initialize the record first. If this is a rep'ed record, - that just means some initializations; otherwise, layout the record. */ - if (rep_level > 0) - { - TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type)); - TYPE_MODE (record_type) = BLKmode; - - if (!had_size_unit) - TYPE_SIZE_UNIT (record_type) = size_zero_node; - if (!had_size) - TYPE_SIZE (record_type) = bitsize_zero_node; - - /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE - out just like a UNION_TYPE, since the size will be fixed. */ - else if (code == QUAL_UNION_TYPE) - code = UNION_TYPE; - } - else - { - /* Ensure there isn't a size already set. There can be in an error - case where there is a rep clause but all fields have errors and - no longer have a position. */ - TYPE_SIZE (record_type) = 0; - layout_type (record_type); - } - - /* At this point, the position and size of each field is known. It was - either set before entry by a rep clause, or by laying out the type above. - - We now run a pass over the fields (in reverse order for QUAL_UNION_TYPEs) - to compute the Ada size; the GCC size and alignment (for rep'ed records - that are not padding types); and the mode (for rep'ed records). We also - clear the DECL_BIT_FIELD indication for the cases we know have not been - handled yet, and adjust DECL_NONADDRESSABLE_P accordingly. */ - - if (code == QUAL_UNION_TYPE) - fieldlist = nreverse (fieldlist); - - for (field = fieldlist; field; field = TREE_CHAIN (field)) - { - tree pos = bit_position (field); - - tree type = TREE_TYPE (field); - tree this_size = DECL_SIZE (field); - tree this_ada_size = DECL_SIZE (field); - - /* We need to make an XVE/XVU record if any field has variable size, - whether or not the record does. For example, if we have a union, - it may be that all fields, rounded up to the alignment, have the - same size, in which case we'll use that size. But the debug - output routines (except Dwarf2) won't be able to output the fields, - so we need to make the special record. */ - if (TREE_CODE (this_size) != INTEGER_CST) - var_size = true; - - if ((TREE_CODE (type) == RECORD_TYPE || TREE_CODE (type) == UNION_TYPE - || TREE_CODE (type) == QUAL_UNION_TYPE) - && !TYPE_IS_FAT_POINTER_P (type) - && !TYPE_CONTAINS_TEMPLATE_P (type) - && TYPE_ADA_SIZE (type)) - this_ada_size = TYPE_ADA_SIZE (type); - - /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle. */ - if (DECL_BIT_FIELD (field) && !STRICT_ALIGNMENT - && value_factor_p (pos, BITS_PER_UNIT) - && operand_equal_p (this_size, TYPE_SIZE (type), 0)) - DECL_BIT_FIELD (field) = 0; - - /* If we still have DECL_BIT_FIELD set at this point, we know the field - is technically not addressable. Except that it can actually be - addressed if the field is BLKmode and happens to be properly - aligned. */ - DECL_NONADDRESSABLE_P (field) - |= DECL_BIT_FIELD (field) && DECL_MODE (field) != BLKmode; - - if ((rep_level > 0) && !DECL_BIT_FIELD (field)) - TYPE_ALIGN (record_type) - = MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field)); - - switch (code) - { - case UNION_TYPE: - ada_size = size_binop (MAX_EXPR, ada_size, this_ada_size); - size = size_binop (MAX_EXPR, size, this_size); - break; - - case QUAL_UNION_TYPE: - ada_size - = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field), - this_ada_size, ada_size); - size = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field), - this_size, size); - break; - - case RECORD_TYPE: - /* Since we know here that all fields are sorted in order of - increasing bit position, the size of the record is one - higher than the ending bit of the last field processed - unless we have a rep clause, since in that case we might - have a field outside a QUAL_UNION_TYPE that has a higher ending - position. So use a MAX in that case. Also, if this field is a - QUAL_UNION_TYPE, we need to take into account the previous size in - the case of empty variants. */ - ada_size - = merge_sizes (ada_size, pos, this_ada_size, - TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0); - size - = merge_sizes (size, pos, this_size, - TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0); - break; - - default: - gcc_unreachable (); - } - } - - if (code == QUAL_UNION_TYPE) - nreverse (fieldlist); - - if (rep_level < 2) - { - /* If this is a padding record, we never want to make the size smaller - than what was specified in it, if any. */ - if (TREE_CODE (record_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type)) - size = TYPE_SIZE (record_type); - - /* Now set any of the values we've just computed that apply. */ - if (!TYPE_IS_FAT_POINTER_P (record_type) - && !TYPE_CONTAINS_TEMPLATE_P (record_type)) - SET_TYPE_ADA_SIZE (record_type, ada_size); - - if (rep_level > 0) - { - tree size_unit = had_size_unit - ? TYPE_SIZE_UNIT (record_type) - : convert (sizetype, - size_binop (CEIL_DIV_EXPR, size, - bitsize_unit_node)); - unsigned int align = TYPE_ALIGN (record_type); - - TYPE_SIZE (record_type) = variable_size (round_up (size, align)); - TYPE_SIZE_UNIT (record_type) - = variable_size (round_up (size_unit, align / BITS_PER_UNIT)); - - compute_record_mode (record_type); - } - } - - if (!do_not_finalize) - rest_of_record_type_compilation (record_type); - } - - /* Wrap up compilation of RECORD_TYPE, i.e. most notably output all - the debug information associated with it. It need not be invoked - directly in most cases since finish_record_type takes care of doing - so, unless explicitly requested not to through DO_NOT_FINALIZE. */ - - void - rest_of_record_type_compilation (tree record_type) - { - tree fieldlist = TYPE_FIELDS (record_type); - tree field; - enum tree_code code = TREE_CODE (record_type); - bool var_size = false; - - for (field = fieldlist; field; field = TREE_CHAIN (field)) - { - /* We need to make an XVE/XVU record if any field has variable size, - whether or not the record does. For example, if we have a union, - it may be that all fields, rounded up to the alignment, have the - same size, in which case we'll use that size. But the debug - output routines (except Dwarf2) won't be able to output the fields, - so we need to make the special record. */ - if (TREE_CODE (DECL_SIZE (field)) != INTEGER_CST - /* If a field has a non-constant qualifier, the record will have - variable size too. */ - || (code == QUAL_UNION_TYPE - && TREE_CODE (DECL_QUALIFIER (field)) != INTEGER_CST)) - { - var_size = true; - break; - } - } - - /* If this record is of variable size, rename it so that the - debugger knows it is and make a new, parallel, record - that tells the debugger how the record is laid out. See - exp_dbug.ads. But don't do this for records that are padding - since they confuse GDB. */ - if (var_size - && !(TREE_CODE (record_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (record_type))) - { - tree new_record_type - = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE - ? UNION_TYPE : TREE_CODE (record_type)); - tree orig_name = TYPE_NAME (record_type); - tree orig_id - = (TREE_CODE (orig_name) == TYPE_DECL ? DECL_NAME (orig_name) - : orig_name); - tree new_id - = concat_id_with_name (orig_id, - TREE_CODE (record_type) == QUAL_UNION_TYPE - ? "XVU" : "XVE"); - tree last_pos = bitsize_zero_node; - tree old_field; - tree prev_old_field = 0; - - TYPE_NAME (new_record_type) = new_id; - TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT; - TYPE_STUB_DECL (new_record_type) - = build_decl (TYPE_DECL, new_id, new_record_type); - DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type)) = 1; - DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type)) - = DECL_IGNORED_P (TYPE_STUB_DECL (record_type)); - TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type)); - TYPE_SIZE_UNIT (new_record_type) - = size_int (TYPE_ALIGN (record_type) / BITS_PER_UNIT); - - /* Now scan all the fields, replacing each field with a new - field corresponding to the new encoding. */ - for (old_field = TYPE_FIELDS (record_type); old_field; - old_field = TREE_CHAIN (old_field)) - { - tree field_type = TREE_TYPE (old_field); - tree field_name = DECL_NAME (old_field); - tree new_field; - tree curpos = bit_position (old_field); - bool var = false; - unsigned int align = 0; - tree pos; - - /* See how the position was modified from the last position. - - There are two basic cases we support: a value was added - to the last position or the last position was rounded to - a boundary and they something was added. Check for the - first case first. If not, see if there is any evidence - of rounding. If so, round the last position and try - again. - - If this is a union, the position can be taken as zero. */ - - if (TREE_CODE (new_record_type) == UNION_TYPE) - pos = bitsize_zero_node, align = 0; - else - pos = compute_related_constant (curpos, last_pos); - - if (!pos && TREE_CODE (curpos) == MULT_EXPR - && host_integerp (TREE_OPERAND (curpos, 1), 1)) - { - tree offset = TREE_OPERAND (curpos, 0); - align = tree_low_cst (TREE_OPERAND (curpos, 1), 1); - - /* Strip off any conversions. */ - while (TREE_CODE (offset) == NON_LVALUE_EXPR - || TREE_CODE (offset) == NOP_EXPR - || TREE_CODE (offset) == CONVERT_EXPR) - offset = TREE_OPERAND (offset, 0); - - /* An offset which is a bitwise AND with a negative power of 2 - means an alignment corresponding to this power of 2. */ - if (TREE_CODE (offset) == BIT_AND_EXPR - && host_integerp (TREE_OPERAND (offset, 1), 0) - && tree_int_cst_sgn (TREE_OPERAND (offset, 1)) < 0) - { - unsigned int pow - = - tree_low_cst (TREE_OPERAND (offset, 1), 0); - if (exact_log2 (pow) > 0) - align *= pow; - } - - pos = compute_related_constant (curpos, - round_up (last_pos, align)); - } - else if (!pos && TREE_CODE (curpos) == PLUS_EXPR - && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST - && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR - && host_integerp (TREE_OPERAND - (TREE_OPERAND (curpos, 0), 1), - 1)) - { - align - = tree_low_cst - (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1), 1); - pos = compute_related_constant (curpos, - round_up (last_pos, align)); - } - else if (potential_alignment_gap (prev_old_field, old_field, - pos)) - { - align = TYPE_ALIGN (field_type); - pos = compute_related_constant (curpos, - round_up (last_pos, align)); - } - - /* If we can't compute a position, set it to zero. - - ??? We really should abort here, but it's too much work - to get this correct for all cases. */ - - if (!pos) - pos = bitsize_zero_node; - - /* See if this type is variable-sized and make a pointer type - and indicate the indirection if so. Beware that the debug - back-end may adjust the position computed above according - to the alignment of the field type, i.e. the pointer type - in this case, if we don't preventively counter that. */ - if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST) - { - field_type = build_pointer_type (field_type); - if (align != 0 && TYPE_ALIGN (field_type) > align) - { - field_type = copy_node (field_type); - TYPE_ALIGN (field_type) = align; - } - var = true; - } - - /* Make a new field name, if necessary. */ - if (var || align != 0) - { - char suffix[16]; - - if (align != 0) - sprintf (suffix, "XV%c%u", var ? 'L' : 'A', - align / BITS_PER_UNIT); - else - strcpy (suffix, "XVL"); - - field_name = concat_id_with_name (field_name, suffix); - } - - new_field = create_field_decl (field_name, field_type, - new_record_type, 0, - DECL_SIZE (old_field), pos, 0); - TREE_CHAIN (new_field) = TYPE_FIELDS (new_record_type); - TYPE_FIELDS (new_record_type) = new_field; - - /* If old_field is a QUAL_UNION_TYPE, take its size as being - zero. The only time it's not the last field of the record - is when there are other components at fixed positions after - it (meaning there was a rep clause for every field) and we - want to be able to encode them. */ - last_pos = size_binop (PLUS_EXPR, bit_position (old_field), - (TREE_CODE (TREE_TYPE (old_field)) - == QUAL_UNION_TYPE) - ? bitsize_zero_node - : DECL_SIZE (old_field)); - prev_old_field = old_field; - } - - TYPE_FIELDS (new_record_type) - = nreverse (TYPE_FIELDS (new_record_type)); - - rest_of_type_decl_compilation (TYPE_STUB_DECL (new_record_type)); - } - - rest_of_type_decl_compilation (TYPE_STUB_DECL (record_type)); - } - - /* Utility function of above to merge LAST_SIZE, the previous size of a record - with FIRST_BIT and SIZE that describe a field. SPECIAL is nonzero - if this represents a QUAL_UNION_TYPE in which case we must look for - COND_EXPRs and replace a value of zero with the old size. If HAS_REP - is nonzero, we must take the MAX of the end position of this field - with LAST_SIZE. In all other cases, we use FIRST_BIT plus SIZE. - - We return an expression for the size. */ - - static tree - merge_sizes (tree last_size, tree first_bit, tree size, bool special, - bool has_rep) - { - tree type = TREE_TYPE (last_size); - tree new; - - if (!special || TREE_CODE (size) != COND_EXPR) - { - new = size_binop (PLUS_EXPR, first_bit, size); - if (has_rep) - new = size_binop (MAX_EXPR, last_size, new); - } - - else - new = fold_build3 (COND_EXPR, type, TREE_OPERAND (size, 0), - integer_zerop (TREE_OPERAND (size, 1)) - ? last_size : merge_sizes (last_size, first_bit, - TREE_OPERAND (size, 1), - 1, has_rep), - integer_zerop (TREE_OPERAND (size, 2)) - ? last_size : merge_sizes (last_size, first_bit, - TREE_OPERAND (size, 2), - 1, has_rep)); - - /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially - when fed through substitute_in_expr) into thinking that a constant - size is not constant. */ - while (TREE_CODE (new) == NON_LVALUE_EXPR) - new = TREE_OPERAND (new, 0); - - return new; - } - - /* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are - related by the addition of a constant. Return that constant if so. */ - - static tree - compute_related_constant (tree op0, tree op1) - { - tree op0_var, op1_var; - tree op0_con = split_plus (op0, &op0_var); - tree op1_con = split_plus (op1, &op1_var); - tree result = size_binop (MINUS_EXPR, op0_con, op1_con); - - if (operand_equal_p (op0_var, op1_var, 0)) - return result; - else if (operand_equal_p (op0, size_binop (PLUS_EXPR, op1_var, result), 0)) - return result; - else - return 0; - } - - /* Utility function of above to split a tree OP which may be a sum, into a - constant part, which is returned, and a variable part, which is stored - in *PVAR. *PVAR may be bitsize_zero_node. All operations must be of - bitsizetype. */ - - static tree - split_plus (tree in, tree *pvar) - { - /* Strip NOPS in order to ease the tree traversal and maximize the - potential for constant or plus/minus discovery. We need to be careful - to always return and set *pvar to bitsizetype trees, but it's worth - the effort. */ - STRIP_NOPS (in); - - *pvar = convert (bitsizetype, in); - - if (TREE_CODE (in) == INTEGER_CST) - { - *pvar = bitsize_zero_node; - return convert (bitsizetype, in); - } - else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR) - { - tree lhs_var, rhs_var; - tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var); - tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var); - - if (lhs_var == TREE_OPERAND (in, 0) - && rhs_var == TREE_OPERAND (in, 1)) - return bitsize_zero_node; - - *pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var); - return size_binop (TREE_CODE (in), lhs_con, rhs_con); - } - else - return bitsize_zero_node; - } - - /* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the - subprogram. If it is void_type_node, then we are dealing with a procedure, - otherwise we are dealing with a function. PARAM_DECL_LIST is a list of - PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the - copy-in/copy-out list to be stored into TYPE_CICO_LIST. - RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained - object. RETURNS_BY_REF is nonzero if the function returns by reference. - RETURNS_WITH_DSP is nonzero if the function is to return with a - depressed stack pointer. RETURNS_BY_TARGET_PTR is true if the function - is to be passed (as its first parameter) the address of the place to copy - its result. */ - - tree - create_subprog_type (tree return_type, tree param_decl_list, tree cico_list, - bool returns_unconstrained, bool returns_by_ref, - bool returns_with_dsp, bool returns_by_target_ptr) - { - /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of - the subprogram formal parameters. This list is generated by traversing the - input list of PARM_DECL nodes. */ - tree param_type_list = NULL; - tree param_decl; - tree type; - - for (param_decl = param_decl_list; param_decl; - param_decl = TREE_CHAIN (param_decl)) - param_type_list = tree_cons (NULL_TREE, TREE_TYPE (param_decl), - param_type_list); - - /* The list of the function parameter types has to be terminated by the void - type to signal to the back-end that we are not dealing with a variable - parameter subprogram, but that the subprogram has a fixed number of - parameters. */ - param_type_list = tree_cons (NULL_TREE, void_type_node, param_type_list); - - /* The list of argument types has been created in reverse - so nreverse it. */ - param_type_list = nreverse (param_type_list); - - type = build_function_type (return_type, param_type_list); - - /* TYPE may have been shared since GCC hashes types. If it has a CICO_LIST - or the new type should, make a copy of TYPE. Likewise for - RETURNS_UNCONSTRAINED and RETURNS_BY_REF. */ - if (TYPE_CI_CO_LIST (type) || cico_list - || TYPE_RETURNS_UNCONSTRAINED_P (type) != returns_unconstrained - || TYPE_RETURNS_BY_REF_P (type) != returns_by_ref - || TYPE_RETURNS_BY_TARGET_PTR_P (type) != returns_by_target_ptr) - type = copy_type (type); - - TYPE_CI_CO_LIST (type) = cico_list; - TYPE_RETURNS_UNCONSTRAINED_P (type) = returns_unconstrained; - TYPE_RETURNS_STACK_DEPRESSED (type) = returns_with_dsp; - TYPE_RETURNS_BY_REF_P (type) = returns_by_ref; - TYPE_RETURNS_BY_TARGET_PTR_P (type) = returns_by_target_ptr; - return type; - } - - /* Return a copy of TYPE but safe to modify in any way. */ - - tree - copy_type (tree type) - { - tree new = copy_node (type); - - /* copy_node clears this field instead of copying it, because it is - aliased with TREE_CHAIN. */ - TYPE_STUB_DECL (new) = TYPE_STUB_DECL (type); - - TYPE_POINTER_TO (new) = 0; - TYPE_REFERENCE_TO (new) = 0; - TYPE_MAIN_VARIANT (new) = new; - TYPE_NEXT_VARIANT (new) = 0; - - return new; - } - - /* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose - TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position of - the decl. */ - - tree - create_index_type (tree min, tree max, tree index, Node_Id gnat_node) - { - /* First build a type for the desired range. */ - tree type = build_index_2_type (min, max); - - /* If this type has the TYPE_INDEX_TYPE we want, return it. Otherwise, if it - doesn't have TYPE_INDEX_TYPE set, set it to INDEX. If TYPE_INDEX_TYPE - is set, but not to INDEX, make a copy of this type with the requested - index type. Note that we have no way of sharing these types, but that's - only a small hole. */ - if (TYPE_INDEX_TYPE (type) == index) - return type; - else if (TYPE_INDEX_TYPE (type)) - type = copy_type (type); - - SET_TYPE_INDEX_TYPE (type, index); - create_type_decl (NULL_TREE, type, NULL, true, false, gnat_node); - return type; - } - - /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character - string) and TYPE is a ..._TYPE node giving its data type. - ARTIFICIAL_P is true if this is a declaration that was generated - by the compiler. DEBUG_INFO_P is true if we need to write debugging - information about this type. GNAT_NODE is used for the position of - the decl. */ - - tree - create_type_decl (tree type_name, tree type, struct attrib *attr_list, - bool artificial_p, bool debug_info_p, Node_Id gnat_node) - { - tree type_decl = build_decl (TYPE_DECL, type_name, type); - enum tree_code code = TREE_CODE (type); - - DECL_ARTIFICIAL (type_decl) = artificial_p; - - if (!TYPE_IS_DUMMY_P (type)) - gnat_pushdecl (type_decl, gnat_node); - - process_attributes (type_decl, attr_list); - - /* Pass type declaration information to the debugger unless this is an - UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support, - and ENUMERAL_TYPE or RECORD_TYPE which is handled separately, or - type for which debugging information was not requested. */ - if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p) - DECL_IGNORED_P (type_decl) = 1; - else if (code != ENUMERAL_TYPE - && (code != RECORD_TYPE || TYPE_IS_FAT_POINTER_P (type)) - && !((code == POINTER_TYPE || code == REFERENCE_TYPE) - && TYPE_IS_DUMMY_P (TREE_TYPE (type)))) - rest_of_type_decl_compilation (type_decl); - - return type_decl; - } - - /* Helper for create_var_decl and create_true_var_decl. Returns a GCC VAR_DECL - or CONST_DECL node. - - VAR_NAME gives the name of the variable. ASM_NAME is its assembler name - (if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is - the GCC tree for an optional initial expression; NULL_TREE if none. - - CONST_FLAG is true if this variable is constant, in which case we might - return a CONST_DECL node unless CONST_DECL_ALLOWED_FLAG is false. - - PUBLIC_FLAG is true if this definition is to be made visible outside of - the current compilation unit. This flag should be set when processing the - variable definitions in a package specification. EXTERN_FLAG is nonzero - when processing an external variable declaration (as opposed to a - definition: no storage is to be allocated for the variable here). - - STATIC_FLAG is only relevant when not at top level. In that case - it indicates whether to always allocate storage to the variable. - - GNAT_NODE is used for the position of the decl. */ - - static tree - create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init, - bool const_flag, bool const_decl_allowed_flag, - bool public_flag, bool extern_flag, bool static_flag, - struct attrib *attr_list, Node_Id gnat_node) - { - bool init_const - = (var_init != 0 - && TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (var_init)) - && (global_bindings_p () || static_flag - ? initializer_constant_valid_p (var_init, TREE_TYPE (var_init)) != 0 - : TREE_CONSTANT (var_init))); - - /* Whether we will make TREE_CONSTANT the DECL we produce here, in which - case the initializer may be used in-lieu of the DECL node (as done in - Identifier_to_gnu). This is useful to prevent the need of elaboration - code when an identifier for which such a decl is made is in turn used as - an initializer. We used to rely on CONST vs VAR_DECL for this purpose, - but extra constraints apply to this choice (see below) and are not - relevant to the distinction we wish to make. */ - bool constant_p = const_flag && init_const; - - /* The actual DECL node. CONST_DECL was initially intended for enumerals - and may be used for scalars in general but not for aggregates. */ - tree var_decl - = build_decl ((constant_p && const_decl_allowed_flag - && !AGGREGATE_TYPE_P (type)) ? CONST_DECL : VAR_DECL, - var_name, type); - - /* If this is external, throw away any initializations (they will be done - elsewhere) unless this is a a constant for which we would like to remain - able to get the initializer. If we are defining a global here, leave a - constant initialization and save any variable elaborations for the - elaboration routine. If we are just annotating types, throw away the - initialization if it isn't a constant. */ - if ((extern_flag && !constant_p) - || (type_annotate_only && var_init && !TREE_CONSTANT (var_init))) - var_init = NULL_TREE; - - /* At the global level, an initializer requiring code to be generated - produces elaboration statements. Check that such statements are allowed, - that is, not violating a No_Elaboration_Code restriction. */ - if (global_bindings_p () && var_init != 0 && ! init_const) - Check_Elaboration_Code_Allowed (gnat_node); - - /* Ada doesn't feature Fortran-like COMMON variables so we shouldn't - try to fiddle with DECL_COMMON. However, on platforms that don't - support global BSS sections, uninitialized global variables would - go in DATA instead, thus increasing the size of the executable. */ - if (!flag_no_common - && TREE_CODE (var_decl) == VAR_DECL - && !have_global_bss_p ()) - DECL_COMMON (var_decl) = 1; - DECL_INITIAL (var_decl) = var_init; - TREE_READONLY (var_decl) = const_flag; - DECL_EXTERNAL (var_decl) = extern_flag; - TREE_PUBLIC (var_decl) = public_flag || extern_flag; - TREE_CONSTANT (var_decl) = constant_p; - TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl) - = TYPE_VOLATILE (type); - - /* If it's public and not external, always allocate storage for it. - At the global binding level we need to allocate static storage for the - variable if and only if it's not external. If we are not at the top level - we allocate automatic storage unless requested not to. */ - TREE_STATIC (var_decl) - = public_flag || (global_bindings_p () ? !extern_flag : static_flag); - - if (asm_name && VAR_OR_FUNCTION_DECL_P (var_decl)) - SET_DECL_ASSEMBLER_NAME (var_decl, asm_name); - - process_attributes (var_decl, attr_list); - - /* Add this decl to the current binding level. */ - gnat_pushdecl (var_decl, gnat_node); - - if (TREE_SIDE_EFFECTS (var_decl)) - TREE_ADDRESSABLE (var_decl) = 1; - - if (TREE_CODE (var_decl) != CONST_DECL) - { - if (global_bindings_p ()) - rest_of_decl_compilation (var_decl, true, 0); - } - else - expand_decl (var_decl); - - return var_decl; - } - - /* Wrapper around create_var_decl_1 for cases where we don't care whether - a VAR or a CONST decl node is created. */ - - tree - create_var_decl (tree var_name, tree asm_name, tree type, tree var_init, - bool const_flag, bool public_flag, bool extern_flag, - bool static_flag, struct attrib *attr_list, - Node_Id gnat_node) - { - return create_var_decl_1 (var_name, asm_name, type, var_init, - const_flag, true, - public_flag, extern_flag, static_flag, - attr_list, gnat_node); - } - - /* Wrapper around create_var_decl_1 for cases where a VAR_DECL node is - required. The primary intent is for DECL_CONST_CORRESPONDING_VARs, which - must be VAR_DECLs and on which we want TREE_READONLY set to have them - possibly assigned to a readonly data section. */ - - tree - create_true_var_decl (tree var_name, tree asm_name, tree type, tree var_init, - bool const_flag, bool public_flag, bool extern_flag, - bool static_flag, struct attrib *attr_list, - Node_Id gnat_node) - { - return create_var_decl_1 (var_name, asm_name, type, var_init, - const_flag, false, - public_flag, extern_flag, static_flag, - attr_list, gnat_node); - } - - /* Return true if TYPE, an aggregate type, contains (or is) an array. */ - - static bool - aggregate_type_contains_array_p (tree type) - { - switch (TREE_CODE (type)) - { - case RECORD_TYPE: - case UNION_TYPE: - case QUAL_UNION_TYPE: - { - tree field; - for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) - if (AGGREGATE_TYPE_P (TREE_TYPE (field)) - && aggregate_type_contains_array_p (TREE_TYPE (field))) - return true; - return false; - } - - case ARRAY_TYPE: - return true; - - default: - gcc_unreachable (); - } - } - - /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its - type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if - this field is in a record type with a "pragma pack". If SIZE is nonzero - it is the specified size for this field. If POS is nonzero, it is the bit - position. If ADDRESSABLE is nonzero, it means we are allowed to take - the address of this field for aliasing purposes. If it is negative, we - should not make a bitfield, which is used by make_aligning_type. */ - - tree - create_field_decl (tree field_name, tree field_type, tree record_type, - int packed, tree size, tree pos, int addressable) - { - tree field_decl = build_decl (FIELD_DECL, field_name, field_type); - - DECL_CONTEXT (field_decl) = record_type; - TREE_READONLY (field_decl) = TYPE_READONLY (field_type); - - /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a - byte boundary since GCC cannot handle less-aligned BLKmode bitfields. - Likewise for an aggregate without specified position that contains an - array, because in this case slices of variable length of this array - must be handled by GCC and variable-sized objects need to be aligned - to at least a byte boundary. */ - if (packed && (TYPE_MODE (field_type) == BLKmode - || (!pos - && AGGREGATE_TYPE_P (field_type) - && aggregate_type_contains_array_p (field_type)))) - DECL_ALIGN (field_decl) = BITS_PER_UNIT; - - /* If a size is specified, use it. Otherwise, if the record type is packed - compute a size to use, which may differ from the object's natural size. - We always set a size in this case to trigger the checks for bitfield - creation below, which is typically required when no position has been - specified. */ - if (size) - size = convert (bitsizetype, size); - else if (packed == 1) - { - size = rm_size (field_type); - - /* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to - byte. */ - if (TREE_CODE (size) == INTEGER_CST - && compare_tree_int (size, MAX_FIXED_MODE_SIZE) > 0) - size = round_up (size, BITS_PER_UNIT); - } - - /* If we may, according to ADDRESSABLE, make a bitfield if a size is - specified for two reasons: first if the size differs from the natural - size. Second, if the alignment is insufficient. There are a number of - ways the latter can be true. - - We never make a bitfield if the type of the field has a nonconstant size, - because no such entity requiring bitfield operations should reach here. - - We do *preventively* make a bitfield when there might be the need for it - but we don't have all the necessary information to decide, as is the case - of a field with no specified position in a packed record. - - We also don't look at STRICT_ALIGNMENT here, and rely on later processing - in layout_decl or finish_record_type to clear the bit_field indication if - it is in fact not needed. */ - if (addressable >= 0 - && size - && TREE_CODE (size) == INTEGER_CST - && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST - && (!tree_int_cst_equal (size, TYPE_SIZE (field_type)) - || (pos && !value_factor_p (pos, TYPE_ALIGN (field_type))) - || packed - || (TYPE_ALIGN (record_type) != 0 - && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type)))) - { - DECL_BIT_FIELD (field_decl) = 1; - DECL_SIZE (field_decl) = size; - if (!packed && !pos) - DECL_ALIGN (field_decl) - = (TYPE_ALIGN (record_type) != 0 - ? MIN (TYPE_ALIGN (record_type), TYPE_ALIGN (field_type)) - : TYPE_ALIGN (field_type)); - } - - DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed; - - /* Bump the alignment if need be, either for bitfield/packing purposes or - to satisfy the type requirements if no such consideration applies. When - we get the alignment from the type, indicate if this is from an explicit - user request, which prevents stor-layout from lowering it later on. */ - { - int bit_align - = (DECL_BIT_FIELD (field_decl) ? 1 - : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT : 0); - - if (bit_align > DECL_ALIGN (field_decl)) - DECL_ALIGN (field_decl) = bit_align; - else if (!bit_align && TYPE_ALIGN (field_type) > DECL_ALIGN (field_decl)) - { - DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type); - DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (field_type); - } - } - - if (pos) - { - /* We need to pass in the alignment the DECL is known to have. - This is the lowest-order bit set in POS, but no more than - the alignment of the record, if one is specified. Note - that an alignment of 0 is taken as infinite. */ - unsigned int known_align; - - if (host_integerp (pos, 1)) - known_align = tree_low_cst (pos, 1) & - tree_low_cst (pos, 1); - else - known_align = BITS_PER_UNIT; - - if (TYPE_ALIGN (record_type) - && (known_align == 0 || known_align > TYPE_ALIGN (record_type))) - known_align = TYPE_ALIGN (record_type); - - layout_decl (field_decl, known_align); - SET_DECL_OFFSET_ALIGN (field_decl, - host_integerp (pos, 1) ? BIGGEST_ALIGNMENT - : BITS_PER_UNIT); - pos_from_bit (&DECL_FIELD_OFFSET (field_decl), - &DECL_FIELD_BIT_OFFSET (field_decl), - DECL_OFFSET_ALIGN (field_decl), pos); - - DECL_HAS_REP_P (field_decl) = 1; - } - - /* In addition to what our caller says, claim the field is addressable if we - know that its type is not suitable. - - The field may also be "technically" nonaddressable, meaning that even if - we attempt to take the field's address we will actually get the address - of a copy. This is the case for true bitfields, but the DECL_BIT_FIELD - value we have at this point is not accurate enough, so we don't account - for this here and let finish_record_type decide. */ - if (!type_for_nonaliased_component_p (field_type)) - addressable = 1; - - DECL_NONADDRESSABLE_P (field_decl) = !addressable; - - return field_decl; - } - - /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter, - PARAM_TYPE is its type. READONLY is true if the parameter is - readonly (either an In parameter or an address of a pass-by-ref - parameter). */ - - tree - create_param_decl (tree param_name, tree param_type, bool readonly) - { - tree param_decl = build_decl (PARM_DECL, param_name, param_type); - - /* Honor targetm.calls.promote_prototypes(), as not doing so can - lead to various ABI violations. */ - if (targetm.calls.promote_prototypes (param_type) - && (TREE_CODE (param_type) == INTEGER_TYPE - || TREE_CODE (param_type) == ENUMERAL_TYPE) - && TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node)) - { - /* We have to be careful about biased types here. Make a subtype - of integer_type_node with the proper biasing. */ - if (TREE_CODE (param_type) == INTEGER_TYPE - && TYPE_BIASED_REPRESENTATION_P (param_type)) - { - param_type - = copy_type (build_range_type (integer_type_node, - TYPE_MIN_VALUE (param_type), - TYPE_MAX_VALUE (param_type))); - - TYPE_BIASED_REPRESENTATION_P (param_type) = 1; - } - else - param_type = integer_type_node; - } - - DECL_ARG_TYPE (param_decl) = param_type; - TREE_READONLY (param_decl) = readonly; - return param_decl; - } - - /* Given a DECL and ATTR_LIST, process the listed attributes. */ - - void - process_attributes (tree decl, struct attrib *attr_list) - { - for (; attr_list; attr_list = attr_list->next) - switch (attr_list->type) - { - case ATTR_MACHINE_ATTRIBUTE: - decl_attributes (&decl, tree_cons (attr_list->name, attr_list->args, - NULL_TREE), - ATTR_FLAG_TYPE_IN_PLACE); - break; - - case ATTR_LINK_ALIAS: - if (! DECL_EXTERNAL (decl)) - { - TREE_STATIC (decl) = 1; - assemble_alias (decl, attr_list->name); - } - break; - - case ATTR_WEAK_EXTERNAL: - if (SUPPORTS_WEAK) - declare_weak (decl); - else - post_error ("?weak declarations not supported on this target", - attr_list->error_point); - break; - - case ATTR_LINK_SECTION: - if (targetm.have_named_sections) - { - DECL_SECTION_NAME (decl) - = build_string (IDENTIFIER_LENGTH (attr_list->name), - IDENTIFIER_POINTER (attr_list->name)); - DECL_COMMON (decl) = 0; - } - else - post_error ("?section attributes are not supported for this target", - attr_list->error_point); - break; - - case ATTR_LINK_CONSTRUCTOR: - DECL_STATIC_CONSTRUCTOR (decl) = 1; - TREE_USED (decl) = 1; - break; - - case ATTR_LINK_DESTRUCTOR: - DECL_STATIC_DESTRUCTOR (decl) = 1; - TREE_USED (decl) = 1; - break; - } - } - - /* Record a global renaming pointer. */ - - void - record_global_renaming_pointer (tree decl) - { - gcc_assert (DECL_RENAMED_OBJECT (decl)); - VEC_safe_push (tree, gc, global_renaming_pointers, decl); - } - - /* Invalidate the global renaming pointers. */ - - void - invalidate_global_renaming_pointers (void) - { - unsigned int i; - tree iter; - - for (i = 0; VEC_iterate(tree, global_renaming_pointers, i, iter); i++) - SET_DECL_RENAMED_OBJECT (iter, NULL_TREE); - - VEC_free (tree, gc, global_renaming_pointers); - } - - /* Return true if VALUE is a known to be a multiple of FACTOR, which must be - a power of 2. */ - - bool - value_factor_p (tree value, HOST_WIDE_INT factor) - { - if (host_integerp (value, 1)) - return tree_low_cst (value, 1) % factor == 0; - - if (TREE_CODE (value) == MULT_EXPR) - return (value_factor_p (TREE_OPERAND (value, 0), factor) - || value_factor_p (TREE_OPERAND (value, 1), factor)); - - return 0; - } - - /* Given 2 consecutive field decls PREV_FIELD and CURR_FIELD, return true - unless we can prove these 2 fields are laid out in such a way that no gap - exist between the end of PREV_FIELD and the beginning of CURR_FIELD. OFFSET - is the distance in bits between the end of PREV_FIELD and the starting - position of CURR_FIELD. It is ignored if null. */ - - static bool - potential_alignment_gap (tree prev_field, tree curr_field, tree offset) - { - /* If this is the first field of the record, there cannot be any gap */ - if (!prev_field) - return false; - - /* If the previous field is a union type, then return False: The only - time when such a field is not the last field of the record is when - there are other components at fixed positions after it (meaning there - was a rep clause for every field), in which case we don't want the - alignment constraint to override them. */ - if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE) - return false; - - /* If the distance between the end of prev_field and the beginning of - curr_field is constant, then there is a gap if the value of this - constant is not null. */ - if (offset && host_integerp (offset, 1)) - return !integer_zerop (offset); - - /* If the size and position of the previous field are constant, - then check the sum of this size and position. There will be a gap - iff it is not multiple of the current field alignment. */ - if (host_integerp (DECL_SIZE (prev_field), 1) - && host_integerp (bit_position (prev_field), 1)) - return ((tree_low_cst (bit_position (prev_field), 1) - + tree_low_cst (DECL_SIZE (prev_field), 1)) - % DECL_ALIGN (curr_field) != 0); - - /* If both the position and size of the previous field are multiples - of the current field alignment, there cannot be any gap. */ - if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field)) - && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field))) - return false; - - /* Fallback, return that there may be a potential gap */ - return true; - } - - /* Returns a LABEL_DECL node for LABEL_NAME. */ - - tree - create_label_decl (tree label_name) - { - tree label_decl = build_decl (LABEL_DECL, label_name, void_type_node); - - DECL_CONTEXT (label_decl) = current_function_decl; - DECL_MODE (label_decl) = VOIDmode; - DECL_SOURCE_LOCATION (label_decl) = input_location; - - return label_decl; - } - - /* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram, - ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE - node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of - PARM_DECL nodes chained through the TREE_CHAIN field). - - INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the - appropriate fields in the FUNCTION_DECL. GNAT_NODE gives the location. */ - - tree - create_subprog_decl (tree subprog_name, tree asm_name, - tree subprog_type, tree param_decl_list, bool inline_flag, - bool public_flag, bool extern_flag, - struct attrib *attr_list, Node_Id gnat_node) - { - tree return_type = TREE_TYPE (subprog_type); - tree subprog_decl = build_decl (FUNCTION_DECL, subprog_name, subprog_type); - - /* If this is a function nested inside an inlined external function, it - means we aren't going to compile the outer function unless it is - actually inlined, so do the same for us. */ - if (current_function_decl && DECL_INLINE (current_function_decl) - && DECL_EXTERNAL (current_function_decl)) - extern_flag = true; - - DECL_EXTERNAL (subprog_decl) = extern_flag; - TREE_PUBLIC (subprog_decl) = public_flag; - TREE_STATIC (subprog_decl) = 1; - TREE_READONLY (subprog_decl) = TYPE_READONLY (subprog_type); - TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type); - TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type); - DECL_ARGUMENTS (subprog_decl) = param_decl_list; - DECL_RESULT (subprog_decl) = build_decl (RESULT_DECL, 0, return_type); - DECL_ARTIFICIAL (DECL_RESULT (subprog_decl)) = 1; - DECL_IGNORED_P (DECL_RESULT (subprog_decl)) = 1; - - /* TREE_ADDRESSABLE is set on the result type to request the use of the - target by-reference return mechanism. This is not supported all the - way down to RTL expansion with GCC 4, which ICEs on temporary creation - attempts with such a type and expects DECL_BY_REFERENCE to be set on - the RESULT_DECL instead - see gnat_genericize for more details. */ - if (TREE_ADDRESSABLE (TREE_TYPE (DECL_RESULT (subprog_decl)))) - { - tree result_decl = DECL_RESULT (subprog_decl); - - TREE_ADDRESSABLE (TREE_TYPE (result_decl)) = 0; - DECL_BY_REFERENCE (result_decl) = 1; - } - - if (inline_flag) - DECL_DECLARED_INLINE_P (subprog_decl) = 1; - - if (asm_name) - SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name); - - process_attributes (subprog_decl, attr_list); - - /* Add this decl to the current binding level. */ - gnat_pushdecl (subprog_decl, gnat_node); - - /* Output the assembler code and/or RTL for the declaration. */ - rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0); - - return subprog_decl; - } - - /* Set up the framework for generating code for SUBPROG_DECL, a subprogram - body. This routine needs to be invoked before processing the declarations - appearing in the subprogram. */ - - void - begin_subprog_body (tree subprog_decl) - { - tree param_decl; - - current_function_decl = subprog_decl; - announce_function (subprog_decl); - - /* Enter a new binding level and show that all the parameters belong to - this function. */ - gnat_pushlevel (); - for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl; - param_decl = TREE_CHAIN (param_decl)) - DECL_CONTEXT (param_decl) = subprog_decl; - - make_decl_rtl (subprog_decl); - - /* We handle pending sizes via the elaboration of types, so we don't need to - save them. This causes them to be marked as part of the outer function - and then discarded. */ - get_pending_sizes (); - } - - - /* Helper for the genericization callback. Return a dereference of VAL - if it is of a reference type. */ - - static tree - convert_from_reference (tree val) - { - tree value_type, ref; - - if (TREE_CODE (TREE_TYPE (val)) != REFERENCE_TYPE) - return val; - - value_type = TREE_TYPE (TREE_TYPE (val)); - ref = build1 (INDIRECT_REF, value_type, val); - - /* See if what we reference is CONST or VOLATILE, which requires - looking into array types to get to the component type. */ - - while (TREE_CODE (value_type) == ARRAY_TYPE) - value_type = TREE_TYPE (value_type); - - TREE_READONLY (ref) - = (TYPE_QUALS (value_type) & TYPE_QUAL_CONST); - TREE_THIS_VOLATILE (ref) - = (TYPE_QUALS (value_type) & TYPE_QUAL_VOLATILE); - - TREE_SIDE_EFFECTS (ref) - = (TREE_THIS_VOLATILE (ref) || TREE_SIDE_EFFECTS (val)); - - return ref; - } - - /* Helper for the genericization callback. Returns true if T denotes - a RESULT_DECL with DECL_BY_REFERENCE set. */ - - static inline bool - is_byref_result (tree t) - { - return (TREE_CODE (t) == RESULT_DECL && DECL_BY_REFERENCE (t)); - } - - - /* Tree walking callback for gnat_genericize. Currently ... - - o Adjust references to the function's DECL_RESULT if it is marked - DECL_BY_REFERENCE and so has had its type turned into a reference - type at the end of the function compilation. */ - - static tree - gnat_genericize_r (tree *stmt_p, int *walk_subtrees, void *data) - { - /* This implementation is modeled after what the C++ front-end is - doing, basis of the downstream passes behavior. */ - - tree stmt = *stmt_p; - struct pointer_set_t *p_set = (struct pointer_set_t*) data; - - /* If we have a direct mention of the result decl, dereference. */ - if (is_byref_result (stmt)) - { - *stmt_p = convert_from_reference (stmt); - *walk_subtrees = 0; - return NULL; - } - - /* Otherwise, no need to walk the the same tree twice. */ - if (pointer_set_contains (p_set, stmt)) - { - *walk_subtrees = 0; - return NULL_TREE; - } - - /* If we are taking the address of what now is a reference, just get the - reference value. */ - if (TREE_CODE (stmt) == ADDR_EXPR - && is_byref_result (TREE_OPERAND (stmt, 0))) - { - *stmt_p = convert (TREE_TYPE (stmt), TREE_OPERAND (stmt, 0)); - *walk_subtrees = 0; - } - - /* Don't dereference an by-reference RESULT_DECL inside a RETURN_EXPR. */ - else if (TREE_CODE (stmt) == RETURN_EXPR - && TREE_OPERAND (stmt, 0) - && is_byref_result (TREE_OPERAND (stmt, 0))) - *walk_subtrees = 0; - - /* Don't look inside trees that cannot embed references of interest. */ - else if (IS_TYPE_OR_DECL_P (stmt)) - *walk_subtrees = 0; - - pointer_set_insert (p_set, *stmt_p); - - return NULL; - } - - /* Perform lowering of Ada trees to GENERIC. In particular: - - o Turn a DECL_BY_REFERENCE RESULT_DECL into a real by-reference decl - and adjust all the references to this decl accordingly. */ - - static void - gnat_genericize (tree fndecl) - { - /* Prior to GCC 4, an explicit By_Reference result mechanism for a function - was handled by simply setting TREE_ADDRESSABLE on the result type. - Everything required to actually pass by invisible ref using the target - mechanism (e.g. extra parameter) was handled at RTL expansion time. - - This doesn't work with GCC 4 any more for several reasons. First, the - gimplification process might need the creation of temporaries of this - type, and the gimplifier ICEs on such attempts. Second, the middle-end - now relies on a different attribute for such cases (DECL_BY_REFERENCE on - RESULT/PARM_DECLs), and expects the user invisible by-reference-ness to - be explicitely accounted for by the front-end in the function body. - - We achieve the complete transformation in two steps: - - 1/ create_subprog_decl performs early attribute tweaks: it clears - TREE_ADDRESSABLE from the result type and sets DECL_BY_REFERENCE on - the result decl. The former ensures that the bit isn't set in the GCC - tree saved for the function, so prevents ICEs on temporary creation. - The latter we use here to trigger the rest of the processing. - - 2/ This function performs the type transformation on the result decl - and adjusts all the references to this decl from the function body - accordingly. - - Clearing TREE_ADDRESSABLE from the type differs from the C++ front-end - strategy, which escapes the gimplifier temporary creation issues by - creating it's own temporaries using TARGET_EXPR nodes. Our way relies - on simple specific support code in aggregate_value_p to look at the - target function result decl explicitely. */ - - struct pointer_set_t *p_set; - tree decl_result = DECL_RESULT (fndecl); - - if (!DECL_BY_REFERENCE (decl_result)) - return; - - /* Make the DECL_RESULT explicitely by-reference and adjust all the - occurrences in the function body using the common tree-walking facility. - We want to see every occurrence of the result decl to adjust the - referencing tree, so need to use our own pointer set to control which - trees should be visited again or not. */ - - p_set = pointer_set_create (); - - TREE_TYPE (decl_result) = build_reference_type (TREE_TYPE (decl_result)); - TREE_ADDRESSABLE (decl_result) = 0; - relayout_decl (decl_result); - - walk_tree (&DECL_SAVED_TREE (fndecl), gnat_genericize_r, p_set, NULL); - - pointer_set_destroy (p_set); - } - - /* Finish the definition of the current subprogram and compile it all the way - to assembler language output. BODY is the tree corresponding to - the subprogram. */ - - void - end_subprog_body (tree body) - { - tree fndecl = current_function_decl; - - /* Mark the BLOCK for this level as being for this function and pop the - level. Since the vars in it are the parameters, clear them. */ - BLOCK_VARS (current_binding_level->block) = 0; - BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl; - DECL_INITIAL (fndecl) = current_binding_level->block; - gnat_poplevel (); - - /* Deal with inline. If declared inline or we should default to inline, - set the flag in the decl. */ - DECL_INLINE (fndecl) - = DECL_DECLARED_INLINE_P (fndecl) || flag_inline_trees == 2; - - /* We handle pending sizes via the elaboration of types, so we don't - need to save them. */ - get_pending_sizes (); - - /* Mark the RESULT_DECL as being in this subprogram. */ - DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; - - DECL_SAVED_TREE (fndecl) = body; - - current_function_decl = DECL_CONTEXT (fndecl); - set_cfun (NULL); - - /* We cannot track the location of errors past this point. */ - error_gnat_node = Empty; - - /* If we're only annotating types, don't actually compile this function. */ - if (type_annotate_only) - return; - - /* Perform the required pre-gimplfication transformations on the tree. */ - gnat_genericize (fndecl); - - /* We do different things for nested and non-nested functions. - ??? This should be in cgraph. */ - if (!DECL_CONTEXT (fndecl)) - { - gnat_gimplify_function (fndecl); - cgraph_finalize_function (fndecl, false); - } - else - /* Register this function with cgraph just far enough to get it - added to our parent's nested function list. */ - (void) cgraph_node (fndecl); - } - - /* Convert FNDECL's code to GIMPLE and handle any nested functions. */ - - static void - gnat_gimplify_function (tree fndecl) - { - struct cgraph_node *cgn; - - dump_function (TDI_original, fndecl); - gimplify_function_tree (fndecl); - dump_function (TDI_generic, fndecl); - - /* Convert all nested functions to GIMPLE now. We do things in this order - so that items like VLA sizes are expanded properly in the context of the - correct function. */ - cgn = cgraph_node (fndecl); - for (cgn = cgn->nested; cgn; cgn = cgn->next_nested) - gnat_gimplify_function (cgn->decl); - } - - - tree - gnat_builtin_function (tree decl) - { - gnat_pushdecl (decl, Empty); - return decl; - } - - /* Handle a "const" attribute; arguments as in - struct attribute_spec.handler. */ - - static tree - handle_const_attribute (tree *node, tree ARG_UNUSED (name), - tree ARG_UNUSED (args), int ARG_UNUSED (flags), - bool *no_add_attrs) - { - if (TREE_CODE (*node) == FUNCTION_DECL) - TREE_READONLY (*node) = 1; - else - *no_add_attrs = true; - - return NULL_TREE; - } - - /* Handle a "nothrow" attribute; arguments as in - struct attribute_spec.handler. */ - - static tree - handle_nothrow_attribute (tree *node, tree ARG_UNUSED (name), - tree ARG_UNUSED (args), int ARG_UNUSED (flags), - bool *no_add_attrs) - { - if (TREE_CODE (*node) == FUNCTION_DECL) - TREE_NOTHROW (*node) = 1; - else - *no_add_attrs = true; - - return NULL_TREE; - } - - /* Return an integer type with the number of bits of precision given by - PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise - it is a signed type. */ - - tree - gnat_type_for_size (unsigned precision, int unsignedp) - { - tree t; - char type_name[20]; - - if (precision <= 2 * MAX_BITS_PER_WORD - && signed_and_unsigned_types[precision][unsignedp]) - return signed_and_unsigned_types[precision][unsignedp]; - - if (unsignedp) - t = make_unsigned_type (precision); - else - t = make_signed_type (precision); - - if (precision <= 2 * MAX_BITS_PER_WORD) - signed_and_unsigned_types[precision][unsignedp] = t; - - if (!TYPE_NAME (t)) - { - sprintf (type_name, "%sSIGNED_%d", unsignedp ? "UN" : "", precision); - TYPE_NAME (t) = get_identifier (type_name); - } - - return t; - } - - /* Likewise for floating-point types. */ - - static tree - float_type_for_precision (int precision, enum machine_mode mode) - { - tree t; - char type_name[20]; - - if (float_types[(int) mode]) - return float_types[(int) mode]; - - float_types[(int) mode] = t = make_node (REAL_TYPE); - TYPE_PRECISION (t) = precision; - layout_type (t); - - gcc_assert (TYPE_MODE (t) == mode); - if (!TYPE_NAME (t)) - { - sprintf (type_name, "FLOAT_%d", precision); - TYPE_NAME (t) = get_identifier (type_name); - } - - return t; - } - - /* Return a data type that has machine mode MODE. UNSIGNEDP selects - an unsigned type; otherwise a signed type is returned. */ - - tree - gnat_type_for_mode (enum machine_mode mode, int unsignedp) - { - if (mode == BLKmode) - return NULL_TREE; - else if (mode == VOIDmode) - return void_type_node; - else if (COMPLEX_MODE_P (mode)) - return NULL_TREE; - else if (SCALAR_FLOAT_MODE_P (mode)) - return float_type_for_precision (GET_MODE_PRECISION (mode), mode); - else if (SCALAR_INT_MODE_P (mode)) - return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp); - else - return NULL_TREE; - } - - /* Return the unsigned version of a TYPE_NODE, a scalar type. */ - - tree - gnat_unsigned_type (tree type_node) - { - tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 1); - - if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node)) - { - type = copy_node (type); - TREE_TYPE (type) = type_node; - } - else if (TREE_TYPE (type_node) - && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE - && TYPE_MODULAR_P (TREE_TYPE (type_node))) - { - type = copy_node (type); - TREE_TYPE (type) = TREE_TYPE (type_node); - } - - return type; - } - - /* Return the signed version of a TYPE_NODE, a scalar type. */ - - tree - gnat_signed_type (tree type_node) - { - tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 0); - - if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node)) - { - type = copy_node (type); - TREE_TYPE (type) = type_node; - } - else if (TREE_TYPE (type_node) - && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE - && TYPE_MODULAR_P (TREE_TYPE (type_node))) - { - type = copy_node (type); - TREE_TYPE (type) = TREE_TYPE (type_node); - } - - return type; - } - - - /* EXP is an expression for the size of an object. If this size contains - discriminant references, replace them with the maximum (if MAX_P) or - minimum (if !MAX_P) possible value of the discriminant. */ - - tree - max_size (tree exp, bool max_p) - { - enum tree_code code = TREE_CODE (exp); - tree type = TREE_TYPE (exp); - - switch (TREE_CODE_CLASS (code)) - { - case tcc_declaration: - case tcc_constant: - return exp; - - case tcc_vl_exp: - if (code == CALL_EXPR) - { - tree *argarray; - int i, n = call_expr_nargs (exp); - gcc_assert (n > 0); - - argarray = (tree *) alloca (n * sizeof (tree)); - for (i = 0; i < n; i++) - argarray[i] = max_size (CALL_EXPR_ARG (exp, i), max_p); - return build_call_array (type, CALL_EXPR_FN (exp), n, argarray); - } - break; - - case tcc_reference: - /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to - modify. Otherwise, we treat it like a variable. */ - if (!CONTAINS_PLACEHOLDER_P (exp)) - return exp; - - type = TREE_TYPE (TREE_OPERAND (exp, 1)); - return - max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), true); - - case tcc_comparison: - return max_p ? size_one_node : size_zero_node; - - case tcc_unary: - case tcc_binary: - case tcc_expression: - switch (TREE_CODE_LENGTH (code)) - { - case 1: - if (code == NON_LVALUE_EXPR) - return max_size (TREE_OPERAND (exp, 0), max_p); - else - return - fold_build1 (code, type, - max_size (TREE_OPERAND (exp, 0), - code == NEGATE_EXPR ? !max_p : max_p)); - - case 2: - if (code == COMPOUND_EXPR) - return max_size (TREE_OPERAND (exp, 1), max_p); - - /* Calculate "(A ? B : C) - D" as "A ? B - D : C - D" which - may provide a tighter bound on max_size. */ - if (code == MINUS_EXPR - && TREE_CODE (TREE_OPERAND (exp, 0)) == COND_EXPR) - { - tree lhs = fold_build2 (MINUS_EXPR, type, - TREE_OPERAND (TREE_OPERAND (exp, 0), 1), - TREE_OPERAND (exp, 1)); - tree rhs = fold_build2 (MINUS_EXPR, type, - TREE_OPERAND (TREE_OPERAND (exp, 0), 2), - TREE_OPERAND (exp, 1)); - return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type, - max_size (lhs, max_p), - max_size (rhs, max_p)); - } - - { - tree lhs = max_size (TREE_OPERAND (exp, 0), max_p); - tree rhs = max_size (TREE_OPERAND (exp, 1), - code == MINUS_EXPR ? !max_p : max_p); - - /* Special-case wanting the maximum value of a MIN_EXPR. - In that case, if one side overflows, return the other. - sizetype is signed, but we know sizes are non-negative. - Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS - overflowing or the maximum possible value and the RHS - a variable. */ - if (max_p - && code == MIN_EXPR - && TREE_CODE (rhs) == INTEGER_CST - && TREE_OVERFLOW (rhs)) - return lhs; - else if (max_p - && code == MIN_EXPR - && TREE_CODE (lhs) == INTEGER_CST - && TREE_OVERFLOW (lhs)) - return rhs; - else if ((code == MINUS_EXPR || code == PLUS_EXPR) - && ((TREE_CODE (lhs) == INTEGER_CST - && TREE_OVERFLOW (lhs)) - || operand_equal_p (lhs, TYPE_MAX_VALUE (type), 0)) - && !TREE_CONSTANT (rhs)) - return lhs; - else - return fold_build2 (code, type, lhs, rhs); - } - - case 3: - if (code == SAVE_EXPR) - return exp; - else if (code == COND_EXPR) - return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type, - max_size (TREE_OPERAND (exp, 1), max_p), - max_size (TREE_OPERAND (exp, 2), max_p)); - } - - /* Other tree classes cannot happen. */ - default: - break; - } - - gcc_unreachable (); - } - - /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE. - EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs. - Return a constructor for the template. */ - - tree - build_template (tree template_type, tree array_type, tree expr) - { - tree template_elts = NULL_TREE; - tree bound_list = NULL_TREE; - tree field; - - if (TREE_CODE (array_type) == RECORD_TYPE - && (TYPE_IS_PADDING_P (array_type) - || TYPE_JUSTIFIED_MODULAR_P (array_type))) - array_type = TREE_TYPE (TYPE_FIELDS (array_type)); - - if (TREE_CODE (array_type) == ARRAY_TYPE - || (TREE_CODE (array_type) == INTEGER_TYPE - && TYPE_HAS_ACTUAL_BOUNDS_P (array_type))) - bound_list = TYPE_ACTUAL_BOUNDS (array_type); - - /* First make the list for a CONSTRUCTOR for the template. Go down the - field list of the template instead of the type chain because this - array might be an Ada array of arrays and we can't tell where the - nested arrays stop being the underlying object. */ - - for (field = TYPE_FIELDS (template_type); field; - (bound_list - ? (bound_list = TREE_CHAIN (bound_list)) - : (array_type = TREE_TYPE (array_type))), - field = TREE_CHAIN (TREE_CHAIN (field))) - { - tree bounds, min, max; - - /* If we have a bound list, get the bounds from there. Likewise - for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with - DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template. - This will give us a maximum range. */ - if (bound_list) - bounds = TREE_VALUE (bound_list); - else if (TREE_CODE (array_type) == ARRAY_TYPE) - bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type)); - else if (expr && TREE_CODE (expr) == PARM_DECL - && DECL_BY_COMPONENT_PTR_P (expr)) - bounds = TREE_TYPE (field); - else - gcc_unreachable (); - - min = convert (TREE_TYPE (field), TYPE_MIN_VALUE (bounds)); - max = convert (TREE_TYPE (TREE_CHAIN (field)), TYPE_MAX_VALUE (bounds)); - - /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must - substitute it from OBJECT. */ - min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr); - max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr); - - template_elts = tree_cons (TREE_CHAIN (field), max, - tree_cons (field, min, template_elts)); - } - - return gnat_build_constructor (template_type, nreverse (template_elts)); - } - - /* Build a VMS descriptor from a Mechanism_Type, which must specify - a descriptor type, and the GCC type of an object. Each FIELD_DECL - in the type contains in its DECL_INITIAL the expression to use when - a constructor is made for the type. GNAT_ENTITY is an entity used - to print out an error message if the mechanism cannot be applied to - an object of that type and also for the name. */ - - tree - build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) - { - tree record_type = make_node (RECORD_TYPE); - tree pointer32_type; - tree field_list = 0; - int class; - int dtype = 0; - tree inner_type; - int ndim; - int i; - tree *idx_arr; - tree tem; - - /* If TYPE is an unconstrained array, use the underlying array type. */ - if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) - type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))); - - /* If this is an array, compute the number of dimensions in the array, - get the index types, and point to the inner type. */ - if (TREE_CODE (type) != ARRAY_TYPE) - ndim = 0; - else - for (ndim = 1, inner_type = type; - TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type)); - ndim++, inner_type = TREE_TYPE (inner_type)) - ; - - idx_arr = (tree *) alloca (ndim * sizeof (tree)); - - if (mech != By_Descriptor_NCA - && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type)) - for (i = ndim - 1, inner_type = type; - i >= 0; - i--, inner_type = TREE_TYPE (inner_type)) - idx_arr[i] = TYPE_DOMAIN (inner_type); - else - for (i = 0, inner_type = type; - i < ndim; - i++, inner_type = TREE_TYPE (inner_type)) - idx_arr[i] = TYPE_DOMAIN (inner_type); - - /* Now get the DTYPE value. */ - switch (TREE_CODE (type)) - { - case INTEGER_TYPE: - case ENUMERAL_TYPE: - if (TYPE_VAX_FLOATING_POINT_P (type)) - switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1)) - { - case 6: - dtype = 10; - break; - case 9: - dtype = 11; - break; - case 15: - dtype = 27; - break; - } - else - switch (GET_MODE_BITSIZE (TYPE_MODE (type))) - { - case 8: - dtype = TYPE_UNSIGNED (type) ? 2 : 6; - break; - case 16: - dtype = TYPE_UNSIGNED (type) ? 3 : 7; - break; - case 32: - dtype = TYPE_UNSIGNED (type) ? 4 : 8; - break; - case 64: - dtype = TYPE_UNSIGNED (type) ? 5 : 9; - break; - case 128: - dtype = TYPE_UNSIGNED (type) ? 25 : 26; - break; - } - break; - - case REAL_TYPE: - dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53; - break; - - case COMPLEX_TYPE: - if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE - && TYPE_VAX_FLOATING_POINT_P (type)) - switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1)) - { - case 6: - dtype = 12; - break; - case 9: - dtype = 13; - break; - case 15: - dtype = 29; - } - else - dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55; - break; - - case ARRAY_TYPE: - dtype = 14; - break; - - default: - break; - } - - /* Get the CLASS value. */ - switch (mech) - { - case By_Descriptor_A: - class = 4; - break; - case By_Descriptor_NCA: - class = 10; - break; - case By_Descriptor_SB: - class = 15; - break; - case By_Descriptor: - case By_Descriptor_S: - default: - class = 1; - break; - } - - /* Make the type for a descriptor for VMS. The first four fields - are the same for all types. */ - - field_list - = chainon (field_list, - make_descriptor_field - ("LENGTH", gnat_type_for_size (16, 1), record_type, - size_in_bytes (mech == By_Descriptor_A ? inner_type : type))); - - field_list = chainon (field_list, - make_descriptor_field ("DTYPE", - gnat_type_for_size (8, 1), - record_type, size_int (dtype))); - field_list = chainon (field_list, - make_descriptor_field ("CLASS", - gnat_type_for_size (8, 1), - record_type, size_int (class))); - - /* Of course this will crash at run-time if the address space is not - within the low 32 bits, but there is nothing else we can do. */ - pointer32_type = build_pointer_type_for_mode (type, SImode, false); - - field_list - = chainon (field_list, - make_descriptor_field - ("POINTER", pointer32_type, record_type, - build_unary_op (ADDR_EXPR, - pointer32_type, - build0 (PLACEHOLDER_EXPR, type)))); - - switch (mech) - { - case By_Descriptor: - case By_Descriptor_S: - break; - - case By_Descriptor_SB: - field_list - = chainon (field_list, - make_descriptor_field - ("SB_L1", gnat_type_for_size (32, 1), record_type, - TREE_CODE (type) == ARRAY_TYPE - ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node)); - field_list - = chainon (field_list, - make_descriptor_field - ("SB_U1", gnat_type_for_size (32, 1), record_type, - TREE_CODE (type) == ARRAY_TYPE - ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node)); - break; - - case By_Descriptor_A: - case By_Descriptor_NCA: - field_list = chainon (field_list, - make_descriptor_field ("SCALE", - gnat_type_for_size (8, 1), - record_type, - size_zero_node)); - - field_list = chainon (field_list, - make_descriptor_field ("DIGITS", - gnat_type_for_size (8, 1), - record_type, - size_zero_node)); - - field_list - = chainon (field_list, - make_descriptor_field - ("AFLAGS", gnat_type_for_size (8, 1), record_type, - size_int (mech == By_Descriptor_NCA - ? 0 - /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS. */ - : (TREE_CODE (type) == ARRAY_TYPE - && TYPE_CONVENTION_FORTRAN_P (type) - ? 224 : 192)))); - - field_list = chainon (field_list, - make_descriptor_field ("DIMCT", - gnat_type_for_size (8, 1), - record_type, - size_int (ndim))); - - field_list = chainon (field_list, - make_descriptor_field ("ARSIZE", - gnat_type_for_size (32, 1), - record_type, - size_in_bytes (type))); - - /* Now build a pointer to the 0,0,0... element. */ - tem = build0 (PLACEHOLDER_EXPR, type); - for (i = 0, inner_type = type; i < ndim; - i++, inner_type = TREE_TYPE (inner_type)) - tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem, - convert (TYPE_DOMAIN (inner_type), size_zero_node), - NULL_TREE, NULL_TREE); - - field_list - = chainon (field_list, - make_descriptor_field - ("A0", - build_pointer_type_for_mode (inner_type, SImode, false), - record_type, - build1 (ADDR_EXPR, - build_pointer_type_for_mode (inner_type, SImode, - false), - tem))); - - /* Next come the addressing coefficients. */ - tem = size_one_node; - for (i = 0; i < ndim; i++) - { - char fname[3]; - tree idx_length - = size_binop (MULT_EXPR, tem, - size_binop (PLUS_EXPR, - size_binop (MINUS_EXPR, - TYPE_MAX_VALUE (idx_arr[i]), - TYPE_MIN_VALUE (idx_arr[i])), - size_int (1))); - - fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M'); - fname[1] = '0' + i, fname[2] = 0; - field_list - = chainon (field_list, - make_descriptor_field (fname, - gnat_type_for_size (32, 1), - record_type, idx_length)); - - if (mech == By_Descriptor_NCA) - tem = idx_length; - } - - /* Finally here are the bounds. */ - for (i = 0; i < ndim; i++) - { - char fname[3]; - - fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0; - field_list - = chainon (field_list, - make_descriptor_field - (fname, gnat_type_for_size (32, 1), record_type, - TYPE_MIN_VALUE (idx_arr[i]))); - - fname[0] = 'U'; - field_list - = chainon (field_list, - make_descriptor_field - (fname, gnat_type_for_size (32, 1), record_type, - TYPE_MAX_VALUE (idx_arr[i]))); - } - break; - - default: - post_error ("unsupported descriptor type for &", gnat_entity); - } - - finish_record_type (record_type, field_list, 0, true); - create_type_decl (create_concat_name (gnat_entity, "DESC"), record_type, - NULL, true, false, gnat_entity); - - return record_type; - } - - /* Utility routine for above code to make a field. */ - - static tree - make_descriptor_field (const char *name, tree type, - tree rec_type, tree initial) - { - tree field - = create_field_decl (get_identifier (name), type, rec_type, 0, 0, 0, 0); - - DECL_INITIAL (field) = initial; - return field; - } - - /* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular - pointer or fat pointer type. GNAT_SUBPROG is the subprogram to which - the VMS descriptor is passed. */ - - static tree - convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) - { - tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); - tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); - /* The CLASS field is the 3rd field in the descriptor. */ - tree class = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (desc_type))); - /* The POINTER field is the 4th field in the descriptor. */ - tree pointer = TREE_CHAIN (class); - - /* Retrieve the value of the POINTER field. */ - gnu_expr - = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE); - - if (POINTER_TYPE_P (gnu_type)) - return convert (gnu_type, gnu_expr); - - else if (TYPE_FAT_POINTER_P (gnu_type)) - { - tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); - tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); - tree template_type = TREE_TYPE (p_bounds_type); - tree min_field = TYPE_FIELDS (template_type); - tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type)); - tree template, template_addr, aflags, dimct, t, u; - /* See the head comment of build_vms_descriptor. */ - int iclass = TREE_INT_CST_LOW (DECL_INITIAL (class)); - - /* Convert POINTER to the type of the P_ARRAY field. */ - gnu_expr = convert (p_array_type, gnu_expr); - - switch (iclass) - { - case 1: /* Class S */ - case 15: /* Class SB */ - /* Build {1, LENGTH} template; LENGTH is the 1st field. */ - t = TYPE_FIELDS (desc_type); - t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - t = tree_cons (min_field, - convert (TREE_TYPE (min_field), integer_one_node), - tree_cons (max_field, - convert (TREE_TYPE (max_field), t), - NULL_TREE)); - template = gnat_build_constructor (template_type, t); - template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template); - - /* For class S, we are done. */ - if (iclass == 1) - break; - - /* Test that we really have a SB descriptor, like DEC Ada. */ - t = build3 (COMPONENT_REF, TREE_TYPE (class), desc, class, NULL); - u = convert (TREE_TYPE (class), DECL_INITIAL (class)); - u = build_binary_op (EQ_EXPR, integer_type_node, t, u); - /* If so, there is already a template in the descriptor and - it is located right after the POINTER field. */ - t = TREE_CHAIN (pointer); - template = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - /* Otherwise use the {1, LENGTH} template we build above. */ - template_addr = build3 (COND_EXPR, p_bounds_type, u, - build_unary_op (ADDR_EXPR, p_bounds_type, - template), - template_addr); - break; - - case 4: /* Class A */ - /* The AFLAGS field is the 7th field in the descriptor. */ - t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (pointer))); - aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - /* The DIMCT field is the 8th field in the descriptor. */ - t = TREE_CHAIN (t); - dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - /* Raise CONSTRAINT_ERROR if either more than 1 dimension - or FL_COEFF or FL_BOUNDS not set. */ - u = build_int_cst (TREE_TYPE (aflags), 192); - u = build_binary_op (TRUTH_OR_EXPR, integer_type_node, - build_binary_op (NE_EXPR, integer_type_node, - dimct, - convert (TREE_TYPE (dimct), - size_one_node)), - build_binary_op (NE_EXPR, integer_type_node, - build2 (BIT_AND_EXPR, - TREE_TYPE (aflags), - aflags, u), - u)); - add_stmt (build3 (COND_EXPR, void_type_node, u, - build_call_raise (CE_Length_Check_Failed, Empty, - N_Raise_Constraint_Error), - NULL_TREE)); - /* There is already a template in the descriptor and it is - located at the start of block 3 (12th field). */ - t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (t)))); - template = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - template_addr = build_unary_op (ADDR_EXPR, p_bounds_type, template); - break; - - case 10: /* Class NCA */ - default: - post_error ("unsupported descriptor type for &", gnat_subprog); - template_addr = integer_zero_node; - break; - } - - /* Build the fat pointer in the form of a constructor. */ - t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr, - tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)), - template_addr, NULL_TREE)); - return gnat_build_constructor (gnu_type, t); - } - - else - gcc_unreachable (); - } - - /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG - and the GNAT node GNAT_SUBPROG. */ - - void - build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog) - { - tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call; - tree gnu_stub_param, gnu_param_list, gnu_arg_types, gnu_param; - tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog); - tree gnu_body; - - gnu_subprog_type = TREE_TYPE (gnu_subprog); - gnu_param_list = NULL_TREE; - - begin_subprog_body (gnu_stub_decl); - gnat_pushlevel (); - - start_stmt_group (); - - /* Loop over the parameters of the stub and translate any of them - passed by descriptor into a by reference one. */ - for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl), - gnu_arg_types = TYPE_ARG_TYPES (gnu_subprog_type); - gnu_stub_param; - gnu_stub_param = TREE_CHAIN (gnu_stub_param), - gnu_arg_types = TREE_CHAIN (gnu_arg_types)) - { - if (DECL_BY_DESCRIPTOR_P (gnu_stub_param)) - gnu_param = convert_vms_descriptor (TREE_VALUE (gnu_arg_types), - gnu_stub_param, gnat_subprog); - else - gnu_param = gnu_stub_param; - - gnu_param_list = tree_cons (NULL_TREE, gnu_param, gnu_param_list); - } - - gnu_body = end_stmt_group (); - - /* Invoke the internal subprogram. */ - gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type), - gnu_subprog); - gnu_subprog_call = build_call_list (TREE_TYPE (gnu_subprog_type), - gnu_subprog_addr, - nreverse (gnu_param_list)); - - /* Propagate the return value, if any. */ - if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type))) - append_to_statement_list (gnu_subprog_call, &gnu_body); - else - append_to_statement_list (build_return_expr (DECL_RESULT (gnu_stub_decl), - gnu_subprog_call), - &gnu_body); - - gnat_poplevel (); - - allocate_struct_function (gnu_stub_decl, false); - end_subprog_body (gnu_body); - } - - /* Build a type to be used to represent an aliased object whose nominal - type is an unconstrained array. This consists of a RECORD_TYPE containing - a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an - ARRAY_TYPE. If ARRAY_TYPE is that of the unconstrained array, this - is used to represent an arbitrary unconstrained object. Use NAME - as the name of the record. */ - - tree - build_unc_object_type (tree template_type, tree object_type, tree name) - { - tree type = make_node (RECORD_TYPE); - tree template_field = create_field_decl (get_identifier ("BOUNDS"), - template_type, type, 0, 0, 0, 1); - tree array_field = create_field_decl (get_identifier ("ARRAY"), object_type, - type, 0, 0, 0, 1); - - TYPE_NAME (type) = name; - TYPE_CONTAINS_TEMPLATE_P (type) = 1; - finish_record_type (type, - chainon (chainon (NULL_TREE, template_field), - array_field), - 0, false); - - return type; - } - - /* Same, taking a thin or fat pointer type instead of a template type. */ - - tree - build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type, - tree name) - { - tree template_type; - - gcc_assert (TYPE_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type)); - - template_type - = (TYPE_FAT_POINTER_P (thin_fat_ptr_type) - ? TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (thin_fat_ptr_type)))) - : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type)))); - return build_unc_object_type (template_type, object_type, name); - } - - /* Shift the component offsets within an unconstrained object TYPE to make it - suitable for use as a designated type for thin pointers. */ - - void - shift_unc_components_for_thin_pointers (tree type) - { - /* Thin pointer values designate the ARRAY data of an unconstrained object, - allocated past the BOUNDS template. The designated type is adjusted to - have ARRAY at position zero and the template at a negative offset, so - that COMPONENT_REFs on (*thin_ptr) designate the proper location. */ - - tree bounds_field = TYPE_FIELDS (type); - tree array_field = TREE_CHAIN (TYPE_FIELDS (type)); - - DECL_FIELD_OFFSET (bounds_field) - = size_binop (MINUS_EXPR, size_zero_node, byte_position (array_field)); - - DECL_FIELD_OFFSET (array_field) = size_zero_node; - DECL_FIELD_BIT_OFFSET (array_field) = bitsize_zero_node; - } - - /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In - the normal case this is just two adjustments, but we have more to do - if NEW is an UNCONSTRAINED_ARRAY_TYPE. */ - - void - update_pointer_to (tree old_type, tree new_type) - { - tree ptr = TYPE_POINTER_TO (old_type); - tree ref = TYPE_REFERENCE_TO (old_type); - tree ptr1, ref1; - tree type; - - /* If this is the main variant, process all the other variants first. */ - if (TYPE_MAIN_VARIANT (old_type) == old_type) - for (type = TYPE_NEXT_VARIANT (old_type); type; - type = TYPE_NEXT_VARIANT (type)) - update_pointer_to (type, new_type); - - /* If no pointer or reference, we are done. */ - if (!ptr && !ref) - return; - - /* Merge the old type qualifiers in the new type. - - Each old variant has qualifiers for specific reasons, and the new - designated type as well. Each set of qualifiers represents useful - information grabbed at some point, and merging the two simply unifies - these inputs into the final type description. - - Consider for instance a volatile type frozen after an access to constant - type designating it. After the designated type freeze, we get here with a - volatile new_type and a dummy old_type with a readonly variant, created - when the access type was processed. We shall make a volatile and readonly - designated type, because that's what it really is. - - We might also get here for a non-dummy old_type variant with different - qualifiers than the new_type ones, for instance in some cases of pointers - to private record type elaboration (see the comments around the call to - this routine from gnat_to_gnu_entity/E_Access_Type). We have to merge the - qualifiers in thoses cases too, to avoid accidentally discarding the - initial set, and will often end up with old_type == new_type then. */ - new_type = build_qualified_type (new_type, - TYPE_QUALS (old_type) - | TYPE_QUALS (new_type)); - - /* If the new type and the old one are identical, there is nothing to - update. */ - if (old_type == new_type) - return; - - /* Otherwise, first handle the simple case. */ - if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE) - { - TYPE_POINTER_TO (new_type) = ptr; - TYPE_REFERENCE_TO (new_type) = ref; - - for (; ptr; ptr = TYPE_NEXT_PTR_TO (ptr)) - for (ptr1 = TYPE_MAIN_VARIANT (ptr); ptr1; - ptr1 = TYPE_NEXT_VARIANT (ptr1)) - TREE_TYPE (ptr1) = new_type; - - for (; ref; ref = TYPE_NEXT_REF_TO (ref)) - for (ref1 = TYPE_MAIN_VARIANT (ref); ref1; - ref1 = TYPE_NEXT_VARIANT (ref1)) - TREE_TYPE (ref1) = new_type; - } - - /* Now deal with the unconstrained array case. In this case the "pointer" - is actually a RECORD_TYPE where both fields are pointers to dummy nodes. - Turn them into pointers to the correct types using update_pointer_to. */ - else if (TREE_CODE (ptr) != RECORD_TYPE || !TYPE_IS_FAT_POINTER_P (ptr)) - gcc_unreachable (); - - else - { - tree new_obj_rec = TYPE_OBJECT_RECORD_TYPE (new_type); - tree array_field = TYPE_FIELDS (ptr); - tree bounds_field = TREE_CHAIN (TYPE_FIELDS (ptr)); - tree new_ptr = TYPE_POINTER_TO (new_type); - tree new_ref; - tree var; - - /* Make pointers to the dummy template point to the real template. */ - update_pointer_to - (TREE_TYPE (TREE_TYPE (bounds_field)), - TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_ptr))))); - - /* The references to the template bounds present in the array type - are made through a PLACEHOLDER_EXPR of type new_ptr. Since we - are updating ptr to make it a full replacement for new_ptr as - pointer to new_type, we must rework the PLACEHOLDER_EXPR so as - to make it of type ptr. */ - new_ref = build3 (COMPONENT_REF, TREE_TYPE (bounds_field), - build0 (PLACEHOLDER_EXPR, ptr), - bounds_field, NULL_TREE); - - /* Create the new array for the new PLACEHOLDER_EXPR and make - pointers to the dummy array point to it. - - ??? This is now the only use of substitute_in_type, - which is a very "heavy" routine to do this, so it - should be replaced at some point. */ - update_pointer_to - (TREE_TYPE (TREE_TYPE (array_field)), - substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (new_ptr))), - TREE_CHAIN (TYPE_FIELDS (new_ptr)), new_ref)); - - /* Make ptr the pointer to new_type. */ - TYPE_POINTER_TO (new_type) = TYPE_REFERENCE_TO (new_type) - = TREE_TYPE (new_type) = ptr; - - for (var = TYPE_MAIN_VARIANT (ptr); var; var = TYPE_NEXT_VARIANT (var)) - SET_TYPE_UNCONSTRAINED_ARRAY (var, new_type); - - /* Now handle updating the allocation record, what the thin pointer - points to. Update all pointers from the old record into the new - one, update the type of the array field, and recompute the size. */ - update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type), new_obj_rec); - - TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))) - = TREE_TYPE (TREE_TYPE (array_field)); - - /* The size recomputation needs to account for alignment constraints, so - we let layout_type work it out. This will reset the field offsets to - what they would be in a regular record, so we shift them back to what - we want them to be for a thin pointer designated type afterwards. */ - DECL_SIZE (TYPE_FIELDS (new_obj_rec)) = 0; - DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))) = 0; - TYPE_SIZE (new_obj_rec) = 0; - layout_type (new_obj_rec); - - shift_unc_components_for_thin_pointers (new_obj_rec); - - /* We are done, at last. */ - rest_of_record_type_compilation (ptr); - } - } - - /* Convert a pointer to a constrained array into a pointer to a fat - pointer. This involves making or finding a template. */ - - static tree - convert_to_fat_pointer (tree type, tree expr) - { - tree template_type = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)))); - tree template, template_addr; - tree etype = TREE_TYPE (expr); - - /* If EXPR is a constant of zero, we make a fat pointer that has a null - pointer to the template and array. */ - if (integer_zerop (expr)) - return - gnat_build_constructor - (type, - tree_cons (TYPE_FIELDS (type), - convert (TREE_TYPE (TYPE_FIELDS (type)), expr), - tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), - convert (build_pointer_type (template_type), - expr), - NULL_TREE))); - - /* If EXPR is a thin pointer, make the template and data from the record. */ - - else if (TYPE_THIN_POINTER_P (etype)) - { - tree fields = TYPE_FIELDS (TREE_TYPE (etype)); - - expr = save_expr (expr); - if (TREE_CODE (expr) == ADDR_EXPR) - expr = TREE_OPERAND (expr, 0); - else - expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr); - - template = build_component_ref (expr, NULL_TREE, fields, false); - expr = build_unary_op (ADDR_EXPR, NULL_TREE, - build_component_ref (expr, NULL_TREE, - TREE_CHAIN (fields), false)); - } - else - /* Otherwise, build the constructor for the template. */ - template = build_template (template_type, TREE_TYPE (etype), expr); - - template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template); - - /* The result is a CONSTRUCTOR for the fat pointer. - - If expr is an argument of a foreign convention subprogram, the type it - points to is directly the component type. In this case, the expression - type may not match the corresponding FIELD_DECL type at this point, so we - call "convert" here to fix that up if necessary. This type consistency is - required, for instance because it ensures that possible later folding of - component_refs against this constructor always yields something of the - same type as the initial reference. - - Note that the call to "build_template" above is still fine, because it - will only refer to the provided template_type in this case. */ - return - gnat_build_constructor - (type, tree_cons (TYPE_FIELDS (type), - convert (TREE_TYPE (TYPE_FIELDS (type)), expr), - tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), - template_addr, NULL_TREE))); - } - - /* Convert to a thin pointer type, TYPE. The only thing we know how to convert - is something that is a fat pointer, so convert to it first if it EXPR - is not already a fat pointer. */ - - static tree - convert_to_thin_pointer (tree type, tree expr) - { - if (!TYPE_FAT_POINTER_P (TREE_TYPE (expr))) - expr - = convert_to_fat_pointer - (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), expr); - - /* We get the pointer to the data and use a NOP_EXPR to make it the - proper GCC type. */ - expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)), - false); - expr = build1 (NOP_EXPR, type, expr); - - return expr; - } - - /* Create an expression whose value is that of EXPR, - converted to type TYPE. The TREE_TYPE of the value - is always TYPE. This function implements all reasonable - conversions; callers should filter out those that are - not permitted by the language being compiled. */ - - tree - convert (tree type, tree expr) - { - enum tree_code code = TREE_CODE (type); - tree etype = TREE_TYPE (expr); - enum tree_code ecode = TREE_CODE (etype); - - /* If EXPR is already the right type, we are done. */ - if (type == etype) - return expr; - - /* If both input and output have padding and are of variable size, do this - as an unchecked conversion. Likewise if one is a mere variant of the - other, so we avoid a pointless unpad/repad sequence. */ - else if (ecode == RECORD_TYPE && code == RECORD_TYPE - && TYPE_IS_PADDING_P (type) && TYPE_IS_PADDING_P (etype) - && (!TREE_CONSTANT (TYPE_SIZE (type)) - || !TREE_CONSTANT (TYPE_SIZE (etype)) - || TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))) - ; - - /* If the output type has padding, make a constructor to build the - record. */ - else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type)) - { - /* If we previously converted from another type and our type is - of variable size, remove the conversion to avoid the need for - variable-size temporaries. */ - if (TREE_CODE (expr) == VIEW_CONVERT_EXPR - && !TREE_CONSTANT (TYPE_SIZE (type))) - expr = TREE_OPERAND (expr, 0); - - /* If we are just removing the padding from expr, convert the original - object if we have variable size. That will avoid the need - for some variable-size temporaries. */ - if (TREE_CODE (expr) == COMPONENT_REF - && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0))) - && !TREE_CONSTANT (TYPE_SIZE (type))) - return convert (type, TREE_OPERAND (expr, 0)); - - /* If the result type is a padded type with a self-referentially-sized - field and the expression type is a record, do this as an - unchecked conversion. */ - else if (TREE_CODE (etype) == RECORD_TYPE - && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type)))) - return unchecked_convert (type, expr, false); - - else - return - gnat_build_constructor (type, - tree_cons (TYPE_FIELDS (type), - convert (TREE_TYPE - (TYPE_FIELDS (type)), - expr), - NULL_TREE)); - } - - /* If the input type has padding, remove it and convert to the output type. - The conditions ordering is arranged to ensure that the output type is not - a padding type here, as it is not clear whether the conversion would - always be correct if this was to happen. */ - else if (ecode == RECORD_TYPE && TYPE_IS_PADDING_P (etype)) - { - tree unpadded; - - /* If we have just converted to this padded type, just get the - inner expression. */ - if (TREE_CODE (expr) == CONSTRUCTOR - && !VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (expr)) - && VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->index - == TYPE_FIELDS (etype)) - unpadded - = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->value; - - /* Otherwise, build an explicit component reference. */ - else - unpadded - = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false); - - return convert (type, unpadded); - } - - /* If the input is a biased type, adjust first. */ - if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype)) - return convert (type, fold_build2 (PLUS_EXPR, TREE_TYPE (etype), - fold_convert (TREE_TYPE (etype), - expr), - TYPE_MIN_VALUE (etype))); - - /* If the input is a justified modular type, we need to extract the actual - object before converting it to any other type with the exceptions of an - unconstrained array or of a mere type variant. It is useful to avoid the - extraction and conversion in the type variant case because it could end - up replacing a VAR_DECL expr by a constructor and we might be about the - take the address of the result. */ - if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype) - && code != UNCONSTRAINED_ARRAY_TYPE - && TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (etype)) - return convert (type, build_component_ref (expr, NULL_TREE, - TYPE_FIELDS (etype), false)); - - /* If converting to a type that contains a template, convert to the data - type and then build the template. */ - if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type)) - { - tree obj_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))); - - /* If the source already has a template, get a reference to the - associated array only, as we are going to rebuild a template - for the target type anyway. */ - expr = maybe_unconstrained_array (expr); - - return - gnat_build_constructor - (type, - tree_cons (TYPE_FIELDS (type), - build_template (TREE_TYPE (TYPE_FIELDS (type)), - obj_type, NULL_TREE), - tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), - convert (obj_type, expr), NULL_TREE))); - } - - /* There are some special cases of expressions that we process - specially. */ - switch (TREE_CODE (expr)) - { - case ERROR_MARK: - return expr; - - case NULL_EXPR: - /* Just set its type here. For TRANSFORM_EXPR, we will do the actual - conversion in gnat_expand_expr. NULL_EXPR does not represent - and actual value, so no conversion is needed. */ - expr = copy_node (expr); - TREE_TYPE (expr) = type; - return expr; - - case STRING_CST: - /* If we are converting a STRING_CST to another constrained array type, - just make a new one in the proper type. */ - if (code == ecode && AGGREGATE_TYPE_P (etype) - && !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST - && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)) - { - expr = copy_node (expr); - TREE_TYPE (expr) = type; - return expr; - } - break; - - case CONSTRUCTOR: - /* If we are converting a CONSTRUCTOR to another constrained array type - with the same domain, just make a new one in the proper type. */ - if (code == ecode && code == ARRAY_TYPE - && TREE_TYPE (type) == TREE_TYPE (etype) - && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)), - TYPE_MIN_VALUE (TYPE_DOMAIN (etype))) - && tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (type)), - TYPE_MAX_VALUE (TYPE_DOMAIN (etype)))) - { - expr = copy_node (expr); - TREE_TYPE (expr) = type; - return expr; - } - break; - - case UNCONSTRAINED_ARRAY_REF: - /* Convert this to the type of the inner array by getting the address of - the array from the template. */ - expr = build_unary_op (INDIRECT_REF, NULL_TREE, - build_component_ref (TREE_OPERAND (expr, 0), - get_identifier ("P_ARRAY"), - NULL_TREE, false)); - etype = TREE_TYPE (expr); - ecode = TREE_CODE (etype); - break; - - case VIEW_CONVERT_EXPR: - { - /* GCC 4.x is very sensitive to type consistency overall, and view - conversions thus are very frequent. Even though just "convert"ing - the inner operand to the output type is fine in most cases, it - might expose unexpected input/output type mismatches in special - circumstances so we avoid such recursive calls when we can. */ - - tree op0 = TREE_OPERAND (expr, 0); - - /* If we are converting back to the original type, we can just - lift the input conversion. This is a common occurrence with - switches back-and-forth amongst type variants. */ - if (type == TREE_TYPE (op0)) - return op0; - - /* Otherwise, if we're converting between two aggregate types, we - might be allowed to substitute the VIEW_CONVERT target type in - place or to just convert the inner expression. */ - if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)) - { - /* If we are converting between type variants, we can just - substitute the VIEW_CONVERT in place. */ - if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)) - return build1 (VIEW_CONVERT_EXPR, type, op0); - - /* Otherwise, we may just bypass the input view conversion unless - one of the types is a fat pointer, which is handled by - specialized code below which relies on exact type matching. */ - else if (!TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)) - return convert (type, op0); - } - } - break; - - case INDIRECT_REF: - /* If both types are record types, just convert the pointer and - make a new INDIRECT_REF. - - ??? Disable this for now since it causes problems with the - code in build_binary_op for MODIFY_EXPR which wants to - strip off conversions. But that code really is a mess and - we need to do this a much better way some time. */ - if (0 - && (TREE_CODE (type) == RECORD_TYPE - || TREE_CODE (type) == UNION_TYPE) - && (TREE_CODE (etype) == RECORD_TYPE - || TREE_CODE (etype) == UNION_TYPE) - && !TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)) - return build_unary_op (INDIRECT_REF, NULL_TREE, - convert (build_pointer_type (type), - TREE_OPERAND (expr, 0))); - break; - - default: - break; - } - - /* Check for converting to a pointer to an unconstrained array. */ - if (TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)) - return convert_to_fat_pointer (type, expr); - - /* If we are converting between two aggregate types that have the same main - variant, just make a VIEW_CONVER_EXPR. */ - else if (AGGREGATE_TYPE_P (type) - && TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)) - return build1 (VIEW_CONVERT_EXPR, type, expr); - - /* In all other cases of related types, make a NOP_EXPR. */ - else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype) - || (code == INTEGER_CST && ecode == INTEGER_CST - && (type == TREE_TYPE (etype) || etype == TREE_TYPE (type)))) - return fold_convert (type, expr); - - switch (code) - { - case VOID_TYPE: - return fold_build1 (CONVERT_EXPR, type, expr); - - case BOOLEAN_TYPE: - return fold_convert (type, gnat_truthvalue_conversion (expr)); - - case INTEGER_TYPE: - if (TYPE_HAS_ACTUAL_BOUNDS_P (type) - && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE - || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype)))) - return unchecked_convert (type, expr, false); - else if (TYPE_BIASED_REPRESENTATION_P (type)) - return fold_convert (type, - fold_build2 (MINUS_EXPR, TREE_TYPE (type), - convert (TREE_TYPE (type), expr), - TYPE_MIN_VALUE (type))); - - /* ... fall through ... */ - - case ENUMERAL_TYPE: - /* If we are converting an additive expression to an integer type - with lower precision, be wary of the optimization that can be - applied by convert_to_integer. There are 2 problematic cases: - - if the first operand was originally of a biased type, - because we could be recursively called to convert it - to an intermediate type and thus rematerialize the - additive operator endlessly, - - if the expression contains a placeholder, because an - intermediate conversion that changes the sign could - be inserted and thus introduce an artificial overflow - at compile time when the placeholder is substituted. */ - if (code == INTEGER_TYPE - && ecode == INTEGER_TYPE - && TYPE_PRECISION (type) < TYPE_PRECISION (etype) - && (TREE_CODE (expr) == PLUS_EXPR || TREE_CODE (expr) == MINUS_EXPR)) - { - tree op0 = get_unwidened (TREE_OPERAND (expr, 0), type); - - if ((TREE_CODE (TREE_TYPE (op0)) == INTEGER_TYPE - && TYPE_BIASED_REPRESENTATION_P (TREE_TYPE (op0))) - || CONTAINS_PLACEHOLDER_P (expr)) - return build1 (NOP_EXPR, type, expr); - } - - return fold (convert_to_integer (type, expr)); - - case POINTER_TYPE: - case REFERENCE_TYPE: - /* If converting between two pointers to records denoting - both a template and type, adjust if needed to account - for any differing offsets, since one might be negative. */ - if (TYPE_THIN_POINTER_P (etype) && TYPE_THIN_POINTER_P (type)) - { - tree bit_diff - = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype))), - bit_position (TYPE_FIELDS (TREE_TYPE (type)))); - tree byte_diff = size_binop (CEIL_DIV_EXPR, bit_diff, - sbitsize_int (BITS_PER_UNIT)); - - expr = build1 (NOP_EXPR, type, expr); - TREE_CONSTANT (expr) = TREE_CONSTANT (TREE_OPERAND (expr, 0)); - if (integer_zerop (byte_diff)) - return expr; - - return build_binary_op (POINTER_PLUS_EXPR, type, expr, - fold (convert (sizetype, byte_diff))); - } - - /* If converting to a thin pointer, handle specially. */ - if (TYPE_THIN_POINTER_P (type) - && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))) - return convert_to_thin_pointer (type, expr); - - /* If converting fat pointer to normal pointer, get the pointer to the - array and then convert it. */ - else if (TYPE_FAT_POINTER_P (etype)) - expr = build_component_ref (expr, get_identifier ("P_ARRAY"), - NULL_TREE, false); - - return fold (convert_to_pointer (type, expr)); - - case REAL_TYPE: - return fold (convert_to_real (type, expr)); - - case RECORD_TYPE: - if (TYPE_JUSTIFIED_MODULAR_P (type) && !AGGREGATE_TYPE_P (etype)) - return - gnat_build_constructor - (type, tree_cons (TYPE_FIELDS (type), - convert (TREE_TYPE (TYPE_FIELDS (type)), expr), - NULL_TREE)); - - /* ... fall through ... */ - - case ARRAY_TYPE: - /* In these cases, assume the front-end has validated the conversion. - If the conversion is valid, it will be a bit-wise conversion, so - it can be viewed as an unchecked conversion. */ - return unchecked_convert (type, expr, false); - - case UNION_TYPE: - /* This is a either a conversion between a tagged type and some - subtype, which we have to mark as a UNION_TYPE because of - overlapping fields or a conversion of an Unchecked_Union. */ - return unchecked_convert (type, expr, false); - - case UNCONSTRAINED_ARRAY_TYPE: - /* If EXPR is a constrained array, take its address, convert it to a - fat pointer, and then dereference it. Likewise if EXPR is a - record containing both a template and a constrained array. - Note that a record representing a justified modular type - always represents a packed constrained array. */ - if (ecode == ARRAY_TYPE - || (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype)) - || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype)) - || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype))) - return - build_unary_op - (INDIRECT_REF, NULL_TREE, - convert_to_fat_pointer (TREE_TYPE (type), - build_unary_op (ADDR_EXPR, - NULL_TREE, expr))); - - /* Do something very similar for converting one unconstrained - array to another. */ - else if (ecode == UNCONSTRAINED_ARRAY_TYPE) - return - build_unary_op (INDIRECT_REF, NULL_TREE, - convert (TREE_TYPE (type), - build_unary_op (ADDR_EXPR, - NULL_TREE, expr))); - else - gcc_unreachable (); - - case COMPLEX_TYPE: - return fold (convert_to_complex (type, expr)); - - default: - gcc_unreachable (); - } - } - - /* Remove all conversions that are done in EXP. This includes converting - from a padded type or to a justified modular type. If TRUE_ADDRESS - is true, always return the address of the containing object even if - the address is not bit-aligned. */ - - tree - remove_conversions (tree exp, bool true_address) - { - switch (TREE_CODE (exp)) - { - case CONSTRUCTOR: - if (true_address - && TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (exp))) - return - remove_conversions (VEC_index (constructor_elt, - CONSTRUCTOR_ELTS (exp), 0)->value, - true); - break; - - case COMPONENT_REF: - if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp, 0))) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0)))) - return remove_conversions (TREE_OPERAND (exp, 0), true_address); - break; - - case VIEW_CONVERT_EXPR: case NON_LVALUE_EXPR: - case NOP_EXPR: case CONVERT_EXPR: - return remove_conversions (TREE_OPERAND (exp, 0), true_address); - - default: - break; - } - - return exp; - } - - /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that - refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P, - likewise return an expression pointing to the underlying array. */ - - tree - maybe_unconstrained_array (tree exp) - { - enum tree_code code = TREE_CODE (exp); - tree new; - - switch (TREE_CODE (TREE_TYPE (exp))) - { - case UNCONSTRAINED_ARRAY_TYPE: - if (code == UNCONSTRAINED_ARRAY_REF) - { - new - = build_unary_op (INDIRECT_REF, NULL_TREE, - build_component_ref (TREE_OPERAND (exp, 0), - get_identifier ("P_ARRAY"), - NULL_TREE, false)); - TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp); - return new; - } - - else if (code == NULL_EXPR) - return build1 (NULL_EXPR, - TREE_TYPE (TREE_TYPE (TYPE_FIELDS - (TREE_TYPE (TREE_TYPE (exp))))), - TREE_OPERAND (exp, 0)); - - case RECORD_TYPE: - /* If this is a padded type, convert to the unpadded type and see if - it contains a template. */ - if (TYPE_IS_PADDING_P (TREE_TYPE (exp))) - { - new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp); - if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new))) - return - build_component_ref (new, NULL_TREE, - TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))), - 0); - } - else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp))) - return - build_component_ref (exp, NULL_TREE, - TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))), 0); - break; - - default: - break; - } - - return exp; - } - - /* Return true if EXPR is an expression that can be folded as an operand - of a VIEW_CONVERT_EXPR. See the head comment of unchecked_convert for - the rationale. */ - - static bool - can_fold_for_view_convert_p (tree expr) - { - tree t1, t2; - - /* The folder will fold NOP_EXPRs between integral types with the same - precision (in the middle-end's sense). We cannot allow it if the - types don't have the same precision in the Ada sense as well. */ - if (TREE_CODE (expr) != NOP_EXPR) - return true; - - t1 = TREE_TYPE (expr); - t2 = TREE_TYPE (TREE_OPERAND (expr, 0)); - - /* Defer to the folder for non-integral conversions. */ - if (!(INTEGRAL_TYPE_P (t1) && INTEGRAL_TYPE_P (t2))) - return true; - - /* Only fold conversions that preserve both precisions. */ - if (TYPE_PRECISION (t1) == TYPE_PRECISION (t2) - && operand_equal_p (rm_size (t1), rm_size (t2), 0)) - return true; - - return false; - } - - /* Return an expression that does an unchecked conversion of EXPR to TYPE. - If NOTRUNC_P is true, truncation operations should be suppressed. - - Special care is required with (source or target) integral types whose - precision is not equal to their size, to make sure we fetch or assign - the value bits whose location might depend on the endianness, e.g. - - Rmsize : constant := 8; - subtype Int is Integer range 0 .. 2 ** Rmsize - 1; - - type Bit_Array is array (1 .. Rmsize) of Boolean; - pragma Pack (Bit_Array); - - function To_Bit_Array is new Unchecked_Conversion (Int, Bit_Array); - - Value : Int := 2#1000_0001#; - Vbits : Bit_Array := To_Bit_Array (Value); - - we expect the 8 bits at Vbits'Address to always contain Value, while - their original location depends on the endianness, at Value'Address - on a little-endian architecture but not on a big-endian one. - - ??? There is a problematic discrepancy between what is called precision - here (and more generally throughout gigi) for integral types and what is - called precision in the middle-end. In the former case it's the RM size - as given by TYPE_RM_SIZE (or rm_size) whereas it's TYPE_PRECISION in the - latter case, the hitch being that they are not equal when they matter, - that is when the number of value bits is not equal to the type's size: - TYPE_RM_SIZE does give the number of value bits but TYPE_PRECISION is set - to the size. The sole exception are BOOLEAN_TYPEs for which both are 1. - - The consequence is that gigi must duplicate code bridging the gap between - the type's size and its precision that exists for TYPE_PRECISION in the - middle-end, because the latter knows nothing about TYPE_RM_SIZE, and be - wary of transformations applied in the middle-end based on TYPE_PRECISION - because this value doesn't reflect the actual precision for Ada. */ - - tree - unchecked_convert (tree type, tree expr, bool notrunc_p) - { - tree etype = TREE_TYPE (expr); - - /* If the expression is already the right type, we are done. */ - if (etype == type) - return expr; - - /* If both types types are integral just do a normal conversion. - Likewise for a conversion to an unconstrained array. */ - if ((((INTEGRAL_TYPE_P (type) - && !(TREE_CODE (type) == INTEGER_TYPE - && TYPE_VAX_FLOATING_POINT_P (type))) - || (POINTER_TYPE_P (type) && ! TYPE_THIN_POINTER_P (type)) - || (TREE_CODE (type) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (type))) - && ((INTEGRAL_TYPE_P (etype) - && !(TREE_CODE (etype) == INTEGER_TYPE - && TYPE_VAX_FLOATING_POINT_P (etype))) - || (POINTER_TYPE_P (etype) && !TYPE_THIN_POINTER_P (etype)) - || (TREE_CODE (etype) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (etype)))) - || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) - { - if (TREE_CODE (etype) == INTEGER_TYPE - && TYPE_BIASED_REPRESENTATION_P (etype)) - { - tree ntype = copy_type (etype); - TYPE_BIASED_REPRESENTATION_P (ntype) = 0; - TYPE_MAIN_VARIANT (ntype) = ntype; - expr = build1 (NOP_EXPR, ntype, expr); - } - - if (TREE_CODE (type) == INTEGER_TYPE - && TYPE_BIASED_REPRESENTATION_P (type)) - { - tree rtype = copy_type (type); - TYPE_BIASED_REPRESENTATION_P (rtype) = 0; - TYPE_MAIN_VARIANT (rtype) = rtype; - expr = convert (rtype, expr); - expr = build1 (NOP_EXPR, type, expr); - } - - /* We have another special case: if we are unchecked converting either - a subtype or a type with limited range into a base type, we need to - ensure that VRP doesn't propagate range information because this - conversion may be done precisely to validate that the object is - within the range it is supposed to have. */ - else if (TREE_CODE (expr) != INTEGER_CST - && TREE_CODE (type) == INTEGER_TYPE && !TREE_TYPE (type) - && ((TREE_CODE (etype) == INTEGER_TYPE && TREE_TYPE (etype)) - || TREE_CODE (etype) == ENUMERAL_TYPE - || TREE_CODE (etype) == BOOLEAN_TYPE)) - { - /* The optimization barrier is a VIEW_CONVERT_EXPR node; moreover, - in order not to be deemed an useless type conversion, it must - be from subtype to base type. - - Therefore we first do the bulk of the conversion to a subtype of - the final type. And this conversion must itself not be deemed - useless if the source type is not a subtype because, otherwise, - the final VIEW_CONVERT_EXPR will be deemed so as well. That's - why we toggle the unsigned flag in this conversion, which is - harmless since the final conversion is only a reinterpretation - of the bit pattern. - - ??? This may raise addressability and/or aliasing issues because - VIEW_CONVERT_EXPR gets gimplified as an lvalue, thus causing the - address of its operand to be taken if it is deemed addressable - and not already in GIMPLE form. */ - tree rtype - = gnat_type_for_mode (TYPE_MODE (type), !TYPE_UNSIGNED (etype)); - rtype = copy_type (rtype); - TYPE_MAIN_VARIANT (rtype) = rtype; - TREE_TYPE (rtype) = type; - expr = convert (rtype, expr); - expr = build1 (VIEW_CONVERT_EXPR, type, expr); - } - - else - expr = convert (type, expr); - } - - /* If we are converting to an integral type whose precision is not equal - to its size, first unchecked convert to a record that contains an - object of the output type. Then extract the field. */ - else if (INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) - && 0 != compare_tree_int (TYPE_RM_SIZE (type), - GET_MODE_BITSIZE (TYPE_MODE (type)))) - { - tree rec_type = make_node (RECORD_TYPE); - tree field = create_field_decl (get_identifier ("OBJ"), type, - rec_type, 1, 0, 0, 0); - - TYPE_FIELDS (rec_type) = field; - layout_type (rec_type); - - expr = unchecked_convert (rec_type, expr, notrunc_p); - expr = build_component_ref (expr, NULL_TREE, field, 0); - } - - /* Similarly if we are converting from an integral type whose precision - is not equal to its size. */ - else if (INTEGRAL_TYPE_P (etype) && TYPE_RM_SIZE (etype) - && 0 != compare_tree_int (TYPE_RM_SIZE (etype), - GET_MODE_BITSIZE (TYPE_MODE (etype)))) - { - tree rec_type = make_node (RECORD_TYPE); - tree field - = create_field_decl (get_identifier ("OBJ"), etype, rec_type, - 1, 0, 0, 0); - - TYPE_FIELDS (rec_type) = field; - layout_type (rec_type); - - expr = gnat_build_constructor (rec_type, build_tree_list (field, expr)); - expr = unchecked_convert (type, expr, notrunc_p); - } - - /* We have a special case when we are converting between two - unconstrained array types. In that case, take the address, - convert the fat pointer types, and dereference. */ - else if (TREE_CODE (etype) == UNCONSTRAINED_ARRAY_TYPE - && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) - expr = build_unary_op (INDIRECT_REF, NULL_TREE, - build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type), - build_unary_op (ADDR_EXPR, NULL_TREE, - expr))); - else - { - expr = maybe_unconstrained_array (expr); - etype = TREE_TYPE (expr); - if (can_fold_for_view_convert_p (expr)) - expr = fold_build1 (VIEW_CONVERT_EXPR, type, expr); - else - expr = build1 (VIEW_CONVERT_EXPR, type, expr); - } - - /* If the result is an integral type whose precision is not equal to its - size, sign- or zero-extend the result. We need not do this if the input - is an integral type of the same precision and signedness or if the output - is a biased type or if both the input and output are unsigned. */ - if (!notrunc_p - && INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) - && !(TREE_CODE (type) == INTEGER_TYPE - && TYPE_BIASED_REPRESENTATION_P (type)) - && 0 != compare_tree_int (TYPE_RM_SIZE (type), - GET_MODE_BITSIZE (TYPE_MODE (type))) - && !(INTEGRAL_TYPE_P (etype) - && TYPE_UNSIGNED (type) == TYPE_UNSIGNED (etype) - && operand_equal_p (TYPE_RM_SIZE (type), - (TYPE_RM_SIZE (etype) != 0 - ? TYPE_RM_SIZE (etype) : TYPE_SIZE (etype)), - 0)) - && !(TYPE_UNSIGNED (type) && TYPE_UNSIGNED (etype))) - { - tree base_type = gnat_type_for_mode (TYPE_MODE (type), - TYPE_UNSIGNED (type)); - tree shift_expr - = convert (base_type, - size_binop (MINUS_EXPR, - bitsize_int - (GET_MODE_BITSIZE (TYPE_MODE (type))), - TYPE_RM_SIZE (type))); - expr - = convert (type, - build_binary_op (RSHIFT_EXPR, base_type, - build_binary_op (LSHIFT_EXPR, base_type, - convert (base_type, expr), - shift_expr), - shift_expr)); - } - - /* An unchecked conversion should never raise Constraint_Error. The code - below assumes that GCC's conversion routines overflow the same way that - the underlying hardware does. This is probably true. In the rare case - when it is false, we can rely on the fact that such conversions are - erroneous anyway. */ - if (TREE_CODE (expr) == INTEGER_CST) - TREE_OVERFLOW (expr) = 0; - - /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR, - show no longer constant. */ - if (TREE_CODE (expr) == VIEW_CONVERT_EXPR - && !operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype), - OEP_ONLY_CONST)) - TREE_CONSTANT (expr) = 0; - - return expr; - } - - /* Search the chain of currently available builtin declarations for a node - corresponding to function NAME (an IDENTIFIER_NODE). Return the first node - found, if any, or NULL_TREE otherwise. */ - tree - builtin_decl_for (tree name) - { - unsigned i; - tree decl; - - for (i = 0; VEC_iterate(tree, builtin_decls, i, decl); i++) - if (DECL_NAME (decl) == name) - return decl; - - return NULL_TREE; - } - - /* Return the appropriate GCC tree code for the specified GNAT type, - the latter being a record type as predicated by Is_Record_Type. */ - - enum tree_code - tree_code_for_record_type (Entity_Id gnat_type) - { - Node_Id component_list - = Component_List (Type_Definition - (Declaration_Node - (Implementation_Base_Type (gnat_type)))); - Node_Id component; - - /* Make this a UNION_TYPE unless it's either not an Unchecked_Union or - we have a non-discriminant field outside a variant. In either case, - it's a RECORD_TYPE. */ - - if (!Is_Unchecked_Union (gnat_type)) - return RECORD_TYPE; - - for (component = First_Non_Pragma (Component_Items (component_list)); - Present (component); - component = Next_Non_Pragma (component)) - if (Ekind (Defining_Entity (component)) == E_Component) - return RECORD_TYPE; - - return UNION_TYPE; - } - - /* Return true if GNU_TYPE is suitable as the type of a non-aliased - component of an aggregate type. */ - - bool - type_for_nonaliased_component_p (tree gnu_type) - { - /* If the type is passed by reference, we may have pointers to the - component so it cannot be made non-aliased. */ - if (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type)) - return false; - - /* We used to say that any component of aggregate type is aliased - because the front-end may take 'Reference of it. The front-end - has been enhanced in the meantime so as to use a renaming instead - in most cases, but the back-end can probably take the address of - such a component too so we go for the conservative stance. - - For instance, we might need the address of any array type, even - if normally passed by copy, to construct a fat pointer if the - component is used as an actual for an unconstrained formal. - - Likewise for record types: even if a specific record subtype is - passed by copy, the parent type might be passed by ref (e.g. if - it's of variable size) and we might take the address of a child - component to pass to a parent formal. We have no way to check - for such conditions here. */ - if (AGGREGATE_TYPE_P (gnu_type)) - return false; - - return true; - } - - /* Perform final processing on global variables. */ - - void - gnat_write_global_declarations (void) - { - /* Proceed to optimize and emit assembly. - FIXME: shouldn't be the front end's responsibility to call this. */ - cgraph_optimize (); - - /* Emit debug info for all global declarations. */ - emit_debug_global_declarations (VEC_address (tree, global_decls), - VEC_length (tree, global_decls)); - } - - #include "gt-ada-utils.h" - #include "gtype-ada.h" --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/utils2.c gcc-4.4.0/gcc/ada/utils2.c *** gcc-4.3.3/gcc/ada/utils2.c Tue Jun 24 18:15:56 2008 --- gcc-4.4.0/gcc/ada/utils2.c Thu Jan 1 00:00:00 1970 *************** *** 1,2183 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * U T I L S 2 * - * * - * C Implementation File * - * * - * Copyright (C) 1992-2008, 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- * - * ware Foundation; either version 3, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License along with GCC; see the file COPYING3. If not see * - * . * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - #include "config.h" - #include "system.h" - #include "coretypes.h" - #include "tm.h" - #include "tree.h" - #include "rtl.h" - #include "ggc.h" - #include "flags.h" - #include "output.h" - #include "ada.h" - #include "types.h" - #include "atree.h" - #include "stringt.h" - #include "namet.h" - #include "uintp.h" - #include "fe.h" - #include "elists.h" - #include "nlists.h" - #include "sinfo.h" - #include "einfo.h" - #include "ada-tree.h" - #include "gigi.h" - - static tree find_common_type (tree, tree); - static bool contains_save_expr_p (tree); - static tree contains_null_expr (tree); - static tree compare_arrays (tree, tree, tree); - static tree nonbinary_modular_operation (enum tree_code, tree, tree, tree); - static tree build_simple_component_ref (tree, tree, tree, bool); - - /* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical - operation. - - This preparation consists of taking the ordinary representation of - an expression expr and producing a valid tree boolean expression - describing whether expr is nonzero. We could simply always do - - build_binary_op (NE_EXPR, expr, integer_zero_node, 1), - - but we optimize comparisons, &&, ||, and !. - - The resulting type should always be the same as the input type. - This function is simpler than the corresponding C version since - the only possible operands will be things of Boolean type. */ - - tree - gnat_truthvalue_conversion (tree expr) - { - tree type = TREE_TYPE (expr); - - switch (TREE_CODE (expr)) - { - case EQ_EXPR: case NE_EXPR: case LE_EXPR: case GE_EXPR: - case LT_EXPR: case GT_EXPR: - case TRUTH_ANDIF_EXPR: - case TRUTH_ORIF_EXPR: - case TRUTH_AND_EXPR: - case TRUTH_OR_EXPR: - case TRUTH_XOR_EXPR: - case ERROR_MARK: - return expr; - - case INTEGER_CST: - return (integer_zerop (expr) - ? build_int_cst (type, 0) - : build_int_cst (type, 1)); - - case REAL_CST: - return (real_zerop (expr) - ? fold_convert (type, integer_zero_node) - : fold_convert (type, integer_one_node)); - - case COND_EXPR: - /* Distribute the conversion into the arms of a COND_EXPR. */ - { - tree arg1 = gnat_truthvalue_conversion (TREE_OPERAND (expr, 1)); - tree arg2 = gnat_truthvalue_conversion (TREE_OPERAND (expr, 2)); - return fold_build3 (COND_EXPR, type, TREE_OPERAND (expr, 0), - arg1, arg2); - } - - default: - return build_binary_op (NE_EXPR, type, expr, - fold_convert (type, integer_zero_node)); - } - } - - /* Return the base type of TYPE. */ - - tree - get_base_type (tree type) - { - if (TREE_CODE (type) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (type)) - type = TREE_TYPE (TYPE_FIELDS (type)); - - while (TREE_TYPE (type) - && (TREE_CODE (type) == INTEGER_TYPE - || TREE_CODE (type) == REAL_TYPE)) - type = TREE_TYPE (type); - - return type; - } - - /* EXP is a GCC tree representing an address. See if we can find how - strictly the object at that address is aligned. Return that alignment - in bits. If we don't know anything about the alignment, return 0. */ - - unsigned int - known_alignment (tree exp) - { - unsigned int this_alignment; - unsigned int lhs, rhs; - - switch (TREE_CODE (exp)) - { - case CONVERT_EXPR: - case VIEW_CONVERT_EXPR: - case NOP_EXPR: - case NON_LVALUE_EXPR: - /* Conversions between pointers and integers don't change the alignment - of the underlying object. */ - this_alignment = known_alignment (TREE_OPERAND (exp, 0)); - break; - - case COMPOUND_EXPR: - /* The value of a COMPOUND_EXPR is that of it's second operand. */ - this_alignment = known_alignment (TREE_OPERAND (exp, 1)); - break; - - case PLUS_EXPR: - case MINUS_EXPR: - /* If two address are added, the alignment of the result is the - minimum of the two alignments. */ - lhs = known_alignment (TREE_OPERAND (exp, 0)); - rhs = known_alignment (TREE_OPERAND (exp, 1)); - this_alignment = MIN (lhs, rhs); - break; - - case POINTER_PLUS_EXPR: - lhs = known_alignment (TREE_OPERAND (exp, 0)); - rhs = known_alignment (TREE_OPERAND (exp, 1)); - /* If we don't know the alignment of the offset, we assume that - of the base. */ - if (rhs == 0) - this_alignment = lhs; - else - this_alignment = MIN (lhs, rhs); - break; - - case COND_EXPR: - /* If there is a choice between two values, use the smallest one. */ - lhs = known_alignment (TREE_OPERAND (exp, 1)); - rhs = known_alignment (TREE_OPERAND (exp, 2)); - this_alignment = MIN (lhs, rhs); - break; - - case INTEGER_CST: - { - unsigned HOST_WIDE_INT c = TREE_INT_CST_LOW (exp); - /* The first part of this represents the lowest bit in the constant, - but it is originally in bytes, not bits. */ - this_alignment = MIN (BITS_PER_UNIT * (c & -c), BIGGEST_ALIGNMENT); - } - break; - - case MULT_EXPR: - /* If we know the alignment of just one side, use it. Otherwise, - use the product of the alignments. */ - lhs = known_alignment (TREE_OPERAND (exp, 0)); - rhs = known_alignment (TREE_OPERAND (exp, 1)); - - if (lhs == 0) - this_alignment = rhs; - else if (rhs == 0) - this_alignment = lhs; - else - this_alignment = MIN (lhs * rhs, BIGGEST_ALIGNMENT); - break; - - case BIT_AND_EXPR: - /* A bit-and expression is as aligned as the maximum alignment of the - operands. We typically get here for a complex lhs and a constant - negative power of two on the rhs to force an explicit alignment, so - don't bother looking at the lhs. */ - this_alignment = known_alignment (TREE_OPERAND (exp, 1)); - break; - - case ADDR_EXPR: - this_alignment = expr_align (TREE_OPERAND (exp, 0)); - break; - - default: - /* For other pointer expressions, we assume that the pointed-to object - is at least as aligned as the pointed-to type. Beware that we can - have a dummy type here (e.g. a Taft Amendment type), for which the - alignment is meaningless and should be ignored. */ - if (POINTER_TYPE_P (TREE_TYPE (exp)) - && !TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp)))) - this_alignment = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (exp))); - else - this_alignment = 0; - break; - } - - return this_alignment; - } - - /* We have a comparison or assignment operation on two types, T1 and T2, - which are both either array types or both record types. - Return the type that both operands should be converted to, if any. - Otherwise return zero. */ - - static tree - find_common_type (tree t1, tree t2) - { - /* If either type is non-BLKmode, use it. Note that we know that we will - not have any alignment problems since if we did the non-BLKmode - type could not have been used. */ - if (TYPE_MODE (t1) != BLKmode) - return t1; - else if (TYPE_MODE (t2) != BLKmode) - return t2; - - /* If both types have constant size, use the smaller one. Keep returning - T1 if we have a tie, to be consistent with the other cases. */ - if (TREE_CONSTANT (TYPE_SIZE (t1)) && TREE_CONSTANT (TYPE_SIZE (t2))) - return tree_int_cst_lt (TYPE_SIZE (t2), TYPE_SIZE (t1)) ? t2 : t1; - - /* Otherwise, if either type has a constant size, use it. */ - else if (TREE_CONSTANT (TYPE_SIZE (t1))) - return t1; - else if (TREE_CONSTANT (TYPE_SIZE (t2))) - return t2; - - /* In this case, both types have variable size. It's probably - best to leave the "type mismatch" because changing it could - case a bad self-referential reference. */ - return 0; - } - - /* See if EXP contains a SAVE_EXPR in a position where we would - normally put it. - - ??? This is a real kludge, but is probably the best approach short - of some very general solution. */ - - static bool - contains_save_expr_p (tree exp) - { - switch (TREE_CODE (exp)) - { - case SAVE_EXPR: - return true; - - case ADDR_EXPR: case INDIRECT_REF: - case COMPONENT_REF: - case NOP_EXPR: case CONVERT_EXPR: case VIEW_CONVERT_EXPR: - return contains_save_expr_p (TREE_OPERAND (exp, 0)); - - case CONSTRUCTOR: - { - tree value; - unsigned HOST_WIDE_INT ix; - - FOR_EACH_CONSTRUCTOR_VALUE (CONSTRUCTOR_ELTS (exp), ix, value) - if (contains_save_expr_p (value)) - return true; - return false; - } - - default: - return false; - } - } - - /* See if EXP contains a NULL_EXPR in an expression we use for sizes. Return - it if so. This is used to detect types whose sizes involve computations - that are known to raise Constraint_Error. */ - - static tree - contains_null_expr (tree exp) - { - tree tem; - - if (TREE_CODE (exp) == NULL_EXPR) - return exp; - - switch (TREE_CODE_CLASS (TREE_CODE (exp))) - { - case tcc_unary: - return contains_null_expr (TREE_OPERAND (exp, 0)); - - case tcc_comparison: - case tcc_binary: - tem = contains_null_expr (TREE_OPERAND (exp, 0)); - if (tem) - return tem; - - return contains_null_expr (TREE_OPERAND (exp, 1)); - - case tcc_expression: - switch (TREE_CODE (exp)) - { - case SAVE_EXPR: - return contains_null_expr (TREE_OPERAND (exp, 0)); - - case COND_EXPR: - tem = contains_null_expr (TREE_OPERAND (exp, 0)); - if (tem) - return tem; - - tem = contains_null_expr (TREE_OPERAND (exp, 1)); - if (tem) - return tem; - - return contains_null_expr (TREE_OPERAND (exp, 2)); - - default: - return 0; - } - - default: - return 0; - } - } - - /* Return an expression tree representing an equality comparison of - A1 and A2, two objects of ARRAY_TYPE. The returned expression should - be of type RESULT_TYPE - - Two arrays are equal in one of two ways: (1) if both have zero length - in some dimension (not necessarily the same dimension) or (2) if the - lengths in each dimension are equal and the data is equal. We perform the - length tests in as efficient a manner as possible. */ - - static tree - compare_arrays (tree result_type, tree a1, tree a2) - { - tree t1 = TREE_TYPE (a1); - tree t2 = TREE_TYPE (a2); - tree result = convert (result_type, integer_one_node); - tree a1_is_null = convert (result_type, integer_zero_node); - tree a2_is_null = convert (result_type, integer_zero_node); - bool length_zero_p = false; - - /* Process each dimension separately and compare the lengths. If any - dimension has a size known to be zero, set SIZE_ZERO_P to 1 to - suppress the comparison of the data. */ - while (TREE_CODE (t1) == ARRAY_TYPE && TREE_CODE (t2) == ARRAY_TYPE) - { - tree lb1 = TYPE_MIN_VALUE (TYPE_DOMAIN (t1)); - tree ub1 = TYPE_MAX_VALUE (TYPE_DOMAIN (t1)); - tree lb2 = TYPE_MIN_VALUE (TYPE_DOMAIN (t2)); - tree ub2 = TYPE_MAX_VALUE (TYPE_DOMAIN (t2)); - tree bt = get_base_type (TREE_TYPE (lb1)); - tree length1 = fold_build2 (MINUS_EXPR, bt, ub1, lb1); - tree length2 = fold_build2 (MINUS_EXPR, bt, ub2, lb2); - tree nbt; - tree tem; - tree comparison, this_a1_is_null, this_a2_is_null; - - /* If the length of the first array is a constant, swap our operands - unless the length of the second array is the constant zero. - Note that we have set the `length' values to the length - 1. */ - if (TREE_CODE (length1) == INTEGER_CST - && !integer_zerop (fold_build2 (PLUS_EXPR, bt, length2, - convert (bt, integer_one_node)))) - { - tem = a1, a1 = a2, a2 = tem; - tem = t1, t1 = t2, t2 = tem; - tem = lb1, lb1 = lb2, lb2 = tem; - tem = ub1, ub1 = ub2, ub2 = tem; - tem = length1, length1 = length2, length2 = tem; - tem = a1_is_null, a1_is_null = a2_is_null, a2_is_null = tem; - } - - /* If the length of this dimension in the second array is the constant - zero, we can just go inside the original bounds for the first - array and see if last < first. */ - if (integer_zerop (fold_build2 (PLUS_EXPR, bt, length2, - convert (bt, integer_one_node)))) - { - tree ub = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); - tree lb = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); - - comparison = build_binary_op (LT_EXPR, result_type, ub, lb); - comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1); - length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1); - - length_zero_p = true; - this_a1_is_null = comparison; - this_a2_is_null = convert (result_type, integer_one_node); - } - - /* If the length is some other constant value, we know that the - this dimension in the first array cannot be superflat, so we - can just use its length from the actual stored bounds. */ - else if (TREE_CODE (length2) == INTEGER_CST) - { - ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); - lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); - ub2 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2))); - lb2 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2))); - nbt = get_base_type (TREE_TYPE (ub1)); - - comparison - = build_binary_op (EQ_EXPR, result_type, - build_binary_op (MINUS_EXPR, nbt, ub1, lb1), - build_binary_op (MINUS_EXPR, nbt, ub2, lb2)); - - /* Note that we know that UB2 and LB2 are constant and hence - cannot contain a PLACEHOLDER_EXPR. */ - - comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1); - length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1); - - this_a1_is_null = build_binary_op (LT_EXPR, result_type, ub1, lb1); - this_a2_is_null = convert (result_type, integer_zero_node); - } - - /* Otherwise compare the computed lengths. */ - else - { - length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1); - length2 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length2, a2); - - comparison - = build_binary_op (EQ_EXPR, result_type, length1, length2); - - this_a1_is_null - = build_binary_op (LT_EXPR, result_type, length1, - convert (bt, integer_zero_node)); - this_a2_is_null - = build_binary_op (LT_EXPR, result_type, length2, - convert (bt, integer_zero_node)); - } - - result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, - result, comparison); - - a1_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type, - this_a1_is_null, a1_is_null); - a2_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type, - this_a2_is_null, a2_is_null); - - t1 = TREE_TYPE (t1); - t2 = TREE_TYPE (t2); - } - - /* Unless the size of some bound is known to be zero, compare the - data in the array. */ - if (!length_zero_p) - { - tree type = find_common_type (TREE_TYPE (a1), TREE_TYPE (a2)); - - if (type) - a1 = convert (type, a1), a2 = convert (type, a2); - - result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result, - fold_build2 (EQ_EXPR, result_type, a1, a2)); - - } - - /* The result is also true if both sizes are zero. */ - result = build_binary_op (TRUTH_ORIF_EXPR, result_type, - build_binary_op (TRUTH_ANDIF_EXPR, result_type, - a1_is_null, a2_is_null), - result); - - /* If either operand contains SAVE_EXPRs, they have to be evaluated before - starting the comparison above since the place it would be otherwise - evaluated would be wrong. */ - - if (contains_save_expr_p (a1)) - result = build2 (COMPOUND_EXPR, result_type, a1, result); - - if (contains_save_expr_p (a2)) - result = build2 (COMPOUND_EXPR, result_type, a2, result); - - return result; - } - - /* Compute the result of applying OP_CODE to LHS and RHS, where both are of - type TYPE. We know that TYPE is a modular type with a nonbinary - modulus. */ - - static tree - nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs, - tree rhs) - { - tree modulus = TYPE_MODULUS (type); - unsigned int needed_precision = tree_floor_log2 (modulus) + 1; - unsigned int precision; - bool unsignedp = true; - tree op_type = type; - tree result; - - /* If this is an addition of a constant, convert it to a subtraction - of a constant since we can do that faster. */ - if (op_code == PLUS_EXPR && TREE_CODE (rhs) == INTEGER_CST) - { - rhs = fold_build2 (MINUS_EXPR, type, modulus, rhs); - op_code = MINUS_EXPR; - } - - /* For the logical operations, we only need PRECISION bits. For - addition and subtraction, we need one more and for multiplication we - need twice as many. But we never want to make a size smaller than - our size. */ - if (op_code == PLUS_EXPR || op_code == MINUS_EXPR) - needed_precision += 1; - else if (op_code == MULT_EXPR) - needed_precision *= 2; - - precision = MAX (needed_precision, TYPE_PRECISION (op_type)); - - /* Unsigned will do for everything but subtraction. */ - if (op_code == MINUS_EXPR) - unsignedp = false; - - /* If our type is the wrong signedness or isn't wide enough, make a new - type and convert both our operands to it. */ - if (TYPE_PRECISION (op_type) < precision - || TYPE_UNSIGNED (op_type) != unsignedp) - { - /* Copy the node so we ensure it can be modified to make it modular. */ - op_type = copy_node (gnat_type_for_size (precision, unsignedp)); - modulus = convert (op_type, modulus); - SET_TYPE_MODULUS (op_type, modulus); - TYPE_MODULAR_P (op_type) = 1; - lhs = convert (op_type, lhs); - rhs = convert (op_type, rhs); - } - - /* Do the operation, then we'll fix it up. */ - result = fold_build2 (op_code, op_type, lhs, rhs); - - /* For multiplication, we have no choice but to do a full modulus - operation. However, we want to do this in the narrowest - possible size. */ - if (op_code == MULT_EXPR) - { - tree div_type = copy_node (gnat_type_for_size (needed_precision, 1)); - modulus = convert (div_type, modulus); - SET_TYPE_MODULUS (div_type, modulus); - TYPE_MODULAR_P (div_type) = 1; - result = convert (op_type, - fold_build2 (TRUNC_MOD_EXPR, div_type, - convert (div_type, result), modulus)); - } - - /* For subtraction, add the modulus back if we are negative. */ - else if (op_code == MINUS_EXPR) - { - result = save_expr (result); - result = fold_build3 (COND_EXPR, op_type, - fold_build2 (LT_EXPR, integer_type_node, result, - convert (op_type, integer_zero_node)), - fold_build2 (PLUS_EXPR, op_type, result, modulus), - result); - } - - /* For the other operations, subtract the modulus if we are >= it. */ - else - { - result = save_expr (result); - result = fold_build3 (COND_EXPR, op_type, - fold_build2 (GE_EXPR, integer_type_node, - result, modulus), - fold_build2 (MINUS_EXPR, op_type, - result, modulus), - result); - } - - return convert (type, result); - } - - /* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type - desired for the result. Usually the operation is to be performed - in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0 - in which case the type to be used will be derived from the operands. - - This function is very much unlike the ones for C and C++ since we - have already done any type conversion and matching required. All we - have to do here is validate the work done by SEM and handle subtypes. */ - - tree - build_binary_op (enum tree_code op_code, tree result_type, - tree left_operand, tree right_operand) - { - tree left_type = TREE_TYPE (left_operand); - tree right_type = TREE_TYPE (right_operand); - tree left_base_type = get_base_type (left_type); - tree right_base_type = get_base_type (right_type); - tree operation_type = result_type; - tree best_type = NULL_TREE; - tree modulus; - tree result; - bool has_side_effects = false; - - if (operation_type - && TREE_CODE (operation_type) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (operation_type)) - operation_type = TREE_TYPE (TYPE_FIELDS (operation_type)); - - if (operation_type - && !AGGREGATE_TYPE_P (operation_type) - && TYPE_EXTRA_SUBTYPE_P (operation_type)) - operation_type = get_base_type (operation_type); - - modulus = (operation_type && TREE_CODE (operation_type) == INTEGER_TYPE - && TYPE_MODULAR_P (operation_type) - ? TYPE_MODULUS (operation_type) : 0); - - switch (op_code) - { - case MODIFY_EXPR: - /* If there were any integral or pointer conversions on LHS, remove - them; we'll be putting them back below if needed. Likewise for - conversions between array and record types. But don't do this if - the right operand is not BLKmode (for packed arrays) - unless we are not changing the mode. */ - while ((TREE_CODE (left_operand) == CONVERT_EXPR - || TREE_CODE (left_operand) == NOP_EXPR - || TREE_CODE (left_operand) == VIEW_CONVERT_EXPR) - && (((INTEGRAL_TYPE_P (left_type) - || POINTER_TYPE_P (left_type)) - && (INTEGRAL_TYPE_P (TREE_TYPE - (TREE_OPERAND (left_operand, 0))) - || POINTER_TYPE_P (TREE_TYPE - (TREE_OPERAND (left_operand, 0))))) - || (((TREE_CODE (left_type) == RECORD_TYPE - /* Don't remove conversions to justified modular - types. */ - && !TYPE_JUSTIFIED_MODULAR_P (left_type)) - || TREE_CODE (left_type) == ARRAY_TYPE) - && ((TREE_CODE (TREE_TYPE - (TREE_OPERAND (left_operand, 0))) - == RECORD_TYPE) - || (TREE_CODE (TREE_TYPE - (TREE_OPERAND (left_operand, 0))) - == ARRAY_TYPE)) - && (TYPE_MODE (right_type) == BLKmode - || (TYPE_MODE (left_type) - == TYPE_MODE (TREE_TYPE - (TREE_OPERAND - (left_operand, 0)))))))) - { - left_operand = TREE_OPERAND (left_operand, 0); - left_type = TREE_TYPE (left_operand); - } - - if (!operation_type) - operation_type = left_type; - - /* If we are copying one array or record to another, find the best type - to use. */ - if (((TREE_CODE (left_type) == ARRAY_TYPE - && TREE_CODE (right_type) == ARRAY_TYPE) - || (TREE_CODE (left_type) == RECORD_TYPE - && TREE_CODE (right_type) == RECORD_TYPE)) - && (best_type = find_common_type (left_type, right_type))) - operation_type = best_type; - - /* If a class-wide type may be involved, force use of the RHS type. */ - if ((TREE_CODE (right_type) == RECORD_TYPE - || TREE_CODE (right_type) == UNION_TYPE) - && TYPE_ALIGN_OK (right_type)) - operation_type = right_type; - - /* Ensure everything on the LHS is valid. If we have a field reference, - strip anything that get_inner_reference can handle. Then remove any - conversions with type types having the same code and mode. Mark - VIEW_CONVERT_EXPRs with TREE_ADDRESSABLE. When done, we must have - either an INDIRECT_REF or a decl. */ - result = left_operand; - while (1) - { - tree restype = TREE_TYPE (result); - - if (TREE_CODE (result) == COMPONENT_REF - || TREE_CODE (result) == ARRAY_REF - || TREE_CODE (result) == ARRAY_RANGE_REF) - while (handled_component_p (result)) - result = TREE_OPERAND (result, 0); - else if (TREE_CODE (result) == REALPART_EXPR - || TREE_CODE (result) == IMAGPART_EXPR - || ((TREE_CODE (result) == NOP_EXPR - || TREE_CODE (result) == CONVERT_EXPR) - && (((TREE_CODE (restype) - == TREE_CODE (TREE_TYPE - (TREE_OPERAND (result, 0)))) - && (TYPE_MODE (TREE_TYPE - (TREE_OPERAND (result, 0))) - == TYPE_MODE (restype))) - || TYPE_ALIGN_OK (restype)))) - result = TREE_OPERAND (result, 0); - else if (TREE_CODE (result) == VIEW_CONVERT_EXPR) - { - TREE_ADDRESSABLE (result) = 1; - result = TREE_OPERAND (result, 0); - } - else - break; - } - - gcc_assert (TREE_CODE (result) == INDIRECT_REF - || TREE_CODE (result) == NULL_EXPR || DECL_P (result)); - - /* Convert the right operand to the operation type unless - it is either already of the correct type or if the type - involves a placeholder, since the RHS may not have the same - record type. */ - if (operation_type != right_type - && (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (operation_type)))) - { - right_operand = convert (operation_type, right_operand); - right_type = operation_type; - } - - /* If the left operand is not the same type as the operation type, - surround it in a VIEW_CONVERT_EXPR. */ - if (left_type != operation_type) - left_operand = unchecked_convert (operation_type, left_operand, false); - - has_side_effects = true; - modulus = NULL_TREE; - break; - - case ARRAY_REF: - if (!operation_type) - operation_type = TREE_TYPE (left_type); - - /* ... fall through ... */ - - case ARRAY_RANGE_REF: - /* First look through conversion between type variants. Note that - this changes neither the operation type nor the type domain. */ - if (TREE_CODE (left_operand) == VIEW_CONVERT_EXPR - && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (left_operand, 0))) - == TYPE_MAIN_VARIANT (left_type)) - { - left_operand = TREE_OPERAND (left_operand, 0); - left_type = TREE_TYPE (left_operand); - } - - /* Then convert the right operand to its base type. This will - prevent unneeded signedness conversions when sizetype is wider than - integer. */ - right_operand = convert (right_base_type, right_operand); - right_operand = convert (TYPE_DOMAIN (left_type), right_operand); - - if (!TREE_CONSTANT (right_operand) - || !TREE_CONSTANT (TYPE_MIN_VALUE (right_type))) - gnat_mark_addressable (left_operand); - - modulus = NULL_TREE; - break; - - case GE_EXPR: - case LE_EXPR: - case GT_EXPR: - case LT_EXPR: - gcc_assert (!POINTER_TYPE_P (left_type)); - - /* ... fall through ... */ - - case EQ_EXPR: - case NE_EXPR: - /* If either operand is a NULL_EXPR, just return a new one. */ - if (TREE_CODE (left_operand) == NULL_EXPR) - return build2 (op_code, result_type, - build1 (NULL_EXPR, integer_type_node, - TREE_OPERAND (left_operand, 0)), - integer_zero_node); - - else if (TREE_CODE (right_operand) == NULL_EXPR) - return build2 (op_code, result_type, - build1 (NULL_EXPR, integer_type_node, - TREE_OPERAND (right_operand, 0)), - integer_zero_node); - - /* If either object is a justified modular types, get the - fields from within. */ - if (TREE_CODE (left_type) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (left_type)) - { - left_operand = convert (TREE_TYPE (TYPE_FIELDS (left_type)), - left_operand); - left_type = TREE_TYPE (left_operand); - left_base_type = get_base_type (left_type); - } - - if (TREE_CODE (right_type) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (right_type)) - { - right_operand = convert (TREE_TYPE (TYPE_FIELDS (right_type)), - right_operand); - right_type = TREE_TYPE (right_operand); - right_base_type = get_base_type (right_type); - } - - /* If both objects are arrays, compare them specially. */ - if ((TREE_CODE (left_type) == ARRAY_TYPE - || (TREE_CODE (left_type) == INTEGER_TYPE - && TYPE_HAS_ACTUAL_BOUNDS_P (left_type))) - && (TREE_CODE (right_type) == ARRAY_TYPE - || (TREE_CODE (right_type) == INTEGER_TYPE - && TYPE_HAS_ACTUAL_BOUNDS_P (right_type)))) - { - result = compare_arrays (result_type, left_operand, right_operand); - - if (op_code == NE_EXPR) - result = invert_truthvalue (result); - else - gcc_assert (op_code == EQ_EXPR); - - return result; - } - - /* Otherwise, the base types must be the same unless the objects are - fat pointers or records. If we have records, use the best type and - convert both operands to that type. */ - if (left_base_type != right_base_type) - { - if (TYPE_FAT_POINTER_P (left_base_type) - && TYPE_FAT_POINTER_P (right_base_type) - && TYPE_MAIN_VARIANT (left_base_type) - == TYPE_MAIN_VARIANT (right_base_type)) - best_type = left_base_type; - else if (TREE_CODE (left_base_type) == RECORD_TYPE - && TREE_CODE (right_base_type) == RECORD_TYPE) - { - /* The only way these are permitted to be the same is if both - types have the same name. In that case, one of them must - not be self-referential. Use that one as the best type. - Even better is if one is of fixed size. */ - gcc_assert (TYPE_NAME (left_base_type) - && (TYPE_NAME (left_base_type) - == TYPE_NAME (right_base_type))); - - if (TREE_CONSTANT (TYPE_SIZE (left_base_type))) - best_type = left_base_type; - else if (TREE_CONSTANT (TYPE_SIZE (right_base_type))) - best_type = right_base_type; - else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (left_base_type))) - best_type = left_base_type; - else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (right_base_type))) - best_type = right_base_type; - else - gcc_unreachable (); - } - else - gcc_unreachable (); - - left_operand = convert (best_type, left_operand); - right_operand = convert (best_type, right_operand); - } - - /* If we are comparing a fat pointer against zero, we need to - just compare the data pointer. */ - else if (TYPE_FAT_POINTER_P (left_base_type) - && TREE_CODE (right_operand) == CONSTRUCTOR - && integer_zerop (VEC_index (constructor_elt, - CONSTRUCTOR_ELTS (right_operand), - 0) - ->value)) - { - right_operand = build_component_ref (left_operand, NULL_TREE, - TYPE_FIELDS (left_base_type), - false); - left_operand = convert (TREE_TYPE (right_operand), - integer_zero_node); - } - else - { - left_operand = convert (left_base_type, left_operand); - right_operand = convert (right_base_type, right_operand); - } - - modulus = NULL_TREE; - break; - - case PREINCREMENT_EXPR: - case PREDECREMENT_EXPR: - case POSTINCREMENT_EXPR: - case POSTDECREMENT_EXPR: - /* In these, the result type and the left operand type should be the - same. Do the operation in the base type of those and convert the - right operand (which is an integer) to that type. - - Note that these operations are only used in loop control where - we guarantee that no overflow can occur. So nothing special need - be done for modular types. */ - - gcc_assert (left_type == result_type); - operation_type = get_base_type (result_type); - left_operand = convert (operation_type, left_operand); - right_operand = convert (operation_type, right_operand); - has_side_effects = true; - modulus = NULL_TREE; - break; - - case LSHIFT_EXPR: - case RSHIFT_EXPR: - case LROTATE_EXPR: - case RROTATE_EXPR: - /* The RHS of a shift can be any type. Also, ignore any modulus - (we used to abort, but this is needed for unchecked conversion - to modular types). Otherwise, processing is the same as normal. */ - gcc_assert (operation_type == left_base_type); - modulus = NULL_TREE; - left_operand = convert (operation_type, left_operand); - break; - - case TRUTH_ANDIF_EXPR: - case TRUTH_ORIF_EXPR: - case TRUTH_AND_EXPR: - case TRUTH_OR_EXPR: - case TRUTH_XOR_EXPR: - left_operand = gnat_truthvalue_conversion (left_operand); - right_operand = gnat_truthvalue_conversion (right_operand); - goto common; - - case BIT_AND_EXPR: - case BIT_IOR_EXPR: - case BIT_XOR_EXPR: - /* For binary modulus, if the inputs are in range, so are the - outputs. */ - if (modulus && integer_pow2p (modulus)) - modulus = NULL_TREE; - - goto common; - - case COMPLEX_EXPR: - gcc_assert (TREE_TYPE (result_type) == left_base_type - && TREE_TYPE (result_type) == right_base_type); - left_operand = convert (left_base_type, left_operand); - right_operand = convert (right_base_type, right_operand); - break; - - case TRUNC_DIV_EXPR: case TRUNC_MOD_EXPR: - case CEIL_DIV_EXPR: case CEIL_MOD_EXPR: - case FLOOR_DIV_EXPR: case FLOOR_MOD_EXPR: - case ROUND_DIV_EXPR: case ROUND_MOD_EXPR: - /* These always produce results lower than either operand. */ - modulus = NULL_TREE; - goto common; - - case POINTER_PLUS_EXPR: - gcc_assert (operation_type == left_base_type - && sizetype == right_base_type); - left_operand = convert (operation_type, left_operand); - right_operand = convert (sizetype, right_operand); - break; - - default: - common: - /* The result type should be the same as the base types of the - both operands (and they should be the same). Convert - everything to the result type. */ - - gcc_assert (operation_type == left_base_type - && left_base_type == right_base_type); - left_operand = convert (operation_type, left_operand); - right_operand = convert (operation_type, right_operand); - } - - if (modulus && !integer_pow2p (modulus)) - { - result = nonbinary_modular_operation (op_code, operation_type, - left_operand, right_operand); - modulus = NULL_TREE; - } - /* If either operand is a NULL_EXPR, just return a new one. */ - else if (TREE_CODE (left_operand) == NULL_EXPR) - return build1 (NULL_EXPR, operation_type, TREE_OPERAND (left_operand, 0)); - else if (TREE_CODE (right_operand) == NULL_EXPR) - return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0)); - else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF) - result = build4 (op_code, operation_type, left_operand, - right_operand, NULL_TREE, NULL_TREE); - else - result - = fold_build2 (op_code, operation_type, left_operand, right_operand); - - TREE_SIDE_EFFECTS (result) |= has_side_effects; - TREE_CONSTANT (result) - |= (TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand) - && op_code != ARRAY_REF && op_code != ARRAY_RANGE_REF); - - if ((op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF) - && TYPE_VOLATILE (operation_type)) - TREE_THIS_VOLATILE (result) = 1; - - /* If we are working with modular types, perform the MOD operation - if something above hasn't eliminated the need for it. */ - if (modulus) - result = fold_build2 (FLOOR_MOD_EXPR, operation_type, result, - convert (operation_type, modulus)); - - if (result_type && result_type != operation_type) - result = convert (result_type, result); - - return result; - } - - /* Similar, but for unary operations. */ - - tree - build_unary_op (enum tree_code op_code, tree result_type, tree operand) - { - tree type = TREE_TYPE (operand); - tree base_type = get_base_type (type); - tree operation_type = result_type; - tree result; - bool side_effects = false; - - if (operation_type - && TREE_CODE (operation_type) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (operation_type)) - operation_type = TREE_TYPE (TYPE_FIELDS (operation_type)); - - if (operation_type - && !AGGREGATE_TYPE_P (operation_type) - && TYPE_EXTRA_SUBTYPE_P (operation_type)) - operation_type = get_base_type (operation_type); - - switch (op_code) - { - case REALPART_EXPR: - case IMAGPART_EXPR: - if (!operation_type) - result_type = operation_type = TREE_TYPE (type); - else - gcc_assert (result_type == TREE_TYPE (type)); - - result = fold_build1 (op_code, operation_type, operand); - break; - - case TRUTH_NOT_EXPR: - gcc_assert (result_type == base_type); - result = invert_truthvalue (gnat_truthvalue_conversion (operand)); - break; - - case ATTR_ADDR_EXPR: - case ADDR_EXPR: - switch (TREE_CODE (operand)) - { - case INDIRECT_REF: - case UNCONSTRAINED_ARRAY_REF: - result = TREE_OPERAND (operand, 0); - - /* Make sure the type here is a pointer, not a reference. - GCC wants pointer types for function addresses. */ - if (!result_type) - result_type = build_pointer_type (type); - - /* If the underlying object can alias everything, propagate the - property since we are effectively retrieving the object. */ - if (POINTER_TYPE_P (TREE_TYPE (result)) - && TYPE_REF_CAN_ALIAS_ALL (TREE_TYPE (result))) - { - if (TREE_CODE (result_type) == POINTER_TYPE - && !TYPE_REF_CAN_ALIAS_ALL (result_type)) - result_type - = build_pointer_type_for_mode (TREE_TYPE (result_type), - TYPE_MODE (result_type), - true); - else if (TREE_CODE (result_type) == REFERENCE_TYPE - && !TYPE_REF_CAN_ALIAS_ALL (result_type)) - result_type - = build_reference_type_for_mode (TREE_TYPE (result_type), - TYPE_MODE (result_type), - true); - } - break; - - case NULL_EXPR: - result = operand; - TREE_TYPE (result) = type = build_pointer_type (type); - break; - - case ARRAY_REF: - case ARRAY_RANGE_REF: - case COMPONENT_REF: - case BIT_FIELD_REF: - /* If this is for 'Address, find the address of the prefix and - add the offset to the field. Otherwise, do this the normal - way. */ - if (op_code == ATTR_ADDR_EXPR) - { - HOST_WIDE_INT bitsize; - HOST_WIDE_INT bitpos; - tree offset, inner; - enum machine_mode mode; - int unsignedp, volatilep; - - inner = get_inner_reference (operand, &bitsize, &bitpos, &offset, - &mode, &unsignedp, &volatilep, - false); - - /* If INNER is a padding type whose field has a self-referential - size, convert to that inner type. We know the offset is zero - and we need to have that type visible. */ - if (TREE_CODE (TREE_TYPE (inner)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (inner)) - && (CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS - (TREE_TYPE (inner))))))) - inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))), - inner); - - /* Compute the offset as a byte offset from INNER. */ - if (!offset) - offset = size_zero_node; - - if (bitpos % BITS_PER_UNIT != 0) - post_error - ("taking address of object not aligned on storage unit?", - error_gnat_node); - - offset = size_binop (PLUS_EXPR, offset, - size_int (bitpos / BITS_PER_UNIT)); - - /* Take the address of INNER, convert the offset to void *, and - add then. It will later be converted to the desired result - type, if any. */ - inner = build_unary_op (ADDR_EXPR, NULL_TREE, inner); - inner = convert (ptr_void_type_node, inner); - result = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node, - inner, offset); - result = convert (build_pointer_type (TREE_TYPE (operand)), - result); - break; - } - goto common; - - case CONSTRUCTOR: - /* If this is just a constructor for a padded record, we can - just take the address of the single field and convert it to - a pointer to our type. */ - if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) - { - result = (VEC_index (constructor_elt, - CONSTRUCTOR_ELTS (operand), - 0) - ->value); - - result = convert (build_pointer_type (TREE_TYPE (operand)), - build_unary_op (ADDR_EXPR, NULL_TREE, result)); - break; - } - - goto common; - - case NOP_EXPR: - if (AGGREGATE_TYPE_P (type) - && AGGREGATE_TYPE_P (TREE_TYPE (TREE_OPERAND (operand, 0)))) - return build_unary_op (ADDR_EXPR, result_type, - TREE_OPERAND (operand, 0)); - - /* ... fallthru ... */ - - case VIEW_CONVERT_EXPR: - /* If this just a variant conversion or if the conversion doesn't - change the mode, get the result type from this type and go down. - This is needed for conversions of CONST_DECLs, to eventually get - to the address of their CORRESPONDING_VARs. */ - if ((TYPE_MAIN_VARIANT (type) - == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand, 0)))) - || (TYPE_MODE (type) != BLKmode - && (TYPE_MODE (type) - == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0)))))) - return build_unary_op (ADDR_EXPR, - (result_type ? result_type - : build_pointer_type (type)), - TREE_OPERAND (operand, 0)); - goto common; - - case CONST_DECL: - operand = DECL_CONST_CORRESPONDING_VAR (operand); - - /* ... fall through ... */ - - default: - common: - - /* If we are taking the address of a padded record whose field is - contains a template, take the address of the template. */ - if (TREE_CODE (type) == RECORD_TYPE - && TYPE_IS_PADDING_P (type) - && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type)))) - { - type = TREE_TYPE (TYPE_FIELDS (type)); - operand = convert (type, operand); - } - - if (type != error_mark_node) - operation_type = build_pointer_type (type); - - gnat_mark_addressable (operand); - result = fold_build1 (ADDR_EXPR, operation_type, operand); - } - - TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand); - break; - - case INDIRECT_REF: - /* If we want to refer to an entire unconstrained array, - make up an expression to do so. This will never survive to - the backend. If TYPE is a thin pointer, first convert the - operand to a fat pointer. */ - if (TYPE_THIN_POINTER_P (type) - && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))) - { - operand - = convert (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), - operand); - type = TREE_TYPE (operand); - } - - if (TYPE_FAT_POINTER_P (type)) - { - result = build1 (UNCONSTRAINED_ARRAY_REF, - TYPE_UNCONSTRAINED_ARRAY (type), operand); - TREE_READONLY (result) = TREE_STATIC (result) - = TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type)); - } - else if (TREE_CODE (operand) == ADDR_EXPR) - result = TREE_OPERAND (operand, 0); - - else - { - result = fold_build1 (op_code, TREE_TYPE (type), operand); - TREE_READONLY (result) = TYPE_READONLY (TREE_TYPE (type)); - } - - side_effects - = (!TYPE_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type))); - break; - - case NEGATE_EXPR: - case BIT_NOT_EXPR: - { - tree modulus = ((operation_type - && TREE_CODE (operation_type) == INTEGER_TYPE - && TYPE_MODULAR_P (operation_type)) - ? TYPE_MODULUS (operation_type) : 0); - int mod_pow2 = modulus && integer_pow2p (modulus); - - /* If this is a modular type, there are various possibilities - depending on the operation and whether the modulus is a - power of two or not. */ - - if (modulus) - { - gcc_assert (operation_type == base_type); - operand = convert (operation_type, operand); - - /* The fastest in the negate case for binary modulus is - the straightforward code; the TRUNC_MOD_EXPR below - is an AND operation. */ - if (op_code == NEGATE_EXPR && mod_pow2) - result = fold_build2 (TRUNC_MOD_EXPR, operation_type, - fold_build1 (NEGATE_EXPR, operation_type, - operand), - modulus); - - /* For nonbinary negate case, return zero for zero operand, - else return the modulus minus the operand. If the modulus - is a power of two minus one, we can do the subtraction - as an XOR since it is equivalent and faster on most machines. */ - else if (op_code == NEGATE_EXPR && !mod_pow2) - { - if (integer_pow2p (fold_build2 (PLUS_EXPR, operation_type, - modulus, - convert (operation_type, - integer_one_node)))) - result = fold_build2 (BIT_XOR_EXPR, operation_type, - operand, modulus); - else - result = fold_build2 (MINUS_EXPR, operation_type, - modulus, operand); - - result = fold_build3 (COND_EXPR, operation_type, - fold_build2 (NE_EXPR, - integer_type_node, - operand, - convert - (operation_type, - integer_zero_node)), - result, operand); - } - else - { - /* For the NOT cases, we need a constant equal to - the modulus minus one. For a binary modulus, we - XOR against the constant and subtract the operand from - that constant for nonbinary modulus. */ - - tree cnst = fold_build2 (MINUS_EXPR, operation_type, modulus, - convert (operation_type, - integer_one_node)); - - if (mod_pow2) - result = fold_build2 (BIT_XOR_EXPR, operation_type, - operand, cnst); - else - result = fold_build2 (MINUS_EXPR, operation_type, - cnst, operand); - } - - break; - } - } - - /* ... fall through ... */ - - default: - gcc_assert (operation_type == base_type); - result = fold_build1 (op_code, operation_type, - convert (operation_type, operand)); - } - - if (side_effects) - { - TREE_SIDE_EFFECTS (result) = 1; - if (TREE_CODE (result) == INDIRECT_REF) - TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result)); - } - - if (result_type && TREE_TYPE (result) != result_type) - result = convert (result_type, result); - - return result; - } - - /* Similar, but for COND_EXPR. */ - - tree - build_cond_expr (tree result_type, tree condition_operand, - tree true_operand, tree false_operand) - { - tree result; - bool addr_p = false; - - /* The front-end verifies that result, true and false operands have same base - type. Convert everything to the result type. */ - - true_operand = convert (result_type, true_operand); - false_operand = convert (result_type, false_operand); - - /* If the result type is unconstrained, take the address of - the operands and then dereference our result. */ - if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE - || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type))) - { - addr_p = true; - result_type = build_pointer_type (result_type); - true_operand = build_unary_op (ADDR_EXPR, result_type, true_operand); - false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand); - } - - result = fold_build3 (COND_EXPR, result_type, condition_operand, - true_operand, false_operand); - - /* If either operand is a SAVE_EXPR (possibly surrounded by - arithmetic, make sure it gets done. */ - true_operand = skip_simple_arithmetic (true_operand); - false_operand = skip_simple_arithmetic (false_operand); - - if (TREE_CODE (true_operand) == SAVE_EXPR) - result = build2 (COMPOUND_EXPR, result_type, true_operand, result); - - if (TREE_CODE (false_operand) == SAVE_EXPR) - result = build2 (COMPOUND_EXPR, result_type, false_operand, result); - - /* ??? Seems the code above is wrong, as it may move ahead of the COND - SAVE_EXPRs with side effects and not shared by both arms. */ - - if (addr_p) - result = build_unary_op (INDIRECT_REF, NULL_TREE, result); - - return result; - } - - /* Similar, but for RETURN_EXPR. If RESULT_DECL is non-zero, build - a RETURN_EXPR around the assignment of RET_VAL to RESULT_DECL. - If RESULT_DECL is zero, build a bare RETURN_EXPR. */ - - tree - build_return_expr (tree result_decl, tree ret_val) - { - tree result_expr; - - if (result_decl) - { - /* The gimplifier explicitly enforces the following invariant: - - RETURN_EXPR - | - MODIFY_EXPR - / \ - / \ - RESULT_DECL ... - - As a consequence, type-homogeneity dictates that we use the type - of the RESULT_DECL as the operation type. */ - - tree operation_type = TREE_TYPE (result_decl); - - /* Convert the right operand to the operation type. Note that - it's the same transformation as in the MODIFY_EXPR case of - build_binary_op with the additional guarantee that the type - cannot involve a placeholder, since otherwise the function - would use the "target pointer" return mechanism. */ - - if (operation_type != TREE_TYPE (ret_val)) - ret_val = convert (operation_type, ret_val); - - result_expr - = build2 (MODIFY_EXPR, operation_type, result_decl, ret_val); - } - else - result_expr = NULL_TREE; - - return build1 (RETURN_EXPR, void_type_node, result_expr); - } - - /* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return - the CALL_EXPR. */ - - tree - build_call_1_expr (tree fundecl, tree arg) - { - tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)), - build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), - 1, arg); - TREE_SIDE_EFFECTS (call) = 1; - return call; - } - - /* Build a CALL_EXPR to call FUNDECL with two arguments, ARG1 & ARG2. Return - the CALL_EXPR. */ - - tree - build_call_2_expr (tree fundecl, tree arg1, tree arg2) - { - tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)), - build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), - 2, arg1, arg2); - TREE_SIDE_EFFECTS (call) = 1; - return call; - } - - /* Likewise to call FUNDECL with no arguments. */ - - tree - build_call_0_expr (tree fundecl) - { - /* We rely on build_call_nary to compute TREE_SIDE_EFFECTS. This makes - it possible to propagate DECL_IS_PURE on parameterless functions. */ - tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)), - build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), - 0); - return call; - } - - /* Call a function that raises an exception and pass the line number and file - name, if requested. MSG says which exception function to call. - - GNAT_NODE is the gnat node conveying the source location for which the - error should be signaled, or Empty in which case the error is signaled on - the current ref_file_name/input_line. - - KIND says which kind of exception this is for - (N_Raise_{Constraint,Storage,Program}_Error). */ - - tree - build_call_raise (int msg, Node_Id gnat_node, char kind) - { - tree fndecl = gnat_raise_decls[msg]; - tree label = get_exception_label (kind); - tree filename; - int line_number; - const char *str; - int len; - - /* If this is to be done as a goto, handle that case. */ - if (label) - { - Entity_Id local_raise = Get_Local_Raise_Call_Entity (); - tree gnu_result = build1 (GOTO_EXPR, void_type_node, label); - - /* If Local_Raise is present, generate - Local_Raise (exception'Identity); */ - if (Present (local_raise)) - { - tree gnu_local_raise - = gnat_to_gnu_entity (local_raise, NULL_TREE, 0); - tree gnu_exception_entity - = gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0); - tree gnu_call - = build_call_1_expr (gnu_local_raise, - build_unary_op (ADDR_EXPR, NULL_TREE, - gnu_exception_entity)); - - gnu_result = build2 (COMPOUND_EXPR, void_type_node, - gnu_call, gnu_result);} - - return gnu_result; - } - - str - = (Debug_Flag_NN || Exception_Locations_Suppressed) - ? "" - : (gnat_node != Empty && Sloc (gnat_node) != No_Location) - ? IDENTIFIER_POINTER - (get_identifier (Get_Name_String - (Debug_Source_Name - (Get_Source_File_Index (Sloc (gnat_node)))))) - : ref_filename; - - len = strlen (str) + 1; - filename = build_string (len, str); - line_number - = (gnat_node != Empty && Sloc (gnat_node) != No_Location) - ? Get_Logical_Line_Number (Sloc(gnat_node)) : input_line; - - TREE_TYPE (filename) - = build_array_type (char_type_node, - build_index_type (build_int_cst (NULL_TREE, len))); - - return - build_call_2_expr (fndecl, - build1 (ADDR_EXPR, build_pointer_type (char_type_node), - filename), - build_int_cst (NULL_TREE, line_number)); - } - - /* qsort comparer for the bit positions of two constructor elements - for record components. */ - - static int - compare_elmt_bitpos (const PTR rt1, const PTR rt2) - { - const_tree const elmt1 = * (const_tree const *) rt1; - const_tree const elmt2 = * (const_tree const *) rt2; - const_tree const field1 = TREE_PURPOSE (elmt1); - const_tree const field2 = TREE_PURPOSE (elmt2); - const int ret - = tree_int_cst_compare (bit_position (field1), bit_position (field2)); - - return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2)); - } - - /* Return a CONSTRUCTOR of TYPE whose list is LIST. */ - - tree - gnat_build_constructor (tree type, tree list) - { - tree elmt; - int n_elmts; - bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST); - bool side_effects = false; - tree result; - - /* Scan the elements to see if they are all constant or if any has side - effects, to let us set global flags on the resulting constructor. Count - the elements along the way for possible sorting purposes below. */ - for (n_elmts = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), n_elmts ++) - { - if (!TREE_CONSTANT (TREE_VALUE (elmt)) - || (TREE_CODE (type) == RECORD_TYPE - && DECL_BIT_FIELD (TREE_PURPOSE (elmt)) - && TREE_CODE (TREE_VALUE (elmt)) != INTEGER_CST) - || !initializer_constant_valid_p (TREE_VALUE (elmt), - TREE_TYPE (TREE_VALUE (elmt)))) - allconstant = false; - - if (TREE_SIDE_EFFECTS (TREE_VALUE (elmt))) - side_effects = true; - - /* Propagate an NULL_EXPR from the size of the type. We won't ever - be executing the code we generate here in that case, but handle it - specially to avoid the compiler blowing up. */ - if (TREE_CODE (type) == RECORD_TYPE - && (0 != (result - = contains_null_expr (DECL_SIZE (TREE_PURPOSE (elmt)))))) - return build1 (NULL_EXPR, type, TREE_OPERAND (result, 0)); - } - - /* For record types with constant components only, sort field list - by increasing bit position. This is necessary to ensure the - constructor can be output as static data. */ - if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1) - { - /* Fill an array with an element tree per index, and ask qsort to order - them according to what a bitpos comparison function says. */ - tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts); - int i; - - for (i = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), i++) - gnu_arr[i] = elmt; - - qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos); - - /* Then reconstruct the list from the sorted array contents. */ - list = NULL_TREE; - for (i = n_elmts - 1; i >= 0; i--) - { - TREE_CHAIN (gnu_arr[i]) = list; - list = gnu_arr[i]; - } - } - - result = build_constructor_from_list (type, list); - TREE_CONSTANT (result) = TREE_INVARIANT (result) - = TREE_STATIC (result) = allconstant; - TREE_SIDE_EFFECTS (result) = side_effects; - TREE_READONLY (result) = TYPE_READONLY (type) || allconstant; - return result; - } - - /* Return a COMPONENT_REF to access a field that is given by COMPONENT, - an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL, - for the field. Don't fold the result if NO_FOLD_P is true. - - We also handle the fact that we might have been passed a pointer to the - actual record and know how to look for fields in variant parts. */ - - static tree - build_simple_component_ref (tree record_variable, tree component, - tree field, bool no_fold_p) - { - tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable)); - tree ref, inner_variable; - - gcc_assert ((TREE_CODE (record_type) == RECORD_TYPE - || TREE_CODE (record_type) == UNION_TYPE - || TREE_CODE (record_type) == QUAL_UNION_TYPE) - && TYPE_SIZE (record_type) - && (component != 0) != (field != 0)); - - /* If no field was specified, look for a field with the specified name - in the current record only. */ - if (!field) - for (field = TYPE_FIELDS (record_type); field; - field = TREE_CHAIN (field)) - if (DECL_NAME (field) == component) - break; - - if (!field) - return NULL_TREE; - - /* If this field is not in the specified record, see if we can find - something in the record whose original field is the same as this one. */ - if (DECL_CONTEXT (field) != record_type) - /* Check if there is a field with name COMPONENT in the record. */ - { - tree new_field; - - /* First loop thru normal components. */ - - for (new_field = TYPE_FIELDS (record_type); new_field; - new_field = TREE_CHAIN (new_field)) - if (field == new_field - || DECL_ORIGINAL_FIELD (new_field) == field - || new_field == DECL_ORIGINAL_FIELD (field) - || (DECL_ORIGINAL_FIELD (field) - && (DECL_ORIGINAL_FIELD (field) - == DECL_ORIGINAL_FIELD (new_field)))) - break; - - /* Next, loop thru DECL_INTERNAL_P components if we haven't found - the component in the first search. Doing this search in 2 steps - is required to avoiding hidden homonymous fields in the - _Parent field. */ - - if (!new_field) - for (new_field = TYPE_FIELDS (record_type); new_field; - new_field = TREE_CHAIN (new_field)) - if (DECL_INTERNAL_P (new_field)) - { - tree field_ref - = build_simple_component_ref (record_variable, - NULL_TREE, new_field, no_fold_p); - ref = build_simple_component_ref (field_ref, NULL_TREE, field, - no_fold_p); - - if (ref) - return ref; - } - - field = new_field; - } - - if (!field) - return NULL_TREE; - - /* If the field's offset has overflowed, do not attempt to access it - as doing so may trigger sanity checks deeper in the back-end. - Note that we don't need to warn since this will be done on trying - to declare the object. */ - if (TREE_CODE (DECL_FIELD_OFFSET (field)) == INTEGER_CST - && TREE_OVERFLOW (DECL_FIELD_OFFSET (field))) - return NULL_TREE; - - /* Look through conversion between type variants. Note that this - is transparent as far as the field is concerned. */ - if (TREE_CODE (record_variable) == VIEW_CONVERT_EXPR - && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (record_variable, 0))) - == record_type) - inner_variable = TREE_OPERAND (record_variable, 0); - else - inner_variable = record_variable; - - ref = build3 (COMPONENT_REF, TREE_TYPE (field), inner_variable, field, - NULL_TREE); - - if (TREE_READONLY (record_variable) || TREE_READONLY (field)) - TREE_READONLY (ref) = 1; - if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field) - || TYPE_VOLATILE (record_type)) - TREE_THIS_VOLATILE (ref) = 1; - - if (no_fold_p) - return ref; - - /* The generic folder may punt in this case because the inner array type - can be self-referential, but folding is in fact not problematic. */ - else if (TREE_CODE (record_variable) == CONSTRUCTOR - && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (record_variable))) - { - VEC(constructor_elt,gc) *elts = CONSTRUCTOR_ELTS (record_variable); - unsigned HOST_WIDE_INT idx; - tree index, value; - FOR_EACH_CONSTRUCTOR_ELT (elts, idx, index, value) - if (index == field) - return value; - return ref; - } - - else - return fold (ref); - } - - /* Like build_simple_component_ref, except that we give an error if the - reference could not be found. */ - - tree - build_component_ref (tree record_variable, tree component, - tree field, bool no_fold_p) - { - tree ref = build_simple_component_ref (record_variable, component, field, - no_fold_p); - - if (ref) - return ref; - - /* If FIELD was specified, assume this is an invalid user field so - raise constraint error. Otherwise, we can't find the type to return, so - abort. */ - gcc_assert (field); - return build1 (NULL_EXPR, TREE_TYPE (field), - build_call_raise (CE_Discriminant_Check_Failed, Empty, - N_Raise_Constraint_Error)); - } - - /* Build a GCC tree to call an allocation or deallocation function. - If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise, - generate an allocator. - - GNU_SIZE is the size of the object in bytes and ALIGN is the alignment in - bits. GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the - storage pool to use. If not preset, malloc and free will be used except - if GNAT_PROC is the "fake" value of -1, in which case we allocate the - object dynamically on the stack frame. */ - - tree - build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align, - Entity_Id gnat_proc, Entity_Id gnat_pool, - Node_Id gnat_node) - { - tree gnu_align = size_int (align / BITS_PER_UNIT); - - gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj); - - if (Present (gnat_proc)) - { - /* The storage pools are obviously always tagged types, but the - secondary stack uses the same mechanism and is not tagged */ - if (Is_Tagged_Type (Etype (gnat_pool))) - { - /* The size is the third parameter; the alignment is the - same type. */ - Entity_Id gnat_size_type - = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc)))); - tree gnu_size_type = gnat_to_gnu_type (gnat_size_type); - tree gnu_proc = gnat_to_gnu (gnat_proc); - tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc); - tree gnu_pool = gnat_to_gnu (gnat_pool); - tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool); - tree gnu_call; - - gnu_size = convert (gnu_size_type, gnu_size); - gnu_align = convert (gnu_size_type, gnu_align); - - /* The first arg is always the address of the storage pool; next - comes the address of the object, for a deallocator, then the - size and alignment. */ - if (gnu_obj) - gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)), - gnu_proc_addr, 4, gnu_pool_addr, - gnu_obj, gnu_size, gnu_align); - else - gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)), - gnu_proc_addr, 3, gnu_pool_addr, - gnu_size, gnu_align); - TREE_SIDE_EFFECTS (gnu_call) = 1; - return gnu_call; - } - - /* Secondary stack case. */ - else - { - /* The size is the second parameter */ - Entity_Id gnat_size_type - = Etype (Next_Formal (First_Formal (gnat_proc))); - tree gnu_size_type = gnat_to_gnu_type (gnat_size_type); - tree gnu_proc = gnat_to_gnu (gnat_proc); - tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc); - tree gnu_call; - - gnu_size = convert (gnu_size_type, gnu_size); - - /* The first arg is the address of the object, for a - deallocator, then the size */ - if (gnu_obj) - gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)), - gnu_proc_addr, 2, gnu_obj, gnu_size); - else - gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)), - gnu_proc_addr, 1, gnu_size); - TREE_SIDE_EFFECTS (gnu_call) = 1; - return gnu_call; - } - } - - else if (gnu_obj) - return build_call_1_expr (free_decl, gnu_obj); - - /* ??? For now, disable variable-sized allocators in the stack since - we can't yet gimplify an ALLOCATE_EXPR. */ - else if (gnat_pool == -1 - && TREE_CODE (gnu_size) == INTEGER_CST && !flag_stack_check) - { - /* If the size is a constant, we can put it in the fixed portion of - the stack frame to avoid the need to adjust the stack pointer. */ - if (TREE_CODE (gnu_size) == INTEGER_CST && !flag_stack_check) - { - tree gnu_range - = build_range_type (NULL_TREE, size_one_node, gnu_size); - tree gnu_array_type = build_array_type (char_type_node, gnu_range); - tree gnu_decl - = create_var_decl (get_identifier ("RETVAL"), NULL_TREE, - gnu_array_type, NULL_TREE, false, false, false, - false, NULL, gnat_node); - - return convert (ptr_void_type_node, - build_unary_op (ADDR_EXPR, NULL_TREE, gnu_decl)); - } - else - gcc_unreachable (); - #if 0 - return build2 (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align); - #endif - } - else - { - if (Nkind (gnat_node) != N_Allocator || !Comes_From_Source (gnat_node)) - Check_No_Implicit_Heap_Alloc (gnat_node); - return build_call_1_expr (malloc_decl, gnu_size); - } - } - - /* Build a GCC tree to correspond to allocating an object of TYPE whose - initial value is INIT, if INIT is nonzero. Convert the expression to - RESULT_TYPE, which must be some type of pointer. Return the tree. - GNAT_PROC and GNAT_POOL optionally give the procedure to call and - the storage pool to use. GNAT_NODE is used to provide an error - location for restriction violations messages. If IGNORE_INIT_TYPE is - true, ignore the type of INIT for the purpose of determining the size; - this will cause the maximum size to be allocated if TYPE is of - self-referential size. */ - - tree - build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, - Entity_Id gnat_pool, Node_Id gnat_node, bool ignore_init_type) - { - tree size = TYPE_SIZE_UNIT (type); - tree result; - unsigned int default_allocator_alignment - = get_target_default_allocator_alignment () * BITS_PER_UNIT; - - /* If the initializer, if present, is a NULL_EXPR, just return a new one. */ - if (init && TREE_CODE (init) == NULL_EXPR) - return build1 (NULL_EXPR, result_type, TREE_OPERAND (init, 0)); - - /* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the - sizes of the object and its template. Allocate the whole thing and - fill in the parts that are known. */ - else if (TYPE_FAT_OR_THIN_POINTER_P (result_type)) - { - tree storage_type - = build_unc_object_type_from_ptr (result_type, type, - get_identifier ("ALLOC")); - tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type)); - tree storage_ptr_type = build_pointer_type (storage_type); - tree storage; - tree template_cons = NULL_TREE; - - size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type), - init); - - /* If the size overflows, pass -1 so the allocator will raise - storage error. */ - if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size)) - size = ssize_int (-1); - - storage = build_call_alloc_dealloc (NULL_TREE, size, - TYPE_ALIGN (storage_type), - gnat_proc, gnat_pool, gnat_node); - storage = convert (storage_ptr_type, protect_multiple_eval (storage)); - - if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) - { - type = TREE_TYPE (TYPE_FIELDS (type)); - - if (init) - init = convert (type, init); - } - - /* If there is an initializing expression, make a constructor for - the entire object including the bounds and copy it into the - object. If there is no initializing expression, just set the - bounds. */ - if (init) - { - template_cons = tree_cons (TREE_CHAIN (TYPE_FIELDS (storage_type)), - init, NULL_TREE); - template_cons = tree_cons (TYPE_FIELDS (storage_type), - build_template (template_type, type, - init), - template_cons); - - return convert - (result_type, - build2 (COMPOUND_EXPR, storage_ptr_type, - build_binary_op - (MODIFY_EXPR, storage_type, - build_unary_op (INDIRECT_REF, NULL_TREE, - convert (storage_ptr_type, storage)), - gnat_build_constructor (storage_type, template_cons)), - convert (storage_ptr_type, storage))); - } - else - return build2 - (COMPOUND_EXPR, result_type, - build_binary_op - (MODIFY_EXPR, template_type, - build_component_ref - (build_unary_op (INDIRECT_REF, NULL_TREE, - convert (storage_ptr_type, storage)), - NULL_TREE, TYPE_FIELDS (storage_type), 0), - build_template (template_type, type, NULL_TREE)), - convert (result_type, convert (storage_ptr_type, storage))); - } - - /* If we have an initializing expression, see if its size is simpler - than the size from the type. */ - if (!ignore_init_type && init && TYPE_SIZE_UNIT (TREE_TYPE (init)) - && (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST - || CONTAINS_PLACEHOLDER_P (size))) - size = TYPE_SIZE_UNIT (TREE_TYPE (init)); - - /* If the size is still self-referential, reference the initializing - expression, if it is present. If not, this must have been a - call to allocate a library-level object, in which case we use - the maximum size. */ - if (CONTAINS_PLACEHOLDER_P (size)) - { - if (!ignore_init_type && init) - size = substitute_placeholder_in_expr (size, init); - else - size = max_size (size, true); - } - - /* If the size overflows, pass -1 so the allocator will raise - storage error. */ - if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size)) - size = ssize_int (-1); - - /* If this is in the default storage pool and the type alignment is larger - than what the default allocator supports, make an "aligning" record type - with room to store a pointer before the field, allocate an object of that - type, store the system's allocator return value just in front of the - field and return the field's address. */ - - if (No (gnat_proc) && TYPE_ALIGN (type) > default_allocator_alignment) - { - /* Construct the aligning type with enough room for a pointer ahead - of the field, then allocate. */ - tree record_type - = make_aligning_type (type, TYPE_ALIGN (type), size, - default_allocator_alignment, - POINTER_SIZE / BITS_PER_UNIT); - - tree record, record_addr; - - record_addr - = build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE_UNIT (record_type), - default_allocator_alignment, Empty, Empty, - gnat_node); - - record_addr - = convert (build_pointer_type (record_type), - save_expr (record_addr)); - - record = build_unary_op (INDIRECT_REF, NULL_TREE, record_addr); - - /* Our RESULT (the Ada allocator's value) is the super-aligned address - of the internal record field ... */ - result - = build_unary_op (ADDR_EXPR, NULL_TREE, - build_component_ref - (record, NULL_TREE, TYPE_FIELDS (record_type), 0)); - result = convert (result_type, result); - - /* ... with the system allocator's return value stored just in - front. */ - { - tree ptr_addr - = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node, - convert (ptr_void_type_node, result), - size_int (-POINTER_SIZE/BITS_PER_UNIT)); - - tree ptr_ref - = convert (build_pointer_type (ptr_void_type_node), ptr_addr); - - result - = build2 (COMPOUND_EXPR, TREE_TYPE (result), - build_binary_op (MODIFY_EXPR, NULL_TREE, - build_unary_op (INDIRECT_REF, NULL_TREE, - ptr_ref), - convert (ptr_void_type_node, - record_addr)), - result); - } - } - else - result = convert (result_type, - build_call_alloc_dealloc (NULL_TREE, size, - TYPE_ALIGN (type), - gnat_proc, - gnat_pool, - gnat_node)); - - /* If we have an initial value, put the new address into a SAVE_EXPR, assign - the value, and return the address. Do this with a COMPOUND_EXPR. */ - - if (init) - { - result = save_expr (result); - result - = build2 (COMPOUND_EXPR, TREE_TYPE (result), - build_binary_op - (MODIFY_EXPR, NULL_TREE, - build_unary_op (INDIRECT_REF, - TREE_TYPE (TREE_TYPE (result)), result), - init), - result); - } - - return convert (result_type, result); - } - - /* Fill in a VMS descriptor for EXPR and return a constructor for it. - GNAT_FORMAL is how we find the descriptor record. */ - - tree - fill_vms_descriptor (tree expr, Entity_Id gnat_formal) - { - tree record_type = TREE_TYPE (TREE_TYPE (get_gnu_tree (gnat_formal))); - tree field; - tree const_list = NULL_TREE; - - expr = maybe_unconstrained_array (expr); - gnat_mark_addressable (expr); - - for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field)) - const_list - = tree_cons (field, - convert (TREE_TYPE (field), - SUBSTITUTE_PLACEHOLDER_IN_EXPR - (DECL_INITIAL (field), expr)), - const_list); - - return gnat_build_constructor (record_type, nreverse (const_list)); - } - - /* Indicate that we need to make the address of EXPR_NODE and it therefore - should not be allocated in a register. Returns true if successful. */ - - bool - gnat_mark_addressable (tree expr_node) - { - while (1) - switch (TREE_CODE (expr_node)) - { - case ADDR_EXPR: - case COMPONENT_REF: - case ARRAY_REF: - case ARRAY_RANGE_REF: - case REALPART_EXPR: - case IMAGPART_EXPR: - case VIEW_CONVERT_EXPR: - case CONVERT_EXPR: - case NON_LVALUE_EXPR: - case NOP_EXPR: - expr_node = TREE_OPERAND (expr_node, 0); - break; - - case CONSTRUCTOR: - TREE_ADDRESSABLE (expr_node) = 1; - return true; - - case VAR_DECL: - case PARM_DECL: - case RESULT_DECL: - TREE_ADDRESSABLE (expr_node) = 1; - return true; - - case FUNCTION_DECL: - TREE_ADDRESSABLE (expr_node) = 1; - return true; - - case CONST_DECL: - return (DECL_CONST_CORRESPONDING_VAR (expr_node) - && (gnat_mark_addressable - (DECL_CONST_CORRESPONDING_VAR (expr_node)))); - default: - return true; - } - } --- 0 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/validsw.ads gcc-4.4.0/gcc/ada/validsw.ads *** gcc-4.3.3/gcc/ada/validsw.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/validsw.ads Sun Apr 13 18:03:09 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2008, 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- -- *************** package Validsw is *** 73,86 **** -- Controls the validity checking of IN OUT parameters. If this switch -- is set to True using -gnatVm or a 'm' in the argument of a pragma -- Validity_Checks, then the initial value of all IN OUT parameters ! -- will be checked at the point of call of a procecure. Note that the -- character 'm' here stands for modified (parameters). Validity_Check_In_Params : Boolean := False; -- Controls the validity checking of IN parameters. If this switch is -- set to True using -gnatVm or an 'i' in the argument of a pragma -- Validity_Checks, then the initial value of all IN parameters ! -- will be checked at the point of call of a procecure or function. Validity_Check_Operands : Boolean := False; -- Controls validity checking of operands. If this switch is set to --- 73,86 ---- -- Controls the validity checking of IN OUT parameters. If this switch -- is set to True using -gnatVm or a 'm' in the argument of a pragma -- Validity_Checks, then the initial value of all IN OUT parameters ! -- will be checked at the point of call of a procedure. Note that the -- character 'm' here stands for modified (parameters). Validity_Check_In_Params : Boolean := False; -- Controls the validity checking of IN parameters. If this switch is -- set to True using -gnatVm or an 'i' in the argument of a pragma -- Validity_Checks, then the initial value of all IN parameters ! -- will be checked at the point of call of a procedure or function. Validity_Check_Operands : Boolean := False; -- Controls validity checking of operands. If this switch is set to *************** package Validsw is *** 145,151 **** procedure Set_Validity_Check_Options (Options : String); -- Like the above procedure, except that the call is simply ignored if ! -- there are any error conditions, this is for example appopriate for -- calls where the string is known to be valid, e.g. because it was -- obtained by Save_Validity_Check_Options. --- 145,151 ---- procedure Set_Validity_Check_Options (Options : String); -- Like the above procedure, except that the call is simply ignored if ! -- there are any error conditions, this is for example appropriate for -- calls where the string is known to be valid, e.g. because it was -- obtained by Save_Validity_Check_Options. diff -Nrcpad gcc-4.3.3/gcc/ada/vms_conv.adb gcc-4.4.0/gcc/ada/vms_conv.adb *** gcc-4.3.3/gcc/ada/vms_conv.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/vms_conv.adb Sun Apr 13 18:03:09 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2008, 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- -- *************** package body VMS_Conv is *** 44,50 **** -- kept in a more conveniently accessible form described in this -- section. ! -- Commands, command qualifers and options have a similar common format -- so that searching for matching names can be done in a common manner. type Item_Id is (Id_Command, Id_Switch, Id_Option); --- 44,50 ---- -- kept in a more conveniently accessible form described in this -- section. ! -- Commands, command qualifiers and options have a similar common format -- so that searching for matching names can be done in a common manner. type Item_Id is (Id_Command, Id_Switch, Id_Option); *************** package body VMS_Conv is *** 274,280 **** procedure Place_Unix_Switches (S : VMS_Data.String_Ptr); -- Given a unix switch string, place corresponding switches in Buffer, ! -- updating Ptr appropriatelly. Note that in the case of use of ! the -- result may be to remove a previously placed switch. procedure Preprocess_Command_Data; --- 274,280 ---- procedure Place_Unix_Switches (S : VMS_Data.String_Ptr); -- Given a unix switch string, place corresponding switches in Buffer, ! -- updating Ptr appropriately. Note that in the case of use of ! the -- result may be to remove a previously placed switch. procedure Preprocess_Command_Data; *************** package body VMS_Conv is *** 397,402 **** --- 397,412 ---- Params => new Parameter_Array'(1 => Unlimited_Files), Defext => " "), + Sync => + (Cname => new S'("SYNC"), + Usage => new S'("GNAT SYNC name /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatsync"), + Unixsws => null, + Switches => Sync_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + Elim => (Cname => new S'("ELIM"), Usage => new S'("GNAT ELIM name /qualifiers"), *************** package body VMS_Conv is *** 804,810 **** procedure Output_Version is begin ! Put ("GNAT "); Put_Line (Gnatvsn.Gnat_Version_String); Put_Line ("Copyright 1996-" & Current_Year & --- 814,825 ---- procedure Output_Version is begin ! if AAMP_On_Target then ! Put ("GNAAMP "); ! else ! Put ("GNAT "); ! end if; ! Put_Line (Gnatvsn.Gnat_Version_String); Put_Line ("Copyright 1996-" & Current_Year & *************** package body VMS_Conv is *** 2005,2011 **** -- end of the Argv, otherwise strings like -- "foo/bar" get split at the slash. ! -- The begining and ending of the string -- are flagged with embedded nulls which -- are removed when building the Spawn -- call. Nulls are use because they won't --- 2020,2026 ---- -- end of the Argv, otherwise strings like -- "foo/bar" get split at the slash. ! -- The beginning and ending of the string -- are flagged with embedded nulls which -- are removed when building the Spawn -- call. Nulls are use because they won't diff -Nrcpad gcc-4.3.3/gcc/ada/vms_conv.ads gcc-4.4.0/gcc/ada/vms_conv.ads *** gcc-4.3.3/gcc/ada/vms_conv.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/vms_conv.ads Sun Apr 13 18:03:09 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2008, 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- -- *************** package VMS_Conv is *** 65,71 **** -- GNATCmd. The entries are represented by an array of records. type Parameter_Type is ! -- A parameter is defined as a whitespace bounded string, not begining -- with a slash. (But see note under FILES_OR_WILDCARD). (File, -- A required file or directory parameter --- 65,71 ---- -- GNATCmd. The entries are represented by an array of records. type Parameter_Type is ! -- A parameter is defined as a whitespace bounded string, not beginning -- with a slash. (But see note under FILES_OR_WILDCARD). (File, -- A required file or directory parameter *************** package VMS_Conv is *** 81,87 **** -- parameters including wildcard specifications. Unlimited_As_Is, ! -- Un unlimited number of whitespace separated paameters that are -- passed through as is (not canonicalized). Files_Or_Wildcard); --- 81,87 ---- -- parameters including wildcard specifications. Unlimited_As_Is, ! -- An unlimited number of whitespace separated parameters that are -- passed through as is (not canonicalized). Files_Or_Wildcard); *************** package VMS_Conv is *** 98,103 **** --- 98,104 ---- Clean, Compile, Check, + Sync, Elim, Find, Krunch, diff -Nrcpad gcc-4.3.3/gcc/ada/vms_data.ads gcc-4.4.0/gcc/ada/vms_data.ads *** gcc-4.3.3/gcc/ada/vms_data.ads Thu Dec 13 10:42:14 2007 --- gcc-4.4.0/gcc/ada/vms_data.ads Sun Sep 14 06:21:12 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2008, 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- -- *************** *** 40,46 **** -- NOTE: the format of this package must follow the following rules, so that -- the VMS GNAT help tool works properly: ! -- - Each command zone (where the eventual qualifiers are declared must -- begin with a boxed comment of the form: -- --------------------------------- --- 40,46 ---- -- NOTE: the format of this package must follow the following rules, so that -- the VMS GNAT help tool works properly: ! -- - Each command zone (where the eventual qualifiers are declared) must -- begin with a boxed comment of the form: -- --------------------------------- *************** *** 56,62 **** -- - a contiguous sequence of comments that constitute the -- documentation of the qualifier. ! -- - each command zone ends with the declaration of the contant array -- for the command, of the form: -- __Switches : aliased constant Switches := --- 56,62 ---- -- - a contiguous sequence of comments that constitute the -- documentation of the qualifier. ! -- - each command zone ends with the declaration of the constant array -- for the command, of the form: -- __Switches : aliased constant Switches := *************** package VMS_Data is *** 67,73 **** -- QUALIFIERS -- ---------------- ! -- The syntax of a qualifier delaration is as follows: -- SWITCH_STRING ::= "/ command-qualifier-name TRANSLATION" --- 67,73 ---- -- QUALIFIERS -- ---------------- ! -- The syntax of a qualifier declaration is as follows: -- SWITCH_STRING ::= "/ command-qualifier-name TRANSLATION" *************** package VMS_Data is *** 109,115 **** -- The unix-switch-string always starts with a minus, and has no commas -- or spaces in it. Case is significant in the unix switch string. If a -- unix switch string is preceded by the not sign (!) it means that the ! -- effect of the corresponding command qualifer is to remove any previous -- occurrence of the given switch in the command line. -- The DIRECTORIES_TRANSLATION format is used where a list of directories --- 109,115 ---- -- The unix-switch-string always starts with a minus, and has no commas -- or spaces in it. Case is significant in the unix switch string. If a -- unix switch string is preceded by the not sign (!) it means that the ! -- effect of the corresponding command qualifier is to remove any previous -- occurrence of the given switch in the command line. -- The DIRECTORIES_TRANSLATION format is used where a list of directories *************** package VMS_Data is *** 149,155 **** -- The COMMANDS_TRANSLATION case is only used for gnatmake, to correspond -- to the use of -cargs, -bargs and -largs (the ARGS string as indicated -- is one of these three possibilities). The name given by COMMAND is the ! -- corresponding command name to be used to interprete the switches to be -- passed on. Switches of this type set modes, e.g. /COMPILER_QUALIFIERS -- sets the mode so that all subsequent switches, up to another switch -- with COMMANDS_TRANSLATION apply to the corresponding commands issued --- 149,155 ---- -- The COMMANDS_TRANSLATION case is only used for gnatmake, to correspond -- to the use of -cargs, -bargs and -largs (the ARGS string as indicated -- is one of these three possibilities). The name given by COMMAND is the ! -- corresponding command name to be used to interpret the switches to be -- passed on. Switches of this type set modes, e.g. /COMPILER_QUALIFIERS -- sets the mode so that all subsequent switches, up to another switch -- with COMMANDS_TRANSLATION apply to the corresponding commands issued *************** package VMS_Data is *** 162,168 **** -- since all subsequent switches apply to an issued command. -- For the DIRECT_TRANSLATION case, an implicit additional qualifier ! -- declaration is created by prepending NO to the name of the qualifer, -- and then inverting the sense of the UNIX_SWITCHES string. For example, -- given the qualifier definition: --- 162,168 ---- -- since all subsequent switches apply to an issued command. -- For the DIRECT_TRANSLATION case, an implicit additional qualifier ! -- declaration is created by prepending NO to the name of the qualifier, -- and then inverting the sense of the UNIX_SWITCHES string. For example, -- given the qualifier definition: *************** package VMS_Data is *** 182,188 **** -- String pointer type used throughout type Switches is array (Natural range <>) of String_Ptr; ! -- Type used for array of swtiches type Switches_Ptr is access constant Switches; --- 182,188 ---- -- String pointer type used throughout type Switches is array (Natural range <>) of String_Ptr; ! -- Type used for array of switches type Switches_Ptr is access constant Switches; *************** package VMS_Data is *** 190,198 **** -- Switches for GNAT BIND -- ---------------------------- ! S_Bind_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. --- 190,198 ---- -- Switches for GNAT BIND -- ---------------------------- ! S_Bind_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. *************** package VMS_Data is *** 275,280 **** --- 275,287 ---- -- Example: -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + S_Bind_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_Bind_Force : aliased constant S := "/FORCE_ELAB_FLAGS " & "-F"; -- /NOFORCE_ELAB_FLAGS (D) *************** package VMS_Data is *** 506,512 **** -- /NORESTRICTION_LIST (D) -- /RESTRICTION_LIST -- ! -- Generate list of pragma Rerstrictions that could be applied to the -- current unit. This is useful for code audit purposes, and also may be -- used to improve code generation in some cases. --- 513,519 ---- -- /NORESTRICTION_LIST (D) -- /RESTRICTION_LIST -- ! -- Generate list of pragma Restrictions that could be applied to the -- current unit. This is useful for code audit purposes, and also may be -- used to improve code generation in some cases. *************** package VMS_Data is *** 519,525 **** -- /RETURN_CODES=VMS -- -- Specifies the style of default exit code returned. Must be used in ! -- conjunction with and match the Link qualifer with same name. -- -- POSIX (D) Return Posix success (0) by default. -- --- 526,532 ---- -- /RETURN_CODES=VMS -- -- Specifies the style of default exit code returned. Must be used in ! -- conjunction with and match the Link qualifier with same name. -- -- POSIX (D) Return Posix success (0) by default. -- *************** package VMS_Data is *** 579,584 **** --- 586,599 ---- -- This qualifier has no impact, except when using the setjmp/longjmp -- exception mechanism, with the GNAT COMPILE qualifier /LONGJMP_SETJMP. + S_Bind_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + S_Bind_Time : aliased constant S := "/TIME_STAMP_CHECK " & "!-t"; -- /TIME_STAMP_CHECK (D) *************** package VMS_Data is *** 662,667 **** --- 677,683 ---- S_Bind_Elab 'Access, S_Bind_Error 'Access, S_Bind_Ext 'Access, + S_Bind_Follow 'Access, S_Bind_Force 'Access, S_Bind_Help 'Access, S_Bind_Init 'Access, *************** package VMS_Data is *** 693,698 **** --- 709,715 ---- S_Bind_Source 'Access, S_Bind_Static 'Access, S_Bind_Store 'Access, + S_Bind_Subdirs 'Access, S_Bind_Time 'Access, S_Bind_Verbose 'Access, S_Bind_Warn 'Access, *************** package VMS_Data is *** 706,716 **** S_Check_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. ! S_Check_All : aliased constant S := "/ALL " & "-a"; -- /NOALL (D) -- /ALL --- 723,733 ---- S_Check_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. ! S_Check_All : aliased constant S := "/ALL " & "-a"; -- /NOALL (D) -- /ALL *************** package VMS_Data is *** 719,725 **** -- components of the GNAT RTL when building and analyzing the global -- structure for checking the global rules. ! S_Check_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & "-X" & '"'; -- /EXTERNAL_REFERENCE="name=val" -- --- 736,742 ---- -- components of the GNAT RTL when building and analyzing the global -- structure for checking the global rules. ! S_Check_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & "-X" & '"'; -- /EXTERNAL_REFERENCE="name=val" -- *************** package VMS_Data is *** 729,761 **** -- Example: -- /EXTERNAL_REFERENCE="DEBUG=TRUE" ! S_Check_Files : aliased constant S := "/FILES=@" & "-files=@"; -- /FILES=filename -- -- Take as arguments the files that are listed in the specified -- text file. ! S_Check_Help : aliased constant S := "/HELP " & "-h"; -- /NOHELP (D) -- /HELP -- -- Print information about currently implemented checks. ! S_Check_Locs : aliased constant S := "/LOCS " & "-l"; -- /NOLOCS (D) -- /LOCS -- ! -- Use full source locations referebces in the report file. ! S_Check_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & ! "DEFAULT " & ! "-vP0 " & ! "MEDIUM " & ! "-vP1 " & ! "HIGH " & "-vP2"; -- /MESSAGES_PROJECT_FILE[=messages-option] -- --- 746,796 ---- -- Example: -- /EXTERNAL_REFERENCE="DEBUG=TRUE" ! S_Check_Files : aliased constant S := "/FILES=@" & "-files=@"; -- /FILES=filename -- -- Take as arguments the files that are listed in the specified -- text file. ! S_Check_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & ! "-eL"; ! -- /NOFOLLOW_LINKS_FOR_FILES (D) ! -- /FOLLOW_LINKS_FOR_FILES ! -- ! -- Follow links when parsing project files ! ! S_Check_Help : aliased constant S := "/HELP " & "-h"; -- /NOHELP (D) -- /HELP -- -- Print information about currently implemented checks. ! S_Check_Locs : aliased constant S := "/LOCS " & "-l"; -- /NOLOCS (D) -- /LOCS -- ! -- Use full source locations references in the report file. ! S_Diagnosis : aliased constant S := "/DIAGNOSIS_LIMIT=#" & ! "-m#"; ! -- /DIAGNOSIS_LIMIT=500 (D) ! -- /ERROR_LIMIT=nnn ! -- ! -- NNN is a decimal integer in the range of 1 to 1000 and limits the ! -- number of diagnostic messages to be generated into Stdout to that ! -- number. Once that number has been reached, gnatcheck stops ! -- to print out diagnoses into Stderr. If NNN is equal to 0, this means ! -- that there is no limit on the number of diagnoses in Stdout ! ! S_Check_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & ! "DEFAULT " & ! "-vP0 " & ! "MEDIUM " & ! "-vP1 " & ! "HIGH " & "-vP2"; -- /MESSAGES_PROJECT_FILE[=messages-option] -- *************** package VMS_Data is *** 769,775 **** -- HIGH A great number of messages are output, most of them not -- being useful for the user. ! S_Check_Project : aliased constant S := "/PROJECT_FILE=<" & "-P>"; -- /PROJECT_FILE=filename -- --- 804,810 ---- -- HIGH A great number of messages are output, most of them not -- being useful for the user. ! S_Check_Project : aliased constant S := "/PROJECT_FILE=<" & "-P>"; -- /PROJECT_FILE=filename -- *************** package VMS_Data is *** 778,829 **** -- gnatcheck. The source directories to be searched will be communicated -- to gnatcheck through logical name ADA_PRJ_INCLUDE_FILE. ! S_Check_Quiet : aliased constant S := "/QUIET " & "-q"; -- /NOQUIET (D) -- /QUIET -- -- Work quietly, only output warnings and errors. ! S_Check_Sections : aliased constant S := "/SECTIONS=" & ! "DEFAULT " & ! "-s123 " & ! "COMPILER_STYLE " & ! "-s1 " & ! "BY_RULES " & ! "-s2 " & ! "BY_FILES_BY_RULES " & "-s3"; -- /SECTIONS[=section-option, section-option, ...] -- -- Specify what sections should be included into the report file. ! -- By default, all three section (diagnises in the format correcponding -- to compiler error and warning messages, diagnoses grouped by rules and -- then - by files, diagnoses grouped by files and then - by rules) are -- included in the report file. -- -- section-option may be one of the following: -- ! -- COMPILER_STYLE Include diagnoses in compile-style format ! -- (diagoses are grouped by files, for each file -- they are ordered according to the references -- into the source) ! -- BY_RULES Include diagnoses grouped first by rules and -- then by files ! -- BY_FILES_BY_RULES Include diagnoses grouped first by files and -- then by rules -- -- If one of these options is specified, then the report file contains -- only sections set by these options ! S_Check_Short : aliased constant S := "/SHORT " & "-s"; -- /NOSHORT (D) -- /SHORT -- -- Generate a short form of the report file. ! S_Check_Verb : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) -- /VERBOSE --- 813,872 ---- -- gnatcheck. The source directories to be searched will be communicated -- to gnatcheck through logical name ADA_PRJ_INCLUDE_FILE. ! S_Check_Quiet : aliased constant S := "/QUIET " & "-q"; -- /NOQUIET (D) -- /QUIET -- -- Work quietly, only output warnings and errors. ! S_Check_Sections : aliased constant S := "/SECTIONS=" & ! "DEFAULT " & ! "-s123 " & ! "COMPILER_STYLE " & ! "-s1 " & ! "BY_RULES " & ! "-s2 " & ! "BY_FILES_BY_RULES " & "-s3"; -- /SECTIONS[=section-option, section-option, ...] -- -- Specify what sections should be included into the report file. ! -- By default, all three section (diagnoses in the format corresponding -- to compiler error and warning messages, diagnoses grouped by rules and -- then - by files, diagnoses grouped by files and then - by rules) are -- included in the report file. -- -- section-option may be one of the following: -- ! -- COMPILER_STYLE Include diagnostics in compile-style format ! -- (diagnoses are grouped by files, for each file -- they are ordered according to the references -- into the source) ! -- BY_RULES Include diagnostics grouped first by rules and -- then by files ! -- BY_FILES_BY_RULES Include diagnostics grouped first by files and -- then by rules -- -- If one of these options is specified, then the report file contains -- only sections set by these options ! S_Check_Short : aliased constant S := "/SHORT " & "-s"; -- /NOSHORT (D) -- /SHORT -- -- Generate a short form of the report file. ! S_Check_Subdirs : aliased constant S := "/SUBDIRS=<" & ! "--subdirs=>"; ! -- /SUBDIRS=dir ! -- ! -- The actual directories (object, exec, library, ...) are subdirectories ! -- of the directory specified in the project file. If the subdirectory ! -- does not exist, it is created automatically. ! ! S_Check_Verb : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) -- /VERBOSE *************** package VMS_Data is *** 835,842 **** --- 878,887 ---- Check_Switches : aliased constant Switches := (S_Check_Add 'Access, S_Check_All 'Access, + S_Diagnosis 'Access, S_Check_Ext 'Access, S_Check_Files 'Access, + S_Check_Follow 'Access, S_Check_Help 'Access, S_Check_Locs 'Access, S_Check_Mess 'Access, *************** package VMS_Data is *** 844,849 **** --- 889,895 ---- S_Check_Quiet 'Access, S_Check_Sections 'Access, S_Check_Short 'Access, + S_Check_Subdirs 'Access, S_Check_Verb 'Access); ---------------------------- *************** package VMS_Data is *** 890,896 **** -- -- Causes the file modification time stamp of the input file to be -- preserved and used for the time stamp of the output file(s). This may ! -- be useful for preserving coherency of time stamps in an enviroment -- where gnatchop is used as part of a standard build process. S_Chop_Quiet : aliased constant S := "/QUIET " & --- 936,942 ---- -- -- Causes the file modification time stamp of the input file to be -- preserved and used for the time stamp of the output file(s). This may ! -- be useful for preserving coherency of time stamps in an environment -- where gnatchop is used as part of a standard build process. S_Chop_Quiet : aliased constant S := "/QUIET " & *************** package VMS_Data is *** 944,950 **** S_Clean_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. --- 990,996 ---- S_Clean_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. *************** package VMS_Data is *** 998,1003 **** --- 1044,1056 ---- -- Example: -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + S_Clean_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_Clean_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " & "-F"; -- /NOFULL_PATH_IN_BRIEF_MESSAGES (D) *************** package VMS_Data is *** 1064,1070 **** -- /NOQUIET (D) -- /QUIET -- ! -- Quiet output. If there are no error, do not ouuput anything, except in -- verbose mode (qualifier /VERBOSE) or in informative-only mode -- (qualifier /NODELETE). --- 1117,1123 ---- -- /NOQUIET (D) -- /QUIET -- ! -- Quiet output. If there are no error, do not output anything, except in -- verbose mode (qualifier /VERBOSE) or in informative-only mode -- (qualifier /NODELETE). *************** package VMS_Data is *** 1084,1089 **** --- 1137,1150 ---- -- -- Equivalent to /OBJECT_SEARCH=(directory,...). + S_Clean_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + S_Clean_Verbose : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) *************** package VMS_Data is *** 1098,1103 **** --- 1159,1165 ---- S_Clean_Delete 'Access, S_Clean_Dirobj 'Access, S_Clean_Ext 'Access, + S_Clean_Follow 'Access, S_Clean_Full 'Access, S_Clean_Help 'Access, S_Clean_Index 'Access, *************** package VMS_Data is *** 1107,1112 **** --- 1169,1175 ---- S_Clean_Quiet 'Access, S_Clean_Recurs 'Access, S_Clean_Search 'Access, + S_Clean_Subdirs'Access, S_Clean_Verbose'Access); ------------------------------- *************** package VMS_Data is *** 1143,1149 **** -- Allows GNAT to recognize the full range of Ada 95 constructs. -- This is the normal default for GNAT Pro. ! S_GCC_Ada_05 : aliased constant S := "/05 " & "-gnat05"; -- /05 (D) -- --- 1206,1212 ---- -- Allows GNAT to recognize the full range of Ada 95 constructs. -- This is the normal default for GNAT Pro. ! S_GCC_Ada_05 : aliased constant S := "/05 " & "-gnat05"; -- /05 (D) -- *************** package VMS_Data is *** 1152,1158 **** S_GCC_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. --- 1215,1221 ---- S_GCC_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. *************** package VMS_Data is *** 1220,1226 **** -- -- ASSERTIONS The pragmas "Assert" and "Debug" normally have no -- effect and are ignored. This keyword causes "Assert" ! -- and "Debug" pragmas to be activated. -- -- SUPPRESS_ALL Suppress all runtime checks as though you have "pragma -- Suppress (all_checks)" in your source. Use this switch --- 1283,1290 ---- -- -- ASSERTIONS The pragmas "Assert" and "Debug" normally have no -- effect and are ignored. This keyword causes "Assert" ! -- and "Debug" pragmas to be activated, as well as ! -- "Check", "Precondition" and "Postcondition" pragmas. -- -- SUPPRESS_ALL Suppress all runtime checks as though you have "pragma -- Suppress (all_checks)" in your source. Use this switch *************** package VMS_Data is *** 1268,1274 **** -- -- Look for source files in the default directory. ! S_GCC_Data : aliased constant S := "/DATA_PREPROCESSING=<" & "-gnatep>"; -- /DATA_PREPROCESSING=file_name -- --- 1332,1338 ---- -- -- Look for source files in the default directory. ! S_GCC_Data : aliased constant S := "/DATA_PREPROCESSING=<" & "-gnatep>"; -- /DATA_PREPROCESSING=file_name -- *************** package VMS_Data is *** 1444,1449 **** --- 1508,1520 ---- -- including the ADS or ADB filetype. The default is not to enable file -- name krunching. + S_GCC_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_GCC_Force : aliased constant S := "/FORCE_ALI " & "-gnatQ"; -- /NOFORCE_ALI (D) *************** package VMS_Data is *** 1454,1460 **** -- forces generation of the .ALI file. This file is marked as being -- in error, so it cannot be used for binding purposes, but it does -- contain reasonably complete cross-reference information, and thus may ! -- be useful for use by tools (e.g. semantic browing tools or integrated -- development environments) that are driven from the .ALI file. S_GCC_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " & --- 1525,1531 ---- -- forces generation of the .ALI file. This file is marked as being -- in error, so it cannot be used for binding purposes, but it does -- contain reasonably complete cross-reference information, and thus may ! -- be useful for use by tools (e.g. semantic browsing tools or integrated -- development environments) that are driven from the .ALI file. S_GCC_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " & *************** package VMS_Data is *** 1467,1472 **** --- 1538,1551 ---- -- /VERBOSE), then error lines start with the full path name of the -- project file, rather than its simple file name. + S_GCC_Generate : aliased constant S := "/GENERATE_PROCESSED_SOURCE " & + "-gnateG"; + -- /NOGENERATE_PROCESSED_SOURCE (D) + -- /GENERATE_PROCESSED_SOURCE + -- + -- Generate a file _prep if the integrated preprocessing + -- is modifying the source text. + S_GCC_GNAT : aliased constant S := "/GNAT_INTERNAL " & "-gnatg"; -- /NOGNAT_INTERNAL (D) *************** package VMS_Data is *** 1652,1658 **** -- lines from the original source file, output as comment lines with the -- associated line number. ! S_GCC_Just : aliased constant S := "/JUSTIFY_MESSAGES=#" & "-gnatj#"; -- /NO_JUSTIFY_MESSAGES (D) --- 1731,1737 ---- -- lines from the original source file, output as comment lines with the -- associated line number. ! S_GCC_Just : aliased constant S := "/JUSTIFY_MESSAGES=#" & "-gnatj#"; -- /NO_JUSTIFY_MESSAGES (D) *************** package VMS_Data is *** 1665,1671 **** -- behavior (each message counted separately and not reformatted to fit -- a particular line length) can be obtained using /NO_JUSTIFY_MESSAGES. ! S_GCC_JustX : aliased constant S := "/NO_JUSTIFY_MESSAGES " & "-gnatj0"; -- NODOC (see /JUSTIFY_MESSAGES) --- 1744,1750 ---- -- behavior (each message counted separately and not reformatted to fit -- a particular line length) can be obtained using /NO_JUSTIFY_MESSAGES. ! S_GCC_JustX : aliased constant S := "/NO_JUSTIFY_MESSAGES " & "-gnatj0"; -- NODOC (see /JUSTIFY_MESSAGES) *************** package VMS_Data is *** 1686,1692 **** -- a body is compiled, the corresponding spec is also listed, along -- with any subunits. ! S_GCC_Mapping : aliased constant S := "/MAPPING_FILE=<" & "-gnatem>"; -- /MAPPING_FILE=file_name -- --- 1765,1780 ---- -- a body is compiled, the corresponding spec is also listed, along -- with any subunits. ! S_GCC_Machine : aliased constant S := "/MACHINE_CODE_LISTING " & ! "-source-listing"; ! -- /NOMACHINE_CODE_LISTING (D) ! -- /MACHINE_CODE_LISTING ! -- ! -- Cause a full machine code listing of the file to be generated to ! -- .lis. Interspersed source is included if the /DEBUG ! -- qualifier is also present. ! ! S_GCC_Mapping : aliased constant S := "/MAPPING_FILE=<" & "-gnatem>"; -- /MAPPING_FILE=file_name -- *************** package VMS_Data is *** 1749,1755 **** -- HIGH A great number of messages are output, most of them not -- being useful for the user. ! S_GCC_Nesting : aliased constant S := "/MAX_NESTING=#" & "-gnatyL#"; -- /MAX_NESTING=nnn -- --- 1837,1843 ---- -- HIGH A great number of messages are output, most of them not -- being useful for the user. ! S_GCC_Nesting : aliased constant S := "/MAX_NESTING=#" & "-gnatyL#"; -- /MAX_NESTING=nnn -- *************** package VMS_Data is *** 1796,1802 **** -- -- Do not look in the default directory for source files of the runtime. ! S_GCC_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & "-nostdlib"; -- /NOSTD_LIBRARIES -- --- 1884,1890 ---- -- -- Do not look in the default directory for source files of the runtime. ! S_GCC_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & "-nostdlib"; -- /NOSTD_LIBRARIES -- *************** package VMS_Data is *** 1873,1878 **** --- 1961,1996 ---- -- file xyz.adb is compiled with -gnatl=.lst, then the output is written -- to file xyz.adb_lst. + S_GCC_Pointer : aliased constant S := "/POINTER_SIZE=" & + "64 " & + "-mmalloc64 " & + "LONG " & + "-mmalloc64 " & + "32 " & + "-mno-malloc64 " & + "SHORT " & + "-mno-malloc64"; + -- /POINTER_SIZE=64 (D) + -- /POINTER_SIZE[=(keyword[,...])] + -- + -- Change how pointers and descriptors are allocated. The following + -- keywords are supported: + -- + -- 64 (D) Allocate heap pointers in 64bit space except as + -- constrained by a 32bit size clause or by + -- Convention_C and generate 64bit descriptors for + -- Descriptor mechanisms for calling imported + -- subprograms and accept both 64bit and 32bit + -- descriptors for calls to exported subprograms. + -- + -- LONG Equivalent to option 64. + -- + -- 32 Allocate all heap pointers in 32bit space and + -- generate 32bit descriptors for Descriptor + -- mechanisms for calling imported subprograms. + -- + -- SHORT Equivalent to option 32. + S_GCC_Polling : aliased constant S := "/POLLING " & "-gnatP"; -- /NOPOLLING (D) *************** package VMS_Data is *** 1902,1907 **** --- 2020,2035 ---- -- readable to any Ada programmer, and is useful to determine the -- characteristics of target dependent types in package Standard. + S_GCC_Reswarn : aliased constant S := "/TREAT_RESTRICTIONS_AS_WARNINGS " & + "-gnatr"; + + -- /NO_TREAT_RESTRICTIONS_AS_WARNINGS (D) + -- /TREAT_RESTRICTIONS_AS_WARNINGS + -- + -- Causes all restrictions to be treated as warnings (pragma Restriction + -- treated as Restriction_Warnings, pragma Profile as Profile_Warnings, + -- and pragma Ravenscar sets restriction warnings instead of restrictions) + S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" & "VERBOSE " & "-gnatv " & *************** package VMS_Data is *** 2020,2026 **** S_GCC_Style : aliased constant S := "/STYLE_CHECKS=" & "ALL_BUILTIN " & ! "-gnaty " & "1 " & "-gnaty1 " & "2 " & --- 2148,2156 ---- S_GCC_Style : aliased constant S := "/STYLE_CHECKS=" & "ALL_BUILTIN " & ! "-gnatyy " & ! "0 " & ! "-gnaty0 " & "1 " & "-gnaty1 " & "2 " & *************** package VMS_Data is *** 2041,2092 **** "-gnaty9 " & "ATTRIBUTE " & "-gnatya " & "ARRAY_INDEXES " & "-gnatyA " & "BLANKS " & "-gnatyb " & "COMMENTS " & "-gnatyc " & "DOS_LINE_ENDINGS " & "-gnatyd " & "END " & "-gnatye " & "VTABS " & "-gnatyf " & "GNAT " & "-gnatyg " & "HTABS " & "-gnatyh " & "IF_THEN " & "-gnatyi " & "KEYWORD " & "-gnatyk " & "LAYOUT " & "-gnatyl " & "LINE_LENGTH " & "-gnatym " & "MODE_IN " & "-gnatyI " & "NONE " & "-gnatyN " & "STANDARD_CASING " & "-gnatyn " & "ORDERED_SUBPROGRAMS " & "-gnatyo " & "PRAGMA " & "-gnatyp " & "REFERENCES " & "-gnatyr " & "SPECS " & "-gnatys " & "STATEMENTS_AFTER_THEN_ELSE " & "-gnatyS " & "TOKEN " & "-gnatyt " & "UNNECESSARY_BLANK_LINES " & "-gnatyu " & "XTRA_PARENS " & ! "-gnatyx "; -- /NOSTYLE_CHECKS (D) -- /STYLE_CHECKS[=(keyword,[...])] -- --- 2171,2266 ---- "-gnaty9 " & "ATTRIBUTE " & "-gnatya " & + "NOATTRIBUTE " & + "-gnaty-a " & "ARRAY_INDEXES " & "-gnatyA " & + "NOARRAY_INDEXES " & + "-gnaty-A " & "BLANKS " & "-gnatyb " & + "NOBLANKS " & + "-gnaty-b " & "COMMENTS " & "-gnatyc " & + "NOCOMMENTS " & + "-gnaty-c " & "DOS_LINE_ENDINGS " & "-gnatyd " & + "NODOS_LINE_ENDINGS " & + "-gnaty-d " & "END " & "-gnatye " & + "NOEND " & + "-gnaty-e " & "VTABS " & "-gnatyf " & + "NOVTABS " & + "-gnaty-f " & "GNAT " & "-gnatyg " & "HTABS " & "-gnatyh " & + "NOHTABS " & + "-gnaty-h " & "IF_THEN " & "-gnatyi " & + "NOIF_THEN " & + "-gnaty-i " & "KEYWORD " & "-gnatyk " & + "NOKEYWORD " & + "-gnaty-k " & "LAYOUT " & "-gnatyl " & + "NOLAYOUT " & + "-gnaty-l " & "LINE_LENGTH " & "-gnatym " & + "NOLINE_LENGTH " & + "-gnaty-m " & "MODE_IN " & "-gnatyI " & + "NOMODE_IN " & + "-gnaty-I " & "NONE " & "-gnatyN " & "STANDARD_CASING " & "-gnatyn " & + "NOSTANDARD_CASING " & + "-gnaty-n " & "ORDERED_SUBPROGRAMS " & "-gnatyo " & + "NOORDERED_SUBPROGRAMS " & + "-gnaty-o " & "PRAGMA " & "-gnatyp " & + "NOPRAGMA " & + "-gnaty-p " & "REFERENCES " & "-gnatyr " & + "NOREFERENCES " & + "-gnaty-r " & "SPECS " & "-gnatys " & + "NOSPECS " & + "-gnaty-s " & "STATEMENTS_AFTER_THEN_ELSE " & "-gnatyS " & + "NOSTATEMENTS_AFTER_THEN_ELSE " & + "-gnaty-S " & "TOKEN " & "-gnatyt " & + "NOTOKEN " & + "-gnaty-t " & "UNNECESSARY_BLANK_LINES " & "-gnatyu " & + "NOUNNECESSARY_BLANK_LINES " & + "-gnaty-u " & "XTRA_PARENS " & ! "-gnaty-x " & ! "NOXTRA_PARENS " & ! "-gnaty-x "; -- /NOSTYLE_CHECKS (D) -- /STYLE_CHECKS[=(keyword,[...])] -- *************** package VMS_Data is *** 2151,2157 **** -- allows proper processing of the output -- generated by specialized tools including -- gnatprep (where --! is used) and the SPARK ! -- annnotation language (where --# is used). -- For the purposes of this rule, a special -- character is defined as being in one of the -- ASCII ranges 16#21#..16#2F# or --- 2325,2331 ---- -- allows proper processing of the output -- generated by specialized tools including -- gnatprep (where --! is used) and the SPARK ! -- annotation language (where --# is used). -- For the purposes of this rule, a special -- character is defined as being in one of the -- ASCII ranges 16#21#..16#2F# or *************** package VMS_Data is *** 2400,2405 **** --- 2574,2587 ---- "!-gnatg,!-gnaty*"; -- NODOC (see /STYLE_CHECKS) + S_GCC_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + S_GCC_Symbol : aliased constant S := "/SYMBOL_PREPROCESSING=" & '"' & "-gnateD" & '"'; -- /SYMBOL_PREPROCESSING="symbol=value" *************** package VMS_Data is *** 2517,2522 **** --- 2699,2708 ---- "-gnatVc " & "NOCOPIES " & "-gnatVC " & + "COMPONENTS " & + "-gnatVe " & + "NOCOMPONENTS " & + "-gnatVE " & "FLOATS " & "-gnatVf " & "NOFLOATS " & *************** package VMS_Data is *** 2607,2612 **** --- 2793,2800 ---- "!-gnatws,!-gnatwe " & "ALL " & "-gnatwa " & + "EVERY " & + "-gnatw.e " & "OPTIONAL " & "-gnatwa " & "NOOPTIONAL " & *************** package VMS_Data is *** 2623,2628 **** --- 2811,2820 ---- "-gnatwb " & "NO_BAD_FIXED_VALUES " & "-gnatwB " & + "BIASED_REPRESENTATION " & + "-gnatw.b " & + "NO_BIASED_REPRESENTATION " & + "-gnatw.B " & "CONDITIONALS " & "-gnatwc " & "NOCONDITIONALS " & *************** package VMS_Data is *** 2685,2690 **** --- 2877,2886 ---- "-gnatwP " & "MISSING_PARENS " & "-gnatwq " & + "PARAMETER_ORDER " & + "-gnatw.p " & + "NOPARAMETER_ORDER " & + "-gnatw.P " & "NOMISSING_PARENS " & "-gnatwQ " & "REDUNDANT " & *************** package VMS_Data is *** 2715,2720 **** --- 2911,2920 ---- "-gnatww " & "NOLOWBOUND_ASSUMED " & "-gnatwW " & + "WARNINGS_OFF_PRAGMAS " & + "-gnatw.w " & + "NO_WARNINGS_OFF_PRAGMAS " & + "-gnatw.W " & "IMPORT_EXPORT_PRAGMAS " & "-gnatwx " & "NOIMPORT_EXPORT_PRAGMAS " & *************** package VMS_Data is *** 2760,2765 **** --- 2960,2969 ---- -- ELABORATION. All other optional Ada -- warnings are turned on. -- + -- EVERY Activate every optional warning. + -- Activates all optional warnings, including + -- those listed above as exceptions for ALL. + -- -- NOALL Suppress all optional errors. -- Suppresses all optional warning messages -- that can be activated by option ALL. *************** package VMS_Data is *** 2932,2938 **** -- -- NOREDUNDANT Suppress warnings for redundant constructs. -- ! -- SUPPRESS Completely suppresse the output of all warning -- messages. Same as /NOWARNINGS. -- -- UNCHECKED_CONVERSIONS Activates warnings on unchecked conversions. --- 3136,3142 ---- -- -- NOREDUNDANT Suppress warnings for redundant constructs. -- ! -- SUPPRESS Completely suppress the output of all warning -- messages. Same as /NOWARNINGS. -- -- UNCHECKED_CONVERSIONS Activates warnings on unchecked conversions. *************** package VMS_Data is *** 3005,3010 **** --- 3209,3220 ---- -- -- Inhibit all warning messages of the GCC back-end. + S_GCC_All_Back : aliased constant S := "/ALL_BACK_END_WARNINGS " & + "-Wall"; + -- /ALL_BACK_END_WARNINGS + -- + -- Activate all warning messages of the GCC back-end. + S_GCC_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" & "BRACKETS " & "-gnatWb " & *************** package VMS_Data is *** 3038,3044 **** -- of lower case. -- -- NONE No wide characters are allowed. Same ! -- as /NOWIDE_CHARCTER_ENCODING. -- -- HEX In this encoding, a wide character is represented by -- the following five character sequence: ESC a b c d --- 3248,3254 ---- -- of lower case. -- -- NONE No wide characters are allowed. Same ! -- as /NOWIDE_CHARACTER_ENCODING. -- -- HEX In this encoding, a wide character is represented by -- the following five character sequence: ESC a b c d *************** package VMS_Data is *** 3078,3084 **** -- 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx# -- -- where the xxx bits correspond to the left-padded bits ! -- of the the 16-bit character value. Note that all lower -- half ASCII characters are represented as ASCII bytes -- and all upper half characters and other wide characters -- are represented as sequences of upper-half (The full --- 3288,3294 ---- -- 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx# -- -- where the xxx bits correspond to the left-padded bits ! -- of the 16-bit character value. Note that all lower -- half ASCII characters are represented as ASCII bytes -- and all upper half characters and other wide characters -- are represented as sequences of upper-half (The full *************** package VMS_Data is *** 3152,3159 **** --- 3362,3371 ---- S_GCC_Extend 'Access, S_GCC_Ext 'Access, S_GCC_File 'Access, + S_GCC_Follow 'Access, S_GCC_Force 'Access, S_GCC_Full 'Access, + S_GCC_Generate'Access, S_GCC_GNAT 'Access, S_GCC_Help 'Access, S_GCC_Ident 'Access, *************** package VMS_Data is *** 3168,3173 **** --- 3380,3386 ---- S_GCC_Length 'Access, S_GCC_List 'Access, S_GCC_Output 'Access, + S_GCC_Machine 'Access, S_GCC_Mapping 'Access, S_GCC_Mess 'Access, S_GCC_Nesting 'Access, *************** package VMS_Data is *** 3177,3182 **** --- 3390,3396 ---- S_GCC_Nostlib 'Access, S_GCC_Opt 'Access, S_GCC_OptX 'Access, + S_GCC_Pointer 'Access, S_GCC_Polling 'Access, S_GCC_Project 'Access, S_GCC_Psta 'Access, *************** package VMS_Data is *** 3188,3193 **** --- 3402,3408 ---- S_GCC_Search 'Access, S_GCC_Style 'Access, S_GCC_StyleX 'Access, + S_GCC_Subdirs 'Access, S_GCC_Symbol 'Access, S_GCC_Syntax 'Access, S_GCC_Table 'Access, *************** package VMS_Data is *** 3205,3210 **** --- 3420,3426 ---- S_GCC_Wide 'Access, S_GCC_WideX 'Access, S_GCC_No_Back 'Access, + S_GCC_All_Back'Access, S_GCC_Xdebug 'Access, S_GCC_Xref 'Access); *************** package VMS_Data is *** 3214,3220 **** S_Elim_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. --- 3430,3436 ---- S_Elim_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. *************** package VMS_Data is *** 3267,3272 **** --- 3483,3495 ---- -- Example: -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + S_Elim_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_Elim_GNATMAKE : aliased constant S := "/GNATMAKE=@" & "--GNATMAKE=@"; -- /GNATMAKE=path_name *************** package VMS_Data is *** 3317,3322 **** --- 3540,3553 ---- -- -- When looking for source files also look in the specified directories. + S_Elim_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + S_Elim_Verb : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) *************** package VMS_Data is *** 3335,3354 **** S_Elim_Config 'Access, S_Elim_Current 'Access, S_Elim_Ext 'Access, S_Elim_GNATMAKE'Access, S_Elim_Mess 'Access, S_Elim_Project 'Access, S_Elim_Quiet 'Access, S_Elim_Search 'Access, S_Elim_Verb 'Access); ---------------------------- -- Switches for GNAT FIND -- ---------------------------- ! S_Find_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. --- 3566,3587 ---- S_Elim_Config 'Access, S_Elim_Current 'Access, S_Elim_Ext 'Access, + S_Elim_Follow 'Access, S_Elim_GNATMAKE'Access, S_Elim_Mess 'Access, S_Elim_Project 'Access, S_Elim_Quiet 'Access, S_Elim_Search 'Access, + S_Elim_Subdirs 'Access, S_Elim_Verb 'Access); ---------------------------- -- Switches for GNAT FIND -- ---------------------------- ! S_Find_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. *************** package VMS_Data is *** 3389,3394 **** --- 3622,3634 ---- -- Example: -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + S_Find_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_Find_Full : aliased constant S := "/FULL_PATHNAME " & "-f"; -- /NOFULL_PATHNAME (D) *************** package VMS_Data is *** 3468,3474 **** -- -- This qualifier is not compatible with /PROJECT_FILE ! S_Find_Prj : aliased constant S := "/PROJECT_FILE=<" & "-P>"; -- /PROJECT_FILE=filename -- --- 3708,3714 ---- -- -- This qualifier is not compatible with /PROJECT_FILE ! S_Find_Prj : aliased constant S := "/PROJECT_FILE=<" & "-P>"; -- /PROJECT_FILE=filename -- *************** package VMS_Data is *** 3504,3509 **** --- 3744,3757 ---- -- The order in which source file search is undertaken is the same as for -- MAKE. + S_Find_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + S_Find_Types : aliased constant S := "/TYPE_HIERARCHY " & "-t"; -- /NOTYPE_HIERARCHY (D) *************** package VMS_Data is *** 3520,3525 **** --- 3768,3774 ---- S_Find_Deriv 'Access, S_Find_Expr 'Access, S_Find_Ext 'Access, + S_Find_Follow 'Access, S_Find_Full 'Access, S_Find_Ignore 'Access, S_Find_Mess 'Access, *************** package VMS_Data is *** 3532,3537 **** --- 3781,3787 ---- S_Find_Ref 'Access, S_Find_Search 'Access, S_Find_Source 'Access, + S_Find_Subdirs 'Access, S_Find_Types 'Access); ------------------------------ *************** package VMS_Data is *** 3556,3564 **** -- Switches for GNAT LINK -- ---------------------------- ! S_Link_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. --- 3806,3814 ---- -- Switches for GNAT LINK -- ---------------------------- ! S_Link_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. *************** package VMS_Data is *** 3621,3626 **** --- 3871,3883 ---- -- Example: -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + S_Link_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_Link_Forlink : aliased constant S := "/FOR_LINKER=" & '"' & "--for-linker=" & '"'; -- /FOR_LINKER= *************** package VMS_Data is *** 3653,3659 **** S_Link_Library : aliased constant S := "/LIBRARY=|" & "-l|"; ! -- /LYBRARY=xyz -- -- Link with library named "xyz". --- 3910,3916 ---- S_Link_Library : aliased constant S := "/LIBRARY=|" & "-l|"; ! -- /LIBRARY=xyz -- -- Link with library named "xyz". *************** package VMS_Data is *** 3717,3723 **** -- -- Specifies the style of codes returned by -- Ada.Command_Line.Set_Exit_Status. Must be used in conjunction with ! -- and match the Bind qualifer with the same name. -- -- POSIX (D) Return Posix compatible exit codes. -- --- 3974,3980 ---- -- -- Specifies the style of codes returned by -- Ada.Command_Line.Set_Exit_Status. Must be used in conjunction with ! -- and match the Bind qualifier with the same name. -- -- POSIX (D) Return Posix compatible exit codes. -- *************** package VMS_Data is *** 3731,3736 **** --- 3988,4001 ---- -- -- Indicate to the linker that the link is static. + S_Link_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + S_Link_Verb : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) *************** package VMS_Data is *** 3744,3750 **** "--for-linker="; -- / -- ! -- Any other switch that will be transmited to the underlying linker. Link_Switches : aliased constant Switches := (S_Link_Add 'Access, --- 4009,4015 ---- "--for-linker="; -- / -- ! -- Any other switch that will be transmitted to the underlying linker. Link_Switches : aliased constant Switches := (S_Link_Add 'Access, *************** package VMS_Data is *** 3753,3758 **** --- 4018,4024 ---- S_Link_Nodebug 'Access, S_Link_Execut 'Access, S_Link_Ext 'Access, + S_Link_Follow 'Access, S_Link_Forlink 'Access, S_Link_Force 'Access, S_Link_Ident 'Access, *************** package VMS_Data is *** 3765,3770 **** --- 4031,4037 ---- S_Link_Project 'Access, S_Link_Return 'Access, S_Link_Static 'Access, + S_Link_Subdirs 'Access, S_Link_Verb 'Access, S_Link_ZZZZZ 'Access); *************** package VMS_Data is *** 3772,3780 **** -- Switches for GNAT LIST -- ---------------------------- ! S_List_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. --- 4039,4047 ---- -- Switches for GNAT LIST -- ---------------------------- ! S_List_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. *************** package VMS_Data is *** 3824,3829 **** --- 4091,4103 ---- -- Take as arguments the files that are listed in the specified -- text file. + S_List_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_List_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & "DEFAULT " & "-vP0 " & *************** package VMS_Data is *** 3909,3914 **** --- 4183,4196 ---- -- -- When looking for source files also look in the specified directories. + S_List_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + List_Switches : aliased constant Switches := (S_List_Add 'Access, S_List_All 'Access, *************** package VMS_Data is *** 3917,3929 **** S_List_Depend 'Access, S_List_Ext 'Access, S_List_Files 'Access, S_List_Mess 'Access, S_List_Nostinc 'Access, S_List_Object 'Access, S_List_Output 'Access, S_List_Project 'Access, S_List_Search 'Access, ! S_List_Source 'Access); ---------------------------- -- Switches for GNAT MAKE -- --- 4199,4213 ---- S_List_Depend 'Access, S_List_Ext 'Access, S_List_Files 'Access, + S_List_Follow 'Access, S_List_Mess 'Access, S_List_Nostinc 'Access, S_List_Object 'Access, S_List_Output 'Access, S_List_Project 'Access, S_List_Search 'Access, ! S_List_Source 'Access, ! S_List_Subdirs 'Access); ---------------------------- -- Switches for GNAT MAKE -- *************** package VMS_Data is *** 3973,3981 **** -- have been previously compiled and must be up to date, -- and the main program need to have been bound. ! S_Make_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. --- 4257,4265 ---- -- have been previously compiled and must be up to date, -- and the main program need to have been bound. ! S_Make_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. *************** package VMS_Data is *** 4068,4074 **** -- a Unix-style Makefile. By default, each source file is prefixed with -- its (relative or absolute) directory name. This name is whatever you -- specified in the various /SOURCE_SEARCH and /SEARCH qualifiers. If ! -- you also speficy the /QUIET qualifier, only the source file names, -- without relative paths, are output. If you just specify the -- /DEPENDENCY_LIST qualifier, dependencies of the GNAT internal system -- files are omitted. This is typically what you want. If you also --- 4352,4358 ---- -- a Unix-style Makefile. By default, each source file is prefixed with -- its (relative or absolute) directory name. This name is whatever you -- specified in the various /SOURCE_SEARCH and /SEARCH qualifiers. If ! -- you also specify the /QUIET qualifier, only the source file names, -- without relative paths, are output. If you just specify the -- /DEPENDENCY_LIST qualifier, dependencies of the GNAT internal system -- files are omitted. This is typically what you want. If you also *************** package VMS_Data is *** 4084,4089 **** --- 4368,4384 ---- -- Put all object files and .ALI files in . -- This qualifier is not compatible with /PROJECT_FILE. + S_Make_Disprog : aliased constant S := "/DISPLAY_PROGRESS " & + "-d"; + -- /NOPLAY_PROGRESS (D) + -- /DISPLAY_PROGRESS + -- + -- Display progress for each source, up to date or not, as a single line + -- completed x out of y (zz%) + -- If the file needs to be compiled this is displayed after the + -- invocation of the compiler. These lines are displayed even in quiet + -- output mode (/QUIET). + S_Make_Doobj : aliased constant S := "/DO_OBJECT_CHECK " & "-n"; -- /NODO_OBJECT_CHECK (D) *************** package VMS_Data is *** 4116,4121 **** --- 4411,4423 ---- -- Example: -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + S_Make_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_Make_Force : aliased constant S := "/FORCE_COMPILE " & "-f"; -- /NOFORCE_COMPILE (D) *************** package VMS_Data is *** 4123,4129 **** -- -- Force recompilations. Recompile all sources, even though some object -- files may be up to date, but don't recompile predefined or GNAT ! -- internal files unless the /ALL_FILES qualfier is also specified. S_Make_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " & "-F"; --- 4425,4431 ---- -- -- Force recompilations. Recompile all sources, even though some object -- files may be up to date, but don't recompile predefined or GNAT ! -- internal files unless the /ALL_FILES qualifier is also specified. S_Make_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " & "-F"; *************** package VMS_Data is *** 4157,4163 **** -- are found on the Ada object path, the new object and ALI files are -- created in the directory containing the source being compiled. ! S_Make_Index : aliased constant S := "/SOURCE_INDEX=#" & "-eI#"; -- /SOURCE_INDEX=nnn -- --- 4459,4465 ---- -- are found on the Ada object path, the new object and ALI files are -- created in the directory containing the source being compiled. ! S_Make_Index : aliased constant S := "/SOURCE_INDEX=#" & "-eI#"; -- /SOURCE_INDEX=nnn -- *************** package VMS_Data is *** 4311,4317 **** -- /NOPROCESSES (D) -- /PROCESSES=NNN -- ! -- Use NNN processes to carry out the (re)complations. If you have a -- multiprocessor machine, compilations will occur in parallel. In the -- event of compilation errors, messages from various compilations might -- get interspersed (but GNAT MAKE will give you the full ordered list of --- 4613,4619 ---- -- /NOPROCESSES (D) -- /PROCESSES=NNN -- ! -- Use NNN processes to carry out the (re)compilations. If you have a -- multiprocessor machine, compilations will occur in parallel. In the -- event of compilation errors, messages from various compilations might -- get interspersed (but GNAT MAKE will give you the full ordered list of *************** package VMS_Data is *** 4378,4383 **** --- 4680,4693 ---- -- Output the commands for the compiler, the binder and the linker -- on SYS$OUTPUT, instead of SYS$ERROR. + S_Make_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + S_Make_Switch : aliased constant S := "/SWITCH_CHECK " & "-s"; -- /NOSWITCH_CHECK (D) *************** package VMS_Data is *** 4430,4438 **** --- 4740,4750 ---- S_Make_Current 'Access, S_Make_Dep 'Access, S_Make_Dirobj 'Access, + S_Make_Disprog 'Access, S_Make_Doobj 'Access, S_Make_Execut 'Access, S_Make_Ext 'Access, + S_Make_Follow 'Access, S_Make_Force 'Access, S_Make_Full 'Access, S_Make_Hi_Verb 'Access, *************** package VMS_Data is *** 4463,4468 **** --- 4775,4781 ---- S_Make_Skip 'Access, S_Make_Source 'Access, S_Make_Stand 'Access, + S_Make_Subdirs 'Access, S_Make_Switch 'Access, S_Make_Unique 'Access, S_Make_Use_Map 'Access, *************** package VMS_Data is *** 4472,4480 **** -- Switches for GNAT METRIC -- ------------------------------ ! S_Metric_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. --- 4785,4793 ---- -- Switches for GNAT METRIC -- ------------------------------ ! S_Metric_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. *************** package VMS_Data is *** 4486,4571 **** -- specified, the underlying tool gnatmetric is called for all the -- sources of all the Project Files in the project tree. ! S_Metric_Debug : aliased constant S := "/DEBUG_OUTPUT " & "-dv"; -- /DEBUG_OUTPUT -- -- Generate the debug information ! S_Metric_Direct : aliased constant S := "/DIRECTORY=@" & "-d=@"; -- /DIRECTORY=pathname -- -- Put the files with detailed metric information into the specified -- directory ! S_Metric_Element : aliased constant S := "/ELEMENT_METRICS=" & ! "ALL " & ! "!-ed,!-es,!-enl,!-eps," & ! "!-eas,!-ept,!-eat,!-enu," & ! "!-ec " & ! "DECLARATION_TOTAL " & ! "-ed " & ! "STATEMENT_TOTAL " & ! "-es " & ! "LOOP_NESTING_MAX " & ! "-enl " & ! "INT_SUBPROGRAMS " & ! "-eps " & ! "SUBPROGRAMS_ALL " & ! "-eas " & ! "INT_TYPES " & ! "-ept " & ! "TYPES_ALL " & ! "-eat " & ! "PROGRAM_NESTING_MAX " & ! "-enu " & ! "CONSTRUCT_NESTING_MAX " & "-ec"; -- NODOC (see /SYNTAX_METRICS) ! S_Metric_Syntax : aliased constant S := "/SYNTAX_METRICS=" & ! "ALL_ON " & ! "--syntax-all " & ! "ALL_OFF " & ! "--no-syntax-all " & ! "DECLARATIONS_ON " & ! "--declarations " & ! "DECLARATIONS_OFF " & ! "--no-declarations " & ! "STATEMENTS_ON " & ! "--statements " & ! "STATEMENTS_OFF " & ! "--no-statements " & ! "PUBLIC_SUBPROGRAMS_ON " & ! "--public-subprograms " & ! "PUBLIC_SUBPROGRAMS_OFF " & ! "--no-public-subprograms " & ! "ALL_SUBPROGRAMS_ON " & ! "--all-subprograms " & ! "ALL_SUBPROGRAMS_OFF " & ! "--no-all-subprograms " & ! "PUBLIC_TYPES_ON " & ! "--public-types " & ! "PUBLIC_TYPES_OFF " & ! "--no-public-types " & ! "ALL_TYPES_ON " & ! "--all-types " & ! "ALL_TYPES_OFF " & ! "--no-all-types " & ! "UNIT_NESTING_ON " & ! "--unit-nesting " & ! "UNIT_NESTING_OFF " & ! "--no-unit-nesting " & ! "CONSTRUCT_NESTING_ON " & ! "--construct-nesting " & ! "CONSTRUCT_NESTING_OFF " & "--no-construct-nesting"; -- /SYNTAX_METRICS(option, option ...) -- -- Specifies the syntax element metrics to be computed (if at least one ! -- positive syntax element metric, line metric or complexity metric is ! -- specified then only explicitly specified specified syntax element -- metrics are computed and reported) -- -- option may be one of the following: --- 4799,4884 ---- -- specified, the underlying tool gnatmetric is called for all the -- sources of all the Project Files in the project tree. ! S_Metric_Debug : aliased constant S := "/DEBUG_OUTPUT " & "-dv"; -- /DEBUG_OUTPUT -- -- Generate the debug information ! S_Metric_Direct : aliased constant S := "/DIRECTORY=@" & "-d=@"; -- /DIRECTORY=pathname -- -- Put the files with detailed metric information into the specified -- directory ! S_Metric_Element : aliased constant S := "/ELEMENT_METRICS=" & ! "ALL " & ! "!-ed,!-es,!-enl,!-eps," & ! "!-eas,!-ept,!-eat,!-enu," & ! "!-ec " & ! "DECLARATION_TOTAL " & ! "-ed " & ! "STATEMENT_TOTAL " & ! "-es " & ! "LOOP_NESTING_MAX " & ! "-enl " & ! "INT_SUBPROGRAMS " & ! "-eps " & ! "SUBPROGRAMS_ALL " & ! "-eas " & ! "INT_TYPES " & ! "-ept " & ! "TYPES_ALL " & ! "-eat " & ! "PROGRAM_NESTING_MAX " & ! "-enu " & ! "CONSTRUCT_NESTING_MAX " & "-ec"; -- NODOC (see /SYNTAX_METRICS) ! S_Metric_Syntax : aliased constant S := "/SYNTAX_METRICS=" & ! "ALL_ON " & ! "--syntax-all " & ! "ALL_OFF " & ! "--no-syntax-all " & ! "DECLARATIONS_ON " & ! "--declarations " & ! "DECLARATIONS_OFF " & ! "--no-declarations " & ! "STATEMENTS_ON " & ! "--statements " & ! "STATEMENTS_OFF " & ! "--no-statements " & ! "PUBLIC_SUBPROGRAMS_ON " & ! "--public-subprograms " & ! "PUBLIC_SUBPROGRAMS_OFF " & ! "--no-public-subprograms " & ! "ALL_SUBPROGRAMS_ON " & ! "--all-subprograms " & ! "ALL_SUBPROGRAMS_OFF " & ! "--no-all-subprograms " & ! "PUBLIC_TYPES_ON " & ! "--public-types " & ! "PUBLIC_TYPES_OFF " & ! "--no-public-types " & ! "ALL_TYPES_ON " & ! "--all-types " & ! "ALL_TYPES_OFF " & ! "--no-all-types " & ! "UNIT_NESTING_ON " & ! "--unit-nesting " & ! "UNIT_NESTING_OFF " & ! "--no-unit-nesting " & ! "CONSTRUCT_NESTING_ON " & ! "--construct-nesting " & ! "CONSTRUCT_NESTING_OFF " & "--no-construct-nesting"; -- /SYNTAX_METRICS(option, option ...) -- -- Specifies the syntax element metrics to be computed (if at least one ! -- positive syntax element metric, line metric, complexity or coupling ! -- metric is specified then only explicitly specified syntax element -- metrics are computed and reported) -- -- option may be one of the following: *************** package VMS_Data is *** 4598,4604 **** -- -- All combinations of syntax element metrics options are allowed. ! S_Metric_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & "-X" & '"'; -- /EXTERNAL_REFERENCE="name=val" -- --- 4911,4917 ---- -- -- All combinations of syntax element metrics options are allowed. ! S_Metric_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & "-X" & '"'; -- /EXTERNAL_REFERENCE="name=val" -- *************** package VMS_Data is *** 4608,4628 **** -- Example: -- /EXTERNAL_REFERENCE="DEBUG=TRUE" ! S_Metric_Files : aliased constant S := "/FILES=@" & "-files=@"; -- /FILES=filename -- -- Take as arguments the files that are listed in the specified -- text file. ! S_Metric_Format : aliased constant S := "/FORMAT_OUTPUT=" & ! "DEFAULT " & ! "!-x,!-nt,!-sfn " & ! "XML " & ! "-x " & ! "NO_TEXT " & ! "-nt " & ! "SHORT_SOURCE_FILE_NAME " & "-sfn"; -- /FORMAT_OUTPUT=(option, option ...) -- --- 4921,4941 ---- -- Example: -- /EXTERNAL_REFERENCE="DEBUG=TRUE" ! S_Metric_Files : aliased constant S := "/FILES=@" & "-files=@"; -- /FILES=filename -- -- Take as arguments the files that are listed in the specified -- text file. ! S_Metric_Format : aliased constant S := "/FORMAT_OUTPUT=" & ! "DEFAULT " & ! "!-x,!-nt,!-sfn " & ! "XML " & ! "-x " & ! "NO_TEXT " & ! "-nt " & ! "SHORT_SOURCE_FILE_NAME " & "-sfn"; -- /FORMAT_OUTPUT=(option, option ...) -- *************** package VMS_Data is *** 4636,4706 **** -- NO_TEXT Do not generate the text output (implies XML) -- SHORT_SOURCE_FILE_NAME Use short argument source names in output ! S_Metric_Globout : aliased constant S := "/GLOBAL_OUTPUT=@" & "-og@"; -- /GLOBAL_OUTPUT=filename -- -- Put the textual global metric information into the specified file ! S_Metric_Line : aliased constant S := "/LINE_METRICS=" & ! "ALL " & ! "!-la,!-lcode,!-lcomm," & ! "!-leol,!-lb " & ! "LINES_ALL " & ! "-la " & ! "CODE_LINES " & ! "-lcode " & ! "COMENT_LINES " & ! "-lcomm " & ! "MIXED_CODE_COMMENTS " & ! "-leol " & ! "COMMENT_PERCENTAGE " & ! "-lratio " & ! "BLANK_LINES " & ! "-lb " & ! "AVERAGE_LINES_IN_BODIES " & "-lav "; -- NODOC (see /LINE_COUNT_METRICS) ! S_Metric_Lines : aliased constant S := "/LINE_COUNT_METRICS=" & ! "ALL_ON " & ! "--lines-all " & ! "ALL_OFF " & ! "--no-lines-all " & ! "ALL_LINES_ON " & ! "--lines " & ! "ALL_LINES_OFF " & ! "--no-lines " & ! "CODE_LINES_ON " & ! "--lines-code " & ! "CODE_LINES_OFF " & ! "--no-lines-code " & ! "COMMENT_LINES_ON " & ! "--lines-comment " & ! "COMMENT_LINES_OFF " & ! "--no-lines-comment " & ! "CODE_COMMENT_LINES_ON " & ! "--lines-eol-comment " & ! "CODE_COMMENT_LINES_OFF " & ! "--no-lines-eol-comment " & ! "COMMENT_PERCENTAGE_ON " & ! "--lines-ratio " & ! "COMMENT_PERCENTAGE_OFF " & ! "--no-lines-ratio " & ! "BLANK_LINES_ON " & ! "--lines-blank " & ! "BLANK_LINES_OFF " & ! "--no-lines-blank " & ! "AVERAGE_BODY_LINES_ON " & ! "--lines-average " & ! "AVERAGE_BODY_LINES_OFF " & "--no-lines-average"; -- /LINE_COUNT_METRICS=(option, option ...) -- Specifies the line metrics to be computed (if at least one positive ! -- syntax element metric, line metric or complexity metric is specified ! -- then only explicitly specified specified line metrics are computed and ! -- reported) -- -- option may be one of the following: -- --- 4949,5019 ---- -- NO_TEXT Do not generate the text output (implies XML) -- SHORT_SOURCE_FILE_NAME Use short argument source names in output ! S_Metric_Globout : aliased constant S := "/GLOBAL_OUTPUT=@" & "-og@"; -- /GLOBAL_OUTPUT=filename -- -- Put the textual global metric information into the specified file ! S_Metric_Line : aliased constant S := "/LINE_METRICS=" & ! "ALL " & ! "!-la,!-lcode,!-lcomm," & ! "!-leol,!-lb " & ! "LINES_ALL " & ! "-la " & ! "CODE_LINES " & ! "-lcode " & ! "COMENT_LINES " & ! "-lcomm " & ! "MIXED_CODE_COMMENTS " & ! "-leol " & ! "COMMENT_PERCENTAGE " & ! "-lratio " & ! "BLANK_LINES " & ! "-lb " & ! "AVERAGE_LINES_IN_BODIES " & "-lav "; -- NODOC (see /LINE_COUNT_METRICS) ! S_Metric_Lines : aliased constant S := "/LINE_COUNT_METRICS=" & ! "ALL_ON " & ! "--lines-all " & ! "ALL_OFF " & ! "--no-lines-all " & ! "ALL_LINES_ON " & ! "--lines " & ! "ALL_LINES_OFF " & ! "--no-lines " & ! "CODE_LINES_ON " & ! "--lines-code " & ! "CODE_LINES_OFF " & ! "--no-lines-code " & ! "COMMENT_LINES_ON " & ! "--lines-comment " & ! "COMMENT_LINES_OFF " & ! "--no-lines-comment " & ! "CODE_COMMENT_LINES_ON " & ! "--lines-eol-comment " & ! "CODE_COMMENT_LINES_OFF " & ! "--no-lines-eol-comment " & ! "COMMENT_PERCENTAGE_ON " & ! "--lines-ratio " & ! "COMMENT_PERCENTAGE_OFF " & ! "--no-lines-ratio " & ! "BLANK_LINES_ON " & ! "--lines-blank " & ! "BLANK_LINES_OFF " & ! "--no-lines-blank " & ! "AVERAGE_BODY_LINES_ON " & ! "--lines-average " & ! "AVERAGE_BODY_LINES_OFF " & "--no-lines-average"; -- /LINE_COUNT_METRICS=(option, option ...) -- Specifies the line metrics to be computed (if at least one positive ! -- syntax element metric, line metric, complexity or coupling metric is ! -- specified then only explicitly specified line metrics are computed ! -- and reported) -- -- option may be one of the following: -- *************** package VMS_Data is *** 4729,4761 **** -- -- All combinations of line metrics options are allowed. ! S_Metric_Complexity : aliased constant S := "/COMPLEXITY_METRICS=" & ! "ALL_ON " & ! "--complexity-all " & ! "ALL_OFF " & ! "--no-complexity-all " & ! "CYCLOMATIC_ON " & ! "--complexity-cyclomatic " & ! "CYCLOMATIC_OFF " & ! "--no-complexity-cyclomatic " & ! "ESSENTIAL_ON " & ! "--complexity-essential " & ! "ESSENTIAL_OFF " & ! "--no-complexity-essential " & ! "LOOP_NESTING_ON " & ! "--loop-nesting " & ! "LOOP_NESTING_OFF " & ! "--no-loop-nesting " & ! "AVERAGE_COMPLEXITY_ON " & ! "--complexity-average " & ! "AVERAGE_COMPLEXITY_OFF " & "--no-complexity-average"; -- /COMPLEXITY_METRICS=(option, option ...) -- Specifies the complexity metrics to be computed (if at least one ! -- positive syntax element metric, line metric or complexity metric is ! -- specified then only explicitly specified specified line metrics are ! -- computed and reported) -- -- option may be one of the following: -- --- 5042,5074 ---- -- -- All combinations of line metrics options are allowed. ! S_Metric_Complexity : aliased constant S := "/COMPLEXITY_METRICS=" & ! "ALL_ON " & ! "--complexity-all " & ! "ALL_OFF " & ! "--no-complexity-all " & ! "CYCLOMATIC_ON " & ! "--complexity-cyclomatic " & ! "CYCLOMATIC_OFF " & ! "--no-complexity-cyclomatic "& ! "ESSENTIAL_ON " & ! "--complexity-essential " & ! "ESSENTIAL_OFF " & ! "--no-complexity-essential " & ! "LOOP_NESTING_ON " & ! "--loop-nesting " & ! "LOOP_NESTING_OFF " & ! "--no-loop-nesting " & ! "AVERAGE_COMPLEXITY_ON " & ! "--complexity-average " & ! "AVERAGE_COMPLEXITY_OFF " & "--no-complexity-average"; -- /COMPLEXITY_METRICS=(option, option ...) -- Specifies the complexity metrics to be computed (if at least one ! -- positive syntax element metric, line metric, complexity or coupling ! -- metric is specified then only explicitly specified complexity metrics ! -- are computed and reported) -- -- option may be one of the following: -- *************** package VMS_Data is *** 4765,4771 **** -- CYCLOMATIC_OFF Do not compute the McCabe Cyclomatic -- Complexity -- ESSENTIAL_ON Compute the Essential Complexity ! -- ESSENTIAL_OFF Do not ompute the Essential Complexity -- LOOP_NESTIMG_ON Compute the maximal loop nesting -- LOOP_NESTIMG_OFF Do not compute the maximal loop nesting -- AVERAGE_COMPLEXITY_ON Compute the average complexity for --- 5078,5084 ---- -- CYCLOMATIC_OFF Do not compute the McCabe Cyclomatic -- Complexity -- ESSENTIAL_ON Compute the Essential Complexity ! -- ESSENTIAL_OFF Do not compute the Essential Complexity -- LOOP_NESTIMG_ON Compute the maximal loop nesting -- LOOP_NESTIMG_OFF Do not compute the maximal loop nesting -- AVERAGE_COMPLEXITY_ON Compute the average complexity for *************** package VMS_Data is *** 4775,4780 **** --- 5088,5141 ---- -- -- All combinations of line metrics options are allowed. + S_Metric_Coupling : aliased constant S := "/COUPLING_METRICS=" & + "ALL_ON " & + "--coupling-all " & + "ALL_OFF " & + "--no-coupling-all " & + "PACKAGE_EFFERENT_ON " & + "--package-efferent-coupling " & + "PACKAGE_EFFERENT_OFF " & + "--no-package-efferent-coupling " & + "PACKAGE_AFFERENT_ON " & + "--package-afferent-coupling " & + "PACKAGE_AFFERENT_OFF " & + "--no-package-afferent-coupling " & + "CATEGORY_EFFERENT_ON " & + "--category-efferent-coupling " & + "CATEGORY_EFFERENT_OFF " & + "--no-category-efferent-coupling " & + "CATEGORY_AFFERENT_ON " & + "--category-afferent-coupling " & + "CATEGORY_AFFERENT_OFF " & + "--no-category-afferent-coupling"; + + -- /COUPLING_METRICS=(option, option ...) + + -- Specifies the coupling metrics to be computed. + -- + -- option may be one of the following: + -- + -- ALL_ON All the coupling metrics are computed + -- ALL_OFF (D) None of coupling metrics is computed + -- PACKAGE_EFFERENT_ON Compute package efferent coupling + -- PACKAGE_EFFERENT_OFF Do not compute package efferent coupling + -- PACKAGE_AFFERENT_ON Compute package afferent coupling + -- PACKAGE_AFFERENT_OFF Do not compute package afferent coupling + -- CATEGORY_EFFERENT_ON Compute category efferent coupling + -- CATEGORY_EFFERENT_OFF Do not compute category efferent coupling + -- CATEGORY_AFFERENT_ON Compute category afferent coupling + -- CATEGORY_AFFERENT_OFF Do not compute category afferent coupling + -- + -- All combinations of coupling metrics options are allowed. + + S_Metric_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_Metric_No_Local : aliased constant S := "/NO_LOCAL_DETAILS " & "-nolocal"; -- /LOCAL_DETAILS (D) *************** package VMS_Data is *** 4790,4801 **** -- Do not count EXIT statements as GOTOs when computing the Essential -- Complexity. ! S_Metric_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & ! "DEFAULT " & ! "-vP0 " & ! "MEDIUM " & ! "-vP1 " & ! "HIGH " & "-vP2"; -- /MESSAGES_PROJECT_FILE[=messages-option] -- --- 5151,5162 ---- -- Do not count EXIT statements as GOTOs when computing the Essential -- Complexity. ! S_Metric_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & ! "DEFAULT " & ! "-vP0 " & ! "MEDIUM " & ! "-vP1 " & ! "HIGH " & "-vP2"; -- /MESSAGES_PROJECT_FILE[=messages-option] -- *************** package VMS_Data is *** 4809,4815 **** -- HIGH A great number of messages are output, most of them not -- being useful for the user. ! S_Metric_Project : aliased constant S := "/PROJECT_FILE=<" & "-P>"; -- /PROJECT_FILE=filename -- --- 5170,5176 ---- -- HIGH A great number of messages are output, most of them not -- being useful for the user. ! S_Metric_Project : aliased constant S := "/PROJECT_FILE=<" & "-P>"; -- /PROJECT_FILE=filename -- *************** package VMS_Data is *** 4817,4823 **** -- at the main project file will be parsed before the invocation of the -- binder. ! S_Metric_Quiet : aliased constant S := "/QUIET " & "-q"; -- /NOQUIET (D) -- /QUIET --- 5178,5184 ---- -- at the main project file will be parsed before the invocation of the -- binder. ! S_Metric_Quiet : aliased constant S := "/QUIET " & "-q"; -- /NOQUIET (D) -- /QUIET *************** package VMS_Data is *** 4826,4862 **** -- the number of program units left to be processed. This option turns -- this trace off. ! S_Metric_Suffix : aliased constant S := "/SUFFIX_DETAILS=" & '"' & "-o" & '"'; -- /SUFFIX_DETAILS=suffix -- -- Use the given suffix as the suffix for the name of the file to place -- the detailed metrics into. ! S_Metric_Suppress : aliased constant S := "/SUPPRESS=" & ! "NOTHING " & ! "!-nocc,!-noec,!-nonl," & ! "!-ne,!-nolocal " & ! "CYCLOMATIC_COMPLEXITY " & ! "-nocc " & ! "ESSENTIAL_COMPLEXITY " & ! "-noec " & ! "MAXIMAL_LOOP_NESTING " & ! "-nonl " & ! "EXITS_AS_GOTOS " & ! "-ne " & ! "LOCAL_DETAILS " & "-nolocal "; -- NODOC (see /COMPLEXITY_METRICS /NO_LOCAL_DETAILS /NO_EXITS_AS_GOTOS) ! S_Metric_Verbose : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) -- /VERBOSE -- -- Verbose mode. ! S_Metric_XMLout : aliased constant S := "/XML_OUTPUT=@" & "-ox@"; -- /XML_OUTPUT=filename -- --- 5187,5231 ---- -- the number of program units left to be processed. This option turns -- this trace off. ! S_Metric_Subdirs : aliased constant S := "/SUBDIRS=<" & ! "--subdirs=>"; ! -- /SUBDIRS=dir ! -- ! -- The actual directories (object, exec, library, ...) are subdirectories ! -- of the directory specified in the project file. If the subdirectory ! -- does not exist, it is created automatically. ! ! S_Metric_Suffix : aliased constant S := "/SUFFIX_DETAILS=" & '"' & "-o" & '"'; -- /SUFFIX_DETAILS=suffix -- -- Use the given suffix as the suffix for the name of the file to place -- the detailed metrics into. ! S_Metric_Suppress : aliased constant S := "/SUPPRESS=" & ! "NOTHING " & ! "!-nocc,!-noec,!-nonl," & ! "!-ne,!-nolocal " & ! "CYCLOMATIC_COMPLEXITY " & ! "-nocc " & ! "ESSENTIAL_COMPLEXITY " & ! "-noec " & ! "MAXIMAL_LOOP_NESTING " & ! "-nonl " & ! "EXITS_AS_GOTOS " & ! "-ne " & ! "LOCAL_DETAILS " & "-nolocal "; -- NODOC (see /COMPLEXITY_METRICS /NO_LOCAL_DETAILS /NO_EXITS_AS_GOTOS) ! S_Metric_Verbose : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) -- /VERBOSE -- -- Verbose mode. ! S_Metric_XMLout : aliased constant S := "/XML_OUTPUT=@" & "-ox@"; -- /XML_OUTPUT=filename -- *************** package VMS_Data is *** 4866,4876 **** --- 5235,5247 ---- (S_Metric_Add 'Access, S_Metric_All_Prjs 'Access, S_Metric_Complexity 'Access, + S_Metric_Coupling 'Access, S_Metric_Debug 'Access, S_Metric_Direct 'Access, S_Metric_Element 'Access, S_Metric_Ext 'Access, S_Metric_Files 'Access, + S_Metric_Follow 'Access, S_Metric_Format 'Access, S_Metric_Globout 'Access, S_Metric_Line 'Access, *************** package VMS_Data is *** 4881,4886 **** --- 5252,5258 ---- S_Metric_Project 'Access, S_Metric_Quiet 'Access, S_Metric_Suffix 'Access, + S_Metric_Subdirs 'Access, S_Metric_Syntax 'Access, S_Metric_Suppress 'Access, S_Metric_Verbose 'Access, *************** package VMS_Data is *** 4926,4931 **** --- 5298,5310 ---- -- qualifiers /SOURCE_DIRS as there are non empty lines in the specified -- text file. + S_Name_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_Name_Frng : aliased constant S := "/FOREIGN_PATTERN=" & '"' & "-f" & '"'; -- /FOREIGN_PATTERN= *************** package VMS_Data is *** 4954,4962 **** -- -- Create or update a project file. 'file_name' may include directory -- information. The specified file must be writable. There may be only ! -- one qualifier /PROJECT_FILE. When a qualifier /PROJECT_DILE is -- specified, no qualifier /CONFIG_FILE may be specified. S_Name_Verbose : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) --- 5333,5349 ---- -- -- Create or update a project file. 'file_name' may include directory -- information. The specified file must be writable. There may be only ! -- one qualifier /PROJECT_FILE. When a qualifier /PROJECT_FILE is -- specified, no qualifier /CONFIG_FILE may be specified. + S_Name_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + S_Name_Verbose : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) *************** package VMS_Data is *** 4982,4995 **** -- those whose names end with '_NT.ADA'. Name_Switches : aliased constant Switches := ! (S_Name_Conf 'Access, ! S_Name_Dirs 'Access, ! S_Name_Dfile 'Access, ! S_Name_Frng 'Access, ! S_Name_Help 'Access, ! S_Name_Proj 'Access, ! S_Name_Verbose 'Access, ! S_Name_Excl 'Access); ---------------------------------- -- Switches for GNAT PREPROCESS -- --- 5369,5384 ---- -- those whose names end with '_NT.ADA'. Name_Switches : aliased constant Switches := ! (S_Name_Conf 'Access, ! S_Name_Dirs 'Access, ! S_Name_Dfile 'Access, ! S_Name_Follow 'Access, ! S_Name_Frng 'Access, ! S_Name_Help 'Access, ! S_Name_Proj 'Access, ! S_Name_Subdirs 'Access, ! S_Name_Verbose 'Access, ! S_Name_Excl 'Access); ---------------------------------- -- Switches for GNAT PREPROCESS -- *************** package VMS_Data is *** 5079,5087 **** -- Switches for GNAT PRETTY -- ------------------------------ ! S_Pretty_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. --- 5468,5476 ---- -- Switches for GNAT PRETTY -- ------------------------------ ! S_Pretty_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. *************** package VMS_Data is *** 5120,5126 **** -- Specifying one of the ON options without first specifying the OFF -- option has no effect, because by default all alignments are set to ON. ! S_Pretty_All_Prjs : aliased constant S := "/ALL_PROJECTS " & "-U"; -- /NOALL_PROJECTS (D) -- /ALL_PROJECTS --- 5509,5515 ---- -- Specifying one of the ON options without first specifying the OFF -- option has no effect, because by default all alignments are set to ON. ! S_Pretty_All_Prjs : aliased constant S := "/ALL_PROJECTS " & "-U"; -- /NOALL_PROJECTS (D) -- /ALL_PROJECTS *************** package VMS_Data is *** 5165,5171 **** -- -- layout-option may be one of the following: -- ! -- UNTOUCHED           All the comments remain unchanged -- DEFAULT (D) GNAT style comment line indentation -- STANDARD_INDENT Standard comment line indentation -- GNAT_BEGINNING GNAT style comment beginning --- 5554,5560 ---- -- -- layout-option may be one of the following: -- ! -- UNTOUCHED All the comments remain unchanged -- DEFAULT (D) GNAT style comment line indentation -- STANDARD_INDENT Standard comment line indentation -- GNAT_BEGINNING GNAT style comment beginning *************** package VMS_Data is *** 5293,5299 **** -- Do not place the THEN keyword in IF statement and the LOOP keyword in -- for- and while-loops on a separate line. ! S_Pretty_Use_On_New_Line : aliased constant S := "/USE_ON_NEW_LINE " & "--use-on-new-line"; -- /USE_ON_NEW_LINE -- --- 5682,5688 ---- -- Do not place the THEN keyword in IF statement and the LOOP keyword in -- for- and while-loops on a separate line. ! S_Pretty_Use_On_New_Line : aliased constant S := "/USE_ON_NEW_LINE " & "--use-on-new-line"; -- /USE_ON_NEW_LINE -- *************** package VMS_Data is *** 5321,5327 **** -- -- Specifies the form of the line terminators in the produced source. -- By default, the form of the line terminator depends on the platforms. ! -- On Unix and VMS, it is a Line Feed (LF) chararcter. On Windows (DOS), -- It is a Carriage Return (CR) followed by a Line Feed. -- The Options DOS and CRLF are equivalent. The options UNIX and LF are -- also equivalent. --- 5710,5716 ---- -- -- Specifies the form of the line terminators in the produced source. -- By default, the form of the line terminator depends on the platforms. ! -- On Unix and VMS, it is a Line Feed (LF) character. On Windows (DOS), -- It is a Carriage Return (CR) followed by a Line Feed. -- The Options DOS and CRLF are equivalent. The options UNIX and LF are -- also equivalent. *************** package VMS_Data is *** 5376,5382 **** "-W8"; -- /RESULT_ENCODING[=encoding-type] -- ! -- Specify the wide character encoding method used when writtimg the -- reformatted code in the result file. 'encoding-type' is one of the -- following: -- --- 5765,5771 ---- "-W8"; -- /RESULT_ENCODING[=encoding-type] -- ! -- Specify the wide character encoding method used when writing the -- reformatted code in the result file. 'encoding-type' is one of the -- following: -- *************** package VMS_Data is *** 5402,5407 **** --- 5791,5803 ---- -- Take as arguments the files that are listed in the specified -- text file. + S_Pretty_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_Pretty_Forced : aliased constant S := "/FORCED_OUTPUT=@" & "-of@"; -- /FORCED_OUTPUT=file *************** package VMS_Data is *** 5495,5501 **** -- -- MIXED_CASE Names are in mixed case. ! S_Pretty_No_Backup : aliased constant S := "/NO_BACKUP " & "-rnb"; -- /REPLACE_NO_BACKUP -- --- 5891,5897 ---- -- -- MIXED_CASE Names are in mixed case. ! S_Pretty_Replace_No_Backup : aliased constant S := "/REPLACE_NO_BACKUP " & "-rnb"; -- /REPLACE_NO_BACKUP -- *************** package VMS_Data is *** 5597,5602 **** --- 5993,6006 ---- -- -- Redirect the output to the standard output. + S_Pretty_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + S_Pretty_Verbose : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) *************** package VMS_Data is *** 5615,5661 **** -- By default such warnings are not activated. Pretty_Switches : aliased constant Switches := ! (S_Pretty_Add 'Access, ! S_Pretty_Align 'Access, ! S_Pretty_All_Prjs 'Access, ! S_Pretty_Attrib 'Access, ! S_Pretty_Comments 'Access, ! S_Pretty_Compact_Is 'Access, ! S_Pretty_Config 'Access, ! S_Pretty_Constr 'Access, ! S_Pretty_Comind 'Access, ! S_Pretty_Current 'Access, ! S_Pretty_Dico 'Access, ! S_Pretty_Eol 'Access, ! S_Pretty_Ext 'Access, ! S_Pretty_Encoding 'Access, ! S_Pretty_Files 'Access, ! S_Pretty_Forced 'Access, ! S_Pretty_Formfeed 'Access, ! S_Pretty_Indent 'Access, ! S_Pretty_Keyword 'Access, ! S_Pretty_Maxlen 'Access, ! S_Pretty_Maxind 'Access, ! S_Pretty_Mess 'Access, ! S_Pretty_Names 'Access, ! S_Pretty_No_Backup 'Access, ! S_Pretty_No_Labels 'Access, ! S_Pretty_Notabs 'Access, ! S_Pretty_Output 'Access, ! S_Pretty_Override 'Access, ! S_Pretty_Pragma 'Access, ! S_Pretty_Replace 'Access, ! S_Pretty_Project 'Access, ! S_Pretty_RTS 'Access, ! S_Pretty_Search 'Access, ! S_Pretty_Sep_Loop_Then 'Access, ! S_Pretty_N_Sep_Loop_Then'Access, ! S_Pretty_Use_On_New_Line'Access, ! S_Pretty_Stnm_On_Nw_Line'Access, ! S_Pretty_Specific 'Access, ! S_Pretty_Standard 'Access, ! S_Pretty_Verbose 'Access, ! S_Pretty_Warnings 'Access); ------------------------------ -- Switches for GNAT SHARED -- --- 6019,6067 ---- -- By default such warnings are not activated. Pretty_Switches : aliased constant Switches := ! (S_Pretty_Add 'Access, ! S_Pretty_Align 'Access, ! S_Pretty_All_Prjs 'Access, ! S_Pretty_Attrib 'Access, ! S_Pretty_Comments 'Access, ! S_Pretty_Compact_Is 'Access, ! S_Pretty_Config 'Access, ! S_Pretty_Constr 'Access, ! S_Pretty_Comind 'Access, ! S_Pretty_Current 'Access, ! S_Pretty_Dico 'Access, ! S_Pretty_Eol 'Access, ! S_Pretty_Ext 'Access, ! S_Pretty_Encoding 'Access, ! S_Pretty_Files 'Access, ! S_Pretty_Follow 'Access, ! S_Pretty_Forced 'Access, ! S_Pretty_Formfeed 'Access, ! S_Pretty_Indent 'Access, ! S_Pretty_Keyword 'Access, ! S_Pretty_Maxlen 'Access, ! S_Pretty_Maxind 'Access, ! S_Pretty_Mess 'Access, ! S_Pretty_Names 'Access, ! S_Pretty_No_Labels 'Access, ! S_Pretty_Notabs 'Access, ! S_Pretty_Output 'Access, ! S_Pretty_Override 'Access, ! S_Pretty_Pragma 'Access, ! S_Pretty_Replace 'Access, ! S_Pretty_Replace_No_Backup'Access, ! S_Pretty_Project 'Access, ! S_Pretty_RTS 'Access, ! S_Pretty_Search 'Access, ! S_Pretty_Sep_Loop_Then 'Access, ! S_Pretty_N_Sep_Loop_Then 'Access, ! S_Pretty_Subdirs 'Access, ! S_Pretty_Use_On_New_Line 'Access, ! S_Pretty_Stnm_On_Nw_Line 'Access, ! S_Pretty_Specific 'Access, ! S_Pretty_Standard 'Access, ! S_Pretty_Verbose 'Access, ! S_Pretty_Warnings 'Access); ------------------------------ -- Switches for GNAT SHARED -- *************** package VMS_Data is *** 5739,5747 **** -- Switches for GNAT STACK -- ----------------------------- ! S_Stack_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. --- 6145,6153 ---- -- Switches for GNAT STACK -- ----------------------------- ! S_Stack_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. *************** package VMS_Data is *** 5795,5800 **** --- 6201,6213 ---- -- Take as arguments the files that are listed in the specified -- text file. + S_Stack_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_Stack_Help : aliased constant S := "/HELP " & "-h"; -- /NOHELP (D) *************** package VMS_Data is *** 5853,5858 **** --- 6266,6279 ---- -- Any symbol matching the regular expression will be considered as a -- potential entry point for the analysis. + S_Stack_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + S_Stack_Unbounded : aliased constant S := "/UNBOUNDED=#" & "-d#"; -- /UNBOUNDED=nnn *************** package VMS_Data is *** 5909,5914 **** --- 6330,6336 ---- S_Stack_Directory 'Access, S_Stack_Entries 'Access, S_Stack_Files 'Access, + S_Stack_Follow 'Access, S_Stack_Help 'Access, S_Stack_List 'Access, S_Stack_Order 'Access, *************** package VMS_Data is *** 5916,5921 **** --- 6338,6344 ---- S_Stack_Project 'Access, S_Stack_Output 'Access, S_Stack_Regexp 'Access, + S_Stack_Subdirs 'Access, S_Stack_Unbounded 'Access, S_Stack_Unknown 'Access, S_Stack_Verbose 'Access, *************** package VMS_Data is *** 5925,5933 **** -- Switches for GNAT STUB -- ---------------------------- ! S_Stub_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. --- 6348,6356 ---- -- Switches for GNAT STUB -- ---------------------------- ! S_Stub_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. *************** package VMS_Data is *** 5955,5960 **** --- 6378,6390 ---- -- Example: -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + S_Stub_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_Stub_Full : aliased constant S := "/FULL " & "-f"; -- /NOFULL (D) *************** package VMS_Data is *** 5983,5995 **** -- preceding the compilation unit) from the source of the -- library unit declaration into the body stub. S_Stub_Indent : aliased constant S := "/INDENTATION=#" & "-i#"; -- /INDENTATION=nnn -- -- (nnn is a non-negative integer). Set the indentation level in the -- generated body stub to nnn. nnn=0 means "no indentation". ! -- Default insdentation is 3. S_Stub_Keep : aliased constant S := "/KEEP " & "-k"; --- 6413,6433 ---- -- preceding the compilation unit) from the source of the -- library unit declaration into the body stub. + S_Stub_Header_File : aliased constant S := "/FROM_HEADER_FILE=<" & + "--header-file=>"; + + -- /FROM_HEADER_FILE==filename + -- + -- Use the content of the file as the comment header for a generated body + -- stub. + S_Stub_Indent : aliased constant S := "/INDENTATION=#" & "-i#"; -- /INDENTATION=nnn -- -- (nnn is a non-negative integer). Set the indentation level in the -- generated body stub to nnn. nnn=0 means "no indentation". ! -- Default indentation is 3. S_Stub_Keep : aliased constant S := "/KEEP " & "-k"; *************** package VMS_Data is *** 6059,6064 **** --- 6497,6510 ---- -- -- When looking for source files also look in directories specified. + S_Stub_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + S_Stub_Tree : aliased constant S := "/TREE_FILE=" & "OVERWRITE " & "-t " & *************** package VMS_Data is *** 6099,6128 **** -- Verbose mode: generate version information. Stub_Switches : aliased constant Switches := ! (S_Stub_Add 'Access, ! S_Stub_Config 'Access, ! S_Stub_Current 'Access, ! S_Stub_Ext 'Access, ! S_Stub_Full 'Access, ! S_Stub_Header 'Access, ! S_Stub_Indent 'Access, ! S_Stub_Keep 'Access, ! S_Stub_Length 'Access, ! S_Stub_Mess 'Access, ! S_Stub_Output 'Access, ! S_Stub_Project 'Access, ! S_Stub_Quiet 'Access, ! S_Stub_Search 'Access, ! S_Stub_Tree 'Access, ! S_Stub_Verbose 'Access); ---------------------------- -- Switches for GNAT XREF -- ---------------------------- ! S_Xref_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH==(directory[,...]) -- -- Add directories to the project search path. --- 6545,6725 ---- -- Verbose mode: generate version information. Stub_Switches : aliased constant Switches := ! (S_Stub_Add 'Access, ! S_Stub_Config 'Access, ! S_Stub_Current 'Access, ! S_Stub_Ext 'Access, ! S_Stub_Follow 'Access, ! S_Stub_Full 'Access, ! S_Stub_Header 'Access, ! S_Stub_Header_File'Access, ! S_Stub_Indent 'Access, ! S_Stub_Keep 'Access, ! S_Stub_Length 'Access, ! S_Stub_Mess 'Access, ! S_Stub_Output 'Access, ! S_Stub_Project 'Access, ! S_Stub_Quiet 'Access, ! S_Stub_Search 'Access, ! S_Stub_Subdirs 'Access, ! S_Stub_Tree 'Access, ! S_Stub_Verbose 'Access); ! ! ---------------------------- ! -- Switches for GNAT SYNC -- ! ---------------------------- ! ! S_Sync_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & ! "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) ! -- ! -- Add directories to the project search path. ! ! S_Sync_All : aliased constant S := "/ALL " & ! "-a"; ! -- /NOALL (D) ! -- /ALL ! -- ! -- Also check the components of the GNAT run time and process the needed ! -- components of the GNAT RTL when building and analyzing the global ! -- structure for checking the global rules. ! ! S_Sync_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & ! "-X" & '"'; ! -- /EXTERNAL_REFERENCE="name=val" ! -- ! -- Specifies an external reference to the project manager. Useful only if ! -- /PROJECT_FILE is used. ! -- ! -- Example: ! -- /EXTERNAL_REFERENCE="DEBUG=TRUE" ! ! S_Sync_Files : aliased constant S := "/FILES=@" & ! "-files=@"; ! -- /FILES=filename ! -- ! -- Take as arguments the files that are listed in the specified ! -- text file. ! ! S_Sync_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & ! "-eL"; ! -- /NOFOLLOW_LINKS_FOR_FILES (D) ! -- /FOLLOW_LINKS_FOR_FILES ! -- ! -- Follow links when parsing project files ! ! S_Sync_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & ! "DEFAULT " & ! "-vP0 " & ! "MEDIUM " & ! "-vP1 " & ! "HIGH " & ! "-vP2"; ! -- /MESSAGES_PROJECT_FILE[=messages-option] ! -- ! -- Specifies the "verbosity" of the parsing of project files. ! -- messages-option may be one of the following: ! -- ! -- DEFAULT (D) No messages are output if there is no error or warning. ! -- ! -- MEDIUM A small number of messages are output. ! -- ! -- HIGH A great number of messages are output, most of them not ! -- being useful for the user. ! ! S_Sync_Project : aliased constant S := "/PROJECT_FILE=<" & ! "-P>"; ! -- /PROJECT_FILE=filename ! -- ! -- Specifies the main project file to be used. The project files rooted ! -- at the main project file will be parsed before the invocation of the ! -- gnatcheck. The source directories to be searched will be communicated ! -- to gnatcheck through logical name ADA_PRJ_INCLUDE_FILE. ! ! S_Sync_Quiet : aliased constant S := "/QUIET " & ! "-q"; ! -- /NOQUIET (D) ! -- /QUIET ! -- ! -- Work quietly, only output warnings and errors. ! ! S_Sync_Subdirs : aliased constant S := "/SUBDIRS=<" & ! "--subdirs=>"; ! -- /SUBDIRS=dir ! -- ! -- The actual directories (object, exec, library, ...) are subdirectories ! -- of the directory specified in the project file. If the subdirectory ! -- does not exist, it is created automatically. ! ! S_Sync_Verb : aliased constant S := "/VERBOSE " & ! "-v"; ! -- /NOVERBOSE (D) ! -- /VERBOSE ! -- ! -- The version number and copyright notice are output, as well as exact ! -- copies of the gnat1 commands spawned to obtain the chop control ! -- information. ! ! S_Sync_Exec : aliased constant S := "/EXECUTION_TIME " & ! "-t"; ! -- /NOEXECUTION_TIME (D) ! -- /EXECUTION_TIME ! -- ! -- Output the execution time ! ! S_Sync_Details : aliased constant S := "/DETAILS=" & ! "MEDIUM " & ! "-om " & ! "SHORT " & ! "-os " & ! "FULL " & ! "-of"; ! -- /DETAILS[=options] ! -- ! -- Specifies the details of the output. ! -- Options may be one of the following: ! -- ! -- MEDIUM (D) ! -- SHORT ! -- FULL ! ! S_Sync_Warnoff : aliased constant S := "/WARNINGS_OFF " & ! "-wq"; ! -- ! -- /WARNINGS_OFF ! -- ! -- Turn warnings off ! ! S_Sync_Output : aliased constant S := "/OUTPUT_FILE=<" & ! "-out_file=>"; ! -- ! -- /OUTPUT_FILE=filename ! -- ! -- Redirect output to a text file ! ! Sync_Switches : aliased constant Switches := ! (S_Sync_Add 'Access, ! S_Sync_All 'Access, ! S_Sync_Ext 'Access, ! S_Sync_Follow 'Access, ! S_Sync_Files 'Access, ! S_Sync_Mess 'Access, ! S_Sync_Project 'Access, ! S_Sync_Quiet 'Access, ! S_Sync_Subdirs 'Access, ! S_Sync_Verb 'Access, ! S_Sync_Exec 'Access, ! S_Sync_Details 'Access, ! S_Sync_Warnoff 'Access, ! S_Sync_Output 'Access); ---------------------------- -- Switches for GNAT XREF -- ---------------------------- ! S_Xref_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; ! -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) -- -- Add directories to the project search path. *************** package VMS_Data is *** 6154,6159 **** --- 6751,6763 ---- -- Example: -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + S_Xref_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + S_Xref_Full : aliased constant S := "/FULL_PATHNAME " & "-f"; -- /NOFULL_PATHNAME (D) *************** package VMS_Data is *** 6248,6253 **** --- 6852,6865 ---- -- The order in which source file search is undertaken is the same as for -- MAKE. + S_Xref_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + S_Xref_Output : aliased constant S := "/UNUSED " & "-u"; -- /SOURCE_SEARCH=(directory,...) *************** package VMS_Data is *** 6268,6273 **** --- 6880,6886 ---- S_Xref_All 'Access, S_Xref_Deriv 'Access, S_Xref_Ext 'Access, + S_Xref_Follow 'Access, S_Xref_Full 'Access, S_Xref_Global 'Access, S_Xref_Mess 'Access, *************** package VMS_Data is *** 6278,6283 **** --- 6891,6897 ---- S_Xref_Prj 'Access, S_Xref_Search 'Access, S_Xref_Source 'Access, + S_Xref_Subdirs 'Access, S_Xref_Output 'Access, S_Xref_Tags 'Access); diff -Nrcpad gcc-4.3.3/gcc/ada/vx_stack_info.c gcc-4.4.0/gcc/ada/vx_stack_info.c *** gcc-4.3.3/gcc/ada/vx_stack_info.c Thu Dec 13 10:52:39 2007 --- gcc-4.4.0/gcc/ada/vx_stack_info.c Thu Apr 9 23:23:07 2009 *************** *** 6,29 **** * * * C Implementation File * * * ! * Copyright (C) 2007, 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- * ! * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * ! * for more details. You should have received a copy of the GNU General * ! * Public License distributed with GNAT; see file COPYING. If not, write * ! * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * ! * Boston, MA 02110-1301, USA. * * * ! * As a special exception, if you link this file with other files to * ! * produce an executable, this file does not by itself cause the resulting * ! * executable to be covered by the GNU General Public License. This except- * ! * ion does not however invalidate any other reasons why the executable * ! * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * --- 6,28 ---- * * * C Implementation File * * * ! * Copyright (C) 2007-2009 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- * ! * ware Foundation; either version 3, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * ! * or FITNESS FOR A PARTICULAR PURPOSE. * * * ! * As a special exception under Section 7 of GPL version 3, you are granted * ! * additional permissions described in the GCC Runtime Library Exception, * ! * version 3.1, as published by the Free Software Foundation. * ! * * ! * You should have received a copy of the GNU General Public License and * ! * a copy of the GCC Runtime Library Exception along with this program; * ! * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * ! * . * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * diff -Nrcpad gcc-4.3.3/gcc/ada/vxaddr2line.adb gcc-4.4.0/gcc/ada/vxaddr2line.adb *** gcc-4.3.3/gcc/ada/vxaddr2line.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/vxaddr2line.adb Tue Apr 8 06:56:49 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2007, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2008, AdaCore -- -- -- -- 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- -- *************** *** 62,79 **** -- (in a format _), and then an appropriate value to Config_List -- array ! with Text_IO; use Text_IO; ! with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; ! with Ada.Command_Line; use Ada.Command_Line; ! with Ada.Strings.Fixed; use Ada.Strings.Fixed; ! with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Directory_Operations; use GNAT.Directory_Operations; ! with GNAT.Expect; use GNAT.Expect; ! with GNAT.Regpat; use GNAT.Regpat; procedure VxAddr2Line is Ref_Symbol : constant String := "adainit"; -- This is the name of the reference symbol which runtime address shall -- be provided as the argument. --- 62,82 ---- -- (in a format _), and then an appropriate value to Config_List -- array ! with Ada.Text_IO; use Ada.Text_IO; ! with Ada.Command_Line; use Ada.Command_Line; ! with Ada.Strings.Fixed; use Ada.Strings.Fixed; ! with Interfaces; use Interfaces; ! with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Directory_Operations; use GNAT.Directory_Operations; ! with GNAT.Expect; use GNAT.Expect; ! with GNAT.Regpat; use GNAT.Regpat; procedure VxAddr2Line is + package Unsigned_32_IO is new Modular_IO (Unsigned_32); + -- Instantiate Modular_IO to have Put. + Ref_Symbol : constant String := "adainit"; -- This is the name of the reference symbol which runtime address shall -- be provided as the argument. *************** procedure VxAddr2Line is *** 102,108 **** -- which will avoid computational overflows. Typically only useful when -- 64bit addresses are provided. ! Bt_Offset_From_Call : Integer; -- Offset from a backtrace address to the address of the corresponding -- call instruction. This should always be 0, except on platforms where -- the backtrace addresses actually correspond to return and not call --- 105,111 ---- -- which will avoid computational overflows. Typically only useful when -- 64bit addresses are provided. ! Bt_Offset_From_Call : Unsigned_32; -- Offset from a backtrace address to the address of the corresponding -- call instruction. This should always be 0, except on platforms where -- the backtrace addresses actually correspond to return and not call *************** procedure VxAddr2Line is *** 160,173 **** procedure Usage; -- Displays the short help message and then terminates the program ! function Get_Reference_Offset return Integer; -- Computes the static offset of the reference symbol by calling nm ! function Get_Value_From_Hex_Arg (Arg : Natural) return Integer; -- Threats the argument number Arg as a C-style hexadecimal literal -- and returns its integer value ! function Hex_Image (Value : Integer) return String_Access; -- Returns access to a string that contains hexadecimal image of Value -- Separate functions that provide build-time customization: --- 163,176 ---- procedure Usage; -- Displays the short help message and then terminates the program ! function Get_Reference_Offset return Unsigned_32; -- Computes the static offset of the reference symbol by calling nm ! function Get_Value_From_Hex_Arg (Arg : Natural) return Unsigned_32; -- Threats the argument number Arg as a C-style hexadecimal literal -- and returns its integer value ! function Hex_Image (Value : Unsigned_32) return String_Access; -- Returns access to a string that contains hexadecimal image of Value -- Separate functions that provide build-time customization: *************** procedure VxAddr2Line is *** 238,244 **** -- Get_Reference_Offset -- -------------------------- ! function Get_Reference_Offset return Integer is Nm_Cmd : constant String_Access := Locate_Exec_On_Path (Arch_List (Cur_Arch).Nm_Binary.all); --- 241,247 ---- -- Get_Reference_Offset -- -------------------------- ! function Get_Reference_Offset return Unsigned_32 is Nm_Cmd : constant String_Access := Locate_Exec_On_Path (Arch_List (Cur_Arch).Nm_Binary.all); *************** procedure VxAddr2Line is *** 273,283 **** declare Match_String : constant String := Expect_Out_Match (Pd); Matches : Match_Array (0 .. 1); ! Value : Integer; begin Match (Reference, Match_String, Matches); ! Value := Integer'Value ("16#" & Match_String (Matches (1).First .. Matches (1).Last) & "#"); --- 276,286 ---- declare Match_String : constant String := Expect_Out_Match (Pd); Matches : Match_Array (0 .. 1); ! Value : Unsigned_32; begin Match (Reference, Match_String, Matches); ! Value := Unsigned_32'Value ("16#" & Match_String (Matches (1).First .. Matches (1).Last) & "#"); *************** procedure VxAddr2Line is *** 313,319 **** -- Get_Value_From_Hex_Arg -- ---------------------------- ! function Get_Value_From_Hex_Arg (Arg : Natural) return Integer is Cur_Arg : constant String := Argument (Arg); Offset : Natural; --- 316,322 ---- -- Get_Value_From_Hex_Arg -- ---------------------------- ! function Get_Value_From_Hex_Arg (Arg : Natural) return Unsigned_32 is Cur_Arg : constant String := Argument (Arg); Offset : Natural; *************** procedure VxAddr2Line is *** 332,350 **** -- Convert to value ! return Integer'Value ("16#" & Cur_Arg (Offset .. Cur_Arg'Last) & "#"); end Get_Value_From_Hex_Arg; --------------- -- Hex_Image -- --------------- ! function Hex_Image (Value : Integer) return String_Access is Result : String (1 .. 20); Start_Pos : Natural; begin ! Put (Result, Value, 16); Start_Pos := Index (Result, "16#") + 3; return new String'(Result (Start_Pos .. Result'Last - 1)); end Hex_Image; --- 335,360 ---- -- Convert to value ! return Unsigned_32'Value ! ("16#" & Cur_Arg (Offset .. Cur_Arg'Last) & "#"); ! ! exception ! when Constraint_Error => ! ! Error ("Can't parse backtrace address '" & Cur_Arg & "'"); ! raise; end Get_Value_From_Hex_Arg; --------------- -- Hex_Image -- --------------- ! function Hex_Image (Value : Unsigned_32) return String_Access is Result : String (1 .. 20); Start_Pos : Natural; begin ! Unsigned_32_IO.Put (Result, Value, 16); Start_Pos := Index (Result, "16#") + 3; return new String'(Result (Start_Pos .. Result'Last - 1)); end Hex_Image; *************** procedure VxAddr2Line is *** 362,368 **** OS_Exit (1); end Usage; ! Ref_Static_Offset, Ref_Runtime_Address, Bt_Address : Integer; Addr2line_Cmd : String_Access; --- 372,378 ---- OS_Exit (1); end Usage; ! Ref_Static_Offset, Ref_Runtime_Address, Bt_Address : Unsigned_32; Addr2line_Cmd : String_Access; diff -Nrcpad gcc-4.3.3/gcc/ada/widechar.adb gcc-4.4.0/gcc/ada/widechar.adb *** gcc-4.3.3/gcc/ada/widechar.adb Tue Oct 31 18:12:08 2006 --- gcc-4.4.0/gcc/ada/widechar.adb Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2006, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package body Widechar is *** 121,132 **** function WC_In is new Char_Sequence_To_UTF_32 (In_Char); ! -- Start of processingf for Scan_Wide begin Chr := In_Char; ! -- Scan out the wide character. if the first character is a bracket, -- we allow brackets encoding regardless of the standard encoding -- method being used, but otherwise we use this standard method. --- 119,130 ---- function WC_In is new Char_Sequence_To_UTF_32 (In_Char); ! -- Start of processing for Scan_Wide begin Chr := In_Char; ! -- Scan out the wide character. If the first character is a bracket, -- we allow brackets encoding regardless of the standard encoding -- method being used, but otherwise we use this standard method. diff -Nrcpad gcc-4.3.3/gcc/ada/widechar.ads gcc-4.4.0/gcc/ada/widechar.ads *** gcc-4.3.3/gcc/ada/widechar.ads Tue Nov 15 14:06:45 2005 --- gcc-4.4.0/gcc/ada/widechar.ads Thu Apr 9 23:23:07 2009 *************** *** 6,30 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005, 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- -- ! -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- ! -- for more details. You should have received a copy of the GNU General -- ! -- Public License distributed with GNAT; see file COPYING. If not, write -- ! -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- ! -- Boston, MA 02110-1301, USA. -- -- -- ! -- As a special exception, if other files instantiate generics from this -- ! -- unit, or you link this unit with other files to produce an executable, -- ! -- this unit does not by itself cause the resulting executable to be -- ! -- covered by the GNU General Public License. This exception does not -- ! -- however invalidate any other reasons why the executable file might be -- ! -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- --- 6,28 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009 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- -- ! -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- ! -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- ! -- As a special exception under Section 7 of GPL version 3, you are granted -- ! -- additional permissions described in the GCC Runtime Library Exception, -- ! -- version 3.1, as published by the Free Software Foundation. -- ! -- -- ! -- You should have received a copy of the GNU General Public License and -- ! -- a copy of the GCC Runtime Library Exception along with this program; -- ! -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- ! -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- *************** package Widechar is *** 43,49 **** Wide_Char_Byte_Count : Nat := 0; -- This value is incremented whenever Scan_Wide or Skip_Wide is called. -- The amount added is the length of the wide character sequence minus ! -- one. This means that the count that accululates here represents the -- difference between the length in characters and the length in bytes. -- This is used for checking the line length in characters. --- 41,47 ---- Wide_Char_Byte_Count : Nat := 0; -- This value is incremented whenever Scan_Wide or Skip_Wide is called. -- The amount added is the length of the wide character sequence minus ! -- one. This means that the count that accumulates here represents the -- difference between the length in characters and the length in bytes. -- This is used for checking the line length in characters. diff -Nrcpad gcc-4.3.3/gcc/ada/xeinfo.adb gcc-4.4.0/gcc/ada/xeinfo.adb *** gcc-4.3.3/gcc/ada/xeinfo.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/xeinfo.adb Sun Apr 13 18:03:09 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** procedure XEinfo is *** 63,71 **** Err : exception; - pragma Warnings (Off); - -- These seem not to be referenced, but they are (by * operator) - A : VString := Nul; B : VString := Nul; C : VString := Nul; --- 63,68 ---- *************** procedure XEinfo is *** 88,95 **** Rtn : VString := Nul; Term : VString := Nul; - pragma Warnings (On); - InB : File_Type; -- Used to read initial header from body --- 85,90 ---- *************** begin *** 385,391 **** while Match (Line, Get_FN) loop ! -- Non-inlined funcion if not Present (Inlined, FN) then Put_Line (Ofile, ""); --- 380,386 ---- while Match (Line, Get_FN) loop ! -- Non-inlined function if not Present (Inlined, FN) then Put_Line (Ofile, ""); *************** begin *** 444,450 **** Line := Getlin; exit when not Match (Line, Get_Asrt); ! -- Pragma asser found, get its continuation lines loop exit when Match (Line, Semicoln); --- 439,445 ---- Line := Getlin; exit when not Match (Line, Get_Asrt); ! -- Pragma assert found, get its continuation lines loop exit when Match (Line, Semicoln); *************** begin *** 457,463 **** Match (Line, Get_Cmnt, M); Replace (M, A); ! -- Get continuations of return statemnt while not Match (Line, Semicoln) loop Nextlin := Getlin; --- 452,458 ---- Match (Line, Get_Cmnt, M); Replace (M, A); ! -- Get continuations of return statement while not Match (Line, Semicoln) loop Nextlin := Getlin; diff -Nrcpad gcc-4.3.3/gcc/ada/xgnatugn.adb gcc-4.4.0/gcc/ada/xgnatugn.adb *** gcc-4.3.3/gcc/ada/xgnatugn.adb Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/xgnatugn.adb Mon Apr 14 09:39:39 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2008, 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- -- *************** *** 64,70 **** -- appropriate vms equivalents. Note that replacements do not occur -- within ^alpha^beta^ sequences. ! -- Any occurence of [filename].extension, where extension one of the -- following: -- "o", "ads", "adb", "ali", "ada", "atb", "ats", "adc", "c" --- 64,70 ---- -- appropriate vms equivalents. Note that replacements do not occur -- within ^alpha^beta^ sequences. ! -- Any occurrence of [filename].extension, where extension one of the -- following: -- "o", "ads", "adb", "ali", "ada", "atb", "ats", "adc", "c" *************** with Ada.Strings.Fixed; use Ada *** 97,102 **** --- 97,103 ---- with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Strings.Maps; use Ada.Strings.Maps; with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; + with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Spitbol; use GNAT.Spitbol; *************** procedure Xgnatugn is *** 108,119 **** -- Print usage information. Invoked if an invalid command line is -- encountered. ! Output_File : File_Type; -- The preprocessed output is written to this file type Input_File is record Name : VString; ! Data : File_Type; Line : Natural := 0; end record; -- Records information on an input file. Name and Line are used --- 109,122 ---- -- Print usage information. Invoked if an invalid command line is -- encountered. ! subtype Sfile is Ada.Streams.Stream_IO.File_Type; ! ! Output_File : Sfile; -- The preprocessed output is written to this file type Input_File is record Name : VString; ! Data : Ada.Text_IO.File_Type; Line : Natural := 0; end record; -- Records information on an input file. Name and Line are used *************** procedure Xgnatugn is *** 123,128 **** --- 126,135 ---- -- Returns a line from Input and performs the necessary -- line-oriented checks (length, character set, trailing spaces). + procedure Put_Line (F : Sfile; S : String); + procedure Put_Line (F : Sfile; S : VString); + -- Local version of Put_Line ensures Unix style line endings + Number_Of_Warnings : Natural := 0; Number_Of_Errors : Natural := 0; Warnings_Enabled : Boolean; *************** procedure Xgnatugn is *** 352,357 **** --- 359,379 ---- end; end Get_Line; + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (F : Sfile; S : String) is + begin + String'Write (Stream (F), S); + Character'Write (Stream (F), ASCII.LF); + end Put_Line; + + procedure Put_Line (F : Sfile; S : VString) is + begin + Put_Line (F, To_String (S)); + end Put_Line; + ----------- -- Error -- ----------- *************** begin *** 1311,1317 **** Open (Source_File.Data, In_File, Argument (2)); exception ! when Name_Error => Valid_Command_Line := False; end; end if; --- 1333,1339 ---- Open (Source_File.Data, In_File, Argument (2)); exception ! when Ada.Text_IO.Name_Error => Valid_Command_Line := False; end; end if; *************** begin *** 1324,1330 **** Open (Dictionary_File.Data, In_File, Argument (3)); exception ! when Name_Error => Valid_Command_Line := False; end; end if; --- 1346,1352 ---- Open (Dictionary_File.Data, In_File, Argument (3)); exception ! when Ada.Text_IO.Name_Error => Valid_Command_Line := False; end; end if; *************** begin *** 1349,1355 **** Create (Output_File, Out_File, S (Output_File_Name)); exception ! when Name_Error | Use_Error => Valid_Command_Line := False; end; end if; --- 1371,1377 ---- Create (Output_File, Out_File, S (Output_File_Name)); exception ! when Ada.Text_IO.Name_Error | Ada.Text_IO.Use_Error => Valid_Command_Line := False; end; end if; diff -Nrcpad gcc-4.3.3/gcc/ada/xnmake.adb gcc-4.4.0/gcc/ada/xnmake.adb *** gcc-4.3.3/gcc/ada/xnmake.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/xnmake.adb Wed Aug 6 08:31:51 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** with Ada.Text_IO; use *** 58,71 **** with GNAT.Spitbol; use GNAT.Spitbol; with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; procedure XNmake is Err : exception; -- Raised to terminate execution - pragma Warnings (Off); - -- The following are modified by * operator - A : VString := Nul; Arg : VString := Nul; Arg_List : VString := Nul; --- 58,70 ---- with GNAT.Spitbol; use GNAT.Spitbol; with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; + with XUtil; + procedure XNmake is Err : exception; -- Raised to terminate execution A : VString := Nul; Arg : VString := Nul; Arg_List : VString := Nul; *************** procedure XNmake is *** 140,147 **** V_Elist_Id : constant VString := V ("Elist_Id"); V_Boolean : constant VString := V ("Boolean"); ! procedure Put_Line (F : Sfile; S : String); ! procedure Put_Line (F : Sfile; S : VString); -- Local version of Put_Line ensures Unix style line endings procedure WriteS (S : String); --- 139,146 ---- V_Elist_Id : constant VString := V ("Elist_Id"); V_Boolean : constant VString := V ("Boolean"); ! procedure Put_Line (F : Sfile; S : String) renames XUtil.Put_Line; ! procedure Put_Line (F : Sfile; S : VString) renames XUtil.Put_Line; -- Local version of Put_Line ensures Unix style line endings procedure WriteS (S : String); *************** procedure XNmake is *** 202,218 **** end if; end WriteS; - procedure Put_Line (F : Sfile; S : String) is - begin - String'Write (Stream (F), S); - Character'Write (Stream (F), ASCII.LF); - end Put_Line; - - procedure Put_Line (F : Sfile; S : VString) is - begin - Put_Line (F, To_String (S)); - end Put_Line; - -- Start of processing for XNmake begin --- 201,206 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/xoscons.adb gcc-4.4.0/gcc/ada/xoscons.adb *** gcc-4.3.3/gcc/ada/xoscons.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/xoscons.adb Tue Aug 5 13:26:24 2008 *************** *** 0 **** --- 1,419 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT SYSTEM UTILITIES -- + -- -- + -- X O S C O N S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This program generates the spec of System.OS_Constants (s-oscons.ads). + + -- It works in conjunction with a C template file which must be pre-processed + -- and compiled using the cross compiler. Two input files are used: + -- - the preprocessed C file: s-oscons-tmplt.i + -- - the generated assembly file: s-oscons-tmplt.s + + -- The contents of s-oscons.ads is written on standard output. + + with Ada.Characters.Handling; use Ada.Characters.Handling; + with Ada.Exceptions; use Ada.Exceptions; + with Ada.Strings.Fixed; use Ada.Strings.Fixed; + with Ada.Text_IO; use Ada.Text_IO; + with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; + + pragma Warnings (Off); + -- System.Unsigned_Types is an internal GNAT unit + with System.Unsigned_Types; use System.Unsigned_Types; + pragma Warnings (On); + + with GNAT.Table; + + with XUtil; use XUtil; + + procedure XOSCons is + + use ASCII; + use Ada.Strings; + + Unit_Name : constant String := "s-oscons"; + Tmpl_Name : constant String := Unit_Name & "-tmplt"; + + ------------------------------------------------- + -- Information retrieved from assembly listing -- + ------------------------------------------------- + + -- We need to deal with integer values that can be signed or unsigned, + -- so we need to cater for the maximum range of both cases. + + type String_Access is access all String; + -- Note: we can't use GNAT.Strings for this definition, since that unit + -- is not available in older base compilers. + + type Int_Value_Type is record + Positive : Boolean; + Abs_Value : Long_Unsigned := 0; + end record; + + type Asm_Info_Kind is + (CND, -- Constant (decimal) + CNS, -- Constant (freeform string) + TXT); -- Literal text + -- Recognized markers found in assembly file. These markers are produced + -- by the same-named macros from the C template. + + type Asm_Info (Kind : Asm_Info_Kind := TXT) is record + Line_Number : Integer; + -- Line number in C source file + + Constant_Name : String_Access; + -- Name of constant to be defined + + Value_Len : Natural := 0; + -- Length of text representation of constant's value + + Text_Value : String_Access; + -- Value for CNS constant + + Int_Value : Int_Value_Type; + -- Value for CND constant + + Comment : String_Access; + -- Additional descriptive comment for constant, or free-form text (TXT) + end record; + + package Asm_Infos is new GNAT.Table ( + Table_Component_Type => Asm_Info, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 10); + + Max_Constant_Name_Len : Natural := 0; + Max_Constant_Value_Len : Natural := 0; + -- Longest name and longest value lengths + + procedure Output_Info (OFile : Sfile; Info_Index : Integer); + -- Output information from the indicated asm info line + + procedure Parse_Asm_Line (Line : String); + -- Parse one information line from the assembly source + + function Contains_Template_Name (S : String) return Boolean; + -- True if S contains Tmpl_Name, possibly with different casing + + function Spaces (Count : Integer) return String; + -- If Count is positive, return a string of Count spaces, else return an + -- empty string. + + ---------------------------- + -- Contains_Template_Name -- + ---------------------------- + + function Contains_Template_Name (S : String) return Boolean is + begin + return Index (Source => To_Lower (S), Pattern => Tmpl_Name) > 0; + end Contains_Template_Name; + + ----------------- + -- Output_Info -- + ----------------- + + procedure Output_Info (OFile : Sfile; Info_Index : Integer) is + Info : Asm_Info renames Asm_Infos.Table (Info_Index); + + procedure Put (S : String); + + --------- + -- Put -- + --------- + + procedure Put (S : String) is + begin + Put (OFile, S); + end Put; + + begin + if Info.Kind /= TXT then + -- TXT case is handled by the common code below + + Put (" "); + Put (Info.Constant_Name.all); + Put (Spaces (Max_Constant_Name_Len - Info.Constant_Name'Length)); + + Put (" : constant := "); + + if Info.Kind = CND then + if not Info.Int_Value.Positive then + Put ("-"); + end if; + Put (Trim (Info.Int_Value.Abs_Value'Img, Side => Left)); + else + Put (Info.Text_Value.all); + end if; + + Put (";"); + + if Info.Comment'Length > 0 then + Put (Spaces (Max_Constant_Value_Len - Info.Value_Len)); + Put (" -- "); + end if; + end if; + + Put (Info.Comment.all); + New_Line (OFile); + end Output_Info; + + -------------------- + -- Parse_Asm_Line -- + -------------------- + + procedure Parse_Asm_Line (Line : String) is + Index1, Index2 : Integer := Line'First; + + function Field_Alloc return String_Access; + -- Allocate and return a copy of Line (Index1 .. Index2 - 1) + + procedure Find_Colon (Index : in out Integer); + -- Increment Index until the next colon in Line + + function Parse_Int (S : String) return Int_Value_Type; + -- Parse a decimal number, preceded by an optional '$' or '#' character, + -- and return its value. + + ----------------- + -- Field_Alloc -- + ----------------- + + function Field_Alloc return String_Access is + begin + return new String'(Line (Index1 .. Index2 - 1)); + end Field_Alloc; + + ---------------- + -- Find_Colon -- + ---------------- + + procedure Find_Colon (Index : in out Integer) is + begin + loop + Index := Index + 1; + exit when Index > Line'Last or else Line (Index) = ':'; + end loop; + end Find_Colon; + + --------------- + -- Parse_Int -- + --------------- + + function Parse_Int (S : String) return Int_Value_Type is + First : Integer := S'First; + Positive : Boolean; + begin + -- On some platforms, immediate integer values are prefixed with + -- a $ or # character in assembly output. + + if S (First) = '$' + or else S (First) = '#' + then + First := First + 1; + end if; + + if S (First) = '-' then + Positive := False; + First := First + 1; + else + Positive := True; + end if; + + return (Positive => Positive, + Abs_Value => Long_Unsigned'Value (S (First .. S'Last))); + + exception + when E : others => + Put_Line (Standard_Error, "can't parse decimal value: " & S); + raise; + end Parse_Int; + + -- Start of processing for Parse_Asm_Line + + begin + Find_Colon (Index2); + + declare + Info : Asm_Info (Kind => Asm_Info_Kind'Value + (Line (Line'First .. Index2 - 1))); + begin + Index1 := Index2 + 1; + Find_Colon (Index2); + + Info.Line_Number := + Integer (Parse_Int (Line (Index1 .. Index2 - 1)).Abs_Value); + + case Info.Kind is + when CND | CNS => + Index1 := Index2 + 1; + Find_Colon (Index2); + + Info.Constant_Name := Field_Alloc; + if Info.Constant_Name'Length > Max_Constant_Name_Len then + Max_Constant_Name_Len := Info.Constant_Name'Length; + end if; + + Index1 := Index2 + 1; + Find_Colon (Index2); + + if Info.Kind = CND then + Info.Int_Value := Parse_Int (Line (Index1 .. Index2 - 1)); + Info.Value_Len := Index2 - Index1 - 1; + else + Info.Text_Value := Field_Alloc; + Info.Value_Len := Info.Text_Value'Length; + end if; + + when others => + null; + end case; + + Index1 := Index2 + 1; + Index2 := Line'Last + 1; + Info.Comment := Field_Alloc; + + if Info.Kind = TXT then + Info.Text_Value := Info.Comment; + + -- Update Max_Constant_Value_Len, but only if this constant has + -- a comment (else the value is allowed to be longer). + + elsif Info.Comment'Length > 0 then + if Info.Value_Len > Max_Constant_Value_Len then + Max_Constant_Value_Len := Info.Value_Len; + end if; + end if; + + Asm_Infos.Append (Info); + end; + exception + when E : others => + Put_Line (Standard_Error, + "can't parse " & Line); + Put_Line (Standard_Error, + "exception raised: " & Exception_Information (E)); + end Parse_Asm_Line; + + ------------ + -- Spaces -- + ------------ + + function Spaces (Count : Integer) return String is + begin + if Count <= 0 then + return ""; + else + return (1 .. Count => ' '); + end if; + end Spaces; + + -- Local declarations + + Asm_File_Name : constant String := Tmpl_Name & ".s"; + Tmpl_File_Name : constant String := Tmpl_Name & ".i"; + Ada_File_Name : constant String := Unit_Name & ".ads"; + + Asm_File : Ada.Text_IO.File_Type; + Tmpl_File : Ada.Text_IO.File_Type; + OFile : Sfile; + + Line : String (1 .. 256); + Last : Integer; + -- Line being processed + + Current_Line : Integer; + Current_Info : Integer; + In_Comment : Boolean; + In_Template : Boolean; + + -- Start of processing for XOSCons + + begin + -- Load values from assembly file + + Open (Asm_File, In_File, Asm_File_Name); + + while not End_Of_File (Asm_File) loop + Get_Line (Asm_File, Line, Last); + if Last > 2 and then Line (1 .. 2) = "->" then + Parse_Asm_Line (Line (3 .. Last)); + end if; + end loop; + + Close (Asm_File); + + -- Load C template and output definitions + + Open (Tmpl_File, In_File, Tmpl_File_Name); + Create (OFile, Out_File, Ada_File_Name); + + Current_Line := 0; + Current_Info := Asm_Infos.First; + In_Comment := False; + + while not End_Of_File (Tmpl_File) loop + <> + Get_Line (Tmpl_File, Line, Last); + + if Last >= 2 and then Line (1 .. 2) = "# " then + declare + Index : Integer := 3; + begin + while Index <= Last and then Line (Index) in '0' .. '9' loop + Index := Index + 1; + end loop; + + if Contains_Template_Name (Line (Index + 1 .. Last)) then + Current_Line := Integer'Value (Line (3 .. Index - 1)); + In_Template := True; + goto Get_One_Line; + else + In_Template := False; + end if; + end; + + elsif In_Template then + if In_Comment then + if Line (1 .. Last) = "*/" then + In_Comment := False; + else + Put_Line (OFile, Line (1 .. Last)); + end if; + + elsif Line (1 .. Last) = "/*" then + In_Comment := True; + + elsif Asm_Infos.Table (Current_Info).Line_Number = Current_Line then + Output_Info (OFile, Current_Info); + Current_Info := Current_Info + 1; + end if; + Current_Line := Current_Line + 1; + end if; + end loop; + + Close (Tmpl_File); + + end XOSCons; diff -Nrcpad gcc-4.3.3/gcc/ada/xr_tabls.adb gcc-4.4.0/gcc/ada/xr_tabls.adb *** gcc-4.3.3/gcc/ada/xr_tabls.adb Mon Oct 15 13:57:46 2007 --- gcc-4.4.0/gcc/ada/xr_tabls.adb Sun Apr 13 18:03:09 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2008, 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- -- *************** package body Xr_Tabls is *** 49,55 **** function Get_Key (E : File_Reference) return Cst_String_Access; function Hash (F : Cst_String_Access) return HTable_Headers; function Equal (F1, F2 : Cst_String_Access) return Boolean; ! -- The five subprograms above are used to instanciate the static -- htable to store the files that should be processed. package File_HTable is new GNAT.HTable.Static_HTable --- 49,55 ---- function Get_Key (E : File_Reference) return Cst_String_Access; function Hash (F : Cst_String_Access) return HTable_Headers; function Equal (F1, F2 : Cst_String_Access) return Boolean; ! -- The five subprograms above are used to instantiate the static -- htable to store the files that should be processed. package File_HTable is new GNAT.HTable.Static_HTable *************** package body Xr_Tabls is *** 81,87 **** function Next (E : Declaration_Reference) return Declaration_Reference; procedure Set_Next (E, Next : Declaration_Reference); function Get_Key (E : Declaration_Reference) return Cst_String_Access; ! -- The subprograms above are used to instanciate the static -- htable to store the entities that have been found in the application package Entities_HTable is new GNAT.HTable.Static_HTable --- 81,87 ---- function Next (E : Declaration_Reference) return Declaration_Reference; procedure Set_Next (E, Next : Declaration_Reference); function Get_Key (E : Declaration_Reference) return Cst_String_Access; ! -- The subprograms above are used to instantiate the static -- htable to store the entities that have been found in the application package Entities_HTable is new GNAT.HTable.Static_HTable *************** package body Xr_Tabls is *** 1389,1395 **** File_Ref.Visited := False; -- ??? Do not add a source file to the list. This is true at ! -- least for gnatxref, and probably for gnatfind as wel if F'Length > 4 and then F (F'Last - 3 .. F'Last) = ".ali" --- 1389,1395 ---- File_Ref.Visited := False; -- ??? Do not add a source file to the list. This is true at ! -- least for gnatxref, and probably for gnatfind as well if F'Length > 4 and then F (F'Last - 3 .. F'Last) = ".ali" diff -Nrcpad gcc-4.3.3/gcc/ada/xr_tabls.ads gcc-4.4.0/gcc/ada/xr_tabls.ads *** gcc-4.3.3/gcc/ada/xr_tabls.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/xr_tabls.ads Sun Apr 13 18:03:09 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2008, 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- -- *************** package Xr_Tabls is *** 140,146 **** (Sorted : Boolean := True) return Declaration_Array_Access; -- Return a sorted list of all the declarations in the application. ! -- Freeing this array is the responsability of the caller, however it -- shouldn't free the actual contents of the array, which are pointers -- to internal data --- 140,146 ---- (Sorted : Boolean := True) return Declaration_Array_Access; -- Return a sorted list of all the declarations in the application. ! -- Freeing this array is the responsibility of the caller, however it -- shouldn't free the actual contents of the array, which are pointers -- to internal data *************** package Xr_Tabls is *** 274,280 **** procedure Reset_Directory (File : File_Reference); -- Reset the cached directory for file. Next time Get_File is called, the ! -- directory willl be recomputed. procedure Set_Unvisited (File_Ref : File_Reference); -- Set File_Ref as unvisited. So Next_Unvisited_File will return it --- 274,280 ---- procedure Reset_Directory (File : File_Reference); -- Reset the cached directory for file. Next time Get_File is called, the ! -- directory will be recomputed. procedure Set_Unvisited (File_Ref : File_Reference); -- Set File_Ref as unvisited. So Next_Unvisited_File will return it *************** package Xr_Tabls is *** 282,288 **** procedure Read_File (File_Name : String; Contents : out GNAT.OS_Lib.String_Access); ! -- Reads File_Name into the newly allocated strig Contents. Types.EOF -- character will be added to the returned Contents to simplify parsing. -- Name_Error is raised if the file was not found. End_Error is raised if -- the file could not be read correctly. For most systems correct reading --- 282,288 ---- procedure Read_File (File_Name : String; Contents : out GNAT.OS_Lib.String_Access); ! -- Reads File_Name into the newly allocated string Contents. Types.EOF -- character will be added to the returned Contents to simplify parsing. -- Name_Error is raised if the file was not found. End_Error is raised if -- the file could not be read correctly. For most systems correct reading diff -Nrcpad gcc-4.3.3/gcc/ada/xref_lib.adb gcc-4.4.0/gcc/ada/xref_lib.adb *** gcc-4.3.3/gcc/ada/xref_lib.adb Mon Oct 15 13:57:46 2007 --- gcc-4.4.0/gcc/ada/xref_lib.adb Fri Aug 1 07:38:08 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2008, 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- -- *************** package body Xref_Lib is *** 109,115 **** (Source : not null access String; Ptr : in out Positive; Number : out Natural); ! -- Skips any separators and parses Source upto the first character that -- is not a decimal digit. Returns value of parsed digits or 0 if none. procedure Parse_X_Filename (File : in out ALI_File); --- 109,115 ---- (Source : not null access String; Ptr : in out Positive; Number : out Natural); ! -- Skips any separators and parses Source up to the first character that -- is not a decimal digit. Returns value of parsed digits or 0 if none. procedure Parse_X_Filename (File : in out ALI_File); *************** package body Xref_Lib is *** 808,814 **** exit when Ali (Ptr) = EOF; end loop; ! -- We were not able to find the symbol, this should not happend but -- since we don't want to stop here we return a string of three -- question marks as the symbol name. --- 808,814 ---- exit when Ali (Ptr) = EOF; end loop; ! -- We were not able to find the symbol, this should not happen but -- since we don't want to stop here we return a string of three -- question marks as the symbol name. *************** package body Xref_Lib is *** 896,901 **** --- 896,916 ---- Skip_To_Matching_Closing_Bracket; end if; + -- Skip any renaming indication + + if Ali (Ptr) = '=' then + declare + P_Line, P_Column : Natural; + pragma Warnings (Off, P_Line); + pragma Warnings (Off, P_Column); + begin + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, P_Line); + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, P_Column); + end; + end if; + if Ali (Ptr) = '<' or else Ali (Ptr) = '(' or else Ali (Ptr) = '{' *************** package body Xref_Lib is *** 1036,1054 **** end loop; Ptr := Ptr + 1; end if; - - elsif Ali (Ptr) = '=' then - declare - P_Line, P_Column : Natural; - pragma Warnings (Off, P_Line); - pragma Warnings (Off, P_Column); - - begin - Ptr := Ptr + 1; - Parse_Number (Ali, Ptr, P_Line); - Ptr := Ptr + 1; - Parse_Number (Ali, Ptr, P_Column); - end; end if; -- To find the body, we will have to parse the file too --- 1051,1056 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/xref_lib.ads gcc-4.4.0/gcc/ada/xref_lib.ads *** gcc-4.3.3/gcc/ada/xref_lib.ads Mon Sep 10 12:47:10 2007 --- gcc-4.4.0/gcc/ada/xref_lib.ads Sun Apr 13 18:03:09 2008 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2008, 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- -- *************** package Xref_Lib is *** 115,121 **** -- If Der_Info is true, then the derived type information will be -- processed. -- ! -- If Type_Tree is true, then the type hierarchy wil be searched -- going from the pattern to the parent type. procedure Search_Xref --- 115,121 ---- -- If Der_Info is true, then the derived type information will be -- processed. -- ! -- If Type_Tree is true, then the type hierarchy will be searched -- going from the pattern to the parent type. procedure Search_Xref diff -Nrcpad gcc-4.3.3/gcc/ada/xsinfo.adb gcc-4.4.0/gcc/ada/xsinfo.adb *** gcc-4.3.3/gcc/ada/xsinfo.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/xsinfo.adb Sun Apr 13 18:03:09 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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,43 **** -- Note: this program assumes that sinfo.ads has passed the error checks -- which are carried out by the CSinfo utility, so it does not duplicate ! -- these checks and assumes the soruce is correct. -- An optional argument allows the specification of an output file name to -- override the default sinfo.h file name for the generated output file. --- 37,43 ---- -- Note: this program assumes that sinfo.ads has passed the error checks -- which are carried out by the CSinfo utility, so it does not duplicate ! -- these checks and assumes the source is correct. -- An optional argument allows the specification of an output file name to -- override the default sinfo.h file name for the generated output file. *************** procedure XSinfo is *** 55,63 **** Done : exception; Err : exception; - pragma Warnings (Off); - -- Below variables are referenced using * operator - A : VString := Nul; Arg : VString := Nul; Comment : VString := Nul; --- 55,60 ---- *************** procedure XSinfo is *** 68,77 **** Rtn : VString := Nul; Term : VString := Nul; ! pragma Warnings (On); ! ! InS : File_Type; ! Ofile : File_Type; wsp : constant Pattern := Span (' ' & ASCII.HT); Wsp_For : constant Pattern := wsp & "for"; --- 65,72 ---- Rtn : VString := Nul; Term : VString := Nul; ! InS : File_Type; ! Ofile : File_Type; wsp : constant Pattern := Span (' ' & ASCII.HT); Wsp_For : constant Pattern := wsp & "for"; diff -Nrcpad gcc-4.3.3/gcc/ada/xsnames.adb gcc-4.4.0/gcc/ada/xsnames.adb *** gcc-4.3.3/gcc/ada/xsnames.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/xsnames.adb Tue May 27 08:50:31 2008 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** procedure XSnames is *** 47,65 **** InH : File_Type; OutH : File_Type; - pragma Warnings (Off); - -- Variables below are modifed by * operator - A, B : VString := Nul; Line : VString := Nul; Name : VString := Nul; Name1 : VString := Nul; - Oname : VString := Nul; Oval : VString := Nul; Restl : VString := Nul; - pragma Warnings (On); - Tdigs : constant Pattern := Any (Decimal_Digit_Set) & Any (Decimal_Digit_Set) & Any (Decimal_Digit_Set); --- 47,59 ---- *************** begin *** 170,176 **** Create (OutH, Out_File, "snames.nh"); Anchored_Mode := True; - Oname := Nul; Val := 0; loop --- 164,169 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/xtreeprs.adb gcc-4.4.0/gcc/ada/xtreeprs.adb *** gcc-4.3.3/gcc/ada/xtreeprs.adb Thu Dec 13 10:40:58 2007 --- gcc-4.4.0/gcc/ada/xtreeprs.adb Fri Feb 20 15:20:38 2009 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- *************** procedure XTreeprs is *** 59,67 **** Err : exception; -- Raised on fatal error - pragma Warnings (Off); - -- Following variables are assigned by * operator - A : VString := Nul; Ffield : VString := Nul; Field : VString := Nul; --- 59,64 ---- *************** procedure XTreeprs is *** 78,85 **** Synonym : VString := Nul; Term : VString := Nul; - pragma Warnings (On); - subtype Sfile is Ada.Streams.Stream_IO.File_Type; OutS : Sfile; --- 75,80 ---- diff -Nrcpad gcc-4.3.3/gcc/ada/xutil.adb gcc-4.4.0/gcc/ada/xutil.adb *** gcc-4.3.3/gcc/ada/xutil.adb Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/xutil.adb Tue Aug 5 13:26:24 2008 *************** *** 0 **** --- 1,77 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT SYSTEM UTILITIES -- + -- -- + -- X U T I L -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1992-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package body XUtil is + + use Ada.Strings.Unbounded; + use Ada.Streams.Stream_IO; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line (F : Sfile) is + begin + Character'Write (Stream (F), ASCII.LF); + end New_Line; + + --------- + -- Put -- + --------- + + procedure Put (F : Sfile; S : String) is + begin + String'Write (Stream (F), S); + end Put; + + --------- + -- Put -- + --------- + + procedure Put (F : Sfile; S : VString) is + begin + Put (F, To_String (S)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (F : Sfile; S : String) is + begin + Put (F, S); + New_Line (F); + end Put_Line; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (F : Sfile; S : VString) is + begin + Put_Line (F, To_String (S)); + end Put_Line; + + end XUtil; diff -Nrcpad gcc-4.3.3/gcc/ada/xutil.ads gcc-4.4.0/gcc/ada/xutil.ads *** gcc-4.3.3/gcc/ada/xutil.ads Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/ada/xutil.ads Tue Aug 5 13:26:24 2008 *************** *** 0 **** --- 1,44 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT SYSTEM UTILITIES -- + -- -- + -- X U T I L -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 1992-2008, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- Shared routines for the build-time code generation utilities + + with Ada.Streams.Stream_IO; + with Ada.Strings.Unbounded; + + package XUtil is + + subtype VString is Ada.Strings.Unbounded.Unbounded_String; + subtype Sfile is Ada.Streams.Stream_IO.File_Type; + + procedure Put (F : Sfile; S : String); + procedure Put (F : Sfile; S : VString); + procedure Put_Line (F : Sfile; S : String); + procedure Put_Line (F : Sfile; S : VString); + procedure New_Line (F : Sfile); + -- Similar to the same-named Ada.Text_IO routines, but ensure UNIX line + -- ending on all platforms. + + end XUtil; diff -Nrcpad gcc-4.3.3/gnattools/ChangeLog gcc-4.4.0/gnattools/ChangeLog *** gcc-4.3.3/gnattools/ChangeLog Sat Jan 24 10:18:34 2009 --- gcc-4.4.0/gnattools/ChangeLog Tue Apr 21 08:45:55 2009 *************** *** 1,18 **** ! 2009-01-24 Release Manager ! * GCC 4.3.3 released. ! 2008-08-27 Release Manager ! * GCC 4.3.2 released. ! 2008-06-06 Release Manager ! * GCC 4.3.1 released. ! 2008-03-05 Release Manager ! * GCC 4.3.0 released. 2007-12-05 Bechir Zalila --- 1,78 ---- ! 2009-04-21 Release Manager ! * GCC 4.4.0 released. ! 2009-04-09 Jakub Jelinek ! * Makefile.in: Change copyright header to refer to version ! 3 of the GNU General Public License and to point readers at the ! COPYING3 file and the FSF's license web page. ! * configure.ac: Likewise. ! 2009-02-26 Andreas Schwab ! PR ada/39172 ! * Makefile.in (fsrcdir): Point to gcc directory, not gcc/ada. ! (INCLUDES_FOR_SUBDIR): Adjust. ! (ADA_INCLUDES_FOR_SUBDIR): Adjust. ! 2008-08-01 Paolo Bonzini ! * configure.ac (warn_cflags): Substitute. ! * configure: Regenerate. ! * Makefile.in (libdir, exeext, WARN_CFLAGS): Substitute. ! (GCC_WARN_CFLAGS): Remove NOCOMMON_FLAG. ! (ADA_INCLUDE_DIR, ADA_RTL_OBJ_DIR): Remove as they were unused. ! (libsubdir): Remove. ! (libada-mk): Do not include. Include libgcc.mvars instead. ! (xmake_file): Remove, do not include. ! ! 2008-07-30 Paolo Bonzini ! ! * configure.ac (x_ada_cflags): Remove. ! (ADA_CFLAGS): Substitute. ! * configure: Regenerate. ! * Makefile.in (ADA_CFLAGS): Substitute. ! (T_ADA_CFLAGS, X_ADA_CFLAGS, ALL_ADA_CFLAGS): Remove. ! (TOOLS_FLAGS_TO_PASS_1, TOOLS_FLAGS_TO_PASS_1re, ! TOOLS_FLAGS_TO_PASS_NATIVE, TOOLS_FLAGS_TO_PASS_CROSS): ! Pass ADA_CFLAGS. ! ! 2008-07-30 Laurent Guerby ! ! PR ada/5911 ! * gnattools/Makefile.in: Replace stamp-gnatlib by ! stamp-gnatlib-rts. ! ! 2008-06-26 Chris Proctor ! ! * configure.ac, configure: Fix target specific pairs. ! ! 2008-06-17 Ralf Wildenhues ! ! * configure.ac: move sinclude of acx.m4 before AC_INIT, ! also sinclude override.m4. ! * Makefile.in ($(srcdir)/configure): Update dependencies. ! * configure: Regenerate. ! ! 2008-06-07 Joseph Myers ! ! * configure.ac (xscale*-wrs-vx*, xscale*-wrs-coff): Remove. ! * configure: Regenerate. ! ! 2008-05-20 Arnaud Charlet ! ! * Makefile.in (GNATTOOLS2_FILES): Replaced by common-tools target ! in gcc/ada/Makefile.in ! ! 2008-05-13 Arnaud Charlet ! ! PR ada/31808 ! * Makefile.in (gnattools-cross): Do not build vxaddr2line ! ! 2008-04-05 Arnaud Charlet ! ! * Makefile.in: Remove handling of gnatbl. 2007-12-05 Bechir Zalila *************** *** 63,70 **** 2005-02-02 Nathanael Nerode ! * Makefile.in: Remove use of cc_set_by_configure; just use ! plain old CC from the top level in this case. 2005-01-30 Nathanael Nerode Merge from mainline at tag libada-gnattools-merge-20050129: --- 123,130 ---- 2005-02-02 Nathanael Nerode ! * Makefile.in: Remove use of cc_set_by_configure; just use ! plain old CC from the top level in this case. 2005-01-30 Nathanael Nerode Merge from mainline at tag libada-gnattools-merge-20050129: *************** *** 73,79 **** 2004-12-13 Nathanael Nerode ! * Makefile.in: Reinstate stamp-gnatlib check. 2004-12-02 Nathanael Nerode --- 133,139 ---- 2004-12-13 Nathanael Nerode ! * Makefile.in: Reinstate stamp-gnatlib check. 2004-12-02 Nathanael Nerode *************** Copyright 2004, 2005 Free Software Found *** 104,107 **** This ChangeLog is free software; the Free Software Foundation gives unlimited permission to copy, distribute, and modify it. - --- 164,166 ---- diff -Nrcpad gcc-4.3.3/gnattools/Makefile.in gcc-4.4.0/gnattools/Makefile.in *** gcc-4.3.3/gnattools/Makefile.in Mon Apr 30 10:14:24 2007 --- gcc-4.4.0/gnattools/Makefile.in Thu Apr 9 23:23:07 2009 *************** *** 1,9 **** # Makefile for gnattools ! # Copyright 2003, 2004 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, --- 1,9 ---- # Makefile for gnattools ! # Copyright 2003, 2004, 2009 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, *************** *** 12,19 **** # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # Default target; must be first. all: gnattools --- 12,19 ---- # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License ! # along with this program; see the file COPYING3. If not see ! # . # Default target; must be first. all: gnattools *************** all: gnattools *** 21,26 **** --- 21,27 ---- # Standard autoconf-set variables. SHELL = @SHELL@ srcdir = @srcdir@ + libdir = @libdir@ build = @build@ target = @target@ prefix = @prefix@ *************** LN_S=@LN_S@ *** 33,38 **** --- 34,40 ---- target_noncanonical=@target_noncanonical@ # Variables for the user (or the top level) to override. + exeext = @EXEEXT@ objext=.o TRACE=no ADA_FOR_BUILD= *************** PWD_COMMAND = $${PWDCMD-pwd} *** 43,81 **** # The tedious process of getting CFLAGS right. CFLAGS=-g LOOSE_WARN = -W -Wall -Wwrite-strings -Wstrict-prototypes -Wmissing-prototypes ! GCC_WARN_CFLAGS = $(LOOSE_WARN) $(NOCOMMON_FLAG) ! ADA_CFLAGS= ! T_ADA_CFLAGS= ! # HPPA is literally the only target which sets X_ADA_CFLAGS ! X_ADA_CFLAGS=@x_ada_cflags@ ! ALL_ADA_CFLAGS=$(X_ADA_CFLAGS) $(T_ADA_CFLAGS) $(ADA_CFLAGS) # Variables for gnattools. ADAFLAGS= -gnatpg -gnata - ADA_INCLUDE_DIR = $(libsubdir)/adainclude - ADA_RTL_OBJ_DIR = $(libsubdir)/adalib # For finding the GCC build dir, which is used far too much GCC_DIR=../gcc - # Include fragment generated by GCC configure; shared with libada for now. - include $(GCC_DIR)/libada-mk - # Variables based on those gleaned from the GCC makefile. :-P - libsubdir=$(libdir)/gcc/$(target_noncanonical)/$(gcc_version) ! # Get possible host-specific override for libsubdir (ick). ! xmake_file=$(subst /config,/../gcc/config,$(gcc_xmake_file)) ! ifneq ($(xmake_file),) ! include $(xmake_file) ! endif ! ! # Absolute srcdir for gcc/ada (why do we want absolute? I dunno) ! fsrcdir := $(shell cd $(srcdir)/../gcc/ada/; ${PWD_COMMAND}) # Useful "subroutines" for the excess includes ! INCLUDES_FOR_SUBDIR = -I. -I.. -I../.. -I$(fsrcdir) -I$(fsrcdir)/../config \ ! -I$(fsrcdir)/../../include -I$(fsrcdir)/.. ! ADA_INCLUDES_FOR_SUBDIR = -I. -I$(fsrcdir) # Variables for gnattools1, native TOOLS_FLAGS_TO_PASS_1= \ --- 45,68 ---- # The tedious process of getting CFLAGS right. CFLAGS=-g LOOSE_WARN = -W -Wall -Wwrite-strings -Wstrict-prototypes -Wmissing-prototypes ! GCC_WARN_CFLAGS = $(LOOSE_WARN) ! WARN_CFLAGS = @warn_cflags@ ! ADA_CFLAGS=@ADA_CFLAGS@ # Variables for gnattools. ADAFLAGS= -gnatpg -gnata # For finding the GCC build dir, which is used far too much GCC_DIR=../gcc ! # Absolute srcdir for gcc (why do we want absolute? I dunno) ! fsrcdir := $(shell cd $(srcdir)/../gcc/; ${PWD_COMMAND}) # Useful "subroutines" for the excess includes ! INCLUDES_FOR_SUBDIR = -I. -I.. -I../.. -I$(fsrcdir)/ada -I$(fsrcdir)/config \ ! -I$(fsrcdir)/../include -I$(fsrcdir) ! ADA_INCLUDES_FOR_SUBDIR = -I. -I$(fsrcdir)/ada # Variables for gnattools1, native TOOLS_FLAGS_TO_PASS_1= \ *************** TOOLS_FLAGS_TO_PASS_1= \ *** 83,88 **** --- 70,76 ---- "CFLAGS=$(CFLAGS) $(WARN_CFLAGS)" \ "LDFLAGS=$(LDFLAGS)" \ "ADAFLAGS=$(ADAFLAGS)" \ + "ADA_CFLAGS=$(ADA_CFLAGS)" \ "INCLUDES=$(INCLUDES_FOR_SUBDIR)" \ "ADA_INCLUDES=-I- -I../rts $(ADA_INCLUDES_FOR_SUBDIR)"\ "exeext=$(exeext)" \ *************** TOOLS_FLAGS_TO_PASS_1re= \ *** 96,101 **** --- 84,90 ---- "CC=../../xgcc -B../../" \ "CFLAGS=$(CFLAGS)" \ "ADAFLAGS=$(ADAFLAGS)" \ + "ADA_CFLAGS=$(ADA_CFLAGS)" \ "INCLUDES=$(INCLUDES_FOR_SUBDIR)" \ "ADA_INCLUDES=-I../rts $(ADA_INCLUDES_FOR_SUBDIR)"\ "exeext=$(exeext)" \ *************** TOOLS_FLAGS_TO_PASS_NATIVE= \ *** 112,117 **** --- 101,107 ---- "CC=../../xgcc -B../../" \ "CFLAGS=$(CFLAGS)" \ "ADAFLAGS=$(ADAFLAGS)" \ + "ADA_CFLAGS=$(ADA_CFLAGS)" \ "INCLUDES=$(INCLUDES_FOR_SUBDIR)" \ "ADA_INCLUDES=-I../rts $(ADA_INCLUDES_FOR_SUBDIR)" \ "exeext=$(exeext)" \ *************** TOOLS_FLAGS_TO_PASS_CROSS= \ *** 128,133 **** --- 118,124 ---- "CFLAGS=$(CFLAGS) $(WARN_CFLAGS)" \ "LDFLAGS=$(LDFLAGS)" \ "ADAFLAGS=$(ADAFLAGS)" \ + "ADA_CFLAGS=$(ADA_CFLAGS)" \ "INCLUDES=$(INCLUDES_FOR_SUBDIR)" \ "ADA_INCLUDES=-I$(RTS_DIR)../adainclude -I$(RTS_DIR) $(ADA_INCLUDES_FOR_SUBDIR)" \ "exeext=$(exeext)" \ *************** TOOLS_FLAGS_TO_PASS_CROSS= \ *** 146,163 **** EXTRA_GNATTOOLS = @EXTRA_GNATTOOLS@ TOOLS_TARGET_PAIRS = @TOOLS_TARGET_PAIRS@ - # These are built by gnatmake, and in both native and cross configurations. - GNATTOOLS2_FILES = \ - ../../gnatchop$(exeext) \ - ../../gnat$(exeext) \ - ../../gnatkr$(exeext) \ - ../../gnatls$(exeext) \ - ../../gnatprep$(exeext) \ - ../../gnatxref$(exeext) \ - ../../gnatfind$(exeext) \ - ../../gnatname$(exeext) \ - ../../gnatclean$(exeext) - # Makefile targets # ---------------- --- 137,142 ---- *************** GNATTOOLS2_FILES = \ *** 165,172 **** gnattools: @default_gnattools_target@ # Sanity check ! $(GCC_DIR)/stamp-gnatlib: ! @if [ ! -f $(GCC_DIR)/stamp-gnatlib ] ; \ then \ echo "Cannot build gnattools while gnatlib is out of date or unbuilt" ; \ false; \ --- 144,151 ---- gnattools: @default_gnattools_target@ # Sanity check ! $(GCC_DIR)/stamp-gnatlib-rts: ! @if [ ! -f $(GCC_DIR)/stamp-gnatlib-rts ] ; \ then \ echo "Cannot build gnattools while gnatlib is out of date or unbuilt" ; \ false; \ *************** $(GCC_DIR)/stamp-tools: *** 195,222 **** # to be able to build gnatmake without a version of gnatmake around. Once # everything has been compiled once, gnatmake can be recompiled with itself # (see target regnattools) ! gnattools-native: $(GCC_DIR)/stamp-tools $(GCC_DIR)/stamp-gnatlib # gnattools1 $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ $(TOOLS_FLAGS_TO_PASS_1) \ ! ../../gnatmake$(exeext) ../../gnatlink$(exeext) ../../gnatbl$(exeext) # gnattools2 $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ ! $(TOOLS_FLAGS_TO_PASS_NATIVE) \ ! $(GNATTOOLS2_FILES) # gnatmake/link can be built with recent gnatmake/link if they are available. # This is especially convenient for building cross tools or for rebuilding # the tools when the original bootstrap has already be done. ! regnattools: $(GCC_DIR)/stamp-gnatlib # gnattools1-re $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ $(TOOLS_FLAGS_TO_PASS_1re) \ gnatmake-re gnatlink-re # gnattools2 $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ ! $(TOOLS_FLAGS_TO_PASS_NATIVE) \ ! $(GNATTOOLS2_FILES) # For cross builds of gnattools, # put the host RTS dir first in the PATH to hide the default runtime --- 174,199 ---- # to be able to build gnatmake without a version of gnatmake around. Once # everything has been compiled once, gnatmake can be recompiled with itself # (see target regnattools) ! gnattools-native: $(GCC_DIR)/stamp-tools $(GCC_DIR)/stamp-gnatlib-rts # gnattools1 $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ $(TOOLS_FLAGS_TO_PASS_1) \ ! ../../gnatmake$(exeext) ../../gnatlink$(exeext) # gnattools2 $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ ! $(TOOLS_FLAGS_TO_PASS_NATIVE) common-tools # gnatmake/link can be built with recent gnatmake/link if they are available. # This is especially convenient for building cross tools or for rebuilding # the tools when the original bootstrap has already be done. ! regnattools: $(GCC_DIR)/stamp-gnatlib-rts # gnattools1-re $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ $(TOOLS_FLAGS_TO_PASS_1re) \ gnatmake-re gnatlink-re # gnattools2 $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ ! $(TOOLS_FLAGS_TO_PASS_NATIVE) common-tools # For cross builds of gnattools, # put the host RTS dir first in the PATH to hide the default runtime *************** gnattools-cross: $(GCC_DIR)/stamp-tools *** 230,250 **** gnatmake-re gnatlink-re # gnattools2 $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ ! $(TOOLS_FLAGS_TO_PASS_CROSS) \ ! $(GNATTOOLS2_FILES) ! # gnattools4 (cross only) ! $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ ! $(TOOLS_FLAGS_TO_PASS_CROSS) \ ! top_buildir=../../.. \ ! ../../vxaddr2line$(exeext) # Rename cross tools to where the GCC makefile wants them when # installing. FIXME: installation should be done elsewhere. if [ -f $(GCC_DIR)/gnatbind$(exeext) ] ; then \ mv $(GCC_DIR)/gnatbind$(exeext) $(GCC_DIR)/gnatbind-cross$(exeext); \ fi - if [ -f $(GCC_DIR)/gnatbl$(exeext) ] ; then \ - mv $(GCC_DIR)/gnatbl$(exeext) $(GCC_DIR)/gnatbl-cross$(exeext); \ - fi if [ -f $(GCC_DIR)/gnatchop$(exeext) ] ; then \ mv $(GCC_DIR)/gnatchop$(exeext) $(GCC_DIR)/gnatchop-cross$(exeext); \ fi --- 207,218 ---- gnatmake-re gnatlink-re # gnattools2 $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ ! $(TOOLS_FLAGS_TO_PASS_CROSS) common-tools # Rename cross tools to where the GCC makefile wants them when # installing. FIXME: installation should be done elsewhere. if [ -f $(GCC_DIR)/gnatbind$(exeext) ] ; then \ mv $(GCC_DIR)/gnatbind$(exeext) $(GCC_DIR)/gnatbind-cross$(exeext); \ fi if [ -f $(GCC_DIR)/gnatchop$(exeext) ] ; then \ mv $(GCC_DIR)/gnatchop$(exeext) $(GCC_DIR)/gnatchop-cross$(exeext); \ fi *************** Makefile: $(srcdir)/Makefile.in config.s *** 337,343 **** config.status: $(srcdir)/configure $(SHELL) ./config.status --recheck ! $(srcdir)/configure: @MAINT@ $(srcdir)/configure.ac cd $(srcdir) && autoconf # Don't export variables to the environment, in order to not confuse --- 305,312 ---- config.status: $(srcdir)/configure $(SHELL) ./config.status --recheck ! $(srcdir)/configure: @MAINT@ $(srcdir)/configure.ac \ ! $(srcdir)/../config/acx.m4 $(srcdir)/../config/override.m4 cd $(srcdir) && autoconf # Don't export variables to the environment, in order to not confuse diff -Nrcpad gcc-4.3.3/gnattools/configure gcc-4.4.0/gnattools/configure *** gcc-4.3.3/gnattools/configure Wed Dec 5 14:34:48 2007 --- gcc-4.4.0/gnattools/configure Fri Aug 1 08:18:13 2008 *************** PACKAGE_STRING= *** 272,279 **** PACKAGE_BUGREPORT= ac_unique_file="Makefile.in" ! ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS MAINT INSTALL_PROGRAM INSTALL_SCRIPT INSTALL_DATA build build_cpu build_vendor build_os host host_cpu host_vendor host_os target target_cpu target_vendor target_os target_noncanonical LN_S x_ada_cflags default_gnattools_target TOOLS_TARGET_PAIRS EXTRA_GNATTOOLS LIBOBJS LTLIBOBJS' ac_subst_files='' # Initialize some variables set by options. ac_init_help= --- 272,280 ---- PACKAGE_BUGREPORT= ac_unique_file="Makefile.in" ! ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS MAINT INSTALL_PROGRAM INSTALL_SCRIPT INSTALL_DATA build build_cpu build_vendor build_os host host_cpu host_vendor host_os target target_cpu target_vendor target_os target_noncanonical LN_S default_gnattools_target TOOLS_TARGET_PAIRS EXTRA_GNATTOOLS ADA_CFLAGS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT warn_cflags LIBOBJS LTLIBOBJS' ac_subst_files='' + ac_pwd=`pwd` # Initialize some variables set by options. ac_init_help= *************** ac_env_target_alias_set=${target_alias+s *** 713,718 **** --- 714,735 ---- ac_env_target_alias_value=$target_alias ac_cv_env_target_alias_set=${target_alias+set} ac_cv_env_target_alias_value=$target_alias + ac_env_CC_set=${CC+set} + ac_env_CC_value=$CC + ac_cv_env_CC_set=${CC+set} + ac_cv_env_CC_value=$CC + ac_env_CFLAGS_set=${CFLAGS+set} + ac_env_CFLAGS_value=$CFLAGS + ac_cv_env_CFLAGS_set=${CFLAGS+set} + ac_cv_env_CFLAGS_value=$CFLAGS + ac_env_LDFLAGS_set=${LDFLAGS+set} + ac_env_LDFLAGS_value=$LDFLAGS + ac_cv_env_LDFLAGS_set=${LDFLAGS+set} + ac_cv_env_LDFLAGS_value=$LDFLAGS + ac_env_CPPFLAGS_set=${CPPFLAGS+set} + ac_env_CPPFLAGS_value=$CPPFLAGS + ac_cv_env_CPPFLAGS_set=${CPPFLAGS+set} + ac_cv_env_CPPFLAGS_value=$CPPFLAGS # # Report the --help message. *************** Optional Features: *** 792,797 **** --- 809,825 ---- enable make rules and dependencies not useful (and sometimes confusing) to the casual installer + Some influential environment variables: + CC C compiler command + CFLAGS C compiler flags + LDFLAGS linker flags, e.g. -L if you have libraries in a + nonstandard directory + CPPFLAGS C/C++ preprocessor flags, e.g. -I if you have + headers in a nonstandard directory + + Use these variables to override the choices made by `configure' or to help + it to find libraries and programs with nonstandard names/locations. + _ACEOF fi *************** echo "$as_me: error: \`$ac_var' was not *** 1173,1185 **** ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then ! { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ! { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 ! echo "$as_me: former value: $ac_old_val" >&2;} ! { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 ! echo "$as_me: current value: $ac_new_val" >&2;} ! ac_cache_corrupted=: fi;; esac # Pass precious variables to config.status. --- 1201,1222 ---- ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then ! # differences in whitespace do not lead to failure. ! ac_old_val_w=`echo x $ac_old_val` ! ac_new_val_w=`echo x $ac_new_val` ! if test "$ac_old_val_w" != "$ac_new_val_w"; then ! { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ! ac_cache_corrupted=: ! else ! { echo "$as_me:$LINENO: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 ! echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} ! eval $ac_var=\$ac_old_val ! fi ! { echo "$as_me:$LINENO: former value: \`$ac_old_val'" >&5 ! echo "$as_me: former value: \`$ac_old_val'" >&2;} ! { echo "$as_me:$LINENO: current value: \`$ac_new_val'" >&5 ! echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. *************** echo "$as_me: current value: $ac_new_v *** 1196,1201 **** --- 1233,1240 ---- fi done if $ac_cache_corrupted; then + { echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + echo "$as_me: error: in \`$ac_pwd':" >&2;} { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 echo "$as_me: error: changes in the environment can compromise the build" >&2;} { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 *************** ac_compiler_gnu=$ac_cv_c_compiler_gnu *** 1231,1236 **** --- 1270,1278 ---- + + + # Command-line options. # Very limited version of AC_MAINTAINER_MODE. # Check whether --enable-maintainer-mode or --disable-maintainer-mode was given. *************** test -n "$target_alias" && *** 1438,1540 **** NONENONEs,x,x, && program_prefix=${target_alias}- - # Autoconf M4 include file defining utility macros for complex Canadian - # cross builds. - - - - - - - - - - #### - # _NCN_TOOL_PREFIXES: Some stuff that oughtta be done in AC_CANONICAL_SYSTEM - # or AC_INIT. - # These demand that AC_CANONICAL_SYSTEM be called beforehand. - - #### - # NCN_STRICT_CHECK_TOOLS(variable, progs-to-check-for,[value-if-not-found],[path]) - # Like plain AC_CHECK_TOOLS, but require prefix if build!=host. - - - #### - # NCN_STRICT_CHECK_TARGET_TOOLS(variable, progs-to-check-for,[value-if-not-found],[path]) - # Like CVS Autoconf AC_CHECK_TARGET_TOOLS, but require prefix if build!=target. - - - - # Backported from Autoconf 2.5x; can go away when and if - # we switch. Put the OS path separator in $PATH_SEPARATOR. - - - - - # ACX_HAVE_GCC_FOR_TARGET - # Check if the variable GCC_FOR_TARGET really points to a GCC binary. - - - # ACX_CHECK_INSTALLED_TARGET_TOOL(VAR, PROG) - # Searching for installed target binutils. We need to take extra care, - # else we may find the wrong assembler, linker, etc., and lose. - # - # First try --with-build-time-tools, if specified. - # - # For build != host, we ask the installed GCC for the name of the tool it - # uses, and accept it if it is an absolute path. This is because the - # only good choice for a compiler is the same GCC version that is being - # installed (or we couldn't make target libraries), and we assume that - # on the host system we'll have not only the same GCC version, but also - # the same binutils version. - # - # For build == host, search the same directories that the installed - # compiler will search. We used to do this for the assembler, linker, - # and nm only; for simplicity of configuration, however, we extend this - # criterion to tools (such as ar and ranlib) that are never invoked by - # the compiler, to avoid mismatches. - # - # Also note we have to check MD_EXEC_PREFIX before checking the user's path - # if build == target. This makes the most sense only when bootstrapping, - # but we also do so when build != host. In this case, we hope that the - # build and host systems will have similar contents of MD_EXEC_PREFIX. - # - # If we do not find a suitable binary, then try the user's path. - - - ### - # AC_PROG_CPP_WERROR - # Used for autoconf 2.5x to force AC_PREPROC_IFELSE to reject code which - # triggers warnings from the preprocessor. Will be in autoconf 2.58. - # For now, using this also overrides header checks to use only the - # preprocessor (matches 2.13 behavior; matching 2.58's behavior is a - # bit harder from here). - # Eventually autoconf will default to checking headers with the compiler - # instead, and we'll have to do this differently. - - # AC_PROG_CPP_WERROR - - # Test for GNAT. - # We require the gnatbind program, and a compiler driver that - # understands Ada. We use the user's CC setting, already found. - # - # Sets the shell variable have_gnat to yes or no as appropriate, and - # substitutes GNATBIND and GNATMAKE. - - - - - - - - - - - - - - - case ${build_alias} in "") build_noncanonical=${build} ;; *) build_noncanonical=${build_alias} ;; --- 1480,1485 ---- *************** echo "${ECHO_T}no, using $LN_S" >&6 *** 1566,1578 **** fi - # Determine x_ada_cflags - case $host in - hppa*) x_ada_cflags=-mdisable-indexing ;; - *) x_ada_cflags= ;; - esac - - # Determine what to build for 'gnattools' if test $build = $target ; then # Note that build=target is almost certainly the wrong test; FIXME --- 1511,1516 ---- *************** case "${target}" in *** 1597,1612 **** | powerpc*-wrs-vxworks \ | sparc*-wrs-vx* \ | *86-wrs-vxworks \ - | xscale*-wrs-vx* \ - | xscale*-wrs-coff \ | mips*-wrs-vx*) ! TOOLS_TARGET_PAIRS="mlib-tgt-specific.adb&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + CC=$ac_cv_prog_CC + if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 + echo "${ECHO_T}$CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + fi + if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. + set dummy gcc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="gcc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + ac_ct_CC=$ac_cv_prog_ac_ct_CC + if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 + echo "${ECHO_T}$ac_ct_CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + CC=$ac_ct_CC + else + CC="$ac_cv_prog_CC" + fi + + if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. + set dummy ${ac_tool_prefix}cc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + CC=$ac_cv_prog_CC + if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 + echo "${ECHO_T}$CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + fi + if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "cc", so it can be a program name with args. + set dummy cc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + ac_ct_CC=$ac_cv_prog_ac_ct_CC + if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 + echo "${ECHO_T}$ac_ct_CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + CC=$ac_ct_CC + else + CC="$ac_cv_prog_CC" + fi + + fi + if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. + set dummy cc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. + else + ac_prog_rejected=no + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" + fi + fi + fi + fi + CC=$ac_cv_prog_CC + if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 + echo "${ECHO_T}$CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + fi + if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. + set dummy $ac_tool_prefix$ac_prog; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + CC=$ac_cv_prog_CC + if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 + echo "${ECHO_T}$CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + test -n "$CC" && break + done + fi + if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl + do + # Extract the first word of "$ac_prog", so it can be a program name with args. + set dummy $ac_prog; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="$ac_prog" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + ac_ct_CC=$ac_cv_prog_ac_ct_CC + if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 + echo "${ECHO_T}$ac_ct_CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + test -n "$ac_ct_CC" && break + done + + CC=$ac_ct_CC + fi + + fi + + + test -z "$CC" && { { echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + echo "$as_me: error: in \`$ac_pwd':" >&2;} + { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH + See \`config.log' for more details." >&5 + echo "$as_me: error: no acceptable C compiler found in \$PATH + See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; }; } + + # Provide some information about the compiler. + echo "$as_me:$LINENO:" \ + "checking for C compiler version" >&5 + ac_compiler=`set X $ac_compile; echo $2` + { (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 + (eval $ac_compiler --version &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + { (eval echo "$as_me:$LINENO: \"$ac_compiler -v &5\"") >&5 + (eval $ac_compiler -v &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + { (eval echo "$as_me:$LINENO: \"$ac_compiler -V &5\"") >&5 + (eval $ac_compiler -V &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + int + main () + { + + ; + return 0; + } + _ACEOF + ac_clean_files_save=$ac_clean_files + ac_clean_files="$ac_clean_files a.out a.exe b.out" + # Try to create an executable without -o first, disregard a.out. + # It will help us diagnose broken compilers, and finding out an intuition + # of exeext. + echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 + echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6 + ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` + if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 + (eval $ac_link_default) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + # Find the output, starting from the most likely. This scheme is + # not robust to junk in `.', hence go to wildcards (a.*) only as a last + # resort. + + # Be careful to initialize this variable, since it used to be cached. + # Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile. + ac_cv_exeext= + # b.out is created by i960 compilers. + for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out + do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) + ;; + conftest.$ac_ext ) + # This is the source file. + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + # FIXME: I believe we export ac_cv_exeext for Libtool, + # but it would be cool to find out if it's true. Does anybody + # maintain Libtool? --akim. + export ac_cv_exeext + break;; + * ) + break;; + esac + done + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + { { echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + echo "$as_me: error: in \`$ac_pwd':" >&2;} + { { echo "$as_me:$LINENO: error: C compiler cannot create executables + See \`config.log' for more details." >&5 + echo "$as_me: error: C compiler cannot create executables + See \`config.log' for more details." >&2;} + { (exit 77); exit 77; }; }; } + fi + + ac_exeext=$ac_cv_exeext + echo "$as_me:$LINENO: result: $ac_file" >&5 + echo "${ECHO_T}$ac_file" >&6 + + # Check the compiler produces executables we can run. If not, either + # the compiler is broken, or we cross compile. + echo "$as_me:$LINENO: checking whether the C compiler works" >&5 + echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6 + # FIXME: These cross compiler hacks should be removed for Autoconf 3.0 + # If not cross compiling, check that we can run a simple program. + if test "$cross_compiling" != yes; then + if { ac_try='./$ac_file' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + echo "$as_me: error: in \`$ac_pwd':" >&2;} + { { echo "$as_me:$LINENO: error: cannot run C compiled programs. + If you meant to cross compile, use \`--host'. + See \`config.log' for more details." >&5 + echo "$as_me: error: cannot run C compiled programs. + If you meant to cross compile, use \`--host'. + See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; }; } + fi + fi + fi + echo "$as_me:$LINENO: result: yes" >&5 + echo "${ECHO_T}yes" >&6 + + rm -f a.out a.exe conftest$ac_cv_exeext b.out + ac_clean_files=$ac_clean_files_save + # Check the compiler produces executables we can run. If not, either + # the compiler is broken, or we cross compile. + echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 + echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6 + echo "$as_me:$LINENO: result: $cross_compiling" >&5 + echo "${ECHO_T}$cross_compiling" >&6 + + echo "$as_me:$LINENO: checking for suffix of executables" >&5 + echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6 + if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + # If both `conftest.exe' and `conftest' are `present' (well, observable) + # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will + # work properly (i.e., refer to `conftest.exe'), while it won't with + # `rm'. + for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + export ac_cv_exeext + break;; + * ) break;; + esac + done + else + { { echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + echo "$as_me: error: in \`$ac_pwd':" >&2;} + { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link + See \`config.log' for more details." >&5 + echo "$as_me: error: cannot compute suffix of executables: cannot compile and link + See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; }; } + fi + + rm -f conftest$ac_cv_exeext + echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 + echo "${ECHO_T}$ac_cv_exeext" >&6 + + rm -f conftest.$ac_ext + EXEEXT=$ac_cv_exeext + ac_exeext=$EXEEXT + echo "$as_me:$LINENO: checking for suffix of object files" >&5 + echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 + if test "${ac_cv_objext+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + int + main () + { + + ; + return 0; + } + _ACEOF + rm -f conftest.o conftest.obj + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + for ac_file in `(ls conftest.o conftest.obj; ls conftest.*) 2>/dev/null`; do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac + done + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + { { echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + echo "$as_me: error: in \`$ac_pwd':" >&2;} + { { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile + See \`config.log' for more details." >&5 + echo "$as_me: error: cannot compute suffix of object files: cannot compile + See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; }; } + fi + + rm -f conftest.$ac_cv_objext conftest.$ac_ext + fi + echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 + echo "${ECHO_T}$ac_cv_objext" >&6 + OBJEXT=$ac_cv_objext + ac_objext=$OBJEXT + echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 + echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 + if test "${ac_cv_c_compiler_gnu+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + int + main () + { + #ifndef __GNUC__ + choke me + #endif + + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_compiler_gnu=yes + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + ac_compiler_gnu=no + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + ac_cv_c_compiler_gnu=$ac_compiler_gnu + + fi + echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 + echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 + GCC=`test $ac_compiler_gnu = yes && echo yes` + ac_test_CFLAGS=${CFLAGS+set} + ac_save_CFLAGS=$CFLAGS + CFLAGS="-g" + echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 + echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 + if test "${ac_cv_prog_cc_g+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + int + main () + { + + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_g=yes + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_prog_cc_g=no + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + fi + echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 + echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 + if test "$ac_test_CFLAGS" = set; then + CFLAGS=$ac_save_CFLAGS + elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi + else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi + fi + echo "$as_me:$LINENO: checking for $CC option to accept ANSI C" >&5 + echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 + if test "${ac_cv_prog_cc_stdc+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + ac_cv_prog_cc_stdc=no + ac_save_CC=$CC + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + #include + #include + #include + #include + /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ + struct buf { int x; }; + FILE * (*rcsopen) (struct buf *, struct stat *, int); + static char *e (p, i) + char **p; + int i; + { + return p[i]; + } + static char *f (char * (*g) (char **, int), char **p, ...) + { + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; + } + + /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std1 is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std1. */ + int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + + int test (int i, double x); + struct s1 {int (*f) (int a);}; + struct s2 {int (*f) (double a);}; + int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); + int argc; + char **argv; + int + main () + { + return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; + ; + return 0; + } + _ACEOF + # Don't try gcc -ansi; that turns off useful extensions and + # breaks some systems' header files. + # AIX -qlanglvl=ansi + # Ultrix and OSF/1 -std1 + # HP-UX 10.20 and later -Ae + # HP-UX older versions -Aa -D_HPUX_SOURCE + # SVR4 -Xc -D__EXTENSIONS__ + for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" + do + CC="$ac_save_CC $ac_arg" + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_stdc=$ac_arg + break + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + fi + rm -f conftest.err conftest.$ac_objext + done + rm -f conftest.$ac_ext conftest.$ac_objext + CC=$ac_save_CC + + fi + + case "x$ac_cv_prog_cc_stdc" in + x|xno) + echo "$as_me:$LINENO: result: none needed" >&5 + echo "${ECHO_T}none needed" >&6 ;; + *) + echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5 + echo "${ECHO_T}$ac_cv_prog_cc_stdc" >&6 + CC="$CC $ac_cv_prog_cc_stdc" ;; + esac + + # Some people use a C++ compiler to compile C. Since we use `exit', + # in C++ we need to declare it. In case someone uses the same compiler + # for both compiling C and C++ we need to have the C++ compiler decide + # the declaration of exit, since it's the most demanding environment. + cat >conftest.$ac_ext <<_ACEOF + #ifndef __cplusplus + choke me + #endif + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + for ac_declaration in \ + '' \ + 'extern "C" void std::exit (int) throw (); using std::exit;' \ + 'extern "C" void std::exit (int); using std::exit;' \ + 'extern "C" void exit (int) throw ();' \ + 'extern "C" void exit (int);' \ + 'void exit (int);' + do + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + $ac_declaration + #include + int + main () + { + exit (42); + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + : + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + continue + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + $ac_declaration + int + main () + { + exit (42); + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + break + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + done + rm -f conftest* + if test -n "$ac_declaration"; then + echo '#ifdef __cplusplus' >>confdefs.h + echo $ac_declaration >>confdefs.h + echo '#endif' >>confdefs.h + fi + + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + ac_ext=c + ac_cpp='$CPP $CPPFLAGS' + ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' + ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' + ac_compiler_gnu=$ac_cv_c_compiler_gnu + + warn_cflags= + if test "x$GCC" = "xyes"; then + warn_cflags='$(GCC_WARN_CFLAGS)' + fi + + # Output: create a Makefile. ac_config_files="$ac_config_files Makefile" *************** s,@target_vendor@,$target_vendor,;t t *** 2334,2343 **** s,@target_os@,$target_os,;t t s,@target_noncanonical@,$target_noncanonical,;t t s,@LN_S@,$LN_S,;t t - s,@x_ada_cflags@,$x_ada_cflags,;t t s,@default_gnattools_target@,$default_gnattools_target,;t t s,@TOOLS_TARGET_PAIRS@,$TOOLS_TARGET_PAIRS,;t t s,@EXTRA_GNATTOOLS@,$EXTRA_GNATTOOLS,;t t s,@LIBOBJS@,$LIBOBJS,;t t s,@LTLIBOBJS@,$LTLIBOBJS,;t t CEOF --- 3219,3236 ---- s,@target_os@,$target_os,;t t s,@target_noncanonical@,$target_noncanonical,;t t s,@LN_S@,$LN_S,;t t s,@default_gnattools_target@,$default_gnattools_target,;t t s,@TOOLS_TARGET_PAIRS@,$TOOLS_TARGET_PAIRS,;t t s,@EXTRA_GNATTOOLS@,$EXTRA_GNATTOOLS,;t t + s,@ADA_CFLAGS@,$ADA_CFLAGS,;t t + s,@CC@,$CC,;t t + s,@CFLAGS@,$CFLAGS,;t t + s,@LDFLAGS@,$LDFLAGS,;t t + s,@CPPFLAGS@,$CPPFLAGS,;t t + s,@ac_ct_CC@,$ac_ct_CC,;t t + s,@EXEEXT@,$EXEEXT,;t t + s,@OBJEXT@,$OBJEXT,;t t + s,@warn_cflags@,$warn_cflags,;t t s,@LIBOBJS@,$LIBOBJS,;t t s,@LTLIBOBJS@,$LTLIBOBJS,;t t CEOF diff -Nrcpad gcc-4.3.3/gnattools/configure.ac gcc-4.4.0/gnattools/configure.ac *** gcc-4.3.3/gnattools/configure.ac Wed Dec 5 14:34:48 2007 --- gcc-4.4.0/gnattools/configure.ac Thu Apr 9 23:23:07 2009 *************** *** 1,9 **** # Configure script for libada. ! # Copyright 2003, 2004 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but --- 1,9 ---- # Configure script for libada. ! # Copyright 2003, 2004, 2009 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but *************** *** 12,19 **** # General Public License for more details. # # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. AC_INIT AC_PREREQ([2.59]) --- 12,22 ---- # General Public License for more details. # # You should have received a copy of the GNU General Public License ! # along with this program; see the file COPYING3. If not see ! # . ! ! sinclude(../config/acx.m4) ! sinclude(../config/override.m4) AC_INIT AC_PREREQ([2.59]) *************** AC_CANONICAL_BUILD *** 43,61 **** AC_CANONICAL_HOST AC_CANONICAL_TARGET - sinclude(../config/acx.m4) ACX_NONCANONICAL_TARGET # Need to pass this down for now :-P AC_PROG_LN_S - # Determine x_ada_cflags - case $host in - hppa*) x_ada_cflags=-mdisable-indexing ;; - *) x_ada_cflags= ;; - esac - AC_SUBST([x_ada_cflags]) - # Determine what to build for 'gnattools' if test $build = $target ; then # Note that build=target is almost certainly the wrong test; FIXME --- 46,56 ---- *************** case "${target}" in *** 80,95 **** | powerpc*-wrs-vxworks \ | sparc*-wrs-vx* \ | *86-wrs-vxworks \ - | xscale*-wrs-vx* \ - | xscale*-wrs-coff \ | mips*-wrs-vx*) ! TOOLS_TARGET_PAIRS="mlib-tgt-specific.adb --- 1,77 ---- ! 2009-04-21 Release Manager ! * GCC 4.4.0 released. ! 2009-04-09 Jakub Jelinek ! * Makefile.in: Change copyright header to refer to version ! 3 of the GNU General Public License and to point readers at the ! COPYING3 file and the FSF's license web page. ! * configure.ac: Likewise. ! 2009-04-06 Laurent GUERBY ! * Makefile.in (ADA_RTS_DIR): Define. ! * Makefile.in (gnatlib-*): Link adainclude and adalib to it. ! 2008-09-21 Laurent Guerby ! Paolo Bonzini ! ! PR ada/5911 ! * Makefile.in (all, install, mostlyclean, clean, distclean): Add ! multilib handling. ! * configure.ac: Add multilib handling. ! * configure: Regenerate. ! 2008-08-29 Laurent Guerby ! ! * Makefile.in (FLAGS_TO_PASS): renamed to LIBADA_FLAGS_TO_PASS to ! avoid conflicts. Factor more flags to pass. ! (libsubdir): New variable. ! (install-gnatlib): New target. ! ! 2008-08-28 Laurent Guerby ! ! * configure: Regenerate. ! ! 2008-08-06 Thomas Quinot ! ! * Makefile.in: generate s-oscons.ads again, previous change was ! unneeded. ! ! 2008-08-06 Samuel Tardieu ! ! * Makefile.in: Pass FLAGS_TO_PASS to sub-make for target ! oscons. ! ! 2008-08-06 Thomas Quinot ! ! * Makefile.in: Now generate s-oscons-$(THREAD_KIND). ! ! 2008-08-05 Thomas Quinot ! ! * Makefile.in (gnatlib*): Now depend on oscons target. ! (oscons): New target. ! ! 2008-08-01 Paolo Bonzini ! ! * configure.ac (warn_cflags): Substitute. ! * configure: Regenerate. ! * Makefile.in (libdir, WARN_CFLAGS): Substitute. ! (GCC_WARN_CFLAGS): Remove NOCOMMON_FLAG. ! (ADA_CFLAGS, T_ADA_CFLAGS, X_ADA_CFLAGS, ALL_ADA_CFLAGS): Remove, ! they were unused. ! (libada-mk): Do not include. Include libgcc.mvars instead. ! (tmake_file): Remove, do not include. ! (FLAGS_TO_PASS): Pass dummy values for exeext and CC. ! * configure: Regenerate. ! ! 2008-06-17 Ralf Wildenhues ! ! * configure.ac: move sinclude of acx.m4 before AC_INIT, ! also sinclude override.m4. ! * Makefile.in ($(srcdir)/configure): Update dependencies. ! * configure: Regenerate. 2007-03-01 Brooks Moses diff -Nrcpad gcc-4.3.3/libada/Makefile.in gcc-4.4.0/libada/Makefile.in *** gcc-4.3.3/libada/Makefile.in Fri Mar 2 00:05:13 2007 --- gcc-4.4.0/libada/Makefile.in Thu Apr 9 23:23:07 2009 *************** *** 1,9 **** # Makefile for libada. ! # Copyright 2003, 2004 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, --- 1,9 ---- # Makefile for libada. ! # Copyright 2003, 2004, 2009 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, *************** *** 12,26 **** # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # Default target; must be first. all: gnatlib # Standard autoconf-set variables. SHELL = @SHELL@ srcdir = @srcdir@ build = @build@ target = @target@ prefix = @prefix@ --- 12,38 ---- # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License ! # along with this program; see the file COPYING3. If not see ! # . # Default target; must be first. all: gnatlib + $(MULTIDO) $(AM_MAKEFLAGS) DO=all multi-do # $(MAKE) + + .PHONY: all install + + ## Multilib support variables. + MULTISRCTOP = + MULTIBUILDTOP = + MULTIDIRS = + MULTISUBDIR = + MULTIDO = true + MULTICLEAN = true # Standard autoconf-set variables. SHELL = @SHELL@ srcdir = @srcdir@ + libdir = @libdir@ build = @build@ target = @target@ prefix = @prefix@ *************** LDFLAGS= *** 39,107 **** # The tedious process of getting CFLAGS right. CFLAGS=-g LOOSE_WARN = -W -Wall -Wwrite-strings -Wstrict-prototypes -Wmissing-prototypes ! GCC_WARN_CFLAGS = $(LOOSE_WARN) $(NOCOMMON_FLAG) ! ADA_CFLAGS= ! T_ADA_CFLAGS= ! # HPPA is literally the only target which sets X_ADA_CFLAGS ! X_ADA_CFLAGS=@x_ada_cflags@ ! ALL_ADA_CFLAGS=$(X_ADA_CFLAGS) $(T_ADA_CFLAGS) $(ADA_CFLAGS) ! # For finding the GCC build dir, which is used far too much host_subdir = @host_subdir@ ! GCC_DIR=../../$(host_subdir)/gcc ! # Include fragment generated by GCC configure. ! include $(GCC_DIR)/libada-mk ! TARGET_LIBGCC2_CFLAGS= ! GNATLIBCFLAGS= -g -O2 ! # Get target-specific overrides for TARGET_LIBGCC2_CFLAGS ! # and possibly GNATLIBCFLAGS. Currently this uses files ! # in gcc/config. The 'subst' call is used to rerelativize them ! # from their gcc locations. This is hackery, but there isn't ! # yet a better way to do this. ! tmake_file=$(subst /config,/../gcc/config,$(gcc_tmake_file)) ! ifneq ($(tmake_file),) ! include $(tmake_file) ! endif ! FLAGS_TO_PASS = \ "MAKEOVERRIDES=" \ "LDFLAGS=$(LDFLAGS)" \ "LN_S=$(LN_S)" \ "SHELL=$(SHELL)" \ ! "exeext=$(exeext)" \ "objext=$(objext)" \ "prefix=$(prefix)" \ ! "CC=$(host_cc_for_libada)" \ "GCC_FOR_TARGET=$(CC)" \ "CFLAGS=$(CFLAGS) $(WARN_CFLAGS)" # Rules to build gnatlib. ! .PHONY: gnatlib gnatlib-plain gnatlib-sjlj gnatlib-zcx gnatlib-shared gnatlib: @default_gnatlib_target@ ! gnatlib-plain: $(GCC_DIR)/ada/Makefile test -f stamp-libada || \ ! $(MAKE) -C $(GCC_DIR)/ada $(FLAGS_TO_PASS) \ ! GNATLIBFLAGS="$(GNATLIBFLAGS)" \ ! GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ ! TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \ ! THREAD_KIND="$(THREAD_KIND)" \ ! TRACE="$(TRACE)" \ ! gnatlib \ && touch stamp-libada ! gnatlib-sjlj gnatlib-zcx gnatlib-shared: $(GCC_DIR)/ada/Makefile test -f stamp-libada || \ ! $(MAKE) -C $(GCC_DIR)/ada $(FLAGS_TO_PASS) \ ! GNATLIBFLAGS="$(GNATLIBFLAGS)" \ ! GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ ! TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \ ! THREAD_KIND="$(THREAD_KIND)" \ ! TRACE="$(TRACE)" \ ! $@ \ && touch stamp-libada # Check uninstalled version. check: --- 51,122 ---- # The tedious process of getting CFLAGS right. CFLAGS=-g LOOSE_WARN = -W -Wall -Wwrite-strings -Wstrict-prototypes -Wmissing-prototypes ! GCC_WARN_CFLAGS = $(LOOSE_WARN) ! WARN_CFLAGS = @warn_cflags@ ! TARGET_LIBGCC2_CFLAGS= ! GNATLIBCFLAGS= -g -O2 ! # Get target-specific overrides for TARGET_LIBGCC2_CFLAGS. host_subdir = @host_subdir@ ! GCC_DIR=$(MULTIBUILDTOP)../../$(host_subdir)/gcc ! include $(GCC_DIR)/libgcc.mvars ! target_noncanonical:=@target_noncanonical@ ! version := $(shell cat $(srcdir)/../gcc/BASE-VER) ! libsubdir := $(libdir)/gcc/$(target_noncanonical)/$(version)$(MULTISUBDIR) ! ADA_RTS_DIR=$(GCC_DIR)/ada/rts$(subst /,_,$(MULTISUBDIR)) ! # exeext should not be used because it's the *host* exeext. We're building ! # a *target* library, aren't we?!? Likewise for CC. Still, provide bogus ! # definitions just in case something slips through the safety net provided ! # by recursive make invocations in gcc/ada/Makefile.in ! LIBADA_FLAGS_TO_PASS = \ "MAKEOVERRIDES=" \ "LDFLAGS=$(LDFLAGS)" \ "LN_S=$(LN_S)" \ "SHELL=$(SHELL)" \ ! "GNATLIBFLAGS=$(GNATLIBFLAGS) $(MULTIFLAGS)" \ ! "GNATLIBCFLAGS=$(GNATLIBCFLAGS) $(MULTIFLAGS)" \ ! "TARGET_LIBGCC2_CFLAGS=$(TARGET_LIBGCC2_CFLAGS)" \ ! "THREAD_KIND=$(THREAD_KIND)" \ ! "TRACE=$(TRACE)" \ ! "MULTISUBDIR=$(MULTISUBDIR)" \ ! "libsubdir=$(libsubdir)" \ "objext=$(objext)" \ "prefix=$(prefix)" \ ! "exeext=.exeext.should.not.be.used " \ ! 'CC=the.host.compiler.should.not.be.needed' \ "GCC_FOR_TARGET=$(CC)" \ "CFLAGS=$(CFLAGS) $(WARN_CFLAGS)" # Rules to build gnatlib. ! .PHONY: gnatlib gnatlib-plain gnatlib-sjlj gnatlib-zcx gnatlib-shared oscons gnatlib: @default_gnatlib_target@ ! gnatlib-plain: oscons $(GCC_DIR)/ada/Makefile test -f stamp-libada || \ ! $(MAKE) -C $(GCC_DIR)/ada $(LIBADA_FLAGS_TO_PASS) gnatlib \ && touch stamp-libada + -rm -rf adainclude + -rm -rf adalib + $(LN_S) $(ADA_RTS_DIR) adainclude + $(LN_S) $(ADA_RTS_DIR) adalib ! gnatlib-sjlj gnatlib-zcx gnatlib-shared: oscons $(GCC_DIR)/ada/Makefile test -f stamp-libada || \ ! $(MAKE) -C $(GCC_DIR)/ada $(LIBADA_FLAGS_TO_PASS) $@ \ && touch stamp-libada + -rm -rf adainclude + -rm -rf adalib + $(LN_S) $(ADA_RTS_DIR) adainclude + $(LN_S) $(ADA_RTS_DIR) adalib + + oscons: + $(MAKE) -C $(GCC_DIR) $(LIBADA_FLAGS_TO_PASS) ada/s-oscons.ads + + install-gnatlib: $(GCC_DIR)/ada/Makefile + $(MAKE) -C $(GCC_DIR)/ada $(LIBADA_FLAGS_TO_PASS) install-gnatlib # Check uninstalled version. check: *************** html: *** 125,131 **** TAGS: # Installation rules. ! install: install-info: --- 140,147 ---- TAGS: # Installation rules. ! install: install-gnatlib ! $(MULTIDO) $(AM_MAKEFLAGS) DO=install multi-do # $(MAKE) install-info: *************** install-html: *** 135,144 **** --- 151,163 ---- # Cleaning rules. mostlyclean: + $(MULTICLEAN) $(AM_MAKEFLAGS) DO=mostlyclean multi-clean # $(MAKE) clean: + $(MULTICLEAN) $(AM_MAKEFLAGS) DO=clean multi-clean # $(MAKE) distclean: + $(MULTICLEAN) $(AM_MAKEFLAGS) DO=distclean multi-clean # $(MAKE) $(RM) Makefile config.status config.log maintainer-clean: *************** Makefile: $(srcdir)/Makefile.in config.s *** 152,158 **** config.status: $(srcdir)/configure $(SHELL) ./config.status --recheck ! $(srcdir)/configure: @MAINT@ $(srcdir)/configure.ac cd $(srcdir) && autoconf # Don't export variables to the environment, in order to not confuse --- 171,178 ---- config.status: $(srcdir)/configure $(SHELL) ./config.status --recheck ! $(srcdir)/configure: @MAINT@ $(srcdir)/configure.ac \ ! $(srcdir)/../config/acx.m4 $(srcdir)/../config/override.m4 cd $(srcdir) && autoconf # Don't export variables to the environment, in order to not confuse diff -Nrcpad gcc-4.3.3/libada/configure gcc-4.4.0/libada/configure *** gcc-4.3.3/libada/configure Fri Nov 17 10:31:47 2006 --- gcc-4.4.0/libada/configure Tue Apr 21 09:08:08 2009 *************** PACKAGE_STRING= *** 272,279 **** PACKAGE_BUGREPORT= ac_unique_file="Makefile.in" ! ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS build build_cpu build_vendor build_os host host_cpu host_vendor host_os target target_cpu target_vendor target_os target_noncanonical build_libsubdir build_subdir host_subdir target_subdir MAINT enable_shared LN_S x_ada_cflags default_gnatlib_target LIBOBJS LTLIBOBJS' ac_subst_files='' # Initialize some variables set by options. ac_init_help= --- 272,280 ---- PACKAGE_BUGREPORT= ac_unique_file="Makefile.in" ! ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS build build_cpu build_vendor build_os host host_cpu host_vendor host_os target target_cpu target_vendor target_os target_noncanonical build_libsubdir build_subdir host_subdir target_subdir MAINT multi_basedir toolexecdir toolexeclibdir CC ac_ct_CC EXEEXT OBJEXT CFLAGS enable_shared LN_S default_gnatlib_target LDFLAGS CPPFLAGS warn_cflags LIBOBJS LTLIBOBJS' ac_subst_files='' + ac_pwd=`pwd` # Initialize some variables set by options. ac_init_help= *************** ac_env_target_alias_set=${target_alias+s *** 713,718 **** --- 714,735 ---- ac_env_target_alias_value=$target_alias ac_cv_env_target_alias_set=${target_alias+set} ac_cv_env_target_alias_value=$target_alias + ac_env_CC_set=${CC+set} + ac_env_CC_value=$CC + ac_cv_env_CC_set=${CC+set} + ac_cv_env_CC_value=$CC + ac_env_CFLAGS_set=${CFLAGS+set} + ac_env_CFLAGS_value=$CFLAGS + ac_cv_env_CFLAGS_set=${CFLAGS+set} + ac_cv_env_CFLAGS_value=$CFLAGS + ac_env_LDFLAGS_set=${LDFLAGS+set} + ac_env_LDFLAGS_value=$LDFLAGS + ac_cv_env_LDFLAGS_set=${LDFLAGS+set} + ac_cv_env_LDFLAGS_value=$LDFLAGS + ac_env_CPPFLAGS_set=${CPPFLAGS+set} + ac_env_CPPFLAGS_value=$CPPFLAGS + ac_cv_env_CPPFLAGS_set=${CPPFLAGS+set} + ac_cv_env_CPPFLAGS_value=$CPPFLAGS # # Report the --help message. *************** Optional Features: *** 791,796 **** --- 808,814 ---- --enable-maintainer-mode enable make rules and dependencies not useful (and sometimes confusing) to the casual installer + --enable-multilib build many library versions (default) --disable-shared don't provide a shared libgnat Optional Packages: *************** Optional Packages: *** 798,803 **** --- 816,832 ---- --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-build-libsubdir=DIR Directory where to find libraries for build system + Some influential environment variables: + CC C compiler command + CFLAGS C compiler flags + LDFLAGS linker flags, e.g. -L if you have libraries in a + nonstandard directory + CPPFLAGS C/C++ preprocessor flags, e.g. -I if you have + headers in a nonstandard directory + + Use these variables to override the choices made by `configure' or to help + it to find libraries and programs with nonstandard names/locations. + _ACEOF fi *************** echo "$as_me: error: \`$ac_var' was not *** 1179,1191 **** ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then ! { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ! { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 ! echo "$as_me: former value: $ac_old_val" >&2;} ! { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 ! echo "$as_me: current value: $ac_new_val" >&2;} ! ac_cache_corrupted=: fi;; esac # Pass precious variables to config.status. --- 1208,1229 ---- ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then ! # differences in whitespace do not lead to failure. ! ac_old_val_w=`echo x $ac_old_val` ! ac_new_val_w=`echo x $ac_new_val` ! if test "$ac_old_val_w" != "$ac_new_val_w"; then ! { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ! ac_cache_corrupted=: ! else ! { echo "$as_me:$LINENO: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 ! echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} ! eval $ac_var=\$ac_old_val ! fi ! { echo "$as_me:$LINENO: former value: \`$ac_old_val'" >&5 ! echo "$as_me: former value: \`$ac_old_val'" >&2;} ! { echo "$as_me:$LINENO: current value: \`$ac_new_val'" >&5 ! echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. *************** echo "$as_me: current value: $ac_new_v *** 1202,1207 **** --- 1240,1247 ---- fi done if $ac_cache_corrupted; then + { echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + echo "$as_me: error: in \`$ac_pwd':" >&2;} { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 echo "$as_me: error: changes in the environment can compromise the build" >&2;} { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 *************** ac_compiler_gnu=$ac_cv_c_compiler_gnu *** 1237,1334 **** - # Autoconf M4 include file defining utility macros for complex Canadian - # cross builds. - - - - - - - - - - #### - # _NCN_TOOL_PREFIXES: Some stuff that oughtta be done in AC_CANONICAL_SYSTEM - # or AC_INIT. - # These demand that AC_CANONICAL_SYSTEM be called beforehand. - - #### - # NCN_STRICT_CHECK_TOOLS(variable, progs-to-check-for,[value-if-not-found],[path]) - # Like plain AC_CHECK_TOOLS, but require prefix if build!=host. - - - #### - # NCN_STRICT_CHECK_TARGET_TOOLS(variable, progs-to-check-for,[value-if-not-found],[path]) - # Like CVS Autoconf AC_CHECK_TARGET_TOOLS, but require prefix if build!=target. - - - - # Backported from Autoconf 2.5x; can go away when and if - # we switch. Put the OS path separator in $PATH_SEPARATOR. - - - - - # ACX_HAVE_GCC_FOR_TARGET - # Check if the variable GCC_FOR_TARGET really points to a GCC binary. - - - # ACX_CHECK_INSTALLED_TARGET_TOOL(VAR, PROG) - # Searching for installed target binutils. We need to take extra care, - # else we may find the wrong assembler, linker, etc., and lose. - # - # First try --with-build-time-tools, if specified. - # - # For build != host, we ask the installed GCC for the name of the tool it - # uses, and accept it if it is an absolute path. This is because the - # only good choice for a compiler is the same GCC version that is being - # installed (or we couldn't make target libraries), and we assume that - # on the host system we'll have not only the same GCC version, but also - # the same binutils version. - # - # For build == host, search the same directories that the installed - # compiler will search. We used to do this for the assembler, linker, - # and nm only; for simplicity of configuration, however, we extend this - # criterion to tools (such as ar and ranlib) that are never invoked by - # the compiler, to avoid mismatches. - # - # Also note we have to check MD_EXEC_PREFIX before checking the user's path - # if build == target. This makes the most sense only when bootstrapping, - # but we also do so when build != host. In this case, we hope that the - # build and host systems will have similar contents of MD_EXEC_PREFIX. - # - # If we do not find a suitable binary, then try the user's path. - - - ### - # AC_PROG_CPP_WERROR - # Used for autoconf 2.5x to force AC_PREPROC_IFELSE to reject code which - # triggers warnings from the preprocessor. Will be in autoconf 2.58. - # For now, using this also overrides header checks to use only the - # preprocessor (matches 2.13 behavior; matching 2.58's behavior is a - # bit harder from here). - # Eventually autoconf will default to checking headers with the compiler - # instead, and we'll have to do this differently. - - # AC_PROG_CPP_WERROR - - # Test for GNAT. - # We require the gnatbind program, and a compiler driver that - # understands Ada. We use the user's CC setting, already found. - # - # Sets the shell variable have_gnat to yes or no as appropriate, and - # substitutes GNATBIND. - - - - - - - - - - --- 1277,1282 ---- *************** else *** 1509,1514 **** --- 1457,2480 ---- MAINT='#' fi; + + target_alias=${target_alias-$host_alias} + + # Default to --enable-multilib + # Check whether --enable-multilib or --disable-multilib was given. + if test "${enable_multilib+set}" = set; then + enableval="$enable_multilib" + case "$enableval" in + yes) multilib=yes ;; + no) multilib=no ;; + *) { { echo "$as_me:$LINENO: error: bad value $enableval for multilib option" >&5 + echo "$as_me: error: bad value $enableval for multilib option" >&2;} + { (exit 1); exit 1; }; } ;; + esac + else + multilib=yes + fi; + + # We may get other options which we leave undocumented: + # --with-target-subdir, --with-multisrctop, --with-multisubdir + # See config-ml.in if you want the gory details. + + if test "$srcdir" = "."; then + if test "$with_target_subdir" != "."; then + multi_basedir="$srcdir/$with_multisrctop../.." + else + multi_basedir="$srcdir/$with_multisrctop.." + fi + else + multi_basedir="$srcdir/.." + fi + + + ac_config_commands="$ac_config_commands default-1" + + # Calculate toolexeclibdir + # Also toolexecdir, though it's only used in toolexeclibdir + case ${enable_version_specific_runtime_libs} in + yes) + # Need the gcc compiler version to know where to install libraries + # and header files if --enable-version-specific-runtime-libs option + # is selected. + toolexecdir='$(libdir)/gcc/$(target_alias)' + toolexeclibdir='$(toolexecdir)/$(gcc_version)$(MULTISUBDIR)' + ;; + no) + if test -n "$with_cross_host" && + test x"$with_cross_host" != x"no"; then + # Install a library built with a cross compiler in tooldir, not libdir. + toolexecdir='$(exec_prefix)/$(target_alias)' + toolexeclibdir='$(toolexecdir)/lib' + else + toolexecdir='$(libdir)/gcc-lib/$(target_alias)' + toolexeclibdir='$(libdir)' + fi + multi_os_directory=`$CC -print-multi-os-directory` + case $multi_os_directory in + .) ;; # Avoid trailing /. + *) toolexeclibdir=$toolexeclibdir/$multi_os_directory ;; + esac + ;; + esac + + + #TODO: toolexeclibdir is currently disregarded + + # Check the compiler. + # The same as in boehm-gc and libstdc++. Have to borrow it from there. + # We must force CC to /not/ be precious variables; otherwise + # the wrong, non-multilib-adjusted value will be used in multilibs. + # As a side effect, we have to subst CFLAGS ourselves. + + + + ac_ext=c + ac_cpp='$CPP $CPPFLAGS' + ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' + ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' + ac_compiler_gnu=$ac_cv_c_compiler_gnu + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. + set dummy ${ac_tool_prefix}gcc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + CC=$ac_cv_prog_CC + if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 + echo "${ECHO_T}$CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + fi + if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. + set dummy gcc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="gcc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + ac_ct_CC=$ac_cv_prog_ac_ct_CC + if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 + echo "${ECHO_T}$ac_ct_CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + CC=$ac_ct_CC + else + CC="$ac_cv_prog_CC" + fi + + if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. + set dummy ${ac_tool_prefix}cc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + CC=$ac_cv_prog_CC + if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 + echo "${ECHO_T}$CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + fi + if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "cc", so it can be a program name with args. + set dummy cc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + ac_ct_CC=$ac_cv_prog_ac_ct_CC + if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 + echo "${ECHO_T}$ac_ct_CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + CC=$ac_ct_CC + else + CC="$ac_cv_prog_CC" + fi + + fi + if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. + set dummy cc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. + else + ac_prog_rejected=no + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" + fi + fi + fi + fi + CC=$ac_cv_prog_CC + if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 + echo "${ECHO_T}$CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + fi + if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. + set dummy $ac_tool_prefix$ac_prog; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + CC=$ac_cv_prog_CC + if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 + echo "${ECHO_T}$CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + test -n "$CC" && break + done + fi + if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl + do + # Extract the first word of "$ac_prog", so it can be a program name with args. + set dummy $ac_prog; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="$ac_prog" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + ac_ct_CC=$ac_cv_prog_ac_ct_CC + if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 + echo "${ECHO_T}$ac_ct_CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + test -n "$ac_ct_CC" && break + done + + CC=$ac_ct_CC + fi + + fi + + + test -z "$CC" && { { echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + echo "$as_me: error: in \`$ac_pwd':" >&2;} + { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH + See \`config.log' for more details." >&5 + echo "$as_me: error: no acceptable C compiler found in \$PATH + See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; }; } + + # Provide some information about the compiler. + echo "$as_me:$LINENO:" \ + "checking for C compiler version" >&5 + ac_compiler=`set X $ac_compile; echo $2` + { (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 + (eval $ac_compiler --version &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + { (eval echo "$as_me:$LINENO: \"$ac_compiler -v &5\"") >&5 + (eval $ac_compiler -v &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + { (eval echo "$as_me:$LINENO: \"$ac_compiler -V &5\"") >&5 + (eval $ac_compiler -V &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + int + main () + { + + ; + return 0; + } + _ACEOF + ac_clean_files_save=$ac_clean_files + ac_clean_files="$ac_clean_files a.out a.exe b.out" + # Try to create an executable without -o first, disregard a.out. + # It will help us diagnose broken compilers, and finding out an intuition + # of exeext. + echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 + echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6 + ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` + if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 + (eval $ac_link_default) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + # Find the output, starting from the most likely. This scheme is + # not robust to junk in `.', hence go to wildcards (a.*) only as a last + # resort. + + # Be careful to initialize this variable, since it used to be cached. + # Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile. + ac_cv_exeext= + # b.out is created by i960 compilers. + for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out + do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) + ;; + conftest.$ac_ext ) + # This is the source file. + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + # FIXME: I believe we export ac_cv_exeext for Libtool, + # but it would be cool to find out if it's true. Does anybody + # maintain Libtool? --akim. + export ac_cv_exeext + break;; + * ) + break;; + esac + done + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + { { echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + echo "$as_me: error: in \`$ac_pwd':" >&2;} + { { echo "$as_me:$LINENO: error: C compiler cannot create executables + See \`config.log' for more details." >&5 + echo "$as_me: error: C compiler cannot create executables + See \`config.log' for more details." >&2;} + { (exit 77); exit 77; }; }; } + fi + + ac_exeext=$ac_cv_exeext + echo "$as_me:$LINENO: result: $ac_file" >&5 + echo "${ECHO_T}$ac_file" >&6 + + # Check the compiler produces executables we can run. If not, either + # the compiler is broken, or we cross compile. + echo "$as_me:$LINENO: checking whether the C compiler works" >&5 + echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6 + # FIXME: These cross compiler hacks should be removed for Autoconf 3.0 + # If not cross compiling, check that we can run a simple program. + if test "$cross_compiling" != yes; then + if { ac_try='./$ac_file' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + echo "$as_me: error: in \`$ac_pwd':" >&2;} + { { echo "$as_me:$LINENO: error: cannot run C compiled programs. + If you meant to cross compile, use \`--host'. + See \`config.log' for more details." >&5 + echo "$as_me: error: cannot run C compiled programs. + If you meant to cross compile, use \`--host'. + See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; }; } + fi + fi + fi + echo "$as_me:$LINENO: result: yes" >&5 + echo "${ECHO_T}yes" >&6 + + rm -f a.out a.exe conftest$ac_cv_exeext b.out + ac_clean_files=$ac_clean_files_save + # Check the compiler produces executables we can run. If not, either + # the compiler is broken, or we cross compile. + echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 + echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6 + echo "$as_me:$LINENO: result: $cross_compiling" >&5 + echo "${ECHO_T}$cross_compiling" >&6 + + echo "$as_me:$LINENO: checking for suffix of executables" >&5 + echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6 + if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + # If both `conftest.exe' and `conftest' are `present' (well, observable) + # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will + # work properly (i.e., refer to `conftest.exe'), while it won't with + # `rm'. + for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + export ac_cv_exeext + break;; + * ) break;; + esac + done + else + { { echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + echo "$as_me: error: in \`$ac_pwd':" >&2;} + { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link + See \`config.log' for more details." >&5 + echo "$as_me: error: cannot compute suffix of executables: cannot compile and link + See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; }; } + fi + + rm -f conftest$ac_cv_exeext + echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 + echo "${ECHO_T}$ac_cv_exeext" >&6 + + rm -f conftest.$ac_ext + EXEEXT=$ac_cv_exeext + ac_exeext=$EXEEXT + echo "$as_me:$LINENO: checking for suffix of object files" >&5 + echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 + if test "${ac_cv_objext+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + int + main () + { + + ; + return 0; + } + _ACEOF + rm -f conftest.o conftest.obj + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + for ac_file in `(ls conftest.o conftest.obj; ls conftest.*) 2>/dev/null`; do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac + done + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + { { echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + echo "$as_me: error: in \`$ac_pwd':" >&2;} + { { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile + See \`config.log' for more details." >&5 + echo "$as_me: error: cannot compute suffix of object files: cannot compile + See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; }; } + fi + + rm -f conftest.$ac_cv_objext conftest.$ac_ext + fi + echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 + echo "${ECHO_T}$ac_cv_objext" >&6 + OBJEXT=$ac_cv_objext + ac_objext=$OBJEXT + echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 + echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 + if test "${ac_cv_c_compiler_gnu+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + int + main () + { + #ifndef __GNUC__ + choke me + #endif + + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_compiler_gnu=yes + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + ac_compiler_gnu=no + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + ac_cv_c_compiler_gnu=$ac_compiler_gnu + + fi + echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 + echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 + GCC=`test $ac_compiler_gnu = yes && echo yes` + ac_test_CFLAGS=${CFLAGS+set} + ac_save_CFLAGS=$CFLAGS + CFLAGS="-g" + echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 + echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 + if test "${ac_cv_prog_cc_g+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + int + main () + { + + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_g=yes + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_prog_cc_g=no + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + fi + echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 + echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 + if test "$ac_test_CFLAGS" = set; then + CFLAGS=$ac_save_CFLAGS + elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi + else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi + fi + echo "$as_me:$LINENO: checking for $CC option to accept ANSI C" >&5 + echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 + if test "${ac_cv_prog_cc_stdc+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + ac_cv_prog_cc_stdc=no + ac_save_CC=$CC + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + #include + #include + #include + #include + /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ + struct buf { int x; }; + FILE * (*rcsopen) (struct buf *, struct stat *, int); + static char *e (p, i) + char **p; + int i; + { + return p[i]; + } + static char *f (char * (*g) (char **, int), char **p, ...) + { + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; + } + + /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std1 is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std1. */ + int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + + int test (int i, double x); + struct s1 {int (*f) (int a);}; + struct s2 {int (*f) (double a);}; + int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); + int argc; + char **argv; + int + main () + { + return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; + ; + return 0; + } + _ACEOF + # Don't try gcc -ansi; that turns off useful extensions and + # breaks some systems' header files. + # AIX -qlanglvl=ansi + # Ultrix and OSF/1 -std1 + # HP-UX 10.20 and later -Ae + # HP-UX older versions -Aa -D_HPUX_SOURCE + # SVR4 -Xc -D__EXTENSIONS__ + for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" + do + CC="$ac_save_CC $ac_arg" + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_stdc=$ac_arg + break + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + fi + rm -f conftest.err conftest.$ac_objext + done + rm -f conftest.$ac_ext conftest.$ac_objext + CC=$ac_save_CC + + fi + + case "x$ac_cv_prog_cc_stdc" in + x|xno) + echo "$as_me:$LINENO: result: none needed" >&5 + echo "${ECHO_T}none needed" >&6 ;; + *) + echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5 + echo "${ECHO_T}$ac_cv_prog_cc_stdc" >&6 + CC="$CC $ac_cv_prog_cc_stdc" ;; + esac + + # Some people use a C++ compiler to compile C. Since we use `exit', + # in C++ we need to declare it. In case someone uses the same compiler + # for both compiling C and C++ we need to have the C++ compiler decide + # the declaration of exit, since it's the most demanding environment. + cat >conftest.$ac_ext <<_ACEOF + #ifndef __cplusplus + choke me + #endif + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + for ac_declaration in \ + '' \ + 'extern "C" void std::exit (int) throw (); using std::exit;' \ + 'extern "C" void std::exit (int); using std::exit;' \ + 'extern "C" void exit (int) throw ();' \ + 'extern "C" void exit (int);' \ + 'void exit (int);' + do + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + $ac_declaration + #include + int + main () + { + exit (42); + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + : + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + continue + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + $ac_declaration + int + main () + { + exit (42); + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + break + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + done + rm -f conftest* + if test -n "$ac_declaration"; then + echo '#ifdef __cplusplus' >>confdefs.h + echo $ac_declaration >>confdefs.h + echo '#endif' >>confdefs.h + fi + + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + ac_ext=c + ac_cpp='$CPP $CPPFLAGS' + ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' + ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' + ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + + + # Check whether --enable-shared or --disable-shared was given. if test "${enable_shared+set}" = set; then enableval="$enable_shared" *************** echo "${ECHO_T}no, using $LN_S" >&6 *** 1546,1558 **** fi - # Determine x_ada_cflags - case $host in - hppa*) x_ada_cflags=-mdisable-indexing ;; - *) x_ada_cflags= ;; - esac - - # Determine what to build for 'gnatlib' if test $build = $target \ && test ${enable_shared} = yes ; then --- 2512,2517 ---- *************** else *** 1563,1568 **** --- 2522,3264 ---- fi + ac_ext=c + ac_cpp='$CPP $CPPFLAGS' + ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' + ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' + ac_compiler_gnu=$ac_cv_c_compiler_gnu + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. + set dummy ${ac_tool_prefix}gcc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + CC=$ac_cv_prog_CC + if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 + echo "${ECHO_T}$CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + fi + if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. + set dummy gcc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="gcc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + ac_ct_CC=$ac_cv_prog_ac_ct_CC + if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 + echo "${ECHO_T}$ac_ct_CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + CC=$ac_ct_CC + else + CC="$ac_cv_prog_CC" + fi + + if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. + set dummy ${ac_tool_prefix}cc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + CC=$ac_cv_prog_CC + if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 + echo "${ECHO_T}$CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + fi + if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "cc", so it can be a program name with args. + set dummy cc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + ac_ct_CC=$ac_cv_prog_ac_ct_CC + if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 + echo "${ECHO_T}$ac_ct_CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + CC=$ac_ct_CC + else + CC="$ac_cv_prog_CC" + fi + + fi + if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. + set dummy cc; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. + else + ac_prog_rejected=no + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" + fi + fi + fi + fi + CC=$ac_cv_prog_CC + if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 + echo "${ECHO_T}$CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + fi + if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. + set dummy $ac_tool_prefix$ac_prog; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + CC=$ac_cv_prog_CC + if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 + echo "${ECHO_T}$CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + test -n "$CC" && break + done + fi + if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl + do + # Extract the first word of "$ac_prog", so it can be a program name with args. + set dummy $ac_prog; ac_word=$2 + echo "$as_me:$LINENO: checking for $ac_word" >&5 + echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 + if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR + for as_dir in $PATH + do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="$ac_prog" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi + done + done + + fi + fi + ac_ct_CC=$ac_cv_prog_ac_ct_CC + if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 + echo "${ECHO_T}$ac_ct_CC" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6 + fi + + test -n "$ac_ct_CC" && break + done + + CC=$ac_ct_CC + fi + + fi + + + test -z "$CC" && { { echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + echo "$as_me: error: in \`$ac_pwd':" >&2;} + { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH + See \`config.log' for more details." >&5 + echo "$as_me: error: no acceptable C compiler found in \$PATH + See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; }; } + + # Provide some information about the compiler. + echo "$as_me:$LINENO:" \ + "checking for C compiler version" >&5 + ac_compiler=`set X $ac_compile; echo $2` + { (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 + (eval $ac_compiler --version &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + { (eval echo "$as_me:$LINENO: \"$ac_compiler -v &5\"") >&5 + (eval $ac_compiler -v &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + { (eval echo "$as_me:$LINENO: \"$ac_compiler -V &5\"") >&5 + (eval $ac_compiler -V &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + + echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 + echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 + if test "${ac_cv_c_compiler_gnu+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + int + main () + { + #ifndef __GNUC__ + choke me + #endif + + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_compiler_gnu=yes + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + ac_compiler_gnu=no + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + ac_cv_c_compiler_gnu=$ac_compiler_gnu + + fi + echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 + echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 + GCC=`test $ac_compiler_gnu = yes && echo yes` + ac_test_CFLAGS=${CFLAGS+set} + ac_save_CFLAGS=$CFLAGS + CFLAGS="-g" + echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 + echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 + if test "${ac_cv_prog_cc_g+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + int + main () + { + + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_g=yes + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_prog_cc_g=no + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + fi + echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 + echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 + if test "$ac_test_CFLAGS" = set; then + CFLAGS=$ac_save_CFLAGS + elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi + else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi + fi + echo "$as_me:$LINENO: checking for $CC option to accept ANSI C" >&5 + echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 + if test "${ac_cv_prog_cc_stdc+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + ac_cv_prog_cc_stdc=no + ac_save_CC=$CC + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + #include + #include + #include + #include + /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ + struct buf { int x; }; + FILE * (*rcsopen) (struct buf *, struct stat *, int); + static char *e (p, i) + char **p; + int i; + { + return p[i]; + } + static char *f (char * (*g) (char **, int), char **p, ...) + { + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; + } + + /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std1 is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std1. */ + int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + + int test (int i, double x); + struct s1 {int (*f) (int a);}; + struct s2 {int (*f) (double a);}; + int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); + int argc; + char **argv; + int + main () + { + return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; + ; + return 0; + } + _ACEOF + # Don't try gcc -ansi; that turns off useful extensions and + # breaks some systems' header files. + # AIX -qlanglvl=ansi + # Ultrix and OSF/1 -std1 + # HP-UX 10.20 and later -Ae + # HP-UX older versions -Aa -D_HPUX_SOURCE + # SVR4 -Xc -D__EXTENSIONS__ + for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" + do + CC="$ac_save_CC $ac_arg" + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_stdc=$ac_arg + break + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + fi + rm -f conftest.err conftest.$ac_objext + done + rm -f conftest.$ac_ext conftest.$ac_objext + CC=$ac_save_CC + + fi + + case "x$ac_cv_prog_cc_stdc" in + x|xno) + echo "$as_me:$LINENO: result: none needed" >&5 + echo "${ECHO_T}none needed" >&6 ;; + *) + echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5 + echo "${ECHO_T}$ac_cv_prog_cc_stdc" >&6 + CC="$CC $ac_cv_prog_cc_stdc" ;; + esac + + # Some people use a C++ compiler to compile C. Since we use `exit', + # in C++ we need to declare it. In case someone uses the same compiler + # for both compiling C and C++ we need to have the C++ compiler decide + # the declaration of exit, since it's the most demanding environment. + cat >conftest.$ac_ext <<_ACEOF + #ifndef __cplusplus + choke me + #endif + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + for ac_declaration in \ + '' \ + 'extern "C" void std::exit (int) throw (); using std::exit;' \ + 'extern "C" void std::exit (int); using std::exit;' \ + 'extern "C" void exit (int) throw ();' \ + 'extern "C" void exit (int);' \ + 'void exit (int);' + do + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + $ac_declaration + #include + int + main () + { + exit (42); + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + : + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + continue + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + $ac_declaration + int + main () + { + exit (42); + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + break + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + done + rm -f conftest* + if test -n "$ac_declaration"; then + echo '#ifdef __cplusplus' >>confdefs.h + echo $ac_declaration >>confdefs.h + echo '#endif' >>confdefs.h + fi + + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + fi + rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + ac_ext=c + ac_cpp='$CPP $CPPFLAGS' + ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' + ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' + ac_compiler_gnu=$ac_cv_c_compiler_gnu + + warn_cflags= + if test "x$GCC" = "xyes"; then + warn_cflags='$(GCC_WARN_CFLAGS)' + fi + + # Output: create a Makefile. ac_config_files="$ac_config_files Makefile" *************** Usage: $0 [OPTIONS] [FILE]... *** 2010,2015 **** --- 3706,3714 ---- Configuration files: $config_files + Configuration commands: + $config_commands + Report bugs to ." _ACEOF *************** fi *** 2108,2114 **** --- 3807,3830 ---- _ACEOF + cat >>$CONFIG_STATUS <<_ACEOF + # + # INIT-COMMANDS section. + # + + + srcdir="$srcdir" + host="$host" + target="$target" + with_multisubdir="$with_multisubdir" + with_multisrctop="$with_multisrctop" + with_target_subdir="$with_target_subdir" + ac_configure_args="${multilib_arg} ${ac_configure_args}" + multi_basedir="$multi_basedir" + CONFIG_SHELL=${CONFIG_SHELL-/bin/sh} + CC="$CC" + _ACEOF *************** do *** 2118,2123 **** --- 3834,3840 ---- case "$ac_config_target" in # Handling of arguments. "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;; + "default-1" ) CONFIG_COMMANDS="$CONFIG_COMMANDS default-1" ;; *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 echo "$as_me: error: invalid argument: $ac_config_target" >&2;} { (exit 1); exit 1; }; };; *************** done *** 2130,2135 **** --- 3847,3853 ---- # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files + test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands fi # Have a temporary directory for convenience. Make it in the build tree *************** s,@build_subdir@,$build_subdir,;t t *** 2219,2228 **** s,@host_subdir@,$host_subdir,;t t s,@target_subdir@,$target_subdir,;t t s,@MAINT@,$MAINT,;t t s,@enable_shared@,$enable_shared,;t t s,@LN_S@,$LN_S,;t t - s,@x_ada_cflags@,$x_ada_cflags,;t t s,@default_gnatlib_target@,$default_gnatlib_target,;t t s,@LIBOBJS@,$LIBOBJS,;t t s,@LTLIBOBJS@,$LTLIBOBJS,;t t CEOF --- 3937,3956 ---- s,@host_subdir@,$host_subdir,;t t s,@target_subdir@,$target_subdir,;t t s,@MAINT@,$MAINT,;t t + s,@multi_basedir@,$multi_basedir,;t t + s,@toolexecdir@,$toolexecdir,;t t + s,@toolexeclibdir@,$toolexeclibdir,;t t + s,@CC@,$CC,;t t + s,@ac_ct_CC@,$ac_ct_CC,;t t + s,@EXEEXT@,$EXEEXT,;t t + s,@OBJEXT@,$OBJEXT,;t t + s,@CFLAGS@,$CFLAGS,;t t s,@enable_shared@,$enable_shared,;t t s,@LN_S@,$LN_S,;t t s,@default_gnatlib_target@,$default_gnatlib_target,;t t + s,@LDFLAGS@,$LDFLAGS,;t t + s,@CPPFLAGS@,$CPPFLAGS,;t t + s,@warn_cflags@,$warn_cflags,;t t s,@LIBOBJS@,$LIBOBJS,;t t s,@LTLIBOBJS@,$LTLIBOBJS,;t t CEOF *************** s,@abs_top_builddir@,$ac_abs_top_builddi *** 2458,2463 **** --- 4186,4316 ---- done _ACEOF + cat >>$CONFIG_STATUS <<\_ACEOF + + # + # CONFIG_COMMANDS section. + # + for ac_file in : $CONFIG_COMMANDS; do test "x$ac_file" = x: && continue + ac_dest=`echo "$ac_file" | sed 's,:.*,,'` + ac_source=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_dir=`(dirname "$ac_dest") 2>/dev/null || + $as_expr X"$ac_dest" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_dest" : 'X\(//\)[^/]' \| \ + X"$ac_dest" : 'X\(//\)$' \| \ + X"$ac_dest" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || + echo X"$ac_dest" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + { if $as_mkdir_p; then + mkdir -p "$ac_dir" + else + as_dir="$ac_dir" + as_dirs= + while test ! -d "$as_dir"; do + as_dirs="$as_dir $as_dirs" + as_dir=`(dirname "$as_dir") 2>/dev/null || + $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || + echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + done + test ! -n "$as_dirs" || mkdir $as_dirs + fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 + echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} + { (exit 1); exit 1; }; }; } + + ac_builddir=. + + if test "$ac_dir" != .; then + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A "../" for each directory in $ac_dir_suffix. + ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` + else + ac_dir_suffix= ac_top_builddir= + fi + + case $srcdir in + .) # No --srcdir option. We are building in place. + ac_srcdir=. + if test -z "$ac_top_builddir"; then + ac_top_srcdir=. + else + ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` + fi ;; + [\\/]* | ?:[\\/]* ) # Absolute path. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir ;; + *) # Relative path. + ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_builddir$srcdir ;; + esac + + # Do not use `cd foo && pwd` to compute absolute paths, because + # the directories may not exist. + case `pwd` in + .) ac_abs_builddir="$ac_dir";; + *) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; + esac + case $ac_abs_builddir in + .) ac_abs_top_builddir=${ac_top_builddir}.;; + *) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; + esac + case $ac_abs_builddir in + .) ac_abs_srcdir=$ac_srcdir;; + *) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; + esac + case $ac_abs_builddir in + .) ac_abs_top_srcdir=$ac_top_srcdir;; + *) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; + esac + + + { echo "$as_me:$LINENO: executing $ac_dest commands" >&5 + echo "$as_me: executing $ac_dest commands" >&6;} + case $ac_dest in + default-1 ) + # Only add multilib support code if we just rebuilt the top-level + # Makefile. + case " $CONFIG_FILES " in + *" Makefile "*) + ac_file=Makefile . ${multi_basedir}/config-ml.in + ;; + esac ;; + esac + done + _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF diff -Nrcpad gcc-4.3.3/libada/configure.ac gcc-4.4.0/libada/configure.ac *** gcc-4.3.3/libada/configure.ac Fri Nov 17 10:31:47 2006 --- gcc-4.4.0/libada/configure.ac Thu Apr 9 23:23:07 2009 *************** *** 1,9 **** # Configure script for libada. ! # Copyright 2003, 2004 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but --- 1,9 ---- # Configure script for libada. ! # Copyright 2003, 2004, 2009 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but *************** *** 12,27 **** # General Public License for more details. # # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. AC_INIT AC_PREREQ([2.59]) AC_CONFIG_SRCDIR([Makefile.in]) - sinclude(../config/acx.m4) - # Determine the host, build, and target systems AC_CANONICAL_BUILD AC_CANONICAL_HOST --- 12,28 ---- # General Public License for more details. # # You should have received a copy of the GNU General Public License ! # along with this program; see the file COPYING3. If not see ! # . ! ! sinclude(../config/acx.m4) ! sinclude(../config/override.m4) AC_INIT AC_PREREQ([2.59]) AC_CONFIG_SRCDIR([Makefile.in]) # Determine the host, build, and target systems AC_CANONICAL_BUILD AC_CANONICAL_HOST *************** AC_ARG_ENABLE([maintainer-mode], *** 48,53 **** --- 49,102 ---- [MAINT='#']) AC_SUBST([MAINT])dnl + AC_CANONICAL_SYSTEM + target_alias=${target_alias-$host_alias} + + AM_ENABLE_MULTILIB(, ..) + # Calculate toolexeclibdir + # Also toolexecdir, though it's only used in toolexeclibdir + case ${enable_version_specific_runtime_libs} in + yes) + # Need the gcc compiler version to know where to install libraries + # and header files if --enable-version-specific-runtime-libs option + # is selected. + toolexecdir='$(libdir)/gcc/$(target_alias)' + toolexeclibdir='$(toolexecdir)/$(gcc_version)$(MULTISUBDIR)' + ;; + no) + if test -n "$with_cross_host" && + test x"$with_cross_host" != x"no"; then + # Install a library built with a cross compiler in tooldir, not libdir. + toolexecdir='$(exec_prefix)/$(target_alias)' + toolexeclibdir='$(toolexecdir)/lib' + else + toolexecdir='$(libdir)/gcc-lib/$(target_alias)' + toolexeclibdir='$(libdir)' + fi + multi_os_directory=`$CC -print-multi-os-directory` + case $multi_os_directory in + .) ;; # Avoid trailing /. + *) toolexeclibdir=$toolexeclibdir/$multi_os_directory ;; + esac + ;; + esac + AC_SUBST(toolexecdir) + AC_SUBST(toolexeclibdir) + #TODO: toolexeclibdir is currently disregarded + + # Check the compiler. + # The same as in boehm-gc and libstdc++. Have to borrow it from there. + # We must force CC to /not/ be precious variables; otherwise + # the wrong, non-multilib-adjusted value will be used in multilibs. + # As a side effect, we have to subst CFLAGS ourselves. + + m4_rename([_AC_ARG_VAR_PRECIOUS],[real_PRECIOUS]) + m4_define([_AC_ARG_VAR_PRECIOUS],[]) + AC_PROG_CC + m4_rename([real_PRECIOUS],[_AC_ARG_VAR_PRECIOUS]) + + AC_SUBST(CFLAGS) + AC_ARG_ENABLE([shared], [AC_HELP_STRING([--disable-shared], [don't provide a shared libgnat])], *************** AC_SUBST([enable_shared]) *** 72,84 **** # Need to pass this down for now :-P AC_PROG_LN_S - # Determine x_ada_cflags - case $host in - hppa*) x_ada_cflags=-mdisable-indexing ;; - *) x_ada_cflags= ;; - esac - AC_SUBST([x_ada_cflags]) - # Determine what to build for 'gnatlib' if test $build = $target \ && test ${enable_shared} = yes ; then --- 121,126 ---- *************** else *** 89,94 **** --- 131,143 ---- fi AC_SUBST([default_gnatlib_target]) + AC_PROG_CC + warn_cflags= + if test "x$GCC" = "xyes"; then + warn_cflags='$(GCC_WARN_CFLAGS)' + fi + AC_SUBST(warn_cflags) + # Output: create a Makefile. AC_CONFIG_FILES([Makefile])